mailagent 1:3.1-81-4 / usr / bin / maillist

#!/usr/bin/perl
	eval 'exec perl -S $0 ${1+"$@"}'
		if $running_under_some_shell;

# $Id: maillist.SH 75 2011-12-23 10:18:37Z rmanfredi $
#
#  Copyright (c) 1990-2006, Raphael Manfredi
#  
#  You may redistribute only under the terms of the Artistic License,
#  as specified in the README file that comes with the distribution.
#  You may reuse parts of this distribution only within the terms of
#  that same Artistic License; a copy of which may be found at the root
#  of the source tree for mailagent 3.0.
#
# $Log: maillist.SH,v $
# Revision 3.0.1.6  1996/12/24  14:07:48  ram
# patch45: silently discard hostile addresses
# patch45: knows about command forwarding
#
# Revision 3.0.1.5  1995/08/07  16:12:48  ram
# patch37: forgot to define phostname, needed for NFS-secure locks
#
# Revision 3.0.1.4  1995/03/21  12:55:09  ram
# patch35: added pl/cdir.pl to the list of appended files
#
# Revision 3.0.1.3  1995/02/16  14:27:01  ram
# patch32: forgot to include pl/hostname.pl for NFS-secure locks
#
# Revision 3.0.1.2  1994/10/10  10:22:54  ram
# patch19: added various escapes in strings for perl5 support
#
# Revision 3.0.1.1  1994/10/04  17:36:37  ram
# patch17: extended logging to get better error/failure tracking
#
# Revision 3.0  1993/11/29  13:48:24  ram
# Baseline for mailagent 3.0 netwide release.
#

$mversion = '3.1';
$patchlevel = '0';
$revision = '81';
$phostname = '';

$prog_name = $0;				# Who I am
$prog_name =~ s|^.*/(.*)|$1|;	# Keep only base name

&read_config;		# First, read configuration file (in ~/.mailagent)

# take job number and command from environment
# (passed by mailagent)
$jobnum = $ENV{'jobnum'};
$fullcmd = $ENV{'fullcmd'};

$dest=shift;							# Who should the list to be sent to
$dest = $ENV{'path'} if $dest eq '';	# If dest was omitted

# A single '-' as first argument stands for return path
$dest = $ENV{'path'} if $dest eq '-';

# Silently discard hostile addresses
unless (&addr'valid($dest)) {
	&add_log("FAILED (HOSTILE $dest)") if $loglvl > 1;
	exit 0;
}

&read_dist;			# Read distributions and descriptions

open(INFO, "$cf'proglist") ||
	&fatal("cannot open description file");
@sysinfo = <INFO>;
close INFO;

&read_plsave;		# Read patchlevel description file
		
$tmp_mail = "$cf'tmpdir/xml$$";

open(XHEAD, ">$tmp_mail") || &fatal("cannot create $tmp_mail");
print XHEAD
"To: $dest
Subject: List of available distributions
X-Mailer: mailagent [version $mversion-$revision]

Here are the different packages available. If you want the whole
distribution, send me the following:

	\@SH maildist $dest system version

If you want patches, use:

	\@SH mailpatch $dest system version LIST

where LIST is a list of patches number, separated by spaces, commas,
and/or hyphens. Saying 23- means everything from 23 to the end.

Detailed instructions can be obtained by:

	\@SH mailhelp $dest


";

foreach $pname (keys %Program) {
	($system, $version) = $pname =~ /^([\w-]+)\|([\w\.]+)*$/;
	$version = '---' if $version eq '0';
	$location = $Location{$pname};
	&add_log("dealing with $system $version") if $loglvl > 19;
	$forwarded = '';	# Set to forwarded addresses when .forward found...

	# Look for highest patchlevel (even if not maintained)
	$tmp = "";			# Temporary directory created

	if ($Archived{$pname}) {
		unless ($PSystem{$pname}) {
			# Archive not already listed in 'plsave'. Create a new
			# entry with a modification time of zero.
			$PSystem{$pname} = 1;
			$Patch_level{$pname} = -1;	# Not a valid patch level
			$Mtime{$pname} = 0;			# Force unpacking of archive
		}

		# We need to unarchive the directory only if archive
		# modification time is newer than the one in patchlist
		local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime, $mtime,
			$ctime,$blksize,$blocks) = stat(&expand($location));

		if ($mtime != $Mtime{$pname}) {	 # Archive was updated
			$Mtime{$pname} = $mtime;	 # Update mod time in 'plsave'
			# Create a temporary directory
			$tmp = "$cf'tmpdir/dml$$";
			mkdir($tmp, 0700) ||
				&fatal("cannot create $tmp");
			# Need to unarchive the distribution
			$location = &unpack($location, $tmp, $Compressed{$pname});
			$Patch_level{$pname} = -1;	# Force updating
		} else {
			&add_log("no changes in $system $version archive")
				if $loglvl > 15;
		}

	} else {
		# System is not archived
		$Patch_level{$pname} = -1;		# Force computation
	}

	if ($Patch_level{$pname} == -1) {
		# We still don't know wether there is a patchlevel or not...
		# Go to system directory, and look there.
		if (!chdir("$location")) {
			&add_log("ERROR cannot go to $location") if $loglvl;
			next;
		}
		if ($Patch_only{$pname}) {		# Only patches available
			if ($version eq '') {
				&add_log("ERROR old system $system has no version number")
					if $loglvl;
				next;
			}
			if (!chdir("bugs-$version")) {
				&add_log("ERROR no bugs-$version dir for $system")
					if $loglvl;
				next;
			}
			local($maxnum);
			# There is no patchlevel to look at -- compute by hand.
			for ($maxnum = 1; ; $maxnum++) {
				last unless -f "patch$maxnum" || -f "patch$maxnum.Z";
			}
			$maxnum--;		# We've gone too far
			$Patch_level{$pname} = $maxnum;
		} elsif (! -f 'patchlevel.h') {
			&add_log("no patchlevel.h for $system $version") if $loglvl > 17;
		} elsif (!open(PATCHLEVEL, "patchlevel.h")) {
			&add_log("cannot open patchlevel.h for $system $version")
				if $loglvl > 5;
		} else {
			while (<PATCHLEVEL>) {
				if (/.*PATCHLEVEL[ \t]*([\w-]+)/) {	# May have letters
					$Patch_level{$pname} = $1;
					last;
				}
			}
			close PATCHLEVEL;
			if ($Patch_level{$pname} == -1) {
				&add_log("malformed patchlevel.h for $system $version")
					if $loglvl > 5;
			}
		}
	}

	if ($Patch_level{$pname} >= 0) {
		&add_log("patchlevel is #$Patch_level{$pname} for $system $version")
			if $loglvl > 18;
	} else {
		$Patch_level{$pname} = -2;		# Signals: no patchlevel
		&add_log("no patchlevel for $system $version") if $loglvl > 18;
	}

	# If a .forward file is present, maintenance activity is now remotely
	# handled, and all command mails like mailpath and maildist will be
	# forwarded according to that file.
	if (-f '.forward') {
		$forwarded = join(", ", &forward_list);
	}
	
	&clean_dir;			 # Remove tmp directory, if necessary

	# Now look for a description of the package...
	$describe = "";
	$found = 0;
	foreach (@sysinfo) {
		next if /^\s*#/;	# Skip comments
		next if /^\s*$/;	# Skip blank lines
		next if /^\*\s+$system/ && ($found = 1);
		last if $found && /^---|^\*/;		# Reached end of description
		$describe .= "X" . $_ if $found;
	}
	$* = 1;
	$describe =~ s/^X/\t/g;		# Indent description
	$* = 0;

	print XHEAD "System: $system";
	print XHEAD " version $version" if $version !~ /---/;
	print XHEAD "\nStatus: ";
	print XHEAD $Maintained{$pname} ? "maintained" : "not maintained";
	print XHEAD " (patches only)" if $Patch_only{$pname};
	print XHEAD " (official patches available)" if $Patches{$pname};
	print XHEAD "\n";
	if ($forwarded) {
		print XHEAD $Maintained{$pname} ? "Maintained-by: " : "Contact: ";
		print XHEAD "$forwarded\n";
	}
	if ($Maintained{$pname}) {
		if ($Patch_level{$pname} > 0) {
			print XHEAD "Highest patch: #$Patch_level{$pname}\n";
		} else {
			print XHEAD "No patches yet\n";
		}
	} else {
		print XHEAD "Patch level: #$Patch_level{$pname}\n"
			if $Patch_level{$pname} > 0;
	}
	print XHEAD "\n";
	print XHEAD "$describe\n" if $describe ne '';
	print XHEAD "\n";
}
print XHEAD "-- $prog_name speaking for $cf'user\n";
close XHEAD;

open(XHEAD, "$tmp_mail") || &fatal("cannot open mail file");
open(MAILER, "|$cf'sendmail $cf'mailopt $dest") || &nofork;
while (<XHEAD>) {
	print MAILER;
}
close MAILER;
if ($?) {
	&add_log("ERROR couldn't send list to $dest") if $loglvl > 0;
} else {
	&add_log("SENT list to $dest") if $loglvl > 2;
}
close XHEAD;

&write_plsave;			# Write new patchlist file
&clean_tmp;				# Remove temporary dirs/files
exit 0;					# All OK

sub clean_dir {
	chdir $cf'home;		# Leave [to be removed directory] first
	if ($tmp ne '') {
		system '/bin/rm', '-rf', $tmp if -d "$tmp";
		&add_log("directory $tmp removed") if $loglvl > 19;
		$tmp = "";
	}
}

sub clean_tmp {
	&clean_dir;
	unlink "$tmp_mail" if -f "$tmp_mail";
}

# Report error while forking a sendmail process
sub nofork {
	&add_log("SYSERR fork: $!") if $loglvl;
	&add_log("ERROR cannot launch $cf'sendmail") if $loglvl;
}

# In case of fatal error, the program does not simply die
# but also records the failure in the log.
sub fatal {
	local($reason) = @_;			# Why did we get here ?
	&add_log("FAILED ($reason)") if $loglvl > 0;
	die "$prog_name: $reason\n";
}

# Emergency signal was caught
sub emergency {
	local($sig) = @_;			# First argument is signal name
	&fatal("trapped SIG$sig");
}

#
# acs_rqst
#
# Attempt to lock $file, using $format as locking format (used to derive the
# name of the lock file from the filename).
#
# Returns 0 if locked, -1 otherwise.
#
sub acs_rqst {
	local($file, $format) = @_;		# file to be locked, lock format
	return &acs_lock($file, $format, 0);
}

#
# acs_locktry
#
# Same as acs_rqst, but if the file is already locked by some other party, we
# do not wish to wait for the lock.
#
# Returns 1 if locked by someone else, 0 if locked by us, -1 otherwise.
sub acs_locktry {
	local($file, $format) = @_;		# file to be locked, lock format
	return &acs_lock($file, $format, 1);
}

#
# acs_lock
#
# Asks for the exclusive access of a file. The config variable 'nfslock'
# determines whether the locking scheme has to be NFS-secure or not.
# The given parameter (let's say F) is the absolute path of the file we want
# to access. The routine checks for the presence of F.lock. If it exists, it
# sleeps 2 seconds and tries again. After 10 trys, it reports failure by
# returning -1. Otherwise, file F.lock is created and the pid of the current
# process is written. It is checked afterwards.
#
# When $try is true, we return 1 if the file is already locked. This is used
# to attempt locking only when the file is not otherwise locked.
#
sub acs_lock {
	local($file, $format, $try) = @_;	# file to be locked, format, try only?
	local($max) = $cf'lockmax;		# max number of attempts
	local($delay) = $cf'lockdelay;	# seconds to wait between attempts
	local($mask);		# to save old umask
	local($stamp);		# string written in lock file
	&checklock($file, $format);		# avoid long-lasting locks
	if ($cf'nfslock =~ /on/i) {			# NFS-secure lock wanted
		$stamp = "$$" . &hostname;		# use PID and hostname
	} else {
		$stamp = "$$";					# use PID only (may spare a fork)
	}
	local($lockfile) = $file . $lockext;
	$lockfile = &lock'file($file, $format) if $format ne '';
	local($waited) = 0;					# amount of time spent sleeping
	local($lastwarn) = 0;				# last time we warned them...
	local($wmin, $wafter);				# busy lock warn limits

	if ($cf'lockwarn =~ /(\d+),\s*(\d+)/)	{ ($wmin, $wafter) = ($1, $2) }
	elsif ($cf'lockwarn =~ /(\d+)/)			{ ($wmin, $wafter) = ($1, $1) }
	else									{ ($wmin, $wafter) = (20, 300) }

	while ($max > 0) {
		$max--;
		if (-f $lockfile) {
			return 1 if $try;			# already locked
			next;
		}

		# Attempt to create lock
		$mask = umask(0333);			# no write permission
		if (open(FILE, ">$lockfile")) {
			print FILE "$stamp\n";		# write locking stamp
			close FILE;
			umask($mask);				# restore old umask
			# Check lock
			open(FILE, $lockfile);
			chop($_ = <FILE>);			# read contents
			close FILE;
			last if $_ eq $stamp;		# lock is ok
		} else {
			umask($mask);				# restore old umask
			return 1 if $try;			# already locked
			next;
		}
	} continue {
		sleep($delay);				# busy: wait
		$waited += $delay;
		# Warn them once after $wmin seconds and then every $wafter seconds
		if (
			(!$lastwarn && $waited > $wmin) ||
			($waited - $lastwarn) > $wafter
		) {
			local($waiting) = $lastwarn ? 'still waiting' : 'waiting';
			local($after) = $lastwarn ? 'after' : 'since';
			&add_log("WARNING $waiting for $file lock $after $waited seconds")
				if $loglvl > 3;
			$lastwarn = $waited;
		}
	}
	if ($max) {
		&add_log("NOTICE got $file lock after $waited seconds")
			if $lastwarn && $loglvl > 6;
		$result = 0;	# ok
	} else {
		$result = -1;	# could not lock
	}
	$result;			# return status
}

package lock;

# Return the name of the lockfile, given the file name to lock and the custom
# string provided by the user. The following macros are substituted:
#	%D: the file dir name
#   %f: the file name (full path)
#   %F: the file base name (last path component)
#   %p: the process's pid
#   %%: a plain % character
sub file {
	local($file, $_) = @_;
	s/%%/\01/g;				# Protect double percent signs
	s/%/\02/g;				# Protect against substitutions adding their own %
	s/\02f/$file/g;			# %f is the full path name
	s/\02D/&dir($file)/ge;	# %D is the dir name
	s/\02F/&base($file)/ge;	# %F is the base name
	s/\02p/$$/g;			# %p is the process's pid
	s/\02/%/g;				# All other % kept as-is
	s/\01/%/g;				# Restore escaped % signs
	$_;
}

# Return file basename (last path component)
sub base {
	local($file) = @_;
	local($base) = $file =~ m|^.*/(.*)|;
	$base;
}

# Return dirname
sub dir {
	local($file) = @_;
	local($dir) = $file =~ m|^(.*)/.*|;
	$dir;
}

package main;

# Remove the lock on a file. Returns 0 if ok, -1 otherwise
# Locking format is optional but when given must match the one used by
# the &acs_rqst() locking routine.
sub free_file {
	local($file, $format) = @_;		# locked file, locking format
	local($stamp);					# string written in lock file

	if ($cf'nfslock =~ /on/i) {			# NFS-secure lock wanted
		$stamp = "$$" . &hostname;		# use PID and hostname
	} else {
		$stamp = "$$";					# use PID only (may spare a fork)
	}

	local($lockfile) = $file . $lockext;
	$lockfile = &lock'file($file, $format) if defined $format;

	if ( -f $lockfile) {
		# if lock exists, check for pid
		open(FILE, $lockfile);
		chop($_ = <FILE>);
		close FILE;
		if ($_ eq $stamp) {
			# pid (plus hostname eventually) is correct
			$result = 0;
			unlink $lockfile;
		} else {
			# pid is not correct (we did not get that lock)
			$result = -1;
		}
	} else {
		# no lock file
		$result = 0;
	}
	$result;	# return status
}

# Add an entry to logfile
# There is no need to lock logfile as print is sandwiched betweeen
# an open and a close (kernel will flush at the end of the file).
sub add_log {
	# Indirection needed, so that we may remap add_log on stderr_log via a
	# type glob assignment.
	&usrlog'write_log($cf'logfile, $_[0], undef);
}

# When mailagent is used interactively, log messages are also printed on
# the standard error.
# NB: this function is not called directly, but via a type glob *add_log.
sub stderr_log {
	print STDERR "$prog_name: $_[0]\n";
	&usrlog'write_log($cf'logfile, $_[0], undef);
}

# Routine used to emit logs when no logging has been configured yet.
# As soon as a valid configuration has been loaded, logs will also be
# duplicated into the logfile. Used solely by &cf'setup.
# NB: this function is not called directly, but via a type glob *add_log.
sub stdout_log {
	print STDOUT "$prog_name: $_[0]\n";
	&usrlog'write_log($cf'logfile, $_[0], undef) if defined $cf'logfile;
}

#
# User-defined log files
#

package usrlog;

# Record a new logfile by storing its pathname in the %Logpath hash table
# indexed by names and the carbon-copy flag in the %Cc table.
sub new {
	local($name, $path, $cc) = @_;
	return if defined $Logpath{$name};	# Logfile already recorded
	return if $name eq 'default';		# Cannot redefined defaul log
	$path = "$cf'logdir/$path" unless $path =~ m|^/|;
	$Logpath{$name} = $path;			# Where logfile should be stored
	$Cc{$name} = $cc ? 1 : 0;			# Should we cc the default logfile?
	$Map{$path} = $name;				# Two-way hash table
}

# Delete user-defined logfile.
sub delete {
	local($name) = @_;
	return unless defined $Logpath{$name};
	local($path) = $Logpath{$name};
	delete $Logpath{$name};
	delete $Cc{$name};
	delete $Map{$path};
}

# User-level logging main entry point
sub main'usr_log {
	local($name, $message) = @_;	# Logfile name and message to be logged
	local($file);
	$file = ($name eq 'default' || !defined $Logpath{$name}) ?
		$cf'logfile : $Logpath{$name};
	&write_log($file, $message, $Cc{$name});
}

# Log message into logfile, using jobnum to identify process.
sub write_log {
	local($file, $msg, $cc) = @_;	# Logfile, message to be logged, cc flag
	local($date);
	local($log);

	return unless length $file;

	local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
		localtime(time);
	$date = sprintf("%.2d/%.2d/%.2d %.2d:%.2d:%.2d",
		$year % 100,++$mon,$mday,$hour,$min,$sec);
	$log = $date . " $'prog_name\[$'jobnum\]: $msg\n";

	# If we cannot append to the logfile, first check whether it is the default
	# logfile or not. If it is not, then add a log entry to state the error in
	# the default log and then delete that user logname entry, assuming the
	# fault we get is of a permanent nature and not an NFS failure for instance.

	unless (open(LOGFILE, ">>$file")) {
		if ($file ne $cf'logfile) {
			local($name) = $Map{$file};	# Name under which it was registered
			&'add_log("ERROR cannot append to $name logfile $file: $!")
				if $'loglvl > 1;
			&'add_log("NOTICE removing logging to $file") if $'loglvl > 6;
			&delete($Map{$file});
			$cc = 1;				# Force logging to default file
		} else {					# We were already writing to default log
			return;					# Cannot log message at all
		}
	}

	print LOGFILE $log;
	close LOGFILE;

	# If $cc is set, a copy of the same log message (same time stamp guaranteed)
	# is made to the default logfile. If called with $file set to that default
	# logfile, $cc will be undef by construction.

	if ($cc) {
		open(LOGFILE, ">>$cf'logfile");
		print LOGFILE $log;
		close LOGFILE;
	}
}

package main;

package cf;

# This package is responsible for keeping track of the configuration variables.

# Read configuration file (usually in ~/.mailagent)
sub main'read_config {
	local($file) = @_;				# where config file is located
	local($_);
	$file = '~/.mailagent' unless $file;
	local($myhome) = $ENV{'HOME'};	# must be correctly set by filter
	$file =~ s/~/$myhome/;			# ~ substitution
	local($main'config) = $file;	# Save it: could be modified by config
	open(CONFIG, "$file") ||
		&'fatal("can't open config file $file");
	local($config) = ' ' x 2000;	# pre-extend to avoid realloc()
	$config = '';
	while (<CONFIG>) {
		next if /^[ \t]*#/;			# skip comments
		next if /^[ \t]*\n/;		# skip empy lines
		s/([^\\](\\\\)*)@/$1\\@/g;	# escape all un-escaped @ in string
		$config .= $_;
	}
	&parse($config) || &'fatal('bad configuration');
	close CONFIG;

	# Security checks, pending of those performed by the C filter. They are
	# somewhat necessary, even though the mailagent does not run setuid
	# (because anybody may activate the mailagent for any user by sending him
	# a mail, and world writable configuration files makes the task too easy
	# for a potential hacker). The tests are performed once the configuration
	# file has been parsed, so logging of fatal errors may occur.

	local($unsecure) = 0;

	$unsecure++ unless &'file_secure($'config, 'config');
	$unsecure++ unless &'file_secure($rules, 'rule');
	&'fatal("unsecure configuration!") if $unsecure;

	return unless -f "$rules";		# No rule file
}

# Parse config file held in variable and return 1 if ok, 0 for errors
sub parse {
	local($config) = @_;
	return 1 unless defined $config;
	local($eval) = ' ' x 1000;		# Pre-extend
	local($myhome) = $ENV{'HOME'};	# must be correctly set by filter
	local($var, $value);
	local($_);
	$eval = '';
	foreach (split(/\n/, $config)) {
		if (/^[ \t]*([^ \t\n:\/]*)[ \t]*:[ \t]*([^#\n]*)/) {
			$var = $1;
			$value = $2;
			$value =~ s/\s*$//;						# remove trailing spaces
			$eval .= "\$$var = \"$value\";\n";
			$eval .= "\$$var =~ s|~|\$myhome|g;\n";	# ~ substitution
		}
	}
	eval $eval;			# evaluate configuration parameters within package

	if ($@ ne '') {				# Parsing error detected
		local($error) = $@;		# Logged error
		$error = (split(/\n/, $error))[0];		# Keep only first line
		# Dump error message on stderr, as well as faulty configuration file.
		# The original is restored out of the perl form to avoid surprise.
		$eval =~ s/^\$.* =~ s\|~\|.*\n//gm;		# Remove added ~ substitutions
		$eval =~ s/^\$//gm;						# Remove leading '$'
		$eval =~ s/ = "(.*)";/: $1/gm;			# Keep only variable value
		chop($eval);
		print STDERR <<EOM;
**** Syntax error in configuration:
$error

---- Begin of Faulty Configuration
$eval
---- End of Faulty Configuration

EOM
		&'add_log("syntax error in configuration: $error") if $'loglvl > 1;
		return 0;
	}

	# Define the mailagent parameters from those in config file
	$logfile = $logdir . "/$log";
	$seqfile = $spool . "/$seq";
	$hashdir = $spool . "/$hash";
	$main'loglvl = int($level);		# This one is visible in the main package
	$main'track_all = 1 if $track =~ /on/i;		# Option -t set by config
	$sendmail = $'mailer if $sendmail eq '';	# No sendmail program specified
	$sendnews = $'inews if $sendnews eq '';		# No news posting program
	$mailopt = '-odq -i' if $mailopt eq '' && $sendmail =~ /sendmail/;

	# Backward compatibility -- RAM, 25/04/94
	$fromesc = 'ON' unless defined $fromesc;	# If absent from ~/.mailagent
	$lockmax = 20 unless defined $lockmax;
	$lockdelay = 2 unless defined $lockdelay;
	$lockhold = 3600 unless defined $lockhold;
	$queuewait = 60 unless defined $queuewait;
	$queuehold = 1800 unless defined $queuehold;
	$queuelost = 86400 unless defined $queuelost;
	$runmax = 3600 unless defined $runmax;
	$umask = 077 unless defined $umask;
	$email = $user unless defined $email;
	$compspec = "$spool/compressors" unless defined $compspec;
	$comptag = 'gzip' unless defined $comptag;
	$locksafe = 'OFF' unless defined $locksafe;
	$execsafe = 'OFF' unless defined $execsafe;

	# For backward compatibility, we force a .lock locking on mailboxes.
	# For system ones (name = login), there's no problem because the lock
	# file is still under the 14 characters limit. If mail is saved in folders
	# whose name is longer, there might be problems though. There's little we
	# can do about it here, lest they choose an alternate locking name.
	# Note that mailagent's $lockext global variable setting depends on the
	# fact that the target system supports flexible filenames or not, so only
	# mailbox locking is a problem -- RAM, 18/07/95

	$mboxlock = '%f.lock' unless defined $mboxlock;

	# Backward compatibility -- RAM, 17/03/2001
	$domain = $main::hiddennet || $main::mydomain unless defined $domain;
	$hidenet = $main::hiddennet eq '' ? 'OFF' : 'ON' unless defined $hidenet;

	$umask = oct($umask) if $umask =~ /^0/;	 # Translate umask into decimal
	$domain =~ s/^\.*//;					 # Strip leading '.'

	# Update @INC perlib search path with the perlib variable. Paths not
	# starting by a '/' are supposed to be under the mailagent private lib
	# directory.

	local(%seen);		# Avoid dups in @INC (might be called more than once)

	foreach (@INC) { $seen{$_}++; }

	if (defined $perlib) {
		foreach (split(':', $perlib)) {
			s/^~/$home/;
			$_ = $'privlib . '/' . $_ unless m|^/|;
			push(@INC, $_) unless $seen{$_}++;
		}
	}

	1;		# Ok
}

package main;

# Expands an archive's name
sub expand {
	local($path) = shift;		# The archive
	# Look for extension of base path (eg: .cpio.Z)
	local(@fullpath) = <${path}.*>;
	if (-1 == $#fullpath) {
		&clean_tmp;
		&fatal("no archive file");
	}
	$path = $fullpath[0];		# Name with archive extension
}

# Unpack(path,dir,flag) restores archive `path' into `dir'
# and returns the location of the main directory.
sub unpack {
	local($path) = shift;		# The archive
	local($dir) = shift;		# Storage place
	local($compflag) = shift;	# Flag for compression (useful for short names)
	local($unpack) = "";		# Will hold the restore command
	$path = &expand($path);		# Name with archive extension
	&add_log("archive is $path") if $loglvl > 19;
	# First determine wether it is compressed
	if ($compflag) {
		$unpack = "zcat | ";
	}
	# Cpio or tar ?
	if ($path =~ /\.tar/) {
		$unpack .= "tar xof -";
	} else {
		$unpack .= "cpio -icmd";
	}
	system "< $path (cd $dir; $unpack)";
	$path =~ s|.*/([\w-]+)|$1|;	# Keep only basename
	local ($stat) = $?;			# Return status
	if ($stat) {
		&clean_tmp;
		&fatal("unable to unpack $path");
	}
	&add_log("unpacked $path with \"$unpack\"") if $loglvl > 12;

	# The top level directory is the only file in $dir
	local(@top) = <${dir}/*>;
	if ($#top < 0) {
		&clean_tmp;
		&fatal("$prog_name: no top-level dir for $path");
	}
	if ($#top > 0) {
		&add_log("WARNING more than one file in $dir") if $loglvl > 4;
	}
	&add_log("top-level dir for $path is $top[0]") if $loglvl > 19;
	$top[0];		# Top-level directory
}

# Read a distribution file and fill in data structures for
# the query functions. All the data are stored in associative
# arrays, indexed by the system's name and version number.
# Associative arrays are:
#
# name          indexed by       information
#
# %Program      name + version   have we seen that line ?
# %System       name             is name a valid system ?
# %Version      name             latest version for system
# %Location		name + version   location of the distribution
# %Archived     name + version   is distribution archived ?
# %Compressed   name + version   is archive compressed ?
# %Patch_only   name + version   true if only patches delivered
# %Maintained   name + version   true if distribution is maintained
# %Patches      name + version   true if official patches available
#
# For systems with a version of '---' in the file, the version
# for accessing the data has to be a "0" string.
#
# Expected format for the distribution file:
#     system version location archive compress patches
#
# The `archive', `compress' and `patches' fields can take one
# of the following states: "yes" and "no". An additional state
# for `patches' is "old", which means that only patches are
# available for the version, and not the distribution. Another is
# "patch" which means that official patches are available.
# All these states can be abbreviated with the first letter.
#
sub read_dist {
	local($fullname);
	open(DIST, "$cf'distlist") ||
		&fatal("cannot open distribution file");
	while (<DIST>) {
		next if /^\s*#/;	# skip comments
		next if /^\s*$/;	# skip empty lines
		next unless s/^\s*(\w+)\s+([.\-0-9]+)//;
		$fullname = $1 . "|" . ($2 eq '---'? "0" : $2);
		if (defined $Program{$fullname}) {
			&add_log("WARNING duplicate distlist entry $1 $2 ignored")
				if $loglvl > 5;
			next;
		}
		$Program{$fullname}++;
		$Version{$1} = ($2 eq '---' ? "0" : $2) unless
			defined($System{$1}) && $Version{$1} > ($2 eq '---' ? "0":$2);
		$System{$1}++;
		unless (/^\s*(\S+)\s+(\w+)\s+(\w+)\s+(\w+)/) {
			&add_log("WARNING bad system description line $.")
				if $loglvl > 5;
			next;	# Ignore, but it may corrupt further processing
		}
		local($location) = $1;
		local($archive) = $2;
		local($compress) = $3;
		local($patch) = $4;
		$location =~ s/~\//$cf'home\//;		# ~ expansion
		$Location{$fullname} = $location;
		$Archived{$fullname}++ if $archive =~ /^y/;
		$Compressed{$fullname}++ if $compress =~ /^y/;
		$Patch_only{$fullname}++ if $patch =~ /^o/;
		$Maintained{$fullname}++ if $patch =~ /^y|o/;
		$Patches{$fullname}++ if $patch =~ /^p/;
	}
	close DIST;
}

# Make sure lock lasts for a reasonable time
sub checklock {
	local($file, $format) = @_;				# Full path name, locking format
	local($lockfile) = $file . $lockext;	# Add lock extension
	$lockfile = &lock'file($file, $format) if defined $format;
	if (-f $lockfile) {
		# There is a lock file -- look for how long it's been there
		local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
			$atime,$mtime,$ctime,$blksize,$blocks) = stat($lockfile);
		if ((time - $mtime) > $cf'lockhold) {
			# More than outdating time!! Something must have gone wrong
			unlink $lockfile;
			$file =~ s|.*/(.*)|$1|;	# Keep only basename
			&add_log("UNLOCKED $file (lock older than $cf'lockhold seconds)")
				if $loglvl > 5;
		}
	}
}

# Read stored informations for archived systems. The format of
# the file is the following:
#	system version patchlevel mtime
# where:
#	- system is the name of the system
#	- version is the version number or --- if none
#	- patchlevel is the current patchlevel, or -2 if no PL
#	- mtime is the modification time of the archive
#
# The function builds the following associative array, indexed
# by the system's name and version number (which has to be a null
# string for systems with no version number, marked '---'):
#
# name          indexed by       information
#
# %PSystem      name + version   true if line seen
# %Patch_level  name + version   current patch level
# %Mtime        name + version   last modification time
#
# If the 'plsave' file is not found, a new empty one is created
#
sub read_plsave {
	local($fullname);
	if (!open(PATLIST, "$cf'plsave")) {
		&add_log("creating new patlist file") if $loglvl > 8;
		system 'cp', '/dev/null', $cf'plsave;
		open(PATLIST, "$cf'plsave") ||
			&fatal("cannot open patlist file");
	}
	while (<PATLIST>) {
		next if /^\s*#/;	# skip comments
		next if /^\s*$/;	# skip empty lines
		next unless s/^\s*([\w-]+)\s+([\w\.]+)//;
		$fullname = $1 . "|" . ($2 eq '---'? "0" : $2);
		if (defined($PSystem{$fullname})) {
			&add_log("WARNING duplicate patlist entry $1 $2 ignored")
				if $loglvl > 5;
			next;
		}
		$PSystem{$fullname}++;
		unless (/^\s*([\-\d]+)\s+(\d+)/) {
			&add_log("WARNING bad patlist description line $.")
				if $loglvl > 5;
			next;	# Ignore, but it may corrupt further processing
		}
		$Patch_level{$fullname} = $1;
		$Mtime{$fullname} = $2;
	}
	close PATLIST;
}

# Write the new 'plsave', but only if the distributions are found
# in the %Program array (I assume read_dist() has been called).
# The 'plsave' file is locked during the updating process, so that
# no conflicting access occurs. There is a small chance that the
# file we write is not correct, in case the distribution file changed
# while we were processing a mail. However, it isn't a big problem.
sub write_plsave {
	local($lockext) = ".lock";		# Needed by checklock (via acs_rqst)
	local($system);
	local($version);
	if (0 != &acs_rqst($cf'plsave)) {
		&add_log("WARNING updating unlocked patlist file") if $loglvl > 5;
	}
	if (!open(PATLIST, ">$cf'plsave")) {
		&add_log("ERROR unable to update $cf'plsave") if $loglvl;
		return;
	}
	print PATLIST
"# This file was automatically generated by $prog_name.
# It records the archived distributions, their patch level if any, and
# the modification time of the archive, so that these informations can
# be updated when necessary. Do not edit this file.

";
	foreach $pname (keys %PSystem) {
		if ($Archived{$pname}) {
			($system, $version) = $pname =~ /^([\w-]+)\|([\w\.]+)*$/;
			$version = '---' if $version eq '0';
			print PATLIST "$system $version ";
			print PATLIST "$Patch_level{$pname} $Mtime{$pname}\n";
			&add_log("updated patlist for $system $version") if $loglvl > 18;
		} else {
			&add_log("$system $version removed from patlist") if $loglvl > 18;
		}
	}
	close PATLIST;
	&free_file($cf'plsave);
}

# A file "secure" if it is owned by the user and not world writable. Some key
# file within the mailagent have to be kept secure or they might compromise the
# security of the user account.
#
# Additionally, for 'root' users or if the 'secure' parameter in the config
# file is set to ON, checks are made for group writable files and suspicious
# directory as well.
#
# Return true if the file is secure or missing, false otherwise.
# Note the extra parameter $exec which is set by exec_secure() only.
sub file_secure {
	local($file, $type, $exec) = @_;
	return 1 unless -e $file;	# Missing file considered secure

	# If we're trying to execute a symbolic link, try to resolve it recursively
	# Otherwise, symlinks are not considered secure by file_secure().
	if (-l $file) {				# File is a symbolic link
		if ($exec) {
			local($target);
			$target = &symfile_secure($file, $type);
			return 0 unless defined $target;
			&add_log("NOTICE running $type $file actually runs $target")
				if $loglvl > 6;
			$file = $target;
		} else {
			&add_log("WARNING sensitive $type file $file is a symbolic link")
				if $loglvl > 5;
			return 0;				# Unsecure file
		}
	}

	local($ST_MODE) = 2 + $[;	# Field st_mode from inode structure
	unless ($exec || -O _) {	# Reuse stat info from -e
		&add_log("WARNING you do not own $type file $file") if $loglvl > 5;
		return 0;		# Unsecure file
	}
	local($st_mode) = (stat(_))[$ST_MODE];
	if ($st_mode & $S_IWOTH) {
		&add_log("WARNING $type file $file is world writable!") if $loglvl > 5;
		return 0;		# Unsecure file
	}

	# If file is excutable and seg[ug]id, make sure it's not publicly writable.
	# If writable at all, only the owner should have the rights. That's for
	# systems which do no reset the set[ug]id bit on write to the file.
	if (-x _) {
		if (($st_mode & $S_ISUID) && ($st_mode & ($S_IWGRP|$S_IWOTH))) {
			&add_log("WARNING setuid $type file $file is writable!")
				if $loglvl > 5;
			return 0;
		}
		if (($st_mode & $S_ISGID) && ($st_mode & ($S_IWGRP|$S_IWOTH))) {
			&add_log("WARNING setgid $type file $file is writable!")
				if $loglvl > 5;
			return 0;
		}
	}

	return 1 unless $cf'secure =~ /on/i || $< == 0;

	# Extra checks for secure mode (or if root user). We make sure the
	# file is not writable by group and then we conduct the same secure tests
	# on the directory itself
	if (($st_mode & $S_IWGRP) && $cf'groupsafe !~ /^off/i) {
		&add_log("WARNING $type file $file is group writable!") if $loglvl > 5;
		return 0;		# Unsecure file
	}
	local($dir);		# directory where file is located
	$dir = '.' unless ($dir) = ($file =~ m|(.*)/.*|);
	unless ($exec || -O $dir) {
		&add_log("WARNING you do not own directory of $type file $file")
			if $loglvl > 5;
		return 0;		# Unsecure directory, therefore unsecure file
	}
	$st_mode = (stat(_))[$ST_MODE];
	return 0 unless &check_st_mode($dir, 1);

	# If linkdirs is OFF, we do not check further when faced with a symbolic
	# link to a directory.
	if (-l $dir && $cf'linkdirs !~ /^off/i && !&symdir_secure($dir, $type)) {
		&add_log("WARNING directory of $type file $file is an unsecure symlink")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}

	1;		# At last! File is secure...
}

# Is a symbolic link to a directory secure?
sub symdir_secure {
	local($dir, $type) = @_;
	if (&symdir_check($dir, 0)) {
		&add_log("symbolic directory $dir for $type file is secure")
			if $loglvl > 11;
		return 1;
	}
	0;	# Not secure
}

# Is a symbolic link to a file secure?
# Returns the final target if all links up to that file are secure, undef
# if one of the links is not secure enough.
sub symfile_secure {
	local($file, $type) = @_;
	local($target) = &symfile_check($file, 0);
	if (defined $target) {
		&add_log("symbolic file $file for $type file is secure")
			if $loglvl > 11;
	} else {
		&add_log("WARNING symbolic file $file for $type file is unsecure")
			if $loglvl > 5;
	}
	return $target;
}

# A symbolic directory (that is a symlink pointing to a directory) is secure
# if and only if:
#   - its target is a symlink that recursively proves to be secure.
#   - the target lies in a non world-writable directory
#   - the final directory at the end of the symlink chain is not world-writable
#   - less than $MAX_LINKS levels of indirection are needed to reach a real dir
# Unfortunately, we cannot check for group writability here for the parent
# target directory since the target might lie in a system directory which may
# have a legitimate need to be read/write for root and wheel, for instance.
# The routine returns 1 if the file is secure, 0 otherwise.
sub symdir_check {
	local($dir, $level) = @_;	# Directory, indirection level
	$MAX_LINKS = 100 unless defined $MAX_LINKS;	# May have been overridden
	if ($level++ > $MAX_LINKS) {
		&add_log("ERROR more than $MAX_LINKS levels of symlinks to reach $dir")
			if $loglvl;
		return 0
	}
	local($ndir) = readlink($dir);
	unless (defined $ndir) {
		&add_log("SYSERR readlink: $!") if $loglvl;
		return 0;
	}
	$dir =~ s|(.*)/.*|$1|;		# Suppress link component (tail)
	$dir = &cdir($ndir, $dir);	# Follow symlink to get its final path target
	local($still_link) = -l $dir;
	unless (-d $dir || $still_link) {
		&add_log("ERROR inconsistency: $dir is a plain file?") if $loglvl;
		return 0;		# Reached a plain file while following links to a dir!
	}
	unless (-d "$dir/..") {
		&add_log("ERROR inconsistency: $dir/.. is not a directory?") if $loglvl;
		return 0;		# Reached a file hooked nowhere in the file system!
	}
	# Check parent directory
	local($ST_MODE) = 2 + $[;	# Field st_mode from inode structure
	$st_mode = (stat(_))[$ST_MODE];
	return 0 unless &check_st_mode("$dir/..", 0);
	# Recurse if still a symbolic link
	if ($still_link) {
		return 0 unless &symdir_check($dir, $level);
	} else {
		$st_mode = (stat($dir))[$ST_MODE];
		return 0 unless &check_st_mode($dir, 1);
	}
	1;	# Ok, link is secure
}

# Same as symdir_check, but target is a file!
sub symfile_check {
	local($file, $level) = @_;	# File, indirection level
	return undef if $level++ > $MAX_LINKS;
	local($nfile) = readlink($file);
	unless (defined $nfile) {
		&add_log("SYSERR readlink: $!") if $loglvl;
		return undef;
	}
	local($dir) = $file;			# Where symlink was held
	$dir =~ s|(.*)/.*|$1|;			# Suppress link component (tail)
	$file = &cdir($nfile, $dir);	# Follow symlink to get its path
	local($still_link) = -l $file;
	unless (-f $file || $still_link) {
		&add_log("ERROR $file does not exist") if !-e _ && $loglvl;
		&add_log("ERROR $file is not a plain file") if -e _ && $loglvl;
		return undef;				# Reached something that is not a plain file
	}
	# Check parent directory
	($dir = $file) =~ s|(.*)/.*|$1|;
	local($ST_MODE) = 2 + $[;		# Field st_mode from inode structure
	$st_mode = (stat($dir))[$ST_MODE];
	return undef unless &check_st_mode($dir, 1);
	return $file unless $still_link;		# Ok, link is secure
	return &symfile_check($file, $level);	# Still a symbolic link
}

# Returns true if mode in $st_mode does not include world or group writable
# bits, false otherwise. This helps factorizing code used in both &file_secure
# and &symdir_check. Set $both to true if both world/group checks are desirable,
# false to get only world checks.
sub check_st_mode {
	local($dir, $both) = @_;
	if ($st_mode & $S_IWOTH) {
		&add_log("WARNING directory $dir of $type file is world writable!")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}
	return 1 unless $both;
	if (($st_mode & $S_IWGRP) && $cf'groupsafe !~ /^off/i) {
		&add_log("WARNING directory $dir of $type file is group writable!")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}
	1;
}

# Make sure the file we are about to execute is secure. If it is a script
# with the '#!' kernel hook, also check the interpreter! Returns true if the
# file can be executed "safely".
sub exec_secure {
	local($file) = @_;	# File to be executed

	unless (-x $file) {
		&add_log("ERROR lacking execute rights on $file") if $loglvl > 1;
		return 0;
	}

	return 1 if $cf'execskip =~ /^on/i;	# Assume safe to be exec'ed

	local($cf'secure) = $cf'execsafe;	# Use exec settings for file_secure()

	unless (&file_secure($file, 'program', 1)) {
		&add_log("ERROR cannot execute unsecure $file") if $loglvl > 1;
		return 0;
	}

	&add_log("can allow exec() of $file") if $loglvl > 17;

	return 1 unless -T $file;	# Safe as far as we can tell, unless script...

	local($head);				# Heading line
	local($interpretor);		# Interpretor running the script
	local($perl) = '';			# Empiric support for perl scripts
	local(*SCRIPT);

	unless (open(SCRIPT, $file)) {
		&add_log("SYSERR open: $!") if $loglvl > 1;
		&add_log("ERROR cannot check script $file") if $loglvl > 1;
		return 0;
	}

	$head = <SCRIPT>;

	# Allow empiric support for common perl scripts
	# This is not bullet-proof, but should guard against common errors.

	if ($head =~ /\bperl\b/) {
		$perl = <SCRIPT>;
		if ($perl =~ /\beval\b.*\bexec\s+(\S+)/) {
			$perl = $1;
		} else {
			$perl = '';			# False alarm, can't check further
		}
	}

	close SCRIPT;

	($interpretor) = $head =~ /^#!\s*(\S+)/;
	$interpretor = '/bin/sh' unless $interpretor;
	unless (-x $interpretor) {
		&add_log("ERROR lacking execute rights on $interpretor") if $loglvl > 1;
		return 0;
	}

	unless (&file_secure($interpretor, 'interpretor', 1)) {
		&add_log("ERROR cannot run unsecure interpretor $interpretor")
			if $loglvl > 1;
		&add_log("ERROR cannot allow execution of script $file") if $loglvl > 1;
		return 0;
	}

	&add_log("can allow $interpretor to run $file") if $loglvl > 17;

	return 1 unless $perl;		# Okay, can run the script

	$perl = &locate_program($perl) unless $perl =~ m|/|;
	unless (-x $perl) {
		&add_log("ERROR lacking execute rights on $perl") if $loglvl > 1;
		return 0;
	}

	unless (&file_secure($perl, 'perl', 1)) {
		&add_log("ERROR cannot run unsecure perl $perl")
			if $loglvl > 1;
		&add_log("ERROR cannot allow execution of perl script $file")
			if $loglvl > 1;
		return 0;
	}

	&add_log("can allow $perl to run $file") if $loglvl > 17;

	return 1;					# Okay, perl can run it
}

# Apply directory changes into current path and return new directory
sub cdir {
	local($dir, $cur) = @_;			# New relative path, current directory
	return $dir if $dir =~ m|^/|;	# Already an absolute path
	chop($cur = `pwd`) unless defined $cur;
	local(@cur) = split(/\//, $cur);
	local(@dir) = split(/\//, $dir);
	local($path);
	foreach $item (@dir) {
		next if $item eq '.';	# Stay in same dir
		if ($item eq '..') {	# Move up
			pop(@cur);
		} else {
			push(@cur, $item);	# Move down
		}
	}
	local($path) = '/' . join('/', @cur);
	$path =~ tr|/||s;			# Successive '/' are useless
	$path;
}

# Return only the hostname portion of the host name (no domain name)
sub myhostname {
	local($_) = &hostname;
	s/^([^.]*)\..*/$1/;			# Trim down domain name
	$_;
}

# Compute hostname once and for all and cache its value (since we have to fork
# to get it).
sub hostname {
	unless ($cache'hostname) {
		chop($cache'hostname = `$phostname`);
		$cache'hostname =~ tr/A-Z/a-z/;			# Cannonicalize to lower case
	}
	$cache'hostname;
}

package addr;

#
# Address stuff, mainly for mailing list maintainance (package command)
#

# Is an address valid?
# Addresses containing either '|' or '/' in them are considered hostile, since
# sendmail for instance would attempt to deliver to a program or to a file...
# Also, the address must not contain any space or control characters.
# Since the address might also be given verbatim on a shell command line,
# it must not contain any "funny" shell meta-characters.
sub valid {
	local($_) = @_;
	return 0 if $_ eq '';		# Empty address
	return 0 if tr/\0-\31//;	# Control character found
	return 0 if /\s/;			# No space in address
	return 0 if m![\$^&*()[{}`\\|;><?]!;
	1;							# Address is ok
}

# Simplify address for comparaison purposes
sub simplify {
	local($_) = @_;

	return &simplify($_) if s/^@[\w-.]+://;			# @b.c:x -> x and retry
	return "$2\@$1.uucp" if /^([\w-]+)!(\w+)$/;		# b!u -> u@b.uucp
	return "$2\@$1" if /^([\w-.]+)!(\w+)$/;			# b.c!u -> u@b.c
	return $_ if /^[\w.-]+@[\w-.]+$/;				# u@b.c
	return &simplify("$2!$3")
		if /([^%@]+)!([\w-.]+)!(\w+)$/;				# ...!b!u -> b!u
	return "$1\@$2"
		if /^([\w.-]+)%([\w-.]+)@[\w-.]+/;			# u%b.c@d.e -> u@b.c
	return &simplify($1) if s/(.*)@[\w-.]+$//;		# x@b.c -> x and retry
	return &simplify("$1\@$2")
		if /^([\w-.%!]+)%([\w-.]+)$/;				# x%b -> x@b and retry

	return $_;		# Hmm... Better stop here, since we are clueless!!
}

# Does first address matches second address?
sub match {
	local($a1, $a2) = @_;		# Two plain e-mail addresses (no comments)
	$a1 =~ tr/A-Z/a-z/;			# Cannonicalize to lower case
	$a2 =~ tr/A-Z/a-z/;
	local($s1) = &simplify($a1);
	local($s2) = &simplify($a2);
	return 1 if $s1 eq $s2;
	# Face ram@lyon.eiffel.com versus ram@york.eiffel.com or ram@eiffel.com
	# We do not want a match in the first case, but it's ok for the other one.
	local($p1, $p2) = ($s1, $s2);
	$p1 =~ s/(\W)/\\$1/g;
	$p2 =~ s/(\W)/\\$1/g;
	$p1 =~ s/@/@[\\w-]+\\./;
	$p2 =~ s/@/@[\\w-]+\\./;
	$s1 =~ /^$p2$/ || $s2 =~ /^$p1$/;
}

# Are the two addresses close?
# They are if they match or if their login name is the same or they are
# within the same subdomain.domain.country or domain.country.
sub close {
	local($a1, $a2) = @_;		# Two plain e-mail addresses (no comments)
	return 1 if &match($a1, $a2);
	$a1 =~ tr/A-Z/a-z/;			# Cannonicalize to lower case
	$a2 =~ tr/A-Z/a-z/;
	$a1 = &simplify($a1);
	$a2 = &simplify($a2);
	local($l1, $l2);			# Login names
	local($d1, $d2);			# Domain names
	($l1) = $a1 =~ /^(.*)@/;
	($l2) = $a2 =~ /^(.*)@/;
	return 1 if $l1 ne '' && $l1 eq $l2;
	($d1) = $a1 =~ /\@([\w-]+\.[\w-]+\.[\w]+)$/;
	($d2) = $a2 =~ /\@([\w-]+\.[\w-]+\.[\w]+)$/;
	return 1 if $d1 ne '' && $d1 eq $d2;
	($d1) = $a1 =~ /\@([\w-]+\.[\w]+)$/;
	($d2) = $a2 =~ /\@([\w-]+\.[\w]+)$/;
	return 1 if $d1 ne '' && $d1 eq $d2;
	return 0;
}

package main;

#
# Find whether there is a .forward file and if there is, forge a new command
# mail and send it to the address(es) listed in this file, then exit.
# To forge the command message, we rely on the three global variables that
# should have been set from the environment passed by mailagent:
#
#   fullcmd: the shell command itself (without its leading @SH prefix)
#   pack   : the packing mode requested via @PACK (or default value)
#   path   : the path to be used to expand - addresses (@PATH or derived value)
#
# The recipient(s) will get a message which seems to come from us, but since
# there will be an explicit @PATH command and a leading message telling (in the
# body of the message itself) what has hapened, there should be no confusion
# possible. Automatic processing via mailagent of those forwarded requests is
# naturally possible transparently, without wondering about their origin.
#
# A note is sent to the originator of the command telling him his request has
# been forwarded, and to whom it was. That way, he may contact the other
# party if something wrong occurs.
sub check_forward {
	local(@addr) = &forward_list;
	return unless @addr;
	&add_log("NOTICE forwarding to @addr") if $loglvl > 6;
	local($es) = @addr == 1 ? '' : 'es';
	local($address) = join("\t\n", @addr);
	local(*MAIL);
	open(MAIL, "|$cf'sendmail $cf'mailopt $path $cf'email") || &nofork;
	print MAIL
"To: $path
Subject: Your command '$fullcmd' was forwarded
X-Mailer: mailagent [version $mversion PL$patchlevel]

You have sent $cf'email the following command:

	$fullcmd

It has been forwarded to the following address$es:

	$address

under the following (expanded) form:

	\@PATH $path
	\@PACK $pack
	\@SH $fullcmd

so that the remote end may interpret your command properly, if done
at all anyway.

-- $prog_name speaking for $cf'user
";
	close MAIL;
	if ($?) {
		&add_log("ERROR cannot notify $path about forwarding") if $loglvl;
	} else {
		&add_log("MSG forwarded to @addr") if $loglvl > 6;
	}
	local($addr) = join(", ", @addr);
	open(MAIL, "|$cf'sendmail $cf'mailopt @addr") || &nofork;
	print MAIL
"To: $addr
Subject: Command
X-Mailer: mailagent [version $mversion PL$patchlevel]

[Forwarded by $cf'email via mailagent $mversion PL$patchlevel]

\@PATH $path
\@PACK $pack
\@SH $fullcmd

-- $prog_name speaking for $cf'user
";
	close MAIL;
	if ($?) {
		&add_log("ERROR cannot forward command to @addr") if $loglvl;
	}

	# Final cleanup and exit
	&clean_tmp;
	exit 0;
}

# Returns the forwarding address list, or the empty list if none.
sub forward_list {
	return () unless -f '.forward';
	local(*FORWARD);
	unless (open(FORWARD, '.forward')) {
		&add_log("ERROR can't open .forward: $!") if $loglvl;
		return ();
	}
	local($_);
	local(@addr);
	push(@addr, split(/\s*,\s*/)) while chop($_ = <FORWARD>);
	close FORWARD;
	local(@valid);
	foreach $addr (@addr) {
		unless (&addr'valid($addr)) {
			&add_log("WARNING ignoring hostile forward address $addr")
				if $loglvl > 5;
			next;
		}
		push(@valid, $addr);
	}
	&add_log("WARNING empty forwarding address set!")
		if @valid == 0 && $loglvl > 5;
	return @valid;
}