slashd

#!/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/.
# $Id$

############################################################
#
# 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.
#
############################################################

use strict;
use Carp;
use Errno;
use File::Basename;
use File::Path;
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
);

my $virtual_user = $ARGV[0];
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) {
			slashdLog(sprintf
				"%s odd exit (status %d, signal %d)",
				$taskname, $status, $signal
			);
		}
		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);
		my $ok = 0;
		eval { local $me = $file; $ok = require $fullname; };
		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 };

	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;