blob: bd510cdd9924932198e6385a5b5b73d40e70ded4 [file] [log] [blame]
#!/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.00';
# 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};
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;
}
# 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};
#===========================================================================
# 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");
}
# For testing purposes on Windows
if ($^O =~ /win/i) {
# Set the request_id and reservation_id environment variables
$ENV{request_id} = $request_id;
$ENV{reservation_id} = $reservation_id;
# 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");
my $kid;
if ($kid = ($state_module)->new({%{$request_data}, data_structure => $data_structure})) {
notify($ERRORS{'OK'}, $LOGFILE, "$state object created and initialized");
# Set the request_id and reservation_id environment variables
$kid->process();
}
else {
notify($ERRORS{'CRITICAL'}, $LOGFILE, "$state object could not be created and initialized");
switch_state($request_data, 'failed', '', 'failed', 1);
}
# Set the request_id and reservation_id environment variables
delete $ENV{request_id};
delete $ENV{reservation_id};
delete $ENV{state};
# Restore the vcld environment variable to 1
$ENV{vcld} = 1;
# Only return from make_new_child if running on Windows for testing without actually forking
return;
} ## end if ($^O =~ /win/i)
# 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;
# 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