managementnode/bin/vcld

#!/usr/bin/perl -w
###############################################################################
# $Id$
###############################################################################
# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
###############################################################################

=head1 NAME

VCL::vcld - VCL daemon module

=head1 SYNOPSIS

 perl vcld

=head1 DESCRIPTION

 This is the executable module for running the VCL management node daemon.

=cut

##############################################################################
package VCL::vcld;

# Specify the lib path using FindBin
use FindBin;
use lib "$FindBin::Bin/../lib";

# Configure inheritance
use base qw();

# Specify the version of this module
our $VERSION = '2.5.1';

# Specify the version of Perl to use
use 5.008000;

use strict;
use warnings;
#use diagnostics;

use Symbol;
use POSIX;
use Getopt::Long;
use English qw( -no_match_vars );
use Fcntl qw(:DEFAULT :flock);
use List::Util qw(min);

use VCL::utils;
use VCL::DataStructure;

##############################################################################
# Turn on autoflush
$| = 1;

# Retrieve the management node configuration info from the database
get_management_node_info();

# Check if -setup argument was specified
if ($SETUP_MODE) {
	&setup_management_node();
};

# Call daemonize if -d (debug) wasn't specified
if ($DAEMON_MODE) {
	&daemonize;
}

# Rename this process
rename_vcld_process();

# Variables to store child process information
our %child_pids = ();    # keys are current child process IDs
our $child_count = 0;     # current number of children

# Install signal handlers
$SIG{CHLD} = \&REAPER;
$SIG{INT}  = \&HUNTSMAN;
$SIG{QUIT} = \&HUNTSMAN;
$SIG{HUP}  = \&HUNTSMAN;
$SIG{TERM} = \&HUNTSMAN;
$SIG{__WARN__} = \&warning_handler;
$SIG{__DIE__} = \&die_handler;

# Call main subroutine
&main();


#/////////////////////////////////////////////////////////////////////////////

=head2 main

 Parameters  : 
 Returns     : 
 Description : Main VCL daemon engine subroutine. Queries database for request
               and passes off data to make_new_child() to begin processing.

=cut

sub main () {
	# Create a hash to store all of the program state information
	my %info;

	# Get the management node info from the database
	# get_management_node_info() will determine the hostname
	if ($info{managementnode} = get_management_node_info()) {
		notify($ERRORS{'DEBUG'}, $LOGFILE, "retrieved management node information from database");
	}
	else {
		notify($ERRORS{'CRITICAL'}, $LOGFILE, "unable to retrieve management node information from database");
		exit;
	}
	
	# Define local variables from the management node hash for code simplicity
	my $management_node_id       = $info{managementnode}{id};
	my $management_node_hostname = $info{managementnode}{hostname};

	# Set environment variables for global management node information
	$ENV{management_node_id} = $management_node_id;
	notify($ERRORS{'DEBUG'}, $LOGFILE, "management_node_id environment variable set: $management_node_id");
	
	# Get the management node checkin interval from the database if defined
	# Otherwise, the default is 12 seconds
	my $management_node_checkin_interval = 12;
	if (defined $info{managementnode}{checkininterval}) {
		$management_node_checkin_interval = $info{managementnode}{checkininterval};
	}
	notify($ERRORS{'DEBUG'}, $LOGFILE, "management node checkin interval is $management_node_checkin_interval seconds");
	notify($ERRORS{'OK'}, $LOGFILE, "vcld started on $management_node_hostname");
	
	#===========================================================================
	while (1) {
		delete $ENV{request_id};
		delete $ENV{reservation_id};
		delete $ENV{state};
		delete $ENV{data};
		
		# Web site inserts into variable table whenever an admin or user message is modified
		# Check if the variable exists, if so, validate all of the messages
		check_messages_need_validating();
		
		my $data_age_seconds = (time - $ENV{management_node_info}{$management_node_id}{RETRIEVAL_TIME});
		if ($data_age_seconds > 120 ) {
			notify($ERRORS{'DEBUG'}, $LOGFILE, "retrieving management node info for '$management_node_id', cached data is stale: $data_age_seconds seconds old");
			$info{managementnode} = get_management_node_info();
			if (defined $info{managementnode}{checkininterval}) {
				$management_node_checkin_interval = $info{managementnode}{checkininterval};
			}
			#notify($ERRORS{'DEBUG'}, $LOGFILE, "dump: " . format_data($ENV{management_node_info}{$management_node_id}));
		}
		
		# Set the vcld environment variable to 0 so other subroutines know if this is the vcld or child process
		if (!defined($ENV{vcld})) {
			$ENV{vcld} = 1;
			notify($ERRORS{'DEBUG'}, $LOGFILE, "vcld environment variable set to $ENV{vcld} for this process");
		}
		else {
			#notify($ERRORS{'DEBUG'}, $LOGFILE, "sleeping for $management_node_checkin_interval seconds");
			sleep_uninterrupted($management_node_checkin_interval);
		}
		
		#===========================================================================
		# Update lastcheckin for this management node
		my $lastcheckin_timestamp = update_lastcheckin($management_node_id);
		if ($lastcheckin_timestamp) {
			notify($ERRORS{'DEBUG'}, $LOGFILE, "lastcheckin time updated for management node $management_node_id: $lastcheckin_timestamp");
			# Update the local hash info to reflect the new timestamp
			$info{managementnode}{lastcheckin} = $lastcheckin_timestamp;
		}
		else {
			notify($ERRORS{'CRITICAL'}, $LOGFILE, "could not update lastcheckin for management node $management_node_id");
		}
		
		# Get all the requests assigned to this management node
		# get_management_node_requests() gets a subset of the information available
		$info{request} = get_management_node_requests($management_node_id);
		if (defined($info{request})) {
			#notify($ERRORS{'DEBUG'}, $LOGFILE, "retrieved request information for management node $management_node_id");
		}
		else {
			notify($ERRORS{'CRITICAL'}, $LOGFILE, "could not retrieve request information for management node $management_node_id");
		}
		
		# See if there's anything to do
		my $request_count = scalar keys %{$info{request}};
		#notify($ERRORS{'DEBUG'}, $LOGFILE, "number of requests assigned to management node $management_node_id: $request_count");
		
		#===========================================================================
		# Loop through the requests assigned to this management node
		REQUEST: foreach my $request_id (keys %{$info{request}}) {
			#notify($ERRORS{'DEBUG'}, $LOGFILE, "management node $management_node_id has been assigned request id: $request_id");
			
			# Store some request data into a local variables
			my $request_state_name     = $info{request}{$request_id}{state}{name};
			my $request_laststate_name = $info{request}{$request_id}{laststate}{name};
			my $request_start          = $info{request}{$request_id}{start};
			my $request_end            = $info{request}{$request_id}{end};
			my $request_preload        = $info{request}{$request_id}{preload};
			my $changelog_timestamp    = $info{request}{$request_id}{log}{changelog}{timestamp};

			
			my @reservation_ids = sort { $a <=> $b } keys %{$info{request}{$request_id}{reservation}};
			my $reservation_count = @reservation_ids;
			
			$ENV{request_id} = $request_id;
			$ENV{reservation_id} = 0;
			$ENV{state} = $request_state_name;
			
			# Make sure the request state is valid
			if ($request_state_name !~ /inuse|reserved|deleted|timeout|reclaim|reload|new|tomaintenance|image|imageprep|makeproduction|imageinuse|complete|failed|pending|maintenance|tovmhostinuse|rebootsoft|reboothard|reinstall|servermodified|checkpoint|test/) {
				notify($ERRORS{'WARNING'}, $LOGFILE, "assigned request in unsupported state: $request_state_name");
				next REQUEST;
			}
			
			# Don't process requests that are already pending
			if ($request_state_name =~ /^(pending|maintenance)/) {
				next REQUEST;
			}
			
			my $request_info;
			
			#===========================================================================
			# Loop through the reservations associated with this request
			RESERVATION: foreach my $reservation_id (@reservation_ids) {
				$ENV{reservation_id} = $reservation_id;
				$ENV{database_select_count} = 0;
				$ENV{database_execute_count} = 0;
				$ENV{database_select_calls} = {};
				
				my $reservation_info = $info{request}{$request_id}{reservation}{$reservation_id};
				my $reservation_management_node_id = $reservation_info->{managementnodeid};
				my $reservation_lastcheck = $reservation_info->{lastcheck};
				my $server_request_id = 0;
				$server_request_id = $reservation_info->{serverrequestid} if(defined($reservation_info->{serverrequestid}));

				#notify($ERRORS{'DEBUG'}, $LOGFILE, "dump: " . format_data($info{request}{$request_id}));
				
				if ($management_node_id != $reservation_management_node_id) {
					notify($ERRORS{'DEBUG'}, $LOGFILE, "ignoring reservation $reservation_id assigned to management node ID $reservation_management_node_id");
					next RESERVATION;
				}
				
				# Figure out the status of this reservation based on reservation times and the request state
				# check_time_result can be: start, preload, end, poll, old, remove, 0
				my $check_time_result = check_time($request_start, $request_end, $reservation_lastcheck, $request_state_name, $request_laststate_name, $server_request_id, $reservation_count, $changelog_timestamp);
				
				# Do nothing if check_time returned 0
				# Check this before querying for the large set of request data
				if (!$check_time_result) {
					next RESERVATION;
				}
				elsif ($check_time_result eq "remove") {
					# Remove the request and associated reservations from database
					# This also removes rows from computerloadlog table for associated reservations
					if (delete_request($request_id)) {
						notify($ERRORS{'OK'}, $LOGFILE, "request deleted");
					}
					else {
						notify($ERRORS{'WARNING'}, $LOGFILE, "unable to delete rows from request, reservation, and computerloadlog tables for request");
					}
					
					# Remove the request key from the hash
					delete $info{request}{$request_id};
					next REQUEST;
				}
				elsif ($check_time_result eq "preload" && $request_preload) {
					# Preload flag has already been set, don't process preload request again
					notify($ERRORS{'DEBUG'}, $LOGFILE, "preload request has already been processed");
					next RESERVATION;
				}
				
				# Make sure reservation is not currently being processed
				my $being_processed = reservation_being_processed($reservation_id);
				if ($being_processed) {
					# It's OK for if a process is already running for some user-initated state changes
					if ($request_state_name =~ /^(deleted|makeproduction|image|reinstall|rebootsoft|reboothard|servermodified|checkpoint)$/) {
						notify($ERRORS{'DEBUG'}, $LOGFILE, "$request_state_name processing delayed, reservation $reservation_id is currently being processed");
						next RESERVATION;
					}
					else {
						notify($ERRORS{'DEBUG'}, $LOGFILE, "reservation $reservation_id is already being processed");
						next RESERVATION;
					}
				}
				else {
					notify($ERRORS{'DEBUG'}, $LOGFILE, "reservation $reservation_id is NOT already being processed");
				}
				
				# Get the full set of database data for this request
				if (!$request_info) {
					if ($request_info = get_request_info($request_id)) {
						notify($ERRORS{'DEBUG'}, $LOGFILE, "retrieved request information from database");
						
						# Set request variables that may have changed by other processes to their original values
						# They may change if this is a cluster reservation
						$request_info->{state}{name}     = $request_state_name;
						$request_info->{laststate}{name} = $request_laststate_name;
						$request_info->{preload}         = $request_preload;
						
						# Add the check_time result to the hash
						$request_info->{CHECKTIME} = $check_time_result;
						
						# Check if preload was returned by check_time and that preload flag is 0
						# The preload flag will be set to 1 by new.pm module after it's done
						if ($check_time_result =~ /preload/ && !($request_info->{preload})) {
							notify($ERRORS{'OK'}, $LOGFILE, "request start time within 25-35 minute window and preload flag is 0, processing preload request");
							$request_info->{PRELOADONLY} = 1;
						}
					}
					else {
						notify($ERRORS{'WARNING'}, $LOGFILE, "could not retrieve request information from database");
						next REQUEST;
					}
				}
				
				# Add the reservation ID to be processed to the hash
				$request_info->{RESERVATIONID} = $reservation_id;
				
				# Get a new data structure object
				my $data_structure;
				eval {$data_structure = new VCL::DataStructure({request_data => $request_info, reservation_id => $reservation_id});};
				if (my $error = Exception::Class::Base->caught()) {
					notify($ERRORS{'CRITICAL'}, 0, "unable to create DataStructure object" . $error->message);
					next RESERVATION;
				}
				
				# Add the DataStructure reference to %ENV so it can be accessed from non-object methods
				$ENV{data} = $data_structure;
				
				# Remove any existing 'exited' computerloadlog entries
				delete_computerloadlog_reservation($reservation_id, 'exited');
				
				# Insert a computerloadlog 'begin' entry to indicate processing has begun for this reservation
				# This should prevent multiple processes from being forked for a given reservation
				# Do this before forking the new process because a cluster child will wait for the parent in State.pm::initialize
				my $computer_id = $data_structure->get_computer_id();
				insertloadlog($reservation_id, $computer_id, "begin", "beginning to process, state is $request_state_name");

				# Make a new child process, passing it the request/reservation info
				make_new_child({request_info => $request_info, data_structure => $data_structure});
			} ## end foreach my $reservation_id (keys %{$info{request...
		} ## end foreach my $request_id (keys %{$info{request}})

		delete $ENV{request_id};
		delete $ENV{reservation_id};
		delete $ENV{state};
		delete $ENV{data};
		
		#===========================================================================
		# Get all the block requests assigned to this management node
		my $blockrequest_data = get_management_node_blockrequests($management_node_id);
		if (!defined $blockrequest_data) {
			notify($ERRORS{'CRITICAL'}, $LOGFILE, "could not retrieve block request information for management node $management_node_id");
			next;
		}
		elsif (!$blockrequest_data) {
			#notify($ERRORS{'OK'}, 0, "there are 0 block requests assigned to management node $management_node_id");
			next;
		}
		
		#notify($ERRORS{'CRITICAL'}, $LOGFILE, "\$blockrequest_data", $blockrequest_data);
		#next;
		
		# Loop through the block requests assigned to this management node
		BLOCKREQUEST: foreach my $blockrequest_id (keys %{$blockrequest_data}) {
			#notify($ERRORS{'DEBUG'}, $LOGFILE, "checking block request id=$blockrequest_id");
			
			BLOCKTIME: foreach my $blocktime_id (keys %{$blockrequest_data->{$blockrequest_id}{blockTimes}}) {
				#notify($ERRORS{'DEBUG'}, $LOGFILE, "checking block time id=$blocktime_id");
				
				# Get a new data structure object
				my $data_structure;
				eval {$data_structure = new VCL::DataStructure({blockrequest_data => $blockrequest_data, blockrequest_id => $blockrequest_id, blocktime_id => $blocktime_id});};
				if (my $e = Exception::Class::Base->caught()) {
					notify($ERRORS{'CRITICAL'}, 0, "unable to create DataStructure object" . $e->message);
					next;
				}
				
				# Store some block request data into a local variables
				my $blockrequest_name       = $data_structure->get_blockrequest_name();
				my $blockrequest_expire     = $data_structure->get_blockrequest_expire();
				my $blockrequest_processing = $data_structure->get_blockrequest_processing();
				my $blocktime_start         = $data_structure->get_blocktime_start();
				my $blocktime_end           = $data_structure->get_blocktime_end();
				my $blocktime_processed     = $data_structure->get_blocktime_processed();
				my $blocktime_id            = $data_structure->get_blocktime_id();
				
				#use VCL::blockrequest;
				#$data_structure->set_blockrequest_mode('start');
				#my $br_start = VCL::blockrequest->new({%{$blockrequest_data->{$blockrequest_id}}, data_structure => $data_structure});
				#notify($ERRORS{'OK'}, $LOGFILE, "***** Starting start process *****");
				#$br_start->process();
				#exit;
				#notify($ERRORS{'OK'}, $LOGFILE, "***** DONE WITH START *****");
				#sleep 5;
				#$data_structure->set_blockrequest_mode('end');
				#my $br_end = VCL::blockrequest->new({%{$blockrequest_data->{$blockrequest_id}}, data_structure => $data_structure});
				#notify($ERRORS{'OK'}, $LOGFILE, "***** Starting end process *****");
				#$br_end->process();
				#notify($ERRORS{'OK'}, $LOGFILE, "***** DONE WITH END *****");
				#exit;

				# Check if the block request is already being processed
				if ($blockrequest_processing) {
					#notify($ERRORS{'DEBUG'}, $LOGFILE, "block request $blockrequest_id '$blockrequest_name' is already being processed");
					next BLOCKREQUEST;
				}
				else {
					#notify($ERRORS{'OK'}, $LOGFILE, "block request $blockrequest_id '$blockrequest_name' is not currently being processed");
				}

				# Check block request start, end and expire time
				my $blockrequest_mode = check_blockrequest_time($blocktime_start, $blocktime_end, $blockrequest_expire);

				# check_blockrequest_time will return 0 if nothing needs to be done and undefined if an error occurred
				if (!defined $blockrequest_mode) {
					notify($ERRORS{'CRITICAL'}, $LOGFILE, "error occurred checking block request $blockrequest_id '$blockrequest_name' status");
					next;
				}
				elsif (!$blockrequest_mode) {
					#notify($ERRORS{'DEBUG'}, $LOGFILE, "block request $blockrequest_id will not be processed at this time");
					next;
				}
				else {
					#notify($ERRORS{'DEBUG'}, $LOGFILE, "block request $blockrequest_id will be processed, mode: $blockrequest_mode");
				}

				if ($blockrequest_mode eq 'start' && $blocktime_processed) {
					#notify($ERRORS{'DEBUG'}, $LOGFILE, "block request $blockrequest_id '$blockrequest_name' blocktime_id $blocktime_id has already been processed");
					next BLOCKREQUEST;
				}

				# Start processing block request
				$data_structure->set_blockrequest_mode($blockrequest_mode);

				# Attempt to set the blockRequest processing column to 1
				if (update_blockrequest_processing($blockrequest_id, 1)) {
					notify($ERRORS{'OK'}, $LOGFILE, "block request $blockrequest_id '$blockrequest_name' processing set to 1");

					# Make a new child process, passing it the request/reservation info
					make_new_child({data_structure => $data_structure, request_info => $blockrequest_data->{$blockrequest_id}});
				}
				else {
					notify($ERRORS{'CRITICAL'}, $LOGFILE, "unable to set block request $blockrequest_id '$blockrequest_name' processing to 1");
					next;
				}
			} ## end foreach my $blocktime_id (keys %{$blockrequest_data...

		} ## end foreach my $blockrequest_id (keys %{$blockrequest_data...
	} ## end while (1)
} ## end sub main ()

#/////////////////////////////////////////////////////////////////////////////

=head2 make_new_child

 Parameters  : 
 Returns     : 
 Description :

=cut

sub make_new_child {
	my ($args) = @_;
	
	my $request_data   = $args->{request_info};
	my $data_structure = $args->{data_structure};
	$data_structure = 0 if !$data_structure;

	# Assemble a consistent prefix for notify messages
	my $request_id     = $request_data->{id};
	my $reservation_id = $request_data->{RESERVATIONID};

	# Get the state name
	my $state;
	my $state_module;
	if ($data_structure) {
		$state        = $data_structure->get_state_name();
		$state_module = "VCL::$state";
	}
	else {
		$state        = $request_data->{state}{name};
		$state_module = "VCL::$state";
	}

	# The timeout and deleted states have been combined into reclaim.pm
	if ($state =~ /^(timeout|deleted)$/) {
		notify($ERRORS{'DEBUG'}, $LOGFILE, "request will be processed by reclaim.pm");
		$state_module = "VCL::reclaim";
	}

	# The imageinuse state is now handled by inuse.pm
	if ($state =~ /^(imageinuse|rebootsoft|reboothard|servermodified)$/) {
		notify($ERRORS{'DEBUG'}, $LOGFILE, "request will be processed by inuse.pm");
		$state_module = "VCL::inuse";
	}
	
	# The tomaintenance state is handled by new.pm
	if ($state =~ /^(tomaintenance|imageprep|reload|reinstall|tovmhostinuse)$/) {
		notify($ERRORS{'DEBUG'}, $LOGFILE, "request will be processed by new.pm");
		$state_module = "VCL::new";
	}
	
	# The checkpoint state is handled by image.pm
	if ($state =~ /^(image|checkpoint)$/) {
		notify($ERRORS{'DEBUG'}, $LOGFILE, "request will be processed by image.pm");
		$state_module = "VCL::image";
	}
	
	# Build a signal set using POSIX::SigSet->new, contains only the SIGINT signal
	my $sigset = POSIX::SigSet->new(SIGINT);
	
	# Pass the POSIX::SigSet object to sigprocmask with the SIG_BLOCK flag to delay SIGINT signal delivery
	sigprocmask(SIG_BLOCK, $sigset) or die "can't block SIGINT for fork: $!\n";

	FORK: {
		my $pid;
		if ($pid = fork) {
			# If here, this is the parent process
			
			# Restore delivery of SIGINT signal for the parent process
			sigprocmask(SIG_UNBLOCK, $sigset) or die "can't unblock SIGINT for fork: $!\n";
			
			# Parent process records the child's PID and returns
			# Store the reservation ID so REAPER can clean up the reservation when it dies
			$child_count++;
			$child_pids{$pid} = $reservation_id;
			notify($ERRORS{'DEBUG'}, $LOGFILE, "created child process $pid for reservation $reservation_id, state: $state, current number of forked kids: $child_count");
			return;
		}
		elsif (defined $pid) {
			# If here, this is the child process
			
			# Child must *NOT* return from this subroutine after this point. It must exit.
			# If child returns it will become a parent process and spawn off its own children
			
			# Close/release the lockfile if the handle is shared with the forked child
			# This behavior isn't reliable, using the old SysV daemon it doesn't get shared with the child
			# It does get shared using systemd
			# If shared, the child keeps the file locked even the the parent vcld process dies
			# This prevents the parent from being able to start up again until the child dies
			if (fileno LOCKFILE) {
				close LOCKFILE;
			}
			
			# Set the process group of this child process to its own PID instead of it's parent PID
			# This allows any processes forked by this child to be killed when this process is killed
			setpgrp $$, 0;
			
			# Configure the SIGINT signal to kill this process normally
			$SIG{INT} = 'DEFAULT';
			
			# Unblock the SIGINT signal
			sigprocmask(SIG_UNBLOCK, $sigset) or die "can't unblock SIGINT for fork: $!\n";
			
			# Set the vcld environment variable to 0 so other subroutines know if this is the vcld or child process
			$ENV{vcld} = 0;
			notify($ERRORS{'DEBUG'}, $LOGFILE, "vcld environment variable set to $ENV{vcld} for this process");
			
			# Set the request_id and reservation_id environment variables
			$ENV{request_id}     = $request_id;
			$ENV{reservation_id} = $reservation_id if $reservation_id;
			$ENV{state}          = $state;
			$ENV{data}           = $data_structure;
			
			# Rename this process to include some request info
			rename_vcld_process($data_structure);
			
			#notify($ERRORS{'DEBUG'}, $LOGFILE, "creating new process");
			eval "use $state_module";
			if ($EVAL_ERROR) {
				notify($ERRORS{'CRITICAL'}, $LOGFILE, "$state_module module could not be loaded, error: $EVAL_ERROR");
				exit;
			}
			
			notify($ERRORS{'DEBUG'}, $LOGFILE, "loaded $state_module module");
			
			# Create a new VCL state object, passing it the reservation data
			my $state_object;
			eval {
				$state_object = ($state_module)->new({%{$request_data}, data_structure => $data_structure});
			};
			
			if ($state_object) {
				notify($ERRORS{'OK'}, $LOGFILE, "$state_module object created and initialized");
				
				# Call the state object's process() subroutine
				$state_object->process();
			}
			else {
				if ($EVAL_ERROR) {
					notify($ERRORS{'CRITICAL'}, $LOGFILE, "$state_module object could not be created and initialized, error:\n$EVAL_ERROR");
				}
				else {
					notify($ERRORS{'CRITICAL'}, $LOGFILE, "$state_module object could not be created and initialized");
				}
			}
			
			exit;
		} ## end elsif (defined $pid)  [ if ($pid = fork)
		
		elsif ($! =~ /No more process/) {
			sleep 5;
			redo FORK;
		}
		
		else {
			# strange error
			die "can't fork: $!\n";
		}
	} ## end FORK:
} ## end sub make_new_child

#/////////////////////////////////////////////////////////////////////////////

=head2 warning_handler

 Parameters  : None
 Returns     : Nothing
 Description : Handles __WARN__ signals. This signal is generated when warn()
               is called. This may occur when the VCL code encounters an
               error such as:
               Use of uninitialized value in concatenation (.) or string at
               
               If the signal isn't handled, the warning message is dumped
               to STDOUT and will appear in the log file. This handler
               causes WARN signals to be logged by the notify() subroutine.

=cut

sub warning_handler {
	# Call notify, passing it a string of whatever is contained in @_
	notify($ERRORS{'WARNING'}, $LOGFILE, "@_");
	
	# Reinstall the signal handler in case of unreliable signals
	$SIG{__WARN__} = \&warning_handler;
}

#/////////////////////////////////////////////////////////////////////////////

=head2 die_handler

 Parameters  : None
 Returns     : Nothing
 Description : Handles __DIE__ signals. This signal is generated when die()
               is called. This may occur when the VCL code encounters an
               error such as:
               Uncaught exception from user code:
               Undefined subroutine ... called at ...
               
               If the signal isn't handled, the output is dumped to STDERR
               and the process exits quietly.

=cut

sub die_handler {
	# Call notify, passing it a string of whatever is contained in @_
	notify($ERRORS{'CRITICAL'}, $LOGFILE, "@_");
	
	# Prevent requests stuck in pending, try to set state back to original
	if ($ENV{request_id} && $ENV{state}) {
		update_request_state($ENV{request_id}, $ENV{state}, $ENV{state});
	}
	
	# Reinstall the signal handler in case of unreliable signals
	$SIG{__DIE__} = \&die_handler;
	
	exit;
}

#/////////////////////////////////////////////////////////////////////////////

=head2 HUNTSMAN

 Parameters  : None
 Returns     : Nothing, process exits
 Description : Signal handler for:
               $SIG{INT}
               $SIG{QUIT}
               $SIG{HUP}
               $SIG{TERM}

=cut

sub HUNTSMAN {
	my $signal = shift;
	
	local ($SIG{CHLD}) = 'IGNORE';
	
	# Display a message and exit
	notify($ERRORS{'DEBUG'}, 0, "HUNTSMAN called: signal: $signal, pid: $PID, process exiting");
	exit;
}

#/////////////////////////////////////////////////////////////////////////////

=head2 REAPER

 Parameters  : None
 Returns     : Undefined
 Description : The REAPER subroutine gets called whenever a child process
               stops running or exits. This occurs because the subroutine is
               configured as the handler for SIGCHLD signals. The system will
               send a SIGCHLD signal whenever a child process stops running
               or exits.
               
               The REAPER subroutine manages the child PID hash when a VCL .
               state process exits. It also captures the exit code of the
               child process which died and makes sure the special $?
               variable is set to this value.

=cut

sub REAPER {
	my $signal = shift;
	
	# Don't overwrite current error
	local $!;

	# Save the information saved in $? before proceeding
	# This is done to save the exit status of the child process which died
	# If you don't save it, wait() will overwrite it
	my $status_save = $?;
	my $child_exit_status = $? >> 8;
	my $signal_number = $? & 127;
	my $dumped_core = $? & 128;
	#notify($ERRORS{'DEBUG'}, 0, "REAPER called: signal: $signal, initial value of \$?: $status_save");
	
	# Wait for a child processes to die
	my $dead_pid = -1;
	my $wait_pid;
	while (($wait_pid = waitpid(-1, WNOHANG)) > 0) {
		$status_save = $?;
		$child_exit_status = $? >> 8;
		$signal_number = $? & 127;
		$dumped_core = $? & 128;
		$dead_pid = $wait_pid;
		
		# Assemble a string containing the dead process info
		#notify($ERRORS{'DEBUG'}, 0, "process reaped: pid: $dead_pid, \$?: $status_save, exit status: $child_exit_status");
		
		# Check if the child PID hash contains the pid of the process which just died
		if (exists $child_pids{$dead_pid}) {
			my $dead_reservation_id = $child_pids{$dead_pid} || "<unknown>";
			notify($ERRORS{'DEBUG'}, 0, "VCL process exited for reservation $dead_reservation_id, PID: $dead_pid, signal: $signal");
			
			# Child which died was a VCL state process since its pid is in the hash
			$child_count--;
			delete $child_pids{$dead_pid};
			
			# Kill all child processes which were forked by this process
			kill 'SIGTERM', -$dead_pid;
		}
	}
	
	# Reinstall the signal handler in case of unreliable signals
	$SIG{CHLD} = \&REAPER;
	
	# Set the special $? variable back to the exit status of the child which died
	# This is useful when utilities such as SSH are run in other places in the code
	# The code which called the utility can check the exit status to see if it was successful
	#notify($ERRORS{'DEBUG'}, 0, "setting \$? to $status_save, exit status: $child_exit_status");
	$? = $status_save;
	
	return;
} ## end sub REAPER

#/////////////////////////////////////////////////////////////////////////////

=head2 daemonize

 Parameters  : none
 Returns     : true or exits
 Description :

=cut

sub daemonize {
	#Create EX lock on lockfile
	my $subsys_lock = "/var/lock/subsys/$PROCESSNAME";
	sysopen(LOCKFILE, $subsys_lock, O_RDONLY | O_CREAT ) or die "unable to open lock file: $PIDFILE \n";   
	unless(flock(LOCKFILE, LOCK_EX|LOCK_NB)) {
		notify($ERRORS{'WARNING'}, $LOGFILE, " an process instance of $PROCESSNAME is already running, failed to lock file: $subsys_lock");
		print STDOUT "\nFailed to start. An instance of $PROCESSNAME is already running\n\n";
		print STDERR "\nFailed to start. An instance of $PROCESSNAME is already running\n\n";
		exit(1); 
	}
	
	
	my $child_pid = fork();
	if (!defined($child_pid)) {
		die "Can't fork $!";
	}
	elsif ($child_pid) {
		# If here, this is the process that called fork()
		# This service starting process is only used to start the actual forked vcld daemon process, it must exit
		
		# Before exiting, the parent must create the pidfile
		# This must be done before this parent exits can cannot be done by the forked child
		# Otherwise, timing issues will occur with systemd
		# As soon as this parent exits, systemd expects the pidfile to exist and checks it
		# If the pidfile is missing or incorrect, systemd will try over and over again to start vcld
		notify($ERRORS{'DEBUG'}, 0, "this is parent service startup process: $PID, forked child process which will be the main vcld daemon process: $child_pid, writing child PID to file: $PIDFILE");
		open(PIDFILE, ">" . $PIDFILE) or notify($ERRORS{'WARNING'}, $LOGFILE, "unable to open PID file: $PIDFILE, $!");
		print PIDFILE $child_pid ;
		close(PIDFILE);
		notify($ERRORS{'DEBUG'}, 0, "parent service startup process exiting: $PID");
		exit;
	}
	else {
		# If here, this is the child process created by the fork and will be the main vcld process
		
		# Detatch from controlling terminal
		setsid;
		
		# Process umask is inherited to child from fork
		umask 0;
		
		# Current working directory is inherited to child from fork
		# The daemon will run from that directory and may prevent modification 
		chdir '/';
		
		preplogfile();
		
		# Redirect STDIN,STDOUT,STDERR 
		open STDIN,  '/dev/null'  or die "Can't read /dev/null $!";
		open STDOUT, ">>$LOGFILE" or die "Can't write $LOGFILE $!";
		open STDERR, ">>$LOGFILE" or die "Can't write $LOGFILE $!";
		
		print "Created VCL daemon process: $$\n";
		return 1;
	}
} ## end sub daemonize

#/////////////////////////////////////////////////////////////////////////////

=head2 setup_management_node

 Parameters  : None.
 Returns     : 
 Description : Checks each module in the module table for
               the existance of a subroutine named "setup". Calls the setup
               subroutine for each module which contains one.
               
               The program terminates if a module's setup subroutine returns
               false. The program continues if a module's setup subroutine
               returns true.
               
               STDOUT "print" statements are printed to the screen. Messages
               sent to the "notify" subroutine are printed to the logfile.

=cut

sub setup_management_node {
	print "VCL Management Node Setup\n";
	
	# Always use verbose mode when running in setup mode
	$VERBOSE = 1;
	
	# Create a DataStructure object which will be passed to modules when they are instantiated
	# The creation of this DataStructure object collects the management node information
	my $data_structure = new VCL::DataStructure();
	if (!$data_structure) {
		die "unable to create DataStructure object";
	}
	notify($ERRORS{'DEBUG'}, 0, "created DataStructure object to be used for vcld setup");
	
	# Get the information from the module table
	my $module_info = get_module_info();
	
	# Loop through the entries in the data from the module table
	my %setup_module_objects;
	my %setup_menu;
	
	use VCL::Module;
	for my $module_id (keys %$module_info) {
		# Get the module's Perl package and name
		my $module_name = $module_info->{$module_id}{name};
		my $module_perl_package = $module_info->{$module_id}{perlpackage};
		notify($ERRORS{'DEBUG'}, 0, "checking if setup() subroutine has been implemented by '$module_name' module");
		
		# Attempt to load the module
		eval "use $module_perl_package";
		if ($EVAL_ERROR) {
			notify($ERRORS{'WARNING'}, 0, "$module_name module (" . $module_perl_package . ") could not be loaded, error message:\n$EVAL_ERROR");
			next;
		}
		
		# Check if the module implements a setup subroutine
		# Don't use 'can' or else the same setup subroutine will be called multiple times due to inheritance
		if (!defined(&{$module_perl_package . "::setup"}) && !defined(&{$module_perl_package . "::setup_get_menu"})) {
			next;
		}
		
		my $module_object = VCL::Module::create_object($module_perl_package);
		if (!$module_object) {
			next;
		}
		
		# Store the module object in a hash
		$setup_module_objects{$module_perl_package}{object} = $module_object;
		
		# Determine the name to display for the module
		my $module_display_name = $module_info->{$module_id}{prettyname};
		if (!$module_display_name) {
			# Use the last part of the module's Perl package path if the pretty name isn't set
			($module_display_name) = $module_perl_package =~ /([^:]+)$/;
			
			# Capitalize the first letter
			$module_display_name =~ s/\b([a-z])(\w+)\b/\u$1$2/g;
		}
		$setup_module_objects{$module_perl_package}{display_name} = $module_display_name;
		
		
		if (defined(&{$module_perl_package . "::setup_get_menu"})) {
			my $module_menu = $module_object->setup_get_menu();
			%setup_menu = (%setup_menu, %$module_menu);
		}
		else {
			$setup_menu{Modules}{$module_display_name} = \&{$module_perl_package . "::setup"}
		}
		
		
	}
	
	# Loop until the user selects 'c' to cancel
	while (1) {
		# Set the setup_path environment variable to anonymous array containing 'vcld'
		# This is used to display the location in the menu hierarchy
		# strings added/removed to the array cause the location to change
		$ENV{setup_path} = ['vcld'];
		
		setup_print_break();
		my $choice = setup_get_menu_choice(\%setup_menu);
		## For testing
		#my $choice = {
		#	"name" => "VM Host Operations",
		#	"parent_menu_names" => ["VMware Provisioning Module"],
		#	"sub_ref" => \&VCL::Module::Provisioning::VMware::VMware::setup_vm_host_operations,
		#};
		
		last unless defined($choice);
		
		my $choice_name = $choice->{name};
		my $choice_sub_ref = $choice->{sub_ref};
		my $choice_parent_menu_names = $choice->{parent_menu_names};
		
		push @{$ENV{setup_path}}, @$choice_parent_menu_names, $choice_name;
		
		my $package_name = get_code_ref_package_name($choice_sub_ref);
		my $subroutine_name = get_code_ref_subroutine_name($choice_sub_ref);
		
		my $module_object = $setup_module_objects{$package_name}{object};
		&$choice_sub_ref($module_object);
		pop @{$ENV{setup_path}};
	}
	
	setup_print_break('=');
	exit;
}

#/////////////////////////////////////////////////////////////////////////////

1;
__END__

=head1 SEE ALSO

L<http://cwiki.apache.org/VCL/>

=cut