# General subroutines for Majordomo

# $Source: /sources/cvsrepos/majordomo/majordomo.pl,v $
# $Revision: 1.12.2.2.2.4 $
# $Date: 1995/01/07 17:34:27 $
# $Author: rouilj $
# $State: Exp $
# 
# $Header: /sources/cvsrepos/majordomo/majordomo.pl,v 1.12.2.2.2.4 1995/01/07 17:34:27 rouilj Exp $
# 
# $Locker:  $
# 
# updated to 1.21 with patch for LIST file handle.

package Majordomo;

#  Mail header hacking routines for Majordomo
#
#  Derived from:
#  Routines to parse out an RFC 822 mailheader
#     E. H. Spafford,  last mod: 11/91
#  
#  ParseMailHeader breaks out the header into an % array
#    indexed by a lower-cased keyword, e.g.
#       &ParseMailHeader(STDIN, *Array);
#	use $Array{'subject'}
#
#    Note that some duplicate lines (like "Received:") will get joined
#     into a single entry in %Array; use @Array if you want them separate
#    $Array will contain the unprocessed header, with embedded
#     newlines
#    @Array will contain the header, one line per entry
#
#  RetMailAddr tries to pull out the "preferred" return address
#    based on the presence or absence of various return-reply fields


#  Call as &ParseMailHeader(FileHandle, *array)

sub main'ParseMailHeader  ## Public
{
    local($save1, $save2) = ($*, $/);
    local($FH, *array) =  @_;
    local ($keyw, $val);

    %array = ();

    # force unqualified filehandles into callers' package
    local($package) = caller;
    $FH =~ s/^[^']+$/$package'$&/;

    ($*, $/) = (1, '');
    $array = $_ = <$FH>;
    s/\n\s+/ /g;
       
    @array = split('\n');
    foreach $_ (@array)
    {
	($keyw, $val) = m/^([^:]+):\s*(.*\S)\s*$/g;
	$keyw =~ y/A-Z/a-z/;
	if (defined($array{$keyw})) {
	    $array{$keyw} .= ", $val";
	} else {
	    $array{$keyw} = $val;
	}
    }
    ($*, $/) = ($save1, $save2); 
}


#  Call as $addr = &RetMailAddr(*array)
#    This assumes that the header is in RFC 822 format

sub main'RetMailAddr  ## Public
{
    local(*array) = @_;

    local($ReplyTo) = defined($array{'reply-to'}) ?
		$array{'reply-to'} : $array{'from'};

    $ReplyTo = $array{'apparently-from'} unless $ReplyTo;

    join(", ", &main'ParseAddrs($ReplyTo)) if $ReplyTo;
    $ReplyTo;
}

# @addrs = &ParseAddrs($addr_list)
sub main'ParseAddrs {
    local($_) = shift;
    1 while s/\([^\(\)]*\)//g; 		# strip comments
    1 while s/"[^"]*"//g;		# strip comments
    split(/,/);				# split into parts
    foreach (@_) {
	1 while s/.*<(.*)>.*/\1/;
	s/^\s+//;
	s/\s+$//;
    }

    @_;
}

# Check to see if a list is valid.  If it is, return the validated list
# name; if it's not, return ""
sub main'valid_list {
    local($listdir) = shift;
    # start with a space-separated list of the rest of the arguments
    local($taint_list) = join(" ", @_);
    # strip harmless matched leading and trailing angle brackets off the list
    1 while $taint_list =~ s/^<(.*)>$/\1/;
    # strip harmless trailing "@.*" off the list
    $taint_list =~ s/@.*$//;
    # anything else funny with $taint_list probably isn't harmless; let's check
    # start with $clean_list the same as $taint_list
    local($clean_list) = $taint_list;
    # clean up $clean_list
    $clean_list =~ s/[^-_0-9a-zA-Z]*//g;
    # if $clean_list no longer equals $taint_list, something's wrong
    if ($clean_list ne $taint_list) {
	return ""; 
    } 
    # convert to all-lower-case
    $clean_list =~ tr/A-Z/a-z/;
    # check to see that $listdir/$clean_list exists
    if (! -e "$listdir/$clean_list") {
	return "";
    }
    return $clean_list;
}

# compare two email address to see if they "match" by converting  to all
# lower case, then stripping off comments and comparing what's left.  If
# a optional third argument is specified and it's not undefined, then
# partial matches (where the second argument is a substring of the first
# argument) should return true as well as exact matches.
#
# if optional third argument is 2, then compare the two addresses looking
# to see if the addresses are of the form user@dom.ain.com and user@ain.com
# if that is the format of the two addresses, then return true.
sub main'addr_match {
    local($a1) = &main'chop_nl(shift);
    local($a2) = &main'chop_nl(shift);
    local($partial) = shift;	# may be "undef"

    if ($partial == 1) {
	$a1 =~ tr/A-Z/a-z/;
	$a2 =~ tr/A-Z/a-z/;
	if (index($a1, $a2) >= $[) {
	    return(1);
	} else {
	    return(undef);
	}
    }
	
    local(@a1, @a2);

    $a1 =~ tr/A-Z/a-z/;
    $a2 =~ tr/A-Z/a-z/;

    @a1 = &main'ParseAddrs($a1);
    @a2 = &main'ParseAddrs($a2);
    if (($#a1 != 0) || ($#a2 != 0)) {
	# Can't match, because at least one of them has either zero or
	# multiple addresses
	return(undef);
    }

    if ($partial == 2) { # see if addresses are foo@baz.bax.edu, foo@bax.edu
       local(@addr1,@addr2);
	  @addr1 = split(/@/, $a1[0]);
	  @addr2 = split(/@/, $a2[0]);
	  if ( $#addr1 == $#addr2 && $#addr1 == 1 && 
               $addr1[0] eq $addr2[0] && (index($addr1[1], $addr2[1]) >= $[))
	  {
	    return(1);
	  } else {
	    return(undef);
	  }
       }

    return($a1[0] eq $a2[0]);
}

# These are package globals referenced by &setabortaddr and &abort

$abort_addr = "Postmaster";

sub main'set_abort_addr {
    $abort_addr = shift unless ($#_ < $[);
}

# Abort the process, for the reason stated as the argument
sub main'abort {
    # log the reason for the abort, if possible
    &main'log("ABORT", join(" ", @_), "\n");
    # print the reason for the abort to stderr; maybe someone will see it
    print STDERR join(" ", @_), "\n";
    # send a message to the Majordomo owner, if possible
    if (defined($abort_addr)) {
	&main'sendmail(ABORT, $abort_addr, "MAJORDOMO ABORT");
	print ABORT <<"EOM";

MAJORDOMO ABORT

@_

EOM
	close(ABORT);
    }
    die("ABORT ", @_);
}

# These are package globals referenced by &setlogfile and &log
$log_file = "/tmp/log.$$";
$log_host = "UNKNOWN";
$log_program = "UNKNOWN";
$log_session = "UNKNOWN";

# set the log file
sub main'set_log {
    $log_file = shift unless ($#_ < $[);
    $log_host = shift unless ($#_ < $[);
    $log_program = shift unless ($#_ < $[);
    $log_session = shift unless ($#_ < $[);
}

# Log a message to the log
sub main'log {
    local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
    if (&main'lopen(LOG, ">>", $log_file)) {
	# if the log is open, write to the log
	printf LOG "%s %02d %02d:%02d:%02d %s %s[%d] {%s} ",
	    $ctime'MoY[$mon], $mday, $hour, $min, $sec,
	    $log_host, $log_program, $$, $log_session;
	print LOG join(" ", @_), "\n";
	&main'lclose(LOG);
    } else {
	# otherwise, write to stderr
	printf STDERR "%s[%d] {%s} ", $log_program, $$, $log_session;
	print STDERR join(" ", @_), "\n";
    }
}

# Globals referenced by &set_mail* and &sendmail
$mail_prog = "/usr/lib/sendmail -f\$sender -t";
$mail_from = "Majordomo";
$mail_sender = "Majordomo-Owner";

# set the mailer
sub main'set_mailer {
     $mail_prog = shift;
}

# set the default from address
sub main'set_mail_from {
    $mail_from = shift;
}

# set the default sender address
sub main'set_mail_sender {
    $mail_sender = shift;
}

# Open a sendmail process
sub main'sendmail {
    local($MAIL) = shift;
    local($to) = shift;
    local($subject) = shift;
    local($from) = $mail_from;
    local($sender) = $mail_sender;
    if ($#_ >= $[) { $from = shift; }
    if ($#_ >= $[) { $sender = shift; }

    # force unqualified filehandles into callers' package
    local($package) = caller;
    $MAIL =~ s/^[^']+$/$package'$&/;

    # clean up the addresses, for use on the sendmail command line
    local(@to) = &main'ParseAddrs($to);
    for (@to) {
	$_ = join(", ", &main'ParseAddrs($_));
    }
    $to = join(", ", @to);

    # open the process
    local(@mailer, $mailer);
    eval "\$mailer = \"$mail_prog\"";
    @mailer = split(' ', $mailer);
    open($MAIL, "|-") || &main'do_exec_sendmail(@mailer);

    # generate the header.  Note the line beginning with "-"; this keeps
    # this message from being reprocessed by Majordomo if some misbegotten
    # mailer out there bounces it back.
    print $MAIL 
"To: $to
From: $from
Subject: $subject
Reply-To: $from

--

";
    
    return;
}

sub main'do_exec_sendmail {
    &main'abort("do_exec_sendmail, number of args <= 1 unsafe to exec")
         if scalar(@_) <= 1;
    exec(@_);
    &main'log("Failed to exec mailer \"@_\": $!");
    die("Failed to exec mailer \"@_\": $!");
}

# check the password for a list
sub main'valid_passwd {
    local($listdir) = shift;
    local($list) = shift;
    local($passwd) = shift;
    # is it a valid list?
    local($clean_list) = &main'valid_list($listdir, $list);
    if ($clean_list ne "") {
	# it's a valid list check config passwd first 
        if (defined($main'config_opts{$clean_list,"admin_passwd"}) &&
            $passwd eq $main'config_opts{$clean_list,"admin_passwd"} ) 
	      {	return 1; }

	# read the password from the file in any case
	if (&main'lopen(PASSWD, "", "$listdir/$clean_list.passwd")) {
	    local($file_passwd) = <PASSWD>;
	    &main'lclose(PASSWD);
	    $file_passwd = &main'chop_nl($file_passwd);
	    # got the password; now compare it to what the user sent
	    if ($passwd eq $file_passwd) {
		return 1;
	    } else {
		return 0;
	    }
	} else {
	    return 0;
	}
    } else {
	return 0;
    }
}

# Check to see that this is a valid address. 
# A valid address is a single address with 
# no "/" or "|" in the address part.

sub main'valid_addr {
    local($addr) = shift;
    local(@addrs);

    # Parse the address out into parts
    @addrs = &main'ParseAddrs($addr);

    # if there's not exactly 1 part, it's no good
    if ($#addrs != 0) {
	return undef;
    }

    local($_) = @addrs;

    if ( $main'analyze_slash_in_address ) {
       # if there's a "|" in it, it's hostile
       if ( /\|/ ) {
           &main'abort("HOSTILE ADDRESS $addr pipe in address"); #'
           return undef;
       }
 
       # if the is a / in it, it may be an attempt to write to a file.
       # or it may be an X.400, HP Openmail or some other dain bramaged
       # address 8-(. We check this by breaking the address on '/'s
       # and checking to see if the first component of the address
       # exists in the filesystem. If it does we bounce it as a hostile
       # address.
 
       if ( m#/# ) {
          local(@components) = split( /\//, $_);
 
          # strip null element for / at beginning of address
	  # since the "/" directory always exists.
	  shift(@components) if ( $components[0] eq "" );

          &main'abort("HOSTILE ADDRESS $addr /$components[0] exists") 
                                    if (-e "/$components[0]"); #'
          &main'abort("HOSTILE ADDRESS $addr $components[0] exists")
                                    if (-e "$components[0]"); #'
 
          # then as an extra check that can be turned off in the majordomo.cf
          # file we make sure that the last component of the address has an
          # @ sign on it for an X.400->smtp gateway translation.
 
          if (!$main'no_x400at) {  
              print "$components[$#components]\n"
	      if ( "$components[$#components]" !~ /@/);  #'
              &main'abort("HOSTILE ADDRESS $addr no @ in last component")
	      if ( "$components[$#components]" !~ /@/);  #'
          } #'
 
          # check to see that the c= and a[dm]= parts exist in the X.400
	  # address
          if (!$main'no_true_x400) { 
             &main'abort("HOSTILE ADDRESS $addr no /c=") if ($_ !~ m#/c=#i); #'
             &main'abort("HOSTILE ADDRESS $addr no /a[dm]=") 
                            if ($_ !~ m#/a[dm]=#i); #'
	  } #'
	}
    } else {
        # if there's a "|" or a "/" in it, it's hostile
        if (tr/|\//|\// != 0) {
	    &main'abort("HOSTILE ADDRESS $addr"); #'
	    return undef;
        }
    }

    # if there is a - sign at the front of the address, it may be an attempt
    # to pass a flag to the MTA
    if ( /^-/ ) {
        &main'abort("HOSTILE ADDRESS $addr"); # '
        return undef;
    }

    return $_;
}

# is this a valid filename?
sub main'valid_filename {
    local($directory) = shift;
    local($list) = shift;
    local($suffix) = shift;
    local($taint_filename) = shift;
    local($clean_filename);

    # Safety check the filename.
    if ($taint_filename =~ /^[\/.]|\.\.|[^-_0-9a-zA-Z.\/] /) {
	return undef;
    } else {
	$clean_filename = $taint_filename;
    }
    if (! -e "$directory/$list$suffix/$clean_filename") {
	return undef;
    }
    return "$directory/$list$suffix/$clean_filename";
}

# Chop any trailing newlines off of a string, and return the string
sub main'chop_nl {
    if ($#_ >= $[) {
	local($x) = shift;
	$x =~ s/\n+$//;
	return($x);
    } else {
	return(undef);
    }
}

sub main'is_list_member {
    local($subscriber) = shift;
    local($listdir) = shift;
    local($clean_list) = shift;
    local($matches);
    local(*LIST);
    local($_);

    open(LIST, "$listdir/$clean_list")
	|| &main'abort("Can't read $listdir/$clean_list: $!");
    while (<LIST>) {
	if (&main'addr_match($subscriber, $_, 
	   (&main'cf_ck_bool($clean_list,"mungedomain") ? 2 : undef))) {
	    $matches++;
	}
    }
    close(LIST);
    return($matches);
}

sub main'open_temp {
    local($FH_name, $filename) = @_;
    local($inode1, $inode2, $dev1, $dev2) = ();

    # force unqualified filehandles into callers' package
    local($package) = caller;
    $FH_name =~ s/^[^']+$/$package'$&/;

    if ( -e $filename ) {
	&main'abort("Failed to open temp file $filename, it exists");
    }

    open($FH_name, ">> $filename") || 
	&main'abort("open of temp file $filename failed\n $!");

    if ( -l $filename ) {
	&main'abort("Temp file $filename is a symbolic link after opening");
    }

    if ( (stat(_))[3] != 1 ) {
	&main'abort("$filename has more than one link after opening");
    }

    ($dev1, $inode1) = (lstat(_))[0..1];
    local(*FH) = $FH_name;
    ($dev2, $inode2) = (stat(FH))[0..1];

    if ($inode1 != $inode2) {
	&main'abort("Inode for filename does not match filehandle!
                    Inode1=$inode1 Inode2=$inode2, Aborting.\n");
    }

    if ($dev1 != $dev2) {
	&main'abort("Device for filename does not match filehandle!
                    Inode1=$inode1 Inode2=$inode2, Aborting.\n");
    }

    if ( (stat(FH))[3] != 1 ) {
	&main'abort("filehandle has more than one link after opening");
    }
1;
}

1;