#!/usr/local/bin/perl -w
BEGIN {
  $Sys::Syslog::host = "bug_in_perl_5.003";
}

use strict;
#
# $Header: /home/tibbs/tlb/RCS/tlb,v 1.26 1998/09/22 04:41:41 tibbs Exp $
#
$::rcs_version = '$Revision: 1.26 $$Author: tibbs $$Date: 1998/09/22 04:41:41 $';
$::rcs_version =~ s/\$|Revision: |Author: |Date: //g;
$::rcs_version =~ s/ $//;

$::release_version = "0.11a";

require 5.002;

# Extra libraries required.
# These come with perl.
use Carp;
use Getopt::Std;
use POSIX qw(ceil waitpid);
use Socket 1.3;
use IPC::Open2;

# These you need to get from CPAN; see http://www.perl.com/perl
# Copies that are possibly out of date but are known to work are at
# ftp://ftp.hpc.uh.edu/pub/tlb/
use IO::Socket;                        # From the IO package
use Net::Domain qw(hostfqdn hostname); # From the libnet package
use Date::Format qw(strftime);         # From the TimeDate package
use Mail::Address qw(address parse);   # From the MailTools package

# Uncomment if you have the module and want more precise performance data
# use Time::HiRes qw(time);

# Perl 5.003 has a bug in Sys::Syslog, fixed in 5.003_01.  We work around
# it here, and with the BEGIN clause.
use Sys::Syslog;
$Sys::Syslog::host = hostfqdn;

# Prototypes for all subroutines.
sub AddRecipient ($ );
sub BatchAddrLists ();
sub BatchSeparatedomains ($$$ );
sub BatchMaxaddrs ($$ );
sub BatchMaxdomains ($$ );
sub BatchNumbatches ($$ );
sub ChildReaper ();
sub CloseAllConnections ();
sub CloseConnection (@ );
sub CloseEnvelope (@ );
sub DeliverBatches ();
sub GetResponse ($$$ );
sub Log ($$$ );
sub LogAbort ($ );
sub LogClose ();
sub LogIn ($$$ );
sub LogOpen ();
sub LogOut (;$ );
sub LogStartupTime ();
sub MakeFromLine ();
sub ParseAddrs ($ );
sub PrintAddrLists ();
sub PrintBatches ();
sub PrintUsageInfo ();
sub PrintVersionInfo ();
sub PushAddr ($ );
sub ReadAddrs ($ );
sub ReverseDomain ($ );
sub RunTestMode ();
sub OpenCommand ($ );
sub OpenConnection ($$ );
sub OpenEnvelope ($$ );
sub OpenSocket ($$ );
sub ReadMessage ();
sub SendData ($@ );
sub SendGreeting ($@ );
sub SendMessage ($@ );
sub SendRCPT ($@ );
sub SendSMTP ($$@ );
sub SendToExternals ($$ );
sub SortAddrLists ();


# Set up child process reaper; we can leave this in constantly because we
# always want to reap children.
$SIG{CHLD} = \&ChildReaper;

# Constants.  One day the compiler will make these fast.
sub DEFAULT_BATCH_SIZE { 10 };
sub DEFAULT_TIMEOUT { 60 };

$| = 1;

# Process command line args.
getopts('abcl:x:y:z:vhd:t:');

#Aargh
use vars qw($opt_a $opt_b $opt_c $opt_h $opt_l $opt_v $opt_x $opt_y $opt_z);

if ($::opt_v) {
  PrintVersionInfo;
  exit(0);
}

if ($::opt_h) {
  PrintUsageInfo;
  exit(0);
}

# Set defaults for config variables, override from config file, then
# calculate unspecified vaules, if needed
{
  package Config;
  no strict "vars";  # Turn off strict checking for this block
  use vars qw($opt_a $opt_b $opt_c $opt_x $opt_y $opt_z);
  my($i, $j);
  
  # Pull the user options into this package
  #foreach $i (qw(a b c l x y z)) {
  #  $j = "\$opt_$i = \$::opt_$i";
  #  eval $j;
  #}
  $opt_a = $::opt_a;
  $opt_b = $::opt_b;
  $opt_c = $::opt_c;
  $opt_l = $::opt_l;
  $opt_x = $::opt_x;
  $opt_y = $::opt_y;
  $opt_z = $::opt_z;

  $address_file = undef;
  $sender = undef;
  $send_no_mail = undef;
  $send_to_externals = undef;
  $list_name = $opt_l || "init";
  $local_ESMTP = undef;
  $local_hostname = ::hostfqdn();  # it wasn't imported into this package
  $log_entries = undef;
  $log_level = 6;
  $mailer = "/usr/sbin/sendmail -bs";
  $sorted_address_list = undef;
  $stripped_address_list = undef;
  $tempdir = "/tmp";
  @delivery_matrix = ();
  @external_programs = ();

  # Open the log now, to have a place to complain about errors.
  ::LogOpen;

  # What's left after argument processing must be the config file.  Check it, then load it.
  unless (defined $::ARGV[0]) {
    ::LogAbort("You must specify a config file, stopped");
  }
  unless (-r $::ARGV[0]) {
    ::LogAbort("Invalid or unreadable config file: $::ARGV[0], stopped");
  }
  require $::ARGV[0] ||
    ::LogAbort("Error loading config file: $::ARGV[0], $!, stopped");

  # Check values and abort if necessary.
  # XXX Need more checks here
  unless ($address_file) {
    ::LogAbort("Config must specify address file, stopped");
  }
  unless (-r $address_file) {
    ::LogAbort("Cannot read address file \"$address_file\", stopped");
  }
  
  $address_file =~ m|.*/(.*)|;
  $list_name = $opt_l || $1 || $list_name;
  
  # Provide defaults derived from other config variables
  $sender = "owner-$list_name\@$local_hostname" unless $sender;
}

# We reset the log here so new parameters will take effect.
::LogClose;
::LogOpen;

# Avoid annoying warnings
if (!$::opt_d) {
  $::opt_d = 0;
}

# Allow a simple failsafe
if (defined $Config::send_no_mail && !defined $::opt_t) {
  $::opt_d = $::opt_d | 256;
}

# 256 implies 128, or we bomb writing to unopened handles
if ($::opt_d & 256) {
  $::opt_d = $::opt_d | 128;
}

print "Debugging with $::opt_d.\n" if $::opt_d;
print "Testing with $::opt_t.\n" if $::opt_t;

if ($::opt_t) {
  RunTestMode;
  exit(0);
}

#
# Main program flow (yup, this is it)
#

LogStartupTime;

($::filename,$::from_line) = ReadMessage;

if ($Config::send_to_externals &&
    defined(@Config::external_programs))
  {
    SendToExternals($::filename, $::from_line);
  }

ReadAddrs($Config::address_file);
PrintAddrLists if ($::opt_d & 1); 

unless ($Config::sorted_address_list) {
  SortAddrLists;
  PrintAddrLists if ($::opt_d & 2); 
}

BatchAddrLists;
PrintBatches if ($::opt_d & 4);

DeliverBatches unless ($::opt_d & 256);

unlink $::filename;

exit(0);


#
# Subroutines follow
#


#
# Address/Batch handling routines
#

# Read in the addresses and put them into the main data structure
sub ReadAddrs ($) {
  my($file) = shift;
  
  LogIn(6, "info", "Reading addresses");
  open(LIST,$file) or
    LogAbort("Couldn't open address file $file: $!");

  # read in addresses and place them in the proper address lists
  while (<LIST>) {
    # XXX Could do more useful address parsing here.
    # XXX Will ignoring lines with leading octathorpes cause problems?
    next if /^\#/;
    chomp;
    PushAddr($_);
  }

  LogOut;
}


# Push an address, domain pair onto the appropriate address list
sub PushAddr ($) {
  my($addr) = shift;
  my($domain, $revdomain, $i);

  unless ($Config::stripped_address_list) {
    $addr = ParseAddrs($addr);
  }
  ($domain = $addr) =~ s/(.*@|\[|\])//g; # Leave only the domain and strip brackets.
  $revdomain = uc(join('.',reverse(split /\./,$domain)));

  for $i (0..$#Config::delivery_matrix) {
    if (!defined $Config::delivery_matrix[$i]{'regexp'} ||
	$domain =~ /$Config::delivery_matrix[$i]{'regexp'}/i)
     {
	push @{$Config::delivery_matrix[$i]{'addrs'}},[$addr, $revdomain];
	return;
      }
  }
  # Only get here if no match, meaning we have a completely unspecified
  # default destination.  We extend the delivery matrix by one element to
  # include the default delivery path.  We should only ever get here once.
  push @{$Config::delivery_matrix[$#Config::delivery_matrix + 1]{'addrs'}},[$addr, $revdomain];
}

# Sort each of the address lists according to the reversed components of
# the domain, so addresses in the same top level domain cluster together,
# addresses with the same two last domain levels cluster together, etc.
sub SortAddrLists () {
  my($i);

  LogIn(6, "info", "Sorting addresses");
  for $i (0..$#Config::delivery_matrix) {
    next if (defined $Config::delivery_matrix[$i]{'nosort'} ||
	     !defined $Config::delivery_matrix[$i]{'addrs'});
    $Config::delivery_matrix[$i]{'addrs'} =
      [ sort { $a->[1] cmp $b->[1] }  @{$Config::delivery_matrix[$i]{'addrs'}} ];
  }
  LogOut;
}

# Place address lists into an array of batches
sub BatchAddrLists () {
  my($i, $dest, $j, $count, $maxcount, $lastdomain);

  LogIn(6, "info", "Batching addresses");
  for $i (0..$#Config::delivery_matrix) {
  SWITCH: for $dest ($Config::delivery_matrix[$i]) {
      if (defined $dest->{'minseparate'}) {
	BatchSeparatedomains($dest, $dest->{'minseparate'},
			     (defined $dest->{'maxdomains'} ?
			      $dest->{'maxdomains'} :
			      DEFAULT_BATCH_SIZE));
	last SWITCH;
      }
      if (defined $dest->{'maxdomains'}) {
	BatchMaxdomains($dest, $dest->{'maxdomains'});
	last SWITCH;
      }
      if (defined $dest->{'maxaddrs'}) {
	BatchMaxaddrs($dest, $dest->{'maxaddrs'});
	last SWITCH;
      }
      { # DEFAULT
	if (!$dest->{'numbatches'}) {
	  $dest->{'numbatches'} = 1;
	  print"No batch parameters found; assuming one batch.\n" if ($::opt_d & 4);
	}
	BatchNumbatches($dest, $dest->{'numbatches'});
	last SWITCH;
      }
    }
  }
  LogOut;
}


# Make exactly numbatches batches, each with an indeterminate number of
# addresses.
sub BatchNumbatches ($$) {
  my($dest) = shift;
  my($numbatches) = shift;
  my($maxcount, $currentbatch);
  
  print "Batching with numbatches = $numbatches -> " if ($::opt_d & 4);
  
  $maxcount = ceil( ($#{$dest->{'addrs'}}+1) / $numbatches);
  BatchMaxaddrs($dest,$maxcount);
}


# Make an indeterminate number of batches each with maxaddrs addresses.
sub BatchMaxaddrs ($$) {
  my($dest) = shift;
  my($maxcount) = shift;
  my($count, $currentbatch, $i);
  
  print "Batching with maxaddrs = $maxcount.\n" if ($::opt_d & 4);
  $count = 0;
  $currentbatch = 0;
  for $i (0..$#{$dest->{'addrs'}}) {
    if ($count >= $maxcount) {
      $currentbatch++;
      $count = 0;
    }
    push @{$dest->{'batches'}[$currentbatch]}, $dest->{'addrs'}[$i][0];
    $count++;
  }
}


# Make an indeterminate number of batches each with maxdomains different
#  domains.  The number of addresses per batch is >= maxdomains.
sub BatchMaxdomains ($$) {
  my($dest) = shift;
  my($maxcount) = shift;
  my($count, $currentbatch, $lastdomain, $i);
  
  print "Batching with maxdomains = $maxcount.\n" if ($::opt_d & 4);
  $count = 0;
  $currentbatch = 0;
  undef $lastdomain;
  for $i (0..$#{$dest->{'addrs'}}) {
    if (defined $lastdomain &&
	$lastdomain ne $dest->{'addrs'}[$i][1] &&
	$count >= $maxcount)
      {
	$currentbatch++;
	$count = 0;
      }
    push @{$dest->{'batches'}[$currentbatch]}, $dest->{'addrs'}[$i][0];
    if (! defined $lastdomain ||
	$lastdomain ne $dest->{'addrs'}[$i][1])
      {
	$count++;
	$lastdomain = $dest->{'addrs'}[$i][1];
      }
  }
}

		   
# Put domains appearing more than minseparate times in separate batches;
# put all other domains into batches with maxdomains total domains.
sub BatchSeparatedomains ($$$) {
  my($dest) = shift;
  my($minseparate) = shift;
  my($maxdomains) = shift;
  my($count, $stragglercount, $currentbatch, $lastdomain, @stragglers, $i);

  print "Batching with minseparate = $minseparate and maxdomains = $maxdomains.\n"
    if ($::opt_d & 4);

  $count = 0;
  $stragglercount = 0;
  $currentbatch = 0;
  undef $lastdomain;

  # Loop over all addresses
  for $i (0..$#{$dest->{'addrs'}}) {

    # If this domain isn't the same as the last one
    if (defined $lastdomain &&
	$lastdomain ne $dest->{'addrs'}[$i][1]) {

      # If we didn't get enough addresses from that domain
      if ($count < $minseparate) {
	
	# Place these addresses in a straggler batch
	push @stragglers, @{$dest->{'batches'}[$currentbatch]};
	@{$dest->{'batches'}[$currentbatch]} = ();
	$stragglercount++;

	# If we filled the straggler batch
	if ($stragglercount >= $maxdomains) {

	  # Place it in the list and start a new one
	  @{$dest->{'batches'}[$currentbatch]} = @stragglers;
	  @stragglers = ();
	  $stragglercount = 0;
	  $currentbatch++;
	}
      }
      
      # We got enough address from that domain
      else {
	$currentbatch++;
      }
      $count = 0;
    }
    
    push @{$dest->{'batches'}[$currentbatch]}, $dest->{'addrs'}[$i][0];
    $count++;
    $lastdomain = $dest->{'addrs'}[$i][1];
  }
  if (@stragglers) {
    if ($#{$dest->{'batches'}[$currentbatch]} < $minseparate) {
      push @{$dest->{'batches'}[$currentbatch]}, @stragglers;
    }
    else {
      @{$dest->{'batches'}[$currentbatch+1]} = @stragglers;
    }
  }
}


# The real work.  Deliver each batch according to the rules of the
# destination and hosts.
sub DeliverBatches () {
  my($currenthost, @envelope, $i, $j, $result);
  
  LogIn(6, "info", "Delivering batches");
  # Loop over each destination
  for $i (0..$#Config::delivery_matrix) {
    $currenthost = 0;

    # It's silly to log this if we only have one destination
    unless ($#Config::delivery_matrix == 0) {
      LogIn(7, "info", "Delivering to dest $i");
    }

    # Loop over each batch
    for $j (0..$#{$Config::delivery_matrix[$i]{'batches'}}) {

      LogIn(8, "info", "Delivering dest $i, batch $j");

      # Weird control structure follows.  What we want to do is perform a
      # series of operations, and if one of them fails we execute failure
      # code and try again.  If none of them fails, we execute success code
      # and exit.
      while (1) {
	@envelope = OpenEnvelope($Config::delivery_matrix[$i],
				 $Config::delivery_matrix[$i]{'allhostsdown'}
				 ? 'LOCAL'
				 : $currenthost);
	
	next unless @envelope;
	print "Successfully opened the envelope: D$i, B$j.\n" if ($::opt_d & 16);
	
	# Send the address list
	$result = SendRCPT($Config::delivery_matrix[$i]{'batches'}[$j], @envelope);
	next unless $result;
	if ($result == -1) {
	  # The batch contained only one bad address, so we pretend it was sent completely
	  Log(5, "notice", "Batch contained just a single rejected address.\n");
	  last;
	}

	# Send the message body
	SendMessage($::filename, @envelope) ||
	  next;
	
	# Close the envelope
	CloseEnvelope(@envelope) ||
	  next;

	# OK, we successfully sent a batch.  Increment the current host if
	# not in failsafe mode, skip backup hosts if no hosts are down.
	if (!defined $Config::delivery_matrix[$i]{'allhostsdown'}) {
	  do {
	    $currenthost = ($currenthost + 1) % ($#{$Config::delivery_matrix[$i]{'hosts'}} + 1);
	  } until
	    (!$Config::delivery_matrix[$i]{'hosts'}[$currenthost]{'down'} &&
	     (!$Config::delivery_matrix[$i]{'hosts'}[$currenthost]{'backup'}
	      || ($Config::delivery_matrix[$i]{'downcount'}
		  && $Config::delivery_matrix[$i]{'downcount'} > 0)));
	}
	print "Switching to host $currenthost.\n" if ($::opt_d & 16);
	last;
      }
      continue {
	# Mark host down
	print "Marking $Config::delivery_matrix[$i]{'hosts'}[$currenthost]{'hostname'} down.\n" 
	  if ($::opt_d & 8);
	Log(3, "notice", "Marking $Config::delivery_matrix[$i]{'hosts'}[$currenthost]{'hostname'} down.\n");
	$Config::delivery_matrix[$i]{'hosts'}[$currenthost]{'down'} = 1;
	$Config::delivery_matrix[$i]{'downcount'}++;
	# Nuke a possible cached connection
	delete $Config::delivery_matrix[$i]{'connection'};
	
	# Are all our hosts down?  Fall back to failsafe.
	if ($Config::delivery_matrix[$i]{'downcount'} >= ($#{$Config::delivery_matrix[$i]{'hosts'}}+1)) {
	  print "Switching to failsafe.\n" if ($::opt_d & 8);
	  Log(2, "warning", "Dest $i, in failsafe mode.");
	  $Config::delivery_matrix[$i]{'allhostsdown'} = 1;
	}
	else {
	  # Skip to next working host
	 SKIP:
	  while (1) {
	    $currenthost = ($currenthost + 1) % ($#{$Config::delivery_matrix[$i]{'hosts'}}+1);
	    last SKIP unless $Config::delivery_matrix[$i]{'hosts'}[$currenthost]{'down'};
	  }
	}
      }
	LogOut;
    }
    unless ($#Config::delivery_matrix == 0) {
      LogOut;
    }
  }
  LogOut;
  CloseAllConnections;
}


#
# Message handling functions
#

# Read the message in from STDIN, adding our Received: header and saving
# any leading From_ line separately.  Note that we assume that there is no
# space between the From_ line and the real headers; this assumption should
# be perfectly valid.
sub ReadMessage () {
  my(@time, $date, $received, $filename, $seen_header, $from_line);
  
  LogIn(6, "info", "Reading message");
  @time = localtime;
  $date = strftime("%a, %d %b %Y %T %z (%Z)", @time);
  $received = "Received: by $Config::local_hostname (TLB v$::release_version ($::rcs_version)); $date\n";

  $filename = "$Config::tempdir/tlb.$$";

  # XXX Check for error here.  Try to log the error or inform the
  # postmaster, and exit EX_TEMPFAIL.
  open(MOUT, ">$filename");
  
  print "Reading message to $filename.\n" if ($::opt_d & 8);
  
  # Add our Received: header
  print MOUT $received;

  # First skip over any leading blank lines and store any From_ line just
  # in case
  while (<STDIN>) {
    last if (/^\S+: /);
    next if (/^\s/);
    if (/^From /) {
      $from_line = $_;
      next;
    }
  }
  
  print "  Found mbox separator: $from_line" if ($::opt_d & 16 && defined($from_line));
  
  unless (defined $from_line) {
    $from_line = MakeFromLine;
    print "  Made mbox separator: $from_line" if ($::opt_d & 16);
  }

  print "  Copying message.\n" if ($::opt_d & 16);

  # We've found a real header; print it, then copy rest of message
  print MOUT $_;

  while (<STDIN>) {
    print MOUT $_;
  }

  close MOUT;
  
  print "\n" if ($::opt_d & 8);

  LogOut;
  return ($filename, $from_line);
}
  

# Generate our own From_ line, in case we weren't called from an MTA.  I
# don't like having to do this, but some packages (like archive2.pl) expect
# to be called from a Sendmail alias and thus get the From_ line.
sub MakeFromLine () {
  my($from_line, $time);

  $time = localtime;
  $from_line = "From $Config::sender  $time\n";

  return $from_line;
}


# Send the message to an open and completely set up SMTP connection.  We
# expect all necessary SMTP to already have been sent, including DATA.  We
# do not send \r\n.\r\n, though we do escape leading periods.
sub SendMessage ($@) {
  my($filename) = shift;
  
  print "Sending message.\n" if ($::opt_d & 16);
  SendSMTP("DATA\r\n", 0, @_) || return undef;
  
  open(MESSAGE,"<$filename");
  
  while (<MESSAGE>) {
    SendData($_,@_);  # Isn't that pretty?
  }
  
  close(MESSAGE);
  return 1;
}
  

# Send the message to each of a set of command lines
sub SendToExternals ($$) {
  my($filename) = shift;
  my($from_line) = shift;
  my($pipe) = new IO::Handle;
  my($message) = new IO::Handle;
  my($external,$cmdline,);

  # reaping our own children confuses pipe spawns
  local $SIG{CHLD} = 'IGNORE';
  
  LogIn(6, "info", "Spawning externals");
  print "Spawning externals.\n" if ($::opt_d & 8);
  
  for $external (@Config::external_programs) {

    # Take care of any token expansions.  Eventually a sub call or
    # something will be useful here, when there are more tokens.
    # XXX Or should this be handled with embedded variables and an eval?
    ($cmdline = $external->{'commandline'}) =~ s/=FILE=/$filename/g;

    print "  Will spawn: $cmdline\n" if ($::opt_d & 16);

    if (!($::opt_d & 128)) {
      open($pipe,"|$cmdline") ||
	LogAbort("Failed to execute external: $cmdline, $!, stopped");
      
      open($message,"$filename") ||
	LogAbort("Could not open saved message $filename for reading, $!, stopped");
      
      if ($external->{'pipemessage'}) {
	if ($external->{'needsfrom'}) {
	  print $pipe $from_line;
	}
	while(<$message>) {
	  print $pipe $_;
	}
      }
      # Sendmail appends a blank line to the message, so we must, too.
      # XXX Perhaps this should be configurable.
      print $pipe "\n";

      close $message || LogAbort("Error closing $filename, $!, stopped");
      close $pipe || LogAbort("Error closing $cmdline, $!, stopped");
    }
  }
  print "\n" if ($::opt_d & 8);
  LogOut;
}


#
# Misc. functions
#

# This replaces the function below.  The old function was nicked from old
# Majordomo code and could generate bad results for many uncommon but legal
# addresses.  Since the stripped address is actually used to deliver to, we
# have to make sure that we do it properly.
sub ParseAddrs ($) {
  my($addr) = shift;
  Mail::Address::address(parse Mail::Address $addr);
}

#sub ParseAddrs {
#  local($_) = shift;
#  1 while s/\([^\(\)]*\)//g; # strip parenthesized comments
#  1 while s/"[^"]*"//g;      # strip quoted comments
#  1 while s/.*<(.*)>.*/$1/;  # strip out bracketed addresses
#  s/^\s+//;                  # strip leading whitespace
#  s/\s+$//;                  # strip trailing whitespace
#
#  $_;                        # return stripped address
#}

# This deals with waiting for the children that we spawn
sub ChildReaper () {
  my($child);
  $SIG{CHLD} = \&ChildReaper;
  # Careful here; waitpid may return -1 if we have no more children
  while (($child = waitpid(-1,&POSIX::WNOHANG())) > 0) {
    $::child_status{$child} = $?;
  }
}


#
# Envelope/Connection handling functions
#


# Open an envelope.  We check to see if there is an open connection, open
# one, stash it and send the greeting if needed.  If there was an open
# connection, reset it.  Then send the MAIL FROM: line.
sub OpenEnvelope ($$) {
  my($dest) = shift;
  my($host) = shift;  # Could be 'LOCAL'
  my($hostref, @envelope);

  $hostref = ($host eq 'LOCAL') ? undef :
    $dest->{'hosts'}[$host];
  $hostref = undef if $hostref eq 'LOCAL';

  # Do we need to open a connection?
  # XXX Need to probe extant connections with NOOP to make sure they're
  # still open.
  if (!$hostref || !$hostref->{'connection'} || !@{$hostref->{'connection'}}) {
    @envelope = OpenConnection($dest, $host);
    if (@envelope) {
      SendGreeting($hostref, @envelope) ||
	return wantarray ? () : undef;
    }
    else {
      return wantarray ? () : undef;
    }
  }
  # We already have a connection.  Reset it.  Note that the local mailer
  # will never do persistent connections, so we don't have to worry about
  # LOCAL here.
  else {
    @envelope = @{$hostref->{'connection'}};
    SendSMTP("RSET\r\n", 0, @envelope) ||
      return wantarray ? () : undef;
  }
  
  # We have an open envelope, ready to accept a piece of mail.
  SendSMTP("MAIL FROM:<$Config::sender>\r\n", 0, @envelope) ||
    return wantarray ? () : undef;
  
  # The envelope is good, so stash it
  return (@{$hostref->{'connection'}} = @envelope);
}


# Open a connection and send the greeting.
sub OpenConnection ($$) {
  my($dest) = shift;
  my($host) = shift;  # Could be 'LOCAL'
  
  my($hostname, $port, $timeout, $rfh, $wfh, $pid);

  # For testing, if host has 'fail' tag, fail now
  if ($host ne 'LOCAL' &&
      $dest->{'hosts'}[$host] ne 'LOCAL' &&
      $dest->{'hosts'}[$host]{'fail'} &&
      ($::opt_d & 512))
    {
      return wantarray ? () : undef;
    }
  
  if ($host                   eq 'LOCAL' ||
      $dest->{'hosts'}        eq 'LOCAL' ||
      $dest->{'hosts'}[$host] eq 'LOCAL' )
    {
      # in failsafe mode
      print "Opening envelope in failsafe mode to LOCAL.\n" if ($::opt_d & 16);
      $hostname = 'LOCAL';
      $timeout  = DEFAULT_TIMEOUT;
    }
  else {
    $hostname = $dest->{'hosts'}[$host]{'hostname'} || 'LOCAL';
    $timeout  = $dest->{'hosts'}[$host]{'timeout'}  || DEFAULT_TIMEOUT;
  }

  LogIn(9, "info", "Opening connection to $hostname");
 SWITCH: for ($hostname) {
    /^LOCAL$/ && do {
      ($rfh, $wfh, $pid) = OpenCommand($Config::mailer);
      last SWITCH;
    };
    /^\// && do {
      # Fail randomly if user requests
      if (($::opt_d & 1024) && (rand > 0.5)) {
	return wantarray ? () : undef;
      }

      ($rfh, $wfh, $pid) = OpenCommand($hostname);
      last SWITCH;
    };
    # DEFAULT
    do {
      # Fail randomly if user requests
      if (($::opt_d & 1024) && (rand > 0.5)) {
	return wantarray ? () : undef;  
      }

      $rfh = OpenSocket($dest, $host);
      $wfh = undef;
      $pid = undef;
      last SWITCH;
    }
  }
  
  # Check that the open routine worked
  if (!$rfh || ($pid && !$wfh)) {
    print "Open of socket or command failed!\n" if ($::opt_d & 8);
    LogOut("failed");
    return wantarray ? () : undef;  
  }

  # We expect a response from the server
  unless (GetResponse($rfh, 0, $timeout)) {
    print "Timeout waiting for greeting!\n" if ($::opt_d & 8);
    LogOut("timeout");
    return wantarray ? () : undef;  
  }    

  LogOut;
  return ($rfh, $wfh, $pid, $timeout);
}


# Open two filehandles, one on either end of a command that will be exec'ed
sub OpenCommand ($) {
  my($cmdline) = shift;
  my($rfh, $wfh, $pid, $command);
  
  print "Will exec command: $cmdline\n" if ($::opt_d & 16);
  
  $command = (split(" ",$cmdline))[0];
  
  # Open2 gives spurious warnings and generally behaves badly if it
  # couldn't exec the command.  Here we check to see if we can exec the
  # command.  This doesn't tell us if it ran but died due to bad options or
  # something.  We could trap STDERR with open3, but open2 is bad enough.

  # XXX the mechanics are in place to reap the child if it dies and record
  # its status.  We should use this to make sure it exists.  It already
  # prevents a hang in case we read from it after it dies; instead we die.
  
  if (! -x $command) {
    print "Cannot execute $command!" if ($::opt_d & 8);
    return wantarray ? () : undef;  
  }
  
  $rfh = new IO::Handle;
  $rfh->autoflush;
  $wfh = new IO::Handle;
  $wfh->autoflush;  

  $pid = open2($rfh, $wfh, $cmdline);
  
  # XXX Must check to see that program is still running; it may have died
  # because we gave it bad args.  If we don't check this, we die trying to
  # read the greeting because the reaper gets catches the death of the
  # child so the filehandles go nowhere.  As an alternative to dying (and a
  # better alternative than wrapping every read/write in an eval is to
  # sleep a little while to give the child time to die, then check the
  # %child_status hash to see if it's been reaped.  Using open3 isn't
  # really an option because we need the same read/write semantics as a
  # socket for transparency.
  
  return($rfh, $wfh, $pid);
}


sub OpenSocket ($$) {
  my($dest) = shift;
  my($host) = shift;
  my($fh, $hostname, $timeout, $port, $iaddr, $try);
  
  # Fill in default port value if necessary
  if (!$dest->{'hosts'}[$host]{'port'}) {
    $dest->{'hosts'}[$host]{'port'} = 'smtp';
  }
  # IO::Socket will spew to stderr and eval won't catch it, so we'll do
  # some error checking ourselves.  Remember that we just mark the host
  # down and continue of something fails.
  if ($dest->{'hosts'}[$host]{'port'} =~ /\D/) {
    $port = getservbyname($dest->{'hosts'}[$host]{'port'},"tcp");
    if (!$port) {
      print "Failed to get port number for port: $dest->{'hosts'}[$host]{'port'}!\n"
	if ($::opt_d & 8);
      return wantarray ? () : undef;  
    }
    # Save it so we don't have to do this later
    $dest->{'hosts'}[$host]{'port'} = $port;
  }
  else {
    $port = $dest->{'hosts'}[$host]{'port'};
  }

  # Likewise, resolve the hostname
  $hostname = $dest->{'hosts'}[$host]{'hostname'};
  $iaddr = inet_aton($hostname);

  if (!$iaddr) {
    print "Failed to resolve hostname: $hostname!\n" 
      if ($::opt_d & 8);
    return wantarray ? () : undef;  
  }

  $timeout = $dest->{'hosts'}[$host]{'timeout'} || DEFAULT_TIMEOUT;
  print "Will open socket to: host    = $hostname,\n" if ($::opt_d & 16);
  print "                     port    = $port,\n" if ($::opt_d & 16);
  print "                     timeout = $timeout.\n" if ($::opt_d & 16);
  
  $try = eval {
    $fh = new IO::Socket::INET (
				PeerAddr => $hostname,
				PeerPort => $port,
				Proto    => "tcp",
				Timeout  => $timeout,
			       );
  };
  
  if (!$try) {
    print "Error opening socket: $@"
      if ($::opt_d & 8);
    Log(3, "notice", "Error opening socket: $@");
    return wantarray ? () : undef;
  }

  if (!$fh) {
    print "(Probably) Timeout ($timeout sec) connecting to $hostname!\n"
      if ($::opt_d & 8);
    return wantarray ? () : undef;  
  }

  print "Opened socket!\n" if $fh && ($::opt_d & 16);
  $fh->autoflush;
  return $fh;
}


# End the DATA segment, hang up on the other end, and close our handles.
sub CloseEnvelope (@) {
  print "Closing envelope.\n" if ($::opt_d & 16);
  
  SendSMTP("\r\n.\r\n", 0, @_) ||
    return undef;

  return 1;
}


sub CloseAllConnections () {
  my($i, $j);

  for $i (@Config::delivery_matrix) {
    for $j (@{$i->{'hosts'}}) {
      if ($j ne 'LOCAL' && $j->{'connection'} && @{$j->{'connection'}}) {
	print "Closing connection to $j->{'hostname'}.\n" if ($::opt_d & 16);
	CloseConnection(@{$j->{'connection'}});
	delete $j->{'connection'};
      }
    }
  }
}


sub CloseConnection (@) {
  my($rfh, $wfh, $pid, $timeout) = @_;
  my($waited);

  SendSMTP("QUIT\r\n", 0, @_);
  
  # We must wait for a child command to shut down, exit, and be reaped.
  if ($pid) {
    $waited = 0;
    while (!defined ($::child_status{$pid})) {
      $waited++;
      
      if ($waited > $timeout) {
	Log(3, "notice", "Waited too long for child to exit.");
	last;
      }	
      
      print "Waiting for child process to exit: $waited.\n" if ($::opt_d & 16);
      sleep(1);
    }
    delete $::child_status{$pid};
  }

  # Remote end should have gone away; let's close up shop.  Only actually
  # close the handle if it was a socket; the reaper will automatically have
  # cleaned up after a command.
  unless ($pid) {
    $rfh->close;
  }
  return 1;
}


# This sends the proper SMTP greeting once the connection has been opened
sub SendGreeting ($@) {
  my($host, @envelope) = @_;
  my($hostname, $local_hostname);
  
  unless (!$host || $host eq 'LOCAL') {
    $hostname = $host->{'hostname'};
  }

  if (!$hostname || $hostname eq 'LOCAL' || $hostname =~ m|^/|) {
    $local_hostname = 'localhost';
  }
  else {
    $local_hostname = $Config::local_hostname;
  }

  # XXX Need to allow for persistent connections; HELO may already have
  # been issued in this connection

  # Nasty BS to get around strictification
  if (!$host || $host eq 'LOCAL') {
    if ($Config::local_ESMTP) {
      SendSMTP("EHLO $local_hostname\r\n", 0, @envelope) ||
	return undef;;
    }
  }
  elsif ($host->{'ESMTP'}) {
    SendSMTP("EHLO $local_hostname\r\n", 0, @envelope) ||
      return undef;
  }
  else {
    SendSMTP("HELO $local_hostname\r\n", 0, @envelope) ||
      return undef;
  }
  
  if ($host && $host ne 'LOCAL' && $host->{'ONEX'}) {
    SendSMTP("ONEX\r\n", 0, @envelope) ||
      return undef;
  }
  
  return 1;
}

  

#
# SMTP handling functions
#


# Send an SMTP command and expect a reply
sub SendSMTP ($$@) {
  my($string, $ignorenonfatal, $rfh, $wfh, $pid, $timeout) = @_;
  my($code);

  # XXX We should have a sigpipe handler to trap bad pipe writes, and
  # something to handle a write to a closed socket.

  # We may be using a socket, in which case we use the same handle for
  # input and output
  if (!$wfh) {
    $wfh = $rfh;
  }
  
  if ($string =~ /^\r\n\./) {
    LogIn(10, "info", "SMTP DATA end");
  }
  elsif ($string =~ /^RCPT/) {
    LogIn(10, "info", "SMTP RCPT<".substr($string,9,4).">");
  }
  else {
    LogIn(10, "info", "SMTP ".substr($string,0,4));
  }

  push(@::transaction_log, ">>> $string") if $::opt_t;
  print ">>> $string" if ($::opt_d & 32);

  return(1) if ($::opt_d & 128);

  print $wfh "$string"; 
  $code = GetResponse($rfh, $timeout, $ignorenonfatal) || return undef;
    
  LogOut;
  return $code;
}


# Send a line of data without expecting a response.  Doing this at any time
# other than after sending a DATA command will screw things up badly (the
# read and write ends will get out of sync).  We must escape leading
# periods here, and lines are expected to be terminated properly.  (No \n
# is added.)
sub SendData ($@) {
  my($string, $rfh, $wfh, $pid) = @_;

  # We may be using a socket, in which case we use the same handle for
  # input and output
  if (!$wfh) {
    $wfh = $rfh;
  }

  # Escape leading periods
  $string =~ s/^\./../;
  print $wfh $string unless ($::opt_d & 128);
  print ">>> $string" if ($::opt_d & 64);
}
  
# Sends RCPT TO: for each address in the batch
sub SendRCPT ($@) {
  my($batch) = shift;
  my($i, $code);
  
  # Problem: if the batch has only one address and it is rejected with a
  # non-fatal error then we haven't addresses the envelope and the DATA
  # segment will fail.

  for $i (0..$#{$batch}) {
    $code = SendSMTP("RCPT TO:<$batch->[$i]>\r\n", 1, @_) ||
      return undef;;
  }

  # If we only have one address in this batch, it could be rejected.  We
  # can't continue sending this batch, but we can't just fail because the
  # batch will be resent.  So we return an exceptional value.
  if ($code == -1 && $#{$batch} == 0) {
    return -1;
  }
  return 1;
}

# Get a (possibly multiline) SMTP response from the other end, timing out
# if necessary.  The reply code is read, and non-fatal errors arising from
# the RCPT TO: command can be ignored.
sub GetResponse ($$$) {  
  my($rfh) = shift;
  my($timeout) = shift;
  my($ignorenonfatal) = shift;
  my($resp, $gotresp, $error, $code, $dummy, $multi, $text);

  while (1) {
    # The remote host _must_ respond.
    $gotresp = 0;
    
    local $SIG{ALRM} = sub { die };

    eval {
      $resp = <$rfh>;
      $gotresp = 1;
    };
    
    $SIG{ALRM} = 'DEFAULT';

    unless ($resp) {
      print "Received null STP response!\n" if ($::opt_d & 32);
      Log(3, "notice", "Received null SMTP response!\n");
      return undef;
    }
    
    unless ($gotresp) {
      print "Timeout waiting for response!\n" if ($::opt_d & 32);
      Log(3, "notice", "Timeout waiting for SMTP response!\n");
      return undef;
    }

    $resp =~ s/\r\n$//;
    push(@::transaction_log, "<<< $resp\n") if $::opt_t;
    print "<<< $resp\n" if ($::opt_d & 32);
    
    # Take apart the SMTP response
    ($code, $multi, $text) = ($resp =~ /(\d{3})(.)(.*)/);
    
    # Check SMTP return code
    
    if ($code =~ /^(55[0123])|(45[012])$/ &&
       $ignorenonfatal) 
      {
	# We received a non-fatal error that we should ignore.
	# XXX We should store these somewhere so that we can generate an
	# error report later.
	Log(4, "notice", "Received non-fatal SMTP response: $resp\n");
	$code = -1;
      }
    elsif ($code =~ /^[45]../) {
      # Temporary or permanent failure
      Log(4,"notice","SMTP Failure: $resp\n");
      $error = 1;
    }
    elsif ($code =~ /^[123]../) {
      # No problem
      Log(12, "info", "SMTP Resp: $resp\n");
    }
    else {
      # Whoa; the code was hosed
      LogAbort "Illegal SMTP response: $resp";
    }
    
    # Loop until we get a non-continued response
    last if $multi eq " ";
  }
  return $error ? undef : $code
}


#
# Logging routines
#

sub LogOpen () {
  openlog("tlb/$Config::list_name", 'pid', 'mail');
  Log(8, "info", "TLB starting.");
}

sub LogClose () {
  closelog;
}

sub Log ($$$) {
  my $level = shift;
  my $prio = shift;
  my $message = shift;

  confess("Log with no message!") unless $message;
  if ($level <= $Config::log_level) {
    syslog($prio, $message);
  }
}

sub LogStartupTime () {
  my($user, $system) = (times)[0..1];

  $user = sprintf("%.2f", $user);
  $system = sprintf("%.2f", $system);

  Log(6, "info", "Compilation took " . $user . "s, " . $system . "u");
}

sub LogIn ($$$) {
  my $level = shift;
  my $prio = shift;
  my $message = shift;

  if ($Config::log_entries) {
    Log($level, $prio, $message);
  }
  unshift @::log_state, [$level, $prio, $message, time()];
}

sub LogOut (;$) {
  my $extra = shift || "done";
  my $state = shift @::log_state;
  
  unless ($state) {
    LogAbort "LogOut called without corresponding LogIn, stopped";
  }

  my ($level, $prio, $message) = @{$state}[0..2];
  my $elapsed = time() - @{$state}[3];
  
  $elapsed = sprintf("%.2f", $elapsed);

  Log($level, $prio, "$message..$extra, took $elapsed sec");
}

sub LogAbort ($) {
  my $message = shift;

  Log(1, "warning", $message);
  confess $message;
}
     
#
# Debugging and informational routines
#


# Print out unbatched address lists
sub PrintAddrLists () {
  my ($i, $j, @blah);
  
  print "Address lists:\n";
  
  for $i (0..$#Config::delivery_matrix) {
    if (defined $Config::delivery_matrix[$i]{'hosts'}) {
      @blah = ();
      for $j (0..$#{$Config::delivery_matrix[$i]{'hosts'}}) {
        push @blah,$Config::delivery_matrix[$i]{'hosts'}[$j]{'hostname'};
      }
    }
    else {
      @blah = ('LOCAL');
    }
    print "  List for destination $i, host(s): ",join(", ",@blah),".\n";
    foreach (@{$Config::delivery_matrix[$i]{'addrs'}}) {
      print "    $_->[0], $_->[1]\n";
    }
    print "\n";
  }
}


# Print out destinations and corresponding batches
sub PrintBatches () {
  my($i, $j, $k, @blah);
  
  print "Batches:\n";
  
  for $i (0..$#Config::delivery_matrix) {
    if (defined $Config::delivery_matrix[$i]{'hosts'}) {
      @blah = ();
      for $j (0..$#{$Config::delivery_matrix[$i]{'hosts'}}) {
	if ($Config::delivery_matrix[$i]{'hosts'}[$j]{'backup'}) {
	  push @blah,"$Config::delivery_matrix[$i]{'hosts'}[$j]{'hostname'}(b)";
	}
	else {
	  push @blah,"$Config::delivery_matrix[$i]{'hosts'}[$j]{'hostname'}";
	}
      }
    }
    else {
      @blah = ('LOCAL');
    }
    print "  Batch to ",join(", ",@blah),".\n";
    
    for $j (0..$#{$Config::delivery_matrix[$i]{'batches'}}) {
      print "    batch \#$j:\n";
      for $k (0..$#{$Config::delivery_matrix[$i]{'batches'}[$j]}) {
	print "      $Config::delivery_matrix[$i]{'batches'}[$j][$k]\n";
      }
    }
    print "\n";
  }
}

sub PrintUsageInfo () {
  PrintVersionInfo;
  print <<"EOF";
Send questions or comments to Jason Tibbitts <tibbs\@hpc.uh.edu>.

Usage: $0 [-hv] [-t address] [-d ##] config-file

  -h print this usage info
  -v print version info
  -t test address (do delivery test for all destinations)
  -d debug level

  Debug flags.  Add desired flags to get -d value.
  1    - address lists before sorting
  2    - address lists after sorting
  4    - batches that will be sent to each host, and batch info
  8    - delivery verbosity (important things, errors))
  16   - delivery verbosity (less important things, informationals)
  32   - SMTP transactions excluding the message test
  64   - The escaped mesage text
  128  - Open connections, but do not actually send or receive and data.
         Do not spawn external programs.
  256  - Do not open sockets, and send no data (has no effect in test mode).
  512  - Pay attention to 'fail' tags in hosts descriptions.
  1024 - Fail all envelope opens (except to LOCAL) with 50% probability

Usage in aliases file:

listname-out: "|$0 config-file"

Usage with Majordomo:

listname: "|/path/to/wrapper resend -l listname
           -h your.host listname-secret,nobody"
listname-secret: "|/path/to/wrapper tlb config-file"

Or for Majordomo 1.94 or later, see majordomo.cf for calling TLB as a
mailer.
EOF
}

sub PrintVersionInfo () {
  print "TLB version $::release_version ($::rcs_version)\n";
}


# Here we send some informational message to an address provided on the
# command line through each host in each destination.  This _should_ test
# every delivery path possible.  The idea is that _if_ each host will
# accept a message bound for one random address, it will accept one bound
# for a bunch of random addresses.  Currently hosts that appear in
# different destinations will be tested multiple times.  Eliminating this
# is easy, but then you'd have to guess why you didn't get the number of
# test messages you expected.
sub RunTestMode () {
  my($i, $j, @envelope, @time, $date, $filename, $hostname, $hregexp, $line);
  
  # Override the config default for this, so bounces go where we expect
  # them to
  # XXX is this a good idea?  Might some hosts reject based on the
  # envelope sender?  We hope to get no bounces anyway.
  $Config::sender = $::opt_t;
  
  # Add another element to the end of the delivery matrix, to force test of
  # LOCAL destination
  # XXX This could be redundant, but it can't hurt
  push @Config::delivery_matrix, {'test' => 1};

  # Loop over each destination
  for $i (@Config::delivery_matrix) {
    
    if (!$i->{'hosts'}) {
      $i->{'hosts'} = [ 'LOCAL' ];
    }

    # Loop over each possible delivery host (even backups)
    for $j (0..$#{$i->{'hosts'}}) {
      
      @time = localtime;
      $date = strftime("%a, %d %b %Y %T %z (%Z)", @time);
      if ($i->{'hosts'}[$j] eq 'LOCAL') {
	$hostname = 'LOCAL';
      }
      else {
	$hostname = $i->{'hosts'}[$j]{'hostname'};
      }
      $hregexp = $i->{'regexp'} ? $i->{'regexp'} : 'DEFAULT';
      
      $filename = "/tmp/tlb.$$";
      open(MESSAGE,">$filename");
      print MESSAGE <<"EOM";
Date: $date
From: list_batcher_test\@$Config::local_hostname
To: $::opt_t

This is a test message from list_batcher.
Destination $hregexp
Host        $hostname
.
The SMTP transaction so far:

EOM
      close MESSAGE;
      @::transaction_log = ();
      print "Opening envelope.\n" if ($::opt_d & 16);
      @envelope = OpenEnvelope($i,$j);
      if (@envelope) {
	SendSMTP("RCPT TO: $::opt_t\r\n", 1, @envelope);
	SendMessage($filename,@envelope);
	for $line (@::transaction_log) {
	  SendData($line,@envelope);
	}
	CloseEnvelope(@envelope);
      }
      else {
	print "Problems connecting to Dest: $hregexp\n";
	print "                       Host: $hostname\n";
      }
      unlink $filename;
    }
  }
  CloseAllConnections();
}

#
# $Log: tlb,v $
# Revision 1.26  1998/09/22 04:41:41  tibbs
# Fixed some warnings.
#
# Revision 1.25  1997/01/30 01:05:08  tibbs
# sorted_address_list, stripped_address_list: test for truth, not
# definedness.
#
# Revision 1.24  1997/01/30  01:03:49  tibbs
# Fixed a couple more warnings.
#
# Revision 1.23  1997/01/09  00:29:32  tibbs
# Bumped to rev 0.10a.
#
# Revision 1.22  1997/01/08  23:26:40  tibbs
# Fixed undef variable reference in connection caching code.
#
# Revision 1.21  1997/01/08  20:34:08  tibbs
# Got rid of cute eval trick with command line args because of perl bug.
# Added warhing for null SMTP response.
#
# Revision 1.20  1996/10/09  22:03:07  tibbs
# Bump to rev 0.09a.
# Chomp redundant comments.
# Properly derive list name from address file.
# Take out a whold bunch of -d256 tests; we don't even pretend to do delivery
#   in that case.
# CloseAllConnections doesn't trip over LOCAL, removes stashed connection.
# RunTest doesn't send greeting twice, and closes conections when it's done.
#
# Revision 1.19  1996/10/09  04:15:26  tibbs
# Bumped to version 0.08a.
# Don't do any delivery-related stuff if -d256.
# Now warn if in failsafe mode.
# Fix bug with LOCAL mailer in OpenConnection.
# Add some return(1)'s to prevent failures when debugging.
# Better SMTP performance data for \r\n.\r\n and RCPT.
# Moved SMTP logging to level 12.
#
# Revision 1.18  1996/10/06  23:32:29  tibbs
# Bumped to release 0.07a.
# Delete cached connection when marking host down.
#
# Revision 1.17  1996/10/06  07:35:00  tibbs
# Added commands to open and close connections.
# GetResponse and SendSMTP can now ignore non-fatal eror replies.
# Moved SIGCHLD definition up a bit higher so Evan's system doesn't croak.
# Rewrote most of DeliverBatches to allow failure at any point without losing
#   or resending a batch.
# Rewrite OpenEnvelope to keep a record of open connections and not open one
#   if it's not necessary.
# Rewrote CloseEnvelope to keep the connection open.
# SendRCPT will return exceptional value on single-address batches that
#   return a non-fatal RCPT error.
#
# Revision 1.16  1996/10/04  22:57:07  tibbs
# GetResponse now takes a timeout value.
# Added DEFAULT_TIMEOUT.
# Fixed broken regexp handling in PushAddr.
# No need to avoid carning on $child_status.
# Minor code cleanups and realignments.
# Handle timeouts from GetResponse.
# An @envelope now includes a timeout.
# Log problem opening socket.
# Properly wait for spawned children to exit.
# SendSMTP now knows about GetResponse timing out, and will handle returned
#   error codes.
# Nicely format startup times.
#
# Revision 1.15  1996/09/28  08:48:32  tibbs
# Moved user-arg package munging up a bit, so we have $opt_l in the config
#   package before we set $list_name.
# Default $list_name to $opt_l if defined, otherwise use "init".  We'll later
#   extract it from $address_file if necesary.
# Abort if the config require fails.
# Add a couple of extra log messages in case of problems.
# Fix booboo in external spawning when -d tells us not to.
# Fix precedence bug in ChildReaper.
# Autoflush handles attached to commands.
# Don't close handles associated with programs; the reaper will take care of
#   them.
# Confess if Log is called with no message.  (Once got an error about this,
#   probably spurious.)
#
# Revision 1.14  1996/09/26  00:38:39  tibbs
# Use Time::HiRes if desired to give better performance date.
# Added extra command-line options that can be used for conditionals in the
#   config file.
# Initialize the @external_programs array.
# Abort due to config errors before providing after-config defaults.
# Reset the log file to pick up any changes made after bringing in the config
#   file, and to fill in the name of the list.
# Put the name of the list in the config file.
#
# Revision 1.13  1996/09/18  08:14:36  tibbs
# Released 0.05a after a week's testing.
# Added syslogging, including workaround for 5.003's bug and performance data.
# Only require 5.002; it should work.
# Carp on errors.
# Add usage and version info on the command line.
# Fix waitpid infloop bug; burn, Solaris, burn.
# More strictification.  I've exercised the code path now and it seems to be
# fine.
# Don't ever die; instead, we log and confess.  This gets around the complete
# lack of an error reporting channel when we're running as a sendmail
# replacement.
#
# Revision 1.12  1996/08/22  22:11:59  tibbs
# Fixed a couple of warnings and cleaned up some debugging output.
#
# Bumped to release 0.04.
#
# Revision 1.11  1996/08/22  05:51:17  tibbs
# Added $sorted_address_list and $stripped_address_list.
# More strict fixes.
#
# Revision 1.10  1996/08/20  06:54:58  tibbs
# Fixed bogus #-d in hash-bang line.
#
# Added info on getting copies of packages from hpc site.
#
# Converted to Mail::Address for parsing addresses, instead of using buggy
# routine.
#
# Added nosort flag to turn off sorting for batching methods that don't need
# it.
#
# Bumped to release 0.03.
#
# Revision 1.9  1996/08/15  17:24:36  tibbs
# Added BatchSeparatedomains method and hooks for calling it.
# Complete strictification (which fixed a few latent bugs).
# Added check for no specified config file.
#
# Revision 1.8  1996/08/12  09:39:45  tibbs
# Added death for unreadable config file.
# Added extra blank line at the end of piped messages.
# Release version 0.02a.
#
# Revision 1.7  1996/07/31  05:53:15  tibbs
# Added SendToExternals functionality.
# Added MakeFromLine.
#
# -d128 doesn't spawn externals.
# Use $tempdir
#
# ReadMessage returns a From_ line, even if it has to generate one.
# Took out extraneous bugfinding message in DeliverBatches.
#
# Slightly better error handling; now know what die does when spawned from
# sendmail.
#
# Rewrote ReadMessage copying.
#
# Revision 1.6  1996/07/22  17:48:35  tibbs
# Reworked version string.
# Converted to using TimeDate package for proper timezone offsets.
# Didn't properly close message after sending.
#
# Released 0.01a!
#
# Revision 1.5  1996/07/17  01:04:59  tibbs
# ReadMessage: eat blank lines and From_ headers until we see a real header.
#
# Revision 1.4  1996/07/16  22:52:30  tibbs
# Played with version handling.
# Changed format of received line.
# Adjusted for use with IO::Socket 1.08 instead of my gross patch.
# Started supporting help and version options.
#
# Revision 1.3  1996/07/15  06:10:04  tibbs
# Reordered subroutines and added extra commentary.
#
# Revision 1.2  1996/07/14  22:55:41  tibbs
# Continuing development.
#
# Revision 1.1  1996/07/01  21:19:48  tibbs
# Initial revision
#
#
