#!/usr/athena/bin/perl

# $Header: /afs/sipb.mit.edu/machine/penguin-lust/src/mail-server/RCS/queue-run.plin,v 1.19 2004/12/15 23:06:42 arolfe Exp arolfe $

# To make changes to this file, edit the source address listed above,
# run "make queue-run.pl" in the directory that file lives in, and
# then replace queue-run with the resulting queue-run.pl file.

push(@INC, '/rtfm/mserv');

require 'mservlib.pl';
require 'header.pl';
require 'syslog.pl';
require 'errno.ph';
#require 'syscall.ph';

# This is evaled because it produces a fatal error and we don't care
# if it fails.

eval "require 'sys/resource.ph' && setpriority(&PRIO_PROCESS, $$, 10);";

$unique_id = 0;
$minsize = 10000;
$archive_root = $lib'archive_root;
$helpfile = $lib'helpfile;
$tempfile = $lib'tempfile;
$help_message = $lib'help_message;
$mailer = $lib'mailer;
$subject_tag = $lib'archiver;
$server_addr = $lib'address;
$host = $lib'server_host;
$admin = $lib'administrator;
@free_handles = ();
$handle_id = "FOO000";
$dont_stop = 0;
$restart = 0;
($logname = $0) =~ s,.*/,,;
$max_errors = $lib'max_errors;
$max_requests = $lib'max_requests;
$runnable_mailers = $lib'runnable_mailers;
$allow_voting = undef;

$SIG{'PIPE'} = 'IGNORE';

while ($_ = $ARGV[0], /^-/) {
    shift;
    if (/^-queuedir$/) {
	die "Missing argument to \"-queuedir\" option.\n" if (@ARGV == 0);
	$lib'queuedir = shift;
	next;
    }
    if (/^-db$/) {
	die "Missing argument to \"-db\" option.\n" if (@ARGV == 0);
	$lib'request_db = shift;
	next;
    }
    if (/^-mailer$/) {
	die "Missing argument to \"-mailer\" option.\n" if (@ARGV == 0);
	$mailer = shift;
	next;
    }
    if (/^-logname$/) {
	die "Missing argument to \"-logname\" option.\n" if (@ARGV == 0);
	$logname = shift;
	next;
    }
    if (/^-logservice$/) {
	die "Missing argument to \"-logservice\" option.\n" if (@ARGV == 0);
	$lib'logservice = shift;
	next;
    }
    if (/^-votelog$/) {
	die "Missing argument to \"-votelog\" option.\n" if (@ARGV == 0);
	$lib'vote_log = shift;
	next;
    }
    if (/^-dontstop$/) {
	$dont_stop++;
	next;
    }
    if (/^-restart$/) {
	$restart++;
	next;
    }
    if (/^-debug$/) {
	$debug++;
	next;
    }
    die "Unknown option \"$_\".\n";
}

&openlog($logname, 'pid', $lib'logservice);

&check_load_average() || exit -1;

&syslog('debug', "starting up");

if (! -d $archive_root) {
    &syslog('err', 
	    "archive root directory `$archive_root' missing.... exiting");
    exit -1;
}

$lockfile = &lib'make_file_name("queue-lock");
$lockpat = &lib'make_file_pattern("queue-lock");
$datapat = &lib'make_file_regexp("data");

while (1) {
    @lockfiles = <$lib'queuedir/$lockpat>;

    if (@lockfiles > 1) {
	&syslog('err', "more than one lock file for $logname.... exiting");
	exit -1;
    }
    elsif (@lockfiles) {
	($lockpid = do $lockfiles[0]) || next;
	if ((! kill(0, $lockpid)) && ($! == &ESRCH)) {
	    if ($restart) {
		&syslog('notice', "Process $lockpid appears to have died, " .
			"removing $lockfiles[0]");
		unlink($lockfiles[0]);
		next;
	    }
	    else {
		&syslog('err', "Process $lockpid appears to have died; " .
			"check server!");
		exit -1;
	    }
	}
	&syslog('notice', "$logname already running.... exiting");
	exit;
    }
    else {
	last;
    }
}
undef @lockfiles;

&lib'get_lock($lockfile);

chdir($lib'queuedir) || &abort("Changing to $lib'queuedir: $!");

opendir(QUEUEDIR, $lib'queuedir) || 
    &abort("Opening directory $lib'queuedir: $!");

@queue_files = sort grep(/$datapat/o, readdir(QUEUEDIR));

closedir(QUEUEDIR);

&lib'clear_lock();

&lib'db_init();

umask(007);
chdir($archive_root) || &abort("Changing to $archive_root: $!");

&syslog('debug', "files: @queue_files");

&init_voting();

queue_file: foreach $queue_file (@queue_files) {

    if ((! $dont_stop) && (-f "$lib'queuedir/queue-stop")) {
	&syslog('notice', "Found queue-stop file, exiting");
	last;
    }

    if (! &check_load_average()) {
	last;
    }

    &syslog('debug', "processing $queue_file");

    # reset the defaults

    $maxsize = $lib'maxsize ? ($lib'maxsize - 1000) : 0;
    $sent_files = 0;
    $errors = 0;
    $sendmail_from = $reply_to = $sender = $from = undef;
    $message = "";
    %sent_files = ();
    $in_group = 0;
    $quitted = 0;
    $vote_output = undef;
    $vote_errors = undef;
    $dir = undef;

    &save($queue_file, $lib'queuedir);

    # Determine return address

    eval {
      open(QUEUE_FILE, "$lib'queuedir/$queue_file") 
	|| &abort("opening $queue_file: $!");
      if (! ($_ = <QUEUE_FILE>)) {
	if ($!) {
	  &abort("Reading $queue_file: $!");
	} else {
	  &syslog('err', "empty queue file %s", $queue_file);
	  next;
	}
      }
      if (/^From ([^ ]+)/) {
	$sendmail_from = $1;
	chop $sendmail_from;
	$_ = <QUEUE_FILE>;
      }
      ($_, %headers) = &header'parse($_, "main'QUEUE_FILE");

      $reply_to = &header'field_value('reply-to', %headers);
      $from = &header'field_value('from', %headers);
      $sender = &header'field_value('sender', %headers);
      $to = &header'field_value('to', %headers);
      $cc = &header'field_value('cc', %headers);

      # rtfm's perl (4.0.1.8) is too old to have the "lc" function.
      ($lcsa = $server_addr) =~ tr/A-Z/a-z/;
      ($lcfrom = $from) =~ tr/A-Z/a-z/;

      if ($lcfrom eq $lcsa) {
	&syslog('err', "message %s is from mail server; ignoring",
		$queue_file);
	goto unlink_and_next;
      }

      # Make sure the mail was actually to us, not to a list.
      if (($to !~ /mail-server/i) && ($cc !~ /mail-server/i)) {
	&syslog('info', "message %s not actually for us; ignoring",
		$queue_file);
	goto unlink_and_next;
      }

      # Ignore ezmlm subscription confirmations.
      if ($from =~ /-help@/ && $reply_to =~ /-sc\.\d+\./) {
	&syslog('info',
		"address \"%s\" is a subscription confirmation; ignoring",
		$from);
	goto unlink_and_next;
      }

      if (($from =~ /postmaster@bloom-picayune\.mit\.edu/i) ||
	  ($from =~ /root@bloom-picayune\.mit\.edu/i) ||
	  ($from =~ /postmaster@charon\.mit\.edu/i) ||
	  ($from =~ /root@charon\.mit\.edu/i) ||
	  ($from =~ /postmaster@penguin-lust\.mit\.edu/i) ||
	  ($from =~ /webmaster@penguin-lust\.mit\.edu/i) ||
	  ($from =~ /root@penguin-lust\.mit\.edu/i) ||
	  ($from =~ /postmaster@rtfm\.mit\.edu/i) ||
	  ($from =~ /root@rtfm\.mit\.edu/i) ||
	  ($from =~ /webmaster@rtfm\.mit\.edu/i)) {
	&syslog('info',
		"address \"%s\" is a local administrator address; ignoring",
		$from);
	goto unlink_and_next;
      }

      if (($from =~ /postmaster@/i) || ($from =~ /webmaster@/i)) {
	&syslog('info', "address \"%s\" is an administrator address; ignoring",
		$from);
	goto unlink_and_next;
      }

      if (($lcfrom eq "arcturianone@earthlink.net") ||
	  ($lcfrom eq "arcturianone@mail.earthlink.net") ||
	  ($from =~ /@e-wollmann\.com$/i) ||
	  ($from =~ /@astroconsulting\.com$/i) ||
	  ($from =~ /mengqiu_cn@cmmail\.com/i) ||
	  ($from =~ /itcenter@yahoogroups\.com/i) ||
	  ($from =~ /admissionsinfo@reg\.ucsd\.edu/i) ||
	  ($from =~ /webmaster@aol\.net/i) ||
	  ($from =~ /wmcfeed@microsoft\.com/i) ||
	  ($from =~ /@pcappliancerepair\.com/i) ||
	  ($from =~ /imailsrv@mail\.winace\.com/i) ||
	  ($from =~ /HELP@DELLEPRO\.COM/i) ||
	  ($from =~ /^majordomo/i) ||
	  ($from =~ /Sales@mypharmacyshop\.com/i) ||
	  ($from =~ /noone@csc\.ncsu\.edu/i) ||
	  ($from =~ /licensing@vpn\.cslb\.ca\.gov/i) ||
	  ($from =~ /answers@crystaldecisions\.com/i) ||
	  ($from =~ /@yahoogroups.com$/i) ||
	  ($from =~ /register@opera\.com/i) ||
	  ($from =~ /anonymous\.ftp\.mail@ella\.hu/i) ||
	  ($from =~ /bcgadmin@normgrills\.net/i)) {
	goto unlink_and_next;
      }

      if (! ($address = ($reply_to || $from || $sendmail_from || $sender))) {
	&syslog('err', "no return address in %s", $queue_file);
	next;
      } else {
	$address =~ s/\n\s*/ /g;
	($address = &check_address($address)) || goto unlink_and_next;
	&syslog('debug', "address: %s", $address);
      }

      if (! &lib'check_db($address, $queue_file)) {
	next;
      }

      for ( ; $_; $_ = <QUEUE_FILE>) {
	$prefix = "  ";

	if (($max_errors && ($errors >= $max_errors)) ||
	    ($max_requests && ($sent_files >= $max_requests))) {
	  local($type) = ($errors >= $max_errors) ? "error" : "request";
	  $message .= "${prefix}[$type limit reached; remainder of " .
	    "message ignored]\n";
	  &syslog('info', 
		  "%s limit reached (%s for %s); punting rest of message",
		  $type, $queue_file, $address);
	  last;
	}

	if ($quitted) {
	  $message .= "$prefix$_";
	  next;
	}
	chop;
	&syslog('debug', "message line: %s", $_);
	if (/(^\s*\#|^\s*$)/) {
	} elsif (/^\s*path\s+/i) {
	  local($newaddr) = $';
	  if ($in_group) {
	    &syslog('debug', "group: end at address change");
	    if (! &flush_group()) {
	      next queue_file;
	    }
	  }
	  $address = $newaddr;
	  ($address = &check_address($address)) || goto unlink_and_next;
	  &syslog('debug', "path: %s", $address);
	  $prefix = "+ ";
	} elsif (/^\s*index(\s+|$)/i) {
	  local($retval);
	  local($file) = $_;

	  if ($file =~ s/^\s*index\s+([^\s]|[^\s].*[^\s])\s*$/$1/i) {
	    $file = $file . "/index";
	  } else {
	    $file = "index";
	  }
	  if ($dir) {
	    $file = $dir . $file
	  }

	  if ($sent_files{$file}) {
	    &syslog('debug', "repeat: %s", $_);
	    $prefix = "R ";
	  } elsif (! ($retval = &process_file_request($_, $file))) {
	    next queue_file;
	  } elsif ($retval == -1) {
	    $errors++;
	    $prefix = "- ";
	  } else {
	    $sent_files++;
	    $sent_files{$file}++;
	    $prefix = "+ ";
	  }
	} elsif (/^\s*help\s*$/i) {
	  local($retval);

	  if ($sent_files{"help"}) {
	    &syslog('debug', "repeat: %s", $_);
	    $prefix = "R ";
	  } elsif (! ($retval = &process_file_request($_, "help"))) {
	    next queue_file;
	  } elsif ($retval == -1) {
	    $errors++;
	    $prefix = "- ";
	  } else {
	    $sent_files++;
	    $sent_files{"help"}++;
	    $prefix = "+ ";
	  }
	} elsif (/^\s*setdir\s+\/?(.*[^\s])\/?\s*$/i) {
	  if (! -d $1) {
	    $errors++;
	    $prefix = "- ";
	  } else {
	    $prefix = "+ ";
	  }
	  # Set directory even if there's an error, to prevent send commands
	  # (e.g. wildcards) from succeeding in the old directory.
	  $dir = $1 . "/";
	} elsif (/^\s*send\s+(.*[^\s])\s*$/i) {
	  local($retval);
	  local($file);

	  if ($dir) {
	    $file  = $dir.$1;
	  } else {
	    $file = $1;
	  }
	  if ($sent_files{$file}) {
	    &syslog('debug', "repeat: %s", $_);
	    $prefix = "R ";
	  } elsif (! ($retval = &process_file_request($_, $file))) {
	    next queue_file;
	  } elsif ($retval == -1) {
	    $errors++;
	    $prefix = "- ";
	  } else {
	    $sent_files++;
	    $sent_files{$file}++;
	    $prefix = "+ ";
	  }
	} elsif (/^\s*size\s+([0-9]+)\s*$/i) {
	  &syslog('debug', "maxsize: $1");
	  if ($in_group) {
	    &syslog('debug', "group: end at size change");
	    if (! &flush_group()) {
	      next queue_file;
	    }
	  }
	  $maxsize = $1;
	  if ($maxsize) {
	    $maxsize = $minsize if ($maxsize < $minsize);
	    $maxsize -= 1000;
	  }
	  $prefix = "+ ";
	} elsif ($allow_voting && /^\s*vote\s+/i) {
	  if ($in_group) {
	    &syslog('debug', "group: end at vote");
	    if (! &flush_group()) {
	      next queue_file;
	    }
	  }
	  ($vote = $_) =~ s/^\s*vote\s+//i;
	  $vote = join(' ', split(' ', $vote));
	  $vote =~ tr/A-Z/a-z/;
	  if ($sent_files{"voting/$vote"}) {
	    &syslog('debug', "repeat: %s", $_);
	    $prefix = "R ";
	  } elsif ($vote =~ /^(help|index|-listing-)$/i) {
	    if ($sent_files{"voting/help"}) {
	      &syslog('debug', "repeat: %s", $_);
	      $prefix = "R ";
	    } else {
	      &syslog('info', "sent %s // voting/%s", $address, $vote);
	      if (! &deliver("\"$_\"", 0, 
			     &make_string_file($votes{"help"}))) {
		next queue_file;
	      }
	      $prefix = "+ ";
	      $sent_files{"voting/help"}++;
	      $sent_files++;
	    }
	  } elsif ($votes{$vote}) {
	    $vote_output .= $votes{$vote};
	    &log_vote($address, $vote);
	    $prefix = "+ ";
	    $sent_files{"voting/$vote"}++;
	    $sent_files++;
	  } else {
	    &syslog('info', "bad vote %s // %s", $address, $vote);
	    $vote_errors .= "$_";
	    if ($expired_votes{$vote}) {
	      $vote_errors .= " (not received during voting period)";
	    }
	    $vote_errors .= "\n";
	    $sent_files++;
	    $errors++;
	    $prefix = "- ";
	  }
	} elsif (/^\s*group\s*$/i) {
	  $in_group++;
	  $prefix = "+ ";
	  &syslog('debug', "group: begin");
	} elsif (/^\s*endgroup\s*$/i) {
	  &syslog('debug', "group: end");
	  if (! &flush_group()) {
	    next queue_file;
	  }
	  $prefix = "+ ";
	} elsif (/^\s*quit\s*$/i || /^-- $/) {
	  &syslog('debug', "quit");
	  $quitted++;
	  $prefix = "+ ";
	} else {
	  $prefix = "X ";
	  $errors++;
	  &syslog('debug', "unknown");
	}
	$message .= "$prefix$_\n";
      }

      close(QUEUE_FILE);

      if ($in_group) {
	&syslog('debug', "group: end at message end");
	if (! &flush_group()) {
	  next queue_file;
	}
      }

      if ($vote_output || $vote_errors) {
	if (! &deliver("vote acknowledgement", 0,
		       &make_group(undef),
		       &make_string_file($vote_output ? "The following votes have been received and recorded:\n\n$vote_output\n" : ""),
		       &make_string_file($vote_errors ? "The following invalid votes were encountered:\n\n$vote_errors" : ""),
		       &make_endgroup())) {
	  next queue_file;
	}
      }

      if ($errors) {
	if (! &error_report($message)) {
	  next queue_file;
	}
      } elsif (! $sent_files) {
	if (! &empty_report()) {
	  next queue_file;
	}
      } elsif ($max_requests && ($sent_files >= $max_requests)) {
	if (! &max_request_report($message)) {
	  next queue_file;
	}
      }

    };				# end of eval
      if ($@) {
	&syslog("error doing $queue_file : $@");
      }
unlink_and_next:

    unlink("$lib'queuedir/$queue_file");
}

while (&cleanup_mailers()) {}

&syslog('debug', "cleaning up");

unlink(<$lib'queuedir/$lockpat>);
&lib'cleanup();			# *** this exits

sub abort {
    local($package, $filename, $line) = caller;
    &syslog('err', "%s at %s line %d", $_[0], $filename, $line);
    unlink("$lib'queuedir/$lockfile");
    unlink(<$tempfile.*>);
    close(VOTELOG) if ($vote_log_opened);
    die "$_[0] at $filename line $line.\n";
}

sub save {
    local($queue_file, $queue_dir) = @_;

    unlink("$queue_dir/old/$queue_file");
    link("$queue_dir/$queue_file", "$queue_dir/old/$queue_file")
	|| &abort("Linking old/$queue_file to $queue_file: $!");
    &syslog('debug', "saved $queue_file");
}

# Returns: 0 or undef for a system error which should cause the script to
# skip to the next queue file, -1 for a failure to find the desired file(s),
# or anything else to indicate success.

sub process_file_request {
    local($command, $file) = @_;
    local(@files);
    local($retval);

    if (@files = &find_files($file)) {
	&syslog('info', "sent %s // %s", $address, $file);
	$retval = &deliver("\"$command\"", 1, @files);
    }
    else {
	&syslog('info', "fail %s // %s", $address, $file);
	$retval = -1;
    }
    $retval;
}

sub find_files {
    local($file, $name_files) = @_;
    local($headpath, $tailpath, $sendscript);
    local($_);
    local(@files);
    local($docat, $dolisting, $domatch);

    if ($file eq "help") {
	if (! $help_message) {
	    &abort("No help message!") if (! $lib'helpfile);
	    $help_message = do $lib'helpfile;
	    &abort("$lib'helpfile returned false!") if (! $help_message);
	}
	return(&make_string_file($help_message));
    }

    return () if ($file =~ m,(/|^)\.\.(/|$),);

    $file =~ s,^/,,;
    $file =~ s,^pub/,,;

    if ($file =~ m,^(.*)/([^/]*)$,) {
	$headpath = $1;
	$tailpath = $2;
    }
    else {
	$headpath = ".";
	$tailpath = $file;
    }

    if (-x ($sendscript = "$lib'sendscriptdir/$headpath/.sendscript")) {
    }
    elsif (-x ($sendscript = "$lib'sendscriptdir/$file/.sendscript")) {
	$headpath = $file;
	$tailpath = "-listing-";
	$file = "$headpath/$tailpath";
    }
    else {
	$sendscript = undef;
    }

    if ($sendscript) {
	local($temp) = &new_file();
	local($arg) = &shell_protect($tailpath);
	local($dir) = &shell_protect($headpath);

	open(TEMP, ">$temp") || &abort("Opening $temp for write: $!");
	open(SENDSCRIPT, "(cd $dir; $lib'sendscriptdir/$dir/.sendscript $arg)|") 
	    || &abort("Opening pipe from $headpath/.sendscript $tailpath: $!");
	while (<SENDSCRIPT>) {
	    print TEMP $_ || &abort("Writing to $temp: $!");
	}
	close(TEMP);
	close(SENDSCRIPT);
	if ($?) {
	    &syslog('info',
		    "%s/.sendscript %s non-zero exit status", $headpath,
		    $tailpath);
	    unlink($temp);
	    return ();
	}
	else {
	    &syslog('debug', "sendscript: %s/.sendscript %s",
		    $headpath, $tailpath);
	}
	return(&make_disk_file($name_files ? $file : undef, $temp));
    }

    if (-f $file) {
	$docat++;
	$dolisting++ if (($tailpath =~ /^index$/i) &&
			 (-f "$headpath/.dolisting"));
    }
    elsif (-f "$file.Z") {
	$docat++;
	$file .= ".Z";
	&syslog('debug', "compressed: %s", $file);
    }
    elsif (($file =~ /\.Z$/) && (-f $`)) {
	$docat++;
	$file = $`;
    }
    elsif ((($tailpath =~ /^index$/i) || ($tailpath =~ /^-listing-$/i)) &&
	   (-d $headpath)) {
	$dolisting++;
    }
    elsif (-d $file) {
	$headpath = $file;
	$tailpath = "-listing-";
	$dolisting++;
    }
    elsif ($tailpath eq "*") {
	local($dir) = &shell_protect($headpath);
	local($f);
	local(@sub_files);
	local(@names) = <$dir/*>;

	for (@names) {
	    @sub_files = &find_files($_, 1);
	    if (@sub_files) {
		push(@files, @sub_files);
	    }
	}
	grep(s,.*/,,, @names);
	&syslog('debug', "domatch: %s (%s)", $headpath, "@names");
	return(@files);
    }


    push(@files, &make_group($name_files ? $file : undef)) if ($dolisting);

    if ($docat) {
	if (! -r $file) {
	    &syslog('notice', "unreadable file %s", $file);
	    return ();
	}

	push(@files, &make_disk_file($name_files ? $file : undef, $file));
	&syslog('debug', "docat: %s", $file);
    }

    if ($dolisting) {
	local($dir) = &shell_protect($headpath);
	local($cmd);

	if (! -r $headpath) {
	    &syslog('notice', "unreadable directory %s", $headpath);
	    return ();
	}

	&syslog('debug', "dolisting: %s", $headpath);
	push(@files, &make_string_file("\n")) if ($docat);
	if ($headpath eq ".") {
	    push(@files, &make_string_file("The following is a list of files in the top-level archive.\n"));
	}
	else {
	    push(@files, &make_string_file("The following is a list of files in the $headpath archive.\n"));
	}
	push(@files, &make_string_file("\(A \"d\" as the first character of a line indicates a subarchive.\)\n\n"));
	$cmd = "(cd $dir; /bin/ls -l)";
	push(@files, &make_command_file($cmd, $cmd));
    }

    push(@files, &make_endgroup()) if ($dolisting);

    return(@files);
}

sub flush_group {
    local($retval) = 1;

    $in_group = 0;
    if (@batch_files) {
	$retval = &deliver_files("batched output", 1, @batch_files);
	@batch_files = ();
    }
    $retval;
}

sub deliver {
    local($subject, $split, @files) = @_;
    local($file, $fn);
    local($group, $newgroup, $groupname, @my_batched_files);

    while ($file = shift @files) {
	if (&is_group($file)) {
	    if (! $group) {
		$groupname = &file_name($file);
	    }
	    else {
		$groupname = undef;
	    }
	    $group++;
	    $newgroup++;
	    next;
	}

	if (&is_endgroup($file)) {
	    $group--;
	    if ((! $group) && @my_batched_files) {
		if (! &deliver_files($groupname ? "$subject -- $groupname" :
				     $subject, $split, @my_batched_files)) {
		    return undef;
		}
		@my_batched_files = ();
	    }
	    next;
	}

	if ($in_group) {
	    if ($group) {
		if ($newgroup) {
		    push(@batch_files,
			 &make_string_file($groupname ? 
				       "Subject: $subject -- $groupname\n\n" :
					   "Subject: $subject\n\n"));
		    $newgroup = undef;
		}
		push(@batch_files, $file);
		push(@batch_files, &make_string_file("\n"));
		next;
	    }
	    else {
		$fn = &file_name($file);
		push(@batch_files, 
		     &make_string_file($fn ? "Subject: $subject -- $fn\n\n" : 
				       "Subject: $subject\n\n"));
		push(@batch_files, $file);
		push(@batch_files, &make_string_file("\n"));
		next;
	    }
	}
	else {
	    if ($group) {
		push(@my_batched_files, $file);
		next;
	    }
	    else {
		$fn = &file_name($file);
		if (! &deliver_files($fn ? "$subject -- $fn" :
			             $subject,
				     $split, $file)) {
		    return undef;
		}
		next;
	    }
	}
    }

    1;
}

sub reap_mailer {
    local($pid) = @_;
    local($status);

    if ($running_mailers{$pid}) {
	if ($?) {
	    $status = $? >> 8;
	    &syslog('err', "$mailer (for $running_mailers{$pid}) exited with status $status");
	}
	print "Reaped mailer $pid.\n" if ($debug);
	delete $running_mailers{$pid};
	1;
    }
    else {
	$exit_stats{$pid} = $? >> 8;
	0;
    }
}

sub cleanup_mailers {
    local($_);
    local($cleaned);

# XXX I really want to use WNOHANG here, but I can't do that because
# the RT doesn't support wait4 or waitpid, so I have to use signals instead.
# 
# I have a wait here before I do the killing below, so that I don't busy-wait,
# since at least one process must die before I'll go through the loop below.
# XXX now, however, that this will interfere with any other code in this script
# that's using wait.  This is unavoidable.
    if (($_ = wait) < 0) {
	%running_mailers = ();
    }
    else {
	$cleaned += &reap_mailer($_);
    }
    for (keys %running_mailers) {
	if ((! kill(0, $_)) && ($! == &ESRCH)) {
	    waitpid($_, 0);
	    $cleaned += &reap_mailer($_);
	}
    }
    if ($cleaned) {
	print "Cleaned up $cleaned mailers.\n" if ($debug);
	$cleaned;
    }
    elsif (scalar(keys %running_mailers)) {
	&cleanup_mailers();
    }
    else {
	print "No mailers to clean up.\n" if ($debug);
	0;
    }
}

sub setup_mailer {
    local($address, $subject) = @_;
    local($write_handle);
    local($_);
    local($waiting);

    printf("%d running mailers at start of setup_mailer.\n", 
	   scalar(keys %running_mailers))
	if ($debug);

    while (scalar(keys %running_mailers) >= $runnable_mailers) {
	&syslog('info', "too many mailers running; waiting") if ($waiting);
	&cleanup_mailers();
	$waiting++;
    }

    &lib'add_db($address, 1);

    $write_handle = &get_handle();

    pipe(MAILREAD, $write_handle);

# Using fork explicitly, rather than opening |-, because I want to be
# able to get exit statuses in cleanup_mailers with "wait" and "waitpid".

    while (! defined($pid = fork)) {
	$waiting = &cleanup_mailers();
	if ($waiting) {
	    print("Error forking to start mailer ($!); reaped old mailers and trying again.\n")
		if ($debug);
	    &syslog('notice', "error forking to start mailer (%m); reaped old mailers and trying again");
	}
	else {
	    &abort("Forking to start mailer: $!");
	}
    }

    if ($pid) {
	close(MAILREAD);
	$running_mailers{$pid} = "$queue_file for $address";

	print($write_handle "From: $server_addr
To: $address
Subject: $subject
Reply-To: $server_addr
", $lib'precedence_junk ? "Precedence: junk\n" : "",
"X-Problems-To: $admin@$host

")
	    || &abort("Writing to $mailer: $!");

	print "Started mailer $pid.\n" if ($debug);

	return $write_handle;
    }
    else {
	close($write_handle);
	open(STDIN, "<&MAILREAD");
	exec $mailer || die "Exec'ing $mailer: $!.\n";
    }
}

sub close_mailer {
    &free_handle($_[0]);
    close($_[0]);
}

sub deliver_files {
    local($subject, $split, @files) = @_;
    local($file, $handle);
    local($_);
    local($mhandle);
    local($parts);

    if ($maxsize && $split) {
	local($cursize, $part);

	$cursize = 0;
	$parts = 1;
	foreach $file (@files) {
	    $handle = &open_file($file);
	    while ($_ = &read_file($handle)) {
		if ($cursize >= $maxsize) {
		    $parts++;
		    $cursize = 0;
		}
		$cursize += length($_);
	    }
	    &close_file($handle);
	}
    }

    if ($maxsize && $split && ($parts > 1)) {
	local($cursize, $part);

	$part = 0;
	$cursize = $maxsize;
	$mhandle = &get_handle();
	open($mhandle, ">/dev/null");

	foreach $file (@files) {
	    $handle = &open_file($file);
	    while ($_ = &read_file($handle)) {
		if ($cursize >= $maxsize) {
		    $cursize = 0;
		    $part++;
		    print($mhandle "-----cut here-----\n")
			|| &abort("Writing to mailer: $!");
		    &close_mailer($mhandle);
		    $mhandle = &setup_mailer($address, 
					     "$subject_tag: $subject (part $part of $parts)");
		    print $mhandle "-----cut here-----\n"
			|| &abort("Writing to mailer: $!");
		}
		print $mhandle $_
		    || &abort("Writing to mailer: $!");
		$cursize += length($_);
	    }
	    &close_file($handle);
	}

	print $mhandle "-----cut here-----\n"
	    || &abort("Writing to mailer: $!");
	&close_mailer($mhandle);
    }
    else {
	$mhandle = &setup_mailer($address, "$subject_tag: $subject");
	print $mhandle "-----cut here-----\n"
	    || &abort("Writing to $mailer: $!");
	foreach $file (@files) {
	    $handle = &open_file($file);
	    while ($_ = &read_file($handle)) {
		print($mhandle $_)
		    || &abort("Writing to $mailer: $!");
	    }
	    &close_file($handle);
	}
	print $mhandle "-----cut here-----\n"
	    || &abort("Writing to $mailer: $!");
	&close_mailer($mhandle);
    }
    1;
}

sub empty_report {
    local($retval);

    &syslog('debug', "empty: %s", $address);
    $retval = &deliver("no commands found", 0,
		       &make_group(undef),
		       &make_string_file(
"No commands were found in your mail to the mail server.  A copy of the
help message for the server is therefore appended below.\n\n"),
		       &find_files("help"),
		       &make_endgroup());

    $retval;
}

sub error_report {
    local($message) = @_;
    local($retval);

    chop $message;
    &syslog('debug', "error: %s", $address);
    $retval = &deliver("error report", 0,
		       &make_group(undef),
		       &make_string_file(<<"EOF"),
Errors were encountered by the mail server while parsing your message to it.
An annotated copy of your message is below.  The annotations of each command
line are as follows (lines not annotated were not treated as commands by the
server):
  -     Could not be processed (e.g., missing file, illegal vote).
  X     Is not valid.
  R     Skipped because it is a repeat of a previous request in
        the same message.
  +     Successfully interpreted.
EOF
		       &make_string_file($max_errors ? <<"EOF" : ""),
Note that the server ignores the remainder of a message if it encounters
$max_errors errors in it.
EOF
		       &make_string_file($max_requests ? <<"EOF" : ""),
Furthermore, only the first $max_requests requests in a message are honored.
EOF
		       &make_string_file(<<"EOF"),

Output of successful commands will be sent under separate cover.

$message

The most common error in requests to the mail server is specifying an
incorrect file name.  Other common errors include:
  * incorrect case in file names (case IS significant when requesting files);
  * including a signature or other extra text without a "quit" command
    before it.

Commands should be sent to "$server_addr".

For general information on using the mail server, send a message
to "$server_addr" with a body of:

	help

For a listing of top-level files and directories available at this
site, send a message to "$server_addr" with a body of:

	index

Send mail to "$admin@$host" to contact a real person
(We have a limited amount of time to answer questions, so please read
the help file before sending questions.)
EOF
		       &make_endgroup());
    $retval;
}

sub max_request_report {
    local($message) = @_;
    local($retval);

    chop $message;
    &syslog('debug', "max_request: %s", $address);
    $retval = &deliver("too many requests", 0,
		       &make_group(undef),
		       &make_string_file(<<"EOF"),
Part of your message to the mail server was ignored, because it contained
more than $max_requests requests.  An annotated copy of your message is below.  The
annotations of each command line are as follows (lines not annotated were not
treated as commands by the server):
  -     Could not be processed (e.g., missing file, illegal vote).
  X     Is not valid.
  R     Skipped because it is a repeat of a previous request in
        the same message.
  +     Successfully interpreted.
EOF
		       &make_string_file(<<"EOF"),

Output of successful commands will be sent under separate cover.

$message
EOF
		       &make_endgroup());
    $retval;
}

sub new_file {
    local($newfile);

    ++$unique_id;
    $newfile = "$tempfile.$unique_id";

    $newfile;
}

sub shell_protect {
    local($str) = @_;

    $str =~ s/(\W)/\\$1/g;

    $str;
}

sub file_name {
    local($file) = @_;
    local($retval);

    if ($file =~ /^.*\n(.+)\n/i) {
	$retval = $1;
    }
    else {
	$retval = undef;
    }

    $retval;
}

sub open_file {
    local($file) = $_[0];
    local($handle);
    local($retval);
    local($pid);

    if ($file =~ /^string\n/i) {
	$retval = $file;
    }
    elsif ($file =~ s/^file\n(.*)\n//i) {
	if ($file =~ /\.F$/) {
	    $handle = &get_handle();
	    while (! defined($pid = open($handle, "-|"))) {
		print "Error forking ($!); attempting to reap mailers.\n"
		    if ($debug);
		next if (&cleanup_mailers());
		&abort("Forking to fcat $file: $!");
	    }
	    if ($pid) {
		$retval = "command\n$1\n$handle";
		$child_pids{$handle} = $pid;
	    }
	    else {
		exec("/rtfm/bin/fcat", $file) || 
		    die "Exec'ing fcat: $!.\n";
	    }
	}
	elsif ($file =~ /\.Z$/) {
	    $handle = &get_handle();
	    while (! defined($pid = open($handle, "-|"))) {
		print "Error forking ($!); attempting to reap mailers.\n"
		    if ($debug);
		next if (&cleanup_mailers());
		&abort("Forking to zcat $file: $!");
	    }
	    if ($pid) {
		$retval = "command\n$1\n$handle";
		$child_pids{$handle} = $pid;
	    }
	    else {
		exec("/usr/ucb/zcat", $file) || 
		    die "Exec'ing zcat: $!.\n";
	    }
	}
	elsif ($file =~ /\.gz$/) {
	    $handle = &get_handle();
	    while (! defined($pid = open($handle, "-|"))) {
		print "Error forking ($!); attempting to reap mailers.\n"
		    if ($debug);
		next if (&cleanup_mailers());
		&abort("Forking to gzcat $file: $!");
	    }
	    if ($pid) {
		$retval = "command\n$1\n$handle";
		$child_pids{$handle} = $pid;
	    }
	    else {
		exec("/usr/bin/zcat", $file) || 
		    die "Exec'ing zcat: $!.\n";
	    }
	}
	else {
	    $handle = &get_handle();
	    open($handle, $file) 
		|| &abort("opening $file: $!");
	    $retval = "file\n$1\n$handle";
	}
    }
    elsif ($file =~ s/^command\n(.*)\n//i) {
	local($command) = $1;
	$handle = &get_handle();
	while (! defined($pid = open($handle, "-|"))) {
	    print "Error forking ($!); attempting to reap mailers.\n"
		if ($debug);
	    next if (&cleanup_mailers());
	    &abort("Forking to $file: $!");
	}
	if ($pid) {
	    $retval = "command\n$command\n$handle";	
	    $child_pids{$handle} = $pid;
	}
	else {
	    exec $file || die "Exec'ing $file: $!.\n";
	}
    }
    else {
	die "Unknown file type for $file in open_file";
    }

    $retval;
}

sub read_file {
    local($file) = @_;

    if ($file =~ /^(string\n.*\n)/i) {
	$_[0] = $1;
	if ($' eq "") {
	    undef;
	}
	else {
	    $';
	}
    }
    elsif ($file =~ /^(file|command)\n.*\n/i) {
	<$'>;
    }
    else {
	die "Unknown file type for $file in read_file";
    }
}

sub close_file {
    local($file) = @_;
    local($exit_stat);

    if ($file =~ /^string\n/i) {
    }
    elsif ($file =~ /^file\n.*\n/i) {
	close($');
	&free_handle($');
    }
    elsif ($file =~ /^command\n(.*)\n/i) {
	local($command) = $1;
	close($');
	$exit_stat = $?;
	if ($exit_stat) {
	    if (($! == &ECHILD) && defined($exit_stats{$child_pids{$'}})) {
		$exit_stat = $exit_stats{$child_pids{$'}};
	    }
	}
	&abort("Closing command $command: $!") if ($exit_stat);
	delete $exit_stats{$child_pids{$'}};
	delete $child_pids{$'};
	&free_handle($');
    }
    else {
	die "Unknown file type for $file in close_file";
    }
}

sub make_disk_file {
    if (@_ == 2) {
	"file\n$_[0]\n$_[1]";
    }
    else {
	"file\n$_[0]\n$_[0]";
    }
}

sub make_string_file {
    "string\n\n$_[0]";
}

sub make_command_file {
    "command\n$_[0]\n$_[1]";
}

sub make_group {
    "group\n$_[0]\n";
}

sub make_endgroup {
    "endgroup\n\n";
}

sub is_group {
    $_[0] =~ /^group/;
}

sub is_endgroup {
    $_[0] =~ /^endgroup/;
}

sub init_voting {
    local($width, $ng);
    local(@votes, %starts, %ends);
    local($votelist);
    local($time) = time;
    local($_, @split);

    return if (! $lib'vote_config);

    $allow_voting++;

    open(VOTECONFIG, $lib'vote_config) || goto no_votes;

    while (<VOTECONFIG>) {
	next if (/^\s*#/ || /^\s*$/);
	@split = split;
	push(@votes, $split[0]);
	$starts{$split[0]} = $split[1] if ($split[1]);
	$ends{$split[0]} = $split[2] if ($split[2]);
    }

    close(VOTECONFIG);

    $votes{"help"} = "The following votes are currently valid:\n\n";

    foreach $ng (@votes) {
	if (! ((defined($starts{$ng}) && ($starts{$ng} > $time)) ||
	       (defined($ends{$ng}) && ($ends{$ng} < $time)))) {
	    $width = length("$ng ABSTAIN") + 1;
	    $votelist .= sprintf("%-${width}s%s\n", "$ng YES", 
				 "Vote FOR $ng.");
	    $votelist .= sprintf("%-${width}s%s\n", "$ng NO",
				 "Vote AGAINST $ng.");
	    $votelist .= sprintf("%-${width}s%s\n%-${width}s%s\n",
				 "$ng ABSTAIN", 
				 "Cancel a previous vote for or against",
				 "", "$ng.");
	    $votelist .= "\n";

	    $votes{"$ng yes"} = "FOR $ng.\n";
	    $votes{"$ng no"} = "AGAINST $ng.\n";
	    $votes{"$ng abstain"} = 
		"Cancellation of previous $ng vote (if any).\n";
	}
	else {
	    $expired_votes{"$ng yes"} = $expired_votes{"$ng no"} =
		$expired_votes{"$ng abstain"} = 1;
	}
    }

no_votes:

    if ($votelist) {
	$votes{"help"} = "The following votes are currently valid:\n\n" .
	    $votelist . "To vote, send a mail message to $server_addr with the
command \"vote your-vote\" (without the quotes) in the body of your mail
message; for example, \"vote comp.answers yes\".  If your mail message
contains a signature, then be sure to put the command \"quit\" before it to
prevent the mail server from being confused.\n";
    }
    else {
	$votes{"help"} = "No votes are currently valid.\n";
    }
}

sub get_handle {
    local($handle);

    if (! @free_handles) {
	$handle = $handle_id++;
    }
    else {
	$handle = shift @free_handles;
    }
    $handle;
}

sub free_handle {
    local($handle) = @_;

    unshift(@free_handles, $handle);
}

sub log_vote {
    local($address, $vote) = @_;
    local($oldselect);

    if (! $vote_log_opened) {
	open(VOTELOG, ">>$lib'vote_log") ||
	    &abort("Opening $lib'vote_log for write: $!");
	$oldselect = select(VOTELOG); $| = 1; select($oldselect);
	$vote_log_opened++;
    }

    &syslog('info', "good vote %s // %s", $address, $vote);
    print(VOTELOG $address, " // ", $vote, "\n") ||
	&abort("Writing to $lib'vote_log: $!");
}

sub check_address {
    local($address) = @_;
    local($same_address);
    local($_);

    return undef if (!($address =~ /[@!]/));
    return undef if ($address =~ /^(owner-)?mail-server@/);
    return $address if (! $lib'valid_addresses);

    if (! @valid_address_list) {
	if (! open(ADDRESS_LIST, $lib'valid_addresses)) {
	    &abort("Opening $lib'valid_addresses: $!");
	}
	while (<ADDRESS_LIST>) {
	    chop;
	    push(@valid_address_list, $_);
	}
	close(ADDRESS_LIST);
    }

    for (@valid_address_list) {
	return $same_address 
	    if ($same_address = &same_addresses($address, $_));
    }

    if ($lib'invalid_address_file) {
	&deliver("Your request to $lib'address", undef,
		 &make_disk_file(undef, $lib'invalid_address_file));
    }

    &syslog('notice', "%s: request from invalid address %s",
	    $queue_file, $address);

    undef;
}

sub same_addresses {
    local($a1, $a2) = @_;

    # First, check if they're completely identical
    return $a1 if ($a1 eq $a2);

    # Now, check if they're identical after conversion to lower case
    $a1 =~ tr/A-Z/a-z/;
    $a2 =~ tr/A-Z/a-z/;
    return $a1 if ($a1 eq $a2);

    # Now check if their "real addresses" are identical
    $a1 = &real_address($a1);
    $a2 = &real_address($a2);
    return $a1 if ($a1 eq $a2);

    undef;
}

sub real_address {
    local($_) = @_;

    s/\s*\(.*\)\s*//;
    s/.*\<(.*)\>.*/$1/;
    s/^\s+//;
    s/\s+$//;
    $_;
}

sub check_load_average {
    if ($lib'max_load) {
	$uptime = `/usr/ucb/uptime`;
	if ($?) {
	    &syslog('err', 'error running /usr/ucb/uptime (possibly %m).... continuing anyway');
	}
	elsif ($uptime !~ /load average:\s*([0-9.]+)/) {
	    &syslog('err', 'error parsing output of /usr/ucb/uptime (%s).... continuing anyway', $uptime);
	}
	elsif ($1 > $lib'max_load) {
	    &syslog('notice', 'aborting queue run because current load average (%s) is greater than %s', $1, $lib'max_load);
	    return undef;
	}
    }
    return 1;
}