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

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

# $Id: mailhelp.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: mailhelp.SH,v $
# Revision 3.0.1.3  1996/12/24  14:07:01  ram
# patch45: silently discard hostile addresses
#
# Revision 3.0.1.2  1995/03/21  12:55:04  ram
# patch35: added pl/cdir.pl to the list of appended files
#
# Revision 3.0.1.1  1994/10/04  17:36:31  ram
# patch17: extended logging to get better error/failure tracking
#
# Revision 3.0  1993/11/29  13:48:23  ram
# Baseline for mailagent 3.0 netwide release.
#

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

$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 help 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;
}

open(HELP, "$cf'spool/agenthelp") || &fatal("no help file!\n");
open(MAILER, "|$cf'sendmail $cf'mailopt $dest") || &nofork;
print MAILER
"To: $dest
Subject: How to use my mail agent
X-Mailer: mailagent [version $mversion-$revision]

";
while (<HELP>) {
	# Replace some tokens by parameters
	s/=DEST=/$dest/g;
	s/=MAXSIZE=/$cf'maxsize/g;
	print MAILER;
}
print MAILER
"
-- $prog_name speaking for $cf'user
";
close MAILER;
if ($?) {
	&add_log("ERROR couldn't send help to $dest") if $loglvl > 0;
} else {
	&add_log("SENT help to $dest") if $loglvl > 2;
}
close HELP;

# 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");
}

# 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;

# 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;
}

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;