Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
executable file 1129 lines (976 sloc) 32.2 KB
#!/usr/bin/perl -w
# This code is a part of Slash, and is released under the GPL.
# Copyright 1997-2005 by Open Source Technology Group. See README
# and COPYING for more information, or see http://slashcode.com/.
############################################################
#
# slashd - the daemon that runs tasks from your site's "tasks"
# directory. Which tasks are in this directory (probably
# /usr/local/slash/site/yoursitename/tasks) depends on which
# theme and plugins (if any) you installed with install-slashsite.
#
# If the times showing up in slashd.log are not the times you expect
# to see, it's because this script uses your database machine
# to decide when to run scripts, but the machine it runs on when
# logging timestamps. This may help you notice unsynched clocks.
#
# An improvement I'd like to make: multi-machine processing. Multiple
# slashd's should be able to run on separate machines. They'd still
# each use their own slashd.pid, but: tasks could set params to
# indicate that they would only run on a particular hostname;
# slashd_status would store machine name and pid (to coordinate who
# gets to override in case of crash/restart); %resource_info would
# also be moved into slashd_status; runtask would need similar changes
# (and would benefit in that runtask/slashd would no longer step on
# each other for resources or even running the same task). There may
# be other shared information that would need to move from perl vars
# into the DB, I haven't looked carefully.
#
############################################################
use strict;
use Carp;
use Errno;
use File::Basename;
use File::Path;
use File::Temp 'tempfile';
use File::Spec::Functions qw(:DEFAULT devnull);
use LWP::UserAgent;
use HTTP::Request;
use POSIX ':sys_wait_h';
use Time::Local;
use Time::HiRes;
use URI::Escape;
use XML::Parser::Expat;
use XML::RSS 0.95;
use Schedule::Cron;
use Slash;
use Slash::Constants ':slashd';
use Slash::Display;
use Slash::Utility;
use vars qw(
%task %task_info $me
%resource_info
$event_ar
$cron
$task_exit_flag
$PROGNAME $virtual_user
);
$virtual_user = $ARGV[0];
# Rename the binary in the process list, to make identification
# with `ps` easier (see also do_child below).
$PROGNAME = basename($0);
$0 = "$PROGNAME $virtual_user";
eval {
createEnvironment($virtual_user);
};
if ($@) {
if ($@ =~ /DBIx::Password has no information about the virtual user/
&& $virtual_user eq 'start') {
die <<"EOT";
$@
To be more specific, your error is that, per step 7 of the INSTALLATION
section in the INSTALL file (please reread), you need to start slashd
with '/etc/init.d/slash start', not '/usr/local/slash/sbin/slashd start'.
EOT
}
die $@;
}
my $constants = getCurrentStatic();
my $slashdb = getCurrentDB();
my $user = getCurrentUser();
setCurrentSkin(determineCurrentSkin());
my $gSkin = getCurrentSkin();
my %pids = ( );
main();
exit 0;
############################################################
#
# Routines meant to be accessible from task scripts.
#
############################################################
# The standard log command.
sub slashdLog {
my(@args) = @_;
if ($pids{$$} && $pids{$$}{forktype} == SLASHD_NOWAIT) {
# prepend script name if we are a child that is forked nowait
$args[0] =~ s/^$pids{$$}{taskname}\s*//;
$args[0] = "[$pids{$$}{taskname}] $args[0]";
}
doLog('slashd', \@args);
}
# Tagboxes get the option to log to a separate file.
sub tagboxLog {
my(@args) = @_;
doLog('tagbox', \@args);
}
# A command to log an error to a DB table. This is only for messages
# that are important enough that the admins should see them (maybe in
# the admin.pl backend, but definitely in email at the end of the day).
sub slashdErrnote {
my($errnote, $moreinfo) = @_;
my $taskname = "SLASHD"; # the default if not called from a task
if ($pids{$$} && $pids{$$}{forktype} == SLASHD_NOWAIT) {
$taskname = $pids{$$}{taskname};
}
$slashdb->insertErrnoteLog($taskname, $errnote, $moreinfo);
}
# log children ending
# We're polling this reaper function, instead of calling it from within
# a $SIG{CHLD} handler. "if you're running in a loop, just arrange to
# call the reaper every so often. This is the best approach because it
# isn't subject to the occasional core dump that signals can sometimes
# trigger in the C library." - Camel3, p. 416, and see also p. 413.
sub REAPER {
return unless %pids;
if (verbosity() >= 4) {
my @pid_checklist = sort { $a <=> $b } keys %pids;
slashdLog("REAPER in parent $$ begin: "
. scalar(keys %pids) . " child(ren) potentially need reaping: @pid_checklist"
);
}
while (my $pid = waitpid(-1, WNOHANG)) {
if (verbosity() >= 4) {
slashdLog("REAPER in parent $$ found reaped pid $pid");
}
last if $pid < 1;
next if !exists $pids{$pid};
my $status = $? >> 8;
my $signal = $? & 127;
my $taskname = $pids{$pid}{taskname};
slashdLog("$taskname reaped ($pid)") if verbosity() >= 3;
delete $pids{$pid};
if ($status || $signal) {
my $oddexit = sprintf
"%s odd exit (status %d, signal %d)",
$taskname, $status, $signal;
slashdLog($oddexit);
slashdErrnote($oddexit);
}
set_resources($taskname, -1);
insert_task_event($taskname, 0);
}
if (verbosity() >= 4) {
my @pid_checklist = sort { $a <=> $b } keys %pids;
slashdLog("REAPER in parent $$ done for now: "
. scalar(keys %pids) . " child(ren) potentially need reaping"
. (%pids ? ": @pid_checklist" : "")
);
}
}
# Log a warning and die. Since slashd is meant to keep running
# long-term, this is meant for extreme circumstances such as a
# security violation; normal warnings can go to slashdLog.
sub slashdLogDie {
my $err = join(" ", @_);
slashdLog($err);
die $err;
}
# The closure and cache that was done on this is now done in
# MySQL.pm, making this utility function pretty much a no-op.
sub db_time {
return $slashdb->getTime({ unix_format => 1 });
}
# Get the logging verbosity from the database.
#
# More closure and mini-caching, again to avoid querying the DB every
# single time we want to do something.
{ my($last_level, $last_level_confirm) = (undef, undef);
sub verbosity {
my $my_time = time;
if (!$last_level_confirm
or $my_time > $last_level_confirm + 30) {
my $new_level = $slashdb->getVar('slashd_verbosity', 'value');
$new_level =~ /(\d+)/; $new_level = $1 || 2;
if (defined($last_level) and $last_level != $new_level) {
slashdLog("verbosity was $last_level, is $new_level");
}
$last_level = $new_level;
$last_level_confirm = $my_time;
}
return $last_level;
} }
############################################################
#
# And now the internal routines (not that your script can't
# invoke them, but it probably won't need to).
#
############################################################
{ my $last_static_update = $^T;
sub update_static {
my $my_time = time;
my $changed = 0;
if (!$last_static_update
|| $my_time > $last_static_update + 30) {
my $old_panic = $constants->{panic} || 0;
sleep 5 until $slashdb->sqlConnect();
createCurrentStatic($slashdb->getSlashConf());
$constants = getCurrentStatic();
$last_static_update = $my_time;
if ($old_panic != $constants->{panic}) {
slashdLog("'panic' was $old_panic, is $constants->{panic}");
init_event_ar();
$changed = 1;
}
}
return $changed;
} }
sub send_children_usr1 {
my @pids = sort { $a <=> $b } keys %pids;
if (@pids) {
my @info_str = ( );
for my $pid (@pids) {
my $success = kill USR1 => $pid;
push @info_str, "pid $pid ($pids{$pid}{taskname})"
. ($success ? "" : " (FAILED)");
}
slashdLog("sent SIGUSR1 to running tasks: @info_str");
}
}
sub slashdLogInit {
doLogInit('slashd', { exit_func => \&send_children_usr1 });
# When the parent process gets tapped with a USR1 signal,
# pass it along to all the children (it's their cue to exit
# at their earliest appropriate opportunity -- they also get
# that if the parent gets a TERM or INT).
$SIG{USR1} = \&send_children_usr1;
}
sub init_cron {
sub null_dispatcher { die "null_dispatcher called, there's a bug" }
$cron = Schedule::Cron->new(\&null_dispatcher);
}
sub end_log {
my($basename, $duration, $summary, $forktype) = @_;
return if verbosity() < 1;
my @log = ( );
# secs_until can be negative; that just means we're
# behind and will execute the next task immediately to
# try to catch up.
my $secs_until = $event_ar->[0][1] - db_time();
my $next_task = basename($event_ar->[0][0]);
my $secs = verbosity() >= 2 ? 0 : -30;
if ($forktype == SLASHD_LOG_NEXT_TASK) {
push @log, "$basename forked";
} else {
push @log, "$basename end";
}
if ($forktype == SLASHD_WAIT) {
push @log, " ($$)";
}
if ($forktype != SLASHD_LOG_NEXT_TASK) {
push @log, " (${duration}s";
}
if ($forktype != SLASHD_NOWAIT) {
# The child doesn't know what the next task is, if nowait
push @log, ($secs_until < $secs)
? "; $next_task "
. -$secs_until
. "s late"
: verbosity() >= 2
? "; $next_task in ${secs_until}s"
: ();
}
if ($forktype != SLASHD_LOG_NEXT_TASK) {
push @log, ")$summary";
}
slashdLog(join "", @log) if @log;
}
sub process_tasks {
%task = ( );
# "require" all the task files -- each will put its info into
# $task{"filename.pl"}
my %success = ( );
my %failure = ( );
my $dir = catdir($constants->{datadir}, "tasks");
if (!-e $dir or !-d _ or !-r _) {
slashdLogDie(<<EOT);
could not process task files in $dir, missing or not readable to $>
EOT
}
# Go through the files and require them all. Each file will
# store its data and code in %task and execute any necessary
# initialization. We also do some rudimentary checks of whether
# an attacker with guest access on this system could be feeding
# us bad code (the better solution, of course, is not to let
# attackers have local guest access).
my $I_WANT_SLASHD_TO_BE_A_SILLY_LOCAL_SECURITY_HOLE = 0;
if (not $I_WANT_SLASHD_TO_BE_A_SILLY_LOCAL_SECURITY_HOLE
and (stat $dir)[2] & 002) {
slashdLogDie("you really don't want me to use task files",
"from a directory that's world-writable: $dir");
}
my @files =
sort
grep { -e $_ and -f _ and -r _ }
glob "$dir/[a-zA-Z0-9_-][a-zA-Z0-9_-]*.pl";
for my $fullname (@files) {
if (not $I_WANT_SLASHD_TO_BE_A_SILLY_LOCAL_SECURITY_HOLE
and (stat $fullname)[2] & 002) {
slashdLogDie(<<EOT);
you really don't want me to use a task file that's world-writable: $fullname
EOT
}
my $file = basename($fullname);
# we want to encapsulate each task automatically. to do that,
# we automatically create a package name for each task, and
# then we manually import the symbols we want into that package.
# then it is written out as a temp file, and THAT file is
# require'd, not the actual task.
# we may be importing more than we need for coderefs, but
# i didn't feel like looking at each task individually.
(my $tmppackage = $file) =~ s/\.pl$//;
$tmppackage =~ s/\W/_/g;
$tmppackage =~ s/^([^a-zA-Z])/a_$1/g;
$tmppackage = "Slash::Task::$tmppackage";
# replace tmppackage in string where appropriate
(my $addtxt = <<'EOT') =~ s/\${?tmppackage}?/$tmppackage/g;
package $tmppackage;
{ no strict 'refs';
my @scalar = qw(me task_exit_flag);
my @hash = qw(task);
my @code = (qw(
slashdLog slashdErrnote slashdLogDie
tagboxLog verbosity db_time init_cron
),
grep { *{"main::$_"}{CODE} }
@Slash::EXPORT, @Slash::Display::EXPORT,
@Slash::Utility::EXPORT,
@File::Spec::Functions::EXPORT,
@LWP::UserAgent::EXPORT, @URI::Escape::EXPORT,
@File::Basename::EXPORT, @File::Path::EXPORT,
@Time::Local::EXPORT, @Time::HiRes::EXPORT
);
*{"${tmppackage}::$_"} = *{"main::$_"}{HASH} for @hash;
*{"${tmppackage}::$_"} = *{"main::$_"}{SCALAR} for @scalar;
*{"${tmppackage}::$_"} = *{"main::$_"}{CODE} for @code;
}
#line 1
EOT
my($tmpfh, $tmpfile) = tempfile();
my $tmptxt = do { open my $fh, '<', $fullname; local $/; <$fh> };
print $tmpfh $addtxt, $tmptxt;
$tmpfh->flush; # can't close fh until we require the file,
# else the file might disappear
my $ok = 0;
eval { local $me = $file; $ok = require $tmpfile };
if ($@) {
slashdLog("requiring '$fullname' raised exception: $@");
$ok = 0;
}
if ($!) {
slashdLog("requiring '$fullname' caused error: $!");
$ok = 0;
}
if (!$task{$file}{code} || ref $task{$file}{code} ne 'CODE') {
slashdLog("'$fullname' did not set code properly");
$ok = 0;
}
# This may be rethought later, but for those useful tasks we
# MAY OR MAY NOT want to run on an automated AND/OR a manual
# type basis: this allows the user to decide.
if ($task{$file}{standalone}) {
slashdLog("'$fullname' only runs via runtask (this is not an error)");
$ok = 0;
}
if (!defined($task{$file}{timespec})) {
slashdLog("'$fullname' did not set timespec properly");
$ok = 0;
}
if ($ok) {
$success{$file} = 1;
# Allow a default value for at least this one field
# (and maybe others, later... haven't decided yet)
$task{$file}{fork} ||= SLASHD_NOWAIT;
} else {
delete $task{$file} if $task{$file};
$failure{$file} = 1;
}
}
# Log success and failure, and if no successes, abort with die()
for my $task (keys %success) {
$task =~ s/\.pl$//;
$slashdb->createSlashdStatus($task);
}
slashdLog(
"processed $dir; "
. (scalar keys %success) . " successful"
. (
(scalar keys %success)
? " (" . join(" ", sort keys %success) . ")"
: ""
)
. "; "
. (scalar keys %failure) . " failed"
. (
(scalar keys %failure)
? " (" . join(" ", sort keys %failure) . ")"
: ""
)
);
slashdLogDie("aborting: no files successfully processed from $dir")
if !%task;
# Adjust timespecs for any tasks that have a var to override it.
my @adjusted = ( );
for my $file (sort keys %task) {
(my $file_nopl = $file) =~ s/\.pl$//;
my $varname = "task_timespec_$file_nopl";
next unless $constants->{$varname}
&& $constants->{$varname} ne $task{$file}{timespec};
$task{$file}{timespec} = $constants->{$varname};
push @adjusted, "$file ($task{$file}{timespec})";
}
if (@adjusted) {
slashdLog("Custom timespecs: @adjusted");
}
# Check the timespecs for the tasks, make sure they are valid.
my %invalid_timespec = ( );
my $db_time = db_time();
for my $file (sort keys %task) {
my @timespecs = ( );
for my $key (qw( timespec timespec_panic_1 timespec_panic_2 )) {
push @timespecs, $task{$file}{$key} if $task{$file}{$key};
}
CHECK: for my $check_spec (@timespecs) {
eval { $cron->get_next_execution_time($check_spec, $db_time) };
if ($@) {
# If the timespec is invalid, Schedule::Cron calls die().
# Trap that and log a warning instead.
my $err = "Invalid timespec '$check_spec' for $file, ignoring task. $@";
slashdErrnote($err);
slashdLog($err);
$invalid_timespec{$file} = 1;
last CHECK;
}
}
}
for my $file (keys %invalid_timespec) {
delete $task{$file};
}
# The appropriate data is in $task{"filename.pl"} -- write it all into
# the $cron object.
$cron->clean_timetable;
for my $file (sort keys %task) {
$task{$file}{entry} = $cron->add_entry($task{$file}{timespec},
$task{$file}{code});
}
$cron->build_initial_queue;
}
# Create an initial array of events with their next-scheduled
# execution times.
sub init_event_ar {
$event_ar = [ ];
for my $file (sort keys %task) {
my $immediate = $task{$file}{on_startup} ? 1 : 0;
insert_task_event($file, $immediate);
}
if (verbosity() >= 2) {
my $first_task = basename($event_ar->[0][0]);
my $secs_until = $event_ar->[0][1] - db_time();
slashdLog("first task will be $first_task in $secs_until secs");
}
}
# Given a task's filename, returns the next time at which that task will
# run. The optional third argument is a hashref in which the current
# database time is cached and where the next execution time and its file
# are stored (in case the caller cares).
sub calc_next_execution_time {
my($file, $hr) = @_;
$hr = { } if !$hr;
$hr->{db_time} = db_time();
my $timespec = $task{$file}{timespec};
if ($constants->{panic} >= 1) {
# Check for timespec_panic_n being defined, where n is
# the current panic level or, if available, less.
my $i = $constants->{panic};
while ($i > 0) {
if (defined($task{$file}{"timespec_panic_$i"})) {
$timespec = $task{$file}{"timespec_panic_$i"};
last;
}
--$i;
}
}
my $entry_time;
if ($timespec) {
# Let Schedule::Cron determine the next execution time.
$entry_time = $cron->get_next_execution_time($timespec,
$hr->{db_time});
} else {
# "Never execute" if timespec (at least for this panic level)
# is an empty string. This will break on Jan. 18, 2038.
$entry_time = 2**31-1;
}
if ($entry_time < $hr->{db_time}) {
my $min_time = $hr->{min_time} || "none";
slashdLog(<<EOT) if verbosity() >= 1;
error: entry_time in the past, check TZ ($entry_time < $hr->{db_time}) $file $timespec $min_time
EOT
return undef;
}
if (!$hr->{min_time} or $entry_time < $hr->{min_time}) {
$hr->{min_time} = $entry_time;
$hr->{min_file} = $file;
}
$entry_time;
}
# Add or subtract from resource values (to handle a task locking,
# or giving up, its resources). Round off to 0 to prevent roundoff
# errors from accumulating.
sub set_resources {
my($task_filename, $mult) = @_;
return unless $task{$task_filename}{resource_locks};
for my $resource (sort keys %{$task{$task_filename}{resource_locks}}) {
$resource_info{$resource} += $mult
* $task{$task_filename}{resource_locks}{$resource};
$resource_info{$resource} = 0 if abs($resource_info{$resource}) < 0.001;
if (verbosity() >= 3) {
slashdLog("$task_filename set resource_info '$resource' to $resource_info{$resource}");
}
}
}
# Given a task filename, calculates its next execution time, and recreates
# the event array with that task scheduled for that time. This happens
# to be always called when the task in question has already been popped
# off the front (current) end of the list, though this function will also
# happen to work if the task is already on the list for some reason.
sub insert_task_event {
my($filename, $immediate) = @_;
my $event_hr = { };
if (verbosity() >= 4) {
slashdLog("insert_task_event called: '$filename' '$immediate'");
}
# Convert the existing array into a hash.
for my $file_num (0..$#$event_ar) {
my($file, $until_time) = @{$event_ar->[$file_num]};
$event_hr->{$file}{until_time} = $until_time;
}
# Add (or replace) the desired task into the hash.
my $next_time;
if ($immediate and $constants->{panic} < 1) {
$next_time = db_time();
} else {
$next_time = calc_next_execution_time($filename);
}
$event_hr->{$filename}{until_time} = $next_time;
if (verbosity() >= 4) {
slashdLog("insert_task_event decided: '$filename' next at "
. scalar(localtime($next_time)));
}
# Rebuild the array in the proper order. Wrap this in a transaction
# so the DB doesn't have to go to disk 50 times, it can write all
# the rows at once.
$event_ar = [ ];
my @files = rebuild_event_ar($event_hr);
$slashdb->sqlDo("SET AUTOCOMMIT=0");
for my $file (@files) {
push @$event_ar, [ $file, $event_hr->{$file}{until_time} ];
(my $file_nopl = $file) =~ s/\.pl$//;
my @u = gmtime($event_hr->{$file}{until_time});
my $options = {
next_begin => sprintf("%4d-%02d-%02d %02d:%02d:%02d",
$u[5]+1900, $u[4]+1, $u[3],
$u[2], $u[1], $u[0]
)
};
$slashdb->setSlashdStatus($file_nopl, $options);
}
$slashdb->sqlDo("COMMIT");
$slashdb->sqlDo("SET AUTOCOMMIT=1");
}
# Sort the events from the hash back into an array. We choose the
# order carefully. Obviously the earlier events come before the
# later ones. But if several events occur at the same time, we
# put the event first which demands the fewest number of resource
# locks. We hope that will prevent lock contention as much as
# possible. If there's a tie for that, go alphabetically by name.
{ # closure
my $event_hr;
sub event_sort {
my $a_untiltime = $event_hr->{$a}{until_time};
my $b_untiltime = $event_hr->{$b}{until_time};
return $a_untiltime <=> $b_untiltime
if $a_untiltime <=> $b_untiltime;
my $a_resourcecount =
$event_hr->{$a}{resource_locks} && %{$event_hr->{$a}{resource_locks}}
? scalar(keys %{$event_hr->{$a}{resource_locks}})
: 0;
my $b_resourcecount =
$event_hr->{$b}{resource_locks} && %{$event_hr->{$b}{resource_locks}}
? scalar(keys %{$event_hr->{$b}{resource_locks}})
: 0;
return $a_resourcecount <=> $b_resourcecount
if $a_resourcecount <=> $b_resourcecount;
return $a cmp $b;
}
sub rebuild_event_ar {
($event_hr) = @_;
return sort event_sort keys %$event_hr;
}
}
sub get_next_possible_task {
# Return the next task that could be executed -- right now that
# means the next task that does not have any of its resources
# locked by another currently-executing task. In future it
# might be a more complex function to determine that :)
# If event arrayref not init'd yet, then nothing.
return undef unless $event_ar && @$event_ar;
# Walk thru the list starting from the beginning; take the
# first task that does not require locked resources.
for my $task_ar (@$event_ar) {
my($task_filename, $until_time) = @$task_ar;
return $task_ar if !$task{$task_filename}{resource_locks};
my $ok = 1;
for my $resource (sort keys %{$task{$task_filename}{resource_locks}}) {
# If the sum of what this task needs plus what is
# already in use exceeds 1, this task can't yet run.
if ($task{$task_filename}{resource_locks}{$resource}
+ ($resource_info{$resource} || 0)
> 1) {
$ok = 0;
last;
}
}
if (verbosity() >= 4) {
slashdLog("task '$task_filename' ok=$ok");
}
return $task_ar if $ok;
}
# Nothing qualifies!
return undef;
}
sub wait_until_task {
# The time we need to sleep until will stay at the front of the
# event array. However, it may change after every call to
# REAPER(), because REAPER() calls insert_task_event(). As
# soon as the current time exceeds the time at the front of the
# event array, we're done, so we return that first task.
my $max_sleep;
my $next_task = undef;
my($task_filename, $until_time);
WAIT_UNTIL: while (1) {
$next_task = get_next_possible_task($event_ar);
($task_filename, $until_time) = ('', 2**31-1);
if ($next_task) {
($task_filename, $until_time) = @$next_task;
}
my $cur_time = db_time();
if ($cur_time >= $until_time) {
# OK, this task is ready to run; we're done
# twiddling our thumbs.
if (verbosity() >= 4) {
slashdLog("Ready to run '$task_filename'");
}
last WAIT_UNTIL;
}
# If there are children waiting to be reaped, we loop
# frequently to poll REAPER to look for them to die.
# If not, there's no need to hit it frequently.
$max_sleep = (%pids ? 2 : 300);
my $sleep_total = $until_time - $cur_time;
if ($sleep_total < 1) {
$sleep_total = 1;
} elsif ($sleep_total > $max_sleep) {
$sleep_total = $max_sleep;
}
slashdLog(sprintf "Begin reap-and-sleep-for-%s-secs: %s < %s",
$sleep_total,
scalar(localtime($cur_time)),
scalar(localtime($until_time)))
if verbosity() >= 3;
REAPER();
# If the REAPER() call pushed a new event with a new
# until_time onto the front of the event array, then
# jump right back into this while loop without
# sleeping at all (because the new event may trigger
# sooner, even need to be triggered immediately).
my $new_until_time = 2**31-1;
my $new_next_task = get_next_possible_task($event_ar);
$new_until_time = $new_next_task->[1] if $new_next_task;
if ($new_until_time != $until_time) {
if (verbosity() >= 4) {
slashdLog("REAPER() found new task,"
. " cancelling sleep");
}
next WAIT_UNTIL;
}
# If not, do the sleep we planned to do.
sleep $sleep_total;
}
slashdLog(sprintf "Finishing sleep: %s >= %s",
scalar(localtime(db_time())),
scalar(localtime($until_time)))
if verbosity() >= 3;
return $next_task;
}
sub pull_task {
my($task_ar) = @_;
my $task_filename = $task_ar->[0];
my($the_task) = grep { $_->[0] eq $task_filename } @$event_ar;
my @new_event_ary = grep { $_->[0] ne $task_filename } @$event_ar;
$event_ar = [ @new_event_ary ];
return @$the_task;
}
sub main {
# Initialize logging and all the low-level stuff.
slashdLogInit();
slashdLog("Starting up Slashd (verbosity " . verbosity()
. ") with pid $$");
if ($ENV{TZ} ne 'GMT') {
slashdLog(join(" ",
"Note: \$ENV{TZ}='$ENV{TZ}' not GMT, this may cause",
"'entry_time in the past' errors; did you not start",
"slashd with the init script?"
));
}
# Initialize the scheduling stuff.
%task_info = ( );
%resource_info = ( );
init_cron();
process_tasks();
init_event_ar();
$task_exit_flag = 0;
# Set some signal handlers. First, when a child exits, this
# handler gets called (right now it does nothing).
$SIG{CHLD} = sub {
# Logging is for debugging only!! Almost anything you do
# in a signal handler (including opening, printing to,
# and closing a file, which slashdLog does) can call into
# the C library which can (though it's unlikely) cause
# coredumps and other bad stuff. For more, see the
# comment at the top of the REAPER function.
# slashdLog("SIGCHLD called in $$")
# NOTE: perl 5.8 has safe signals.
};
# Here's the main event loop, which never returns (slashd is
# typically ended with a SIGTERM from /etc/*/init.d/slash stop).
# daemonize
open(STDOUT, '+>' . devnull());
MAINLOOP: while (1) {
if (verbosity() >= 4) {
slashdLog("Beginning MAINLOOP");
}
# wait_until_task calls REAPER() periodically; it will
# return when there is a task that needs to be called.
my $next_task = wait_until_task();
# If there is no next task, repeat the loop.
if (!$next_task) {
if (verbosity() >= 2) {
slashdLog("No next task, which is highly unusual unless most or all tasks are disabled; sleeping and retrying");
}
sleep 5;
next MAINLOOP;
}
# Recheck the vars table to reload $constants if necessary.
# If it changed, this may alter our execution schedule, so
# repeat the loop from the top.
if (update_static()) {
next MAINLOOP;
}
# Pull that task out of the event array and get the
# information about it.
my($task_filename, $until_time) = pull_task($next_task);
my $basename = basename($task_filename);
(my $basename_nopl = $basename) =~ s/\.pl$//;
my $subref = $task{$task_filename}{code};
my $forktype = SLASHD_WAIT; # the default
$forktype = SLASHD_NOWAIT
if $task{$task_filename}{fork} == SLASHD_NOWAIT;
# Mark the resources it needs locked as being in use.
set_resources($task_filename, +1);
# Execute it.
$slashdb->setSlashdStatus($basename_nopl, {
-in_progress => 'in_progress+1',
task => $basename_nopl,
});
my $start_time = Time::HiRes::time;
my $args = {
basename => $basename,
basename_nopl => $basename_nopl,
forktype => $forktype,
subref => $subref,
start_time => $start_time,
task_filename => $task_filename,
invocation_num => $task_info{$task_filename}{invocations} || 0
};
REAPER();
local $me = $basename;
# kill the dbh, we have too many problems
# if it sticks around during a fork -- pudge
$slashdb->getMCD()->disconnect_all() if $slashdb->getMCD();
$slashdb->{_dbh}->disconnect if $slashdb->{_dbh};
undef $slashdb->{_dbh};
FORK: {
$args->{parent_pid} = $$;
$args->{pid} = my $pid = fork();
if (!dbAvailable()) {
# Don't we want to do this _before_ we fork?
# (It's not like calling dbAvailable() and
# then sqlConnect() is atomic anyway.)
# - Jamie
slashdLog("DB unavailable waiting to start next task");
sleep 5 until dbAvailable();
slashdLog("DB available again preparing to start next task");
};
# Parent and child now separately reconnect.
$slashdb->sqlConnect();
if ($pid) {
next MAINLOOP if !do_parent($args);
} elsif (defined $pid) {
do_child($args);
# should never reach here, do_child exits
} elsif ($!{EAGAIN}) {
# Recoverable fork error.
sleep 1;
redo FORK;
} else {
# "Weird fork error," says Camel3 p. 715.
slashdLog("Error: cannot fork '$me': $!");
# current task is *not* added back into
# event array if we get here, it is lost
# until slashd restarts -- pudge
# if weird forks stalk the land, we must
# expect casualties -- jamie
next MAINLOOP;
}
}
# Sleep for at least a second between tasks.
if (verbosity() >= 4) {
slashdLog("Ending MAINLOOP");
}
sleep 1;
$task_info{$task_filename}{invocations}++;
}
}
sub do_parent {
my($args) = @_;
my($pid, $basename, $forktype) =
@{$args}{qw(pid basename forktype)};
# some later call to REAPER will
# reap and delete this hash field
$pids{$pid} = {
taskname => $basename,
forktype => $forktype,
dead => 0,
};
if ($forktype == SLASHD_NOWAIT) {
# log when next task is running
end_log($basename, 0, "", SLASHD_LOG_NEXT_TASK);
if (verbosity() >= 4) {
slashdLog("Parent $$: sleep for 1 second after fork()");
}
sleep 1;
if (verbosity() >= 4) {
slashdLog("Parent $$: slept for 1 second after fork()");
}
} elsif ($forktype == SLASHD_WAIT) {
if (verbosity() >= 4) {
slashdLog("Parent $$: sleep and wait after fork()");
}
# wait for REAPER to reap and delete this hash field
while (exists $pids{$pid}) {
REAPER();
sleep 1;
}
if (verbosity() >= 4) {
slashdLog("Parent $$: slept and waited after fork()");
}
} else {
slashdLog("unexpected value of \$forktype: $forktype");
return 0;
}
return 1;
}
sub do_child {
my($args) = @_;
my($basename, $forktype, $subref, $basename_nopl,
$start_time, $invocation_num, $parent_pid) =
@{$args}{qw(
basename forktype subref basename_nopl
start_time invocation_num parent_pid
)};
# In doLogPid (which is called by doLogInit, which is called by
# slashdLogInit) we had set a handler for these that deletes the
# slashd.pid file. Children don't have the right to do that.
$SIG{TERM} = $SIG{INT} = 'DEFAULT';
# Children may use system(), backticks, or open() pipes, all of which
# end up invoking CHLD handlers. Don't call the parent's CHLD handler
# -- whatever it may be, it's inappropriate for the child. The default
# action for SIGCHLD is to ignore it.
$SIG{CHLD} = 'DEFAULT';
# If someone sends this child a SIGUSR1, that means it should exit
# at its earliest appropriate opportunity. It's up to the task code
# to check this var and behave accordingly, though.
$SIG{USR1} = sub { $task_exit_flag = 1 };
# Change the name of the child process in the process list to be
# simply "slashd virtuser taskname". This makes identification of
# the children in `ps` much easier.
$0 = "$PROGNAME $virtual_user $basename_nopl";
setUserDBs($user);
if (verbosity() >= 4) {
slashdLog("Child $$ [$me]: sleep for 1 second after fork()");
}
$pids{$$} = {
taskname => $basename,
forktype => $forktype
};
# have STDERR passed through slashdLog
tie *STDERR, 'Slash::Tie::STDERR' if $forktype == SLASHD_NOWAIT;
# Give the parent a chance to get into its REAPER loop. This
# shouldn't be necessary now that the parent is not using $SIG{CHLD}
# to handle reaping child processes, but it still isn't a bad idea.
sleep 1;
slashdLog("$basename begin ($$)") if verbosity() >= 2;
if (verbosity() >= 4) {
slashdLog("Child $$: slept for 1 second after fork()");
}
my $info = {
invocation_num => $invocation_num,
parent_pid => $parent_pid,
};
if (verbosity() >= 4) {
slashdLog("invocation_num $info->{invocation_num}");
}
srand;
my $summary = $subref->($virtual_user, $constants, $slashdb, $user,
$info, $gSkin);
my $end_time = Time::HiRes::time;
my $duration = sprintf("%.2f", $end_time - $start_time);
# If desired, log that it's done (to disk logfile and into the DB).
$summary = "" if !$summary;
$summary =~ s/\s+/ /g; chomp $summary;
$summary = ": $summary" if $summary;
end_log($basename, $duration, $summary, $forktype);
(my $summary_trim = $summary) =~ s/^:\s*//;
$slashdb->setSlashdStatus($basename_nopl, {
-last_completed => "NOW()",
summary => $summary_trim,
duration => $duration,
-in_progress => 'GREATEST(in_progress-1, 0)',
});
if (verbosity() >= 4) {
slashdLog("Child $$ exits here");
}
# Child must not drop out of this subroutine.
exit;
}
package Slash::Tie::STDERR;
use Symbol 'gensym';
use base 'Tie::Handle';
sub TIEHANDLE {
my $class = shift;
my $fh = gensym();
bless $fh, $class;
return $fh;
}
sub PRINT {
my($fh, @args) = @_;
main::slashdLog(@args);
}
sub PRINTF {
my($fh, $format, @args) = @_;
main::slashdLog(sprintf($format, @args));
}
sub FILENO {
my($fh) = @_;
return fileno($fh);
}
1;
Jump to Line
Something went wrong with that request. Please try again.