| #!/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.2.2'; |
| |
| # 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 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 () { |
| #=========================================================================== |
| # BEGIN NEW CODE |
| # This section does some prep work before looping |
| my ($package, $filename, $line, $sub) = caller(0); |
| |
| # Set the vcld environment variable to 0 so other subroutines know if this is the vcld or child process |
| $ENV{vcld} = 1; |
| notify($ERRORS{'DEBUG'}, $LOGFILE, "vcld environment variable set to $ENV{vcld} for this process"); |
| |
| # 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) { |
| SLEEP: |
| |
| delete $ENV{request_id}; |
| delete $ENV{reservation_id}; |
| delete $ENV{state}; |
| delete $ENV{data}; |
| |
| sleep $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 |
| if ($info{request} = {get_management_node_requests($management_node_id)}) { |
| #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}; |
| |
| $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/) { |
| 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; |
| } |
| |
| #=========================================================================== |
| # Loop through the reservations associated with this request |
| RESERVATION: foreach my $reservation_id (keys %{$info{request}{$request_id}{reservation}}) { |
| $ENV{reservation_id} = $reservation_id; |
| |
| # Check to see if the reservation is still in the hash before proceeding |
| # If request was deleted from database, it was also removed from this hash |
| if (!defined($info{request}{$request_id}{reservation}{$reservation_id})) { |
| #notify($ERRORS{'DEBUG'}, $LOGFILE, "reservation was deleted"); |
| next RESERVATION; |
| } |
| |
| # Store reservation variables into local variable |
| my $reservation_lastcheck = $info{request}{$request_id}{reservation}{$reservation_id}{lastcheck}; |
| |
| # Perform steps common to all states |
| #notify($ERRORS{'DEBUG'}, $LOGFILE, "assigned reservation in state: $request_state_name"); |
| |
| # The request_info hash stores all the information for this request |
| my %request_info; |
| |
| # 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); |
| #notify($ERRORS{'DEBUG'}, 0, "check_time returned \'$check_time_result\'"); |
| |
| # Do nothing if check_time returned 0 |
| # Check this before querying for the large set of request data |
| if (!$check_time_result) { |
| # do nothing - disabled debug output too much info for large numbr of requests |
| #notify($ERRORS{'DEBUG'}, $LOGFILE, "request will not be processed"); |
| 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 RESERVATION; |
| } ## end elsif ($check_time_result eq "remove") [ if (!$check_time_result) |
| 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 && $request_state_name ne 'deleted') { |
| notify($ERRORS{'WARNING'}, $LOGFILE, "reservation $reservation_id is already being processed"); |
| next RESERVATION; |
| } |
| elsif ($being_processed) { |
| notify($ERRORS{'DEBUG'}, $LOGFILE, "$request_state_name processing delayed, reservation $reservation_id is currently being processed"); |
| } |
| 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 = get_request_info($request_id)) { |
| notify($ERRORS{'DEBUG'}, $LOGFILE, "retrieved request information from database"); |
| |
| # Add the reservation ID to be processed to the hash |
| $request_info{RESERVATIONID} = $reservation_id; |
| |
| # 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; |
| } |
| else { |
| notify($ERRORS{'WARNING'}, $LOGFILE, "could not retrieve request information from database"); |
| next RESERVATION; |
| } |
| |
| # 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; |
| } |
| |
| # 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 $e = Exception::Class::Base->caught()) { |
| notify($ERRORS{'CRITICAL'}, 0, "unable to create DataStructure object" . $e->message); |
| next RESERVATION; |
| } |
| |
| # Add the DataStructure reference to %ENV so it can be accessed from non-object methods |
| $ENV{data} = $data_structure; |
| |
| # Update the request state to pending, laststate to next state |
| # Pending is set now so vcld doesn't try to process it again |
| # The previous state is already in the hash as the laststate value |
| # This will be passed to the next module so it knows where it came from |
| my $is_parent_reservation = $data_structure->is_parent_reservation(); |
| if ($is_parent_reservation && update_request_state($request_id, "pending", $request_state_name)) { |
| #notify($ERRORS{'OK'}, $LOGFILE, "request state updated to pending, laststate $request_state_name"); |
| } |
| elsif (!$is_parent_reservation) { |
| notify($ERRORS{'OK'}, $LOGFILE, "child reservation: request state NOT updated to pending"); |
| } |
| else { |
| notify($ERRORS{'CRITICAL'}, $LOGFILE, "request state could not be updated to pending, reservation not processed"); |
| next RESERVATION; |
| } |
| |
| # Insert a computerloadlog entry to indicate processing has begin for this reservation |
| my $computer_id = $data_structure->get_computer_id(); |
| if (insertloadlog($reservation_id, $computer_id, "begin", "beginning to process, state is $request_state_name")) { |
| #notify($ERRORS{'OK'}, $LOGFILE, "inserted 'begin' entry into computerloadlog for reservation $reservation_id"); |
| } |
| else { |
| notify($ERRORS{'CRITICAL'}, $LOGFILE, "failed to insert 'begin' entry into computerloadlog for reservation $reservation_id"); |
| } |
| |
| # 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)$/) { |
| 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|tovmhostinuse)$/) { |
| notify($ERRORS{'DEBUG'}, $LOGFILE, "request will be processed by new.pm"); |
| $state_module = "VCL::new"; |
| } |
| |
| #notify($ERRORS{'DEBUG'}, $LOGFILE, "creating new process"); |
| |
| eval "use $state_module"; |
| if (!$EVAL_ERROR) { |
| notify($ERRORS{'DEBUG'}, $LOGFILE, "loaded $state_module module"); |
| } |
| else { |
| notify($ERRORS{'WARNING'}, $LOGFILE, "$state_module module could not be loaded"); |
| } |
| |
| # 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, "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 |
| |
| # 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; |
| |
| # Create a new VCL state object, passing it the reservation data |
| if (my $state_object = ($state_module)->new({%{$request_data}, data_structure => $data_structure})) { |
| notify($ERRORS{'OK'}, $LOGFILE, "$state_module object created and initialized"); |
| |
| # Call the state object's process() subroutine |
| $state_object->process(); |
| } |
| else { |
| notify($ERRORS{'CRITICAL'}, $LOGFILE, "$state_module object could not be created and initialized"); |
| switch_state($request_data, 'failed', '', 'failed', 1); |
| } |
| |
| 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, "@_"); |
| |
| # 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}; |
| } |
| } |
| |
| # 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 : |
| Returns : |
| 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 "); |
| print STDOUT "\nFailed to start.\n\nAn instance of $PROCESSNAME is already running\n\n"; |
| print STDERR "\nFailed to start.\n\nAn instance of $PROCESSNAME is already running\n\n"; |
| exit(1); |
| } |
| |
| |
| chdir '/' or die "Can't chdir to /: $!"; |
| defined(my $pid = fork) or die "Can't fork $!"; |
| exit if $pid; |
| |
| |
| umask 0; |
| setsid or die "Can't start a new session: $!"; |
| |
| # write pid to pidfile |
| open(PIDFILE, ">" . $PIDFILE) or notify($ERRORS{'WARNING'}, $LOGFILE, "unable to open PID file: $PIDFILE, $!"); |
| print PIDFILE $$ ; |
| close(PIDFILE); |
| |
| preplogfile(); |
| print "Created VCL daemon process: $$\n"; |
| |
| #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 $!"; |
| |
| |
| } ## 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; |
| |
| 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"); |
| print "ERROR: '$module_name' module could not be loaded:\n$EVAL_ERROR\n"; |
| 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"})) { |
| next; |
| } |
| |
| # Create a new VCL state object, passing it the reservation data |
| my $module_object; |
| unless ($module_object = ($module_perl_package)->new({data_structure => $data_structure})) { |
| notify($ERRORS{'WARNING'}, 0, "$module_name module (" . $module_perl_package . ") object could not be created, error message:\n$!"); |
| print "ERROR: '$module_name' object could not be created, see log file, $!"; |
| 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; |
| } |
| |
| # 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']; |
| |
| # Loop until the user selects 'c' to cancel |
| while (1) { |
| print '-' x 76 . "\n"; |
| |
| # Display a menu to the user listing the modules that were found containing setup subroutines |
| print "Select a module to configure:\n"; |
| my $module_perl_package = setup_get_hash_choice(\%setup_module_objects, 'display_name'); |
| last if (!defined($module_perl_package)); |
| |
| # Retrieve the module object already created |
| my $module_object = $setup_module_objects{$module_perl_package}{object}; |
| if (!$module_object) { |
| die "Module object is not defined: $module_perl_package"; |
| } |
| |
| # Call the setup subroutine |
| $module_object->setup(); |
| } |
| |
| print "============================================================================\n"; |
| exit; |
| } |
| |
| #///////////////////////////////////////////////////////////////////////////// |
| |
| 1; |
| __END__ |
| |
| =head1 SEE ALSO |
| |
| L<http://cwiki.apache.org/VCL/> |
| |
| =cut |
| |