
# slocal subset

# Read maildelivery file in .slocal format.
# Returns arrays @field, @pat, @action, @res, @cmd.
sub read_delivery {
    open (IN, "maildelivery")  ||  die $?;

    while (<IN>) {
	next if /^\s*#/ || /^\s*$/;	# Skip blank and comment lines
	@line = split (" ");
	undef(@mailline);
	for ($i=0; $i<=$#line; $i++) {
	    $field = $line[$i];
	    if ($field =~ /^"/) {	# Re-join args collected by quotes
		while ((substr($field,-1,1) ne '"')  &&  (++$i<=$#line)) {
		    $field .= ' ' . $line[$i];
		}
		substr($field,0,1) = '';
		substr($field,-1,1) = '';
	    }
	    push (@mailline, $field);
	}			
	die "Incorrect number of fields on line:\n  ". $_ if @mailline != 5;
	($field[$ln], $pat[$ln], $action[$ln], $res[$ln], $cmd[$ln]) =
		    @mailline;
	# Lower-case field and pattern
	$field[$ln] =~ tr/A-Z/a-z/;
	$pat[$ln] =~ tr/A-Z/a-z/;
	++$ln;
    }
}

# Call to read mail header from parameter, e.g. read_header(STDIN).
# Returns headers and fields in associative array %head.
# Return header as a string in $head.
sub read_header {
    local ($/,$*,$s) = ("",1,@_);	# Paragraph mode
    $head = <$s>;		# Read header
    ($head1=$head) =~ tr/A-Z/a-z/;	# Lower case everything
    chop $head1;		# Delete trailing newline
    $head1 =~ s/\n\s+/ /g ;	# Merge continuation lines
    %head = ("FRONT\001", split(/^([-\w]+):/, $head1));
}

# Defines and subroutines for BSD-style mail delivery.
$LOCK_SH = 1;
$LOCK_EX = 2;
$LOCK_NB = 4;
$LOCK_UN = 8;
sub lock {
  local ($mbox) = @_;
  flock ($mbox, $LOCK_EX);
  # and, in case someone appended while we were waiting...
  seek($mbox, 0, 2);
}
sub unlock {
  local ($mbox) = @_;
  flock ($mbox, $LOCK_UN);
}

# Call as &maildeliver ($mailbox, $message).
# Delivers the message to the specified mailbox using BSD conventions.
# Returns $mailstat = 1 if it fails, $mailstat = 0 if it succeeds.
#
sub maildeliver {
    local ($*, $mbox, $msg) = (1, @_);
    # Eliminate trailing blank lines
    chop($msg) while substr($msg,-1,1) eq "\n";

    # Quote '^From ' lines
    $msg =~ s/\nFrom /\n>From /g;

    open (MBOX, ">>$mbox") || ($mailstat = 1 && return);
    &lock(MBOX);
    print STDOUT $msg, "\n\n";
# Wed Nov 25 09:39:04 1992
# Had a bug where we would do just an unlock here.  Since we hadn't
# closed the FD, another process which immediately grabbed a lock
# which would do a seek to the end, didn't always find the right spot
# due to buffering.  So we close instead, which automatically releases
# the lock.
#   &unlock(MBOX);
    close(MBOX);
    $mailstat = 0;
}


# Exercise the above subroutines


# Prepare for debugging logging

#open (LOG, ">/tmp/LOG$$") || die "Can't log: $!\n";
open (LOG, ">/dev/null");
select(LOG);
print "Starting process $$\n";
print "Environment = ", join(',',%ENV), "\n";
print "UID = $<; EUID = $>; CWD = " . `pwd`;

# Parse optional command-line argument, or use effective user ID.
($user, $passwd, $uid, $gid, $quota, $comm, $gcos, $dir, $shell) =
	($user = $ARGV[0]) ? getpwnam($user) : getpwuid($>);
	
die "Usage: $0 [username]\n" if $dir eq '';

$mbox = "/usr/spool/mail/$user";
chdir("$dir/.remail") || die "Chdir failure: $!\n";
print "MBOX = $mbox; CWD = " . `pwd`;

# Some systems run mail delivery with a pretty bare environment.
$ENV{'USER'} = $user;
$ENV{'HOME'} = $dir;
substr($ENV{'PATH'},0,0) = ".:";
$gcos =~ s/&/$user/;
$gcos =~ s/,+$//;
$ENV{'USERNAME'} = $gcos;	# Remailer uses this
print "Environment = ", join(',',%ENV), "\n";

# My version of Perl (4.0) needs this or unsuccessful pipe commands
# cause it to silently die.
$SIG{'PIPE'} = 'IGNORE';

# Read things...
&read_delivery ;
&read_header(STDIN);
$msg = join ('', $head, <STDIN>);

for $i (0 .. $#field) {
    $field = $field[$i];
    if (defined ($head{$field})  ||  $field eq "*") {
	if (($field eq "*")  ||  ($head{$field} =~ /$pat[$i]/)  ||
			$pat[$i] eq "") {
print "Match on field $field, pattern $pat[$i], contents are: $head{$field}\n";
	    # Here we have a match.
	    next if ($delivered && $res[$i] eq '?');
	    if ($action[$i] eq "file" || $action[$i] eq ">") {
print "Delivering to file $cmd[$i]\n";
		&maildeliver ( $cmd[$i], $msg );
print "(File write returned status: $mailstat)\n";
		if ($res[$i] =~ /A|\?/  && $mailstat == 0) {
print "Now delivered.\n";
		    $delivered = 1;
		}
		next;
	    }
	    if ($action[$i] eq "pipe" || $action[$i] eq "|") {
print "Delivering to pipe $cmd[$i]\n";
		open (PIPE, "|" . $cmd[$i]);
		print(PIPE $msg);
		close(PIPE);
print "$?\n";
		$mailstat = $?;
print "(Pipe returned status: $mailstat)\n";
		if ($res[$i] =~ /A|\?/  && $mailstat == 0) {
print "Now delivered.\n";
		    $delivered = 1;
		}
		next;
	    }
	}
    }
}

# Possibly deliver to default mailbox, found from command-line argument
if (!$delivered) {
print "Delivering to regular mailbox: $mbox\n";
    &maildeliver ( $mbox, $msg );
print "(Result status: $mailstat)\n";
}
