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

#
# This perl program uses dynamic loading [generated by perload]
#

# You'll need to set up a .forward file that feeds your mail to this script,
# via the filter. Mine looks like this:
#   "|exec /users/ram/mail/filter >>/users/ram/.bak 2>&1"

# $Id: magent.sh,v 3.0.1.17 2001/03/17 18:07:49 ram Exp ram $
#
#  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: magent.sh,v $
# Revision 3.0.1.17  2001/03/17 18:07:49  ram
# patch72: mydomain and hiddennet now superseded by config vars
# patch72: changed email_addr() and domain_addr() to honour new config vars
#
# Revision 3.0.1.16  1999/01/13  18:08:48  ram
# patch64: changed agent_wait to AGENT_WAIT, now holding full path
#
# Revision 3.0.1.15  1997/09/15  15:05:06  ram
# patch57: call new pmail() routine to process main message
# patch57: fixed typo in -r usage
#
# Revision 3.0.1.14  1997/02/20  11:39:31  ram
# patch55: used  variable for no purpose
#
# Revision 3.0.1.13  1996/12/24  14:06:02  ram
# patch45: rule file path is now absolute, so caching can be safe
# patch45: changed queue processing/sleeping logic for better interactivity
# patch45: new stat constants, and updated usage line
#
# Revision 3.0.1.12  1995/09/15  13:54:28  ram
# patch43: rewrote mbox_lock routine to deal with new locksafe variable
# patch43: will now warn if configured to do flock() but can't actually
# patch43: can now be configured to do safe or allow partial mbox locking
#
# Revision 3.0.1.11  1995/08/31  16:26:54  ram
# patch42: forced numeric value when reading the Length header
#
# Revision 3.0.1.10  1995/08/07  16:12:03  ram
# patch37: now remove mailagent's lock as soon as possible before exiting
# patch37: added support for locking on filesystems with short filenames
#
# Revision 3.0.1.9  1995/03/21  12:54:50  ram
# patch35: added pl/cdir.pl to the list of appended files
#
# Revision 3.0.1.8  1995/02/16  14:24:42  ram
# patch32: new -I option for installation setup and checking
# patch32: usage message now sorts options by case type
#
# Revision 3.0.1.7  1995/02/03  17:57:16  ram
# patch30: also select hot piping on stderr to avoid problems on fork
#
# Revision 3.0.1.6  1995/01/03  17:56:52  ram
# patch24: new library files pl/rulenv.pl and pl/options.pl included
# patch24: no longer uses pl/umask.pl
#
# Revision 3.0.1.5  1994/10/29  17:40:14  ram
# patch20: added built-in biffing support
#
# Revision 3.0.1.4  1994/10/04  17:34:14  ram
# patch17: no longer report errors when orgname file is missing
# patch17: mailbox locking now uses customized mboxlock parameter
#
# Revision 3.0.1.3  1994/09/22  13:52:34  ram
# patch12: now performs &init_constants as soon as possible
# patch12: changed interface for &queue_mail to include first 2 letters
# patch12: context is loaded earlier to initialize callout queue
# patch12: added definition for , ,  and &abs
# patch12: changed &email_addr to cache its result and not rely on 'user
# patch12: moved &init_signals to pl/signals.pl as &catch_signals
#
# Revision 3.0.1.2  1994/07/01  14:54:29  ram
# patch8: fixed leading From date format (spacing problem)
#
# Revision 3.0.1.1  1994/01/26  09:27:56  ram
# patch5: new -F option to force procesing on filtered messages
#
# Revision 3.0  1993/11/29  13:48:22  ram
# Baseline for mailagent 3.0 netwide release.
#

# Perload ON

#
# The following were determined by Configure...
#

# Command used to compute hostname
$phostname = '';

# Our domain name
$mydomain = '.Unconfigured.Mailagent.Domain';

# Hidden network (advertised host)
$hiddennet = '';

# Directory where mail is spooled
$maildir = '/var/spool/mail';

# File in which mail is stored
$mailfile = '/var/spool/mail/%L';

# Current version number and patchlevel
$mversion = '3.1';
$patchlevel = '0';
$revision = '106';

# Want to lock mailboxes with flock ?
$lock_by_flock = '';

# Only use flock() and no .lock file
$flock_only = '';

# Our organization name
$orgname = '/etc/news/organization';

# Private mailagent library
$privlib = '/usr/share/mailagent';

# News posting program
$inews = 'inews';

# Mail sending program
$mailer = 'mail';

# Can we have filenames longer than 14 characters?
$long_filenames = 'define' eq 'define';

#
# End of configuration section.
#

$prog_name = $0;				# Who I am
$prog_name =~ s|^.*/(.*)|$1|;	# Keep only base name
$has_option = 0;				# True if invoked with options
$nolock = 0;					# Do we need to get a lock file?
$config_file = '~/.mailagent';	# Default configuration file
$log_level = -1;				# Changed by -L option

# Calling the mailagent as 'mailqueue' lists the queue
if ($prog_name eq 'mailqueue') {
	unshift(@ARGV, '-l');
}

# Parse options
while ($ARGV[0] =~ /^-/) {
	$_ = shift;
	last if /--/;
	if ($_ eq '-c') {		# Specify alternate configuration file
		++$nolock;			# Immediate processing wanted
		$config_file = shift;
	}
	elsif ($_ eq '-d') {	# Dump rules
		++$has_option;		# Incompatible with other special options
		++$dump_rule;
	}
	elsif ($_ eq '-e') {	# Rule supplied on command line
		$_ = shift;
		s/\n/ /g;
		push(@Linerules, $_);
		++$edited_rules;	# Signals rules came from command line
		++$nolock;			# Immediate processing wanted
	}
	elsif ($_ eq '-f') {	# Take messages from UNIX mailbox
		++$nolock;			# Immediate processing wanted
		++$mbox_mail;
		$mbox_file = shift;	# -f followed by file name
	}
	elsif ($_ eq '-h') {	# Usage help
		&usage;
	}
	elsif ($_ eq '-i') {	# Interactive mode: log messages also on stderr
		*add_log = *stderr_log;
	}
	elsif ($_ eq '-l') {	# List queue
		++$has_option;		# Incompatible with other special options
		++$list_queue;
		++$norule;			# No need to compile rules
	}
	elsif ($_ eq '-o') {	# Overwrite configuration variable
		++$nolock;			# Immediate processing wanted
		$over_config .= "\n" . shift;
	}
	elsif ($_ eq '-q') {	# Process the queue
		++$has_option;		# Incompatible with other special options
		++$run_queue;
	}
	elsif ($_ eq '-r') {	# Specify alternate rule file
		++$nolock;			# Immediate processing wanted
		$rule_file = shift;
		$rule_file = &cdir($rule_file);		# Make it an absolute path
	}
	elsif (/^-s(\S*)/) {	# Print statistics
		++$has_option;		# Incompatible with other special options
		++$stats;
		++$norule;			# No need to compile rules
		$stats_opt = $1;
	}
	elsif ($_ eq '-t') {	# Track rule matches on stdout
		++$track_all;
	}
	elsif ($_ eq '-F') {	# Force processing, even if already seen
		++$force_seen;
	}
	elsif ($_ eq '-I') {	# Install a suitable mailagent environment...
		++$has_option;		# That option must be the only one specified
		++$install_me;
	}
	elsif ($_ eq '-L') {	# Specify new logging level
		$log_level = int(shift);
	}
	elsif ($_ eq '-V') {	# Version number
		print STDERR "$prog_name $mversion-$revision\n";
		exit 0;
	}
	elsif ($_ eq '-U') {	# Do not allow UNIQUE to reject / abort
		++$disable_unique;
	}
	elsif ($_ eq '-TEST') {	# Mailagent run via TEST (undocumented feature)
		++$test_mode;
	}
	else {
		print STDERR "$prog_name: unknown option: $_\n";
		&usage;
	}
}

++$nolock if $has_option;		# No need to take a lock with special options

# Only one option at a time (among those options which change our goal)
if ($has_option > 1) {
	print STDERR "$prog_name: at most one special option may be specified.\n";
	exit 1;
}

exit(&cf'setup) if $install_me;	# Get a suitable configuration if -I

$file_name = shift;				# File name to be processed (null if stdin)
$ENV{'IFS'}='' if $ENV{'IFS'};	# Shell separation field
&init_constants;				# Constants definitions
&get_configuration;				# Get a suitable configuration package (cf)
&patch_constants;				# Change some constants after config
select(STDERR); $| = 1;			# In case we get perl warnings...
select(STDOUT);					# and because the -t option writes on STDOUT,
$| = 1;							# make sure it is flushed before we fork().
$privlib = "$cf'home/../.." if $test_mode;	# Tests ran from test/out
$AGENT_WAIT = "$cf'spool/agent.wait";		# Waiting file for mails

$orgname = &tilda_expand($orgname);		# Perform run-time ~name substitution

if ($orgname =~ m|^/|) {		# Name of organization kept in file
	unless (open(ORG, $orgname)) {
		&add_log("ERROR cannot read $orgname: $!") if $loglvl && -f $orgname;
	} else {
		chop($orgname = <ORG>);
		close ORG;
	}
}

$ENV{'HOME'} = $cf'home;
$ENV{'USER'} = $cf'user;
$ENV{'NAME'} = $cf'name;
$baselock = "$cf'spool/perl";	# This file does not exist
$lockext = $long_filenames ? '.lock' : '!';	# Extension used by lock routines
$lockfile = $baselock . $lockext;

umask(077);						# Files we create are private ones
$jobnum = &jobnum;				# Compute a job number

# Allow only ONE mailagent at a time (resource consumming)
&checklock($baselock);			# Make sure old locks do not remain
unless (-f $lockfile) {
	# Try to get the lock file (acting as a token). We do not need locking if
	# we have been invoked with an option and that option is not -q.
	if ($nolock && !$run_queue) {
		&add_log("no need to get a lock") if $loglvl > 19;
	} elsif (0 == &acs_rqst($baselock)) {
		&add_log("got the right to process mail") if $loglvl > 19;
		++$locked;
	} else {
		&add_log("denied right to process mail") if $loglvl > 19;
	}
}

if (!$locked && !$nolock) {
	# Another mailagent is running somewhere
	&queue_mail($file_name, 'fm');
	exit 0;
}

# Initialize mail filtering and compile filter rule if necessary
&init_all;
&compile_rules unless $norule;
&context'init;		# Load context, initialize callout queue

# If rules are to be dumped, this is the only action
if ($dump_rule) {
	&dump_rules(*print_rule_number, *void_func);
	unlink $lockfile if $locked;
	exit 0;
}

# Likewise, statistics dumping is the only option
if ($stats) {
	&report_stats($stats_opt);
	unlink $lockfile if $locked;
	exit 0;
}

# Listing the queue is also the only performed action
if ($list_queue) {
	&list_queue;
	unlink $lockfile if $locked;
	exit 0;
}

# Taking messages from mailbox file
if ($mbox_mail) {
	++$run_queue if 0 == &mbox_mail($mbox_file);
	unless ($run_queue) {
		unlink $lockfile if $locked;
		exit 1;		# -f failed
	}
	&add_log("processing queued mails") if $loglvl > 15;
}

# Suppress statistics when mailagent invoked manually (i.e. not in test mode)
&no_stats if $nolock && !$test_mode;

&read_stats;					# Load statistics into memory for fast update
&newcmd'load if $cf'newcmd;		# Load user-defined command definitions

#
# If -q is not specfied, we need to process the file which was given to us
# on the command line. We're calling pmail() to process it via locking,
# but unfortunately we can't allow pmail() to unlink the processed file,
# because it might be something the user wants to keep around...
# However, if we were invoked by the filter program, the processed mail
# will be unlinked later on. The trouble is the file was unlocked and
# there is a slight time window were the message could be processed again by
# another mailagent. If the 'queuehold' variable is reasonably set, such a
# message will be skipped anyway, so it's not that critical.
#

my $process_queue = 1;

if (!$run_queue) {				# Do not enter here if -q
	if (0 != &pmail($file_name, 0)) {
		&add_log("ERROR while processing main message--queing it") if $loglvl;
		&queue_mail($file_name, 'fm');
		unlink $lockfile;
		exit 0;					# Do not continue
	}

	# If invoked from a tty and not in test mode, do not process queue
	$process_queue = 0 if -t STDOUT && !$test_mode;
}

if ($process_queue) {
	unless ($test_mode) {
		# Fork a child: we have to take care of the filter script which is
		# waiting for us to finish processing of the delivered mail.
		&fork_child() unless $run_queue;

		# From now on, we are in the child process...
		# Don't sleep at all if logging level is greater that 11
		# or if $run_queue is true. Logging level of 12 and higher are
		# for debugging and should not be used on a permanent basis
		# anyway.

		$sleep = 1;					# Give others a chance to queue their mail
		$sleep = 0 if $loglvl > 11 || $run_queue;

		do {						# Eventually process the queue
			sleep 30 if $sleep;		# Wait in case new mail arrives
		} while (&pqueue);
	} else {
		&pqueue;					# Process the queue once in test mode
	}
}

# Mailagent is exiting. Remove lock file as early as possible to avoid a
# race condition: another mailagent could start up and decide another one
# is already processing mail, but since we're about to exit...
unlink $lockfile if $locked;
&add_log("mailagent exits") if $loglvl > 17;

# End of mailagent processing
&write_stats;					# Resynchronizes the statistics file
&compress'recompress;			# Compress some of the folders we delivered to
&contextual_operations;			# Perform all the contextual operations
exit 0;

sub main'usage { &auto_main'usage; }
sub auto_main'usage { &main'dataload; }

sub main'get_configuration { &auto_main'get_configuration; }
sub auto_main'get_configuration { &main'dataload; }

#
# The filtering routines
#

sub main'init_all { &auto_main'init_all; }
sub auto_main'init_all { &main'dataload; }

sub main'init_constants { &auto_main'init_constants; }
sub auto_main'init_constants { &main'dataload; }

sub main'patch_constants { &auto_main'patch_constants; }
sub auto_main'patch_constants { &main'dataload; }

sub main'init_env { &auto_main'init_env; }
sub auto_main'init_env { &main'dataload; }

sub main'init_pseudokey { &auto_main'init_pseudokey; }
sub auto_main'init_pseudokey { &main'dataload; }

#
# Miscellaneous utilities
#

sub main'mbox_lock { &auto_main'mbox_lock; }
sub auto_main'mbox_lock { &main'dataload; }

sub main'mbox_unlock { &auto_main'mbox_unlock; }
sub auto_main'mbox_unlock { &main'dataload; }

sub main'email_addr { &auto_main'email_addr; }
sub auto_main'email_addr { &main'dataload; }

sub main'domain_addr { &auto_main'domain_addr; }
sub auto_main'domain_addr { &main'dataload; }

sub main'tilda { &auto_main'tilda; }
sub auto_main'tilda { &main'dataload; }

# Compute absolute value -- on one line to avoid dataloading
sub abs { $_[0] > 0 ? $_[0] : -$_[0]; }

sub main'mailbox_name { &auto_main'mailbox_name; }
sub auto_main'mailbox_name { &main'dataload; }

sub main'fork_child { &auto_main'fork_child; }
sub auto_main'fork_child { &main'dataload; }

sub main'eval_error { &auto_main'eval_error; }
sub auto_main'eval_error { &main'dataload; }

sub main'jobnum { &auto_main'jobnum; }
sub auto_main'jobnum { &main'dataload; }

use Encode;

package cf;

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

sub main'read_config { &auto_main'read_config; }
sub auto_main'read_config { &main'dataload; }

sub cf'parse { &auto_cf'parse; }
sub auto_cf'parse { &main'dataload; }

package main;

sub main'acs_rqst { &auto_main'acs_rqst; }
sub auto_main'acs_rqst { &main'dataload; }

sub main'acs_locktry { &auto_main'acs_locktry; }
sub auto_main'acs_locktry { &main'dataload; }

sub main'acs_lock { &auto_main'acs_lock; }
sub auto_main'acs_lock { &main'dataload; }

package lock;

sub lock'file { &auto_lock'file; }
sub auto_lock'file { &main'dataload; }

sub lock'base { &auto_lock'base; }
sub auto_lock'base { &main'dataload; }

sub lock'dir { &auto_lock'dir; }
sub auto_lock'dir { &main'dataload; }

package main;

sub main'free_file { &auto_main'free_file; }
sub auto_main'free_file { &main'dataload; }

sub main'add_log { &auto_main'add_log; }
sub auto_main'add_log { &main'dataload; }

sub main'stderr_log { &auto_main'stderr_log; }
sub auto_main'stderr_log { &main'dataload; }

sub main'stdout_log { &auto_main'stdout_log; }
sub auto_main'stdout_log { &main'dataload; }

#
# User-defined log files
#

package usrlog;

sub usrlog'new { &auto_usrlog'new; }
sub auto_usrlog'new { &main'dataload; }

sub usrlog'delete { &auto_usrlog'delete; }
sub auto_usrlog'delete { &main'dataload; }

sub main'usr_log { &auto_main'usr_log; }
sub auto_main'usr_log { &main'dataload; }

sub usrlog'write_log { &auto_usrlog'write_log; }
sub auto_usrlog'write_log { &main'dataload; }

package main;

sub main'checklock { &auto_main'checklock; }
sub auto_main'checklock { &main'dataload; }

#
# Lexical parsing of the rules
#

sub main'read_filerule { &auto_main'read_filerule; }
sub auto_main'read_filerule { &main'dataload; }

sub main'read_linerule { &auto_main'read_linerule; }
sub auto_main'read_linerule { &main'dataload; }

sub main'get_line { &auto_main'get_line; }
sub auto_main'get_line { &main'dataload; }

sub main'get_mode { &auto_main'get_mode; }
sub auto_main'get_mode { &main'dataload; }

sub main'get_selector { &auto_main'get_selector; }
sub auto_main'get_selector { &main'dataload; }

sub main'get_pattern { &auto_main'get_pattern; }
sub auto_main'get_pattern { &main'dataload; }

sub main'get_action { &auto_main'get_action; }
sub auto_main'get_action { &main'dataload; }

sub main'action_parse { &auto_main'action_parse; }
sub auto_main'action_parse { &main'dataload; }

#
# Parsing mail
#

sub main'parse_mail { &auto_main'parse_mail; }
sub auto_main'parse_mail { &main'dataload; }

sub main'header_parse { &auto_main'header_parse; }
sub auto_main'header_parse { &main'dataload; }

sub main'header_lines { &auto_main'header_lines; }
sub auto_main'header_lines { &main'dataload; }

sub main'header_update_size { &auto_main'header_update_size; }
sub auto_main'header_update_size { &main'dataload; }

sub main'body_check { &auto_main'body_check; }
sub auto_main'body_check { &main'dataload; }

sub main'body_recode_with { &auto_main'body_recode_with; }
sub auto_main'body_recode_with { &main'dataload; }

sub main'body_recode { &auto_main'body_recode; }
sub auto_main'body_recode { &main'dataload; }

sub main'body_recode_optimally { &auto_main'body_recode_optimally; }
sub auto_main'body_recode_optimally { &main'dataload; }

sub main'header_check_body_encoding { &auto_main'header_check_body_encoding; }
sub auto_main'header_check_body_encoding { &main'dataload; }

sub main'header_check { &auto_main'header_check; }
sub auto_main'header_check { &main'dataload; }

sub main'relay_list { &auto_main'relay_list; }
sub auto_main'relay_list { &main'dataload; }

sub main'header_append { &auto_main'header_append; }
sub auto_main'header_append { &main'dataload; }

sub main'header_prepend { &auto_main'header_prepend; }
sub auto_main'header_prepend { &main'dataload; }

sub main'best_body_encoding { &auto_main'best_body_encoding; }
sub auto_main'best_body_encoding { &main'dataload; }

#
# Analyzing mail
#

sub main'init_special { &auto_main'init_special; }
sub auto_main'init_special { &main'dataload; }

sub main'mail_logname { &auto_main'mail_logname; }
sub auto_main'mail_logname { &main'dataload; }

sub main'mail_logsize { &auto_main'mail_logsize; }
sub auto_main'mail_logsize { &main'dataload; }

sub main'analyze_mail { &auto_main'analyze_mail; }
sub auto_main'analyze_mail { &main'dataload; }

sub main'apply_rules { &auto_main'apply_rules; }
sub auto_main'apply_rules { &main'dataload; }

sub main'right_mode { &auto_main'right_mode; }
sub auto_main'right_mode { &main'dataload; }

sub main'special_user { &auto_main'special_user; }
sub auto_main'special_user { &main'dataload; }

sub main'fuzzy_domain { &auto_main'fuzzy_domain; }
sub auto_main'fuzzy_domain { &main'dataload; }

sub main'reception { &auto_main'reception; }
sub auto_main'reception { &main'dataload; }

sub main'track_rule { &auto_main'track_rule; }
sub auto_main'track_rule { &main'dataload; }


sub main'xeqte { &auto_main'xeqte; }
sub auto_main'xeqte { &main'dataload; }

sub main'run_command { &auto_main'run_command; }
sub auto_main'run_command { &main'dataload; }

sub main'init_filter { &auto_main'init_filter; }
sub auto_main'init_filter { &main'dataload; }

#
# Filter commands are run from here
#

sub main'run_process { &auto_main'run_process; }
sub auto_main'run_process { &main'dataload; }

sub main'run_server { &auto_main'run_server; }
sub auto_main'run_server { &main'dataload; }

sub main'run_leave { &auto_main'run_leave; }
sub auto_main'run_leave { &main'dataload; }

sub main'run_save { &auto_main'run_save; }
sub auto_main'run_save { &main'dataload; }

sub main'run_store { &auto_main'run_store; }
sub auto_main'run_store { &main'dataload; }

sub main'run_write { &auto_main'run_write; }
sub auto_main'run_write { &main'dataload; }

sub main'run_delete { &auto_main'run_delete; }
sub auto_main'run_delete { &main'dataload; }

sub main'run_macro { &auto_main'run_macro; }
sub auto_main'run_macro { &main'dataload; }

sub main'run_message { &auto_main'run_message; }
sub auto_main'run_message { &main'dataload; }

sub main'run_notify { &auto_main'run_notify; }
sub auto_main'run_notify { &main'dataload; }

sub main'run_reject { &auto_main'run_reject; }
sub auto_main'run_reject { &main'dataload; }

sub main'run_restart { &auto_main'run_restart; }
sub auto_main'run_restart { &main'dataload; }

sub main'run_abort { &auto_main'run_abort; }
sub auto_main'run_abort { &main'dataload; }

sub main'run_resync { &auto_main'run_resync; }
sub auto_main'run_resync { &main'dataload; }

sub main'run_begin { &auto_main'run_begin; }
sub auto_main'run_begin { &main'dataload; }

sub main'run_record { &auto_main'run_record; }
sub auto_main'run_record { &main'dataload; }

sub main'run_unique { &auto_main'run_unique; }
sub auto_main'run_unique { &main'dataload; }

sub main'run_forward { &auto_main'run_forward; }
sub auto_main'run_forward { &main'dataload; }

sub main'run_bounce { &auto_main'run_bounce; }
sub auto_main'run_bounce { &main'dataload; }

sub main'run_post { &auto_main'run_post; }
sub auto_main'run_post { &main'dataload; }

sub main'run_run { &auto_main'run_run; }
sub auto_main'run_run { &main'dataload; }

sub main'run_pipe { &auto_main'run_pipe; }
sub auto_main'run_pipe { &main'dataload; }

sub main'run_give { &auto_main'run_give; }
sub auto_main'run_give { &main'dataload; }

sub main'run_pass { &auto_main'run_pass; }
sub auto_main'run_pass { &main'dataload; }

sub main'run_feed { &auto_main'run_feed; }
sub auto_main'run_feed { &main'dataload; }

sub main'run_purify { &auto_main'run_purify; }
sub auto_main'run_purify { &main'dataload; }

sub main'run_back { &auto_main'run_back; }
sub auto_main'run_back { &main'dataload; }

sub main'run_on { &auto_main'run_on; }
sub auto_main'run_on { &main'dataload; }

sub main'run_once { &auto_main'run_once; }
sub auto_main'run_once { &main'dataload; }

sub main'run_select { &auto_main'run_select; }
sub auto_main'run_select { &main'dataload; }

sub main'run_nop { &auto_main'run_nop; }
sub auto_main'run_nop { &main'dataload; }

sub main'run_strip { &auto_main'run_strip; }
sub auto_main'run_strip { &main'dataload; }

sub main'run_keep { &auto_main'run_keep; }
sub auto_main'run_keep { &main'dataload; }

sub main'run_annotate { &auto_main'run_annotate; }
sub auto_main'run_annotate { &main'dataload; }

sub main'run_assign { &auto_main'run_assign; }
sub auto_main'run_assign { &main'dataload; }

sub main'run_tr { &auto_main'run_tr; }
sub auto_main'run_tr { &main'dataload; }

sub main'run_subst { &auto_main'run_subst; }
sub auto_main'run_subst { &main'dataload; }

sub main'run_split { &auto_main'run_split; }
sub auto_main'run_split { &main'dataload; }

sub main'run_vacation { &auto_main'run_vacation; }
sub auto_main'run_vacation { &main'dataload; }

sub main'run_queue { &auto_main'run_queue; }
sub auto_main'run_queue { &main'dataload; }

sub main'run_perl { &auto_main'run_perl; }
sub auto_main'run_perl { &main'dataload; }

sub main'run_require { &auto_main'run_require; }
sub auto_main'run_require { &main'dataload; }

sub main'run_apply { &auto_main'run_apply; }
sub auto_main'run_apply { &main'dataload; }

sub main'run_umask { &auto_main'run_umask; }
sub auto_main'run_umask { &main'dataload; }

sub main'run_after { &auto_main'run_after; }
sub auto_main'run_after { &main'dataload; }

sub main'run_do { &auto_main'run_do; }
sub auto_main'run_do { &main'dataload; }

sub main'run_beep { &auto_main'run_beep; }
sub auto_main'run_beep { &main'dataload; }

sub main'run_protect { &auto_main'run_protect; }
sub auto_main'run_protect { &main'dataload; }

sub main'run_biff { &auto_main'run_biff; }
sub auto_main'run_biff { &main'dataload; }

sub main'run_saving { &auto_main'run_saving; }
sub auto_main'run_saving { &main'dataload; }

sub main'alter_execution { &auto_main'alter_execution; }
sub auto_main'alter_execution { &main'dataload; }

sub main'save_message { &auto_main'save_message; }
sub auto_main'save_message { &main'dataload; }

#
# Matching functions
#

sub main'init_matcher { &auto_main'init_matcher; }
sub auto_main'init_matcher { &main'dataload; }

sub main'perl_pattern { &auto_main'perl_pattern; }
sub auto_main'perl_pattern { &main'dataload; }

sub main'make_pattern { &auto_main'make_pattern; }
sub auto_main'make_pattern { &main'dataload; }

sub main'match { &auto_main'match; }
sub auto_main'match { &main'dataload; }

sub main'apply_match { &auto_main'apply_match; }
sub auto_main'apply_match { &main'dataload; }

sub main'expr_selector_match { &auto_main'expr_selector_match; }
sub auto_main'expr_selector_match { &main'dataload; }

sub main'selector_match { &auto_main'selector_match; }
sub auto_main'selector_match { &main'dataload; }

# Pattern matching functions:
#	They are invoked as function($selector, $pattern, $range) and return true
#	if the pattern is found in the variable, according to some internal rules
#	which are different among the functions. For instance, match_single will
#	attempt a match with a login name or a regular pattern matching on the
#	whole variable if the pattern was not a single word.

sub main'match_single { &auto_main'match_single; }
sub auto_main'match_single { &main'dataload; }

sub main'match_list { &auto_main'match_list; }
sub auto_main'match_list { &main'dataload; }

sub main'match_var { &auto_main'match_var; }
sub auto_main'match_var { &main'dataload; }

#
# Backreference handling
#

sub main'reset_backref { &auto_main'reset_backref; }
sub auto_main'reset_backref { &main'dataload; }

sub main'update_backref { &auto_main'update_backref; }
sub auto_main'update_backref { &main'dataload; }

#
# Range interpolation
#

sub main'mrange { &auto_main'mrange; }
sub auto_main'mrange { &main'dataload; }

sub main'locate_file { &auto_main'locate_file; }
sub auto_main'locate_file { &main'dataload; }

sub main'locate_program { &auto_main'locate_program; }
sub auto_main'locate_program { &main'dataload; }


sub main'parse_address { &auto_main'parse_address; }
sub auto_main'parse_address { &main'dataload; }

sub main'login_name { &auto_main'login_name; }
sub auto_main'login_name { &main'dataload; }

sub main'last_name { &auto_main'last_name; }
sub auto_main'last_name { &main'dataload; }

sub main'internet_info { &auto_main'internet_info; }
sub auto_main'internet_info { &main'dataload; }

sub main'gen_message_id { &auto_main'gen_message_id; }
sub auto_main'gen_message_id { &main'dataload; }

#
# Macro handling (system)
#

sub main'macros_subst { &auto_main'macros_subst; }
sub auto_main'macros_subst { &main'dataload; }

package macro;

sub macro'info { &auto_macro'info; }
sub auto_macro'info { &main'dataload; }

sub macro'org { &auto_macro'org; }
sub auto_macro'org { &main'dataload; }

sub macro'domain { &auto_macro'domain; }
sub auto_macro'domain { &main'dataload; }

sub macro'internet { &auto_macro'internet; }
sub auto_macro'internet { &main'dataload; }

#
# Internal override feature
#

sub macro'overload { &auto_macro'overload; }
sub auto_macro'overload { &main'dataload; }

# Free routine defined by &overload
sub unload { undef &over }


package main;

package header;

# This package implements a header checker. To initialize it, call 'reset'.
# Then, call 'valid' with a header line and the function returns 0 if the
# line is not part of a header (which means all the lines seen since 'reset'
# are not part of a mail header). If the line may still be part of a header,
# returns 1. Finally, -1 is returned at the end of the header.

sub header'init { &auto_header'init; }
sub auto_header'init { &main'dataload; }

sub header'reset { &auto_header'reset; }
sub auto_header'reset { &main'dataload; }

sub header'valid { &auto_header'valid; }
sub auto_header'valid { &main'dataload; }

sub header'warning { &auto_header'warning; }
sub auto_header'warning { &main'dataload; }

sub header'clean { &auto_header'clean; }
sub auto_header'clean { &main'dataload; }

sub header'check { &auto_header'check; }
sub auto_header'check { &main'dataload; }

sub header'push { &auto_header'push; }
sub auto_header'push { &main'dataload; }

sub header'mta_date { &auto_header'mta_date; }
sub auto_header'mta_date { &main'dataload; }

sub header'normalize { &auto_header'normalize; }
sub auto_header'normalize { &main'dataload; }

sub header'msgid_cleanup { &auto_header'msgid_cleanup; }
sub auto_header'msgid_cleanup { &main'dataload; }

# Perload OFF

# Fixup one message ID by ensuring it has but one single "@" in it.
# Cannot be dataloaded since it is referenced from a regular expression
sub msgid_fix {
	my ($x, $fixupref) = @_;
	# Ensure at least one "@"
	unless ($x =~ /@/) {
		$$fixupref++;
		return $x . "\@faked-by-mailagent.local";
	}
	# Ensure only one "@"
	if ($x =~ tr/@/@/ > 1) {
		my ($leading, $trailing) = ($x =~ /(.*)@(.*)/);
		$leading =~ s/@/./g;
		$$fixupref++;
		return $leading . '@' . $trailing;
	}
	return $x;
}

# Perload ON

sub header'parsedate { &auto_header'parsedate; }
sub auto_header'parsedate { &main'dataload; }

sub header'format { &auto_header'format; }
sub auto_header'format { &main'dataload; }

sub header'news_fmt { &auto_header'news_fmt; }
sub auto_header'news_fmt { &main'dataload; }

sub main'header_found { &auto_main'header_found; }
sub auto_main'header_found { &main'dataload; }

package main;

#
# Implementation of filtering commands
#

sub main'leave { &auto_main'leave; }
sub auto_main'leave { &main'dataload; }

sub main'save { &auto_main'save; }
sub auto_main'save { &main'dataload; }

sub main'save_folder { &auto_main'save_folder; }
sub auto_main'save_folder { &main'dataload; }

sub main'save_hook { &auto_main'save_hook; }
sub auto_main'save_hook { &main'dataload; }

sub main'process { &auto_main'process; }
sub auto_main'process { &main'dataload; }

sub main'macro { &auto_main'macro; }
sub auto_main'macro { &main'dataload; }

sub main'message { &auto_main'message; }
sub auto_main'message { &main'dataload; }

sub main'notify { &auto_main'notify; }
sub auto_main'notify { &main'dataload; }

sub main'send_message { &auto_main'send_message; }
sub auto_main'send_message { &main'dataload; }

sub main'forward { &auto_main'forward; }
sub auto_main'forward { &main'dataload; }

sub main'bounce { &auto_main'bounce; }
sub auto_main'bounce { &main'dataload; }

sub main'post { &auto_main'post; }
sub auto_main'post { &main'dataload; }

sub main'apply { &auto_main'apply; }
sub auto_main'apply { &main'dataload; }

sub main'split { &auto_main'split; }
sub auto_main'split { &main'dataload; }

sub main'shell_command { &auto_main'shell_command; }
sub auto_main'shell_command { &main'dataload; }

sub main'popen_failed { &auto_main'popen_failed; }
sub auto_main'popen_failed { &main'dataload; }

sub main'alarm_clock { &auto_main'alarm_clock; }
sub auto_main'alarm_clock { &main'dataload; }

sub main'print_binary_mail { &auto_main'print_binary_mail; }
sub auto_main'print_binary_mail { &main'dataload; }

sub main'execute_command { &auto_main'execute_command; }
sub auto_main'execute_command { &main'dataload; }

sub main'handle_output { &auto_main'handle_output; }
sub auto_main'handle_output { &main'dataload; }

sub main'mail_back { &auto_main'mail_back; }
sub auto_main'mail_back { &main'dataload; }

sub main'feed_back { &auto_main'feed_back; }
sub auto_main'feed_back { &main'dataload; }

sub main'xeq_back { &auto_main'xeq_back; }
sub auto_main'xeq_back { &main'dataload; }

sub main'header_resync { &auto_main'header_resync; }
sub auto_main'header_resync { &main'dataload; }

sub main'alter_header { &auto_main'alter_header; }
sub auto_main'alter_header { &main'dataload; }

sub main'annotate_header { &auto_main'annotate_header; }
sub auto_main'annotate_header { &main'dataload; }


sub main'runop_on_field { &auto_main'runop_on_field; }
sub auto_main'runop_on_field { &main'dataload; }

sub main'alter_field { &auto_main'alter_field; }
sub auto_main'alter_field { &main'dataload; }

sub main'alter_value { &auto_main'alter_value; }
sub auto_main'alter_value { &main'dataload; }

sub main'perl { &auto_main'perl; }
sub auto_main'perl { &main'dataload; }

sub main'require { &auto_main'require; }
sub auto_main'require { &main'dataload; }

sub main'do { &auto_main'do; }
sub auto_main'do { &main'dataload; }

sub main'after { &auto_main'after; }
sub auto_main'after { &main'dataload; }

sub main'alter_flow { &auto_main'alter_flow; }
sub auto_main'alter_flow { &main'dataload; }

sub main'do_reject { &auto_main'do_reject; }
sub auto_main'do_reject { &main'dataload; }

sub main'do_restart { &auto_main'do_restart; }
sub auto_main'do_restart { &main'dataload; }

sub main'do_abort { &auto_main'do_abort; }
sub auto_main'do_abort { &main'dataload; }

sub main'complete_list { &auto_main'complete_list; }
sub auto_main'complete_list { &main'dataload; }

sub main'save_mail { &auto_main'save_mail; }
sub auto_main'save_mail { &main'dataload; }

sub main'empty_body { &auto_main'empty_body; }
sub auto_main'empty_body { &main'dataload; }

sub main'trace_dump { &auto_main'trace_dump; }
sub auto_main'trace_dump { &main'dataload; }

package stats;

$stats_wanted = 0;				# No statistics wanted by default
$new_record = 0;				# True when a new record is to be started
$start_date = 0;				# When statistics started
$suppressed = 0;				# Statistics suppressed by higher authority

# Suppress statistics. This function is called when options like -r or -e are
# used. Those usually specify one time rules and thus are not entitled to be
# recorded into the statistics.
sub main'no_stats { $suppressed = 1; }

sub main'read_stats { &auto_main'read_stats; }
sub auto_main'read_stats { &main'dataload; }

sub main'write_stats { &auto_main'write_stats; }
sub auto_main'write_stats { &main'dataload; }

sub stats'print_array { &auto_stats'print_array; }
sub auto_stats'print_array { &main'dataload; }

#
# Accounting routines
#

sub main's_filtered { &auto_main's_filtered; }
sub auto_main's_filtered { &main'dataload; }

sub main's_match { &auto_main's_match; }
sub auto_main's_match { &main'dataload; }

sub main's_default { &auto_main's_default; }
sub auto_main's_default { &main'dataload; }

sub main's_vacation { &auto_main's_vacation; }
sub auto_main's_vacation { &main'dataload; }

sub main's_saved { &auto_main's_saved; }
sub auto_main's_saved { &main'dataload; }

sub main's_seen { &auto_main's_seen; }
sub auto_main's_seen { &main'dataload; }

sub main's_action { &auto_main's_action; }
sub auto_main's_action { &main'dataload; }

sub main's_failed { &auto_main's_failed; }
sub auto_main's_failed { &main'dataload; }

sub main's_once { &auto_main's_once; }
sub auto_main's_once { &main'dataload; }

sub main's_noretry { &auto_main's_noretry; }
sub auto_main's_noretry { &main'dataload; }

#
# Low-level routines
#

sub stats'diff_rules { &auto_stats'diff_rules; }
sub auto_stats'diff_rules { &main'dataload; }

sub stats'fill_stats { &auto_stats'fill_stats; }
sub auto_stats'fill_stats { &main'dataload; }

#
# Reporting statistics
#

sub main'report_stats { &auto_main'report_stats; }
sub auto_main'report_stats { &main'dataload; }

sub stats'print_stats { &auto_stats'print_stats; }
sub auto_stats'print_stats { &main'dataload; }

sub stats'print_summary { &auto_stats'print_summary; }
sub auto_stats'print_summary { &main'dataload; }

sub stats'print_general { &auto_stats'print_general; }
sub auto_stats'print_general { &main'dataload; }

sub stats'print_commands { &auto_stats'print_commands; }
sub auto_stats'print_commands { &main'dataload; }

sub stats'uniform_rule { &auto_stats'uniform_rule; }
sub auto_stats'uniform_rule { &main'dataload; }

sub stats'print_rules_summary { &auto_stats'print_rules_summary; }
sub auto_stats'print_rules_summary { &main'dataload; }

#
# Hooks for rule dumping
#

sub stats'print_header { &auto_stats'print_header; }
sub auto_stats'print_header { &main'dataload; }

sub stats'rule_stats { &auto_stats'rule_stats; }
sub auto_stats'rule_stats { &main'dataload; }

package main;

sub main'qmail { &auto_main'qmail; }
sub auto_main'qmail { &main'dataload; }

sub main'queue_mail { &auto_main'queue_mail; }
sub auto_main'queue_mail { &main'dataload; }

sub main'waiting_mail { &auto_main'waiting_mail; }
sub auto_main'waiting_mail { &main'dataload; }

sub main'mv { &auto_main'mv; }
sub auto_main'mv { &main'dataload; }

sub main'same_device { &auto_main'same_device; }
sub auto_main'same_device { &main'dataload; }

sub main'pqueue { &auto_main'pqueue; }
sub auto_main'pqueue { &main'dataload; }

sub main'pmail { &auto_main'pmail; }
sub auto_main'pmail { &main'dataload; }

#
# Executing builtin commands
#

sub main'send_receipt { &auto_main'send_receipt; }
sub auto_main'send_receipt { &main'dataload; }

#
# Deal with builtins
#

sub main'init_builtins { &auto_main'init_builtins; }
sub auto_main'init_builtins { &main'dataload; }

# Whenever a builtin command is recognized (on the fly) while parsing the mail
# body, the corresponding builtin function is called with the remaining of the
# line given as argument (leading spaces removed).

sub main'builtin_rr { &auto_main'builtin_rr; }
sub auto_main'builtin_rr { &main'dataload; }

sub main'builtin_path { &auto_main'builtin_path; }
sub auto_main'builtin_path { &main'dataload; }

sub main'run_builtins { &auto_main'run_builtins; }
sub auto_main'run_builtins { &main'dataload; }

# Here are the data structures we use to store the compiled form of the rules:
#  @Rules has entries looking like "<$mode> {$action} $rulekeys..."
#  %Rule has entries looking like "$selector: $pattern"
# Each rule was saved in @Rules. The ruleskeys have the form H<num> where <num>
# is an increasing integer. They index the rules in %Rule.

sub main'compile_rules { &auto_main'compile_rules; }
sub auto_main'compile_rules { &main'dataload; }

sub main'default_rules { &auto_main'default_rules; }
sub auto_main'default_rules { &main'dataload; }

sub main'rule_cleanup { &auto_main'rule_cleanup; }
sub auto_main'rule_cleanup { &main'dataload; }

sub main'print_rule_number { &auto_main'print_rule_number; }
sub auto_main'print_rule_number { &main'dataload; }

sub main'void_func { &auto_main'void_func; }
sub auto_main'void_func { &main'dataload; }

sub main'exact_rule { &auto_main'exact_rule; }
sub auto_main'exact_rule { &main'dataload; }

sub nothing { }			 # Do nothing, really nothing

sub main'dump_rules { &auto_main'dump_rules; }
sub auto_main'dump_rules { &main'dataload; }

sub main'print_rule { &auto_main'print_rule; }
sub auto_main'print_rule { &main'dataload; }

#
# The following package added to hold all the new rule-specific functions
# added at version 3.0.
#

package rules;

sub rules'write_cache { &auto_rules'write_cache; }
sub auto_rules'write_cache { &main'dataload; }

sub rules'read_cache { &auto_rules'read_cache; }
sub auto_rules'read_cache { &main'dataload; }

sub rules'cache_ok { &auto_rules'cache_ok; }
sub auto_rules'cache_ok { &main'dataload; }

sub rules'write_fd { &auto_rules'write_fd; }
sub auto_rules'write_fd { &main'dataload; }

sub rules'writevar_fd { &auto_rules'writevar_fd; }
sub auto_rules'writevar_fd { &main'dataload; }

# Perload OFF
# (Used as a sort function, causes perl5 to dump core with native AUTOLOAD)

# Sorting for hash keys used by %Rule
sub hashkey {
	local($c) = $a =~ /^H(\d+)/;
	local($d) = $b =~ /^H(\d+)/;
	$c <=> $d;
}

# Perload ON

sub rules'alternate { &auto_rules'alternate; }
sub auto_rules'alternate { &main'dataload; }

package main;

sub main'seconds_in_period { &auto_main'seconds_in_period; }
sub auto_main'seconds_in_period { &main'dataload; }

sub main'relative_age { &auto_main'relative_age; }
sub auto_main'relative_age { &main'dataload; }

#
# The built-in expression interpreter
#

sub main'init_interpreter { &auto_main'init_interpreter; }
sub auto_main'init_interpreter { &main'dataload; }

sub main'set_priorities { &auto_main'set_priorities; }
sub auto_main'set_priorities { &main'dataload; }

sub main'set_functions { &auto_main'set_functions; }
sub auto_main'set_functions { &main'dataload; }

sub main'error { &auto_main'error; }
sub auto_main'error { &main'dataload; }

sub main'push_val { &auto_main'push_val; }
sub auto_main'push_val { &main'dataload; }

sub main'execute { &auto_main'execute; }
sub auto_main'execute { &main'dataload; }

sub main'update_stack { &auto_main'update_stack; }
sub auto_main'update_stack { &main'dataload; }

sub main'eval_expr { &auto_main'eval_expr; }
sub auto_main'eval_expr { &main'dataload; }

sub main'evaluate { &auto_main'evaluate; }
sub auto_main'evaluate { &main'dataload; }

#
# Boolean functions used by the interpreter. They all take two arguments
# and return 0 if false and 1 if true.
#

sub f_and { $_[0] && $_[1]; }		# Boolean AND
sub f_or { $_[0] || $_[1]; }		# Boolean OR
sub f_ge { $_[0] >= $_[1]; }		# Greater or equal
sub f_le { $_[0] <= $_[1]; }		# Lesser or equal
sub f_lt { $_[0] < $_[1]; }			# Lesser than
sub f_gt { $_[0] > $_[1]; }			# Greater than
sub f_eq { "$_[0]" eq "$_[1]"; }	# Equal
sub f_ne { "$_[0]" ne "$_[1]"; }	# Not equal
sub f_match { $_[0] =~ /$_[1]/; }	# Pattern matches
sub f_nomatch { $_[0] !~ /$_[1]/; }	# Pattern does not match

package dbr;

sub dbr'hash_path { &auto_dbr'hash_path; }
sub auto_dbr'hash_path { &main'dataload; }

sub dbr'info { &auto_dbr'info; }
sub auto_dbr'info { &main'dataload; }

sub dbr'match { &auto_dbr'match; }
sub auto_dbr'match { &main'dataload; }

sub dbr'update { &auto_dbr'update; }
sub auto_dbr'update { &main'dataload; }

sub dbr'delete { &auto_dbr'delete; }
sub auto_dbr'delete { &main'dataload; }

sub dbr'default { &auto_dbr'default; }
sub auto_dbr'default { &main'dataload; }

sub dbr'clean { &auto_dbr'clean; }
sub auto_dbr'clean { &main'dataload; }

sub dbr'recursive_clean { &auto_dbr'recursive_clean; }
sub auto_dbr'recursive_clean { &main'dataload; }

sub dbr'clean_file { &auto_dbr'clean_file; }
sub auto_dbr'clean_file { &main'dataload; }

package main;

sub main'history_tag { &auto_main'history_tag; }
sub auto_main'history_tag { &main'dataload; }

sub main'history_ignore { &auto_main'history_ignore; }
sub auto_main'history_ignore { &main'dataload; }

sub main'history_record { &auto_main'history_record; }
sub auto_main'history_record { &main'dataload; }

sub main'once_check { &auto_main'once_check; }
sub auto_main'once_check { &main'dataload; }

sub main'makedir { &auto_main'makedir; }
sub auto_main'makedir { &main'dataload; }

#
# Emergency situation routines
#

# Perload OFF
# (Better not be dynamically loaded as it is a signal handler)

# Emergency signal was caught
sub emergency {
	local($sig) = @_;			# First argument is signal name
	if ($has_option) {			# Mailagent was invoked "manually"
		&resync;				# Resynchronize waiting file if necessary
		&add_log("ERROR trapped SIG$sig") if $loglvl;
		exit 1;
	}
	&fatal("trapped SIG$sig");
}

# Perload ON

sub main'fatal { &auto_main'fatal; }
sub auto_main'fatal { &main'dataload; }

sub main'emergency_save { &auto_main'emergency_save; }
sub auto_main'emergency_save { &main'dataload; }

sub main'dump_mbox { &auto_main'dump_mbox; }
sub auto_main'dump_mbox { &main'dataload; }

sub main'write_waitkeys { &auto_main'write_waitkeys; }
sub auto_main'write_waitkeys { &main'dataload; }

sub main'resync { &auto_main'resync; }
sub auto_main'resync { &main'dataload; }

sub main'list_queue { &auto_main'list_queue; }
sub auto_main'list_queue { &main'dataload; }

package mbox;

sub main'mbox_mail { &auto_main'mbox_mail; }
sub auto_main'mbox_mail { &main'dataload; }

sub mbox'flush_blanks { &auto_mbox'flush_blanks; }
sub auto_mbox'flush_blanks { &main'dataload; }

sub mbox'flush_buffer { &auto_mbox'flush_buffer; }
sub auto_mbox'flush_buffer { &main'dataload; }

sub mbox'flush { &auto_mbox'flush; }
sub auto_mbox'flush { &main'dataload; }

package main;

package context;

#
# General handling
#

sub context'init { &auto_context'init; }
sub auto_context'init { &main'dataload; }

sub context'default { &auto_context'default; }
sub auto_context'default { &main'dataload; }

sub context'load { &auto_context'load; }
sub auto_context'load { &main'dataload; }

sub context'clean { &auto_context'clean; }
sub auto_context'clean { &main'dataload; }

sub context'save { &auto_context'save; }
sub auto_context'save { &main'dataload; }

#
# Access features
#

sub context'set { &auto_context'set; }
sub auto_context'set { &main'dataload; }

sub context'get { &auto_context'get; }
sub auto_context'get { &main'dataload; }

sub context'delete { &auto_context'delete; }
sub auto_context'delete { &main'dataload; }

#
# Context-dependant actions
#

sub context'autoclean { &auto_context'autoclean; }
sub auto_context'autoclean { &main'dataload; }

#
# Perform all contextual actions
#

sub main'contextual_operations { &auto_main'contextual_operations; }
sub auto_main'contextual_operations { &main'dataload; }

package main;

#
# Persitent variables handling
#

package extern;

sub extern'val { &auto_extern'val; }
sub auto_extern'val { &main'dataload; }

sub extern'set { &auto_extern'set; }
sub auto_extern'set { &main'dataload; }

sub extern'age { &auto_extern'age; }
sub auto_extern'age { &main'dataload; }

package main;

#
# Various hook utilities
# (name in package hook, compiled in package mailhook)
#

package mailhook;

sub hook'initvar { &auto_hook'initvar; }
sub auto_hook'initvar { &main'dataload; }

sub hook'run { &auto_hook'run; }
sub auto_hook'run { &main'dataload; }

package main;

#
# Perl interface with the filter actions
#

package mailhook;

sub abort		{ &interface'dispatch; }
sub annotate	{ &interface'dispatch; }
sub apply		{ &interface'dispatch; }
sub assign		{ &interface'dispatch; }
sub back		{ &interface'dispatch; }
sub beep		{ &interface'dispatch; }
sub begin		{ &interface'dispatch; }
sub biff		{ &interface'dispatch; }
sub bounce		{ &interface'dispatch; }
sub delete		{ &interface'dispatch; }
sub feed		{ &interface'dispatch; }
sub forward		{ &interface'dispatch; }
sub give		{ &interface'dispatch; }
sub keep		{ &interface'dispatch; }
sub leave		{ &interface'dispatch; }
sub macro		{ &interface'dispatch; }
sub message		{ &interface'dispatch; }
sub nop			{ &interface'dispatch; }
sub notify		{ &interface'dispatch; }
sub on			{ &interface'dispatch; }
sub once		{ &interface'dispatch; }
sub pass		{ &interface'dispatch; }
sub perl		{ &interface'dispatch; }
sub pipe		{ &interface'dispatch; }
sub post		{ &interface'dispatch; }
sub process		{ &interface'dispatch; }
sub protect		{ &interface'dispatch; }
sub purify		{ &interface'dispatch; }
sub queue		{ &interface'dispatch; }
sub record		{ &interface'dispatch; }
sub reject		{ &interface'dispatch; }
sub require		{ &interface'dispatch; }
sub restart		{ &interface'dispatch; }
sub resync		{ &interface'dispatch; }
sub run			{ &interface'dispatch; }
sub save		{ &interface'dispatch; }
sub select		{ &interface'dispatch; }
sub server		{ &interface'dispatch; }
sub split		{ &interface'dispatch; }
sub store		{ &interface'dispatch; }
sub strip		{ &interface'dispatch; }
sub subst		{ &interface'dispatch; }
sub tr			{ &interface'dispatch; }
sub umask		{ &interface'dispatch; }
sub unique		{ &interface'dispatch; }
sub vacation	{ &interface'dispatch; }
sub write		{ &interface'dispatch; }

# Perload OFF
# A perl filtering script should call &exit and not exit directly.
# (Cannot be data-loaded or it will corrupt $@ expected by &main'perl)
sub exit { 
	local($code) = @_;
	die "OK\n" unless $code;
	die "Exit $code\n";
}
# Perload ON

package interface;

# Perload OFF
# (Cannot be dynamically loaded as it uses the caller() function)

# The dispatch routine is really simple. We compute the name of our caller,
# prepend it to the argument and call run_command to actually run the command.
# Upon return, if we get anything but a continue status, we simply die with
# an 'OK' string, which will be a signal to the routine monitoring the execution
# that nothing wrong happened.
sub dispatch {
	local($args) = join(' ', @_);			# Arguments for the command
	local($name) = (caller(1))[3];			# Function which called us
	local($status);							# Continuation status
	$name =~ s/^\w+('|::)//;				# Strip leading package name
	&'add_log("calling '$name $args'") if $'loglvl > 18;
	$status = &'run_command("$name $args");	# Case does not matter

	# The status propagation is the only thing we have to deal with, as this
	# is handled within run_command. All other variables which are meaningful
	# for the filter are dynamically bound to function called before in the
	# stack, hence they are modified directly from within the perl script.

	die "Status $status\n" unless $status == $'FT_CONT;

	# Return the status held in $lastcmd, unless the command does not alter
	# the status significantly, in which case we return success. Note that
	# this is in fact a boolean success status, so 1 means success, whereas
	# $lastcmd records a failure status.

	$name =~ tr/a-z/A-Z/;					# Stored upper-cased
	$'Nostatus{$name} ? 1 : !$'lastcmd;		# Propagate status
}

# Perload ON

$in_perl = 0;					# Number of nested perl evaluations

sub interface'new { &auto_interface'new; }
sub auto_interface'new { &main'dataload; }

sub interface'reset { &auto_interface'reset; }
sub auto_interface'reset { &main'dataload; }

sub interface'valid { &auto_interface'valid; }
sub auto_interface'valid { &main'dataload; }

sub interface'add { &auto_interface'add; }
sub auto_interface'add { &main'dataload; }

package main;

package getdate;

# This package parses a date string and converts it into a number of seconds.
# I did minor editing on this code, mainly to remove all the YYDEBUG #if tests
# and to reformat some of the table. I also encapsulated all the initializations
# into init subroutines and reworked on the indentation of semantic actions.
# Oh yes, I also made some minor modifications in place (i.e. without running
# yacc again) to apply some small fixes Richard sent me via e-mail.
# Other than that, it's pretty verbatim--RAM.

sub getdate'yyinit { &auto_getdate'yyinit; }
sub auto_getdate'yyinit { &main'dataload; }

sub yyclearin { $yychar = -1; }
sub yyerrok { $yyerrflag = 0; }
sub YYERROR { ++$yynerrs; &yy_err_recover; }
sub getdate'yy_err_recover { &auto_getdate'yy_err_recover; }
sub auto_getdate'yy_err_recover { &main'dataload; }

sub getdate'yyparse { &auto_getdate'yyparse; }
sub auto_getdate'yyparse { &main'dataload; }

sub getdate'dateconv { &auto_getdate'dateconv; }
sub auto_getdate'dateconv { &main'dataload; }

sub getdate'dayconv { &auto_getdate'dayconv; }
sub auto_getdate'dayconv { &main'dataload; }

sub getdate'timeconv { &auto_getdate'timeconv; }
sub auto_getdate'timeconv { &main'dataload; }

sub getdate'monthadd { &auto_getdate'monthadd; }
sub auto_getdate'monthadd { &main'dataload; }

sub getdate'daylcorr { &auto_getdate'daylcorr; }
sub auto_getdate'daylcorr { &main'dataload; }

sub getdate'yylex { &auto_getdate'yylex; }
sub auto_getdate'yylex { &main'dataload; }
		
sub getdate'lookup_init { &auto_getdate'lookup_init; }
sub auto_getdate'lookup_init { &main'dataload; }

sub getdate'lookup { &auto_getdate'lookup; }
sub auto_getdate'lookup { &main'dataload; }

sub main'getdate { &auto_main'getdate; }
sub auto_main'getdate { &main'dataload; }

sub getdate'yyerror { &auto_getdate'yyerror; }
sub auto_getdate'yyerror { &main'dataload; }

package main;

sub main'include_file { &auto_main'include_file; }
sub auto_main'include_file { &main'dataload; }

sub main'plural { &auto_main'plural; }
sub auto_main'plural { &main'dataload; }

sub main'myhostname { &auto_main'myhostname; }
sub auto_main'myhostname { &main'dataload; }

sub main'hostname { &auto_main'hostname; }
sub auto_main'hostname { &main'dataload; }

#
# MMDF-style saving routines
#

package mmdf;

sub mmdf'save { &auto_mmdf'save; }
sub auto_mmdf'save { &main'dataload; }
	
sub mmdf'save_mmdf { &auto_mmdf'save_mmdf; }
sub auto_mmdf'save_mmdf { &main'dataload; }

sub mmdf'save_unix { &auto_mmdf'save_unix; }
sub auto_mmdf'save_unix { &main'dataload; }

sub mmdf'force_flushing { &auto_mmdf'force_flushing; }
sub auto_mmdf'force_flushing { &main'dataload; }

sub mmdf'is_mmdf { &auto_mmdf'is_mmdf; }
sub auto_mmdf'is_mmdf { &main'dataload; }

sub mmdf'chmod { &auto_mmdf'chmod; }
sub auto_mmdf'chmod { &main'dataload; }

package main;

#
# Folder compression
#

package compress;

sub compress'init { &auto_compress'init; }
sub auto_compress'init { &main'dataload; }

sub compress'uncompress { &auto_compress'uncompress; }
sub auto_compress'uncompress { &main'dataload; }

sub compress'compress { &auto_compress'compress; }
sub auto_compress'compress { &main'dataload; }

sub compress'recompress { &auto_compress'recompress; }
sub auto_compress'recompress { &main'dataload; }

sub compress'restore { &auto_compress'restore; }
sub auto_compress'restore { &main'dataload; }

sub compress'is_compressed { &auto_compress'is_compressed; }
sub auto_compress'is_compressed { &main'dataload; }

sub compress'add_compressor { &auto_compress'add_compressor; }
sub auto_compress'add_compressor { &main'dataload; }

package main;


package newcmd;

#
# User-defined commands
#

sub newcmd'load { &auto_newcmd'load; }
sub auto_newcmd'load { &main'dataload; }

sub newcmd'run { &auto_newcmd'run; }
sub auto_newcmd'run { &main'dataload; }

package main;

sub main'q { &auto_main'q; }
sub auto_main'q { &main'dataload; }

#
# Mailhook handling
#

package hook;

sub hook'init { &auto_hook'init; }
sub auto_hook'init { &main'dataload; }

sub hook'process { &auto_hook'process; }
sub auto_hook'process { &main'dataload; }

sub hook'type { &auto_hook'type; }
sub auto_hook'type { &main'dataload; }

#
# Hook functions
#

sub hook'unknown { &auto_hook'unknown; }
sub auto_hook'unknown { &main'dataload; }

sub hook'program { &auto_hook'program; }
sub auto_hook'program { &main'dataload; }

sub hook'rules { &auto_hook'rules; }
sub auto_hook'rules { &main'dataload; }

sub hook'perl { &auto_hook'perl; }
sub auto_hook'perl { &main'dataload; }

sub hook'audit { &auto_hook'audit; }
sub auto_hook'audit { &main'dataload; }

sub hook'deliver { &auto_hook'deliver; }
sub auto_hook'deliver { &main'dataload; }

sub hook'hooking { &auto_hook'hooking; }
sub auto_hook'hooking { &main'dataload; }

package main;

sub main'file_secure { &auto_main'file_secure; }
sub auto_main'file_secure { &main'dataload; }

sub main'symdir_secure { &auto_main'symdir_secure; }
sub auto_main'symdir_secure { &main'dataload; }

sub main'symfile_secure { &auto_main'symfile_secure; }
sub auto_main'symfile_secure { &main'dataload; }

sub main'symdir_check { &auto_main'symdir_check; }
sub auto_main'symdir_check { &main'dataload; }

sub main'symfile_check { &auto_main'symfile_check; }
sub auto_main'symfile_check { &main'dataload; }

sub main'check_st_mode { &auto_main'check_st_mode; }
sub auto_main'check_st_mode { &main'dataload; }

sub main'exec_secure { &auto_main'exec_secure; }
sub auto_main'exec_secure { &main'dataload; }

sub main'cdir { &auto_main'cdir; }
sub auto_main'cdir { &main'dataload; }

#
# Command server
#

package cmdserv;

$loaded = 0;			# Set to true when loading done

sub cmdserv'init { &auto_cmdserv'init; }
sub auto_cmdserv'init { &main'dataload; }

sub cmdserv'load { &auto_cmdserv'load; }
sub auto_cmdserv'load { &main'dataload; }

sub cmdserv'process { &auto_cmdserv'process; }
sub auto_cmdserv'process { &main'dataload; }

#
# Command execution
#

sub cmdserv'execute { &auto_cmdserv'execute; }
sub auto_cmdserv'execute { &main'dataload; }

sub cmdserv'dispatch { &auto_cmdserv'dispatch; }
sub auto_cmdserv'dispatch { &main'dataload; }

sub cmdserv'exec_shell { &auto_cmdserv'exec_shell; }
sub auto_cmdserv'exec_shell { &main'dataload; }

sub cmdserv'exec_perl { &auto_cmdserv'exec_perl; }
sub auto_cmdserv'exec_perl { &main'dataload; }

sub cmdserv'exec_help { &auto_cmdserv'exec_help; }
sub auto_cmdserv'exec_help { &main'dataload; }

#
# Builtins
#

sub cmdserv'run_approve { &auto_cmdserv'run_approve; }
sub auto_cmdserv'run_approve { &main'dataload; }

sub cmdserv'run_power { &auto_cmdserv'run_power; }
sub auto_cmdserv'run_power { &main'dataload; }

sub cmdserv'run_release { &auto_cmdserv'run_release; }
sub auto_cmdserv'run_release { &main'dataload; }

sub cmdserv'run_powers { &auto_cmdserv'run_powers; }
sub auto_cmdserv'run_powers { &main'dataload; }

sub cmdserv'run_password { &auto_cmdserv'run_password; }
sub auto_cmdserv'run_password { &main'dataload; }

sub cmdserv'run_passwd { &auto_cmdserv'run_passwd; }
sub auto_cmdserv'run_passwd { &main'dataload; }

sub cmdserv'change_password { &auto_cmdserv'change_password; }
sub auto_cmdserv'change_password { &main'dataload; }

sub cmdserv'run_user { &auto_cmdserv'run_user; }
sub auto_cmdserv'run_user { &main'dataload; }

sub cmdserv'run_newpower { &auto_cmdserv'run_newpower; }
sub auto_cmdserv'run_newpower { &main'dataload; }

sub cmdserv'newpower { &auto_cmdserv'newpower; }
sub auto_cmdserv'newpower { &main'dataload; }

sub cmdserv'run_delpower { &auto_cmdserv'run_delpower; }
sub auto_cmdserv'run_delpower { &main'dataload; }

sub cmdserv'delpower { &auto_cmdserv'delpower; }
sub auto_cmdserv'delpower { &main'dataload; }

sub cmdserv'run_setauth { &auto_cmdserv'run_setauth; }
sub auto_cmdserv'run_setauth { &main'dataload; }

sub cmdserv'run_addauth { &auto_cmdserv'run_addauth; }
sub auto_cmdserv'run_addauth { &main'dataload; }

sub cmdserv'run_remauth { &auto_cmdserv'run_remauth; }
sub auto_cmdserv'run_remauth { &main'dataload; }

sub cmdserv'run_getauth { &auto_cmdserv'run_getauth; }
sub auto_cmdserv'run_getauth { &main'dataload; }

sub cmdserv'run_set { &auto_cmdserv'run_set; }
sub auto_cmdserv'run_set { &main'dataload; }

#
# Utilities
#

sub cmdserv'user_prompt { &auto_cmdserv'user_prompt; }
sub auto_cmdserv'user_prompt { &main'dataload; }

sub cmdserv'include { &auto_cmdserv'include; }
sub auto_cmdserv'include { &main'dataload; }

sub cmdserv'finish { &auto_cmdserv'finish; }
sub auto_cmdserv'finish { &main'dataload; }

sub cmdserv'root { &auto_cmdserv'root; }
sub auto_cmdserv'root { &main'dataload; }

#
# Server modes
#

sub cmdserv'trusted { &auto_cmdserv'trusted; }
sub auto_cmdserv'trusted { &main'dataload; }

sub cmdserv'disable { &auto_cmdserv'disable; }
sub auto_cmdserv'disable { &main'dataload; }

sub cmdserv'servshell { &auto_cmdserv'servshell; }
sub auto_cmdserv'servshell { &main'dataload; }

#
# Environment for server commands
#

package cmdenv;

sub cmdenv'inituid { &auto_cmdenv'inituid; }
sub auto_cmdenv'inituid { &main'dataload; }

sub cmdenv'set_cmd { &auto_cmdenv'set_cmd; }
sub auto_cmdenv'set_cmd { &main'dataload; }

sub cmdenv'addpower { &auto_cmdenv'addpower; }
sub auto_cmdenv'addpower { &main'dataload; }

sub cmdenv'rempower { &auto_cmdenv'rempower; }
sub auto_cmdenv'rempower { &main'dataload; }

sub cmdenv'wipe_powers { &auto_cmdenv'wipe_powers; }
sub auto_cmdenv'wipe_powers { &main'dataload; }

sub cmdenv'haspower { &auto_cmdenv'haspower; }
sub auto_cmdenv'haspower { &main'dataload; }

package main;

#
# Power control
#

package power;

sub power'grant { &auto_power'grant; }
sub auto_power'grant { &main'dataload; }

sub power'authorized { &auto_power'authorized; }
sub auto_power'authorized { &main'dataload; }

sub power'valid { &auto_power'valid; }
sub auto_power'valid { &main'dataload; }

#
# Power aliases
#

sub power'authfile { &auto_power'authfile; }
sub auto_power'authfile { &main'dataload; }

sub power'set_auth { &auto_power'set_auth; }
sub auto_power'set_auth { &main'dataload; }

sub power'add_auth { &auto_power'add_auth; }
sub auto_power'add_auth { &main'dataload; }

sub power'rem_auth { &auto_power'rem_auth; }
sub auto_power'rem_auth { &main'dataload; }

sub power'used_alias { &auto_power'used_alias; }
sub auto_power'used_alias { &main'dataload; }

sub power'add_alias { &auto_power'add_alias; }
sub auto_power'add_alias { &main'dataload; }

sub power'del_alias { &auto_power'del_alias; }
sub auto_power'del_alias { &main'dataload; }

#
# Setting password information
#

sub power'set_passwd { &auto_power'set_passwd; }
sub auto_power'set_passwd { &main'dataload; }

sub power'getpwent { &auto_power'getpwent; }
sub auto_power'getpwent { &main'dataload; }

sub power'setpwent { &auto_power'setpwent; }
sub auto_power'setpwent { &main'dataload; }

sub power'rempwent { &auto_power'rempwent; }
sub auto_power'rempwent { &main'dataload; }

#
# Logging control
#

sub power'add_log { &auto_power'add_log; }
sub auto_power'add_log { &main'dataload; }

package main;

sub main'file_edit { &auto_main'file_edit; }
sub auto_main'file_edit { &main'dataload; }

#
# Load function into package
#

package dynload;

sub dynload'load { &auto_dynload'load; }
sub auto_dynload'load { &main'dataload; }

sub dynload'parse { &auto_dynload'parse; }
sub auto_dynload'parse { &main'dataload; }

sub dynload'do { &auto_dynload'do; }
sub auto_dynload'do { &main'dataload; }

package main;

sub main'gensym { &auto_main'gensym; }
sub auto_main'gensym { &main'dataload; }

#
# User-defined macros
#

package usrmac;

$init_done = 0;

sub usrmac'init { &auto_usrmac'init; }
sub auto_usrmac'init { &main'dataload; }

sub usrmac'push { &auto_usrmac'push; }
sub auto_usrmac'push { &main'dataload; }

sub usrmac'new { &auto_usrmac'new; }
sub auto_usrmac'new { &main'dataload; }

sub usrmac'pop { &auto_usrmac'pop; }
sub auto_usrmac'pop { &main'dataload; }

sub usrmac'delete { &auto_usrmac'delete; }
sub auto_usrmac'delete { &main'dataload; }

sub usrmac'save { &auto_usrmac'save; }
sub auto_usrmac'save { &main'dataload; }

sub usrmac'restore { &auto_usrmac'restore; }
sub auto_usrmac'restore { &main'dataload; }

#
# User-defined substitutions
#

sub macro'usr { &auto_macro'usr; }
sub auto_macro'usr { &main'dataload; }

#
# Type-dependant substitutions
#

sub usrmac'sub_scalar { &auto_usrmac'sub_scalar; }
sub auto_usrmac'sub_scalar { &main'dataload; }

sub usrmac'sub_expr { &auto_usrmac'sub_expr; }
sub auto_usrmac'sub_expr { &main'dataload; }

sub usrmac'sub_const { &auto_usrmac'sub_const; }
sub auto_usrmac'sub_const { &main'dataload; }

sub usrmac'sub_fn { &auto_usrmac'sub_fn; }
sub auto_usrmac'sub_fn { &main'dataload; }

sub usrmac'sub_prog { &auto_usrmac'sub_prog; }
sub auto_usrmac'sub_prog { &main'dataload; }

sub usrmac'sub_progc { &auto_usrmac'sub_progc; }
sub auto_usrmac'sub_progc { &main'dataload; }

#
# Value caching
#

sub usrmac'cache { &auto_usrmac'cache; }
sub auto_usrmac'cache { &main'dataload; }

package main;

sub main'tilda_expand { &auto_main'tilda_expand; }
sub auto_main'tilda_expand { &main'dataload; }

#
# MH-style saving routines
#

package mh;

sub mh'save { &auto_mh'save; }
sub auto_mh'save { &main'dataload; }
	
sub mh'savedir { &auto_mh'savedir; }
sub auto_mh'savedir { &main'dataload; }

sub mh'save_msg { &auto_mh'save_msg; }
sub auto_mh'save_msg { &main'dataload; }

#
# MH profile and sequence management.
#

sub mh'profile { &auto_mh'profile; }
sub auto_mh'profile { &main'dataload; }

sub mh'new_msg { &auto_mh'new_msg; }
sub auto_mh'new_msg { &main'dataload; }

sub mh'unseen { &auto_mh'unseen; }
sub auto_mh'unseen { &main'dataload; }

sub mh'seqadd { &auto_mh'seqadd; }
sub auto_mh'seqadd { &main'dataload; }

package main;

sub main'catch_signals { &auto_main'catch_signals; }
sub auto_main'catch_signals { &main'dataload; }

package callout;

#
# Callout queue handling
#

sub callout'init { &auto_callout'init; }
sub auto_callout'init { &main'dataload; }

sub callout'load { &auto_callout'load; }
sub auto_callout'load { &main'dataload; }

sub callout'queue { &auto_callout'queue; }
sub auto_callout'queue { &main'dataload; }

sub callout'trigger { &auto_callout'trigger; }
sub auto_callout'trigger { &main'dataload; }

sub callout'run { &auto_callout'run; }
sub auto_callout'run { &main'dataload; }

sub callout'flush { &auto_callout'flush; }
sub auto_callout'flush { &main'dataload; }

sub callout'save { &auto_callout'save; }
sub auto_callout'save { &main'dataload; }

#
# Spawning engine
#

sub callout'spawn { &auto_callout'spawn; }
sub auto_callout'spawn { &main'dataload; }

sub callout'spawn_agent { &auto_callout'spawn_agent; }
sub auto_callout'spawn_agent { &main'dataload; }

sub callout'spawn_cmd { &auto_callout'spawn_cmd; }
sub auto_callout'spawn_cmd { &main'dataload; }

sub callout'spawn_shell { &auto_callout'spawn_shell; }
sub auto_callout'spawn_shell { &main'dataload; }

package main;

package addr;

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

sub addr'valid { &auto_addr'valid; }
sub auto_addr'valid { &main'dataload; }

sub addr'simplify { &auto_addr'simplify; }
sub auto_addr'simplify { &main'dataload; }

sub addr'match { &auto_addr'match; }
sub auto_addr'match { &main'dataload; }

sub addr'close { &auto_addr'close; }
sub auto_addr'close { &main'dataload; }

package main;

#
# utmp file primitives
#

package utmp;

sub utmp'init { &auto_utmp'init; }
sub auto_utmp'init { &main'dataload; }

sub utmp'update { &auto_utmp'update; }
sub auto_utmp'update { &main'dataload; }

sub utmp'reload { &auto_utmp'reload; }
sub auto_utmp'reload { &main'dataload; }

sub utmp'ttys { &auto_utmp'ttys; }
sub auto_utmp'ttys { &main'dataload; }

package main;

#
# Local biff support
#

use Encode;

sub main'biff { &auto_main'biff; }
sub auto_main'biff { &main'dataload; }

package biff;

sub biff'notify { &auto_biff'notify; }
sub auto_biff'notify { &main'dataload; }

sub biff'custom { &auto_biff'custom; }
sub auto_biff'custom { &main'dataload; }

# Routine for %a substitution in biff templates
# Value of $env'beep is set by the BEEP command (default is 1).
sub beep { "\07" x $env'beep; }

sub biff'default { &auto_biff'default; }
sub auto_biff'default { &main'dataload; }

sub biff'all { &auto_biff'all; }
sub auto_biff'all { &main'dataload; }

sub biff'headers { &auto_biff'headers; }
sub auto_biff'headers { &main'dataload; }

sub biff'is_blank { &auto_biff'is_blank; }
sub auto_biff'is_blank { &main'dataload; }

sub biff'to_ascii { &auto_biff'to_ascii; }
sub auto_biff'to_ascii { &main'dataload; }

sub biff'body { &auto_biff'body; }
sub auto_biff'body { &main'dataload; }

sub biff'trim { &auto_biff'trim; }
sub auto_biff'trim { &main'dataload; }

sub biff'mh { &auto_biff'mh; }
sub auto_biff'mh { &main'dataload; }

sub biff'format { &auto_biff'format; }
sub auto_biff'format { &main'dataload; }

# Perload OFF

# Mangle given character to ASCII, or swallow it if CTRL char
# MUST NOT be dataloaded (would mess $1 in the regexp)
sub mangle_ascii {
	my ($x) = @_;
	my $c = unpack("U", $x);				# Read as Unicode
	return '' if $c <= 8;					# Invisible
	# Chars 9 and 10 are \t and \n in ASCII
	return '' if $c >= 11 && $c < 32;		# Invisible
	return '.' if $c >= 127;				# Outside the ASCII range
	return pack("C", $c);					# Write as a byte (ASCII)
}

# Quoted-printable decoder
# MUST NOT be dataloaded (would mess $1 in the regexp)
sub to_txt {
	my ($c, $l) = @_;	# charset, line
	$l =~ s/=([\da-fA-F]{2})/pack('C', hex($1))/ge;
	my $enc = Encode::find_encoding($c);
	my $biffenc = Encode::find_encoding($cf'biffchars);
	if (ref $enc && ref $biffenc && $enc->name ne $biffenc->name) {
		my $data = $enc->decode($l);
		$data = $biffenc->encode($data);
		$l = $data if length $data;
	}
	return $l;
}

# Base64 decoder
# MUST NOT be dataloaded (would mess $1 in the regexp)
sub b64_to_txt {
	my ($c, $l) = @_;	# charset, line
	base64'reset(length $l);
	base64'decode($l);
	my $o = base64'output();
	my $enc = Encode::find_encoding($c);
	my $biffenc = Encode::find_encoding($cf'biffchars);
	if (ref $enc && ref $biffenc && $enc->name ne $biffenc->name) {
		my $data = $enc->decode($$o);
		$data = $biffenc->encode($data);
		$l = $data if length $data;
	}
	return $l;
}

# Perload ON

sub biff'unquote_printable { &auto_biff'unquote_printable; }
sub auto_biff'unquote_printable { &main'dataload; }

sub biff'unmime_recursive { &auto_biff'unmime_recursive; }
sub auto_biff'unmime_recursive { &main'dataload; }

sub biff'unmime { &auto_biff'unmime; }
sub auto_biff'unmime { &main'dataload; }

sub biff'skip_past { &auto_biff'skip_past; }
sub auto_biff'skip_past { &main'dataload; }

sub biff'parse_header { &auto_biff'parse_header; }
sub auto_biff'parse_header { &main'dataload; }

sub biff'strip_html { &auto_biff'strip_html; }
sub auto_biff'strip_html { &main'dataload; }

package main;

package env;

sub env'init { &auto_env'init; }
sub auto_env'init { &main'dataload; }

sub env'setup { &auto_env'setup; }
sub auto_env'setup { &main'dataload; }

sub env'local { &auto_env'local; }
sub auto_env'local { &main'dataload; }

sub env'unset { &auto_env'unset; }
sub auto_env'unset { &main'dataload; }

sub env'undef { &auto_env'undef; }
sub auto_env'undef { &main'dataload; }

sub env'restore { &auto_env'restore; }
sub auto_env'restore { &main'dataload; }

sub env'cleanup { &auto_env'cleanup; }
sub auto_env'cleanup { &main'dataload; }

package main;

package opt;

sub opt'get { &auto_opt'get; }
sub auto_opt'get { &main'dataload; }

sub opt'reset { &auto_opt'reset; }
sub auto_opt'reset { &main'dataload; }

sub opt'restore { &auto_opt'restore; }
sub auto_opt'restore { &main'dataload; }

sub opt'parse { &auto_opt'parse; }
sub auto_opt'parse { &main'dataload; }

package main;

#
# Configuration setup main entry point
#

package cf;

sub cf'setup { &auto_cf'setup; }
sub auto_cf'setup { &main'dataload; }

#
# Configuration setup routines
#

package cfset;

sub cfset'init { &auto_cfset'init; }
sub auto_cfset'init { &main'dataload; }

sub cfset'merge { &auto_cfset'merge; }
sub auto_cfset'merge { &main'dataload; }

sub cfset'check { &auto_cfset'check; }
sub auto_cfset'check { &main'dataload; }

sub cfset'read_setup { &auto_cfset'read_setup; }
sub auto_cfset'read_setup { &main'dataload; }

sub cfset'dflt { &auto_cfset'dflt; }
sub auto_cfset'dflt { &main'dataload; }

sub cfset'exists { &auto_cfset'exists; }
sub auto_cfset'exists { &main'dataload; }

sub cfset'create { &auto_cfset'create; }
sub auto_cfset'create { &main'dataload; }

sub cfset'prefix { &auto_cfset'prefix; }
sub auto_cfset'prefix { &main'dataload; }

sub cfset'path_check { &auto_cfset'path_check; }
sub auto_cfset'path_check { &main'dataload; }

sub cfset'default_path { &auto_cfset'default_path; }
sub auto_cfset'default_path { &main'dataload; }

sub cfset'contains { &auto_cfset'contains; }
sub auto_cfset'contains { &main'dataload; }

package main;

package base64;

#
# Simple base64 encoder/decoder.
#

sub base64'init { &auto_base64'init; }
sub auto_base64'init { &main'dataload; }

sub base64'reset { &auto_base64'reset; }
sub auto_base64'reset { &main'dataload; }

sub base64'decode { &auto_base64'decode; }
sub auto_base64'decode { &main'dataload; }

sub base64'encode { &auto_base64'encode; }
sub auto_base64'encode { &main'dataload; }

sub base64'output { &auto_base64'output; }
sub auto_base64'output { &main'dataload; }

sub base64'is_valid { &auto_base64'is_valid; }
sub auto_base64'is_valid { &main'dataload; }

sub base64'error_msg { &auto_base64'error_msg; }
sub auto_base64'error_msg { &main'dataload; }

package main;

package qp;

#
# Simple quoted-printable encoder/decoder.
#

sub qp'reset { &auto_qp'reset; }
sub auto_qp'reset { &main'dataload; }

sub qp'decode { &auto_qp'decode; }
sub auto_qp'decode { &main'dataload; }

sub qp'encode { &auto_qp'encode; }
sub auto_qp'encode { &main'dataload; }

sub qp'output { &auto_qp'output; }
sub auto_qp'output { &main'dataload; }

sub qp'is_valid { &auto_qp'is_valid; }
sub auto_qp'is_valid { &main'dataload; }

sub qp'error_msg { &auto_qp'error_msg; }
sub auto_qp'error_msg { &main'dataload; }

package main;

#
# termios primitives
#

package termios;

sub termios'init { &auto_termios'init; }
sub auto_termios'init { &main'dataload; }

sub termios'decompile { &auto_termios'decompile; }
sub auto_termios'decompile { &main'dataload; }

sub termios'size { &auto_termios'size; }
sub auto_termios'size { &main'dataload; }

package main;

# Load the calling function from DATA segment and call it. This function is
# called only once per routine to be loaded.
sub main'dataload {
	package perload;
	local($__packname__) = (caller(1))[3];
	$__packname__ =~ s/::/'/;
	local($__rpackname__) = $__packname__;
	local($__at__) = $@;
	$__rpackname__ =~ s/^auto_//;
	eval { load_from_data($__rpackname__, 0) };
	if ($@ eq "RETRY\n") {
		undef %Datapos;
		load_from_data($__rpackname__, 1);
	} else {
		die $@ if $@;
	}
	local($__fun__) = "$__rpackname__";
	$__fun__ =~ s/'/'load_/;
	eval "*$__packname__ = *$__fun__;";	# Change symbol table entry
	die $@ if $@;		# Should not happen
	$@ = $__at__;		# Restore value $@ had on entrance
	&$__fun__;			# Call newly loaded function
}

# Load function name given as argument, fatal error if not existent
sub perload'load_from_data {
	package perload;
	local ($name, $retried) = @_;
	local($pos) = $Datapos{$name};			# Offset within DATA
	# Avoid side effects by protecting special variables which will be changed
	# by the dataloading operation.
	local($., $_);
	$pos = &fetch_function_code($name, $retried) unless $pos;
	die "Function $name not found in data section.\n" unless $pos;
	die "Cannot seek to $pos into data section.\n"
		unless seek(main'DATA, $pos, 0);
	local($/) = "\n}";
	local($body) = scalar(<main'DATA>);
	local $loaded = $name;
	$loaded =~ s/^(.*?)'(.*)/sub ${1}'load_$2 {/;;
	unless ($body =~ /\n\}$/s && substr($body, 0, length $loaded) eq $loaded) {
		if ($retried) {
			die "End of file found while loading $name.\n"
				unless $body =~ /\n\}$/s;
			die "Offset table garbled or file changed whilst loading $name.\n";
		}
		die "RETRY\n";
	}
	local $@;
	eval $body;		# Load function into perl space
	chop($@) && die "$@, while parsing code of $_[0].\n";
}

# This function is called only once, and fills in the %Datapos array with
# the offset of each of the dataloaded routines held in the data section.
sub perload'fetch_function_code {
	package perload;
	local ($name, $retried) = @_;
	local($start) = 0;
	local($., $_);
	if ($retried) {
		my $date = scalar localtime;
		warn("$0 probably changed, reloading offset table on $date\n");
		close(main'DATA);
		open(main'DATA, $0) || die "Can't open $0 to reload offset table: $!\n";
		my $found = 0;
		while (<main'DATA>) {
			if (/^__END__\s$/) { $found++; last }
		}
		die "Unable to find __END__ token in $0\n" unless $found;
	}
	while (<main'DATA>) {			# First move to start of offset table
		next if /^#/;
		last if /^$/ && ++$start > 2;	# Skip two blank line after end token
	}
	$start = tell(main'DATA);		# Offsets in table are relative to here
	local($key, $value);
	while (<main'DATA>) {			# Load the offset table
		last if /^$/;				# Ends with a single blank line
		($key, $value) = split(' ');
		$Datapos{$key} = $value + $start;
	}
	$Datapos{$name};		# All that pain to get this offset...
}

#
# The perl compiler stops here.
#

__END__

#
# Beyond this point lie functions we may never compile.
#

#
# DO NOT CHANGE A IOTA BEYOND THIS COMMENT!
# The following table lists offsets of functions within the data section.
# Should modifications be needed, change original code and rerun perload
# with the -o option to regenerate a proper offset table.
#

	                     addr'close     499475
	                     addr'match     498731
	                  addr'simplify     498011
	                     addr'valid     497711
	                  base64'decode     547370
	                  base64'encode     548927
	               base64'error_msg     551242
	                    base64'init     544762
	                base64'is_valid     551116
	                  base64'output     550382
	                   base64'reset     546947
	                       biff'all     507576
	                      biff'body     509365
	                    biff'custom     504653
	                   biff'default     507128
	                    biff'format     517754
	                   biff'headers     508193
	                  biff'is_blank     508653
	                        biff'mh     516700
	                    biff'notify     502721
	              biff'parse_header     524320
	                 biff'skip_past     523995
	                biff'strip_html     525051
	                  biff'to_ascii     508922
	                      biff'trim     512849
	                    biff'unmime     521776
	          biff'unmime_recursive     519770
	         biff'unquote_printable     518790
	                  callout'flush     493686
	                   callout'init     488877
	                   callout'load     489452
	                  callout'queue     490670
	                    callout'run     492312
	                   callout'save     494051
	                  callout'spawn     495488
	            callout'spawn_agent     496660
	              callout'spawn_cmd     497038
	            callout'spawn_shell     497195
	                callout'trigger     491830
	                       cf'parse      36869
	                       cf'setup     531155
	                    cfset'check     537533
	                 cfset'contains     544524
	                   cfset'create     540718
	             cfset'default_path     543977
	                     cfset'dflt     539656
	                   cfset'exists     539971
	                     cfset'init     532312
	                    cfset'merge     534380
	               cfset'path_check     542963
	                   cfset'prefix     542463
	               cfset'read_setup     539021
	                cmdenv'addpower     454130
	                cmdenv'haspower     454624
	                 cmdenv'inituid     452517
	                cmdenv'rempower     454290
	                 cmdenv'set_cmd     453582
	             cmdenv'wipe_powers     454451
	        cmdserv'change_password     438769
	               cmdserv'delpower     444700
	                cmdserv'disable     451809
	               cmdserv'dispatch     423201
	              cmdserv'exec_help     431462
	              cmdserv'exec_perl     430187
	             cmdserv'exec_shell     424081
	                cmdserv'execute     422728
	                 cmdserv'finish     451175
	                cmdserv'include     450584
	                   cmdserv'init     412019
	                   cmdserv'load     414153
	               cmdserv'newpower     441684
	                cmdserv'process     417435
	                   cmdserv'root     451372
	            cmdserv'run_addauth     446571
	            cmdserv'run_approve     433512
	           cmdserv'run_delpower     444014
	            cmdserv'run_getauth     448224
	           cmdserv'run_newpower     441096
	             cmdserv'run_passwd     437944
	           cmdserv'run_password     437075
	              cmdserv'run_power     434031
	             cmdserv'run_powers     435444
	            cmdserv'run_release     434881
	            cmdserv'run_remauth     447397
	                cmdserv'run_set     448920
	            cmdserv'run_setauth     445752
	               cmdserv'run_user     439683
	              cmdserv'servshell     452138
	                cmdserv'trusted     451512
	            cmdserv'user_prompt     449964
	        compress'add_compressor     390831
	              compress'compress     387092
	                  compress'init     382576
	         compress'is_compressed     389841
	            compress'recompress     388422
	               compress'restore     388596
	            compress'uncompress     384300
	              context'autoclean     346684
	                  context'clean     344770
	                context'default     344130
	                 context'delete     346139
	                    context'get     345989
	                   context'init     343845
	                   context'load     344276
	                   context'save     344952
	                    context'set     345839
	                      dbr'clean     319985
	                 dbr'clean_file     321241
	                    dbr'default     319500
	                     dbr'delete     319278
	                  dbr'hash_path     313070
	                       dbr'info     314492
	                      dbr'match     315759
	            dbr'recursive_clean     320224
	                     dbr'update     317347
	                     dynload'do     471906
	                   dynload'load     469435
	                  dynload'parse     470491
	                    env'cleanup     528514
	                       env'init     526263
	                      env'local     527084
	                    env'restore     528140
	                      env'setup     526638
	                      env'undef     527755
	                      env'unset     527528
	                     extern'age     347941
	                     extern'set     347756
	                     extern'val     347531
	               getdate'dateconv     364904
	                getdate'dayconv     365734
	               getdate'daylcorr     366954
	                 getdate'lookup     372974
	            getdate'lookup_init     368393
	               getdate'monthadd     366557
	               getdate'timeconv     366085
	         getdate'yy_err_recover     358473
	                getdate'yyerror     376042
	                 getdate'yyinit     351882
	                  getdate'yylex     367207
	                getdate'yyparse     359056
	                   header'check     173246
	                   header'clean     172650
	                  header'format     176797
	                    header'init     170638
	           header'msgid_cleanup     175490
	                header'mta_date     174133
	                header'news_fmt     179054
	               header'normalize     175209
	               header'parsedate     176300
	                    header'push     173737
	                   header'reset     170861
	                   header'valid     171177
	                 header'warning     171884
	                     hook'audit     398867
	                   hook'deliver     399618
	                   hook'hooking     400834
	                      hook'init     395654
	                   hook'initvar     348319
	                      hook'perl     398215
	                   hook'process     396074
	                   hook'program     397450
	                     hook'rules     397728
	                       hook'run     349333
	                      hook'type     396719
	                   hook'unknown     397301
	                  interface'add     351471
	                  interface'new     349848
	                interface'reset     350080
	                interface'valid     351070
	                      lock'base      45449
	                       lock'dir      45571
	                      lock'file      44962
	                   macro'domain     169402
	                     macro'info     169132
	                 macro'internet     169552
	                      macro'org     169285
	                 macro'overload     170198
	                      macro'usr     476672
	                  main'acs_lock      42440
	               main'acs_locktry      41638
	                  main'acs_rqst      41288
	              main'action_parse      56610
	                   main'add_log      46805
	                     main'after     246085
	               main'alarm_clock     223099
	           main'alter_execution     141239
	               main'alter_field     237724
	                main'alter_flow     247557
	              main'alter_header     234044
	               main'alter_value     239550
	              main'analyze_mail      89503
	           main'annotate_header     235852
	                     main'apply     213955
	               main'apply_match     146206
	               main'apply_rules      93987
	        main'best_body_encoding      87415
	                      main'biff     502178
	                main'body_check      67611
	               main'body_recode      70633
	     main'body_recode_optimally      71656
	          main'body_recode_with      69394
	                    main'bounce     202822
	              main'builtin_path     289798
	                main'builtin_rr     289397
	             main'catch_signals     488356
	                      main'cdir     411432
	             main'check_st_mode     408461
	                 main'checklock      50420
	             main'compile_rules     290907
	             main'complete_list     248749
	     main'contextual_operations     347318
	             main'default_rules     294981
	                        main'do     244797
	                  main'do_abort     248450
	                 main'do_reject     248056
	                main'do_restart     248252
	               main'domain_addr      31407
	                 main'dump_mbox     331666
	                main'dump_rules     295858
	                main'email_addr      30872
	            main'emergency_save     330947
	                main'empty_body     252893
	                     main'error     308948
	                main'eval_error      34695
	                 main'eval_expr     310926
	                  main'evaluate     312673
	                main'exact_rule     295740
	               main'exec_secure     409085
	                   main'execute     309495
	           main'execute_command     224598
	       main'expr_selector_match     148612
	                     main'fatal     328507
	                 main'feed_back     229283
	                 main'file_edit     462266
	               main'file_secure     401602
	                main'fork_child      33746
	                   main'forward     201070
	                 main'free_file      45838
	              main'fuzzy_domain     104649
	            main'gen_message_id     164464
	                    main'gensym     473174
	                main'get_action      55781
	         main'get_configuration      23800
	                  main'get_line      51722
	                  main'get_mode      52648
	               main'get_pattern      53886
	              main'get_selector      53138
	                   main'getdate     374629
	             main'handle_output     227614
	             main'header_append      86821
	              main'header_check      74832
	main'header_check_body_encoding      72726
	              main'header_found     180903
	              main'header_lines      65562
	              main'header_parse      63789
	            main'header_prepend      87056
	             main'header_resync     233609
	        main'header_update_size      65830
	            main'history_ignore     326096
	            main'history_record     326622
	               main'history_tag     323029
	                  main'hostname     378371
	              main'include_file     376491
	                  main'init_all      24151
	             main'init_builtins     289228
	            main'init_constants      24651
	                  main'init_env      27106
	               main'init_filter     110906
	          main'init_interpreter     307808
	              main'init_matcher     142768
	            main'init_pseudokey      27274
	              main'init_special      88339
	             main'internet_info     163355
	                    main'jobnum      34975
	                 main'last_name     163126
	                     main'leave     181489
	                main'list_queue     336188
	               main'locate_file     159221
	            main'locate_program     160115
	                main'login_name     162266
	                     main'macro     194683
	              main'macros_subst     164902
	                 main'mail_back     227937
	              main'mail_logname      88871
	              main'mail_logsize      89209
	              main'mailbox_name      32233
	              main'make_pattern     143966
	                   main'makedir     327957
	                     main'match     145043
	                main'match_list     154348
	              main'match_single     152032
	                 main'match_var     155309
	                 main'mbox_lock      28097
	                 main'mbox_mail     341835
	               main'mbox_unlock      30278
	                   main'message     196022
	                    main'mrange     158332
	                        main'mv     281282
	                main'myhostname     378157
	                    main'notify     196349
	                main'once_check     326837
	             main'parse_address     161215
	                main'parse_mail      58861
	           main'patch_constants      26653
	                      main'perl     240881
	              main'perl_pattern     143503
	                    main'plural     377693
	                     main'pmail     286126
	              main'popen_failed     222726
	                      main'post     204262
	                    main'pqueue     283222
	         main'print_binary_mail     224081
	                main'print_rule     299805
	         main'print_rule_number     295457
	                   main'process     187386
	                  main'push_val     309144
	                         main'q     395555
	                     main'qmail     273533
	                main'queue_mail     275266
	               main'read_config      35419
	             main'read_filerule      51265
	             main'read_linerule      51476
	                main'read_stats     253800
	                 main'reception     105548
	              main'relative_age     307172
	                main'relay_list      79543
	              main'report_stats     263521
	                   main'require     243794
	             main'reset_backref     157096
	                    main'resync     333981
	                main'right_mode     101144
	              main'rule_cleanup     295279
	                 main'run_abort     118641
	                 main'run_after     136076
	              main'run_annotate     130136
	                 main'run_apply     135159
	                main'run_assign     130461
	                  main'run_back     123406
	                  main'run_beep     136992
	                 main'run_begin     119092
	                  main'run_biff     137987
	                main'run_bounce     120950
	              main'run_builtins     290028
	               main'run_command     108098
	                main'run_delete     116974
	                    main'run_do     136632
	                  main'run_feed     122676
	               main'run_forward     120642
	                  main'run_give     122134
	                  main'run_keep     129880
	                 main'run_leave     115360
	                 main'run_macro     117160
	               main'run_message     117413
	                   main'run_nop     129250
	                main'run_notify     117761
	                    main'run_on     124620
	                  main'run_once     126237
	                  main'run_pass     122403
	                  main'run_perl     134431
	                  main'run_pipe     121812
	                  main'run_post     121250
	               main'run_process     114585
	               main'run_protect     137342
	                main'run_purify     123060
	                 main'run_queue     134013
	                main'run_record     119504
	                main'run_reject     118323
	               main'run_require     134738
	               main'run_restart     118482
	                main'run_resync     118797
	                   main'run_run     121546
	                  main'run_save     115782
	                main'run_saving     138981
	                main'run_select     127586
	                main'run_server     114847
	                 main'run_split     131534
	                 main'run_store     115935
	                 main'run_strip     129620
	                 main'run_subst     131383
	                    main'run_tr     131232
	                 main'run_umask     135597
	                main'run_unique     120110
	              main'run_vacation     132931
	                 main'run_write     116626
	            main'runop_on_field     236956
	                  main's_action     259740
	                 main's_default     259185
	                  main's_failed     259909
	                main's_filtered     258879
	                   main's_match     259032
	                 main's_noretry     260281
	                    main's_once     260118
	                   main's_saved     259482
	                    main's_seen     259615
	                main's_vacation     259334
	               main'same_device     282798
	                      main'save     182071
	               main'save_folder     183811
	                 main'save_hook     187115
	                 main'save_mail     249447
	              main'save_message     142036
	         main'seconds_in_period     306184
	            main'selector_match     150760
	              main'send_message     197195
	              main'send_receipt     287486
	             main'set_functions     308460
	            main'set_priorities     308238
	             main'shell_command     221003
	              main'special_user     102486
	                     main'split     215031
	                main'stderr_log      47160
	                main'stdout_log      47559
	              main'symdir_check     405791
	             main'symdir_secure     404405
	             main'symfile_check     407163
	            main'symfile_secure     404782
	                     main'tilda      31909
	              main'tilda_expand     479480
	                main'trace_dump     253313
	                main'track_rule     106454
	            main'update_backref     157559
	              main'update_stack     310200
	                     main'usage      22705
	                   main'usr_log      48542
	                 main'void_func     295624
	              main'waiting_mail     280055
	               main'write_stats     256010
	            main'write_waitkeys     333027
	                  main'xeq_back     233146
	                     main'xeqte     106901
	                     mbox'flush     343379
	              mbox'flush_blanks     343029
	              mbox'flush_buffer     343206
	                     mh'new_msg     483399
	                     mh'profile     482469
	                        mh'save     479844
	                    mh'save_msg     480788
	                     mh'savedir     480508
	                      mh'seqadd     487211
	                      mh'unseen     485186
	                     mmdf'chmod     382091
	            mmdf'force_flushing     381198
	                   mmdf'is_mmdf     381403
	                      mmdf'save     378745
	                 mmdf'save_mmdf     379240
	                 mmdf'save_unix     380311
	                    newcmd'load     391414
	                     newcmd'run     393568
	                        opt'get     528804
	                      opt'parse     530696
	                      opt'reset     529770
	                    opt'restore     530140
	                power'add_alias     459013
	                 power'add_auth     458050
	                  power'add_log     461973
	                 power'authfile     457057
	               power'authorized     455566
	                power'del_alias     459323
	                 power'getpwent     460538
	                    power'grant     454862
	                 power'rem_auth     458319
	                 power'rempwent     461462
	                 power'set_auth     457598
	               power'set_passwd     459699
	                 power'setpwent     461101
	               power'used_alias     458628
	                    power'valid     456461
	                      qp'decode     551953
	                      qp'encode     552647
	                   qp'error_msg     554220
	                    qp'is_valid     554102
	                      qp'output     553734
	                       qp'reset     551593
	                rules'alternate     304618
	                 rules'cache_ok     302745
	               rules'read_cache     301619
	              rules'write_cache     300381
	                 rules'write_fd     303402
	              rules'writevar_fd     303955
	               stats'diff_rules     260598
	               stats'fill_stats     262313
	              stats'print_array     258639
	           stats'print_commands     268617
	            stats'print_general     267482
	             stats'print_header     271569
	      stats'print_rules_summary     270713
	              stats'print_stats     265793
	            stats'print_summary     266873
	               stats'rule_stats     272462
	             stats'uniform_rule     270310
	              termios'decompile     554706
	                   termios'init     554353
	                   termios'size     555192
	                  usrlog'delete      48300
	                     usrlog'new      47847
	               usrlog'write_log      48868
	                   usrmac'cache     479173
	                  usrmac'delete     475444
	                    usrmac'init     473628
	                     usrmac'new     474617
	                     usrmac'pop     475054
	                    usrmac'push     474149
	                 usrmac'restore     476187
	                    usrmac'save     475880
	               usrmac'sub_const     477576
	                usrmac'sub_expr     477420
	                  usrmac'sub_fn     477905
	                usrmac'sub_prog     478296
	               usrmac'sub_progc     478788
	              usrmac'sub_scalar     477277
	                      utmp'init     500170
	                    utmp'reload     501022
	                      utmp'ttys     501722
	                    utmp'update     500715

#
# End of offset table and beginning of dataloading section.
#

# Print usage and exit
sub main'load_usage {
	package main;
	print STDERR <<EOF;
Usage: $prog_name [-dhilqtFIVU] [-s{umaryt}] [-f file] [-e rules] [-c config]
       [-L level] [-r file] [-o def] [mailfile]
  -c : specify alternate configuration file.
  -d : dump filter rules (special).
  -e : enter rules to be applied.
  -f : get messages from UNIX-style mailbox file.
  -h : print this help message and exits.
  -i : interactive usage -- print log messages on stderr.
  -l : list message queue (special).
  -o : overwrite config file with supplied definition.
  -q : process the queue (special).
  -r : specify alternate rule file.
  -s : report gathered statistics (special).
  -t : track rules on stdout.
  -F : force processing on already filtered messages.
  -I : install configuration and perform sanity checks.
  -L : force logging level.
  -V : print version number and exits.
  -U : prevent UNIQUE from rejecting an already processed Message-ID.
EOF
	exit 1;
}

# Read configuration file and alter it with the values specified via -o.
# Then apply -r and -t by modifying suitable configuration parameters.
sub main'load_get_configuration {
	package main;
	&read_config($config_file);		# Read configuration file and set vars
	&cf'parse($over_config);		# Overwrite with command line options
	$cf'rules = $rule_file if $rule_file;		# -r overwrites rule file
	$loglvl = $log_level if $log_level >= 0;	# -L overwrites logging level
}

# Start-up initializations
sub main'load_init_all {
	package main;
	&catch_signals;		# Trap common signals
	&init_interpreter;	# Initialize tables %Priority, %Function, ...
	&init_env;			# Initialize the %XENV array
	&init_matcher;		# Initialize special matching functions
	&init_pseudokey;	# Initialize the pseudo header keys for H table
	&init_builtins;		# Initialize built-in commands like @RR
	&init_filter;		# Initialize filter commands
	&init_special;		# Initialize special user table %Special
}

# Constants definitions
sub main'load_init_constants {
	package main;
	# Values for flock(), usually in <sys/file.h>
	$LOCK_SH = 1;				# Request a shared lock on file
	$LOCK_EX = 2;				# Request an exclusive lock
	$LOCK_NB = 4;				# Make a non-blocking lock request
	$LOCK_UN = 8;				# Unlock the file

	# Stat constants for file rights
	$S_IWOTH = 00002;			# Writable by world (no .ph files here)
	$S_IWGRP = 00020;			# Writable by group
	$S_ISUID = 04000;			# Set user ID on exec
	$S_ISGID = 02000;			# Set group ID on exec

	# Status used by filter
	$FT_RESTART = 0;			# Abort current action, restart from scratch
	$FT_CONT = 1;				# Continue execution
	$FT_REJECT = 2;				# Abort current action, continue filtering
	$FT_ABORT = 3;				# Abort filtering process

	# Shall we append or remove folder?
	$FOLDER_APPEND = 0;			# Append in folder
	$FOLDER_REMOVE = 1;			# Remove folder

	# Used by shell_command and children
	$NO_INPUT = 0;				# No input (stdin is closed)
	$BODY_INPUT = 1;			# Give body of mail as stdin
	$MAIL_INPUT = 2;			# Pipe the whole mail
	$HEADER_INPUT = 3;			# Pipe the header only
	$MAIL_INPUT_BINARY = 4;		# Whole mail in binary (no transfer encoding)
	$NO_FEEDBACK = 0;			# No feedback wanted
	$FEEDBACK = 1;				# Feed result of command back into %Header
	$FEEDBACK_ENCODING = 2;		# Same as $FEEDBACK, but probe body for encoding

	# The filter message
	local($address) = &email_addr;
	$FILTER =
		"X-Filter: mailagent [version $mversion-$revision] for $address";
	$MAILER =
		"X-Mailer: mailagent [version $mversion-$revision]";

	# For header fields alteration
	$HD_STRIP = 0;				# Strip header fields
	$HD_KEEP = 1;				# Keep header fields

	# Faked leading From line (used for digest items, by SPLIT)
	local($now) = scalar(localtime());
	$now =~ s/\s(\d:\d\d:\d\d)\b/0$1/;	# Add leading 0 if hour < 10
	$FAKE_FROM = "From mailagent " . $now;

	# Miscellaneous constants
	$MAX_LINKS = 100;			# Maximum number of symbolic link levels
}

# Change some constants after configuration file was parsed
sub main'load_patch_constants {
	package main;
	local($address) = &email_addr;	# Will prefer cf vars to hardwired ones
	$FILTER =
		"X-Filter: mailagent [version $mversion-$revision] for $address";
}

# Initializes environment. All the variables are initialized in XENV array
# The sole purpose of XENV is to be able to know what changes wrt the invoking
# environment when dumping the rules. It also avoid modifying the environment
# for our children.
sub main'load_init_env {
	package main;
	foreach (keys(%ENV)) {
		$XENV{$_} = $ENV{$_};
	}
}

# List of special header keys which do not represent a true header field.
sub main'load_init_pseudokey {
	package main;
	%Pseudokey = (
		'Body', 1,			# Body of message
		'Head', 1,			# Header of message
		'All', 1,			# Concatenation of Header, "\n", Body
		'=Body=', 1,		# Reference to body with decoded transfer encoding
	);
}

# Attempts a mailbox locking. The argument is the name of the file, the file
# descriptor is the global MBOX, opened for appending.
# Returns true if the lock was obtained, false if the lock could not be
# obtained but we wish to continue anyway, and undef if the lock was not
# obtained and locksafe is ON (i.e. the user does not wish to risk a delivery
# with no locking).
# If locksafe is set to PARTIAL, we only wish a lock to protect against
# another concurrent mailagent delivery, so any partial lock is ok (e.g. an
# flock() lock was obtained, but no .lock).
sub main'load_mbox_lock {
	package main;
	local($file) = @_;				# File name
	local($locked) = 0;				# Did we get at least one lock?
	local($error) = 0;				# Assume no error
	local($lastlock) = '';			# Last lock we successfully grabbed

	# Initial .lock locking (optionally reconfigured via mboxlock)
	# Done only when not configured to perform flock()-style locks.

	unless ($flock_only) {			# Lock with .lock
		if (0 != &acs_rqst($file, $cf'mboxlock)) {
			&add_log("WARNING could not lock $file") if $loglvl > 5;
			$error++;
		} else {
			$locked++;
			$lastlock = 'mbox .lock';
		}
	}

	# Make sure the file is still there and as not been removed while we were
	# waiting for the lock (in which case our MBOX file descriptor would be
	# useless: we would write in a ghost file!). This could happen when 'elm'
	# (or other mail user agent) resynchronizes the mailbox.

	close MBOX;
	unless (open(MBOX, ">>$file")) {
		&fatal("could not reopen $file");
	}

	# Perform flock()-style locking if configured to do so.

	if ($lock_by_flock) {
		local($ok) = 0;
		eval { $ok = flock(MBOX, $LOCK_EX) };	# flock() may be missing!
		if ($@ ne '' && $flock_only) {
			&add_log("WARNING flock() not available for locking")
				if $loglvl > 5;
			$error++;
		} elsif ($ok) {
			$locked++;
			$lastlock = 'flock';
		} else {
			&add_log("WARNING could not flock $file: $!") if $loglvl > 5;
			$error++;
		}
	}

	&add_log("WARNING was unable to get any lock on $file")
		if !$locked && $loglvl > 5;

	&add_log("NOTICE got an \"$lastlock\"-style lock on $file")
		if $error && $locked && $cf'locksafe !~ /^ON/i && $loglvl > 6;

	seek(MBOX, 0, 2);			# Someone may have appended something

	if ($cf'locksafe =~ /^ON/i && $error) {
		&mbox_unlock;
		return undef;			# No lock grabbed, can't deliver to folder
	} elsif ($cf'locksafe =~ /^PARTIAL/i) {
		return 1 if $locked;	# We got a partial locking, allow delivery
		return undef;			# No lock, can't deliver to that mbox
	} elsif ($error) {
		return 0;				# False but defined, meaning we may deliver!
	}

	return 1;	# Ok, we did lock that mailbox and we may deliver to it
}

# Remove lock on mailbox and return a failure status if closing failed
sub main'load_mbox_unlock {
	package main;
	local($file) = @_;				# File name
	local($status);					# Error status from close
	$status = close(MBOX);			# Closing will remove flock lock
	&free_file($file, $cf'mboxlock) unless $flock_only;	# Remove the lock
	$status ? 0 : 1;				# Return 0 for ok, 1 if close failed
}

# Computes the e-mail address of the user
# Can't rely on the value of $cf'user since config file may not have
# been parsed when this routine is first called. This routine is also used
# to set a default value for $cf'email.
# Once $cf'email exists however, its value is used.
sub main'load_email_addr {
	package main;
	if (defined $cf'email) {
		my $mail = $cf'email;
		$mail .= '@' . &domain_addr unless $mail =~ /@/;
		return $mail;
	}
	return $email_addr_cached if defined $email_addr_cached;
	local($user);
	($user) = getpwuid($>);
	($user) = getpwuid($<) unless $user;
	$user = 'nobody' unless $user;
	$email_addr_cached = $user . '@' . &domain_addr;
	return $email_addr_cached;	# E-mail address in internet format
}

# Domain name address for current host
# Use $cf'domain and $cf'hidenet when available.
sub main'load_domain_addr {
	package main;
	local($_);							# Our host name
	if (defined $cf'domain) {
		$_ = $cf'domain;
		if (lc($cf'hidenet) ne "on" || $_ eq '') {
			$_ = &hostname;
			$_ .= ".$cf::domain" unless /\./;
		}
	} else {
		$_ = $hiddennet if $hiddennet ne '';
		if ($_ eq '') {
			$_ = &hostname;					# Must fork to get hostname, grr...
			$_ .= $mydomain unless /\./;	# We want something fully qualified
		}
	}
	$_;
}

# Strip out leading path to home directory and replace it by a ~
sub main'load_tilda {
	package main;
	local($path) = @_;					# Path we wish to shorten
	local($home) = $cf'home;
	$home =~ s/(\W)/\\$1/g;				# Escape possible meta-characters
	$path =~ s/^$home/~/;				# Replace the home directory by ~
	$path;								# Return possibly stripped path
}

# Compute the system mailbox file name
sub main'load_mailbox_name {
	package main;
	# If ~/.mailagent provides us with a mail directory, use it and possibly
	# override value computed by Configure.
	$maildir = $cf'maildrop if $cf'maildrop ne '';
	# If Configure gave a valid 'maildir', use it. Otherwise compute one now.
	unless ($maildir ne '' && -d "$maildir") {
		$maildir = "/var/spool/mail";		# Default spooling area
		-d "$maildir" || ( -d "/usr/mail" && ($maildir = "/usr/mail"));
		-d "$maildir" || ($maildir = "$cf'home");
	}
	local($mbox) = $cf'user;					# Default mailbox file name
	$mbox = $cf'mailbox if $cf'mailbox ne '';	# Priority to config variable
	$mailbox = "$maildir/$mbox";				# Full mailbox path
	if (! -f "$mailbox" && ! -w "$maildir") {
		# No mailbox already exists and we can't write in the spool directory.
		# Use mailfile then, and if we can't write in the directory and the
		# mail file does not exist either, use ~/mbox.$cf'user as mailbox.
		$mailbox = $mailfile;		# Determined by configure (%~ and %L form)
		$mailbox =~ s/%~/$cf'home/go;	# %~ stands for the user directory
		$mailbox =~ s/%L/$cf'user/go;	# %L stands for the user login name
		$mailbox =~ m|(.*)/.*|;			# Extract dirname
		$mailbox = "$cf'home/mbox.$cf'user" unless (-f "$mailbox" || -w "$1");
		&add_log("WARNING using $mailbox for mailbox") if $loglvl > 5;
	}
	$mailbox;
}

# Fork a new mailagent and update the pid in the perl.lock file. The parent
# then exits and the child continues. This enables the filter which invoked
# us to finally exit.
sub main'load_fork_child {
	package main;
	local($pid) = fork;
	if ($pid == -1) {				# We cannot fork, exit.
		&add_log("ERROR couldn't fork to process the queue") if $loglvl > 5;
		unlink $lockfile if $locked;
		exit 0;
	} elsif ($pid == 0) {			# The child process
		# Update the pid in the perl.lock file, so that any process which will
		# use the kill(pid, 0) feature to check whether we are alive or not will
		# get a meaningful status.
		if ($locked) {
			chmod 0644, $lockfile;
			open(LOCK, ">$lockfile");	# Ignore errors
			chmod 0444, $lockfile;		# Now it's open, so we may restore mode
			print LOCK "$$\n";			# Write child's PID
			close LOCK;
		}
		sleep(2);					# Give filter time to clean up
	} else {						# Parent process
		exit 0;						# Exit without removing lock, of course
	}
	# Only the child comes here and returns
	&add_log("mailagent continues") if $loglvl > 17;
}

# Report any eval error and returns 1 if error detected.
sub main'load_eval_error {
	package main;
	if ($@ ne '') {
		$@ =~ s/ in file \(eval\) at line \d+//;	# Older perls
		$@ =~ s/ at \(eval \d+\) line \d+\.//;		# Modern perl 5.x
		chop($@);
		&add_log("ERROR $@") if $loglvl > 1;
	}
	$@ eq '' ? 0 : 1;
}

# Computes a new job number
sub main'load_jobnum {
	package main;
	local($job);						# Computed job number
	if (0 != &acs_rqst($cf'seqfile)) {
		$job = "?";
	} else {
		local($njob);
		open(FILE, "$cf'seqfile");
		$njob = int(<FILE>);
		close FILE;
		$njob++;
		open(FILE, ">$cf'seqfile");
		print FILE "$njob\n";
		close FILE;
		$job = "$njob";
		&free_file("$cf'seqfile");
	}
	$job;		# Return job number to be used
}

# Read configuration file (usually in ~/.mailagent)
sub main'load_read_config {
	package cf;
	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 cf'load_parse {
	package cf;
	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 '.'

	# Backward compatibility -- RAM, 2016-09-13

	$biffchars = 'iso-8859-1' unless defined $biffchars;

	# 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{$_}++;
		}
	}

	# Make sure the "biffchars" encoding is known if biff is set.

	if ($biff =~ /^on/i) {
		my $enc = Encode::find_encoding($biffchars);
		unless (ref $enc) {
			&'add_log("WARNING unknown biff charset '$biffchars', using latin1")
				if $'loglvl > 1;
			$biffchars = 'iso-8859-1';
		}
	}

	1;		# Ok
}

#
# 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 main'load_acs_rqst {
	package main;
	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 main'load_acs_locktry {
	package main;
	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 main'load_acs_lock {
	package main;
	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
}

# 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 lock'load_file {
	package lock;
	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 lock'load_base {
	package lock;
	local($file) = @_;
	local($base) = $file =~ m|^.*/(.*)|;
	$base;
}

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

# 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 main'load_free_file {
	package main;
	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 main'load_add_log {
	package main;
	# 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 main'load_stderr_log {
	package main;
	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 main'load_stdout_log {
	package main;
	print STDOUT "$prog_name: $_[0]\n";
	&usrlog'write_log($cf'logfile, $_[0], undef) if defined $cf'logfile;
}

# 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 usrlog'load_new {
	package usrlog;
	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 usrlog'load_delete {
	package usrlog;
	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'load_usr_log {
	package usrlog;
	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 usrlog'load_write_log {
	package usrlog;
	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;
	}
}

# Make sure lock lasts for a reasonable time
sub main'load_checklock {
	package main;
	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;
		}
	}
}

# The following subroutine is called whenever a new rule input is needed.
# It returns that new line or a null string if end of file has been reached.
sub main'load_read_filerule {
	package main;
	<RULES>;					# Read a new line from file
}

# The following subroutine is called in place of read_rule when rules are
# coming from the command line via @Linerules.
sub main'load_read_linerule {
	package main;
	$.++;						# One more line
	shift(@Linerules);			# Read a new line from array
}

# Assemble a whole rule in one line and return it. The end of a line is
# marked by a ';' at the end of an input line.
sub main'load_get_line {
	package main;
	&add_log("IN get_line") if $loglvl > 24;
	local($result) = "";		# what will be returned
	local($in_braces) = 0;		# are we inside braces ?
	for (;;) {
		$_ = &read_rule;		# new rule line (pseudo from compile_rules)
		last unless defined $_;	# end of file reached
		&add_log("READ <<$_>>") if $loglvl > 24;
		s/\n$//;				# don't use chop in case we read from array
		next if /^\s*#/;		# skip comments
		next if /^\s*$/;		# skip empty lines
		s/\s\s+/ /;				# reduce white spaces
		s/#\s.*$//;				# trailing comments skipped (need space after #)
		$result .= $_;
		# Very simple braces handling
		$in_braces += tr/{/{/ - tr/}/}/;
		last if $in_braces <= 0 && /;\s*$/;
	}
	&add_log("OUT get_line: $result") if $loglvl > 24;
	$result;
}

# Get optional mode (e.g. <TEST>) at the beginning of the line and return
# it, or ALL if none was present. A mode can be negated by pre-pending a '!'.
sub main'load_get_mode {
	package main;
	&add_log("IN get_mode") if $loglvl > 24;
	local(*line) = shift(@_);	# edited in place
	local($_) = $line;			# make a copy of original
	local($mode) = "ALL";		# default mode
	s/^\s*<([\s\w,!]+)>// && ($mode = $1);
	$mode =~ s/\s//g;			# no spaces in returned mode
	$line = $_;					# eventually updates the line
	&add_log("OUT get_mode: $mode") if $loglvl > 24;
	$mode;
}

# A selector is either a script or a list of header fields ending with a ':'.
sub main'load_get_selector {
	package main;
	&add_log("IN get_selector") if $loglvl > 24;
	local(*line) = shift(@_);	# edited in place
	local($_) = $line;			# make a copy of original
	local($selector) = "";
	s/^\s*,//;					# remove rule separator
	if (/^\s*\[\[/) {			# detected a script form
		$selector = 'script:';
	} else {
		s/^\s*([^\/,{\n]*(<[\d\s,-]+>)?\s*:)// && ($selector = $1);
	}
	$line = $_;					# eventually updates the line
	&add_log("OUT get_selector: $selector") if $loglvl > 24;
	$selector;
}

# A pattern if either a single word (with no white space) or something
# starting with a / and ending with an un-escaped / followed by some optional
# modifiers.
# Patterns may be preceded by a single '!' to negate the matching value.
sub main'load_get_pattern {
	package main;
	&add_log("IN get_pattern") if $loglvl > 24;
	local(*line) = shift(@_);		# edited in place
	local($_) = $line;				# make a copy of original
	local($pattern) = "";			# the recognized pattern
	local($buffer) = "";			# the buffer used for parsing
	local($not) = '';				# shall boolean value be negated?
	local($script) = 0;				# true if pattern is a script
	s|^\s*||;						# remove leading spaces
	s/^!// && ($not = '!');			# A leading '!' inverts matching status
	if (s|^\[\[([^{]*)\]\]||) {		# pattern is a script
		$pattern = $1;				# get the whole script
		$script++;					# mark it as a script
	} elsif (s|^/||) {				# pattern starts with a /
		$pattern = "/";				# record the /
		while (s|([^/]*/)||) {		# while there is something before a /
			$buffer = $1;			# save what we've been reading
			$pattern .= $1;
			last unless $buffer =~ m|\\/$|;	# finished unless / is escaped
		}
		s/^(\w+)// && ($pattern .= $1);		# add optional modifiers
	} else {								# pattern does not start with a /
		s/([^\s,;{]*)// && ($pattern = $1);	# grab all until next delimiter
	}
	$line = $_;					# eventually updates the line
	$pattern =~ s/\s+$//;		# remove trailing spaces

	# In perl 4.0, we could write /^ram@acri\.fr/, but in perl 5.0, that
	# is not allowed since @ is now interpolated in patterns and strings.
	# In order to let them still write things that way, or escape the @
	# if they don't mind, we replace all un-escaped @ by escaped ones.

	$pattern =~ s/([^\\](\\\\)*)@/$1\\@/g unless $script;

	if ($not && !$pattern) {
		&add_log("ERROR discarding '!' not followed by pattern") if $loglvl;
	} else {
		$pattern = $not . $pattern;
	}
	&add_log("OUT get_pattern: $pattern") if $loglvl > 24;
	$pattern;
}

# Extract the action part from the line (by editing it in place) and return
# the first action encountered. Nesting of {...} blocks may occur.
sub main'load_get_action {
	package main;
	&add_log("IN get_action") if $loglvl > 24;
	local(*line) = shift(@_);	# edited in place
	local($_) = $line;			# make a copy of original
	unless (s/^\s*\{/{/) {
		&add_log("OUT get_action (none)") if $loglvl > 24;
		return '';
	}
	local($action) = &action_parse(*_, 0);
	&add_log("ERROR no action, discarding '$_'") if $loglvl && $action eq '';
	$line = $_;					# eventually update the line
	$action =~ s/^\{\s*//;		# remove leading and trailing braces
	$action =~ s/\s*\}$//;
	&add_log("OUT get_action: $action") if $loglvl > 24;
	$action;					# return new action block
}

# Recursively parse the action string and return the parsed portion of the text
# with proper nesting wherever necessary. The string given as parameter is
# edited in place and the remaining is the unparsed part.
sub main'load_action_parse {
	package main;
	local(*_) = shift(@_);		# edited in place
	local($level) = shift(@_);	# recursion level
	&add_log("IN action_parse $level: $_") if $loglvl > 24;
	local($parsed) = '';		# the part we parsed so far
	local($block);				# block recognized
	local($follow);				# recursion string returned

	for (;;) {
		# Go to first un-escaped '{', if possible and save leading string
		# up-to first '{'. Note that any '}' immediately stops scanning.
		s/^(([^\\{}]|\\.)*\{)// && ($parsed .= $1);
		# Go to first un-escaped '}', with any '{' stopping scan.
		$block = '';
		s/^(([^\\{}]|\\.)*\})// && ($block = $1);
		$parsed .= $block;		# block may be empty, or has trailing '}'
		&add_log("action_parse $level: $parsed") if $loglvl > 24;
		if ($parsed =~ s/\{$//) {	# recursion if '{' found
			$follow = &action_parse(*_, $level + 1);
			# If a null string is returned, then no matching '}' was found
			&add_log("WARNING no closing brace (added for you)")
				if $follow eq '' && $loglvl > 5;
			$parsed .= '{' . $follow . '}';
		} elsif (s/^\}//) {		# reached end of a block
			&add_log("WARNING extra closing brace ignored")
				if $level == 0 && $loglvl > 5;
			&add_log("OUT action_parse $level: $parsed") if $loglvl > 24;
			return $parsed;
		} else {
			# Get the whole string until the next '}' and return. If a '{'
			# interposes, the first match will return an empty string. In that
			# case, we continue if we are not at level #0. Otherwise we got the
			# whole action and may return now.
			$block = '';
			s/^(([^\\{}]|\\.)*\})// && ($block = $1);
			if ($block eq '' && $level) {		# Advance until '{'
				s/^(([^\\}]|\\.)*\{)// && ($block = $1);
				$parsed .= $block;
				last if $block eq '';	# Reached the end... prematurely!
				next;
			}
			$block =~ s/\}//;
			&add_log("OUT action_parse $level: $parsed$block") if $loglvl > 24;
			return $parsed . $block;
		}
	}

	&add_log("WARNING mismatched braces in rule file") if $loglvl > 5;
	&add_log("OUT action_parse $level: $parsed <EOF>") if $loglvl > 24;
	return $parsed;
}

# Parse the mail and fill-in the Header associative array. The special entries
# All, Body and Head respectively hold the whole message, the body and the
# header of the message.
sub main'load_parse_mail {
	package main;
	local($file_name) = shift(@_);	# Where mail is stored ("" for stdin)
	local($head_only) = shift(@_);	# Optional parameter: parse only header
	local($last_header) = "";		# Name of last header (for continuations)
	local($first_from) = "";		# The first From line in mails
	local($lines) = 0;				# Number of lines in the body
	local($length) = 0;				# Length of body, in bytes
	local($last_was_nl) = 1;		# True when last line was a '\n' (1 for EOH)
	local($fd) = STDIN;				# Where does the mail come from ?
	local($field, $value);			# Field and value for current line
	local($_);
	local($preext) = 0;
	local($added) = 0;
	local($curlen) = 0;
	undef %Header;					# Reset the whole structure holding message

	if ($file_name ne '') {			# Mail spooled in a file
		unless(open(MAIL, $file_name)) {
			&add_log("ERROR cannot open $file_name: $!");
			return;
		}
		$fd = MAIL;
		$preext = -s MAIL;
	}
	$Userpath = "";					# Reset path from possible previous @PATH 

	# Pre-extend 'All', 'Body' and 'Head'
	if ($preext <= 0) {
		$preext = 100_000;
		&add_log("preext uses fixed value ($preext)") if $loglvl > 19;
	} else {
		&add_log("preext uses file size ($preext)") if $loglvl > 19;
	}
	$preext += 500;					# Extra room for From --> >From, etc...

	$Header{'All'} = ' ' x $preext;
	$Header{'Body'} = ' ' x $preext;
	$Header{'Head'} = ' ' x 500;
	$Header{'All'} = '';
	$Header{'Body'} = '';
	$Header{'Head'} = '';

	&add_log ("parsing mail" . ($head_only ? " header" : "")) if $loglvl > 18;
	while (<$fd>) {
		$added += length($_);

		# If string extension goes beyond the pre-allocated space, re-extend
		# by a big amount instead of letting perl realloc space.
		if ($added > $preext) {
			$curlen = length($Header{'All'});
			&add_log ("extended after $curlen bytes") if $loglvl > 19;
			$Header{'All'} .= ' ' x $preext;
			substr($Header{'All'}, $curlen) = '';
			$curlen = length($Header{'Body'});
			$Header{'Body'} .= ' ' x $preext;
			substr($Header{'Body'}, $curlen) = '';
			$added = $added - $preext;
		}

		$Header{'All'} .= $_;
		if (1../^$/) {						# EOH is a blank line
			next if /^$/;					# Skip EOH marker
			chop;

			if (/^\s/) {					# It is a continuation line
				my $val = $_;
				$val =~ s/^\s+/ /;			# Swallow multiple spaces
				$Header{$last_header} .= $val if $last_header ne '';
				&add_log("WARNING bad continuation in header, line $.")
					if $last_header eq '' && $loglvl > 4;
			} elsif (($field, $value) = /^([!-9;-~\w-]+):\s*(.*)/) {
				# We found a new header field (i.e. it is not a continuation).
				# Guarantee only one From: header line. If multiple From: are
				# found, keep the last one.
				# Multiple headers like 'Received' are separated by a new-
				# line character. All headers end on a non new-line.
				# Case is normalized before recording, so apparently-to will
				# be recorded as Apparently-To but header is not changed.
				$last_header = &header'normalize($field);	# Normalize case
				if ($last_header eq 'From' && defined $Header{$last_header}) {
					$Header{$last_header} = $value;
					&add_log("WARNING duplicate From in header, line $.")
						if $loglvl > 4;
				} elsif ($Header{$last_header} ne '') {
					$Header{$last_header} .= "\n" . $value;
				} else {
					$Header{$last_header} .= $value;
				}
			} elsif (/^From\s+(\S+)/) {		# The very first From line
				$first_from = $1;
			} else {
				# Did not identify a header field nor a continuation
				# Maybe there was a wrong header split somewhere?
				# If we did not encounter a header yet, we're seeing garbage.
				if ($last_header eq '') {
					&add_log("ERROR ignoring header garbage, line $.: $_")
						if $loglvl > 1;
					next;					# Skip insertion to 'Head'
				} else {
					&add_log("WARNING ".
						"faking continuation for $last_header, line $."
					) if $loglvl > 4;
					$_ = " " . $_;			# Patch line for 'Head'
					$Header{$last_header} .= $_;
				}
			}

			$Header{'Head'} .= $_ . "\n";	# Record line in header

		} else {
			last if $head_only;		# Stop parsing if only header wanted
			$lines++;								# One more line in body
			$length += length($_);					# Update length of message
			# Protect potentially dangerous lines when asked to do so
			# From could normally be mis-interpreted only after a blank line,
			# but some "broken" User Agents also look for them everywhere...
			# That's where fromall must be set to ON to escape all of them.
			s/^From(\s)/>From$1/ if $last_was_nl && $cf'fromesc =~ /on/i;
			$last_was_nl = /^$/ || $cf'fromall =~ /on/i;
			$Header{'Body'} .= $_;
		}
	}
	close MAIL if $file_name ne '';
	&header_prepend("$FAKE_FROM\n") unless $first_from;
	&body_check unless $head_only;
	&header_check($first_from, $lines);	# Sanity checks
}

# Parse given header string into the supplied hash ref.
# Do that silently if told to do so via $silent.
# Returns: the value of the first From line, and fills %$href.
sub main'load_header_parse {
	package main;
	my ($headers, $href, $silent) = @_;
	# There is some code duplication with parse_mail() above
	local($first_from);						# First From line records sender
	local($last_header);					# Current normalized header field
	local($value);							# Value of current field
	my $missing_warned = 0;
	foreach (split(/\n/, $headers)) {
		if (/^\s/) {					# It is a continuation line
			s/^\s+/ /;					# Swallow multiple spaces
			$href->{$last_header} .= $_ if $last_header ne '';
		} elsif (/^([!-9;-~\w-]+):\s*(.*)/) {	# We found a new header
			$value = $2;				# Bug in perl 4.0 PL19
			$last_header = &header'normalize($1);
			$missing_warned = 0;
			# Multiple headers like 'Received' are separated by a new-
			# line character. All headers end on a non new-line.
			if ($href->{$last_header} ne '') {
				$href->{$last_header} .= "\n$value";
			} else {
				$href->{$last_header} .= $value;
			}
		} elsif (/^From\s+(\S+)/) {		# The very first From line
			$first_from = $1;
		} else {
			# Did not identify a header field nor a continuation
			# Maybe there was a wrong header split somewhere?
			if ($last_header eq '') {
				&add_log("ERROR ignoring leading header garbage: $_")
					if $loglvl > 1 && !$silent;
			} else {
				&add_log("ERROR missing continuation for $last_header: $_")
					if !$missing_warned && $loglvl > 1 && !$silent;
				$href->{$last_header} .= " " . $_;
				$missing_warned++;
			}
		}
	}
	return $first_from;
}

# Compute amount of lines listed in the header
# We do NOT use $Header{'Lines'} here since this is a filtering value which
# represents the number of lines in the *decoded* body, not the physical
# number of lines in the message which the Lines header in the message is
# supposed to represent.
sub main'load_header_lines {
	package main;
	my ($lines) = $Header{'Head'} =~ /^Lines:\s*(\d+)/im;
	return $lines;
}

# Set number of Lines in body and body Length to reflect reality
# If the headers were physically present in the message, they are
# updated as well.
sub main'load_header_update_size {
	package main;
	# Cannot trust %Header to indicate whether the headers were present
	# since we add these entries in any case...  Use a crude way to detect
	# presence then...
	my $had_lines = $Header{'Head'} =~ /^Lines:/im;
	my $had_length = $Header{'Head'} =~ /^Length:/im;

	my $lines = $Header{'Body'} =~ tr/\n/\n/;
	my $length = length($Header{'Body'});
	my $is_mime = exists $Header{'Mime-Version'};

	if ($had_lines && $lines != &header_lines) {
		alter_header("Lines", $HD_STRIP);
		header_append(header'format("Lines: $lines\n"));
	}

	# For filtering, use the *decoded* body!
	$Header{'Lines'} = ${$Header{'=Body='}} =~ tr/\n/\n/;
	$Header{'Length'} = length ${$Header{'=Body='}};

	if ($had_length) {
		alter_header("Length", $HD_STRIP);
		&add_log("NOTICE stripped non-RFC822 Length header") if $loglvl > 5;
	}

	if ($is_mime && exists $Header{'Content-Length'}) {
		my $clen = $Header{'Content-Length'};
		if ($clen != $length) {
			alter_header("Content-Length", $HD_STRIP);
			header_append(header'format("Content-Length: $length\n"));
			$Header{'Content-Length'} = $length;
			&add_log("NOTICE adjusted Content-Length from $clen to $length")
				if $loglvl > 5;
		}
	}

	if (!$is_mime && exists $Header{'Content-Length'}) {
		alter_header("Content-Length", $HD_STRIP);
		delete $Header{'Content-Length'};
		&add_log("NOTICE stripped Content-Length header in non-MIME message")
			if $loglvl > 5;
	}
}

# Check whether the body we got back has received a transfer encoding.
# If it has and we know about that transfer encoding, decode it.
# We make sure the "=Body=" header key is a reference to the decoded body:
# it is either a reference to $Header{'Body'} when we leave it as-is, or
# a reference to a newly allocated scalar.
sub main'load_body_check {
	package main;
	$Header{'=Body='} = \$Header{'Body'};
	my $encoding = lc($Header{'Content-Transfer-Encoding'});
	my %decode = map { $_ => 1 } qw(base64 quoted-printable);
	unless (exists $Header{'Mime-Version'}) {
		return unless length $encoding;
		if ($decode{$encoding}) {
			&add_log("WARNING ignoring $encoding body transfer encoding")
				if $loglvl > 3;
		} else {
			alter_header("Content-Transfer-Encoding", $HD_STRIP);
			delete $Header{'Content-Transfer-Encoding'};
			&add_log("NOTICE stripped $encoding encoding in non-MIME message")
				if $loglvl > 6;
		}
		return;
	}
	my %enc = map { $_ => 1 } qw(7bit 8bit binary base64 quoted-printable);
	$encoding =~ s/\s*;$//;		# Strip (wrong) spurious trailing separator
	if (length $encoding) {
		&'add_log("WARNING unknown content transfer encoding \"$encoding\"")
			if $'loglvl > 5 && !$enc{$encoding};
	}
	return unless $decode{$encoding};
	my @data = split(/\r?\n/, $Header{'Body'});
	my $error;
	my $output;
	if ($encoding eq "base64") {
		base64'reset(length $Header{'Body'});
		foreach my $d (@data) {
			base64'decode($d);
		}
		$error = base64'error_msg();
		$output = base64'output();
	} elsif ($encoding eq "quoted-printable") {
		qp'reset(length $Header{'Body'});
		foreach my $d (@data) {
			qp'decode($d);
		}
		$error = qp'error_msg();
		$output = qp'output();
	}
	if (length $error) {
		&'add_log("WARNING could not decode $encoding body: $error")
			if $'loglvl > 5;
	} else {
		if ($'loglvl > 9) {
			my $len = length $$output;
			&'add_log("decoded $encoding body into $len bytes");
		}
		$Header{'=Body='} = $output;		# Reference
	}
	&header_update_size;
}

# Force recoding of the body to a new encoding.
# The $Header{'Body'} variable is supposed to hold the decoded version.
sub main'load_body_recode_with {
	package main;
	my ($encoding) = @_;
	$Header{'=Body='} = \$Header{'Body'};	# The decoded version!
	my @data = split(/\r?\n/, $Header{'Body'});
	my $error;
	my $output;
	if ($encoding eq "base64") {
		base64'reset(length($Header{'Body'}) * 4/3);
		foreach my $d (@data) {
			base64'encode($d);
		}
		$error = base64'error_msg();
		$output = base64'output();
	} elsif ($encoding eq "quoted-printable") {
		qp'reset(length $Header{'Body'} * 1.1);
		foreach my $d (@data) {
			qp'encode($d);
		}
		$error = qp'error_msg();
		$output = qp'output();
	}
	if (length $error) {
		&'add_log("WARNING could not recode $encoding body: $error")
			if $'loglvl > 5;
	} else {
		if ($'loglvl > 9) {
			my $len = length $$output;
			&'add_log("recoded $encoding body into $len bytes") if $'loglvl > 7;
		}
		delete $Header{'Body'};		# $Header{'=Body='} ref still points to it
		$Header{'Body'} = $$output;	# Transfer-Encoded version of the body
		# The body changed, must update the "All" key...
		$Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'};
		&header_update_size;
	}
}

# When coming from a feeback routine such as PASS, we have a new body that
# maybe we need to recode to match the original encoding...
sub main'load_body_recode {
	package main;
	$Header{'=Body='} = \$Header{'Body'};	# The decoded version!
	my $encoding = lc($Header{'Content-Transfer-Encoding'});
	return unless length $encoding;
	unless (exists $Header{'Mime-Version'}) {
		&add_log("WARNING not recoding body in $encoding: no MIME header")
			if $loglvl > 3;
		alter_header("Content-Transfer-Encoding", $HD_STRIP);
		delete $Header{'Content-Transfer-Encoding'};
		return;
	}
	my %recode = map { $_ => 1 } qw(base64 quoted-printable);
	return unless $recode{$encoding};
	body_recode_with($encoding);
}

# When coming back from a FEED, check whether the content transfer encoding
# is suitable and replace it with the optimal one if not.
# Upon entry, we expect =Body= to point to the decoded versions and headers
# of the message to have been parsed in %Header (read: properly resync-ed).
# Both the header and the body of the message are updated if the encoding
# is changed.
# Return TRUE if body was recoded (implying caller should RESYNC the headers).
sub main'load_body_recode_optimally {
	package main;
	my $encoding = lc($Header{'Content-Transfer-Encoding'}) || "none";
	my $optimal = best_body_encoding($Header{'=Body='});
	my %encoded = map { $_ => 1 } qw(base64 quoted-printable);
	my $recoded = 0;
	if ($optimal ne $encoding) {
		&add_log("converting body encoded with $encoding to optimal $optimal")
			if $'loglvl > 7;
		if ($encoded{$optimal}) {
			$Header{'Body'} = ${$Header{'=Body='}};
			$Header{'=Body='} = \$Header{'Body'};	# The decoded version!
			body_recode_with($optimal);
		}
		alter_header("Content-Transfer-Encoding", $HD_STRIP);
		header_append(header'format("Content-Transfer-Encoding: $optimal\n"));
		$recoded = 1;
	}
	return $recoded;
}

# Whenever we got a new set of headers in $Header{'Head'} we need to ensure
# the new vision is consistent with the body encoding.  If they strip the
# Content-Transfer-Encoding header for instance, we have to use the old
# decoded version we had instead of the original body.
# If they add a Content-Transfer-Encoding header, we have to recode the body!
sub main'load_header_check_body_encoding {
	package main;
	my $plain = \$Header{'Body'} == $Header{'=Body='};	# No encoding
	if ($plain && $Header{'Head'} !~ /^Content-Transfer-Encoding:/mi) {
		# No encoding and no header indicating a transfer encodig...
		return;		# Nothing to change
	}
	my %new;
	header_parse($Header{'Head'}, \%new, 1);	# Silently parse new headers
	my $encoding = $Header{'Content-Transfer-Encoding'} || "none";
	my $new_encoding = lc($new{'Content-Transfer-Encoding'}) || "none";
	return if lc($encoding) eq $new_encoding;	# No change occurred

	&add_log(
		"WARNING body transfer encoding changed from $encoding to $new_encoding"
	) if $loglvl > 3;


	$Header{'Body'} = ${$Header{'=Body='}};		# Restore decoded version
	my %encode = map { $_ => 1 } qw(base64 quoted-printable);
	unless ($encode{$new_encoding}) {
		$Header{'=Body='} = \$Header{'Body'};
		return;
	}
	body_recode_with($new_encoding);			# Then re-encode it

	# At some point a RESYNC will be needed, caller will decide when it is
	# necessary to do it.
}

# Now do some sanity checks:
# - if there is no From: header, fill it in with the first From
# - if there is no To: but an Apparently-To:, copy it also as a To:
# - if an Envelope field was defined in the header, override it (sorry)
# - likewise for Relayed, which is the list of relaying hosts, first one first.
#
# We guarantee the following header entries (to select on in rules):
#   Envelope:     the actual sender of the message, empty if cannot compute
#   From:         the value of the From field
#   To:           to whom the mail was sent
#   Lines:        number of lines in the message (*decoded* version)
#   Length:       number of bytes in the message body (*decoded* version)
#   Relayed:      the list of relaying hosts deduced from Received: lines
#   Reply-To:     the address we may use to reply
#   Sender:       the value of the Sender field, same as From usually
#
# NB: When the $lines parameter is set, we parsed the whole message initially.
# When it is undef, we're resyncing, possibly after an external messaging of
# the message.
sub main'load_header_check {
	package main;
	local($first_from, $lines) = @_;	# First From line, number of lines
	unless (defined $Header{'From'}) {
		&add_log("WARNING no From: field, assuming $first_from") if $loglvl > 4;
		$Header{'From'} = $first_from;
		# Fake a From: header line unless prevented to do so. That way, when
		# saving in an MH or MMDF folder (where the leading From is stripped),
		# the user will still be able to identify the source of the message!
		if ($first_from && $cf'fromfake !~ /^off/i) {
			&add_log("NOTICE faking a From: header line") if $loglvl > 5;
			&header_append("From: $first_from\n");
		}
	}

	# There is usually one Apparently-To line per address. Remove all new lines
	# in the header line and replace them with ','. Likewise for To: and Cc:.
	# although it is far less likely to occur.
	foreach $field ('Apparently-To', 'To', 'Cc') {
		$Header{$field} =~ s/\n/,/gm;	# Remove new-lines
		$Header{$field} =~ s/,$/\n/m;	# Restore last new-line
	}

	# If no To: field, then maybe there is an Apparently-To: instead. If so,
	# make them identical. Otherwise, assume the mail was directed to the user.
	#
	# This changes the way filtering is done, so it's not always a good idea
	# to do it. Some people may want to explicitely check that there is no
	# To: line, but if we fake one, they'll never know. So check for tofake,
	# and if OFF, don't do anything.
	unless ($cf'tofake =~ /^off/i) {
		if (!$Header{'To'} && $Header{'Apparently-To'}) {
			$Header{'To'} = $Header{'Apparently-To'};
		}
		unless ($Header{'To'}) {
			&add_log("WARNING no To: field, assuming $cf'user") if $loglvl > 4;
			$Header{'To'} = $cf'user;
		}
	}

	# Update length information
	# No warning is emitted unless $lines was defined, indicating initial
	# parsing of the message we get.
	my $length = $Header{'Content-Length'};
	&header_update_size;		# Update number of lines and length...
	my $count = &header_lines;
	&add_log("NOTICE adjusted number of lines from $lines to $count")
		if $loglvl > 5 &&
			defined($lines) && defined($count) && $count != $lines;
	$count = $Header{'Content-Length'};
	&add_log("NOTICE adjusted Content-Length from $length to $count")
		if $loglvl > 5 && defined($lines) && $count != $length;

	# If there is no Reply-To: line, then take the address in From, if any.
	# Otherwise use the address found in the return-path
	if (!$Header{'Reply-To'}) {
		local($tmp) = (&parse_address($Header{'From'}))[0];
		$Header{'Reply-To'} = $tmp if $tmp ne '';
		$Header{'Reply-To'} = (&parse_address($Header{'Return-Path'}))[0]
			if $tmp eq '';
	}

	# Unless there is already a sender line, fake one using From field
	if (!$Header{'Sender'}) {
		$Header{'Sender'} = $first_from;
		$Header{'Sender'} = $Header{'From'} unless $first_from;
	}

	# Now override any Envelope header and grab it from the first From field
	# If such a field was defined in the message header, then sorry but it
	# was a mistake: RFC 822 doesn't define it, so it should have been
	# an X-Envelope instead.

	$Header{'Envelope'} = $first_from;

	# Finally, compute the list of relaying hosts. The first host which saw
	# this message comes first, the last one (normally the machine receiving
	# the mail) coming last.

	unless ($Header{'Relayed'} = &relay_list) {
		&add_log("NOTICE no valid Received: indication") if $loglvl > 6;
	}
}

# Compute the relaying hosts by looking at the Received: lines and parsing
# them to deduce which host saw and relayed the message. We parse things
# like this:
#
#	Received: from host1 (host2 [xx.yy.zz.tt]) by host3
#	Received: from host1 ([xx.yy.zz.tt]) by host3
#	Received: from ?host1? ([xx.yy.zz.tt]) by host3
#	Received: from host1 by host3
#	Received: from (host2 [xx.yy.zz.tt]) by host3
#	Received: from (host1) [xx.yy.zz.tt] by host3
#	Received: from host1 [xx.yy.zz.tt] by host3
#	Received: from host2 [xx.yy.zz.tt] (host1) by host3
#	Received: from (user@host1) by host3
#
# The host2, when present, is the reverse DNS mapping of the IP address.
# It can be different from host1 in case of local /etc/host aliasing for
# instance. This is used when present, otherwise we must trust host1.
# The host3 information is never used here. It is possible for host1 to
# be a simple IP address [xx.yy.zz.tt].
#
# The latest Received: line inserted in the header is the one added by
# the host receiving the message. For local messages, it may be the
# only line present. It is the only line for which host3 is used, since
# it is probable we can trust our local delivery mailer.
# 
# The returned comma-separated list is sorted to have the first relaying
# host come first (whilst Received headers are normally prepended, which
# yields a reverse host chain).
sub main'load_relay_list {
	package main;
	local(@received) = split(/\n/, $Header{'Received'});
	return '' unless @received;
	local(@hosts);					# List of relaying hosts
	local($host, $real);
	local($islast) = 1;				# First line we see is the "last" inserted
	local($received);				# Received line, verbatim
        # The regexp /\.X$/i where X is any of offical top level domains at
        # http://data.iana.org/TLD/tlds-alpha-by-domain.txt on 15 Aug 2006 plus the
        # extra domain "private".
        # The regexp is the translation into Perl syntax of the result of calling Emacs's `regexp-opt'
        # on the list of acceptable TLDs.
        local($tlds_rx) = qr'\.A(?:ERO|RPA|[C-GIL-OQ-UWXZ])|B(?:IZ|[ABD-JMNORSTVWYZ])|C(?:AT|O(?:M|OP)|[ACDF-IK-ORUVXYZ])|D[EJKMOZ]|E(?:DU|[CEGR-U])|F[IJKMOR]|G(?:OV|[ABD-ILMNP-UWY])|H[KMNRTU]|I(?:N(?:FO|T)|[DEL-OQ-T])|J(?:OBS|[EMOP])|K[EGHIMNRWYZ]|L[ABCIKR-VY]|M(?:IL|OBI|USEUM|[ACDGHK-Z])|N(?:AME|ET|[ACEFGILOPRUZ])|O(?:M|RG)|P(?:R(?:IVATE|O)|[AE-HK-NRSTWY])|QA|R[EOUW]|S[A-EG-ORTUVYZ]|T(?:RAVEL|[CDFGHJ-PRTVWZ])|U[AGKMSYZ]|V[ACEGINU]|W[FS]|Y[ETU]|Z[AMW]$'i;
	local($i);
	local($_);

	# All the known top-level domains as of 2006-08-15
	# with the addition of "loc", "localdomain" and "private".
	# See http://data.iana.org/TLD/tlds-alpha-by-domain.txt
	my $tlds_re = qr/
		a(?:ero|rpa|[c-gil-oq-uwxz])|
		b(?:iz|[abd-jmnorstvwyz])|
		c(?:at|o(?:m|op)|[acdf-ik-oruvxyz])|
		d[ejkmoz]|
		e(?:du|[cegr-u])|
		f[ijkmor]|
		g(?:ov|[abd-ilmnp-uwy])|
		h[kmnrtu]|
		i(?:n(?:fo|t)|[del-oq-t])|
		j(?:obs|[emop])|
		k[eghimnrwyz]|
		l(?:[abcikr-vy]|o(?:c|caldomain))|
		m(?:il|obi|useum|[acdghk-z])|
		n(?:ame|et|[acefgilopruz])|
		o(?:m|rg)|
		p(?:r(?:ivate|o)|[ae-hk-nrstwy])|
		qa|
		r[eouw]|
		s[a-eg-ortuvyz]|
		t(?:ravel|[cdfghj-prtvwz])|
		u[agkmsyz]|
		v[aceginu]|
		w[fs]|
		y[etu]|
		z[amw]
	/ix;

	for ($i = 0; $i < @received; $i++) {
		$received = $_ = $received[$i];

		# Handle first Received line (the last one added) specially.
		if ($islast) {
			if (
				/\bby\s+(\[\d+\.\d+\.\d+\.\d+\])/i	||
				/\bby\s+([\w-.]+)/i
			) {
				$host = $1;
				$host .= ".$cf::domain"
					if $host =~ /^\w/ && $host !~ /\.$tlds_re$/;
				push(@hosts, $host);
			} else {
				&add_log("WARNING no by in first Received: line '$received'")
					if $loglvl > 4;
			}
			$islast = 0;
		}

		next unless s/^\s*from\s+//i;
		next if s/^by\s+//i;		# Host name missing

		# Look for host1, which must be there somehow since we found a 'from'
		# Some sendmails like to add a leading 'login@' before the address,
		# so strip that out before being fancy...
		# The only case host1 was seen to be missing was when it is replaced
		# by an (host2 [ip]) specification instead.

		s/^\w+\@//;
		# [xx.yy.zz.tt]
		if (s/^(\[\d+\.\d+\.\d+\.\d+\])\s*//) {
			$host = $1;				# IP address [xx.yy.zz.tt]
		}
		# ?xx.yy.zz.tt? ( [XX.YY.ZZ.TT])
		elsif (s/^\?[\d\.]+\?\s*\(\s*(\[\d+\.\d+\.\d+\.\d+\])\s*\)\s*//) {
			$host = $1;
		}
		# foo.domain.com (optional)
		elsif (s/^([\w-.]+)(\(\S+\))?\s*//) {
			$host = $1;				# host name
		}
		# (user@foo.domain.com)
		elsif (s/^\(\w+\@([\w-.]+)\)\s*//) {
			$host = $1;				# host name
		}
		# (foo.domain.com) [xx.yy.zz.tt]
		#  foo.domain.com  [xx.yy.zz.tt]
		elsif (s/^\(?([\w-.]+)\)?\s*\[\d+\.\d+\.\d+\.\d+\]\s*//) {
			$host = $1;				# host name
		}
		# Unrecognized, but starting with a parenthesis, hinting for host2...
		elsif (m/^\(/) {
			$host = undef;			# host1 missing, but host2 should be there
		} else {
			&add_log("WARNING invalid from in Received: line '$received'")
				if $loglvl > 4;
			next;
		}

		# There may be an IP or reverse DNS mapping, which will be used to
		# supersede the current $host if found. Note that some (local) mailers
		# insert host as login@host, so we remove the login part.
		# Also handle things like (really foo.com) or (actually real.host), i.e
		# allow an adjective to qualify the real host name.
		#
		# Note: we don't anchor the match at the beginning of the string
		# since we want to parse the 'user@255.190.143.3' as in:
		#   from foo.net (HELO master.foo.org) (user@255.190.143.3) by bar.net
		# and it may not come first... Later on, we'll remove all remaining
		# leading unrecognized () information.
		#
		# The cryptic regexps below attempt to recognize things like:
		#    (user@foo.domain.com [xx.yy.zz.tt])
		#    (WORD user@foo.domain.com [xx.yy.zz.tt])

		$real = '';
		$real = $1 eq '' ? $2 : $1 if
			s/\(([\w-.@]*)?\s*(\[\d+\.\d+\.\d+\.\d+\])?\)\s*// ||
			s/\(\w+\s+([\w-.@]*)?\s*(\[\d+\.\d+\.\d+\.\d+\])?\)\s*//;
		$real =~ s/^.*\@//;
		$real = '' if $real =~ /^[\d.]+$/;		# A sendmail version number!

		# Supersede the host name computed in the previous parsing only
		# if the "real" host name we attempted to guess is an IP address
		# or looks like a fully qualified domain name.

		$host = $real if $real =~ /\.$tlds_re$/ || $real =~ /^\[[\d.]+\]$/;

		if ($host eq '') {
			&add_log("NOTICE no relaying origin in Received: line '$received'")
				if $loglvl > 6;
			next;
		}

		# If we have not recognized anything above, then we don't want to
		# handle anything between () that may follow the original host name.
		# There are just too many formats out there and we can't definitively
		# parse them all. There may even be multiple such occurrences like:
		#   from foo.net (HELO master.foo.org) (user@255.190.143.3) by bar.net
		# Just skip them.

		s/^\([^)]*\)\s+//g;

		# At this point, we should have a 'by ' string somewhere, or an EOS.
		# We're not checking the 'by' immediately (as in /^by/) because some
		# mailers like inserting comments such as 'with ESMTP' or 'via xyzt'.
		# Also, I have seen stange things like 'from xxx from xxx by yyy'.
		#
		# Otherwise we have an unknown Received line format.
		# This is not as bad as not being able to deduce host1 or host2.
		# The full line is logged, so that we may improve our fuzzy matching
		# policy.
		#
		# Note: the lack of 'by' is only allowed for the first Received line
		# stacked, i.e. the last one we parse here...

		unless (/\s*by\s+/i || /^\s*$/ || $i == $#received) {
			&add_log("weird Received: line '$received'") if $loglvl > 8;
		}

		# Validate the host. It must be either an internet [xx.yy.zz.tt] form,
		# or a domain name. This also skips things like 'localhost'.  We
		# also accept pure xx.yy.zz.tt (i.e. without surrounding brackets)

		unless (
			$host =~ /^\[[\d.]+\]$/							||
			$host =~ /^[\w-.]+\.$tlds_re$/					||
			$host =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/
		) {
			next if $host =~ /^[\w-]+$/;	# No message for unqualified hosts
			&add_log("ignoring bad host $host in Received: line '$received'")
				if $loglvl > 6;
			next;
		}

		push(@hosts, $host);
	}

	# Remove duplicate consecutive hosts in the list, since this is probably
	# an internal relaying (where we don't have real names but only aliases,
	# otherwise the message would have looped forever!) and does not bring
	# us much.

	local($last, $dup);
	local(@unique) = grep(($dup = $last ne $_, $last = $_, $dup), @hosts);

	return join(', ', reverse @unique);
}

# Append given field to the header structure, updating the whole mail
# text at the same time, hence keeping the %Header table.
# The argument must be a valid formatted RFC-822 mail header field.
sub main'load_header_append {
	package main;
	local($hline) = @_;
	$Header{'Head'} .= $hline;
	$Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'};
}

# Prepend given field to the whole mail, updating %Header fields accordingly.
sub main'load_header_prepend {
	package main;
	local($hline) = @_;
	$Header{'Head'} = $hline . $Header{'Head'};
	$Header{'All'} = $hline . $Header{'All'};
}

# Scan the supplied scalar reference (containing a mail body without any
# content transfer encoding) and determine what is the proper encoding
# for that body: "7bit", "quoted-printable" or "base64".
sub main'load_best_body_encoding {
	package main;
	my ($body) = @_;
	my $size = 0;
	my $largest_line = 0;
	my $qp_escaped = 0;
	my $non_7bit = 0;

	foreach my $l (split(/\r?\n/, $$body)) {
		my $len = length($l);
		$size += $len;
		$largest_line = $len if $largest_line < $len;
		$non_7bit += $l =~ tr/[\x80-\xff]/[\x80-\xff]/;
		$non_7bit += $l =~ tr/[\x0]/[\x0]/;	# NUL never allowed in "7bit"
		$l =~ s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])//g;
		$qp_escaped = $len - length($l);
	}

	return "7bit" if $largest_line <= 998 && $non_7bit == 0;

	my $size_qp = $size + 2 * $qp_escaped;
	my $size_base64 = $size * 4 / 3;

	return "base64" if $size_base64 <= $size_qp;
	return "quoted-printable" if $qp_escaped * 8 < $size;	# Less than 1/8th
	return "base64";
}

# Special users. Note that as login name matches are done in a case-insensitive
# manner, there is no need to upper-case any of the followings.
sub main'load_init_special {
	package main;
	%Special = (
		'root', 1,				# Super-user
		'uucp', 1,				# Unix to Unix copy
		'daemon', 1,			# Not a real user, hopefully
		'news', 1,				# News daemon
		'postmaster', 1,		# X-400 mailer-daemon name
		'newsmaster', 1,		# My convention for news administrator--RAM
		'usenet', 1,			# Aka newsmaster
		'mailer-daemon', 1,		# Sendmail
		'mailer-agent', 1,		# NeXT mailer
		'nobody', 1				# Nobody we've heard of
	);
}

# Compute shorthand file name for logging based on the processed file
sub main'load_mail_logname {
	package main;
	my ($file) = @_;
	my ($mfile) = $file =~ m|.*/(.*)|;	# Basename of mail file
	$mfile = $file unless $mfile;		# There was no / in name
	$mfile = '<stdin>' unless $mfile;	# No $file_name if from STDIN
	return $mfile;
}

# Compute file size for logging, if possible (i.e. not reading from STDIN)
sub main'load_mail_logsize {
	package main;
	my ($file) = @_;
	return "" unless length $file;
	my $msize = (stat($file))[7];
	my $size = "";
	my $s = $msize == 1 ? "" : "s";
	$size = " $msize byte$s" if defined $msize;
	return $size;
}

# Parse mail message and apply the filtering rules on it
sub main'load_analyze_mail {
	package main;
	local($file) = shift(@_);	# Mail file to be parsed
	local($mode) = 'INITIAL';	# Initial working mode
	local($wmode) = $mode;		# Needed for statistics routines
	local(%Variable);			# User-defined variables, visible through APPLY

	# Set-up proper environment. Dynamic scoping is used on those variables
	# for the APPLY command (see the &apply function). Note that the $wmode
	# variable is passed to &apply_rules but is local to that function,
	# meaning there is no feedback of the working mode when using APPLY.
	# However, the variables listed below may be probed upon return since they
	# are external to &apply_rules.
	local($ever_matched) = 0;	# Did we ever matched a single saving rule ?
	local($ever_saved) = 0;		# Did we ever saved a message ?
	local($folder_saved) = '';	# Last folder we saved into (full path)

	# Other local variables used only in this function
	local($ever_seen) = 0;		# Did we ever enter seen mode ?
	local($header);				# Header entry name to look for in Header table

	# Reset environment and umask before each new mail processing
	&env'setup;
	umask($env'umask);

	# Log start of processing
	my $mfile = mail_logname($file);
	my $msize = mail_logsize($file);
	add_log("-- HANDLING [$mfile]$msize --") if $loglvl > 8;

	# Parse the mail message in file
	&parse_mail($file);			# Parse the mail and fill-in H tables
	return 1 unless defined $Header{'All'};		# Mail not parsed correctly
	&reception if $loglvl > 8;	# Log mail reception
	&run_builtins;				# Execute builtins, if any

	# Now analyze the mail. If there is already a X-Filter header, then the
	# mail has already been processed. In that case, the default action is
	# performed: leave it in the incomming mailbox with no further action.
	# This should prevent nasty loops.

	&add_log ("analyzing mail") if $loglvl > 18;
	$header = $Header{'X-Filter'};				# Mulitple occurences possible
	if ($header ne '') {						# Hmm... already filtered...
		local(@filter) = split(/\n/, $header);	# Look for each X-Filter
		local($address) = &email_addr;			# Our e-mail address
		local($done) = 0;						# Already processed ?
		local($_);
		foreach (@filter) {						# Maybe we'll find ourselves
			if (/mailagent.*for (\S+)/) {		# Mark left by us ?
				$done = 1 if $1 eq $address;	# Yes, we did that
				# Remove that X-Filter line, LEAVE will add one anyway
				$Header{'Head'} =~ s/^X-Filter:\s*mailagent.*for $address\n//m;
				last;
			}
		}
		if ($done) {			# We already processed that message
			if ($force_seen) {	# They used the -F option
				&add_log("NOTICE already filtered, processing anyway")
					if $loglvl > 5;
			} else {
				&add_log("NOTICE already filtered, entering seen mode")
					if $loglvl > 5;
				$mode = '_SEEN_';	# This is a special mode
			}
			$ever_seen = 1;		# This will prevent vacation messages
			&s_seen;			# Update statistics
		}
	}

	local($lastcmd) = 0;		# Failure status from last command
	&apply_rules($mode, 1);		# Now apply the filtering rules on it.

	# Deal with vacation mode. It applies only on mail not previously seen.
	# The vacation mode must be turned on in the configuration file. The
	# conditions for a vacation message to be sent are:
	#   - Message was directly sent to the user.
	#   - Message does not come from a special user like root.
	#   - Vacation message was not disabled via a VACATION command
	# Note that we use the environment set-up by the last rule we processed.

	if (!$ever_seen && $cf'vacation =~ /on/i && $env'vacation) {
		unless (&special_user) {	# Not from special user and sent to me
			# Send vacation message only once per address per period
			&xeqte("ONCE (%r,vacation,$env'vacperiod) MESSAGE $env'vacfile");
			&s_vacation;		# Message received while in vacation
		}
	}

	# Default action if no rule ever matched. Statistics routines will use
	# our own local $wmode variable.

	unless ($ever_matched) {
		&add_log("NOTICE no match, leaving in mailbox") if $loglvl > 5;
		&xeqte("LEAVE");			# Default action anyway
		&s_default;					# One more application of default rule
	} else {
		unless ($ever_saved) {
			&add_log("NOTICE not saved, leaving in mailbox") if $loglvl > 5;
			&xeqte("LEAVE");		# Leave if message not saved
			&s_saved;				# Message saved by default rule
		}
	}
	&s_filtered($Header{'Length'});		# Update statistics

	&env'cleanup;						# Clean-up the environment
	0;									# Ok status
}

# This is the heart of the mail agent -- Apply the filtering rules
sub main'load_apply_rules {
	package main;
	local($wmode, $stats)= @_;	# Working mode (the mode we start in)
	local($mode);				# Mode (optional)
	local($selector);			# Selector (mandatory)
	local($range);				# Range for selection (optional)
	local($rulentry);			# Entry in rule H table
	local($pattern);			# Pattern for selection, as written in rules
	local($action);				# Related action
	local($last_selector);		# Last used selector
	local($rules);				# A copy of the rules
	local($matched);			# Flag set to true if a rule is matched
	local(%Matched);			# Records the selectors which have been matched
	local($status);				# Status returned by xeqte
	local(@Executed);			# Records already executed rules
	local($selist);				# Key used to detect identical selector lists
	local(%Inverted);			# Records inverted '!' selectors which matched

	# The @Executed array records whether a specified action for a rule was
	# executed. Loops are possible via the RESTART action, and as there is
	# almost no way to exit from such a loop (there is one with FEED and RESYNC)
	# I decided to prohibit them. Hence a given action is allowed to be executed
	# only once during a mail analysis (modulo each possible working mode).
	# For a rule number n, $Executed[n] is a collection of modes in which the
	# rule was executed, comma separated.

	$Executed[$#Rules] = '';		# Pre-extend array

	# Order wrt the one in the rule file is guaranteed. I use a for construct
	# with indexed access to be able to restart from the beginning upon
	# execution of RESTART. This also helps filling in the @Executed array.

	local($i, $j);			# Indices within rule array

	rule: for ($i = 0; $i <= $#Rules; $i++) {
		$j = $i + 1;
		$_ = $Rules[$i];

		# The %Matched array records the boolean value associated with each
		# possible selector. If two identical selector are found, the values
		# are OR'ed (and we stop evaluating as soon as one is true). Otherwise,
		# the values are AND'ed (for different selectors, but all are evaluated
		# in case we later find another identical selectors -- no sort is done).
		# The %Inverted which records '!' selector matches has all the above
		# rules inverted according to De Morgan's Law.

		undef %Matched;							# Reset matching patterns
		undef %Inverted;						# Reset negated patterns
		$rules = $_;							# Work on a copy
		$rules =~ s/^([^{]*)\{// && ($mode = $1);	# First word is the mode
		$rules =~ s/\s*(.*)\}// && ($action = $1);	# Followed by action }
		$mode =~ s/\s*$//;							# Remove trailing spaces
		$rules =~ s/^\s+//;						# Remove leading spaces
		$last_selector = "";					# Last selector used

		# Make sure we are in the correct mode. The $mode variable holds a
		# list of comma-separated modes. If the working mode is found in it
		# then the rules apply. Otherwise, skip them.

		next rule unless &right_mode;		# Skip rule if not in right mode

		# Now loop over all the keys and apply the patterns in turn

		&reset_backref;						# Reset backreferences
		foreach $key (split(/ /, $rules)) {
			$rulentry = $Rule{$key};
			$rulentry =~ s/^\s*([^\/]*:)// && ($selector = $1);
			$rulentry =~ s/^\s*//;
			$pattern = $rulentry;
			if ($last_selector ne $selector) {	# Update last selector
				$last_selector = $selector;
			}
			$selector =~ s/:$//;			# Remove final ':' on selector
			$range = '<1,->';				# Default range
			$selector =~ s/\s*(<[\d\s,-]+>)$// && ($range = $1);

			&add_log ("selector '$selector' on '$range', pattern '$pattern'")
				if $loglvl > 19;

			# Identical (lists of) selectors are logically OR'ed. To make sure
			# 'To Cc:' and 'Cc To:' are correctly OR'ed, the selector list is
			# alphabetically sorted.

			$selist = join(',', sort split(' ', $selector));

			# Direct selectors and negated selectors (starting with a !) are
			# kept separately, because the rules are dual:
			# For normal selectors (kept in %Matched):
			#  - Identical are OR'ed
			#  - Different are AND'ed
			# For inverted selectors (kept in %Inverted):
			#  - Identical are AND'ed
			#  - Different are OR'ed
			# Multiple selectors like 'To Cc' are sorted according to the first
			# selector on the list, i.e. 'To !Cc' is normal but '!To Cc' is
			# inverted.

			if ($selector =~ /^!/) {		# Inverted selector
				# In order to guarantee an optimized AND, we first check that
				# no previous failure has been reported for the current set of
				# selectors.
				unless (defined $Inverted{$selist} && !$Inverted{$selist}) {
					$Inverted{$selist} = &match($selector, $pattern, $range);
				}
			} else {						# Normal selector
				# Here it is the OR which is guaranteed to be optimized. Do
				# not attempt the match if an identical selector already
				# matched sucessfully.
				unless (defined $Matched{$selist} && $Matched{$selist}) {
					$Matched{$selist} = &match($selector, $pattern, $range);
				}
			}
		}

		# Both groups recorded in %Matched and %Inverted are globally AND'ed
		# However, only one match is necessary within %Inverted whilst all
		# must have matched within %Matched...

		$matched = 1;						# Assume everything matched
		foreach $key (keys %Matched) {		# All entries must have matched
			$matched = $Matched{$key} ? 1 : 0;
			&add_log("rule #$j: direct $key " . ($matched ? 'ok' : 'failed'))
				if $loglvl > 19;
			last unless $matched;
		}
		if ($matched) {						# If %Matched failed, all failed!
			foreach $key (keys %Inverted) {	# Only one entry needs to match
				$matched = $Inverted{$key} ? 1 : 0;
				&add_log("rule #$j: neg $key " . ($matched ? 'ok' : 'failed'))
					if $loglvl > 19;
				last if $matched;
			}
		}

		&add_log("matching summary rule #$j: " . ($matched ? 'ok' : 'failed'))
			if $loglvl > 17;

		if ($matched) {						# Execute action if pattern matched
			# Make sure the rule has not already been executed in that mode
			if ($Executed[$i] =~ /,$wmode,/) {
				&add_log("NOTICE loop detected, rule $j, state $wmode")
					if $loglvl > 5;
				last rule;					# Processing ends here
			} else {						# Rule was never executed
				$Executed[$i] = ',' unless $Executed[$i];
				$Executed[$i] .= "$wmode,";
			}
			$ever_matched = 1;				# At least one match
			&add_log("MATCH on rule #$j in mode $wmode") if $loglvl > 8;
			&track_rule($j, $wmode) if $track_all;
			&s_match($j, $wmode) if $stats;	# Record match for statistics

			# By issuing an &env'restore, we make sure any local variable
			# setting done in other rules is not seen by the actions we are
			# about to execute. However, should the action be the last one
			# to be performed, its settings will remain for later perusal
			# by our caller (vacation messages come to mind).

			&env'restore;				# Restore vars set in previous rules
			$status = &xeqte($action);	# Execute actions

			last rule if $status == $FT_CONT;
			$ever_matched = 0;				# No match if REJECT or RESTART
			next rule if $status == $FT_REJECT;
			$i = -1;		# Restart analysis from the beginning ($FT_RESTART)
		}
	}
	($ever_saved, $ever_matched);
}

# Return true if the modes currently specified by the rule (held in $mode)
# are selected by the current mode (in $wmode), meaning the rule has to
# be applied.
sub main'load_right_mode {
	package main;
	local($list) = "," . $mode . ",";
	&add_log("in mode '$wmode' for $mode") if $loglvl > 19;

	# If mode is negated, skip the rule, whatever other selectors may
	# indicate. Thus <ALL, !INITIAL> will not be taken into account if
	# mode is INITIAL, despite the leading ALL. They can be seen as further
	# requirements or restrictions applied to the mode list (like in the
	# sentence "all the listed modes *but* the one negated").

	return 0 if $list =~ /!ALL/;		# !ALL cannot match, ever
	return 0 if $list =~ /,!$wmode,/;	# Negated modes logically and'ed

	# Now strip out all negated modes, and if the resulting string is
	# empty, force a match...

	1 while $list =~ s/,![^,]*,/,/;		# Strip out negated modes
	$list = ',ALL,' if $list eq ',';	# Emtpy list, force a match

	# The special ALL mode matches anything but the other sepcial mode for
	# already filtered messages. Otherwise, direct mode (i.e. non-negated)
	# are logically or'ed.

	if ($list =~ /,ALL,/) {
		return 0 if $wmode eq '_SEEN_' && $list !~ /,_SEEN_,/;
	} else {
		return 0 unless $list =~ /,$wmode,/;
	}

	1;	# Ok, rule can be applied
}

# Return true if the mail was from a special user (root, uucp...) or if the
# mail was not directly mailed to the user (i.e. it comes from a distribution
# list or has bounced somewhere).
sub main'load_special_user {
	package main;
	# Before sending the vacation message, we have to make sure the mail
	# was sent to the user directly, through a 'To:' or a 'Cc:'. Otherwise,
	# it must be from a mailing list or a 'Bcc:' and we don't want to
	# send something back in that case.

	local($matched) = &match_list("To", $cf'user);
	$matched = &match_list("Cc", $cf'user) unless $matched;

	# Try alternate login names, in case they used a company-wide alias like
	# First.Last or simply a plain sendmail alias.

	if (!$matched && $cf'tome ne '') {
		foreach $addr (split(/\s*,\s*/, $cf'tome)) {
			$matched = &match_list('To', $addr);
			$matched = &match_list('Cc', $addr) unless $matched;
			if ($matched) {
				&add_log("mail was sent to alternate $addr") if $loglvl > 8;
				last;
			} else {
				&add_log("mail wasn't sent to alternate $addr") if $loglvl > 12;
			}
		}
	}

	unless ($matched) {
		&add_log("mail was not directly sent to $cf'user") if $loglvl > 8;
		return 1;
	}

	# If there is a Precedence: header set to either 'bulk', 'list' or 'junk',
	# then we do not reply either.
	local($prec) = $Header{'Precedence'};
	if ($prec =~ /^bulk|junk|list/i) {
		&add_log("mail was tagged with a '$prec' precedence") if $loglvl > 8;
		return 1;
	}
	# If there is an RFC-886 Illegal-Object or Illegal-Field header, do not
	# trust the whole header integrity, and therefore do not reply.
	if ($Header{'Illegal-Object'} ne '' || $Header{'Illegal-Field'} ne '') {
		&add_log("mail was received with header errors") if $loglvl > 8;
		return 1;
	}
	# Make sure the mail does not come from a "special" user, as listed in
	# the %Special array (root, uucp...)
	$matched = 0;
	local($matched_login);
	foreach $login (keys %Special) {
		$matched = &match_single("From", $login);
		$matched_login = $login if $matched;
		last if $matched;
	}
	if ($matched) {
		&add_log("mail was from special user $matched_login")
			if $loglvl > 8;
		return 1;
	}
	0;	# Not from special user!
}

# Compare a machine and an e-mail address and return true if the domain
# for that address matches the domain of the machine. We allow an extra
# level of "domain indirection".
sub main'load_fuzzy_domain {
	package main;
	local($first, $fhost) = @_;
	$fhost =~ s/^\S+@([\w-.]+)/$1/;					# Keep hostname part
	$fhost =~ tr/A-Z/a-z/;							# perl4 misses lc()
	$first =~ tr/A-Z/a-z/;
	local(@fhost) = split(/\./, $fhost);
	local(@first) = split(/\./, $first);
	if (@fhost > @first) {
		shift(@fhost);					# Allow extra machine name
	} elsif (@first > @fhost) {
		shift(@first);
	} elsif (@fhost >= 3) {				# Has at least machine.domain.top
		shift(@first);					# Allow server1.domain.top to match
		shift(@fhost);					# server2.domain.top
	}
	$fhost = join('.', @fhost);
	$first = join('.', @first);
	return $fhost eq $first;
}

# Log reception of mail (sender and subject fields). This is mainly intended
# for people like me who parse the logfile once in a while to do more 
# statistics about mail reception. Hence the other distinction between
# original mails and answers.
sub main'load_reception {
	package main;
	local($subject) = $Header{'Subject'};
	local($sender) = $Header{'Sender'};
	local($from) = $Header{'From'};
	&add_log("FROM $from");
	local($faddr) = (&parse_address($from))[0];		# From address
	local($saddr) = '';

	if ($sender ne '') {
		$saddr = (&parse_address($sender))[0];
		&add_log("VIA $sender") if $saddr ne $faddr;
	}

	# Trace relaying hosts as well if the first host is unrelated to sender
	local($relayed) = $Header{'Relayed'};
	local($first) = (split(/,\s+/, $relayed))[0];	# First relaying host
	&add_log("RELAYED $relayed") if $relayed ne '' &&
		!(&fuzzy_domain($first, $saddr) || &fuzzy_domain($first, $faddr));

	if ($subject ne '') {
		if ($subject =~ s/^Re:\s*//) {
			&add_log("REPLY $subject");
		} else {
			&add_log("ABOUT $subject");
		}
	}
	print "-------- From $from\n" if $track_all;
}

# Print match on STDOUT when -t option is used
sub main'load_track_rule {
	package main;
	local($number, $mode) = @_;
	print "*** Match on rule $number in mode $mode ***\n";
	&print_rule($number);
}

# Split the commands and execute them. This function is the main entry point
# for nesting level (e.g. execution of commands from BACK are driven by xeqte).
# We wish to keep track of the execution status of the last command, as does
# the shell with its $? variable. This is done by $lastcmd.
sub main'load_xeqte {
	package main;
	local($line) = shift(@_);		# Commands to execute
	local(@cmd);					# The commands to be ran
	local($status) = $FT_CONT;		# Status returned by run_command
	local($_);

	# Normally, a ';' separates each action. However, an escaped one as in \;
	# must not be taken into account. We also need to escape a single \, in
	# case we want a \ followed by a ; grr...
	$line =~ s/\\\\/\02/g;			# \\ -> ^B
	$line =~ s/\\;/\01/g;			# \; -> ^A
	@cmd = split(/;/, $line);		# Put all commands in an array
	foreach (@cmd) {				# Now restore orginal escaped sequences
		s/\01/;/g;					# ^A -> ;
		s/\02/\\/g;					# ^B -> \
	}

	# Now run each command in turn
	foreach $cmd (@cmd) {
		$status = &run_command($cmd);
		last unless $status == $FT_CONT;
	}

	# Remap $FT_ABORT on $FT_CONT. In effect, we just skipped the remaining
	# commands on the line and act as if they had been executed. This indeed
	# achieves the ABORT command.
	$status = $FT_CONT if $status == $FT_ABORT;
	$status;
}

# Executes a filter command and return continuing status:
#  FT_CONT to continue
#  FT_REJECT if a reject was found
#  FT_RESTART if a restart was found
#  FT_ABORT if an abort was found
sub main'load_run_command {
	package main;
	local($cmd) = @_;				# Command to be run (passed to subroutines)
	local($cmd_name);				# Command name
	local($cont) = $FT_CONT;		# Continue by default
	local($mfile) = mail_logname($file_name);
	&macros_subst(*cmd);			# Macros substitutions
	$cmd =~ s/^\s*//;				# Remove leading spaces
	$cmd =~ s/\s*$//;				# And trailing ones
	return $cont unless $cmd;		# Ignore null instructions
	($cmd_name) = $cmd =~ /^(\w+)/;
	$cmd_name =~ tr/a-z/A-Z/;		# In uppercase from now on
	# In the special mode _SEEN_, only a restricted set of action are allowed
	if ($wmode eq '_SEEN_') {
		if ($Rfilter{$cmd_name}) {
			&add_log("WARNING command $cmd_name not allowed") if $loglvl > 5;
			return $cont;
		}
	}
	&add_log("XEQ ($cmd)") if $loglvl > 10;
	print ">> $cmd\n" if $track_all;		# Option -t
	local($routine) = $Filter{$cmd_name};

	# Unknown commands default to LEAVE if no save have ever been done.
	# Otherwise, they are simply ignored.
	unless ($routine) {
		local($what) = 'defaults to LEAVE';
		$what = 'ignored' if $ever_saved;
		&add_log("ERROR unknown command $cmd_name ($what)")
			if $loglvl > 1;
		$routine = $Filter{'LEAVE'};		# Default action
		return $cont if $ever_saved;		# Command ignored
	}

	# Argument parsing within package opt, defining $opt'sw_i if -i for
	# instance. We first reset previous instances from a former command,
	# then parse it for arguments (if any specified in %Option), updating
	# the command string as needed to remove the options as they are found.
	local($opt) = $Option{$cmd_name};
	local($cms) = $cmd;
	if ($opt) {
		&opt'reset;
		$cms = &opt'parse($cmd, $opt);
	}

	# Call routine to handle the action, passing it a string containing
	# the command arguments, as adjusted by a possible option parsing.
	$cms =~ s/^\w+\s*//;						# Comamnd name stripped
	local($failed) = eval("&$routine(\$cms)");	# Eval traps all fatal errors
	$failed = 1 if &eval_error;					# Make sure eval worked

	&opt'restore if $opt;		# Restore options, in case of recursion

	# If command does not belong to the set of those who do not modify the
	# last execution status recorded, then update $lastcmd with the failure
	# status.
	$lastcmd = $failed unless $Nostatus{$cmd_name};

	# Update statistics
	unless ($failed) {
		&s_action($cmd_name, $wmode);
	} else {
		&s_failed($cmd_name, $wmode);
	}
	$cont;				# Continue status
}

# Each filter command is handled by a specific function. The Filter array
# maps an action name to a subroutine, while the Rfilter array lists the
# authorized actions in the special mode _SEEN_ (used when a mail already
# filtered is processed).
# The %Nostatus array records the commands which do not modify the execution
# status recorded by the last command. Typically, those are commands which can
# never fail.
sub main'load_init_filter {
	package main;
	%Filter = (
		'ABORT', 'run_abort',		# Aborts application of filtering rules
		'AFTER', 'run_after',		# Records callout action
		'ANNOTATE', 'run_annotate',	# Add new field into header
		'APPLY', 'run_apply',		# Apply alternate rule file on message
		'ASSIGN', 'run_assign',		# Assign value to variable
		'BACK', 'run_back',			# Eval feedback
		'BEEP', 'run_beep',			# Change value of %b escape when biffing
		'BEGIN', 'run_begin',		# Enter in a new state
		'BIFF', 'run_biff',			# Turn biffing on/off dynamically
		'BOUNCE', 'run_bounce',		# Bounce message
		'DO', 'run_do',				# Call perl routine directly
		'DELETE', 'run_delete',		# Throw mail away, explicitely
		'FEED', 'run_feed',			# Feed back mail through program
		'FORWARD', 'run_forward',	# Forward mail
		'GIVE', 'run_give',			# Give body to command
		'KEEP', 'run_keep',			# Keep only the listed header fields
		'LEAVE', 'run_leave',		# Saving in incomming mailbox
		'MACRO', 'run_macro',		# Define a user macro
		'MESSAGE', 'run_message',	# Send a vacation-like file
		'NOP', 'run_nop',			# No operation
		'NOTIFY', 'run_notify',		# Notify reception of message
		'ON', 'run_on',				# On day control
		'ONCE', 'run_once',			# Once control
		'PASS', 'run_pass',			# Pass body to program with feedback
		'PERL', 'run_perl',			# Perform actions from within a perl script
		'PIPE', 'run_pipe',			# Pipe message to specified command
		'POST', 'run_post',			# Post mail to the net
		'PROCESS', 'run_process',	# Mailagent processing
		'PROTECT', 'run_protect',	# Change default folder protection mode
		'PURIFY', 'run_purify',		# Purify header through a program
		'QUEUE', 'run_queue',		# Queue mail
		'RECORD', 'run_record',		# Record message in history
		'REJECT', 'run_reject',		# Reject
		'REQUIRE', 'run_require',	# Load perl code
		'RESTART', 'run_restart',	# Restart
		'RESYNC', 'run_resync',		# Resynchronizes the header
		'RUN', 'run_run',			# Run specified program
		'SAVE', 'run_save',			# Save in a folder
		'SELECT', 'run_select',		# Time selection control
		'SERVER', 'run_server',		# Server processing
		'SPLIT', 'run_split',		# Split digest message
		'STORE', 'run_store',		# Save and leave copy in mailbox
		'STRIP', 'run_strip',		# Strip some header lines
		'SUBST', 'run_subst',		# Substitution on variable
		'TR', 'run_tr',				# Translation on variable
		'UMASK', 'run_umask',		# Set new umask
		'UNIQUE', 'run_unique',		# Delete message if already in history
		'VACATION', 'run_vacation',	# Allow or forbid vacation messages
		'WRITE', 'run_write',		# Write mail in folder
	);
	# Option string for &opt'get parsing (syntax similar to getopt)
	%Option = (
		'ABORT',	'ft',
		'AFTER',	'acns',
		'ANNOTATE',	'du',
		'BEEP',		'l',
		'BEGIN',	'ft',
		'BIFF',		'l',
		'FEED',		'be',
		'MACRO',	'rdp',
		'NOP',		'tf',
		'PIPE',		'b',
		'POST',		'lb',
		'PROTECT',	'lu',
		'RECORD',	'acr',
		'REJECT',	'ft',
		'RESTART',	'ft',
		'SERVER',	'd:t',
		'SPLIT',	'adeiw',
		'UMASK',	'l',
		'UNIQUE',	'acr',
		'VACATION',	'l',
	);
	# Restricted filter actions: the commands listed below cannot be
	# executed in the special seen mode (in order to avoid loops).
	%Rfilter = (
		'BACK', 1,
		'BOUNCE', 1,
		'DO', 1,
		'FEED', 1,
		'FORWARD', 1,
		'GIVE', 1,
		'NOTIFY', 1,
		'PASS', 1,
		'PIPE', 1,
		'POST', 1,
		'PURIFY', 1,
		'QUEUE', 1,
		'RUN', 1,
	);
	# The following commands do not modify the last status recorded.
	%Nostatus = (
		'ABORT', 1,
		'ASSIGN', 1,
		'BEEP', 1,
		'BIFF', 1,
		'BEGIN', 1,
		'KEEP', 1,
		'MACRO', 1,
		'PROTECT', 1,
		'REJECT', 1,
		'RESTART', 1,
		'RESYNC', 1,
		'STRIP', 1,
		'UMASK', 1,
		'VACATION', 1,
	);
}

# Run the PROCESS command
sub main'load_run_process {
	package main;
	if (0 != &process) {
		&add_log("ERROR while processing [$mfile]--queing it") if $loglvl;
		&queue_mail($file_name, 'fm');
		return 1;
	}
	&add_log("PROCESSED [$mfile]") if $loglvl > 8;
	0;
}

# Run the SERVER command
sub main'load_run_server {
	package main;
	&cmdenv'inituid;				# Initialize server session environment
	&cmdserv'trusted if $opt'sw_t;	# Server runs in trusted mode
	&cmdserv'disable($opt'sw_d) if $opt'sw_d;	# Disable commands for this run
	local(@body) = split(/\n/, $Header{'Body'});
	local($failed) = &cmdserv'process(*body);
	unless ($failed) {
		&add_log("SERVED [$mfile]") if $loglvl > 8;
	} else {
		&add_log("ERROR unable to serve [$mfile]--discarded") if $loglvl;
	}
	$failed;
}

# Run the LEAVE command
sub main'load_run_leave {
	package main;
	local($mbox, $failed) = &leave;
	unless ($failed) {
		&add_log("LEFT [$mfile] in mailbox") if $loglvl > 2;
	}
	# Even if it failed, mark it as saved anyway, as the default action would
	# be a saving in mailbox and there is little chance another attempt would
	# succeed while this one failed.
	$ever_saved = 1;		# At least we tried to save it
	$failed;
}

# Run the SAVE command
sub main'load_run_save {
	package main;
	local($folder) = @_;	# Folder where message should be saved
	&save_message($folder);
}

# Run the STORE command
sub main'load_run_store {
	package main;
	local($folder) = @_;	# Folder where message should be saved
	local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND);
	unless ($failed) {
		$ever_saved = 1;			# We were able to save it
		($mbox, $failed) = &leave;
		unless ($failed) {
			&add_log("STORED [$mfile] in $log_message") if $loglvl > 2;
		} else {
			&add_log("WARNING only SAVED [$mfile] in $log_message")
				if $loglvl > 1;
			return 1;
		}
	} else {
		($mbox, $failed) = &leave;
		unless ($failed) {
			$ever_saved = 1;			# We were able to save it
			&add_log("WARNING only LEFT [$mfile] in mailbox")
				if $loglvl > 1;
		}
	}
	$failed;
}

# Run the WRITE command
sub main'load_run_write {
	package main;
	local($folder) = @_;	# Folder where message should be saved
	local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_REMOVE);
	unless ($failed) {
		&add_log("WROTE [$mfile] in $log_message") if $loglvl > 2;
		$ever_saved = 1;			# We were able to save it
	}
	$failed;
}

# Run the DELETE command
sub main'load_run_delete {
	package main;
	&add_log("DELETED [$mfile]") if $loglvl > 2;
	$ever_saved = 1;		# User chose to discard it, it counts as a save
	0;
}

# Run the MACRO command
sub main'load_run_macro {
	package main;
	local($args) = @_;		# Get command arguments
	local($name, $action) = &macro($args);	# Perform the command
	&add_log("MACRO [$mfile] $name $action") if $loglvl > 7;
	0;	# Never fails
}

# Run the MESSAGE command
sub main'load_run_message {
	package main;
	local($msg) = @_;		# Vacation message location
	$msg =~ s/~/$cf'home/g;					# ~ substitution
	local($failed) = &message($msg);
	unless ($failed) {
		$msg = &tilda($msg);				# Replace the home directory by ~
		&add_log("MESSAGE $msg for [$mfile]") if $loglvl > 2;
	}
	$failed;
}

# Run the NOTIFY command
sub main'load_run_notify {
	package main;
	local($args) = @_;
	local(@args) = split(' ', $args);
	local($msg) = shift(@args);				# First argument is message text
	$msg =~ s/~/$cf'home/g;					# ~ substitution
	local($address) = join(' ', @args);		# Address list
	$address = $cf'email if $address eq '';	# No address, defaults to user
	local($failed) = &notify($msg, $address);
	unless ($failed) {
		$msg = &tilda($msg);				# Replace the home directory by ~
		&add_log("NOTIFIED $msg [$mfile] to $address") if $loglvl > 2;
	}
	$failed;
}

# Run the REJECT command
sub main'load_run_reject {
	package main;
	local(*perform) = *do_reject;
	&alter_flow;		# Change control flow by calling &perform
}

# Run the RESTART command
sub main'load_run_restart {
	package main;
	local(*perform) = *do_restart;
	&alter_flow;		# Change control flow by calling &perform
}

# Run the ABORT command
sub main'load_run_abort {
	package main;
	local(*perform) = *do_abort;
	&alter_flow;		# Change control flow by calling &perform
}

# Run the RESYNC command
sub main'load_run_resync {
	package main;
	# Headers pertaining to body encoding could have changed.
	&header_check_body_encoding;	# Check and recode if possible
	&header_resync;					# Resynchronize the %Header array
	&add_log("RESYNCED [$mfile]") if $loglvl > 4;
	0;
}

# Run the BEGIN command
sub main'load_run_begin {
	package main;
	local($newstate) = @_;		# New state wanted
	return 0 if $opt'sw_t && $lastcmd;		# -t means change only if true
	return 0 if $opt'sw_f && !$lastcmd;		# -f means change only if false
	$newstate = 'INITIAL' unless $newstate;
	$wmode = $newstate;			# $wmode comes from analyze_mail
	&add_log("BEGUN [$mfile] state $newstate") if $loglvl > 4;
	0;
}

# Run the RECORD command
sub main'load_run_record {
	package main;
	local($mode) = @_;
	local($tags);
	$mode =~ s|^(\w*)\s*\(([^()]*)\).*|$1| && ($tags = $2);
	local($failed) = 0;
	if (&history_tag($tags)) {	# Message already seen
		if ($mode eq '') {
			&add_log("NOTICE entering seen mode")
				if $loglvl > 5 && $wmode ne '_SEEN_';
			# Enter special mode ($wmode from analyze_mail)
			$wmode = '_SEEN_';
		}
		&alter_execution('x', $mode);
		$failed = 1;			# Make sure it "fails"
	}
	local($tagmsg) = $tags ne '' ? " ($tags)" : '';
	&add_log("RECORDED [$mfile]" . $tagmsg) if $loglvl > 4;
	$failed;
}

# Run the UNIQUE command
sub main'load_run_unique {
	package main;
	local($mode) = @_;
	local($tags);
	$mode =~ s|^(\w*)\s*\(([^()]*)\).*|$1| && ($tags = $2);
	local($failed) = 0;
	if (&history_tag($tags)) {	# Message already seen
		&add_log("NOTICE message tagged as saved") if $loglvl > 5;
		$ever_saved = 1;		# In effect, runs a DELETE
		&alter_execution('x', $mode);
		$failed = 1;			# Make sure it "fails"
	}
	local($tagmsg) = $tags ne '' ? " ($tags)" : '';
	&add_log("UNIQUE [$mfile]" . $tagmsg) if $loglvl > 4;
	$failed;
}

# Run the FORWARD command
sub main'load_run_forward {
	package main;
	local($addresses) = @_;		# Address(es)
	local($failed) = &forward($addresses);
	unless ($failed) {
		&add_log("FORWARDED [$mfile] to $addresses") if $loglvl > 2;
		$ever_saved = 1;		# Forwarding succeeded, counts as a save
	}
	$failed;
}

# Run the BOUNCE command
sub main'load_run_bounce {
	package main;
	local($addresses) = @_;		# Address(es)
	local($failed) = &bounce($addresses);
	unless ($failed) {
		&add_log("BOUNCED [$mfile] to $addresses") if $loglvl > 2;
		$ever_saved = 1;		# Bouncing succeeded, counts as a save
	}
	$failed;
}

# Run the POST command
sub main'load_run_post {
	package main;
	local($newsgroups) = @_;	# Newsgroup(s)
	local($failed) = &post($newsgroups);
	unless ($failed) {
		&add_log("POSTED [$mfile] to $newsgroups") if $loglvl > 2;
		$ever_saved = 1;		# Posting succeeded, counts as a save
	}
	$failed;
}

# Run the RUN command
sub main'load_run_run {
	package main;
	local($program) = @_;		# Program to run
	local($failed) = &shell_command($program, $NO_INPUT, $NO_FEEDBACK);
	unless ($failed) {
		&add_log("RAN '$program' for [$mfile]") if $loglvl > 4;
	}
	$failed;
}

# Run the PIPE command
sub main'load_run_pipe {
	package main;
	local($program) = @_;		# Program to run
	my $mail = $opt'sw_b ? $MAIL_INPUT_BINARY : $MAIL_INPUT;
	local($failed) = &shell_command($program, $mail, $NO_FEEDBACK);
	unless ($failed) {
		&add_log("PIPED [$mfile] to '$program'") if $loglvl > 4;
	}
	$failed;
}

# Run the GIVE command
sub main'load_run_give {
	package main;
	local($program) = @_;		# Program to run
	local($failed) = &shell_command($program, $BODY_INPUT, $NO_FEEDBACK);
	unless ($failed) {
		&add_log("GAVE [$mfile] to '$program'") if $loglvl > 4;
	}
	$failed;
}

# Run the PASS command
sub main'load_run_pass {
	package main;
	local($program) = @_;		# Program to run
	local($failed) = &shell_command($program, $BODY_INPUT, $FEEDBACK);
	unless ($failed) {
		&add_log("PASSED [$mfile] through '$program'") if $loglvl > 4;
	}
	$failed;
}

# Run the FEED command
sub main'load_run_feed {
	package main;
	local($program) = @_;		# Program to run
	my $mail = $opt'sw_b ? $MAIL_INPUT_BINARY : $MAIL_INPUT;
	my $feedback = $opt'sw_e ? $FEEDBACK_ENCODING : $FEEDBACK;
	local($failed) = &shell_command($program, $mail, $feedback);
	unless ($failed) {
		&add_log("FED [$mfile] through '$program'") if $loglvl > 4;
	}
	$failed;
}

# Run the PURIFY command
sub main'load_run_purify {
	package main;
	local($program) = @_;		# Program to run
	local($failed) = &shell_command($program, $HEADER_INPUT, $FEEDBACK);
	unless ($failed) {
		&add_log("PURIFIED [$mfile] through '$program'") if $loglvl > 4;
	}
	$failed;
}

# Run the BACK command
# Manipulates dynamically bound variable $cont (output from xeqte)
sub main'load_run_back {
	package main;
	local($command) = @_;
	# The BACK command is handled recursively. The local variable $Back will be
	# set by xeq_back() if any feedback is to ever occur. This routine will be
	# transparently called instead of the usual handle_output() because of the
	# dynamic aliasing done here.
	local($Back) = '';					# BACK may be nested
	local(*handle_output) = *xeq_back;	# Any output to be put in $Back
	local($failed) = 0;
	$command =~ s/%/%%/g;				# Protect against 2nd macro substitution
	# Calling run_command will position $lastcmd to be the return status of
	# the last meaningful command executed. However, we reset $lastcmd before
	# diving into the execution.
	$lastcmd = 0;						# Assume everything went fine
	&run_command($command);				# Run command (ignore return value)
	if ($Back ne '') {
		&add_log("got '$Back' back") if $loglvl > 11;
		$cont = &xeqte($Back);			# Get continuation status back
		$@ = '';						# Avoid cascade of (same) error report
		&add_log("BACK from '$command'") if $loglvl > 4;
	} else {
		&add_log("WARNING got nothing out of '$command'") if $loglvl > 5;
	}
	$lastcmd;			# Propage error status we got from the $command
}

# Run the ON command
sub main'load_run_on {
	package main;
	local($_) = $cmd;					# The whole command line
	local(@days) = split(' ', 'Sun Mon Tue Wed Thu Fri Sat');
	local(%days);
	local($daynum) = 0;
	foreach $day (@days) {				# Initialize Sun => 0, Mon => 1, etc...
		$days{$day} = $daynum++;
	}
	local(@on);							# List of specified days
	local(%on);							# Hash '0' (for sunday) => 1 if selected
	if (s/^ON\s*\(([^\)]*)\)//) {		# List of days, like (Mon Tue)
		@on = split(/,?\s+/, $1);		# Allow (Mon Thu) and (Mon, Thu)
		local($non);
		foreach $on (@on) {
			$non = $on;					# New $on will be canonicalized
			$non =~ s/^(...).*/\u\L$1/;	# Keep only first 3 letters
			unless (defined $days{$non}) {
				&add_log("WARNING ignoring bad day $on in ON (@on)")
					if $loglvl > 5;
				next;
			}
			$on{$days{$non}}++;			# E.g sets $on{1} for Mon
		}
		&add_log("on (@on)") if $loglvl > 18;
	} else {
		&add_log("ERROR bad ON syntax (did not parse right)") if $loglvl > 1;
		return 1;
	}

	# Calling run_command will set $lastcmd to the status of the command. In
	# case we are running a command which does not alter this status, assume
	# everything is fine.

	$lastcmd = 0;						# Assume command will run correctly
	s/^\s*//;							# Remove leading spaces

	local($wday) = (localtime(time))[6];

	if (defined $on{$wday}) {
		&add_log("ON (@on) $_") if $loglvl > 7;
		s/%/%%/g;						# Protect against 2nd macro substitution
		$cont = &run_command($_);		# Run command and update control flow
	} else {
		&add_log("not a good day for $_") if $loglvl > 12;
	}

	$lastcmd;							# Propagates execution status
}

# Run the ONCE command
sub main'load_run_once {
	package main;
	local($_) = $cmd;					# The whole command line
	local($hname);						# Hash name (e-mail address)
	local($tag);						# Tag associated with command
	local($raw_period);					# The period, as written
	if (s/^ONCE\s*\(([^,\)]*),\s*([^,;\)]*),\s*(\w+)\s*\)//) {
		($hname, $tag, $raw_period) = ($1, $2, $3);
		&add_log("tag is ($hname, $tag, $raw_period)") if $loglvl > 18;
	} else {
		&add_log("ERROR bad once syntax (invalid tag)") if $loglvl > 1;
		return 1;
	}
	s/^\s*//;							# Remove leading spaces
	local($period) = &seconds_in_period($raw_period);
	&add_log("period is $raw_period = $period seconds") if $loglvl > 18;

	# Calling run_command will set $lastcmd to the status of the command. In
	# case we are running a command which does not alter this status, assume
	# everything is fine.
	$lastcmd = 0;						# Assume command will run correctly

	if (&once_check($hname, $tag, $period)) {
		&add_log("ONCE ($hname, $tag, $raw_period) $_") if $loglvl > 7;
		&s_once($cmd_name, $wmode, $tag);
		s/%/%%/g;						# Protect against 2nd macro substitution
		$cont = &run_command($_);		# Run it, update continuation status
	} else {
		&add_log("retry time not reached for $_") if $loglvl > 12;
		&s_noretry($cmd_name, $wmode, $tag);
	}

	$lastcmd;							# Propagates execution status
}

# Run the SELECT command
sub main'load_run_select {
	package main;
	local($_) = $cmd;					# The whole command line
	local($start, $end);				# Date strings for start and end
	if (s/^SELECT\s*\(([^.\)]*)\.\.\s*([^\)]*)\)//) {
		($start, $end) = ($1, $2);
		$start =~ s/\s*$//;				# Remove trailing spaces
		$end =~ s/\s*$//;
		&add_log("time is ($start .. $end)") if $loglvl > 18;
	} else {
		&add_log("ERROR bad select syntax (invalid time)") if $loglvl > 1;
		return 1;
	}
	local($now) = time;					# Current time
	local($sec_start, $sec_end);		# Start and end converted in seconds
	$sec_start = &getdate($start, $now);
	if ($sec_start == -1) {
		&add_log("ERROR in SELECT: 1st time '$start'") if $loglvl > 1;
		return 1;
	}
	$sec_end = &getdate($end, $now);
	if ($sec_end == -1) {
		&add_log("ERROR in SELECT: 2nd time '$end'") if $loglvl > 1;
		return 1;
	}
	if ($sec_start > $sec_end) {
		&add_log("WARNING time selection always impossible?") if $loglvl > 1;
		return 0;
	}

	# Calling run_command will set $lastcmd to the status of the command. In
	# case we are running a command which does not alter this status, assume
	# everything is fine.
	$lastcmd = 0;						# Assume command will run correctly

	&add_log("SELECT ($sec_start, $sec_end) at $now") if $loglvl > 11;

	s/^\s*//;							# Remove leading spaces
	if ($now >= $sec_start && $now <= $sec_end) {
		&add_log("SELECT ($start .. $end) $_") if $loglvl > 7;
		s/%/%%/g;						# Protect against 2nd macro substitution
		$cont = &run_command($_);		# Run command and update control flow
	} else {
		&add_log("time period not good for $_") if $loglvl > 12;
	}

	$lastcmd;							# Propagates execution status
}

# Run the NOP command
sub main'load_run_nop {
	package main;
	local($what) = $opt'sw_f ? 'failure' : ($opt'sw_t ? 'success' : '');
	local($force) = $what ? " forcing $what" : '';
	&add_log("NOP [$mfile]$force") if $loglvl > 7;
	return 1 if $opt'sw_f;		# -f forces failure
	return 0 if $opt'sw_t;		# -t forces failure
	$lastcmd;					# Propagates curremt exec status
}

# Run the STRIP command
sub main'load_run_strip {
	package main;
	local($headers) = @_;		# Headers to remove
	&alter_header($headers, $HD_STRIP);
	$headers = join(', ', split(/\s/, $headers));
	&add_log("STRIPPED $headers from [$mfile]") if $loglvl > 7;
	0;
}

# Run the KEEP command
sub main'load_run_keep {
	package main;
	local($headers) = @_;		# Headers to keep
	&alter_header($headers, $HD_KEEP);
	$headers = join(', ', split(/\s/, $headers));
	&add_log("KEPT $headers from [$mfile]") if $loglvl > 7;
	0;
}

# Run the ANNOTATE command
sub main'load_run_annotate {
	package main;
	local($field, $value) = $cms =~ m|([\w\-]+):?\s*(.*)|;
	local($failed) = &annotate_header($field, $value);
	unless ($failed) {
		local($msg) = $opt'sw_d ? ' (no date)' : '';
		&add_log("ANNOTATED [$mfile] with $field$msg") if $loglvl > 7;
	}
	$failed;
}

# Run the ASSIGN command
sub main'load_run_assign {
	package main;
	local($var, $value) = $cms =~ m|^(:?\w+)\s+(.*)|;
	local($eval);						# Evaluated value for expression
	local($@);
	# An expression may be provided as a value. If the whole value is enclosed
	# within simple quotes, then those are stripped and no evaluation is made.
	unless ($value =~ s/^'(.*)'$/$1/) {
		eval "\$eval = $value";			# Maybe value is an expression?
		if ($@) {
			chop($@);
			&add_log("WARNINIG can't evaluate '$value': $@");
		} else {
			$value = $eval;
		}
	}
	if ($var =~ s/^://) {
		&extern'set($var, $value);		# Persistent variable is set
	} else {
		$Variable{$var} = $value;		# User defined variable is set
	}
	&add_log("ASSIGNED '$value' to '$var' [$mfile]") if $loglvl > 7;
	0;
}

# Run the TR command
sub main'load_run_tr {
	package main;
	local($variable, $tr) = $cms =~ m|^(\S+)\s+(.*)|;
	&alter_value($variable, "tr$tr");
}

# Run the SUBST command
sub main'load_run_subst {
	package main;
	local($variable, $s) = $cms =~ m|^(\S+)\s+(.*)|;
	&alter_value($variable, "s$s");
}

# Run the SPLIT command
sub main'load_run_split {
	package main;
	local($folder) = @_;			# Folder where split occurs
	local($failed) = &split($folder);
	if (0 == $failed % 2) {			# Message was in digest format
		if ($failed & 0x4) {
			&add_log("SPLIT [$mfile] in mailagent's queue") if $loglvl > 2;
		} else {
			&add_log("SPLIT [$mfile] in $folder") if $loglvl > 2;
		}
		# If digest was not in RFC-934 style, there is a chance the split
		# was not correctly performed. To avoid any accidental loss of
		# information, the original digest message is also saved if SPLIT
		# had a folder argument, or it is not tagged saved.
		if ($failed & 0x8) {		# Digest was not RFC-934 compliant
			&add_log("NOTICE [$mfile] not RFC-934 compliant") if $loglvl > 6;
			if ($folder ne '') {
				&add_log("NOTICE saving original [$mfile] in $folder")
					if $loglvl > 6;
				&save_message($folder);
			} else {
				&add_log("NOTICE [$mfile] not tagged as saved")
					if $loglvl > 6 && ($failed & 0x2);
			}
		} else {
			$ever_saved = 1 if $failed & 0x2;	# Split -i succeeded
		}
		$failed = 0;
	}
	# If message was not in digest format and a folder was specified, save
	# message in that folder.
	if ($failed < 0 && $folder ne '') {
		&add_log("NOTICE [$mfile] not in digest format") if $loglvl > 6;
		$failed = &save_message($folder);
	}
	$failed ? 1 : 0;	# Failure status from split can be negative
}

# Run the VACATION command
sub main'load_run_vacation {
	package main;
	return 0 unless $cf'vacation =~ /on/i;	# Ignore if vacation mode off
	local($mode, $period) = $cms =~ m|^(\S+)(\s+\S+)?|;
	local($l) = $opt'sw_l ? ' locally' : '';
	local($allowed) = ($mode =~ /off/i) ? 0 : 1;
	&env'local('vacation', $allowed) if $opt'sw_l;
	$env'vacation = $allowed;			# Won't hurt given the above local call
	if ($allowed && $mode !~ /^on$/i) {	# New vacation path given
		if ($cf'vacfixed =~ /on/i) {	# Not allowed if vacfixed is ON
			&add_log("WARNING no message change allowed by 'vacfixed'")
				if $loglvl > 5;
		} else {
			$mode =~ s/^~/$cf'home/;		# ~ substitution
			&env'local('vacfile', $mode) if $opt'sw_l;
			$env'vacfile = $mode;
			&add_log("vacation message in file $mode$l") if $loglvl > 7;
		}
	}
	if ($allowed && $period) {
		&env'local('vacperiod', $period) if $opt'sw_l;
		$env'vacperiod = $period;
		&add_log("vacation period is now $period$l") if $loglvl > 7;
	}
	$mode = $env'vacation ? 'on' : 'off';
	&add_log("vacation message turned $mode$l") if $loglvl > 7;
	0;
}

# Run the QUEUE command
sub main'load_run_queue {
	package main;
	# Mail is saved as a 'qm' file, to avoid endless loops when mailagent
	# processes the queue. This means the mail will be deferred for at
	# least half an hour.
	local($name) = &queue_mail('', 'qm');	# No file name, mail in %Header
	$ever_saved = 1 if defined $name;		# Queuing counts as saving
	defined $name ? 0 : 1;					# Failed if $name is undef
}

# Run the PERL command
sub main'load_run_perl {
	package main;
	local($script) = @_;	# Script to be loaded
	local($failed) = &perl($script);
	unless ($failed) {
		$script = &tilda($script);			# Replace the home directory by ~
		&add_log("PERLED [$mfile] through $script") if $loglvl > 7;
	}
	$failed;
}

# Run the REQUIRE command
sub main'load_run_require {
	package main;
	local($file, $package) = $cms =~ m|^(\S+)\s*(.*)|;
	local($failed) = &require($file, $package);
	unless ($failed) {
		$file = &tilda($file);		# Replace the home directory by ~
		local($inpack) = $file;		# Loaded in a package?
		$inpack .= " in package $package" if $package ne '';
		&add_log("REQUIRED [$mfile] $inpack") if $loglvl > 7;
	}
	$failed;
}

# Run the APPLY command
sub main'load_run_apply {
	package main;
	local($rulefile) = @_;	# Rule file to be applied
	local($failed, $saved) = &apply($rulefile);
	unless ($failed) {
		$rulefile = &tilda($rulefile);		# Replace the home directory by ~
		&add_log("APPLIED [$mfile] rules $rulefile") if $loglvl > 7;
	}
	$ever_saved = 1 if $saved;		# Mark mail as saved if appropriate
	$saved ? $failed : 1;			# Force failure if never saved
}

# Run the UMASK command
sub main'load_run_umask {
	package main;
	local($mask) = @_;
	$mask = oct($mask) if $mask =~ /^0/;
	&env'local('umask', $mask) if $opt'sw_l;	# Restored when leaving rule
	$env'umask = $mask;		# Permanent change, unless changed locally already
	umask($env'umask);
	local($omask) = sprintf("0%o", $mask);	# Octal string, for logging
	local($local) = $opt'sw_l ? ' locally' : '';
	&add_log("UMASK [$mfile] set to ${omask}$local") if $loglvl > 7;
	0;	# Ok
}

# Run the AFTER command
sub main'load_run_after {
	package main;
	local($time, $action) = $cms =~ m|^\((.*)\)(.*)|;
	local($failed, $queued) = &after($time, $action);
	unless ($failed) {
		local(@msg);
		push(@msg, 'shell') if $opt'sw_s;
		push(@msg, 'command') if $opt'sw_c;
		push(@msg, 'no input') if $opt'sw_n;
		push(@msg, 'agent') if $opt'sw_a || 0 == @msg;
		local($type) = join(', ', @msg);
		local($qmsg) = $queued ne '-' ? "-> $queued" : '';
		&add_log("AFTER [$mfile$qmsg] $time {$action} ($type)") if $loglvl > 3;
	}
	$failed;	# Failure status
}

# Run the DO command
sub main'load_run_do {
	package main;
	local($what, $args) = $cms =~ m|^([^()\s]*)(.*)|;
	local($something, $routine) = $what =~ m|^([^:]*):(.*)|;
	$routine = $what if $something eq '';
	local($failed) = &do($something, $routine, $args);
	&add_log("DONE [$mfile] $routine$args") if $loglvl > 7 && !$failed;
	$failed;	# Failure status
}

# Run the BEEP command
sub main'load_run_beep {
	package main;
	local($beep) = @_;
	&env'local('beep', $beep) if $opt'sw_l;	# Restored when leaving rule
	$env'beep = $beep;		# Permanent change, unless changed locally already
	local($local) = $opt'sw_l ? ' locally' : '';
	&add_log("BEEP [$mfile] set to ${beep}$local") if $loglvl > 7;
	0;	# Ok
}

# Run the PROTECT command
sub main'load_run_protect {
	package main;
	local($mode) = @_;
	local($local) = $opt'sw_l ? ' locally' : '';
	if ($opt'sw_u) {
		&env'undef('protect');
		&env'unset('protect') unless $opt'sw_l;
		&add_log("PROTECT [$mfile] reset to default$local") if $loglvl > 7;
		return 0;	# Ok
	}
	$mode = oct($mode) if $mode =~ /^0/;
	&env'local('protect', $mode) if $opt'sw_l;	# Restored when leaving rule
	$env'protect = $mode;	# Permanent change, unless changed locally already
	local($omode) = sprintf("0%o", $mode);	# Octal string, for logging
	&add_log("PROTECT [$mfile] mode set to ${omode}$local") if $loglvl > 7;
	0;	# Ok
}

# Run the BIFF command
sub main'load_run_biff {
	package main;
	local($mode) = $cms =~ m|^(\S+)|;
	local($l) = $opt'sw_l ? ' locally' : '';
	local($allowed) = ($mode =~ /off/i) ? 0 : 1;	# New boolean setting
	local($was) = ($env'biff =~ /off/i) ? 0 : 1;	# Old boolean setting
	local($setting) = $allowed ? 'ON' : 'OFF';
	&env'local('biff', $setting) if $opt'sw_l;
	$env'biff = $setting;				# Won't hurt given the above local call
	if ($allowed && $mode !~ /^on$/i) {	# New biff template format path given
		$mode =~ s/^~/$cf'home/;		# ~ substitution
		&env'local('biffmsg', $mode) if $opt'sw_l;
		$env'biffmsg = $mode;
		&add_log("biff template in file $mode$l") if $loglvl > 7;
	}
	&add_log("biffing turned $setting$l") if $loglvl > 7 && $was != $allowed;
	0;
}

# For SAVE, STORE or WRITE, the job is the same
# If the name is not an absolute path, the folder directory is taken
# in the "maildir" environment variable. If none, defaults to ~/Mail.
# A folder whose name begins with a '+' is taken as an MH folder.
sub main'load_run_saving {
	package main;
	local($folder, $remove) = @_;				# Shall we remove folder first?
	local($folddir) = $XENV{'maildir'};			# Folder directory location
	unless ($folder =~ /^\+/) {					# Not an MH folder
		$folder = "~/mbox" unless $folder;		# No folder -> save in mbox
		$folder =~ s/~/$cf'home/g;				# ~ substitution
		$folddir =~ s/~/$cf'home/g;				# ~ substitution
		$folddir = "$cf'home/Mail" unless $folddir;	# Default folders in ~/Mail
		$folder = "$folddir/$folder" unless $folder =~ m|^/|;
		local($dir) = $folder =~ m|(.*)/.*|;	# Get directory name
		unless (-d "$dir") {
			&makedir($dir);
			unless (-d "$dir") {
				&add_log("ERROR couldn't create directory $dir")
					if $loglvl > 0;
			} else {
				&add_log("created directory $dir") if $loglvl > 7;
			}
		}
	}
	# Cannot use WRITE with an MH folder, it behaves like a SAVE. Same thing
	# when attempting to save in a directory...
	if ($remove == $FOLDER_REMOVE && $folder !~ /^\+/) {
		# Folder has to be removed before writting into it. However, if it
		# is write protected, do not unlink it (save will fail later on anyway).
		# Note that this makes it a candidate for hooks via WRITE, if the
		# folder has its 'x' bit set with its 'w' bit cleared. This is an
		# undocumented feature however (WRITE is not supposed to trigger hooks).
		unlink "$folder" if -f "$folder" && -w _;
	}
	local($mbox, $failed) = &save($folder);
	local($log_message);				# Log message to be issued
	unless ($failed) {
		local($file) = $folder;			# Work on a copy to detect leading dir
		$folddir =~ s/(\W)/\\$1/g;		# Escape possible meta-characters
		$file =~ s|^$folddir/||;		# Preceded by folder directory?
		if ($file =~ s/^\+//) {
			$log_message = "MH folder $file";
		} elsif ($file ne $folder) {
			$log_message = "folder $file";
		} else {
			$log_message = &tilda($folder);	# Replace the home directory by ~
		}
	}

	# Return the status of the save command and a part of the logging message
	# to be issued. That way, we get a nice contextual log.
	($mbox, $failed, $log_message);
}

# Perform the appropriate continuation status, depending on the option:
# When 'x' is given as the option string, then the current options in the
# opt package are used instead of -c, -r or -a.
sub main'load_alter_execution {
	package main;
	local($option, $mode) = @_;	# Option, mode we have to change to
	if ($mode ne '') {
		&add_log("entering new state $mode") if $loglvl > 6 && $wmode ne $mode;
		$wmode = $mode;
	}
	if ($option eq 'x') {		# Backward compatibility at 3.0 PL24
		$option = '-c' if $opt'sw_c;
		$option = '-a' if $opt'sw_a;
		$option = '-r' if $opt'sw_r;
		$option = '' if $option eq 'x';
	}
	&add_log("altering execution in mode '$wmode', option '$option'")
		if $loglvl > 18;
	if ($option eq '-c') {		# Continue execution
		0;
	} elsif ($option eq '-r') {	# Asks for RESTART
		&do_restart;
	} elsif ($option eq '-a') {	# Asks for ABORT
		&do_abort;
	} else {					# Default is to REJECT
		&do_reject;
	}
	# Propagate return status.
}

# Save message in specified folder
sub main'load_save_message {
	package main;
	local($folder) = @_;
	local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND);
	unless ($failed) {
		&add_log("SAVED [$mfile] in $log_message") if $loglvl > 2;
		$ever_saved = 1;			# We were able to save it
	}
	$failed;
}

# List of special header selector, for which a pattern without / is to be
# taken as an equality with the login name of the address. If there are some
# metacharacters, then a match will be attempted on that name. For each of
# those special headers, we record the name of the subroutine to be called.
# If a matching function is not specified, the default is 'match_var'.
# The %Amatcher gives the name of the fields which contains an address.
sub main'load_init_matcher {
	package main;
	%Matcher = (
		'Envelope',			'match_single',
		'From',				'match_single',
		'To',				'match_list',
		'Cc',				'match_list',
		'Apparently-To',	'match_list',
		'Newsgroups',		'match_list',
		'Sender',			'match_single',
		'Resent-From',		'match_single',
		'Resent-To',		'match_list',
		'Resent-Cc',		'match_list',
		'Resent-Sender',	'match_single',
		'Reply-To',			'match_single',
		'Relayed',			'match_list',
	);
	%Amatcher = (
		'From',				1,
		'Envelope',			1,
		'To',				1,
		'Cc',				1,
		'Apparently-To',	1,
		'Sender',			1,
		'Resent-From',		1,
		'Resent-To',		1,
		'Resent-Cc',		1,
		'Resent-Sender',	1,
		'Reply-To',			1,
	);
}

# Transform a shell-style pattern into a perl pattern
sub main'load_perl_pattern {
	package main;
	local($_) = @_;		# The shell pattern
	s/\./\\./g;			# Escape .
	s/\*/.*/g;			# Transform * into .*
	s/\?/./g;			# Transform ? into .
	$_;					# Perl pattern
}

# Take a pattern as written in the rule file and make it suitable for
# pattern matching as understood by perl. Unless the pattern starts with a
# leading / or is of the form m||, it is enclosed within slashes.
# We also enclose the whole pattern within ().
sub main'load_make_pattern {
	package main;
	local($_) = shift(@_);
	# The whole pattern is inserted within () to make at least one
	# backreference. Otherwise, the following could happen:
	#    $_ = '1 for you';
	#    @matched = /^\d/;
	#    @matched = /^(\d)/;
	# In both cases, the @matched array is set to ('1'), with no way to
	# determine whether it is due to a backreference (2nd case) or a sucessful
	# match. Knowing we have at least one bracketed reference is enough to
	# disambiguate.
	if (/^m(\W)(.*)\1(\w*)$/) {
		$_ = "m$1($2)$1$3";
	} elsif (m|^/(.*)/(\w*)$|) {
		$_ = "/($1)/$2";
	} else {
		# Pattern does not start with a / or is not of the form m|xxx|
		$_ = &perl_pattern($_);		# Simple words specified via shell patterns
		$_ = "/^($_)\$/";			# Anchor pattern
	}
	$_;						# Pattern suitable for eval'ed matching
}

# ### Main matching entry point ###
# ### (called from &apply_rules in pl/analyze.pl)
# Attempt a match of a set of pattern, for each possible selector. The selector
# string given can contain multiple selectors separated by white spaces.
sub main'load_match {
	package main;
	local($selector) = shift(@_);	# The selector on which pattern applies
	local($pattern) = shift(@_);	# The pattern or script to apply
	local($range) = shift(@_);		# The range on which pattern applies
	local($matched) = 0;			# Matching status returned
	# If the pattern is held within double quotes, it is assumed to be the name
	# of a file from which patterns may be found (one per line, shell comments
	# being ignored).
	if ($pattern !~ /^"/) {
		$matched = &apply_match($selector, $pattern, $range);
	} else {
		# Load patterns from file whose name is given between "quotes"
		# All un-escaped @ in patterns are escaped for perl5.
		local(@filepat) = &include_file($pattern, 'pattern');
		grep(s/([^\\](\\\\)*)@/$1\\@/g && undef, @filepat);
		# Now do the match for all the patterns. Stop as soon as one matches.
		foreach (@filepat) {
			$matched = &apply_match($selector, $_, $range);
			last if $matched;
		}
	}
	$matched ? 1 : 0;		# Return matching status (guaranteed numeric)
}

# Attempt a pattern match on a set of selectors, and set the special macro %&
# to the name of the regexp-specified fields which matched.
sub main'load_apply_match {
	package main;
	local($selector) = shift(@_);	# The selector on which pattern applies
	local($pattern) = shift(@_);	# The pattern or script to apply
	local($range) = shift(@_);		# The range on which pattern applies
	local($matched) = 0;			# True when a matching occurred
	local($inverted) = 0;			# True whenever all '!' match succeeded
	local($invert) = 1;				# Set to false whenever a '!' match fails
	local($match);					# Matching status reported
	local($not) = '';				# Shall we negate matching status?
	if ($selector eq 'script') {	# Pseudo header selector
		$matched = &evaluate(*pattern);
	} else {						# True header selector

		# There can be multiple selectors separated by white spaces. As soon as
		# one of them matches, we stop and return true. A selector may contain
		# metacharacters, in which case a regular pattern matching is attempted
		# on the true *header* fields (i.e. we skip the pseudo keys like Body,
		# Head, etc..). For instance, Return.* would attempt a match on the
		# field Return-Receipt-To:, if present. The special macro %& is set
		# to the list of all the fields on which the match succeeded
		# (alphabetically sorted).

		foreach $select (split(/ /, $selector)) {
			$not = '';
			$select =~ s/^!// && ($not = '!');
			# Allowed metacharacters are listed here (no braces wanted)
			if ($select =~ /\.|\*|\[|\]|\||\\|\^|\?|\+|\(|\)/) {
				$match = &expr_selector_match($select, $pattern, $range);
			} else {
				$match = &selector_match($select, $pattern, $range);
			}
			if ($not) {								# Negated test
				$invert = !$match if $invert;		# '!' tests AND'ed
				$inverted = $invert;				# Meaningful from now on
			} else {
				$matched = $match;					# Normal tests OR'ed
			}
			last if $matched;		# Stop when matching status known
		}
	}
	$matched = $matched || $inverted;
	if ($loglvl > 19) {
		local($logmsg) = "applied '$pattern' on '$selector' ($range) was ";
		$logmsg .= $matched ? "true" : "false";
		&add_log($logmsg);
	}
	$matched;						# Return matching status
}

# Attempt a pattern match on a set of selectors, and set the special macro %&
# to the name of the field which matched. If there is more than one such
# selector, values are separated using comas. If selector is preceded by a '!',
# then the matching status is negated and *all* the tested fields are recorded
# within %& when the returned status is 'true'.
sub main'load_expr_selector_match {
	package main;
	local($selector) = shift(@_);	# The selector on which pattern applies
	local($pattern) = shift(@_);	# The pattern or script to apply
	local($range) = shift(@_);		# The range on which pattern applies
	local($matched) = 0;			# True when a matching occurred
	local(@keys) = sort keys %Header;
	local($match);					# Local matching status
	local($not) = '';				# Shall boolean value be negated?
	local($orig_ampersand) = $macro_ampersand;	# Save %&
	$selector =~ s/^!// && ($not = '!');
	&add_log("field '$selector' has metacharacters") if $loglvl > 18;
	field: foreach $key (@keys) {
		next if $Pseudokey{$key};		# Skip Body, All...
		&add_log("'$select' tried on '$key'") if $loglvl > 19;
		next unless eval '$key =~ /' . $select . '/';
		$match = &selector_match($key, $pattern, $range);
		$matched = 1 if $match;			# Only one match needed
		# Record matching field for futher reference if a match occurred and
		# the selector does not start with a '!'. Record all the tested fields
		# if's starting with a '!' (because that's what is interesting in that
		# case). In that last case, the original macro will be restored if any
		# match occurs.
		if ($not || $match) {
			$macro_ampersand .= ',' if $macro_ampersand;
			$macro_ampersand =~ s/;,$/;/;
			$macro_ampersand .= $key;
		}
		if ($match) {
			&add_log("obtained match with '$key' field")
				if $loglvl > 18;
			next field;				# Try all the matching selectors
		}
		&add_log("no match with '$key' field") if $loglvl > 18;
	}
	$macro_ampersand .= ';';		# Set terminated with a ';'
	# No need to negate status if selector was preceded by a '!': this will
	# be done by apply match.
	$macro_ampersand = $orig_ampersand if $not && $matched;	# Restore %&
	&add_log("matching status for '$selector' ($range) is '$matched'")
		if $loglvl > 18;
	$matched;						# Return matching status
}

# Attempt a match of a pattern against a selector, return boolean status.
# If pattern is preceded by a '!', the boolean status is negated.
# If the 'rulemac' configuration variable is set to ON, a macro substitution
# is performed on the search pattern.
sub main'load_selector_match {
	package main;
	local($selector) = shift(@_);	# The selector on which pattern applies
	local($pattern) = shift(@_);	# The pattern to apply
	local($range) = shift(@_);		# The range on which pattern applies
	local($matcher);				# Subroutine used to do the match
	local($matched);				# Record matching status
	local($not) = '';				# Shall we apply NOT on matching result?
	$selector = &header'normalize($selector);	# Normalize case
	$matcher = $Matcher{$selector};
	$matcher = 'match_var' unless $matcher;
	$pattern =~ s/^!// && ($not = '!');
	&macros_subst(*pattern) if $cf'rulemac =~ /on/i;	# Macro substitution
	$matched = &$matcher($selector, $pattern, $range);
	$matched = !$matched if $not;	# Revert matching status if ! pattern
	if ($loglvl > 19) {
		local($logmsg) = "matching '$not$pattern' on '$selector' ($range) was ";
		$logmsg .= $matched ? "true" : "false";
		&add_log($logmsg);
	}
	$matched;				# Return matching status
}

# Matching is done in a header which only contains an internet address. The
# $range parameter is ignored (does not make any sense here). An optional 4th
# parameter may be supplied to specify the matching buffer. If absent, the
# corresponding header line is used -- this feature is used by &match_list.
sub main'load_match_single {
	package main;
	local($selector, $pattern, $range, $buffer) = @_;
	local($login) = 0;				# Set to true when attempting login match
	local(@matched);
	unless (defined $buffer) {		# No buffer for matching was supplied
		$buffer = $Header{$selector};
	}
	#
	# If we attempt a match on a field holding e-mail addresses and the pattern
	# is anchored at the beginning with a /^, then we only keep the address
	# part and remove the comment if any.
	#
	# If the field holds a full e-mail address and only that, we automatically
	# select the address part of the field for matching. -- RAM, 17/03/2001
	#
	# Otherwise, the field is left alone.
	#
	# If the pattern is only a single name, we extract the login name for
	# matching purposes...
	#
	if ($Amatcher{$selector}) {					# Field holds an e-mail address
		if (
			$pattern =~ m|^/\^| ||
			$pattern =~ m|^[-\w.*?]+(\\\@[-\w.*?]+)?\s*$|
		) {
			$buffer = (&parse_address($buffer))[0];
			&add_log("matching buffer reduced to '$buffer'") if $loglvl > 18;
		}
		if ($pattern =~ m|^[-\w.*?]+\s*$|) {	# Single name may have - or .
			$buffer = &login_name($buffer);		# Match done only on login name
			$pattern =~ tr/A-Z/a-z/;	# Cannonicalize name to lower case
		}
		$login = 1 unless $pattern =~ m|^/|;	# Ask for case-insensitive match
	}
	$buffer =~ s/^\s+//;				# Remove leading spaces
	$buffer =~ s/\s+$//;				# And trailing ones
	$pattern = &make_pattern($pattern);
	$pattern .= "i" if $login;			# Login matches are case-insensitive
	@matched = eval '($buffer =~ ' . $pattern . ');';
	# If buffer is empty, we have to recheck the pattern in a non array context
	# to see if there is a match. Otherwise, /(.*)/ does not seem to match an
	# empty string as it returns an empty string in $matched[0]...
	$matched[0] = eval '$buffer =~ ' . $pattern if $buffer eq '';
	&eval_error;						# Make sure eval worked
	&update_backref(*matched);			# Record non-null backreferences
	$matched[0];						# Return matching status
}

# Matching is done on a header field which may contains multiple addresses
# This will not work if there is a ',' in the comment part of the addresses,
# but I never saw that and I don't want to write complex code for that--RAM.
# If a range is specified, then only the items specified by the range are
# actually used.
sub main'load_match_list {
	package main;
	local($selector, $pattern, $range) = @_;
	local($_) = $Header{$selector};	# Work on a copy of the line
	tr/\n/ /;						# Make one big happy line
	local(@list) = split(/,/);		# List of addresses
	local($min, $max) = &mrange($range, scalar(@list));
	return 0 unless $min;			# No matching possible if null range
	local($buffer);					# Buffer on which pattern matching is done
	local($matched) = 0;			# Set to true when matching has occurred
	@list = @list[$min - 1 .. ($max > $#list ? $#list : $max - 1)]
		if $min != 1 || $max != 9_999_999;
	foreach $buffer (@list) {
		# Call match_single to perform the actual match and supply the matching
		# buffer as the last argument. Note that since range does not make
		# any sense for single matches, undef is passed on instead.
		$matched = &match_single($selector, $pattern, undef, $buffer);
		last if $matched;
	}
	$matched;
}

# Look for a pattern in a multi-line context
sub main'load_match_var {
	package main;
	local($selector, $pattern, $range) = @_;
	local($lines) = 0;					# Number of lines in matching buffer
	my $target = \$Header{$selector};
	# Need to special-case Body to use the *decoded* version
	$target = $Header{'=Body='} if $selector eq 'Body';
	if ($range ne '<1,->') {			# Optimize: count lines only if needed
		$lines = $$target =~ tr/\n/\n/;
	}
	local($min, $max) = &mrange($range, $lines);
	return 0 unless $min;				# No matching possible if null range
	my $buffer;							# Buffer on which matching is attempted
	local(@buffer);						# Same, whith range line selected
	local(@matched);
	$pattern = &make_pattern($pattern);
	# Optimize, since range selection is the exception and not the rule.
	# Most likely, we use the default selection, i.e. we take everything...
	if ($min != 1 || $max != 9_999_999) {
		@buffer = split(/\n/, $$target);
		@buffer = @buffer[$min - 1 .. ($max > $#buffer ? $#buffer : $max - 1)];
		$buffer = join("\n", @buffer);		# Keep only selected lines
		undef @buffer;						# May be big, so free ASAP
		$target = \$buffer;
	}
	# Ensure multi-line matching by adding trailing "m" option to pattern
	@matched = eval '($$target =~ ' . $pattern . 'm);';
	# If buffer is empty, we have to recheck the pattern in a non array context
	# to see if there is a match. Otherwise, /(.*)/ does not seem to match an
	# empty string as it returns an empty string in $matched[0]...
	$matched[0] = eval '$$target =~ ' . $pattern . 'm' unless length $$target;
	&eval_error;						# Make sure eval worked
	&update_backref(*matched);			# Record non-null backreferences
	$matched[0];						# Return matching status
}

# Reseet the backreferences at the beginning of each rule match attempt
# The backreferences include %& and %1 .. %99.
sub main'load_reset_backref {
	package main;
	$macro_ampersand = '';			# List of matched generic selector
	@Backref = ();					# Stores backreferences provided by perl
}

# Update the backward reference array. There is a maximum of 99 backreferences
# per filter rule. The argument list is an array of all the backreferences
# found in the pattern matching, but the first item has to be skipped: it is
# the whole matching string -- see comment on make_pattern().
sub main'load_update_backref {
	package main;
	local(*array) = @_;				# Array holding $1 .. $9, $10 ..
	local($i, $val);
	for ($i = 1; $i < @array; $i++) {
		$val = $array[$i];
		push(@Backref, $val);		# Stack backreference for later perusal
		&add_log("stacked '$val' as backreference") if $loglvl > 18;
	}
}

# Return minimum and maximum for range value. A range is specified as <min,max>
# but '-' may be used as min for 1 and max as a symbolic constant for the
# maximum value. An arbitrarily large number is returned in that case. If a
# negative value is used, it is added to the number of items and rounded towards
# 1 if still negative. That way, it is possible to request the last 10 items.
# As a special case, <3> stands for <3,3> and thus <-> means everything.
sub main'load_mrange {
	package main;
	local($range, $items) = @_;
	local($min, $max) = (1, 9_999_999);
	local($rmin, $rmax);
	$rmin = $rmax = $1 if $range =~ /<\s*([\d-]+)\s*>/;
	($rmin, $rmax) = $range =~ /<\s*([\d-]*)\s*,\s*([\d-]*)\s*>/
		unless defined $rmin;
	$rmin = $min if $rmin eq '' || $rmin eq '-';
	$rmax = $max if $rmax eq '' || $rmax eq '-';
	$rmin = $rmin + $items + 1 if $rmin < 0;
	$rmax = $rmax + $items + 1 if $rmax < 0;
	$rmin = 1 if $rmin < 0;
	$rmax = 1 if $rmax < 0;
	($rmin, $rmax) = (0, 0) if $rmin > $rmax;	# Null range if min > max
	return ($rmin, $rmax);
}

# If the file name does not start with a '/', then it is assumed to be found
# in the mailfilter directory if defined, maildir otherwise, and the home
# directory finally. The function returns the full path of the file derived
# from those rules but does not actually check whether file exists or not.
sub main'load_locate_file {
	package main;
	local($filename) = @_;			# File we are trying to locate
	$filename =~ s/~/$cf'home/g;	# ~ substitution
	unless ($filename =~ m|^/|) {	# Do nothing if already a full path
		if (defined($XENV{'mailfilter'}) && $XENV{'mailfilter'} ne '') {
			$filename = $XENV{'mailfilter'} . "/$filename";
		} elsif (defined($XENV{'maildir'}) && $XENV{'maildir'} ne '') {
			$filename = $XENV{'maildir'} . "/$filename";
		} else {
			$filename = $cf'home . "/$filename";
		}
	}
	$filename =~ s/~/$cf'home/g;	# ~ substitution
	$filename;
}

# Locate specified program from command line by looking through the PATH
# like the shell would. Return the first matching program path or the program
# name if not found. Caller can check for the presence of '/' in the returned
# value to determine whether we succeeded. A leading ~ is replaced by the
# user's home directory.
sub main'load_locate_program {
	package main;
	local($_) = @_;
	undef while s/^\s*[<>]\s*\S+//;	# Strip leading >&1 or >file directives
	local($name) = /^\s*(\S+)/;
	$name =~ s/~/$cf'home/g;		# ~ substitution
	return $name if $name =~ m|/|;	# Absolute or relative path, no search

	foreach $dir (split(/:/, $ENV{'PATH'})) {
		$dir = '.' if $dir eq '';
		return "$dir/$name" if -x "$dir/$name";
	}

	return $name;		# Not found, return plain name
}

# Parse an address and returns (internet, comment)
# Examples:
#    ram@eiffel.com (Raphael Manfredi)  -> (ram@eiffel.com, Raphael Manfredi)
#    Raphael Manfredi <ram@eiffel.com>  -> (ram@eiffel.com, Raphael Manfredi)
# Note that we try to parse malformed RFC822 addresses to the best we can, by
# giving priority to anything between <> for correct e-mail address detection.
# Common errors include having a '<>' construct as part of the comment attached
# to the address as "name <surname> lastname", but this can only be followed
# by a <> address and the regexp is built so that it will skip the first <>
# and match only the last one on the line.
sub main'load_parse_address {
	package main;
	local($_) = shift(@_);		# The address to be parsed
	local($comment);
	local($internet);
	if (/^\s*(.*?)\s*<(\S+)>[^()]*$/) {		# comment <address>
		$comment = $1;
		$internet = $2;
		$comment =~ s/^"(.*)"/$1/;			# "comment" -> comment
		($internet, $comment);
	} elsif (/^\s*([^()]+?)\s*\((.*)\)/) {	# address (comment) 
		$comment = $2;
		$internet = $1;
		# Construct '<address> (comment)' is invalid but... priority to <>
		# This will also take care of "comment" <address> (other-comment)
		$internet =~ /<(\S+)>/ && ($internet = $1);
		($internet, $comment);
	} elsif (/^\s*<(\S+)>\s*(.*)/) {		# <address> ...garbage...
		($1, $2);
	} elsif (/^\s*\((.*)\)\s*<?(.*)>?/) {	# (comment) [address or <address>]
		($2, $1);
	} else {								# plain address, grab first word
		/^\s*(\S+)\s*(.*)/;
		($1, $2);
	}
}

# Parses an internet address and returns the login name of the sender. When
# facing an RFC 822 group addressing (like To: group:;), it returns the group
# name when mailbox is not specified.
sub main'load_login_name {
	package main;
	local($_) = shift(@_);				# The internet address
	if (/^(\S+):(\S*);/) {				# rfc-822-group:mailbox;
		if ($2 eq '') {
			&last_name($1);				# empty mailbox name, use phrase
		} else {
			&login_name($2);			# mailbox name
		}
	} elsif (s/^@\S+://) {				# @domain:user@other
		&login_name($_);				# parse user@other
	} elsif (s/^"(\S+)"@\S+/$1/) {		# "user@domain"@other
		&login_name($_);				# parse user@domain
	} elsif (s/^(\S+)@\S+/$1/) {		# user@domain.name
		&login_name($_);				# parse user
	} elsif (s/^(\S+)%\S+/$1/) {		# user%domain.name
		&login_name($_);				# parse user
	} elsif (s/^\S+!(\S+)/$1/) {		# ...!backbone!user
		&last_name($_);					# user can only be a simple name
	} else {							# everything else must be a single name
		&last_name($_);					# keep only last name
	}
}

# Lower-case name only
sub main'load_last_name {
	package main;
	local($_) = shift(@_);			# The sender's login name
	tr/A-Z/a-z/;					# And lowercase it
	$_;
}

# Parse an e-mail address and return a three element array:
#   ($host, $domain, $country)
sub main'load_internet_info {
	package main;
	local($_) = shift(@_);				# The internet address
	local($login) = &login_name($_);	# Get the address login name
	local($internet);					# The internet part of the address
	# Try with uucp form first, to detect things like eiffel!ram@inria.fr
	# We use the login name to anchor the last '!' or the first '@' or '%'
	($internet) = /([^!]*)!$login/i;
	($internet) = /$login[@%]([\w.-]*)/i unless $internet;
	$internet = &myhostname . ".$cf::domain" unless $internet;
	$internet =~ tr/A-Z/a-z/;				# Always lower-cased
	local(@parts) = split(/\./, $internet);	# Break on dots
	if (@parts == 1) {						# Only a host name
		# Maybe this is a local address, maybe this is a uucp name. Assume that
		# it is local if there is an '@' sign, as in 'ram@lyon'. Otherwise, it
		# is a uucp name, as in 'eiffel!ram'.
		push(@parts, 'uucp') if /!$login/;	# UUCP name
		push(@parts, split(/\./, $cf::domain)) if @parts == 1;
	}
	unshift(@parts, '') if @parts == 2;		# No host name
	@parts[($#parts - 2) .. $#parts];		# ($host, $domain, $country)
}

# Generate a unique message ID
sub main'load_gen_message_id {
	package main;
	my $now = time;
	my @alphabet = ('a' .. 'z', '0' .. '9', 'A' .. 'Z');
	my $randword = '';
	for (my $i = 0; $i < 10; $i++) {
		$randword .= $alphabet[rand @alphabet];
	}
	my $domain = &domain_addr;				# Local domain where we run
	my $id = "<mailagent-$now-$randword\@$domain>";
	&header'msgid_cleanup(\$id);			# Clean up: domain wrongly set?
	return $id;
}

# Macros substitutions (in-place)
sub main'load_macros_subst {
	package main;
	local(*str) = shift(@_);			# The string
	local($_) = $str;					# Work on a copy
	return $_ unless /%/;				# Return immediately if no macros

	local($sender);							# The from field
	local(@from);							# The rfc-822 parsed from line
	$sender = $Header{'From'};				# Header-derived From address
	@from = &parse_address($sender);		# Get (address, comment)
	local($login) = &login_name($from[0]);	# Keep only login name
	local($fullname) = $from[1];			# The comment part of address
	$fullname = $login unless $fullname;	# Use login name if no comment part
	local($reply_to) = $Header{'Reply-To'}; # Return path derived
	local($subject) = $Header{'Subject'};	# Original subject header
	$subject =~ s/^\s*Re:\s*(.*)/$1/;		# Strip off leading Re:
	$subject = "<empty subject>" unless $subject;
	$reply_to = (&parse_address($reply_to))[0];	# Keep only e-mail address

	# Time computations
	local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
			localtime(time);
	$mon = sprintf("%.2d", $mon + 1);
	$mday = sprintf("%.2d", $mday);
	local($timenow) = sprintf("%.2d:%.2d", $hour, $min);
	$hour = sprintf("%.2d", $hour);
	$year += 1900;

	# The following dummy block is here only to force perl interpreting
	# the $ variables in the substitutions correctly...
	if (0) {
		$Header{'a'} = 'a';
		$Variable{'a'} = 'a';
		$Backref[0] = 0;
	}

	s/%%/\01/g;							# Protect double percent signs
	s/%/\02!/g;							# Make sure substitutions do not add %

	&macro'over if defined &macro'over;	# Allow for internal override

	# In the following, substitutions marked as "workaround for perl 5.0 bug"
	# are fixing the fact that $1 will get clobbered if the routine used in
	# the substitution part is dataloaded.

	s/\02!A/&macro'internet/eg;			# Main internet address of sender
	s/\02!d/$mday/g;					# Day of the month (01-31)
	s/\02!C/&domain_addr/eg;			# CPU name, fully qualified with domain
	s/\02!D/$wday/g;					# Day of the week (0-6)
	s/\02!e/$cf'email/go;				# The user's email address
	s/\02!f/$Header{'From'}/g;			# The "From:" line
	s/\02!h/$hour/g;					# Hour of the day (00-23)
	s/\02!H/&myhostname/eg;				# Hostname on which mailagent runs
	s/\02!i/$Header{'Message-Id'}/g;	# Message-Id (null string if none)
	s/\02!I/&macro'domain/eg;			# Internet domain name of sender
	s/\02!l/$Header{'Lines'}/g;			# Number if lines in message
	s/\02!L/$Header{'Length'}/g;		# Length of message, in bytes
	s/\02!m/$mon/g;						# Month of the year
	s/\02!n/$login/g;					# Lower-cased login name of sender
	s/\02!N/$fullname/g;				# Full name of sender (login if none)
	s/\02!o/$orgname/g;					# Organization name
	s/\02!O/&macro'org/eg;				# Organization part of sender's address
	s/\02!r/$reply_to/g;				# Return path of message
	s/\02!R/$subject/g;					# Subject with leading Re: suppressed
	s/\02!s/$Header{'Subject'}/g;		# Subject of message
	s/\02!S/Re: $Header{'Subject'}/g;	# Re: subject of original message
	s/\02!t/$timenow/g;					# Current time HH:MM
	s/\02!T/$macro_T/g;					# Time of last modification on file
	s/\02!u/$cf'user/go;				# User login name (does not change)
	s/\02!U/$cf'name/go;				# User's name (does not change)
	s/\02!y/$year % 100/eg;				# Year (last two digits)
	s/\02!Y/$year/g;					# Year (yyyy format)
	s/\02!_/ /g;						# A white space
	s/\02!~//g;							# A null character
	s/\02!&/$macro_ampersand/g;			# List of matched generic selectors
	s/\02!(\d\d?)/$Backref[$1 - 1]/g;	# A pattern matching backreference
	s/\02!#:(\w+)/local($x) = $1; &extern'val($x)/eg;
		# A persistent user-defined variable (workaround for perl 5.0 PL0 bug)
	s/\02!#(\w+)/$Variable{$1}/g;		# A user-defined variable
	s/\02!\[([\w-]+)\]/$Header{$1}/g;	# The %[Field] macro
	s/\02!=(\w+)/"\$cf'$1"/gee;			# The %=config_var variable
	s/\02!-([^\s(])/local($x) = $1; &macro'usr($x)/ge;
		# A %-x single letter user macro (workaround for perl 5.0 PL0 bug)
	s/\02!-\(([^\s)]+)\)/local($x) = $1; &macro'usr($x)/ge;
		# A %-(complex) user-defined macro (workaround for perl 5.0 PL0 bug)

	s/\02!/%/g;							# Any remaining percent is kept
	s/\01/%/g;							# A double percent expands to %
	$str = $_;							# Update string in-place
}

# Return the internet information of the From address
sub macro'load_info {
	package macro;
	local($addr) = (&'parse_address($'Header{'From'}))[0];
	&'internet_info($addr);
}

# Return the organization name
sub macro'load_org {
	package macro;
	local($host, $domain, $country) = &info;
	$domain;
}

# Return the domain name
sub macro'load_domain {
	package macro;
	local($host, $domain, $country) = &info;
	$domain .'.'. $country;
}

# Return the qualified internet address
sub macro'load_internet {
	package macro;
	local($host, $domain, $country) = &info;
	$host ne '' ? $host .'.'. $domain .'.'. $country : $domain .'.'. $country;
}

# Record a new set of macros within the &over routine. Macros are defined
# using a low-level (ok, perl) description, but hey! this is an internal
# feature not intended to be used by others. The argument is a single string
# formatted this way:
#   <l> <value> <mod>
# where <l> is a single letter or group of letters, <value> is what will be
# substituted when the macro is seen, and <mod> are the perl modifiers that
# should be added at the end of the substitute perl statement.
sub macro'load_overload {
	package macro;
	local($macros) = @_;
	local(@macs) = split(/\n/, $macros);
	local($_);
	local($fn);					# Where the &over routine is built
	local($l, $value, $mod);
	$fn = "sub over {\n";
	foreach (@macs) {
		($l, $value, $mod) = split;
		$fn .= 's/\02!'.$l.'/'.$value."/g$mod;\n";
	}
	$fn .= "}\n";
	undef &over if defined &over;
	eval $fn;
	&'add_log("ERROR in &macro'overload: $@") if chop($@) && $'loglvl;
}

sub header'load_init {
	package header;
	# Main header fields which should be looked at when parsing a mail header
	%Mailheader = (
		'From', 1,
		'To', 1,
		'Subject', 1,
		'Date', 1,
	);
}

# Reset header checking status
sub header'load_reset {
	package header;
	&init unless $init_done++;		# Initialize private data
	$last_was_header = 0;			# Previous line was not a header
	$maybe = 0;						# Do we have a valid part of header?
	$line = 0;						# Count number of lines in header
}

# Is the current line still part of a valid header ?
sub header'load_valid {
	package header;
	local($_) = @_;
	return 1 if $last_was_header && /^\s/;	# Continuation line
	return -1 if /^$/;						# End of header
	$last_was_header = /^([\w\-]+):/ ? 1 : 0;
	# Activate $maybe when essential parts of a valid mail header are found
	# Any client can check 'maybe' to see if what has been parsed so far would
	# be a valid RFC-822 header, even though syntactically correct.
	$maybe |= $Mailheader{$1} if $last_was_header;
	$last_was_header = /^From\s+\S+/
		unless $last_was_header || $line;	# First line may be special
	++$line;								# One more line
	$last_was_header;						# Are we still inside header?
}

# Produce a warning header field about a specific item
sub header'load_warning {
	package header;
	local($field, $added) = @_;
	local($warning);
	local(@field) = split(' ', $field);
	$warning = 'X-Filter-Note: ';
	if ($added && @field == 1) {
		$warning .= "Header $field added at ";
	} elsif ($added && @field > 1) {
		$field = join(', ', @field);
		$field =~ s/^(.*), (.*)/$1 and $2/;
		$warning .= "Headers $field added at ";
	} else {
		$warning .= "Parsing error in original previous line at ";
	}
	$warning .= &main'domain_addr;
	$warning;
}

# Make sure header contains vital fields. The header is held in an array, on
# a line basis with final new-line chopped. The array is modified in place,
# setting defaults from the %Header array (if defined, which is the case for
# digests mails) or using local defaults.
sub header'load_clean {
	package header;
	local(*array) = @_;					# Array holding the header
	local($added) = '';					# Added fields

	$added .= &check(*array, 'From', $cf'user, 1);
	$added .= &check(*array, 'To', $cf'user, 1);
	$added .= &check(*array, 'Date', &mta_date(), 0);
	$added .= &check(*array, 'Subject', '<none>', 1);

	&push(*array, &warning($added, 1)) if $added ne '';
}

# Check presence of specific field and use value of %Header as a default if
# available and if '$use_header' is set, otherwise use the provided value.
# Return added field or a null string if nothing is done.
sub header'load_check {
	package header;
	local(*array, $field, $default, $use_header) = @_;
	local($faked);						# Faked value to be used
	if ($use_header) {
		$faked = (defined $'Header{$field}) ? $'Header{$field} : $default;
	} else {
		$faked = $default;
	}

	# Try to locate field in header
	local($_);
	foreach (@array) {
		return '' if /^$field:/;
	}

	&push(*array, "$field: $faked");
	$field . ' ';
}

# Push header line at the end of the array, without assuming any final EOH line
sub header'load_push {
	package header;
	local(*array, $line) = @_;
	local($last) = pop(@array);
	push(@array, $last) if $last ne '';	# There was no EOH
	push(@array, $line);				# Insert header line
	push(@array, '') if $last eq '';	# Restore EOH
}

# Compute a valid date field suitable for mail header:
#    Mon,  8 Jan 2001 05:14:00 +0100
# If optional $time arg is missing, use current time.
sub header'load_mta_date {
	package header;
	my ($time) = @_;
	$time = time unless defined $time;
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
	my ($gmmin, $gmhour, $gmyday) = (gmtime($time))[1,2,7];
	my @days   = qw(Sun Mon Tue Wed Thu Fri Sat);
	my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);

	# Compute delta in minutes between local time and GMT
	$yday = -1 if $gmyday == 0 && $yday >= 364;
	$gmyday = -1 if $yday == 0 && $gmyday >= 364;
	$gmhour += 24 if $gmyday > $yday;
	my $dhour = ($gmyday < $yday) ? $hour + 24 : $hour;
	my $dmin = ($dhour * 60 + $min) - ($gmhour * 60 + $gmmin);

	# Must convert delta into +/-HHMM format
	my $d = 100 * int($dmin / 60) + (abs($dmin) % 60) * ($dmin > 0 ? 1 : -1);

	sprintf "%s, %2d %s %4d %02d:%02d:%02d %+05d",
		$days[$wday], $mday, $months[$mon], 1900+$year, $hour, $min, $sec, $d;
}

# Normalizes header: every first letter is uppercase, the remaining of the
# word being lowercased, as in This-Is-A-Normalized-Header. Note that RFC-822
# does not impose such a formatting.
sub header'load_normalize {
	package header;
	local($field_name) = @_;			# Header to be normalized
	$field_name =~ s/(\w+)/\u\L$1/g;
	$field_name;						# Return header name with proper case
}

# Clean-up message ID string passed as reference.
# Returns true if string was changed.
sub header'load_msgid_cleanup {
	package header;
	my $mref = shift;
	local $_ = $$mref;
	my $fixup = 0;

	# Regexps are written to work on both a single <id> as found in Message-ID
	# lines, and on a space-separated list as found in References lines.

	s/>\s+</>\01</g;			# Protect spaces between IDs for References
	$fixup++ if s/\s/-/g;		# No spaces
	$fixup++ if s/_/-/g;		# No _ in names
	$fixup++ if s|/|-|g;		# No / in names
	$fixup++ if s/[(){}]//g;	# No () nor {} in names and ID
	$fixup++ if s/\.+>/>/g;		# No trailing dot(s)
	$fixup++ if s/\.\.+/./g;	# No consecutive dots
	s/<([^>]*?)>/'<' . &header'msgid_fix($1, \$fixup) . '>'/ge;
	s/>\01</> </g;				# Restore spaces between IDs
	$$mref = $_ if $fixup;
	return $fixup;
}

# Parse date from header and return its timestamp (seconds since the Epoch)
sub header'load_parsedate {
	package header;
	my ($str) = @_;

	# Look for +/-HHMM adjustment wrt GMT time
	my ($sign, $hh_d, $mm_d) = $str =~ /\s([-+])(\d\d)(\d\d)\b/;
	my $dt = 0;
	$dt = (($sign eq '+') ? +1 : -1) * ($hh_d * 60 + $mm_d) if $sign ne '';

	# Parse date to compute timestamp since Jan 1, 1970 GMT.
	return main::getdate($str, time, -$dt);
}

# Format header field to fit into 78 columns, each continuation line being
# indented by 4 chars. Returns the new formatted header string.
sub header'load_format {
	package header;
	my ($field) = @_;			# Field to be formatted
	my $tmp;					# Buffer for temporary formatting
	my $new = '';				# Constructed formatted header
	my $kept;					# Length of current line
	my $len = 78;				# Amount of characters kept
	my $cont = ' ' x 4;			# Continuation lines starts with 4 spaces
	# No need to format if length already fits the line
	if (length($field) <= $len) {
		# Normalize continuations
		return $cont . $field if $field =~ s/^\s+//;
		return $field;
	}
	# Adjust length down if we're just formatting a continuation line
	# This can happen when we're called from news_fmt().
	$len = 74 if $field =~ /^\s/;
	# Format header field, separating lines on ',' or space.
	while (length($field) > $len) {
		$tmp = substr($field, 0, $len);		# Keep first $len chars
		$tmp =~ s/^(.*)([,\s]).*/$1$2/;		# Cut at last space or ,
		$kept = length($tmp);				# Amount of chars we kept
		# We must ensure our hard split at $len chars does not fall within
		# a word: we can only split on ',' or space!
		if ($kept == $len) {
			for (;;) {
				my $s = substr($field, $kept, 1);
				last unless length $s;		# Reached end of string
				$kept++;
				$tmp .= $s;
				last if $s =~ /^[,\s]/;
			}
		}
		$tmp =~ s/\s+$//;					# Remove trailing spaces
		$tmp =~ s/^\s+//;					# Remove leading spaces
		if (length $tmp) {					# Avoid empty line within header!
			$len = 74;						# Account continuation for next line
			$new .= $cont if $new;			# Continuation starts with 8 spaces
			$new .= $tmp;
			$new .= "\n";
		}
		$field = substr($field, $kept);
	}
	unless ($field =~ /^\s*$/) {			# Not only spaces and not empty
		$new .= $cont if $new;				# Add 8 chars if continuation
		$new .= $field;						# Remaining information on one line
	}
	return $new;
}

# Same as format() but with extra magic for news articles: we must never
# emit a continuation right after a header, there must be a single space
# after the field name.
# Also, this routine must work when called to format a continuation (field
# stating with spaces).
# Finally, this routine ensures that the first line is not just the header
# name (even if there are continuation lines), so the first line can be
# longer than 80 chars to fulfill this constraint.
sub header'load_news_fmt {
	package header;
	my ($field) = @_;			# Field to be formatted
	my $len = 78;				# Amount of characters kept
	my $cont = ' ' x 4;			# Continuation lines starts with 4 spaces
	$field =~ s/^([\w-]+):(\S)/$1: $2/s;	# Ensure name is followed by space
	return $field if length $field <= $len;	# Nothing to change
	# The first line needs to be handled specially to not be split on the
	# first space, even if it becomes longer than our targeted length limit.
	my $new;
	if ($field =~ /^[\w-]+:/) {
		return $field unless $field =~ /^([\w-]+:\s+.+?[\s,])/;
		$new = $1;
	} else {
		unless ($field =~ /^(\s+.+?[\s,])/) {
			# No space to break-up the header line
			$field =~ s/^\s+//;
			# Do not emit line if it ends-up being empty...
			# Indeed, we're supposed to be emitting header-lines, and an
			# empty line would signal an EOH (End Of Header) condition!
			return '' if $field eq "\n";
			return $cont . $field;		# Normalize continuations
		}
		$new = $1
	}
	# Maybe we can fit more?
	while (length $new < $len) {
		my $tmp = substr($field, length $new);
		last unless $tmp =~ /^(.+?[\s,])/;
		my $extra = $1;
		last if length($new) + length($extra) > $len;
		$new .= $extra;
	}
	$field = substr($field, length $new);
	$new =~ s/\s+$//;			# Remove trailing spaces
	# Normalize continuation to 8 spaces
	$new = $cont . $new if $new =~ s/^\s+//;
	# Format the remaining normally now that we special-cased the first line
	# We add a leading space because we're formatting a continuation line.
	my $remaining;
	$field =~ s/^\s+//;
	$remaining = &format(" " . $field) unless $field =~ /^\s*$/;
	$remaining = $cont . $remaining if length $remaining;
	return $new . "\n" . $remaining;
}

# Scan the head of a file and try to determine whether there is a mail
# header at the beginning or not. Return true if a header was found.
sub main'load_header_found {
	package header;
	local($file) = @_;
	local($correct) = 1;				# Were all the lines from top correct ?
	local($_);
	open(FILE, $file) || return 0;		# Don't care to report error
	&reset;								# Initialize header checker
	while (<FILE>) {					# While still in a possible header
		last if /^$/;					# Exit if end of header reached
		$correct = &valid($_);			# Check line validity
		last unless $correct;			# No, not a valid header
	}
	close FILE;
	$correct;
}

# The "LEAVE" command
# Leave a copy of the message in the mailbox. Returns (mbox, failed_status)
sub main'load_leave {
	package main;
	local($mailbox) = &mailbox_name;	# Incomming mailbox filename
	&add_log("starting LEAVE") if $loglvl > 15;
	&save($mailbox);					# Propagate return status
}

# The "SAVE" command
# Save a message in a folder. Returns (mbox, failed_status). If the folder
# already exists and has the 'x' bit set, then is is understood as an external
# hook and mailhook is invoked. If the folder name begins with '+', it is
# handled as an MH folder. If the folder is actually a directory, then message
# is saved in an individual file, much like an MH folder.
sub main'load_save {
	package main;
	local($mailbox) = @_;			# Where mail should be saved
	local($failed) = 0;				# Printing status
	if ($mailbox eq '') {			# Empty mailbox (e.g. SAVE %1 with no match)
		$mailbox = &mailbox_name;
		&add_log("WARNING empty folder name, using $mailbox") if $loglvl > 5;
	}
	local($biffing) = $env'biff =~ /ON/i;	# Whether we should biff or not
	local($type) = 'file';					# Folder type, for biffing macros
	&add_log("starting SAVE $mailbox") if $loglvl > 15;
	if ($mailbox =~ s/^\+//) {		# MH folder?
		$type = 'MH';
		$failed = &mh'save($mailbox);
	} elsif (-d $mailbox) {			# A directory hook
		$failed = &mh'savedir($mailbox);
		$type = 'dir';
	} elsif (-x $mailbox) {			# Folder hook
		$failed = &save_hook;		# Deliver to program
		$biffing = 0;				# No biffing for hooks
	} else {						# Saving to a normal folder
		# Uncompress folders if necessary. The restore routine will perform
		# the necessary checks and return immediately if no compression is
		# wanted for that particular folder. However, we can avoid the overhead
		# of calling this routine (and loading it when using dataloading) if
		# the 'compress' configuration parameter is missing.
		&compress'restore($mailbox) if $cf'compress;
		$failed = &save_folder($mailbox);
	}
	&add_log("ERROR could not save mail in $mailbox") if $failed && $loglvl;
	&emergency_save if $failed;

	# At this point, folder_saved has been updated to the path of the folder
	# where message has been saved, unless it was a hook but in that case we
	# do not biff anyway.
	&biff($folder_saved, $type) if $biffing && !$failed;

	($mailbox, $failed);			# Where save was made and failure status
}

# Called by &save when folder is a regular one (i.e. not a hook).
sub main'load_save_folder {
	package main;
	local($mailbox) = @_;			# Where mail should be saved
	local($amount);					# Amount of bytes written
	local($failed);
	# Explicitely check for writable mailbox. I've seen an NFS between a SUN
	# and a file on DEC OSF/1 accept appending while file was read-only...
	# We may only perform the open if the file does not exist or is writable.
	local($exist) = -e $mailbox;	# Run chmod if PROTECT used and created
	local($mayopen) = !$exist || -w _;
	if ($mayopen && open(MBOX, ">>$mailbox")) {

		local($ret) = &mbox_lock($mailbox);	# Lock mailbox, get exclusive access
		return 1 unless defined $ret;		# Unable to lock, fail miserably
		local($size) = -s $mailbox;			# Initial mailbox size

		# It's still possible we did not get any lock on the mailbox, or just
		# a partial lock, but the user did tell us that was ok, via the
		# 'locksafe' variable setting. Simply emit a notice that we're
		# delivering without locking.

		&add_log("NOTICE saving to non-locked $mailbox")
			if !$ret && $loglvl > 6;

		# If MMDF-style mailboxes are allowed, then the saving routine will
		# try to determine what kind of folder it is delivering to and choose
		# the right format. Otherwise, standard Unix format is assumed.

		if ($cf'mmdf =~ /on/i) {	# MMDF-style allowed
			# Save to mailbox, selecting the right format (UNIX vs MMDF)
			($failed, $amount) = &mmdf'save(*MBOX, $mailbox);
		} else {
			# Save to UNIX folder
			($failed, $amount) = &mmdf'save_unix(*MBOX);
		}

		# Because we might write over NFS, and because we might have had to
		# force fate to get a lock, it is wise to make sure the folder has the
		# right size, which would tend to indicate the mail made it to the
		# buffer cache, if not to the disk itself.
		local($should) = $size + $amount;	# Computed new size for mailbox
		local($new_size) = -s $mailbox;		# Last write was flushed to disk
		&add_log("ERROR $mailbox has $new_size bytes (should have $should)")
			if $new_size != $should && $loglvl;
		$failed = 1 if $new_size != $should;

		# Finally, release the lock on the mailbox and close the file. If the
		# closing operation fails for whatever reason, the routine will return
		# a 1, so $failed will be set. Of course, "normally" it should not
		# fail at that point, since the mail was previously flushed.
		$failed |= &mbox_unlock($mailbox);	# Will close file

		# Now adjust permissions on the file, if created and PROTECT was used.
		&mmdf'chmod($env'protect, $mailbox) if !$exist && defined $env'protect;

	} else {
		local($msg) = $mayopen ? "$!" : 'Permission denied';
		&add_log("SYSERR open: $msg") if $loglvl;
		if (-f "$mailbox") {
			&add_log("ERROR cannot append to $mailbox") if $loglvl;
		} else {
			&add_log("ERROR cannot create $mailbox") if $loglvl;
		}
		$failed = 1;
	}
	$folder_saved = $mailbox;	# Keep track of last folder we save into
	$failed;					# Propagate failure status
}

# Called by &save when folder is a hook.
# Note that as opposed to other folder saving routines, we do not update the
# $folder_saved variable when saving into a hook. This is because the hook
# might be another set of filtering rules or a perl escape taking care of its
# own saving, in which case we do not want to corrupt the saved location.
# Return command failure status.
sub main'load_save_hook {
	package main;
	local($failed) = &hook'process($mailbox);
	&add_log("HOOKED [$mfile]") if !$failed && $loglvl > 2;
	$failed;				# Propagate failure status
}

# The "PROCESS" command
# The body of the message is expected to be in $Header{'Body'}
sub main'load_process {
	package main;
	local($subj) =			$Header{'Subject'};
	local($msg_id) =		$Header{'Message-Id'};
	local($sender) =		$Header{'Reply-To'};
	local($to) =			$Header{'To'};
	local($bad) = "";		# No bad commands
	local($pack) = "auto";	# Default packing mode for sending files
	local($ncmd) = 0;		# Number of valid commands we have found
	local($dest) = "";		# Destination (where to send answers)
	local(@cmd);			# Array of all commands
	local(%packmode);		# Records pack mode for each command
	local($error) = 0;		# Error report code
	local(@body);			# Body of message

	&add_log("starting PROCESS") if $loglvl > 15;

	# If no @PATH directive was found, use $sender as a return path
	$dest = $Userpath;				# Set by an @PATH
	$dest = $sender unless $dest;
	# Remove the <> if any (e.g. path derived from Return-Path)
	$dest = (&parse_address($dest))[0];

	# Debugging purposes
	&add_log("\@PATH was '$Userpath' and sender was '$sender'")
		if $loglvl > 18;
	&add_log("computed destination: $dest") if $loglvl > 15;

	# Make sure address is not hostile. Since a transcript is sent to the
	# sender computed in $dest, we cannot inform the user if the address
	# turns out to be really hostile.

	unless (&addr'valid($dest)) {
		&add_log("ERROR $dest is an hostile sender address") if $loglvl > 1;
		&add_log("NOTICE discarding whole command mail") if $loglvl > 6;
		return 0;	# An error would requeue message
	}

	# Copy body of message in an array, one line per entry
	@body = split(/\n/, $Header{'Body'});

	# The command file contains the authorized commands
	if ($#command < 0) {			# Command file not processed yet
		open(COMMAND, "$cf'comfile") || &fatal("No command file!");
		while (<COMMAND>) {
			chop;
			$command{$_} = 1;
		}
		close(COMMAND);
	}

	line: foreach (@body) {
		# Built-in commands
		if (/^\@PACK\s*(.*)/) {		# Pack mode
			$pack = $1 if $1 ne '';
			$pack = "" if ($pack =~ /[=$^&*([{}`\\|;><?]/);
		}
		s/^[ \t]\@SH/\@SH/;	# allow one blank only
		if (/^\@SH/) {
			s/\\!/!/g;		# if uucp address, un-escape `!'
			if (/[=\$^&*([{}`\\|;><?]/) {
				s/^\@SH/bad command:/;	# space after ":" will be added
				$bad .= $_ . "\n";
				next line;
			}
			# Some useful substitutions
			s/\@SH[ \t]*//;				# Allow leading blanks
			s/ PATH/ $dest/; 			# PATH is a macro
			s/^mial(\w*)/mail$1/;		# Common mis-spellings
			s/^mailpath/mailpatch/;
			s/^mailist/maillist/;
			s/^help/mailhelp/i;
			# Now fetch command's name (first symbol)
			if (/^([^ \t]+)[ \t]/) {
				$first = $1;
			} else {
				$first = $_;
			}
			if (!$command{$first}) {	# if un-authorized cmd
				s/^/unknown cmd: /;		# needs a space after ":"
				$bad .= $_ . "\n";
				next line;
			}
			$packmode{$_} = $pack;		# packing mode for this command
			push(@cmd, $_);				# record command
		}
	}

	# ************* Check with authoritative file ****************

	# Do not continue if an error occurred, in which case the mail will remain
	# in the queue and will be processed later on.
	return $error if $error || $dest eq '';

	# Now we are sure the mail we proceed is for us
	$sender = "<someone>" if $sender eq '';
	$ncmd = $#cmd + 1;
	if ($ncmd > 1) {
		&add_log("$ncmd commands for $sender") if $loglvl > 11;
	} elsif ($ncmd == 1) {
		&add_log("1 command for $sender") if $loglvl > 11;
	} else {
		&add_log("no command for $sender") if $loglvl > 11;
	}
	foreach $fullcmd (@cmd) {
		$cmdfile = "/tmp/mess.cmd$$";
		open(CMD,">$cmdfile");
		# For our children
		print CMD "jobnum=$jobnum export jobnum\n";
		print CMD "fullcmd=\"$fullcmd\" export fullcmd\n";
		print CMD "pack=\"$packmode{$fullcmd}\" export pack\n";
		print CMD "path=\"$dest\" export path\n";
		print CMD "sender=\"$sender\" export sender\n";
		print CMD "set -x\n";
		print CMD "$fullcmd\n";
		close CMD;
		$fullcmd =~ /^[ \t]*(\w+)/;		# extract first word
		$cmdname = $1;		# this is the command name
		$trace = "$cf'tmpdir/trace.cmd$$";

		# For HPUX-10.x, grrr... have to use our own shell otherwise that
		# silly posix /bin/sh dumps core when fed the $cmdfile we built above.
		local($shell) = &cmdserv'servshell;

		$pid = fork;						# We fork here
		$pid = -1 unless defined $pid;

		if ($pid == 0) {
			open(STDOUT, ">$trace");		# Where output goes
			open(STDERR, ">&STDOUT");		# Make it follow pipe
			exec $shell, "$cmdfile";		# Don't use sh -c
		} elsif ($pid == -1) {
			# Set the error report code, and the mail will remain in queue
			# for later processing. Any @RR in the message will be re-executed
			# but it is not really important. In fact, this is going to be
			# a feature, not a bug--RAM.
			$error = 1;
			&add_log("ERROR cannot fork: $!") if $loglvl > 0;
			unless (open(MAILER,"|$cf'sendmail $cf'mailopt $dest $cf'email")) {
				&add_log("SYSERR fork: $!") if $loglvl;
				&add_log("ERROR cannot launch $cf'sendmail") if $loglvl;
			}
			print MAILER <<EOM;
To: $dest
Subject: $cmdname not executed
$MAILER

Your command was: $fullcmd

It was not executed because I could not fork. Sigh !
(Kernel report: $!)

The command has been left in a queue and will be processed again
as soon as possible, so it is useless to resend it.

-- mailagent speaking for $cf'user
EOM
			close MAILER;
			if ($?) {
				&add_log("ERROR cannot report failure") if $loglvl;
			}
			return $error;		# Abort processing now--mail remains in queue
		} else {
			wait();
			if ($?) {
				unless (
					open(MAILER,"|$cf'sendmail $cf'mailopt $dest $cf'email")
				) {
					&add_log("SYSERR fork: $!") if $loglvl;
					&add_log("ERROR cannot launch $cf'sendmail") if $loglvl;
				}
				print MAILER <<EOM;
To: $dest
Subject: $cmdname returned a non-zero status
$MAILER

Your command was: $fullcmd
It produced the following output and failed:

EOM
				if (open(TRACE, $trace)) {
					while (<TRACE>) {
						print MAILER;
					}
					close TRACE;
				} else {
					print MAILER "** SORRY - NOT AVAILABLE **\n";
					&add_log("ERROR cannot dump trace") if $loglvl;
				}
				print MAILER "\n-- mailagent speaking for $cf'user\n";
				close MAILER;
				if ($?) {
					&add_log("ERROR cannot report failure") if $loglvl;
					&trace_dump($trace, "failed $fullcmd");
				}
				&add_log("FAILED $fullcmd") if $loglvl > 1;
			} else {
				&add_log("OK $fullcmd") if $loglvl > 5;
			}
		}
		unlink $cmdfile, $trace;
	}

	if ($bad) {
		unless (open(MAILER,"|$cf'sendmail $cf'mailopt $dest $cf'email")) {
			&add_log("SYSERR fork: $!") if $loglvl;
			&add_log("ERROR cannot launch $cf'sendmail") if $loglvl;
		}
		chop($bad);			# Remove trailing new-line
		# For unknown reasons, perl 4.0 PL36 chokes here when a here-document
		# syntax is used. Although it compiles fine, no output seems to be
		# sent on the MAILER descriptor. Use a string then... That's funny
		# though becase here-document syntax is used elsewhere without problems.
		print MAILER
"To: $dest
Subject: the following commands were not executed
$MAILER

$bad

If $cf'name can figure out what you wanted, he may do it anyway.

-- mailagent speaking for $cf'user
";
		close MAILER;
		if ($?) {
			&add_log("ERROR unable to mail back bad commands from $sender")
				if $loglvl;
		}
		&add_log("bad commands from $sender") if $loglvl > 5;
	}

	&add_log("all done for $sender") if $loglvl > 11;
	$error;		# Return error report (0 for ok)
}

# The "MACRO" command
sub main'load_macro {
	package main;
	local($args) = @_;				# name = (value, type)
	local($replace) = $opt'sw_r;	# Replace existing macro
	local($delete) = $opt'sw_d;		# Delete macro
	local($pop) = $opt'sw_p;		# Pop macro
	local($name);					# Macro's name
	if ($delete || $pop) {			# Macro is to be deleted or popped
		($name) = $args =~ /(\S+)/;	# Get first "word"
		&usrmac'pop($name) if $pop;	# Pop last value, delete if last
		&usrmac'delete($name) if $delete;
		return ($name, $pop ? 'popped' : 'deleted');	# Propagate action
	}
	# There are two formats for the macro command. The first format uses the
	# 'name = (val, type)' template and can be used to specify any kind of
	# macro (see usrmac.pl). The other form is name ..., where ... is any
	# kind of string --including spaces-- which will be used as a SCALAR
	# value. Of course, that string cannot take the '= (val, type)' format.
	local($val);					# Macro's value
	local($type) = 'SCALAR';		# Assume scalar type
	if ($args =~ /(\S+)\s*=\s*\(\s*(.*),\s*(\w+)\s*\)\s*/) {
		($name, $val, $type) = ($1, $2, $3);
	} else {
		($name, $val) = $args =~ /(\S+)\s+(.*)/;	# SCALAR type assumed
	}
	&usrmac'new($name, $val, $type) if $replace;
	&usrmac'push($name, $val, $type) unless $replace;
	($name, $replace ? 'replaced' : 'pushed');		# Propagate action
}

# The "MESSAGE" command
sub main'load_message {
	package main;
	local($msg) = @_;			# Vacation message to be sent back
	local(@head) = (
		"To: %r (%N)",
		"Subject: Re: %R"
	);
	local($to) = '%r';				# Recipient is macro %r
	&macros_subst(*to);				# Evaluate it so we can give it to mailer
	&send_message($msg, *head, $to);
}

# The "NOTIFY" command
sub main'load_notify {
	package main;
	local($msg, $address) = @_;
	# Any address included withing "" means addresses are stored in a file
	$address = &complete_list($address, 'address');
	$address =~ s/%/%%/g;	# Protect all '%' (subject to macro substitution)
	local($to) = $address;	# For the To: line...
	$to =~ s/\s+/, /g;		# Addresses separated by ',' on the To: line
	local(@head) = (
		"To: $to",
		"Subject: %s (notification)"
	);
	&send_message($msg, *head, $address);
}

# Send a given message to somebody, as specified in the given header
# The message and the header are subject to macro substitution.
# Usually, when using sendmail, the -t option could be used to parse header
# and obtain the recipients. However, the mailer being configurable, we cannot
# assume it will understand -t. Therefore, the recipients must be specified.
sub main'load_send_message {
	package main;
	local($msg, *header, $recipients) = @_;	# Message to send, header, where
	unless (-f "$msg") {
		&add_log("ERROR cannot find message $msg") if $loglvl > 0;
		return 1;
	}
	unless (open(MSG, "$msg")) {
		&add_log("ERROR cannot open message $msg") if $loglvl > 0;
		return 1;
	}

	# Construction of value for the %T macro
	local($macro_T);			# Default value of macro %T is overwritten
	local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime, $mtime,
		$ctime,$blksize,$blocks) = stat($msg);
	local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
			localtime($mtime);
	local($this_year) = (localtime(time))[5];
	# Do not put the year in %T if it is the same as the current one.
	++$mon;						# Month in the range 1-12
	if ($this_year != $year) {
		$macro_T = sprintf("%.2d/%.2d/%.2d", $year % 100, $mon, $mday);
	} else {
		$macro_T = sprintf("%.2d/%.2d", $mon, $mday);
	}

	# Header construction. If the file contains a header at the top, it is
	# added to the one we already have by default. Identical fields are
	# overwritten with the one found in the file.
	# BUG: Multiple line headers are incorrectly overridden by the grep()
	# below: only the first line is taken into account!
	if (&header_found($msg)) {	# Top of message is a header
		local(@newhead);		# New header is constructed here
		local($cc) = '';		# Carbon copy recipients
		local($collect) = 0;	# True when collecting recipients
		local($field);
		local($_);
		while (<MSG>) {			# Read the header then
			last if /^$/;		# End of header
			chop;
			push(@newhead, $_);
			if (/^([\w\-]+):(.*)/) {
				$field = $1;
				$_ = $2;
				@head = grep(!/^$field:/, @head);	# Field is overwritten

				# The following used to be done directly by sendmail -t.
				# However, mailagent does not make use of that option any
				# longer since $cf'sendmail might not be sendmail and the
				# mailer used might therefore not understand this -t option.

				$collect = ($field =~ /^b?cc$/i);
				$cc .= &macros_subst(*_) if $collect;
			} else {
				$cc .= &macros_subst(*_) if $collect;	# Continuation lines
			}
		}
		foreach (@newhead) {
			push(@head, $_);
		}

		# Now update the recipient line by parsing $cc and extracting the
		# e-mail addresses, discarding the comments. Note that this code
		# will fail if ',' is used in address comments.

		local(@addr) = split(/,/, $cc);
		foreach $addr (@addr) {
			$recipients .= ' ' . (&parse_address($addr))[0];
		}
	}

	# Remove duplicate e-mail addresses in the recipient list. Again,
	# mailagent used to rely on sendmail to do this, but we can't assume
	# any user-defined mailer will do it.
	local(%seen);
	foreach $addr (split(' ', $recipients)) {
		$seen{$addr}++;
	}
	$recipients = join(' ', sort keys %seen);
	undef %seen;

	unless (open(MAILER,"|$cf'sendmail $cf'mailopt $recipients")) {
		&add_log("ERROR cannot run $cf'sendmail to send message: $!")
			if $loglvl;
		close MSG;
		return 1;
	}

	push(@head, $FILTER);		# Avoid loops: replying to ourselves or whatever
	foreach $line (@head) {
		&macros_subst(*line);	# In-place macro substitutions
		print MAILER "$line\n";	# Write header
	}
	print MAILER "\n";			# Header separated from body
	# Now write the body
	local($tmp);				# Because of a bug in perl 4.0 PL19
	while (defined ($tmp = <MSG>)) {
		next if $tmp =~ /^$/ && $. == 1;	# Escape sequence to protect header
		&macros_subst(*tmp);		# In-place macro substitutions
		print MAILER $tmp;			# Write message line
	}

	# Close pipe and check status
	close MSG;
	close MAILER;
	local($status) = $?;
	unless ($status) {
		if ($loglvl > 2) {
			local($dest) = $head[0];	# The To: header line
			($dest) = $dest =~ m|^To:\s+(.*)|;
			&add_log("SENT message to $dest");
		}
	} else {
		&add_log("ERROR could not mail back $msg") if $loglvl > 1;
	}
	$status;		# 0 for success
}

# The "FORWARD" command
sub main'load_forward {
	package main;
	local($addresses) = @_;			# Address(es) mail should be forwarded to
	local($address) = $cf'email;	# Address of user
	# Any address included withing "" is in fact a file name where actual
	# forwarding addresses are found.
	$addresses =
		&complete_list($addresses, 'address');	# Process "include-requests"
	local($saddr);					# Address list for shell command
	($saddr = $addresses) =~ s/([()'"<>$;])/\\$1/g;
	unless (open(MAILER,"|$cf'sendmail $cf'mailopt $saddr")) {
		&add_log("ERROR cannot run $cf'sendmail to forward message: $!")
			if $loglvl;
		return 1;
	}
	local $SIG{PIPE} = 'IGNORE';	# sendmail failure caught at close() time
	local(@addr) = split(' ', $addresses);
	print MAILER &header'format("Resent-From: $address"), "\n";
	local($to) = "Resent-To: " . join(', ', @addr);
	print MAILER &header'format($to), "\n";
	# Protect Sender: and Resent-: lines in the original message
	foreach (split(/\n/, $Header{'Head'})) {
		next if /^From\s+(\S+)/;
		s/^Sender:\s*(.*)/Prev-Sender: $1/;
		s/^Resent-([\w\-]+):\s*(.*)/Prev-Resent-$1: $2/;
		print MAILER $_, "\n";
	}
	print MAILER $FILTER, "\n";
	print MAILER "\n";
	# If sendmail is used and there is no -i flag in the options, we need to
	# escape dots on a line by themselves.
	if ($cf'sendmail =~ /\bsendmail\b/ && $cf'mailopt !~ /-i\b/) {
		my $body = $Header{'Body'};
		$body =~ s/^\./../gm;
		print MAILER $body;
		&add_log("WARNING sendmail used -- you should add -i to mailopt")
			if $loglvl > 2;
	} else {
		print MAILER $Header{'Body'};
	}
	close MAILER;
	local($failed) = $?;		# Status of forwarding
	if ($failed) {
		&add_log("ERROR could not forward to $addresses") if $loglvl > 1;
	}
	$failed;		# 0 for success
}

# The "BOUNCE" command
sub main'load_bounce {
	package main;
	local($addresses) = @_;			# Address(es) mail should be bounced to
	# Any address included withing "" is in fact a file name where actual
	# bouncing addresses are found.
	$addresses =
		&complete_list($addresses, 'address');	# Process "include-requests"
	local($saddr);					# Address list for shell command
	($saddr = $addresses) =~ s/([()'"<>$;])/\\$1/g;
	unless (open(MAILER,"|$cf'sendmail $cf'mailopt $saddr")) {
		&add_log("ERROR cannot run $cf'sendmail to bounce message: $!")
			if $loglvl;
		return 1;
	}
	local $SIG{PIPE} = 'IGNORE';	# sendmail failure caught at close() time
	# Protect Sender: lines in the original message
	foreach (split(/\n/, $Header{'Head'})) {
		next if /^From\s+(\S+)/;
		s/^Sender:\s*(.*)/Prev-Sender: $1/;
		print MAILER $_, "\n";
	}
	print MAILER $FILTER, "\n";
	print MAILER "\n";
	# If sendmail is used and there is no -i flag in the options, we need to
	# escape dots on a line by themselves.
	if ($cf'sendmail =~ /\bsendmail\b/ && $cf'mailopt !~ /-i\b/) {
		my $body = $Header{'Body'};
		$body =~ s/^\./../gm;
		print MAILER $body;
		&add_log("WARNING sendmail used -- you should add -i to mailopt")
			if $loglvl > 2;
	} else {
		print MAILER $Header{'Body'};
	}
	close MAILER;
	local($failed) = $?;		# Status of forwarding
	if ($failed) {
		&add_log("ERROR could not bounce to $addresses") if $loglvl > 1;
	}
	$failed;		# 0 for success
}

# The "POST" command
sub main'load_post {
	package main;
	local($newsgroups) = @_;		# Newsgroup(s) mail should be posted to
	local($localdist) = $opt'sw_l;	# Local distribution if POST -l
	local($wantbiff) = $opt'sw_b;	# Biffing activated upon success
	unless (open(NEWS,"|$cf'sendnews $cf'newsopt -h")) {
		&add_log("ERROR cannot run $cf'sendnews to post message: $!")
			if $loglvl;
		return 1;
	}
	&add_log("distribution of posting is local")
		if $loglvl > 18 && $localdist;

	# The From: header we're generating in the news is correctly formatted
	# and escaped, to avoid rejects by the news server.
	# We'll let any Reply-To header through, since RFC-1036 defines them
	# for this purpose (i.e. the same as for mail), but we don't reformat
	# the Reply-To since it's not a required header.
	my ($faddr, $fcom) = &parse_address($Header{'From'});
	$fcom = '"' . $fcom . '"' if $fcom =~ /[@.\(\)<>,:!\/=;]/;
	if ($fcom ne '') {
		print NEWS header::news_fmt("From: $fcom <$faddr>\n");
	} else {
		print NEWS "From: $faddr\n";
	}

	# The Date: field must be parseable by INN, and not be in the future
	# or the article would be rejected.  Articles too far in the past (outside
	# the history range) are also rejected, but we don't know what is
	# configured.  As a precaution, dates older than 14 days (the default INN
	# setting) are patched.
	unless (defined $Header{'Date'} && $Header{'Date'} ne '') {
		&add_log("WARNING no Date, faking one") if $loglvl > 5;
		my $date = &header'mta_date();
		print NEWS "Date: $date\n";
	} else {
		my $str = $Header{'Date'};
		my $when = &header'parsedate($str);
		my $now = time;
		my $date;
		my $AGEMAX = 10 * 86400;		# 10 days
		my $THRESH = 86400;				# 1 day
		my $WARN_THRESH = 600;			# 10 minutes
		if ($when < 0) {
			&add_log("WARNING can't parse Date field '$str', adjusting")
				if $loglvl > 5;
			$date = &header'mta_date($now);
		} elsif ($when > $now) {
			my $rel = &relative_age($when - $now);
			my $adjusting = '';
			my $stamp = $when;
			my $delta = $when - $now;
			if ($delta >= $THRESH) {	# More than a day, adjust!
				$stamp = $now;
				$adjusting = ", adjusting";
			}
			&add_log("WARNING Date field is $rel in the future$adjusting")
				if $loglvl > 5 && $delta >= $WARN_THRESH;
			$date = &header'mta_date($stamp);
		} elsif (($now - $when) >= $AGEMAX) {
			my $rel = &relative_age($now - $when);
			&add_log("WARNING Date field too ancient ($rel), adjusting")
				if $loglvl > 5;
			$date = &header'mta_date($now - $AGEMAX + 3600);
		} else {
			$date = &header'mta_date($when);	# Regenerate properly
		}
		print NEWS "Date: $date\n";
		print NEWS "X-Orig-Date: $str\n" if lc($date) ne lc($str);
	}

	# If no Subject is present, fake one to make inews happy
	unless (defined($Header{'Subject'}) && $Header{'Subject'} ne '') {
		&add_log("WARNING no Subject, faking one") if $loglvl > 5;
		print NEWS "Subject: <none>\n";
	} else {
		my $subject = $Header{'Subject'};
		$subject =~ tr/\n/ /;				# Multiples instances collapsed
		print NEWS header::news_fmt("Subject: $subject\n");
	}

	# If no proper Message-ID is present, generate one
	# If one is present, perform sanity fixups because INN is really picky
	my $msgid;
	unless (defined($Header{'Message-Id'}) && $Header{'Message-Id'} ne '') {
		&add_log("WARNING no Message-Id, faking one") if $loglvl > 5;
		$msgid = &gen_message_id;
	} else {
		($msgid) = $Header{'Message-Id'} =~ /(<[^>]+@[^>]+>)/;
		if ($msgid ne '') {
			# Fixups are always the same, therefore they don't prevent proper
			# duplicate detection provided all feeds are done from mailagent
			# But we also need to fix places using those message IDs, i.e.
			# the References line, to preserve correct threading (see below).
			my $fixup = header::msgid_cleanup(\$msgid);
			&add_log("WARNING fixed Message-Id line for news")
				if $loglvl > 5 && $fixup;
		} else {
			&add_log("WARNING bad Message-Id line, faking one") if $loglvl > 5;
			$msgid = &gen_message_id;
		}
	}
	print NEWS "Message-ID: $msgid\n";

	# If there is a Followup-To line, ignore it, unless it says "poster".
	my $followup = $Header{'Followup-To'};
	if ($followup =~ /\bposter\b/) {
		print NEWS "Followup-To: poster\n";
	} elsif ($followup ne '') {
		&add_log("WARNING stripped Followup-To: $followup")
			if $loglvl > 5;
	}

	# Protect Sender: lines in the original message and clean-up header
	local($last_was_header);		# Set to true when header is skipped

	# Need at most one of the following headers, lest article might be rejected
	my %single = map { lc($_) => 0 } qw(
		Mime-Version
		Content-Transfer-Encoding
		Content-Type
		Reply-To
	);

	foreach (split(/\n/, $Header{'Head'})) {
		next if /^From\s/;					# First From line...
		if (
			/^From:/i				||		# This one was cleaned up above
			/^Subject:/i			||		# This one handled above
			/^Message-Id:/i			||		# idem
			/^Followup-To:/i		||		# idem
			/^Date:/i				||		# idem
			/^In-Reply-To:/i		||
			/^References:/i			||		# One will be faked if missing
			/^Apparently-To:/i		||
			/^Distribution:/i		||		# No mix-up, please
			/^Control:/i			||
			/^Xref:/i				||
			/^NNTP-Posting-.*:/i	||		# Cleanup for NNTP server
			/^Originator:/i			||		# Probably from news->mail gateway
			/^Newsgroups:/i			||		# Reply from news reader
			/^Return-Receipt-To:/i	||		# Sendmail's acknowledgment
			/^Received:/i			||		# We want to remove this MTA trace
			/^Delivered-To:/i		||		# idem
			/^Precedence:/i			||
			/^DKIM-Signature:/i		||		# INN2 does not like this field
			/^Accept-?[\w-]*:/i		||		# INN2 does not like this field
			/^Auth-?[\w-]*:/i		||		# INN2 does not like this field
			/^X-[\w-]+:/i			||		# INN2 does not like these fields
			/^Injection-[\w-]+:/i	||		# INN2 does not like these fields
			/^Errors-To:/i					# Error report redirection
		) {
			$last_was_header = 1;			# Mark we discarded the line
			next;							# Line is skipped
		}
		# Skip any RFC-822 header that is not purely made up of [\w-]+
		# as it is not possible it can be meaningful to the news system.
		if (/^([!-9;-~\w-]+):/) {
			my $header = $1;
			$header = &header::normalize($header);
			unless ($header =~ /^[\w-]+$/) {
				&add_log("NOTICE droping RFC-822 header \"$header\" for news")
					if $loglvl > 5;
				$last_was_header = 1;		# Mark we discarded the line
				next;						# Line is skipped
			}
			# All headers will now match /^[\w-]+:/
			if ($Header{$header} =~ /^\s*$/) {
				&add_log("NOTICE dropping empty header \"$header\" for news")
					if $loglvl > 5;
				$last_was_header = 1;		# Mark we discarded the line
				next;						# Line is skipped
			}
		}
		s/^Sender:/Prev-Sender:/i;
		s/^(To|Cc):/X-$1:/i;				# Keep distribution info
		s/^(Resent-\w+):/X-$1:/i;
		if (/^([\w-]+):/ && exists $single{"\L$1"}) {
			my $field = lc($1);
			if ($single{$field}++) {
				my $nfield = &header'normalize($field);
				&add_log("WARNING stripping dup $nfield header")
					if $loglvl > 5 && $single{$field} == 2;
				$last_was_header = 1;		# Mark we discarded the line
				next;						# Line is skipped
			}
		}
		next if /^\s/ && $last_was_header;	# Skip removed header continuations
		$last_was_header = 0;				# We decided to keep header line
		s/^([\w-]+):\s+/$1: /;				# INN2 is picky: wants one space

		# Ensure that we always put a single space after the field name
		# (before possibly emitting a newline for the continuation)
		if (s/^([\w-]+):(\S)/$1: $2/ || s/^([\w-]+):$/$1: /) {
			my $header = $1;
			&add_log("NOTICE added space after \"$header:\", for news")
				if $loglvl > 5;
		}
		# We include the "\n" at the end of the string to let news_fmt()
		# avoid emitting the line if it ends-up being a blank line: since
		# we are emitting a header, that blank line would signal EOH.
		print NEWS header::news_fmt("$_\n");
	}

	# For correct threading, we need a References: line.
	my $refs = $Header{'References'};		# Will probably be missing
	$refs =~ tr/\n/ /;						# Must be ONE line
	my $inreply = $Header{'In-Reply-To'};	# Should not be missing for replies
	my ($replyid) = $inreply =~ /(<[^>]+>)/;

	# Warn only when there's no message ID in the In-Reply-To header and
	# there is no References line: this will prevent correct threading.
	# We assume the References line was correctly setup when it is present.
	&add_log("WARNING In-Reply-To header did not contain any message ID")
		if $loglvl > 5 && $inreply ne '' && $replyid eq '' && $refs =~ /^\s*$/;

	if ($replyid ne '' && $refs ne '' && $refs !~ /\Q$replyid/) {
		$refs .= " $replyid";
		&add_log("NOTICE added missing In-Reply-To ID to References")
			if $loglvl > 6;
	}
	$refs = $replyid unless $refs ne '';
	if ($refs ne '') {
		my $fixup = &header'msgid_cleanup(\$refs);
		&add_log("WARNING fixed References line for news")
			if $loglvl > 5 && $fixup;
		# INN does not like an empty References: line, even if properly
		# followed by continuations.  Therefore, cheat to force the message
		# to have at least one ref on the line.
		print NEWS header::news_fmt("References: $refs\n");
	}

	# Any address included withing "" means addresses are stored in a file
	$newsgroups = &complete_list($newsgroups, 'newsgroup');
	$newsgroups =~ s/\s/,/g;	# Cannot have spaces between them
	$newsgroups =~ tr/,/,/s;	# Squash down consecutive ','
	print NEWS header::news_fmt("Newsgroups: $newsgroups\n");
	print NEWS "Distribution: local\n" if $localdist;
	print NEWS $FILTER, "\n";	# Avoid loops: inews may forward to sendmail
	print NEWS "\n";
	print NEWS $Header{'Body'};
	close NEWS;
	local($failed) = $?;		# Status of forwarding
	if ($failed) {
		&add_log("ERROR could not post to $newsgroups") if $loglvl > 1;
	} else {
		&biff($newsgroups, "news") if $wantbiff;
	}
	$failed;		# 0 for success
}

# The "APPLY" command
sub main'load_apply {
	package main;
	local($rulefile) = @_;
	# Prepare new environment for apply_rules
	local($ever_saved) = 0;
	local($ever_matched) = 0;
	# Now call apply_rules, with no statistics recorded, propagating the
	# current mode we are in and using an alternate rule file.
	local($saved, $matched) =
		&rules'alternate($rulefile, 'apply_rules', $wmode, 0);
	if (!defined($saved)) {
		&add_log("ERROR could not apply rule file $rulefile") if $loglvl > 1;
		return (1, 0);	# Notify failure
	}
	# Since APPLY will fail when no save, warn the user
	if (!$matched) {
		&add_log("NOTICE no match in $rulefile") if $loglvl > 6;
	} else {
		&add_log("NOTICE no save in $rulefile") if !$saved && $loglvl > 6;
	}
	(0, $saved);		# Mail was correctly filtered, but was it saved?
}

# The "SPLIT" command
# This routine is RFC-934 compliant and will correctly burst digests produced
# with this RFC in mind. For instance, MH produces RFC-934 style digest.
# However, in order to reliably split non RFC-934 digest, some extra work is
# performed to ensure a meaningful output.
sub main'load_split {
	package main;
	local($folder) = @_;		# Folder to save messages into
	# Option parsing: a -i splits "inplace", i.e. acts as a saving if the split
	# is fully successful. A -d discards the leading part. Queues messsages
	# instead of filling them into a folder if the folder name is empty.
	local($inplace) = $opt'sw_i;	# Inplace (original marked saved)
	local($discard) = $opt'sw_d;	# Discard digest leading part
	local($empty) = $opt'sw_e;		# Discard leading digest only if empty
	local($watch) = $opt'sw_w;		# Watch digest closely
	local($annotate) = $opt'sw_a;	# Annotate items with X-Digest-To: field
	local(@leading);			# Leading part of the digest
	local(@header);				# Looked ahead header
	local($found_header) = 0;	# True when header digest was found
	local($look_header) = 0;	# True when we are looking for a mail header
	local($found_end) = 0;		# True when end of digest found
	local($valid);				# Return value from header checking package
	local($failed) = 0;			# Queuing status for each mail item
	local(@body);				# Body of extracted mail
	local($item) = 0;			# Count digest items found
	local($not_rfc934) = 0;		# Is digest RFC-934 compliant?
	local($digest_to);			# Value of the X-Digest-To: field
	local($_);
	# If item annotation is requested, then each item will have a X-Digest-To:
	# field added, which lists both the To: and Cc: fields of the original
	# digest message.
	if ($annotate) {			# Annotation requested
		$digest_to = $Header{'Cc'};
		$digest_to = ', ' . $digest_to if $digest_to;
		$digest_to = 'X-Digest-To: ' . $Header{'To'} . $digest_to;
		$digest_to = &header'format($digest_to);
	}
	# Start digest parsing. According to RFC-934, we could only look for a
	# single '-' as encapsulation boundary, but for safety we look for at least
	# three consecutive ones.
	foreach (split(/\n/, $Header{'All'})) {
		push(@leading, $_) unless $found_header;
		push(@body, $_) if $found_header;
		if (/^---/) {			# Start looking for mail header
			$look_header = 1;	# Focus on mail headers now
			# We are withing the body of a digest and we've just reached
			# what may be the end of a message, or the end of the leading part.
			@header = ();		# Reset look ahead buffer
			&header'reset;		# Reset header checking package
			next;
		}
		next unless $look_header;
		# Record lines we find, but skip possible blank lines after dash.
		# Note that RFC-934 does not make spaces compulsory after each
		# encapsulation boundary (EB) but they are allowed nonetheless.
		next if /^\s*$/ && 0 == @header;
		$found_end = 0;			# Maybe it's not garbage after all...
		$valid = &header'valid($_);
		if ($valid == 0) {		# Not a valid header
			$look_header = 0;	# False alert
			$found_end = 1;		# Garbage after last EB is to be ignored
			if ($watch) {
				# Strict RFC-934: if an EB is followed by something which does
				# not prove to be a valid header but looked like one, enough
				# to have some lines collected into @header, then signal it.
				++$not_rfc934 unless 0 == @header;
			} else {
				# Don't be too scrict. If what we have found so far *may be* a
				# header, then yes, it's not RFC-934. Otherwise let it go.
				++$not_rfc934 if $header'maybe;
			}
			next;
		} elsif ($valid == 1) {	# Still in header
			push(@header, $_);	# Record header lines
			next;
		}
		# Coming here means we reached the end of a valid header
		push(@header, $digest_to) if $annotate;
		push(@header, '');		# Blank header line
		if (!$found_header) {
			if ($empty) {
				$failed |= &save_mail(*leading, $folder)
					unless &empty_body(*leading) || $discard;
			} else {
				$failed |= &save_mail(*leading, $folder) unless $discard;
			}
			undef @leading;		# Not needed any longer
			$item++;			# So that 'save_mail' starts logging items
		}
		# If there was already a mail being collected, save it now, because
		# we are sure it is followed by a valid mail.
		$failed |= &save_mail(*body, $folder) if $found_header;
		$found_header = 1;		# End of header -> this is truly a digest
		$look_header = 0;		# We found our header
		&header'clean(*header);	# Ensure minimal set of header
		@body = @header;		# Copy headers in mail body for next message
	}

	return -1 unless $found_header;	# Message was not in digest format

	# Save last message, making sure to add a final dash line if digest did
	# not have one: There was one if $look_header is true. There was also
	# one if $found_end is true.
	push(@body, '---') unless $look_header || $found_end;

	# If the -w option was used, we look closely at the supposed trailing
	# garbage. If the length is greater than 100 characters, then maybe we
	# are missing something here...
	if ($watch) {
		local($idx) = $#body;
		$_ = $body[$idx];			# Get last line
		@header = ();				# Reset "garbage collector"
		unless (/^---/) {			# Do not go on if end of digest truly found
			for (; $idx >= 0; $idx--) {
				$_ = $body[$idx];
				last if /^---/;		# Reached end of presumed trailing garbage
				unshift(@header, $_);
			}
		}
	}

	# Now save last message
	$failed |= &save_mail(*body, $folder);

	# If we collected something into @header and if it is big enough, save it
	# as a trailing message.
	if ($watch && length(join('', @header)) > 100) {
		&add_log("NOTICE [$mfile] has trailing garbage...") if $loglvl > 6;
		@body = @header;			# Copy saved garbage
		@header = ();				# Now build final garbage headers
		$header[0] = 'Subject: ' . $Header{'Subject'} . ' (trailing garbage)';
		$header[1] = $digest_to if $annotate;
		&header'clean(*header);		# Build other headers
		unshift(@body, '') unless $body[0] =~ s/^\s*$//;	# Ensure EOH
		foreach (@body) {
			push(@header, $_);
		}
		push(@header, '---');
		$failed |= &save_mail(*header, $folder);
	}

	$failed + 0x2 * $inplace + 0x4 * ($folder =~ /^\s*$/)
		+ 0x8 * ($not_rfc934 > 0);
}

# The "RUN" command and its friends
# Start a shell command and mail any output back to the user. The program is
# invoked from within the home directory.
sub main'load_shell_command {
	package main;
	local($program, $input, $feedback) = @_;
	unless (chdir $cf'home) {
		&add_log("WARNING cannot chdir to $cf'home: $!") if $loglvl > 5;
	}
	$program =~ s/^\s*~/$cf'home/;	# ~ substitution
	$program =~ s/\b~/$cf'home/g;	# ~ substitution as first letter in word
	$SIG{'PIPE'} = 'popen_failed';	# Protect against naughty program
	$SIG{'ALRM'} = 'alarm_clock';	# Protect against loops
	alarm $cf'runmax;				# At most that amount of processing
	eval '&execute_command($program, $input, $feedback)';
	alarm 0;						# Disable alarm timeout
	$SIG{'PIPE'} = 'emergency';		# Restore initial value
	$SIG{'ALRM'} = 'DEFAULT';		# Restore default behaviour
	local($msg) = $@;
	$@ = '';						# Clear this global for our caller
	if ($msg =~ /^failed/) {		# Something went wrong?
		&add_log("ERROR couldn't run '$program'") if $loglvl > 0;
		return 1;					# Failed
	} elsif ($msg =~ /^aborted/) {	# Writing to program failed
		&add_log("WARNING pipe closed by '$program'") if $loglvl > 5;
		return 1;					# Failed
	} elsif ($msg =~ /^feedback/) {	# Feedback failed
		&add_log("WARNING no feedback occurred") if $loglvl > 5;
		return 1;					# Failed
	} elsif ($msg =~ /^alarm/) {	# Timeout
		&add_log("WARNING time out received ($cf'runmax seconds)")
			if $loglvl > 5;
		return 1;					# Failed
	} elsif ($msg =~ /^non-zero/) {	# Program returned non-zero status
		&add_log("WARNING program returned non-zero status") if $loglvl > 5;
		return 1;
	} elsif ($msg) {
		$msg =~ s/\n$//;			# Not sure it's there... don't chop!
		&add_log("ERROR $msg") if $loglvl > 0;
		return 1;					# Failed
	}
	0;			# Everything went fine
}

# Abort execution of command when popen() fails or program dies abruptly
sub main'load_popen_failed {
	package main;
	local($status) = 'died abruptly';	# Status for &mail_back
	&mail_back;			# Let the user know about a possible error message
	unlink "$trace" if -f "$trace";
	die "$error\n";
}

# When an alarm call is received, we should be in the 'execute_command'
# routine. The $pid variable holds the pid number of the process to be killed.
sub main'load_alarm_clock {
	package main;
	if ($trace ne '' && -f "$trace") {		# We come from execute_command
		local($status) = "terminated";		# Process was terminated
		if (kill "SIGTERM", $pid) {			# We could signal our child
			sleep 30;						# Give child time to die
			unless (kill "SIGTERM", $pid) {	# Child did not die yet ?
				unless (kill "SIGKILL", $pid) {
					&add_log("ERROR could not kill process $pid: $!")
						if $loglvl > 1;
				} else {
					$status = "killed";
					&add_log("KILLED process $pid") if $loglvl > 4;
				}
			} else {
				&add_log("TERMINATED process $pid") if $loglvl > 4;
			}
		} else {
			$status = "unknown";	# Process died ?
			&add_log("ERROR coud not signal process $pid: $!")
				if $loglvl > 1;
		}
		&mail_back;					# Mail back any output we have so far
		unlink "$trace";			# Remove output of command
	}
	die "alarm call\n";				# Longjmp to shell_command
}

# Print whole mail to supplied fd, without any Content-Transfer-Encoding.
sub main'load_print_binary_mail {
	package main;
	my ($fd) = @_;
	my $skip = 0;
	foreach my $line (split(/\n/, $Header{'Head'})) {
		if ($line =~ /^\s/) {
			print $fd $line, "\n" unless $skip;
		} else {
			$skip = 0;
			my ($field) = $line =~ /^([\w-]+):/;
			$skip = lc($field) eq "content-transfer-encoding";
			print $fd $line, "\n" unless $skip;
		}
	}
	print $fd "\n";
	print $fd ${$Header{'=Body='}};		# No content transfer-encoding
}

# Execute the command, ran in an eval to protect against SIGPIPE signals
sub main'load_execute_command {
	package main;
	local($program, $input, $feedback) = @_;

	local($location) = &locate_program($program);
	die "can't locate $location in PATH\n" unless $location =~ m|/|;
	die "unsecure $location\n" unless &exec_secure($location);

	local($trace) = "$cf'tmpdir/trace.run$$";	# Where output goes
	local($error) = "failed";				# Error reported by popen_failed
	pipe(READ, WRITE);						# Open a pipe
	local($pid) = fork;						# We fork here
	$pid = -1 unless defined $pid;

	if ($pid == 0) {						# Child process
		alarm 0;
		close WRITE;						# The child reads from pipe
		open(STDIN, "<&READ");				# Redirect stdin to pipe
		close READ if $input == $NO_INPUT;	# Close stdin if needed
		unless (open(STDOUT, ">$trace")) {	# Where output goes
			&add_log("WARNING couldn't create $trace: $!") if $loglvl > 5;
			if ($feedback != $NO_FEEDBACK) {	# Need trace if feedback
				kill 'SIGPIPE', getppid;		# Parent still waiting
				exit 1;
			}
		}
		open(STDERR, ">&STDOUT");			# Make it follow pipe
		# Using a sub-block ensures exec() is followed by nothing
		# and makes mailagent "perl -cw" clean, whatever that means ;-)
		{ exec $program }					# Run the program now
		&add_log("ERROR couldn't exec '$program': $!") if $loglvl > 1;
		exit 1;
	} elsif ($pid == -1) {
		&add_log("ERROR couldn't fork: $!") if $loglvl;
		return;
	}

	close READ;								# The parent writes to its child
	$error = "aborted";						# Error reported by popen_failed
	select(WRITE);
	$| = 1;									# Hot pipe wanted
	select(STDOUT);

	# Now feed the program with the mail
	if ($input == $BODY_INPUT) {			# Pipes *decoded* body
		print WRITE ${$Header{'=Body='}};
	} elsif ($input == $MAIL_INPUT) {		# Pipes the whole mail
		print WRITE $Header{'All'};
	} elsif ($input == $MAIL_INPUT_BINARY) {	# Remove any transfer encoding
		print_binary_mail(\*WRITE);			
	} elsif ($input == $HEADER_INPUT) {		# Pipes the header
		print WRITE $Header{'Head'};
	}
	close WRITE;							# Close input, before waiting!

	wait();									# Wait for our child
	local($status) = $? ? "failed" : "ok";
	if ($?) {
		# Log execution failure and return to shell_command via die if some
		# feedback was to be done.
		&add_log("ERROR execution failed for '$program'") if $loglvl > 1;
		if ($feedback != $NO_FEEDBACK) {	# We wanted feedback
			&mail_back;						# Mail back any output
			unlink "$trace";				# Remove output of command
			die "feedback\n";				# Longjmp to shell_command
		}
	}

	&handle_output;			# Take appropriate action with command output
	unlink "$trace";		# Remove output of command
	die "non-zero status\n" unless $status eq 'ok';
}

# If no feedback is wanted, simply mail the output of the commands to the
# user. However, in case of feedback, we have to update the values of
# %Header in the entries 'All', 'Body' and 'Head'. Note that the other
# header fields are left untouched. Only a RESYNC can synchronize them
# (this makes sense only for a FEED command, of course).
# Uses $feedback from execute_command
sub main'load_handle_output {
	package main;
	if ($feedback == $NO_FEEDBACK) {
		&mail_back;						# Mail back any output
	} else {
		&feed_back($feedback);			# Feed result back into %Header
	}
}

# Mail back the contents of the trace file (output of program), if not empty.
# Uses some local variables from execute_command
sub main'load_mail_back {
	package main;
	local($size) = -s "$trace";				# Size of output
	return unless $size;					# Nothing to be done if no output
	local($std_input);						# Standard input used
	$std_input = "none" if $input == $NO_INPUT;
	$std_input = "mail body" if $input == $BODY_INPUT;
	$std_input = "whole mail" if $input == $MAIL_INPUT;
	$std_input = "header" if $input == $HEADER_INPUT;
	local($program_name) = $program =~ m|^(\S+)|;
	unless (open(MAILER,"|$cf'sendmail $cf'mailopt $cf'email")) {
		&add_log("SYSERR fork: $!") if $loglvl;
	}
	print MAILER <<EOM;
To: $cf'email
Subject: Output of your '$program_name' command ($status)
$MAILER

Your command was: $program
Input: $std_input
Status: $status

It produced the following output:

EOM
	unless (open(TRACE, "$trace")) {
		&add_log("ERROR couldn't reopen $trace") if $loglvl > 1;
		print MAILER "*** SORRY -- NOT AVAILABLE ***\n";
	} else {
		while (<TRACE>) {
			print MAILER;
		}
		close TRACE;
	}
	close MAILER;
	unless ($?) {
		&add_log("SENT output of '$program_name' to $cf'email ($size bytes)")
			if $loglvl > 2;
	} else {
		&add_log("ERROR couldn't send $size bytes to $cf'email") if $loglvl;
		&trace_dump($trace, "$program_name output ($status)");
	}
}

# Feed back output of a command in the %Header data structure.
# Uses some local variables from execute_command
sub main'load_feed_back {
	package main;
	my ($feedback) = @_;
	unless (open(TRACE, "$trace")) {
		&add_log("ERROR couldn't feed back from $trace: $!") if $loglvl > 1;
		unlink "$trace";				# Maybe I should leave it around
		die "feedback\n";				# Return to shell_command
	}
	local($temp) = ' ' x 2000;			# Temporary storage (pre-extended)
	$temp = '';
	local($last_was_nl) = 1;			# True when previous line was blank
	if ($input == $BODY_INPUT) {		# We have to feed back the body only
		while (<TRACE>) {
			# Protect potentially dangerous lines. If fromall is ON, then we
			# don't care whether From is within a paragraph, i.e. not preceded
			# by a blank line. This is only required with "broken" User Agents.
			s/^From(\s)/>From$1/ if $last_was_nl && $cf'fromesc =~ /on/i;
			$last_was_nl = /^$/ || $cf'fromall =~ /on/i;
			$temp .= $_;
		}
	} else {
		local($head) = ' ' x 500;		# Pre-extend header
		$head = '';
		while (<TRACE>) {
			if (1../^$/) {
				$head .= $_ unless /^$/;
			} else {
				# Protect potentially dangerous lines
				s/^From(\s)/>From$1/ if $last_was_nl && $cf'fromesc =~ /on/i;
				$last_was_nl = /^$/ || $cf'fromall =~ /on/i;
				$temp .= $_;
			}
		}
		if ($head =~ /^\s*$/s) {			# A perl5 construct
			&add_log("ERROR got empty header from $trace") if $loglvl > 1;
			unlink "$trace";				# Maybe I should leave it around
			die "feedback\n";				# Return to shell_command
		}
		$Header{'Head'} = $head;
	}
	close TRACE;
	$Header{'Body'} = $temp unless $input == $HEADER_INPUT;
	$Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'};
	if ($input == $BODY_INPUT) {
		# Was fed *decoded* body, got a decoded body back.
		# Headers have not changed, recoding will happen as in the original
		&body_recode;
	} elsif ($input == $MAIL_INPUT) {
		# Headers could have changed and we need to reparse them in order
		# to know how/whether we should decode the body.
		&header_resync;
		&body_check;	# Update $Header{'=Body='} to point to *decoded* body
		if ($feedback == $FEEDBACK_ENCODING) {
			&header_resync if &body_recode_optimally;
		}
	} elsif ($input == $HEADER_INPUT) {
		# Headers pertaining to body encoding could have changed.
		&header_check_body_encoding;		# Check and recode if possible
		&header_resync;						# Resynchronize %Header
	} elsif ($input == $MAIL_INPUT_BINARY) {
		# Was fed a *decoded* body, got at possibly decoded body back.
		my $old_encoding = lc($Header{'Content-Transfer-Encoding'});
		&header_resync;
		&body_check;	# Update $Header{'=Body='} to point to *decoded* body
		if ($feedback == $FEEDBACK_ENCODING) {
			# Scan the decoded body and determine the optimal content
			# transfer encoding, recoding the body as needed and updating
			# the headers should they change.
			&header_resync if &body_recode_optimally;
		} else {
			# Adjust encoding if needed (they did not supply the -e to FEED)
			my $current_encoding = lc($Header{'Content-Transfer-Encoding'});
			my %encoded = map { $_ => 1 } qw(base64 quoted-printable);
			# We need to recode if there is presently no encoding but there was
			# one originally.  They could have properly re-encoded the body,
			# which is why we have to check for the current encoding.
			if (!$encoded{$current_encoding} && $encoded{$old_encoding}) {
				alter_header("Content-Transfer-Encoding", $HD_STRIP);
				header_append(header'format(
					"Content-Transfer-Encoding: $old_encoding\n"));
				body_recode_with($old_encoding);
			}
		}
	} else {
		&add_log("ERROR BUG in feed_back: unknown input value \"$input\"");
	}
}

# Feed output back into $Back variable (used by BACK command). Typically, the
# BACK command is used with RUN, though any other command is allowed (but does
# not always make sense).
# NB: This routine:
#  - Is never called explicitely but via a type glob through *handle_output
#  - Uses some local variables from execute_command
sub main'load_xeq_back {
	package main;
	unless (open(TRACE, "$trace")) {
		&add_log("ERROR couldn't feed back from $trace: $!") if $loglvl > 1;
		unlink "$trace";				# Maybe I should leave it around
		die "feedback\n";				# Return to shell_command
	}
	while (<TRACE>) {
		chop;
		next if /^\s*$/;
		$Back .= $_ . '; ';				# Replace \n by ';' separator
	}
	close TRACE;
}

# The "RESYNC" command
# Resynchronizes the %Header entries by reparsing the 'Head' entry
sub main'load_header_resync {
	package main;
	# Clean up all the non-special entries
	foreach $key (keys %Header) {
		next if $Pseudokey{$key};		# Skip pseudo-header entries
		delete $Header{$key};
	}
	my $first_from = header_parse($Header{'Head'}, \%Header, 0);
	&header_check($first_from, undef);	# Sanity checks
}

# The "STRIP" and "KEEP" commands (case insensitive)
# Removes or keeps some headers and update the Header structure
sub main'load_alter_header {
	package main;
	local($headers, $action) = @_;
	$headers =
		&complete_list($headers, 'header');	# Process "file-inclusion"
	local(@list) = split(/\s/, $headers);
	local(@head) = split(/\n/, $Header{'Head'});
	local(@newhead);				# The constructed header
	local($last_was_altered) = 0;	# Set to true when header is altered
	local($matched);				# Did any header matched ?
	local($line);					# Original header line

	foreach $h (@list) {			# Prepare patterns
		$h =~ s/:$//;				# Remove trailing ':' if any
		$h = &perl_pattern($h);		# Headers specified by shell patterns
	}

	foreach (@head) {
		if (/^From\s/) {			# First From line...
			push(@newhead, $_);		# Keep it anyway
			next;
		}
		$line = $_;					# Save original
		# Make sure header field name is normalized before attempting a match
		s/^([!-9;-~\w-]+):/&header'normalize($1).':'/e;
		unless (/^\s/) {			# If not a continuation line
			$last_was_altered = 0;	# Reset header alteration flag
			$matched = 0;			# Assume no match
			foreach $h (@list) {	# Loop over to-be-altered lines
				if (/^$h:/i) {		# We found a line to be removed/kept
					$matched = 1;
					last;
				}
			}
			$last_was_altered = $matched;
			next if $matched && $action == $HD_SKIP;
			next if !$matched && $action == $HD_KEEP;
		}
		if ($action == $HD_SKIP) {
			next if /^\s/ && $last_was_altered;		# Skip header continuations
		} else {									# Action is $HD_KEEP
			next if /^\s/ && !$last_was_altered;	# Header was not kept
		}
		push(@newhead, $line);		# Add line to the new header
	}
	$Header{'Head'} = join("\n", @newhead) . "\n";
	$Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'};

	# Headers pertaining to body encoding could have changed.
	&header_check_body_encoding;	# Check, but no resync
}

# The "ANNOTATE" command
sub main'load_annotate_header {
	package main;
	local($field, $value) = @_;			# Field, value
	if ($opt'sw_u) {					# -u means "unique": no anno if present
		local($normalized) = &header'normalize($field);
		return 1 if defined $Header{$normalized} && $Header{$normalized} ne '';
	}
	if ($value eq '' && $opt'sw_d) {	# No date and no value for field!
		&add_log("WARNING no value for '$field' annotation") if $loglvl > 5;
		return 1;
	}
	if ($field eq '') {				# No field specified!
		&add_log("WARNING no field specified for annotation") if $loglvl > 5;
		return 1;
	}
	local($annotation) = '';		# Annotation made
	$annotation = "$field: " . &header'mta_date() . "\n" unless $opt'sw_d;
	$annotation .= &header'format("$field: $value") . "\n" if $value ne '';
	&header_append($annotation);	# Add field into %Header
	0;
}

# Utilitity routine for alter_field()
# Performs $op on $bufref, the value of the header field $header, and insert
# result in the head (pointed to by $headref), or the original raw buffer if
# there was no change.
# Returns whether there was a change or not, undef on eval() error.
sub main'load_runop_on_field {
	package main;
	my ($header, $op, $bufref, $raw_bufref, $headref) = @_;

	&add_log("running $op for $header: " . $$bufref) if $loglvl > 19;
	my $changed = eval "\$\$bufref =~ $op";
	if ($@) {
		&add_log("ERROR operation $op failed: $@") if $loglvl > 1;
		return undef;		# Abort further processing
	}
	&add_log("changed buffer: " . $$bufref) if $changed && $loglvl > 19;
	$$headref .= $changed ?
		&header'format("$header: " . $$bufref) :
		("$header: " . $$raw_bufref);
	$$headref .= "\n";

	return $changed ? 1 : 0;
}

# The "TR" and "SUBST" commands targetted to header field.
# The operation (s/// or tr//) is performed on the header field.
# If a match occurrs, the whole header is reformatted.
# Returns failure status (0 means OK)
sub main'load_alter_field {
	package main;
	my ($header_field, $op) = @_;
	$header_field = &header'normalize($header_field);

	my $head = ' ' x length $Header{'Head'};
	$head = '';
	my $last_header = '';		# Non-empty indicates header field to process
	my $buffer;					# Holds value of field to process
	my $raw_buffer;				# Holds raw lines of field to process
	my $ever_changed = 0;

	foreach (split(/\n/, $Header{'Head'})) {
		if (/^\s/) {
			if ($last_header eq '') {
				$head .= $_ . "\n";
			} else {
				$raw_buffer .= "\n$_";		# In case there's no change
				s/^\s+/ /;
				$buffer .= $_;				# What we'll run $op on
			}
		} elsif (my ($field, $value) = /^([\w-]+)\s*:\s*(.*)/) {

			# Perform operation on $buffer if previous header matched.
			if ($last_header ne '') {
				my $changed = runop_on_field($last_header, $op,
					\$buffer, \$raw_buffer, \$head);
				return 1 unless defined $changed;	# Abort, because $op failed
				$ever_changed++ if $changed;
				$last_header = '';
			}

			if (&header'normalize($field) eq $header_field) {
				$last_header = $field;			# Indicates a match
				$raw_buffer = $buffer = $value;
			} else {
				$head .= $_ . "\n";
			}
		} else {
			$head .= $_ . "\n";
		}
	}

	# Perform operation on $buffer if last header seen matched.
	if ($last_header ne '') {
		my $changed = runop_on_field($last_header, $op,
			\$buffer, \$raw_buffer, \$head);
		return 1 unless defined $changed;	# Abort, because $op failed
		$ever_changed++ if $changed;
	}

	# Resynchronize pseudo-headers if there was any change
	if ($ever_changed) {
		$Header{'All'} = $head . "\n" . $Header{'Body'};
		$Header{'Head'} = $head;
	}

	&add_log("changed $ever_changed $header_field line" .
		($ever_changed == 1 ? '' : 's') . " with $op") if $loglvl > 6;
}

# The "TR" and "SUBST" commands -- main entry point
sub main'load_alter_value {
	package main;
	local($variable, $op) = @_;	# Variable and operation to performed
	local($lvalue);				# Perl variable to be modified
	local($extern);				# Lvalue used for persistent variables

	# We may modify a variable or a backreference (not read-only as in perl)
	if ($variable =~ s/^#://) {
		$extern = &extern'val($variable);	# Fetch external value
		$lvalue = '$extern';				# Modify this variable
	} elsif ($variable =~ s/^#//) {
		$lvalue = '$Variable{\''.$variable.'\'}';
	} elsif ($variable =~ /^\d\d?$/) {
		$variable = int($variable) - 1;
		$lvalue = '$Backref[' . $variable . ']';
	} elsif ($variable =~ /^([\w-]+):?$/) {
		my $field = $1;						# Dataloading will change $1
		return alter_field($field, $op);	# More complex, handle separately
	} else {
		&add_log("ERROR incorrect variable name '$variable'") if $loglvl > 1;
		return 1;
	}

	# Let perl do the work
	&add_log("running $lvalue =~ $op") if $loglvl > 19;
	eval $lvalue . " =~ $op";
	&add_log("ERROR operation $op failed: $@") if $@ && $loglvl > 1;

	# If an external (persistent) variable was used, update its value now,
	# unless the operation failed, in which case the value is not modified.
	&extern'set($variable, $extern) if $@ eq '' && $lvalue eq '$extern';

	$@ eq '' ? 0 : 1;			# Failure status
}

# The "PERL" command
sub main'load_perl {
	package main;
	local($script) = @_;	# Location of perl script
	local($failed) = '';	# Assume script did not fail
	local(@_);				# No visible args for functions in script

	unless (chdir $cf'home) {
		&add_log("WARNING cannot chdir to $cf'home: $!") if $loglvl > 5;
	}

	$script =~ s/^\s*~/$cf'home/;	# ~ substitution
	$script =~ s/\b~/$cf'home/g;	# ~ substitution as first letter in word

	# Set up the @ARGV array, by parsing the $script variable with &shellwords.
	# Note that the @ARGV array is held in the main package, but since the
	# mailagent makes no use of it at this point, there is no need to save its
	# value before clobbering it.

	require Text::ParseWords;
	*shellwords = \&Text::ParseWords::old_shellwords;

	eval '@ARGV = &shellwords($script)';
	if (chop($@)) {				# There was an unmatched quote
		$@ =~ s/^U/u/;
		&add_log("ERROR $@") if $loglvl > 1;
		&add_log("ERROR cannot run PERL $script") if $loglvl > 2;
		return 1;
	}

	unless (open(PERL, $ARGV[0])) {
		&add_log("ERROR cannot open perl script $ARGV[0]: $!") if $loglvl > 1;
		return 1;
	}

	# Fetch the perl script in memory, within a block to really localize $/
	local($body) = ' ' x (-s PERL);
	{
		local($/) = undef;
		$body = <PERL>;		# Slurp whole file into pre-extended variable
	}
	close(PERL);
	local(@saved) = @INC;	# Save INC array (perl library location path)
	local(%saved) = %INC;	# Save already required files

	# Run the perl script in special package
	unshift(@INC, $privlib);	# Files first searched for in mailagent's lib
	package mailhook;			# -- entering in mailhook --
	&interface'new;				# Signal new script being loaded
	&hook'initvar('mailhook');	# Initialize convenience variables
	eval $'body;				# Load, compile and execute within mailhook
	local($saved) = $@;			# If perl5, interface::reset will use an eval!
	&interface'reset;			# Clear the mailhook package if no more pending
	$@ = $saved;				# Restore old $@ (useful only for perl5)
	package main;				# -- reverting to main --
	@INC = @saved;				# Restore INC array
	%INC = %saved;				# In case script has required some other files

	# If the script died with an 'OK' error message, then it meant 'exit 0'
	# but also wanted the exit to be trapped. The &exit function is provided
	# for that purpose.
	if (chop($@)) {
		if ($@ =~ /^OK/) {
			$@ = '';
			&add_log("script exited with status 0") if $loglvl > 18;
		}
		elsif ($@ =~ /^Exit (\d+)/) {
			$@ = '';
			$failed = "exited with status $1";
		}
		elsif ($@ =~ /^Status (\d+)/) {		# A REJECT, RESTART or ABORT
			$@ = '';
			$cont = $1;						# This will modify control flow
			&add_log("script ended with a control '$cont'") if $loglvl > 18;
		}
		else {
			$@ =~ s/ in file \(eval\)//;
			&add_log("ERROR $@") if $loglvl;
			$failed = "execution aborted";
		}
		&add_log("ERROR perl failed ($failed)") if $loglvl > 1 && $failed;
	}
	$failed ? 1 : 0;
}

# The "REQUIRE" command
sub main'load_require {
	package main;
	local($file, $package) = @_;	# File to load, package to put it in
	$package = 'newcmd' if $package eq '';	# Use newcmd if no package
	$file =~ s/^\s*~/$cf'home/;		# ~ substitution
	# Note that the dynload package records files being loaded into a H table,
	# and "requiring" two times the same file in the *same* package will be
	# a no-op, returning the same status as the first time.
	local($ok) = &dynload'load($package, $file);
	$file = &tilda($file);			# Replace home directory with a nice ~
	unless (defined $ok) {
		&add_log("ERROR cannot load $file in package $package");
		return 1;		# Require failed
	}
	unless ($ok) {
		&add_log("ERROR cannot parse $file into package $package");
		return 1;		# Require failed
	}
	0;		# Success
}

# The "DO" command
# The routine name can be one of pack'routine, COMMAND:pack'routine or
# /some/path:pack'routine. The following parsing duplicates the one done
# in &dynload'do, so beware, should the interface change.
sub main'load_do {
	package main;
	local($something, $routine, $args) = @_;
	$routine = $what if $something eq '';
	unless (&dynload'do($what)) {
		local($under);
		$under = " under $something" if $something ne '';
		&add_log("ERROR couldn't locate routine $routine$under") if $loglvl > 1;
		return 1;	# Failed
	}
	$args = '()' unless $args;
	&add_log("calling routine $routine$args") if $loglvl > 15;
	eval "package main; &$routine$args;";

	# I want to allow people to call mailhook commands from a DO routine call.
	# However, commands modifying the filtering control flow are performing a
	# die() with 'Status x' as the error message where 'x' defines the new
	# continuation value for run_command. This is trapped specially here.
	# Note however that convenience variables typically set for PERL escapes
	# are not available via a DO.

	if (chop($@)) {
		local($_) = $@;
		$@ = '';				# Avoid cascades: we're within an eval already
		if (/^Status (\d+)$/) {	# Filter automaton continuation status
			$cont = $1;			# Propagate status ($cont from &run_command)
			&add_log("NOTICE $routine shifted automaton to status $cont")
				if $loglvl > 1;
		} else {
			&add_log("ERROR cannot call $routine$args: $_") if $loglvl > 1;
			return 1;
		}
	}
	0;		# Success
}

# The "AFTER" command
sub main'load_after {
	package main;
	local($time, $action) = @_;
	local($no_input) = $opt'sw_n;
	local($shell_cmd) = $opt'sw_s;
	local($agent_cmd) = $opt'sw_a || !($opt'sw_n || $opt'sw_s || $opt'sw_c);
	local($now) = time;					# Current time
	local($start);						# Action's starting time
	$start = &getdate($time, $now);
	if ($start == -1) {
		&add_log("ERROR in AFTER: time '$time' is incorrect") if $loglvl > 1;
		return (1,undef);
	}
	if ($start < $now) {
		&add_log("NOTICE time '$time' ($start) is before now ($now)")
			if $loglvl > 5;
		&add_log("ERROR in AFTER: command should have run already!")
			if $loglvl > 1;
		return (1,undef);
	}
	local($atype) = $agent_cmd ? $callout'AGENT :
		($shell_cmd ? $callout'SHELL : $callout'CMD);
	local($qfile) = &callout'queue($start, $action, $atype, $no_input);
	unless (defined $qfile) {
		&add_log("ERROR in AFTER: cannot queue action $action") if $loglvl > 1;
		return (1,undef);
	}
	(0, $qfile);		# Success
}

# Modify control flow within automaton by calling a non-existant function
# &perform, which has been dynamically bound to one of the do_* functions.
# The REJECT, RESTART and ABORT actions share the following options and
# arguments. If followed by -t (resp. -f), then the action only takes place
# when the last recorded command status is true (resp. false, i.e. failure).
# If a mode is present as an argument, the the state of the automaton is
# changed to that mode prior alteration of the control flow.
sub main'load_alter_flow {
	package main;
	local($mode) = @_;				# New mode we eventually change to
	&add_log("last cmd status is $lastcmd") if $loglvl > 11;
	# Variable $lastcmd comes from xeqte(), $wmode comes from analyze_mail().
	return 0 if $opt'sw_t && $lastcmd != 0;
	return 0 if $opt'sw_f && $lastcmd == 0;
	if ($mode ne '') {
		&add_log("entering new state $mode") if $loglvl > 6 && $mode ne $wmode;
		$wmode = $mode;
	}
	&perform;						# This was dynamically bound
}

# Perform a "REJECT"
sub main'load_do_reject {
	package main;
	$cont = $FT_REJECT;			# Reject ($cont defined in run_command)
	&add_log("REJECTED [$mfile] in state $wmode") if $loglvl > 4;
	0;
}

# Perform a "RESTART"
sub main'load_do_restart {
	package main;
	$cont = $FT_RESTART;		# Restart ($cont defined in run_command)
	&add_log("RESTARTED [$mfile] in state $wmode") if $loglvl > 4;
	0;
}

# Perform an "ABORT"
sub main'load_do_abort {
	package main;
	$cont = $FT_ABORT;			# Abort filtering ($cont defined in run_command)
	&add_log("ABORTED [$mfile] in state $wmode") if $loglvl > 4;
	0;
}

# Given a list of items separated by white spaces, return a new list of
# items, but with "include-request" processed.
sub main'load_complete_list {
	package main;
	local(@addr) = split(' ', $_[0]);	# Original list
	local($type) = $_[1];				# Type of item (header, address, ...)
	local(@result);						# Where result list is built
	local($filename);					# Name of include file
	local($_);
	foreach $addr (@addr) {
		if ($addr !~ /^"/) {			# Item not enclosed within ""
			push(@result, $addr);		# Kept as-is
		} else {
			# Load items from file whose name is given between "quotes"
			push(@result, &include_file($addr, $type));
		}
	}
	join(' ', @result);		# Return space separated items
}

# Save digest mail into a folder, or queue it if no folder is provided
# Uses the variable '$item' from 'split' to log items.
sub main'load_save_mail {
	package main;
	local(*array, $folder) = @_;	# Where mail is and where to put it
	local($length) = 0;				# Length of the digest item
	local($mbox, $failed, $log_message);
	local($_);
	# Go back to the previous dash line, removing it from the body part
	# (it's only a separator). In the process, we also remove any looked ahead
	# header which belongs to the next digest item.
	do {
		$_ = pop(@array);			# Remove what belongs to next digest item
	} while !/^---/;
	# It is recommended in RFC-934 that all leading EB be escaped by a leading
	# '- ' sequence, to allow nested forwarding. However, since the message
	# we are dealing with might not be RFC-934 compliant, we are only removing
	# the leading '- ' if it is followed by a '-'. We also use the loop to
	# escape all potentially dangerous From lines.
	local($last_was_space);
	foreach (@array) {
		# Protect potentially dangerous lines
		s/^From\s+(\S+)/>From $1/ if $last_was_space && $cf'fromesc =~ /on/i;
		s/^- -/-/;					# This is the EB escape in RFC-934
		# From is dangerous after blank line, but everywhere if fromall is ON.
		$last_was_space = /^$/ || $cf'fromall =~ /on/i;
	}
	# Now @array holds the whole digest item
	if ($folder =~ /^\s*$/) {		# No folder means we have to queue message
		local($name) = &qmail(*array);
		$failed = defined $name ? 0 : 1;
		$log_message = $name =~ m|/| ? "file [$name]" : "queue [$name]";
		foreach (@array) {
			$length += length($_) + 1;	# No trailing new-lines
		}
	} else {
		# Looks like we have to save the message in a folder. I cannot really
		# ask for a local variable named %Header because emergency routines
		# use it to save mail (they expect the whole mail in $Header{'All'}).
		# However, if something goes wrong, we'll get back to the filter main
		# loop and a LEAVE (default action) will be executed, taking the
		# current values from 'Head' and 'Body'. Hence the following:

		local(%NHeader);
		$NHeader{'All'} = $Header{'All'};
		local(*Header) = *NHeader;	# From now on, we really work on %NHeader
		local($in_header) = 1;		# True while in message header
		local($first_from);			# First From line

		# Fill in %Header strcuture, which is expected by save(): header in
		# entry 'Head' and body in entry 'Body'.
		foreach (@array) {
			if ($in_header) {
				$in_header = 0 if /^$/;
				next if /^$/;
				$Header{'Head'} .= $_ . "\n";
				$first_from = $_ if /^From\s+\S+/;
				next;
			}
			$Header{'Body'} .= $_ . "\n";
		}
		&header_prepend("$FAKE_FROM\n") unless $first_from;

		# Now save into folder
		($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND);

		# Keep track in the logfile of the length of the digest item.
		$length = length($Header{'Head'}) + length($Header{'Body'}) + 1;
	}
	if ($failed) {
		if ($loglvl > 2) {
			local($s) = $length == 1 ? '' : 's';
			&add_log("ERROR unable to save #$item ($length byte$s)") if $item;
			&add_log("ERROR unable to save preamble ($length byte$s)")
				unless $item;
		}
	} else {
		if ($loglvl > 7) {
			local($s) = $length == 1 ? '' : 's';
			&add_log("SPLIT #$item in $log_message ($length byte$s)") if $item;
			&add_log("SPLIT preamble in $log_message ($length byte$s)")
				unless $item;
		}
	}
	++$item if $item;		# Count items, but not preamble (done by 'split')
	$failed;				# Propagate failure status
}

# Check body message (typically head of digest message) and return 1 if its
# body is empty, 0 otherwise.
sub main'load_empty_body {
	package main;
	local(*ary) = @_;
	local(@array) = @ary;		# Work on a copy
	local($_);
	local($is_empty) = 1;
	do {
		$_ = pop(@array);		# Remove what belongs to next digest item
	} while !/^---/;
	do {
		$_ = shift(@array);		# Remove the whole header
	} while !/^$/;
	foreach (@array) {
		$is_empty = 0 unless /^\s*$/;
		last unless $is_empty;
	}
	$is_empty;
}

# Dump trace in ~/agent.trace
sub main'load_trace_dump {
	package main;
	local($trace, $what) = @_;
	local($ok) = 1;
	open(DUMP, ">>$cf'home/agent.trace") || ($ok = 0);
	print DUMP "--- Trace for $what ---\n";
	print DUMP "--- (was unable to mail it back) ---\n";
	open(TRACE, $trace) || ($ok = 0);
	while (<TRACE>) { print DUMP; }
	print DUMP "--- End of trace for $what ---\n";
	close DUMP;
	&add_log("DUMPED trace in ~/agent.trace") if $ok && $loglvl > 2;
}

# Read the statistics file and fill in the hash tables
sub main'load_read_stats {
	package stats;
	local($statfile) = $cf'statfile;	# Extract value from config package
	local($loglvl) = $main'loglvl;
	local($_, $.);
	$stats_wanted = 1 if ($statfile ne '' && -f $statfile);
	$stats_wanted = 0 if $suppressed;
	return unless $stats_wanted;
	# Do not come here unless statistics are really wanted
	unless (open(STATS, "$statfile")) {
		&'add_log("ERROR could not open statistics file $statfile: $!")
			if $loglvl > 0;
		$stats_wanted = 0;		# Cannot keep track of statistics
		return;
	}
	local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime, $mtime,
		$ctime,$blksize,$blocks) = stat($cf'rules);
	# A null size means we have to start over again
	unless (-s $statfile) {
		&'add_log("starting new statistics") if $loglvl > 6;
		$start_date = time;
		close STATS;
		@Top = ($mtime, 0, 0, 0, 0, 0, 0);
		return;
	}
	$_ = <STATS>;
	unless (/^mailstat: (\d+)/) {
		&'add_log("ERROR corrupted statistics file $statfile") if $loglvl;
		close STATS;
		$stats_wanted = 0;
		return;
	} else {
		$start_date = $1;
	}
	# The first record is always the active one. Check the timestamp. If the
	# rule file has changed, check the sums.
	$_ = <STATS>;
	local($timestamp, $unused_1, $unused_2) = split(' ', $_);
	if ($main'edited_rules || $mtime > $timestamp) {	# File was modified?
		# Reset timestamp for next time if rule come from a file.
		$timestamp = $mtime;
		$timestamp = 0 if $main'edited_rules;
		&'add_log("rule file may have changed") if $loglvl > 18;
		$new_record = &diff_rules($statfile);		# Run the full diff then
		if ($new_record) {
			&'add_log("rule file has changed") if $loglvl > 6;
			@Top = ($mtime, 0, 0, 0, 0, 0, 0);
			close STATS;
			$start_date = time;
			return;
		}
		&'add_log("rule file has not changed") if $loglvl > 6;
	}
	# Read second line and build the @Top array
	$_ = <STATS>;
	local($processed, $run, $failed, $bytes) = split(' ', $_);
	@Top =
		($timestamp, $unused_1, $unused_2, $processed, $run, $failed, $bytes);
	local($valid) = 0;			# Set to true when a valid record was found
	&fill_stats;				# Fill in data structures
	close STATS;
	&'add_log('statistics initialized and loaded') if $loglvl > 18;
}

# Write the statistics file
sub main'load_write_stats {
	package stats;
	local($statfile) = $cf'statfile;	# Extract value from config package
	local($loglvl) = $main'loglvl;
	return unless $stats_wanted;
	local($oldstat) = -f $statfile;
	if ($oldstat) {
		unlink("$statfile.b") if -f "$statfile.b";
		unless (rename($statfile, "$statfile.b")) {
			&'add_log("ERROR cannot rename $statfile as $statfile.b: $!")
				if $loglvl;
			return;
		}
	}
	unless (open(STATS, ">$statfile")) {
		&'add_log("ERROR cannot create $statfile: $!") if $loglvl;
		return;
	}
	# If a new record is to be created, do it at the top of the file, then
	# append the old statistics file at the end of it. Otherwise, the first
	# record of the old statistics file is removed and the remaining is
	# appended.
	print STATS "mailstat: $start_date\n";		# Magic line
	print STATS join(' ', @Top[0..2]). "\n";
	print STATS join(' ', @Top[3..$#Top]). "\n";
	&print_array(*Rule, "");			# Print rule matches statistics
	&print_array(*Special, "");			# Print special stats
	&print_array(*Command, "");			# Print actions executions
	&print_array(*FCommand, "!");		# Print failed actions
	&print_array(*Once, "@");			# Print once commands done
	&print_array(*ROnce, "%@");			# Print once commands not retried
	print STATS "------\n";
	&rules'write_fd("stats'STATS");		# Append internal form of rules
	# If there was no previous statistics file, it's done!
	unless ($oldstat) {
		close STATS;
		return;
	}
	unless (open(OLD, "$statfile.b")) {
		&'add_log("ERROR cannot open old statistics file") if $loglvl;
		close STATS;
		return;
	}
	# If no new record was created, we have to skip the first record of the old
	# statistics file before appending.
	unless ($new_record) {
		while (<OLD>) {
			last if /^\+\+\+\+\+\+/;
		}
	}
	# It's fine to only check the return status of print right now. If there is
	# not enough space on the device, we won't be able to append the whole
	# backup file, but then we have to discard previously saved statistics
	# anyway...
	# Note: 'print STATS <OLD>' would cause an excessive memory consumption
	# given that a statistics file can be several hundred Kbytes long.
	local($status) = 1;					# Printing status
	while (<OLD>) {
		$status &= (print STATS);		# Status remains to 1 while successful
	}
	close OLD;
	close STATS;
	if ($status) {						# Print ran ok
		unlink("$statfile.b");
	} else {							# Print failed
		&'add_log("ERROR could not update statistics: $!") if $loglvl;
		unless (rename("$statfile.b", $statfile)) {
			&'add_log("ERROR could not restore old statistics file: $!")
				if $loglvl;
		}
	}
}

# Print the hash table array in STATS file
sub stats'load_print_array {
	package stats;
	local(*name, $leader) = @_;
	local(@keys);
	foreach (sort keys %name) {
		@keys = split(/:/);
		print STATS $leader . join(' ', @keys) . ' ' . $name{$_} . "\n";
	}
}

# Record a mail processing
sub main'load_s_filtered {
	package stats;
	return unless $stats_wanted;
	local($length) = @_;
	$Top[3]++;
	$Top[6] += $length;
}

# Record a rule match
sub main'load_s_match {
	package stats;
	return unless $stats_wanted;
	local($number, $mode) = @_;
	$Rule{"$number:$mode"}++;
}

# Record a default rule
sub main'load_s_default {
	package stats;
	return unless $stats_wanted;
	$Special{'default'}++;
}

# Record a vacation message sent in vacation mode
sub main'load_s_vacation {
	package stats;
	return unless $stats_wanted;
	$Special{'vacation'}++;
}

# Record a message saved by the default action
sub main'load_s_saved {
	package stats;
	return unless $stats_wanted;
	$Special{'saved'}++;
}

# Record an already processed message
sub main'load_s_seen {
	package stats;
	return unless $stats_wanted;
	$Special{'seen'}++;
}

# Record a successful execution
sub main'load_s_action {
	package stats;
	return unless $stats_wanted;
	local($name, $mode) = @_;
	$Command{"$name:$mode"}++;
	$Top[4]++;
}

# Record a failed execution
sub main'load_s_failed {
	package stats;
	return unless $stats_wanted;
	local($name, $mode) = @_;
	$Command{"$name:$mode"}++;
	$FCommand{"$name:$mode"}++;
	$Top[4]++;
	$Top[5]++;
}

# Record a successful once
sub main'load_s_once {
	package stats;
	return unless $stats_wanted;
	local($name, $mode, $tag) = @_;
	$Once{"$name:$mode:$tag"}++;
}

# Record a non-retried once
sub main'load_s_noretry {
	package stats;
	return unless $stats_wanted;
	local($name, $mode, $tag) = @_;
	$ROnce{"$name:$mode:$tag"}++;
}

# Establish a difference between the rules we have in memory and the rules
# that has been dumped at the end of the active record. Return the difference
# status, true or false.
sub stats'load_diff_rules {
	package stats;
	local($file) = @_;					# Statistics file where dump is stored
	local(*loglvl) = *main'loglvl;
	local($_, $.);
	open(FILE, "$file") || return 1;	# Changed if we cannot re-open file
	# Go past the first dashed line, where the dumped rules begin
	while (<FILE>) {
		last if /^------/;
	}
	# The difference is done on the internal representation of the rules,
	# which gives us a uniform and easy way to make sure the rules did not
	# change.
	local(*Rules) = *main'Rules;		# The @Rules array
	local($i) = 0;						# Index in the rules
	while (<FILE>) {
		last if /^\+\+\+\+\+\+/;		# End of dumped rules
		last if $i > $#Rules;
		chop;
		last unless $_ eq $Rules[$i];	# Compare rule with internal form
		$i++;							# Index in the @Rules array
	}
	if ($i <= $#Rules) {				# If one rule did not match
		close FILE;
		++$i;
		&'add_log("rule $i did not match") if $loglvl > 11;
		return 1;						# Rule file has changed
	}
	# Now check the hash table entries
	local(*Rule) = *main'Rule;			# The %Rule array
	local(@keys) =
		sort rules'hashkey keys(%Rule);	# Sorted keys H0, H1, etc...
	$i = 0;								# Reset index
	while (<FILE>) {					# Swallow blank line
		last if /^\+\+\+\+\+\+/;		# End of dumped rules
		last if $i > $#keys;
		chop;
		last unless $_ eq $Rule{$keys[$i]};
		$i++;							# Index in @keys
	}
	if ($i <= $#keys) {					# Changed if one rule did not match
		close FILE;
		++$i;
		&'add_log("hrule $i did not match") if $loglvl > 11;
		return 1;						# Rule file has changed
	}
	close FILE;
	return 1 unless /^\+\+\+\+\+\+/;	# More rules to come
	0;									# Rule file did not change
}

# Read pre-opened STATS file descriptor and fill in the statistics arrays
sub stats'load_fill_stats {
	package stats;
	while (<STATS>) {
		last if /^------/;		# Reached end of statistics
		if (/^(\d+)\s+(\w+)\s+(\d+)/) {				# <rule> <mode> <# match>
			$Rule{"$1:$2"} = int($3);
		} elsif (/^([a-z]+)\s+(\d+)/) {				# <special> <# match>
			$Special{$1} = $2;						# first token is the key
		} elsif (/^([A-Z]+)\s+(\w+)\s+(\d+)/) {		# <cmd> <mode> <# succes>
			$Command{"$1:$2"} = int($3);
		} elsif (/^!([A-Z]+)\s+(\w+)\s+(\d+)/) {	# <cmd> <mode> <# fail>
			$FCommand{"$1:$2"} = int($3);
		} elsif (/^@([A-Z]+)\s+(\w+)\s+(\S+)\s+(\d+)/) {	# Once run
			$Once{"$1:$2:$3"} = int($4);
		} elsif (/^%@([A-Z]+)\s+(\w+)\s+(\S+)\s+(\d+)/) {	# Once not retried
			$ROnce{"$1:$2:$3"} = int($4);
		} else {
			&'add_log("ERROR corrupted line $. in statistics file") if $loglvl;
			&'add_log("ERROR line $. was: $_") if $loglvl > 1;
		}
	}
}

# Dump the statistics on the standard output.
# Here are the possible options:
#   u: print only used rules
#   m: merge all the statistics at the end
#   a: all mode reported
#   r: rule-based statistics, on a per-state basis
#   y: USELESS if -m, but kept for nice mnemonic
#	t: print only statistics for top-level rules (most recent rule file)
sub main'load_report_stats {
	package stats;
	local($option) = @_;				# Options from command line
	local($opt_u) = $option =~ /u/;		# Only used rules
	local($opt_m) = $option =~ /m/;		# Merge all statistics at the end
	local($opt_a) = $option =~ /a/;		# Print mode-related statistics
	local($opt_r) = $option =~ /r/;		# Print rule-based statistics
	local($opt_y) = $option =~ /y/;		# Yield rule-based summary
	local($opt_t) = $option =~ /t/;		# Only last rule file
	local($times) = $opt_t ? 1 : 100_000_000;
	$option =~ /t(\d+)/ && ($times = $1) if $opt_t;
	local($statfile) = $cf'statfile;
	local(*loglvl) = *main'loglvl;
	local($_, $.);
	select(STDOUT);
	unless ($statfile ne '' && -f "$statfile") {
		print "No statistics available.\n";
		return;
	}
	unless (open(STATS, "$statfile")) {
		print "Can't open $statfile: $!\n";
		return;
	}
	unless (-s $statfile) {
		print "Statistics file is empty.\n";
		close STATS;
		return;
	}
	local($lasttime) = time;	# End of last dumped period
	local($start) = $lasttime;	# Save current time
	local($amount);				# Number of mails processed
	local($bytes);				# Bytes processed
	local($actions);			# Number of actions
	local($failures);			# Failures reported
	local(%Cmds);				# Execution / action
	local(%FCmds);				# Failures / action
	local(%Spec);				# Summary of special actions
	local(%Mrule);				# For merged rules statistics
	local($in_summary);			# True when in summary
	1 while $times-- > 0 && &print_stats;	# Print stats for each record
	close STATS;
	if ($opt_m) {
		$in_summary = 1;				# Signal in summary part
		$Top[3] = $amount;				# Number of mails processed
		$Top[4] = $actions;				# Number of mails processed
		$Top[5] = $failures;			# Failures reported
		$Top[6] = $bytes;				# Bytes processed
		$current_time = $lasttime;
		$lasttime = $start;
		local(*Special) = *Spec;		# Alias %Spec into %Special
		&print_general("Summary");
		local(*Command) = *Cmds;		# Alias %Cmds into %Command
		local(*FCommand) = *FCmds;		# Alias %FCmds into %FCommand
		&print_commands;				# Commands summary
		&print_rules_summary;			# Print rules summary
	}
}

# Print statistics for one record. This subroutine exectues in the context
# built by report_stats. I heavily used dynamic scope hereafter to avoid code
# duplication.
sub stats'load_print_stats {
	package stats;
	return 0 if eof(STATS);
	$_ = <STATS>;
	unless (/^mailstat: (\d+)/) {
		print "Statistics file is corrupted, line $.\n";
		return 0;
	}
	local($current_time) = $1;
	# Build a valid context for data structures fill-in
	local(@Top, %Rule, %Special, %Command, %FCommand, %Once, %ROnce);
	# The two first line are the @Top array
	$_ = <STATS>;
	$_ .= <STATS>;
	chop;
	@Top = split(/\s+/);
	&fill_stats;						# Fill in local data structures
	&print_summary;						# Print local summary
	# Now build a valid context for rule dumping
	local(@main'Rules, %main'Rule);
	local($i) = 0;						# Force numeric context
	local($hash);						# True when entering %Rule section
	while (<STATS>) {
		last if /^\+\+\+\+\+\+/;
		chop;
		if (/^$/) {
			$hash = 1;					# Separator between @Rules and %Rule
			next;
		}
		unless ($hash) {
			push(@main'Rules, $_);
		} else {
			$main'Rule{"H$i"} = $_;
			$i++;
		}
	}
	&main'dump_rules(*print_header, *rule_stats);
	print '=' x 79 . "\n";
	$lasttime = $current_time;
}

# Print a summary from a given record
sub stats'load_print_summary {
	package stats;
	&print_general("Statistics");
	&print_commands;						# Commands summary
	$amount += $Top[3];						# Number of mails processed
	$bytes += $Top[6];						# Bytes processed
	$actions += $Top[4];					# Actions exectuted
	$failures += $Top[5];					# Failures reported
	foreach (keys %Special) {				# Special statistics
		$Spec{$_} += $Special{$_};
	}
	foreach (keys %Command) {				# Commands ececuted
		$Cmds{$_} += $Command{$_};
	}
	foreach (keys %FCommand) {				# Failed commands
		$FCmds{$_} += $FCommand{$_};
	}
}

# Print general informations, as found in @Top.
sub stats'load_print_general {
	package stats;
	local($what) = @_;
	local($last) = scalar localtime($lasttime);
	local($now) = scalar localtime($current_time);
	local($n, $s);
	# Header of statistics
	print "$what from $now to $last:\n";
	print '~' x 79 . "\n";
	print "Processed $Top[3] mail";
	print "s" unless $Top[3] == 1;
	print " for a total of $Top[6] bytes";
	$n = $Special{'seen'};
	$s = $n == 1 ? '' : 's';
	print " ($n mail$s already seen)" if $n;
	print ".\n";
	print "Executed $Top[4] action";
	print "s" unless $Top[4] == 1;
	local($failed) = $Top[5];
	unless ($failed) {
		print " with no failure.\n";
	} else {
		print ", $failed of which failed.\n";
	}
	$n = 0 + $Special{'default'};
	$s = $n == 1 ? '' : 's';
	print "The default rule was applied $n time$s";
	$n = $Special{'saved'};
	$s = $n == 1 ? '' : 's';
	local($was) = $n == 1 ? 'was' : 'were';
	print " and $n message$s $was implicitely saved" if $n;
	print ".\n";
	$n = $Special{'vacation'};
	$s = $n == 1 ? '' : 's';
	print "Received $n message$s in vacation mode with no rule match.\n" if $n;
}

# Print the commands executed, as found in %Command and @Top.
sub stats'load_print_commands {
	package stats;
	print '~' x 79 . "\n";
	local($cmd, $mode);
	local(%states, %fstates);
	local(%cmds, %fcmds);
	local(@kstates, @fkstates);
	local($n, $s);
	foreach (keys %Command) {
		($cmd, $mode) = /^(\w+):(\w+)/;
		$n = $Command{$_};
		$cmds{$cmd} += $n;
		$states{"$cmd:$mode"} += $n;
	}
	foreach (keys %FCommand) {
		($cmd, $mode) = /^(\w+):(\w+)/;
		$n = $FCommand{$_};
		$fcmds{$cmd} += $n;
		$fstates{"$cmd:$mode"} += $n;
	}
	local($total) = $Top[4];
	local($percentage);
	local($cmd_total);
	foreach $key (sort keys %cmds) {
		@kstates = sort grep(/^$key:/, keys %states);
		$cmd_total = $n = $cmds{$key};
		$s = $n == 1 ? '' : 's';
		$percentage = '0.00';
		$percentage = sprintf("%.2f", ($n / $total) * 100) if $total;
		print "$key run $n time$s ($percentage %)";
		if (@kstates == 1) {
			($mode) = $kstates[0] =~ /^\w+:(\w+)/;
			print " in state $mode";
		} else {
			$n = @kstates;
			print " in $n states";
		}
		if (defined($fcmds{$key}) && ($n = $fcmds{$key})) {
			$s = $n == 1 ? '' : 's';
			$percentage = sprintf("%.2f", ($n / $cmd_total) * 100);
			print " and failed $n time$s ($percentage %)";
		}
		if (@kstates == 1 || !$opt_a) {
			print ".\n";
		} else {
			print ":\n";
			@fkstates = sort grep(/^$key:/, keys %states);
			foreach (@kstates) {
				($mode) = /^\w+:(\w+)/;
				$n = $states{$_};
				$s = $n == 1 ? '' : 's';
				$percentage = sprintf("%.2f", ($n / $cmd_total) * 100);
				print "    state $mode: $n time$s ($percentage %)";
				$n = $fstates{$_};
				$s = $n == 1 ? '' : 's';
				print ", $n failure$s" if $n;
				print ".\n";
			}
		}
	}
}

# Return a uniform representation of a rule (suitable for usage merging)
sub stats'load_uniform_rule {
	package stats;
	local($rulenum) = @_;
	local($text) = $main'Rules[$rulenum - 1];
	$text =~ s/^(.*}\s+)//;					# Get mode and action
	local($rule) = $1;
	local(@keys) = split(' ', $text);		# H keys for selection / patterns
	foreach (@keys) {
		$rule .= "\n" . $main'Rule{$_};		# Add selectors and patterns
	}
	$rule;
}

# Print a summary of merged rules as found in %Mrule
sub stats'load_print_rules_summary {
	package stats;
	return unless $opt_y;
	local(@main'Rules);				# The main rules array
	local(%main'Rule);				# The H table for selectors and patterns
	local($counter) = 0;			# Counter for H key computation
	local($rulenum) = 0;			# Rule number
	local(%Rule);					# The local rule statistics array
	local(@components);				# Rule components
	local($rule);					# Constructed rule
	foreach (keys %Mrule) {
		s/^(\w+)://;				# Get applied state
		$state = $1;
		@components = split(/\n/);
		$rule = shift(@components);
		foreach (@components) {
			$rule .= " H$counter";
			$main'Rule{"H$counter"} = $_;
			$counter++;
		}
		push(@main'Rules, $rule);
		$rulenum++;
		$Rule{"$rulenum:$state"} += $Mrule{"$state:$_"};
	}
	&main'dump_rules(*print_header, *rule_stats);
}

# Print the rule number and the number of applications
sub stats'load_print_header {
	package stats;
	local($rulenum) = @_;
	local($total_matches) = 0;
	local(@keys) = grep(/^$rulenum:/, keys %Rule);
	local($state);
	local($matches);
	# Add up the usage of rules, whatever the matching state was
	foreach (@keys) {
		$matches = $Rule{$_};
		$total_matches += $matches;
		if ($opt_y && !$in_summary) {
			($state) = /^\d+:(.*)/;
			$_ = $state . ":" . &uniform_rule($rulenum);
			$Mrule{$_} += $matches;
		}
	}
	return 0 if ($opt_u && $total_matches == 0);
	return 0 unless $opt_r;
	local($total) = $Top[3];
	$total = 1 unless $total;
	local($percentage) = sprintf("%.2f", ($total_matches / $total) * 100);
	$percentage = '0' if $total_matches == 0;
	local($s) = $total_matches == 1 ? '' : 's';
	print '-' x 79 . "\n";
	print "Rule #$rulenum, applied $total_matches time$s ($percentage %).\n";
}

# Print the rule applications, on a per-state basis
sub stats'load_rule_stats {
	package stats;
	return unless $opt_r;
	local($rulenum) = @_;
	local($mode) = $main'Rules[$rulenum - 1] =~ /^(.*)\s+\{/;
	return unless $mode =~ /,/ || $mode eq 'ALL' || $mode =~ /!/;

	# If there is only one mode <ALL>, more than one mode, or at least
	# a negated mode, then we have a priori more than one possible mode
	# that can lead to the execution of the rule. So dump them.

	local(@keys) = grep(/^$rulenum:/, keys %Rule);
	local(%states);
	local($s, $total);
	foreach (@keys) {
		/^\d+:(.+)/;
		$states{$1}++;
	}
	@keys = keys %states;
	return unless $opt_a;
	if (@keys == 1) {
		print "Applied only in state $keys[0].\n";
	} else {
		foreach (@keys) {
			$total = $states{$_};
			$s = $total == 1 ? '' : 's';
			print "State $_: $total time$s.\n";
		}
	}
}

# Queue mail in a 'fm' file (or whatever is specified for type). The mail is
# held in memory, within an array passed via a type-glob.
# Returns the name of queued file if success, undef if failed. File name will
# be absolute only when queued outside of the regular queue.
sub main'load_qmail {
	package main;
	local(*array, $type) = @_;	# In which array mail is located.
	local($queue_file);			# Where we attempt to save the mail
	local($failed) = 0;			# Be positive and look forward :-)
	local($name);				# Name of queued file
	$queue_file = "$cf'queue/Mqm$$";
	$queue_file = "$cf'queue/Mqmb$$" if -f "$queue_file";	# Paranoid
	unless (open(QUEUE, ">$queue_file")) {
		&add_log("ERROR unable to create $queue_file: $!") if $loglvl > 1;
		return 1;		# Failed
	}
	# Write mail on disk, making sure there is a first From line
	local($first_line) = 1;
	local($in_header) = 1;		# True while in mail header
	foreach $line (@array) {
		if ($first_line) {
			$first_line = 0;
			print QUEUE "$FAKE_FROM\n" unless $line =~ /^From\s+\S+/;
		}
		next if (print QUEUE $line, "\n");
		$failed = 1;
		&add_log("SYSERR write: $!") if $loglvl;
		last;
	}
	close QUEUE;
	unlink "$queue_file" if $failed;
	unless ($failed) {
		$type = 'fm' unless defined $type;	# Defaults to a 'fm' file
		$name = &queue_mail($queue_file, $type);
		$failed = defined $name ? 0 : 1;
	}
	$failed ? undef : $name;	# File path name, undef if failed
}

# Queue mail in a queue file. There are three types of queued mails:
#   . qm: messages whose handling will be delayed by at most cf'queuehold secs
#   . fm: messages queued for immediate processing by next 'mailagent -q'
#   . cm: callout queue messages, meant for input by callout command
# The mail is supposed to be either on disk or is expected from standard input.
# In case mail comes from stdin, may not return at all but raise a fatal error.
# Returns the name of queued file if success, undef if failed. File name will
# be absolute only when queued outside of the regular queue.
sub main'load_queue_mail {
	package main;
	local($file_name) = shift(@_);		# Where mail to-be-queued is
	local($type) = shift(@_);			# Type of mail message, must be known
	local($dirname);					# Directory name of processed file
	local($tmp_queue);					# Tempoorary storing of queued file
	local($queue_file);					# Final name of queue file
	local($ok) = 1;						# Print status
	local($_);
	&add_log("queuing mail ($type) for delayed processing") if $loglvl > 18;

	if ($file_name ne '' && $file_name !~ m|^/|) {
		local($cwd);
		chop($cwd = `pwd`);
		$file_name = "$cwd/$file_name"
	}
	chdir $cf'queue || &fatal("cannot chdir to $cf'queue");

	local(%known_type) = (				# Known queue message types
		'qm', 1,
		'fm', 1,
		'cm', 1,
	);
	unless ($known_type{$type}) {
		&add_log("ERROR unknown type $type, defaulting to qm") if $loglvl > 1;
		$type = 'qm';
	}

	# The following ensures unique queue mails. As the mailagent itself may
	# queue intensively throughout the SPLIT command, a queue counter is kept
	# and is incremented each time a mail is successfully queued.
	$queue_file = "$type$$";		# Append PID for uniqueness
	$queue_file = "$type${$}x" . $queue_count if -f "$queue_file";
	$queue_file = "${queue_file}x" while -f "$queue_file";	# Paranoid
	++$queue_count;					# Counts amount of queued mails
	&add_log("queue file is $queue_file") if $loglvl > 19;

	# Do not write directly in the fm file, otherwise the main
	# mailagent process could start its processing on it...
	$tmp_queue = "T$type$$";
	local($sender) = "<someone>";	# Attempt to report the sender of message
	if ($file_name) {				# Mail is already on file system
		# Mail already in a file
		$ok = 0 if &mv($file_name, $tmp_queue);
		if ($ok && open(QUEUE, $tmp_queue)) {
			while (<QUEUE>) {
				$Header{'All'} .= $_ unless defined $Header{'All'};
				if (1 .. /^$/) {		# While in header of message
					/^From:[ \t]*(.*)/ && ($sender = $1 );
				}
			}
			close QUEUE;
		}
	} else {
		# Mail comes from stdin or has already been stored in %Header
		unless (defined $Header{'All'}) {	# Only if mail was not already read
			$Header{'All'} = '';			# Needed in case of emergency
			if (open(QUEUE, ">$tmp_queue")) {
				while (<STDIN>) {
					$Header{'All'} .= $_;
					if (1 .. /^$/) {		# While in header of message
						/^From:[ \t]*(.*)/ && ($sender = $1);
					}
					(print QUEUE) || ($ok = 0);
				}
				close QUEUE;
			} else {
				$ok = 0;		# Signals: was not able to queue mail
			}
		} else {							# Mail already in %Header
			if (open(QUEUE, ">$tmp_queue")) {
				local($in_header) = 1;
				foreach (split(/\n/, $Header{'All'})) {
					if ($in_header) {		# While in header of message
						$in_header = 0 if /^$/;
						/^From:[ \t]*(.*)/ && ($sender = $1);
					}
					(print QUEUE $_, "\n") || ($ok = 0);
				}
				close QUEUE;
			} else {
				$ok = 0;		# Signals: was not able to queue mail
			}
		}
	}

	# If there has been some problem (like we ran out of disk space), then
	# attempt to record the temporary file name into the waiting file. If
	# mail came from stdin, there is not much we can do, so we panic.
	if (!$ok) {
		&add_log("ERROR could not queue message '$file_name'") if $loglvl;
		unlink $tmp_queue;
		if ($file_name) {
			# The file processed is already on the disk
			$dirname = $file_name;
			$dirname =~ s|^(.*)/.*|$1|;	# Keep only basename
			$cf'user = (getpwuid($<))[0] || "uid$<" if $cf'user eq '';
			$tmp_queue = "$dirname/$cf'user.$$";
			$tmp_queue = $file_name if &mv($file_name, $tmp_queue);
			&add_log("NOTICE mail held in $tmp_queue") if $loglvl > 4;
		} else {
			&fatal("mail may be lost");	# Mail came from filter via stdin
		}
		# If the mail is on the disk, add its name to the file $AGENT_WAIT
		# in the queue directory. This file contains the names of the mails
		# stored outside of the mailagent's queue and waiting to be processed.
		$ok = &waiting_mail($tmp_queue);
		return undef unless $ok;		# Queuing failed if not ok
		return $tmp_queue;
	}

	# We succeeded in writing the temporary queue mail. Now rename it so that
	# the mailagent may see it and process it.
	if (rename($tmp_queue, $queue_file)) {
		local($bytes) = (stat($queue_file))[7];	# Size of file
		local($s) = $bytes == 1 ? '' : 's';
		&add_log("QUEUED [$queue_file] ($bytes byte$s) from $sender")
			if $loglvl > 3;
	} else {
		&add_log("ERROR cannot rename $tmp_queue to $queue_file") if $loglvl;
		$ok = &waiting_mail($tmp_queue);
		$queue_file = $tmp_queue;
	}
	return undef unless $ok;			# Queuing failed if not ok
	$queue_file;						# Return file name for success
}

# Adds mail into the agent.wait file, if possible. This file records all the
# mails queued with a non-standard name or which are stored outside of the
# queue. Returns 1 if mail was successfully added to this list.
sub main'load_waiting_mail {
	package main;
	local($tmp_queue) = @_;
	local($error) = 0;
	local($old_size) = -s $AGENT_WAIT;
	local($locked) = 0 == &acs_rqst($AGENT_WAIT);

	&add_log("WARNING updating $AGENT_WAIT without lock")
		if !$locked && $loglvl > 5;

	if (open(WAITING, ">>$AGENT_WAIT")) {
		unless (print WAITING "$tmp_queue\n") {
			&add_log("ERROR could not write in $AGENT_WAIT: $!") if $loglvl > 1;
			$error++;
		}
		unless (close WAITING) {
			&add_log("ERROR could not flush $AGENT_WAIT: $!") if $loglvl > 1;
			$error++;
		}
	} else {
		&add_log("ERROR unable to open $AGENT_WAIT: $!") if $loglvl > 0;
		$error++;
	}

	&free_file($AGENT_WAIT) if $locked;

	if (!error && defined $old_size) {
		local($size) = -s $AGENT_WAIT;
		local($expected) = $old_size + length($tmp_queue) + 1;
		if ($size != $expected) {
			&add_log("ERROR $AGENT_WAIT has $size bytes (expected $expected)")
				if $loglvl > 1;
			$error++;
		}
	}

	if ($error) {
		&add_log("ERROR has forgotten about $tmp_queue") if $loglvl;
	} else {
		&add_log("NOTICE processing deferred for $tmp_queue") if $loglvl > 3;
	}

	return $error ? 0 : 1;			# 1 means success
}

# Performs a '/bin/mv' operation, but without the burden of an extra process.
sub main'load_mv {
	package main;
	local($from, $to) = @_;		# Original path and destination path
	# If the two files are on the same file system, then we may use the rename()
	# system call.
	if (&same_device($from, $to)) {
		&add_log("using rename system call") if $loglvl > 19;
		unless (rename($from, $to)) {
			&add_log("SYSERR rename: $!") if $loglvl;
			&add_log("ERROR could not rename $from into $to") if $loglvl;
			return 1;
		}
		return 0;
	}
	# Have to emulate a 'cp'
	&add_log("copying file $from to $to") if $loglvl > 19;
	unless (open(FROM, $from)) {
		&add_log("SYSERR open: $!") if $loglvl;
		&add_log("ERROR cannot open source '$from' to copy to '$to'")
			if $loglvl;
		return 1;
	}
	unless (open(TO, ">$to")) {
		&add_log("SYSERR open: $!") if $loglvl;
		&add_log("ERROR cannot create target '$to' to copy '$from' to it")
			if $loglvl;
		close FROM;
		return 1;
	}
	local($ok) = 1;		# Assume all I/O went all right
	local($_);
	while (<FROM>) {
		next if print TO;
		$ok = 0;
		&add_log("SYSERR write: $!") if $loglvl;
		last;
	}
	close FROM;
	close TO;
	unless ($ok) {
		&add_log("ERROR could not copy '$from' to '$to'") if $loglvl;
		unlink $to;
		return 1;
	}
	# Copy succeeded, remove original file
	unlink $from;
	0;					# Denotes success
}

# Look whether two paths refer to the same device.
# Compute basename and directory name for both files, as the file may
# not exist. However, if both directories are on the same file system,
# then so is it for the two files beneath each of them.
sub main'load_same_device {
	package main;
	local($from, $to) = @_;		# Original path and destination path
	local($fromdir, $fromfile) = $from =~ m|^(.*)/(.*)|;
	($fromdir, $fromfile) = ('.', $fromdir) if $fromfile eq '';
	local($todir, $tofile) = $to =~ m|^(.*)/(.*)|;
	($todir, $tofile) = ('.', $todir) if $tofile eq '';
	local($dev1) = stat($fromdir);
	local($dev2) = stat($todir);
	$dev1 == $dev2;
}

# Process the queue
sub main'load_pqueue {
	package main;
	local($length);						# Length of message, in bytes
	undef %waiting;						# Reset waiting array
	local(*DIR);						# File descriptor to list the queue
	unless (opendir(DIR, $cf'queue)) {
		&add_log("ERROR unable to open $cf'queue: $!") if $loglvl;
		return 0;						# No file processed
	}
	local(@dir) = readdir DIR;			# Slurp the all directory contents
	closedir DIR;

	# The qm files are put there by the filter and left in case of error
	# Only files older than 30 minutes are re-parsed (because otherwise it
	# might have just been queued by the filter). The fm files are normal
	# queued file which may be processed immediately.

	# Prefix each file name with the queue directory path
	local(@files) = grep(s|^fm|$cf'queue/fm| && !/$lockext$/o, @dir);
	local(@filter_files) = grep(s|^qm|$cf'queue/qm| && !/$lockext$/o, @dir);
	undef @dir;							# Directory listing not need any longer

	foreach $file (@filter_files) {
		($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
			$atime,$mtime,$ctime,$blksize,$blocks) = stat($file);
		if ((time - $mtime) > $cf'queuehold) {
			# More than queue timeout -- there must have been a failure
			push(@files, $file);		# Add file to the to-be-parsed list
		}
	}

	# In $AGENT_WAIT are stored the names of the mails outside the queue
	# directory, waiting to be processed. Empty lines (one being added by
	# &resync systematically) are skipped.
	if (-f $AGENT_WAIT) {
		local(*WAITING);
		local($_);
		if (open(WAITING, $AGENT_WAIT)) {
			while (<WAITING>) {
				chop;
				next unless length $_;	# Ignore empty lines
				push(@files, $_);		# Process this file too
				$waiting{$_} = 1;		# Record it comes from waiting file
			}
			close WAITING;
		} else {
			&add_log("ERROR cannot open $AGENT_WAIT: $!") if $loglvl;
		}
	}
	return 0 unless $#files >= 0;

	&add_log("processing the whole queue") if $loglvl > 11;
	$processed = 0;
	foreach $file (@files) {
		&add_log("dealing with $file") if $loglvl > 19;
		$file_name = $file;
		if ($waiting{$file} && ! -f $file) {
			# We may have already processed this file without having resynced
			# AGENT_WAIT or the file has been removed.
			&add_log ("WARNING could not find $file") if $loglvl > 4;
			$waiting{$file} = 0;	# Mark it as processed
			next;					# And skip it
		}
		local($ret) = &pmail($file, 1);
		if ($ret == 0) {
			++$processed;
			$waiting{$file} = 0 if $waiting{$file};
		} elsif ($ret != -1) {		# Not an error if mail was locked
			$file =~ s|.*/(.*)|$1|;	# Keep only basename
			&add_log("ERROR leaving [$file] in queue") if $loglvl > 0;
			unlink $lockfile;
			&resync;				# Resynchronize waiting file
			exit 0;					# Do not continue now
		}
	}
	if ($processed == 0) {
		&add_log("NOTICE was unable to process queue") if $loglvl > 5;
	}
	&resync;			# Resynchronize waiting file
	$processed;			# Return the number of files processed
}

# Process a single mail
sub main'load_pmail {
	package main;
	local($filename, $can_unlink) = @_;
	local($file) = $filename;
	$file =~ s|.*/(.*)|$1|;	# Keep only basename
	$file = '<stdin>' if $file eq '';

	# If not dealing with stdin... lock the file to ensure only one
	# mailagent deals with it.
	unless ($file eq '<stdin>') {
		local($try) = &acs_locktry($filename);
		if ($try != 0) {
			local($reason) = $try == 1 ? "already locked" : "cannot lock it";
			&add_log("WARNING skipping $filename ($reason)") if $loglvl > 4;
			return -1;	# Failed for locking reasons
		} else {
			&add_log("locked $filename") if $loglvl > 17;
		}
	}

	local($result) = &analyze_mail($filename);		# Analyze & filter message

	if ($result == 0) {
		local($len) = $Header{'Length'};
		my $msize = mail_logsize($filename);
		&add_log("FILTERED [$file]$msize ($len bytes)") if $loglvl > 4;
	}

	# If message was not from stdin and was processed successfully, unlink it
	unless ($file eq '<stdin>') {
		if ($result == 0 && $can_unlink && !unlink($filename)) {
			&add_log("SYSERR unlink: $!") if $loglvl;
			&add_log("ERROR unable to unlink $filename") if $loglvl;
		}
		if (0 == &free_file($filename)) {
			&add_log("unlocked $filename") if $loglvl > 17;
		} else {
			&add_log("ERROR cannot unlock $filename") if $loglvl;
		}
	}

	return $result;		# 0 if OK, 1 for analyze errors
}

# Send a receipt
sub main'load_send_receipt {
	package main;
	local($subj) =			$Header{'Subject'};
	local($msg_id) =		$Header{'Message-Id'};
	local($from) =			$Header{'From'};
	local($sender) =		$Header{'Reply-To'};
	local($to) =			$Header{'To'};
	local($ack_dest) = @_;	# Were to send receipt
	local($dest);			# Return path to be used (derived from mail)

	# If no @PATH directive was found, use $sender as a return path
	$dest = $Userpath;				# Set by an @PATH
	$dest = $sender unless $dest;
	# Remove the <> if any (e.g. path derived from Return-Path)
	$dest =~ /<(.*)>/ && ($dest = $1);

	# Derive a correct return path for receipt
	$ack_dest = 'PATH' if $ack_dest eq '-';
	$ack_dest = "" if $ack_dest =~ /[=\$^&*([{}`\\|;><?]/;
	$ack_dest = $dest if ($ack_dest eq '' || $ack_dest =~ /PATH/);

	my $hostname = &domain_addr;
	my $date;
	chop($date = `date`);
	open(MAILER,"|$cf'sendmail $cf'mailopt $ack_dest");
	print MAILER <<EOM;
To: $ack_dest
Subject: Re: $subj (receipt)
$MAILER
EOM
	if ($msg_id ne '') {
		print MAILER "\nYour message $msg_id,\n";
	} else {
		print MAILER "\nYour message ";
	}
	print MAILER "addressed to $to,\n" if $to ne '';
	print MAILER "whose subject was \"$subj\",\n" if $subj ne '';
	print MAILER <<EOM;
has been received by $hostname on $date

-- mailagent speaking for $cf'user
EOM
	close MAILER;
	if ($?) {
		&add_log("ERROR couldn't send receipt to $ack_dest") if $loglvl > 0;
	} else {
		&add_log("SENT receipt to $ack_dest") if $loglvl > 2;
	}
}

# Built-in commands are listed herein. Those commands being built-in are always
# dealt with during mail parsing and are taken care of at the beginning of the
# rules analysis. The code to be executed for each builtin is stored in the
# Builtcode array by those routines.
sub main'load_init_builtins {
	package main;
	%Builtin = (
		'RR', 'builtin_rr',
		'PATH', 'builtin_path'
	);
	undef @Builtcode;
}

# The @RR command asks for a receipt
sub main'load_builtin_rr {
	package main;
	local($_) = @_;
	&add_log("found an \@RR request to $_") if $loglvl > 18;
	# @RR request honored only if not from special user and directed to us
	unless (&special_user) {
		push(@Builtcode, "&send_receipt('$_')");
	} else {
		&add_log("ignoring \@RR request to $_") if $loglvl > 4;
	}
}

# The @PATH command sets a valid return path (recorded in $Userpath)
sub main'load_builtin_path {
	package main;
	local($_) = @_;
	return if /[=\$^&*([{}`\\|;><?]/;		# Invalid character found
	$Userpath = $_;
	&add_log("found an \@PATH request to $_") if $loglvl > 18;
}

# Execute stacked builtins
sub main'load_run_builtins {
	package main;
	undef @Builtcode;
	# Lookup for builtins. Code moved out of &parse_mail.
	# We scan the *decoded* body, not the original one
	foreach $line (split(/\n/, ${$Header{'=Body='}})) {
		if ($line =~ s/^@(\w+)\s*//) {			# A builtin command ?
			local($subroutine) = $Builtin{$1};
			&$subroutine($line) if $subroutine;	# Record it if known
		}
	}
	# End of original &parse_mail exerpt, beginning of original &run_builtins
	# NOTE: since builtins are now looked for here and run from there directly,
	# going through the burden of @Builtcode is not necessary. Will get fixed
	# one day, possibly.
	return if $#Builtcode < 0;		# No recorded builtins
	foreach (@Builtcode) {
		eval($_);					# Execute stacked builtin
	}
	undef @Builtcode;				# Reset builtcode array
}

# Compile the rules held in file $cf'rules (usually ~/.rules) or in memory
sub main'load_compile_rules {
	package main;
	local($mode);			# mode (optional)
	local($first_selector);	# selector (mandatory first time)
	local($selector);		# selector (optional)
	local($pattern);		# pattern to be matched
	local($action);			# associated action
	local($rulekeys);		# keys to rules in hash table
	local($rulenum) = 0;	# to compute unique keys for the hash table
	local($line);			# buffer for next rule
	local($env);			# environment variable recognized

	# This function is called whenever a new line rule has to be read. By
	# default, rules are read from a file, but if @Linerules is set, they
	# are read from there.
	local(*read_rule) = *read_filerule if @Linerules == 0;
	local(*read_rule) = *read_linerule if @Linerules > 0;

	unless ($edited_rules) {		# If no rules from command line
		unless (-s "$cf'rules") {	# No rule file or empty
			&default_rules;			# Build default rules
			return;
		}
		unless (open(RULES, "$cf'rules")) {
			&add_log("ERROR cannot open $cf'rules: $!") if $loglvl;
			&default_rules;			# Default rules will apply then
			return;
		}
		if (&rules'read_cache) {	# Rules already compiled and cached
			close RULES;			# No parsing needs to be done
			return;
		}
	} else {						# Rules in @Linerules array
		&rule_cleanup if @Linerules == 1;
	}

	while ($line = &get_line) {
		# Detect environment settings as soon as possible
		if ($line =~ s/^\s*(\w+)\s*=\s*//) {
			# All the variables referenced in the line have to be environment
			# variables. So replace them with the values we already computed as
			# perl variables. This enables us to do variable substitution in
			# perl with minimum trouble.
			$env = $1;								# Variable being changed
			$line =~ s/\$(\w+)/\$XENV{'$1'}/g;		# $VAR -> $XENV{'VAR'}
			$line =~ s/\s*;$//;						# Remove trailing ;
			eval "\$XENV{'$env'} = \"$line\"";		# Perl does the evaluations
			&eval_error;							# Report any eval error
			next;
		}
		$rulekeys = '';						# Reset keys for each line
		$mode = &get_mode(*line);			# Get operational mode
		&add_log("mode: <$mode>") if $loglvl > 19;
		$first_selector = &get_selector(*line);		# Fetch a selector
		$first_selector = "Subject:" unless $first_selector;
		$selector = $first_selector;
		for (;;) {
			if ($line =~ /^\s*;/) {			# Selector alone on the line
				&add_log("ERROR no pattern nor action, line $.") if $loglvl > 1;
				last;						# Ignore the whole line
			}
			&add_log("selector: $selector") if $loglvl > 19;
			# Get a pattern. If none is found, it is assumed to be '*', which
			# will match anything.
			$pattern = &get_pattern(*line);
			$pattern = '*' if $pattern =~ /^\s*$/;
			&add_log("pattern: $pattern") if $loglvl > 19;
			# Record entry in H table and update the set of used keys
			$Rule{"H$rulenum"} = "$selector $pattern";
			$rulekeys .= "H$rulenum ";
			$rulenum++;
			# Now look for an action. No action at the end means LEAVE.
			$action = &get_action(*line);
			$action = "LEAVE" if $action =~ /^\s*$/ && $line =~/^\s*;/;
			if ($action !~ /^\s*$/) {
				&add_log("action: $action") if $loglvl > 19;
				push(@Rules, "$mode {$action} $rulekeys");
				$rulekeys = '';		# Reset rule keys once used
			}
			last if $line =~ /^\s*;/;	# Finished if end of line reached
			last if $line =~ /^\s*$/;	# Also finished if end of file
			# Get a new selector, defaults to last one seen if none is found
			$selector = &get_selector(*line);
			$selector = $first_selector if $selector eq '';
			$first_selector = $selector;
		}
	}
	close RULES;		# This may not have been opened

	&default_rules unless @Rules;	# Use defaults if no valid rules

	# If rules have been compiled from a file and not entered on the command
	# line via -e switch(es), then $edited_rules is false and it makes sense
	# to cache the lattest compiled rules. Note that the 'rulecache' parameter
	# is optional, and rules are actually cached only if it is defined.

	&rules'write_cache unless $edited_rules;
}

# Build default rules:
#  -  Anything with 'Subject: Command' in it is processed.
#  -  All the mails are left in the mailbox.
sub main'load_default_rules {
	package main;
	&add_log("building default rules") if $loglvl > 18;
	@Rules = ("ALL {LEAVE; PROCESS} H0");
	$Rule{'H0'} = "All: /^Subject: [Cc]ommand/";
}

# Rule cleanup: If there is only one rule specified within the @Linerules
# array, it might not have {} braces.
sub main'load_rule_cleanup {
	package main;
	return if $Linerules[0] =~ /[{}]/;		# Braces found
	$Linerules[0] = '{' . $Linerules[0] . '}';
}

# Hook functions for dumping rules
sub main'load_print_rule_number {
	package main;
	local($rulenum) = @_;
	print "# Rule $rulenum\n";			# For easier reference
	1;									# Continue
}

# Void function
sub main'load_void_func {
	package main;
	print "\n";
}

# Print only rule whose number is held in variable $number
sub main'load_exact_rule {
	package main;
	$_[0] eq $number;
}

# Dump the rules we've compiled -- for debug purposes
sub main'load_dump_rules {
	package main;
	# The 'before' hook is called before each rule is called. It returns a
	# boolean stating wether we should continue or skip the rule. The 'after'
	# hook is called after the rule has been printed. Both hooks are given the
	# rule number as argument.
	local(*before, *after) = @_;	# Hook functions to be called
	local($mode);			# mode (optional)
	local($selector);		# selector (mandatory)
	local($rulentry);		# entry in rule H table
	local($pattern);		# pattern for selection
	local($action);			# related action
	local($last_selector);	# last used selector
	local($rules);			# a copy of the rules
	local($rulenum) = 0;	# each rule is numbered
	local($lines);			# number of pattern lines printed
	local(@action);			# split actions (split on ;)
	local($printed) = 0;	# characters printed on line so far
	local($indent);			# next item indentation
	local($linelen) = 78;	# maximum line length
	# Print the environement variable which differ from the original
	# environment, i.e. those variable which were set by the user.
	$lines = 0;
	foreach (sort keys(%XENV)) {
		unless ("$XENV{$_}" eq "$ENV{$_}") {
			print "$_ = ", $XENV{$_}, ";\n";
			$lines++;
		}
	}
	print "\n" if $lines;
	# Order wrt the one in the rule file is guaranteed
	foreach (@Rules) {
		$rulenum++;
		next unless &before($rulenum);				# Call 'before' hook
		$rules = $_;		# Work on a copy
		$rules =~ s/^([^{]*)\{// && ($mode = $1);	# First "word" is the mode
		$rules =~ s/\s*(.*)\}// && ($action = $1);	# Then action within {}
		$mode =~ s/\s*$//;							# Remove trailing spaces
		print "<$mode> ";							# Mode in which it applies
		$printed = length($mode) + 3;
		$rules =~ s/^\s+//;							# The rule keys remain
		$last_selector = "";						# Last selector in use
		$lines = 0;
		foreach $key (split(/ /, $rules)) {			# Loop over the keys
			$rulentry = $Rule{$key};
			$rulentry =~ s/^\s*([^\/]*:)// && ($selector = $1);
			$rulentry =~ s/^\s*//;
			$pattern = $rulentry;
			if ($last_selector eq $selector) {		# Try to stay on same line
				# Go to next line if current pattern won't fit nicely
				if ($printed + length($pattern) > $linelen) {
					$indent = length($mode) + length($selector) + 4;
					print ",\n", ' ' x $indent;
					$lines++;
					$printed = $indent;
				} else {
					print ", ";
					$printed += 2;
				}
			} else {								# Selector has changed
				if ($lines++) {
					$indent = length($mode) + 3;
					print ",\n", ' ' x $indent;
					$printed = $indent;
				}
			}
			if ($last_selector ne $selector) {		# Update last selector
				$last_selector = $selector;
				if ($selector ne 'script:') {		# Pseudo not printed
					print "$selector ";
					$printed += length($selector) + 1;
				}
			}
			if ($selector ne 'script:') {
				print "$pattern";					# Normal pattern
				$printed += length($pattern);
			} else {
				print "[[ $pattern ]] ";			# An interpreted script
				$printed += length($pattern) + 7;
			}
		}
		print "  " if $lines == 1 && ($printed += 2);

		# Split actions, but take care of escaped \; (layout purposes)
		$action =~ s/\\\\/\02/g;			# \\ -> ^B
		$action =~ s/\\;/\01/g;				# \; -> ^A
		@action = split(/;/, $action);
		foreach (@action) {					# Restore escapes by in-place edit
			s/\01/\\;/g;					# ^A -> \;
			s/\02/\\\\/g;					# ^B -> \\
		}

		# If action is large enough, format differently (one action/line)
		$lines++ if length($action) + 5 + $printed > $linelen;
		$indent = $lines > 1 ? length($mode) + 3 + 4 : 0;
		$printed = $indent == 0 ? $printed : $indent;
		if ((length($action) + $printed) > $linelen && @action > 1) {
			print "\n\t{\n";
			foreach $act (@action) {
				$act =~ s/^\s+//;
				print "\t\t$act;\n";
			}
			print "\t};\n";
		} else {
			print "\n", ' ' x $indent if $lines > 1;
			print "{ $action };\n";
		}
		$printed = 0;

		# Call the hook function after having printed the rule
		&after($rulenum);
	}
}

# Print only a specific rule on stdout
sub main'load_print_rule {
	package main;
	local($number) = @_;
	local(%XENV);			# Suppress printing of leading variables
	&dump_rules(*exact_rule, *nothing);
}

# Cache rules to the 'rulecache' file. The first line is the full pathname
# of the rule file, followed by the modification time stamp. The rulecache
# file will be recreated each time a different rule file is provided or when
# it is out of date. Note that this function is only called when actually
# compiling from the 'rules' file defined in the config file.
# The function returns 1 if success, 0 on failure.
sub rules'load_write_cache {
	package rules;
	return 0 unless defined $cf'rulecache;
	local(*CACHE);					# File handle used to write the cache
	if (0 != &'acs_rqst($cf'rulecache)) {
		&'add_log("NOTICE unable to write-lock $cf'rulecache") if $'loglvl > 6;
		return 0;					# Cannot write
	}
	unless (open(CACHE, ">$cf'rulecache")) {
		&'add_log("ERROR cannot create rule cache $cf'rulecache: $!")
			if $'loglvl;
		&'free_file($cf'rulecache);	# Unlock cache
		unlink $cf'rulecache;
		return 0;
	}
	local($error) = 0;
	local($ST_MTIME) = 9 + $[;
	local($mtime) = (stat($cf'rules))[$ST_MTIME];
	(print CACHE "$cf'rules $mtime\n") || $error++;
	&write_fd(CACHE) || $error++;		# Write rules
	&writevar_fd(CACHE) || $error++;	# And XENV variables
	close(CACHE) || $error++;
	&'free_file($cf'rulecache);		# Unlock cache
	if ($error) {
		unlink $cf'rulecache;
		&'add_log("WARNING could not cache rules") if $'loglvl > 5;
		return 0;
	}
	1;	# Success
}

# Read cached rules into @Rules and %Rules and returns 1 if done, 0 when
# the cache may not be read for whatever reason (e.g. out of date).
# Since the '-r' option may also need to cache rules and no mailagent lock
# is taken in that case, we need to lock the rule file before accessing it.
sub rules'load_read_cache {
	package rules;
	return 0 unless defined $cf'rulecache;
	if (0 != &'acs_rqst($cf'rulecache)) {
		&'add_log("NOTICE unable to read-lock $cf'rulecache") if $'loglvl > 6;
		return 0;					# Cannot read
	}
	unless (&cache_ok) {
		&'free_file($cf'rulecache);
		return 0;					# Cache outdated
	}
	local(*CACHE);					# File handle used to read the cache
	local($_);
	open(CACHE, $cf'rulecache) || return 0;	# Cannot open, assume out of date
	$_ = <CACHE>;					# Disregard top line
	while (<CACHE>) {				# First read the @Rules
		chop;
		last if /^$/;				# Reached end of @Rules table
		push(@'Rules, $_);
	}
	local($rulenum) = 0;
	while (<CACHE>) {				# Next read sorted values, assigned to H...
		chop;
		last if /^\+\+\+\+\+\+/;	# End of dumped rules
		$'Rule{"H$rulenum"} = $_;
		$rulenum++;
	}
	while (<CACHE>) {				# Read XENV variables
		chop;
		s/^\s*(\w+)\s*=\s*// && ($'XENV{$1} = $_);
	}
	close CACHE;
	&'free_file($cf'rulecache);		# Unlock cache
	1;	# Success
}

# Is cache up-to-date with respect to the rule file? Returns true if cache ok.
# The rule file should be read-locked by the caller.
sub rules'load_cache_ok {
	package rules;
	return 0 unless defined $cf'rulecache;
	local(*CACHE);					# File handle used to read the cache
	local($top);					# Top line recording file name and timestamp
	open(CACHE, $cf'rulecache) || return 0;	# Cannot open, assume out of date
	$top = <CACHE>;					# Get that first line
	close CACHE;
	local($name, $stamp) = split(' ', $top);
	return 0 if $name ne $cf'rules;	# File changed, cache out of date
	local($ST_MTIME) = 9 + $[;
	local($mtime) = (stat($cf'rules))[$ST_MTIME];
	$mtime != $stamp ? 0 : 1;		# Cache up-to-date only if $stamp == $mtime
}

# Dump the internal form of the rules, returning 1 for success.
sub rules'load_write_fd {
	package rules;
	local($file) = @_;				# Filehandle in which rules are to be dumped
	local($_);
	local($error) = 0;
	foreach (@'Rules) {
		(print $file $_, "\n") || $error++;
	}
	(print $file "\n") || $error++;	# A blank line separates tables
	foreach (sort hashkey keys %'Rule) {
		(print $file $'Rule{$_}, "\n") || $error++;
	}
	(print $file "++++++\n") || $error++;	# Marks end of dumped rules
	$error ? 0 : 1;		# Success when no error reported
}

# Dump the internal form of environment variables, returning 1 for success.
sub rules'load_writevar_fd {
	package rules;
	local($file) = @_;				# Filehandle in which variables are printed
	local($error) = 0;
	local($_);
	foreach (keys(%'XENV)) {
		unless ("$'XENV{$_}" eq "$'ENV{$_}") {
			(print $file "$_ = ", $'XENV{$_}, "\n") || $error++;
		}
	}
	$error ? 0 : 1;		# Success when no error reported
}

# The following sets-up a new rule environment and then transfers the control
# to some other function, giving it the remaining parameters. That enables the
# other function to work transparently with a different set of rules. Merely
# done for the APPLY function. Returns undef for errors, or propagates the
# result of the function.
sub rules'load_alternate {
	package rules;
	local($rules, $fn, @rest) = @_;
	local($'edited_rules) = 1;	# Signals that rules do not come from main file
	local(@'Linerules);			# We're stuffing our new rules there

	$rules =~ s/^~/$cf'home/;	# ~ substitution
	unless (open(RULES, $rules)) {
		&'add_log("ERROR cannot open alternate rule file $rules: $!")
			if $'loglvl;
		return undef;
	}
	local($_);
	while (<RULES>) {
		chop;					# Not really needed, but it'll save space :-)
		push(@'Linerules, $_);
		&'add_log("PUSH <<$_>>") if $'loglvl > 24;
	}
	close RULES;

	# Need at list two line rules or we'll try to apply some default fixes
	# used by the -e 'rules' switch...
	push(@'Linerules, '', '') if @'Linerules <= 1;

	# Make sure transfer function is package-qualified
	$fn = "main'$fn" unless $fn =~ /'/;

	# Create local instances of @Rules and %Rule that will get filled-up
	# by &compile_rules. Also make a copy of %XENV so that the local
	# rules may override some default settings.

	local(@'Rules);				# Set up a new dynamic environment...
	local(%'Rule);
	local(@xenv) = %'XENV;
	local(%'XENV) = @xenv;		# Local copy of previous environment

	&'compile_rules;	# Compile new rules held in the @'Linerules array
	&$fn(@rest);		# Transfer control in new environment
}

# Compute the number of seconds in the period. An atomic period is a digit
# possibly followed by a modifier. The default modifier is 'd'.
# Here are the available modifiers (case is significant):
#  m  minute
#  h  hour
#  d  day
#  w  week
#  M  month (30 days of 24 hours)
#  y  year
sub main'load_seconds_in_period {
	package main;
	local($_) = @_;				# The string to parse
	s|^(\d+)||;
	local ($number) = int($1);	# Number of elementary periods
	$_ = 'd' unless /^\s*\w$/;	# Period modifier (defaults to day)
	local($sec);				# Number of seconds in an atomic period
	if ($_ eq 'm') {
		$sec = 60;				# One minute = 60 seconds
	} elsif ($_ eq 'h') {
		$sec = 3600;			# One hour = 3600 seconds
	} elsif ($_ eq 'd') {
		$sec = 86400;			# One day = 24 hours
	} elsif ($_ eq 'w') {
		$sec = 604800;			# One week = 7 days
	} elsif ($_ eq 'M') {
		$sec = 2592000;			# One month = 30 days
	} elsif ($_ eq 'y') {
		$sec = 31536000;		# One year = 365 days
	} else {
		$sec = 86400;			# Unrecognized: defaults to one day
	}
	$number * $sec;				# Number of seconds in the period
}

#############################################################
# given seconds, convert to 7y4d9h23m15s format.
# Author: Tom Christiansen
#############################################################
sub main'load_relative_age {
	package main;
	my $secs = shift;
	my($years, $days, $hours, $mins);

	$years = int($secs / (365 * 24 * 60 * 60));
	$secs -= $years    * (365 * 24 * 60 * 60);

	$days  = int($secs / (24 * 60 * 60));
	$secs -= $days     * (24 * 60 * 60);

	$hours = int($secs / (60 * 60));
	$secs -= $hours    * (60 * 60);

	$mins  = int($secs / 60);
	$secs -= $mins     * 60;

	my $retstr  = '';
	$retstr .= $years . "y" if $years;
	$retstr .= $days  . "d" if $days;
	$retstr .= $hours . "h" if $hours;
	$retstr .= $mins  . "m" if $mins;
	$retstr .= $secs  . "s" if $secs;

	return $retstr;

}

# Initialize the interpreter
sub main'load_init_interpreter {
	package main;
	&set_priorities;		# Fill in %Priority
	&set_functions;			# Fill in %Function
	$macro_T = "the Epoch";	# Default value for %T macro substitution
}

# Priorities for operators -- magic numbers :-)
# An operator with higher priority will evaluate before another with a lower
# one. For instance, given the priorities listed hereinafter, a && b == c
# would evaluate as a && (b == c).
sub main'load_set_priorities {
	package main;
	%Priority = (
		'&&',		4,
		'||',		3,
		'>=',		6,
		'<=',		6,
		'<',		6,
		'>',		6,
		'==',		6,
		'!=',		6,
		'=~',		6,
		'!~',		6,
	);
}

# Perl functions handling operators
sub main'load_set_functions {
	package main;
	%Function = (
		'&&',		'f_and',			# Boolean AND
		'||',		'f_or',				# Boolean OR
		'>=',		'f_ge',				# Greated or equal
		'<=',		'f_le',				# Lesser or equal
		'>',		'f_gt',				# Greater than
		'<',		'f_lt',				# Lesser than
		'==',		'f_eq',				# Equal as strings
		'!=',		'f_ne',				# Different (not equal)
		'=~',		'f_match',			# Match
		'!~',		'f_nomatch',		# No match
	);
}

# Print error messages -- asssumes $unit and $. correctly set.
sub main'load_error {
	package main;
	&add_log("ERROR @_") if $loglvl > 1;
}

# Add a value on the stack, modified by all the monadic operators.
# We use the locals @val and @mono from eval_expr.
sub main'load_push_val {
	package main;
	local($val) = shift(@_);
	while ($#mono >= 0) {
		# Cheat... the only monadic operator is '!'.
		pop(@mono);
		$val = !$val;
	}
	push(@val, $val);
}

# Execute a stacked operation, leave result in stack.
# We use the locals @val and @op from eval_expr.
# If the value stack holds only one operand, do nothing.
sub main'load_execute {
	package main;
	return unless $#val > 0;
	local($op) = pop(@op);			# The operator
	local($val2) = pop(@val);		# Right value in algebraic notation
	local($val1) = pop(@val);		# Left value in algebraic notation
	local($func) = $Function{$op};	# Function to be called
	&macros_subst(*val1);			# Expand macros
	&macros_subst(*val2);
	push(@val, eval("&$func($val1, $val2)") ? 1: 0);
}

# Given an operator, either we add it in the stack @op, because its
# priority is lower than the one on top of the stack, or we first execute
# the stacked operations until we reach the end of stack or an operand
# whose priority is lower than ours.
# We use the locals @val and @op from eval_expr.
sub main'load_update_stack {
	package main;
	local($op) = shift(@_);		# Operator
	if (!$Priority{$op}) {
		&error("illegal operator $op");
		return;
	} else {
		if ($#val < 0) {
			&error("missing first operand for '$op' (diadic operator)");
			return;
		}
		# Because of a bug in perl 4.0 PL19, I'm using a loop construct
		# instead of a while() modifier.
		while (
			$Priority{$op[$#op]} > $Priority{$op}	# Higher priority op
			&& $#val > 0							# At least 2 values
		) {
			&execute;	# Execute an higer priority stacked operation
		}
		push(@op, $op);		# Everything at higher priority has been executed
	}
}

# This is the heart of our little interpreter. Here, we evaluate
# a logical expression and return its value.
sub main'load_eval_expr {
	package main;
	local(*expr) = shift(@_);	# Expression to parse
	local(@val) = ();			# Stack of values
	local(@op) = ();			# Stack of diadic operators
	local(@mono) =();			# Stack of monadic operators
	local($tmp);
	$_ = $expr;
	while (1) {
		s/^\s+//;				# Remove spaces between words
		# A perl statement <<command>>
		if (s/^<<//) {
			if (s/^(.*)>>//) {
				&push_val((system
					('perl','-e', "if ($1) {exit 0;} else {exit 1;}"
					))? 0 : 1);
			} else {
				&error("incomplete perl statement");
			}
		}
		# A shell statement <command>
		elsif (s/^<//) {
			if (s/^(.*)>//) {
				&push_val((system
					("if $1 >/dev/null 2>&1; then exit 0; else exit 1; fi"
					))? 0 : 1);
			} else {
				&error("incomplete shell statement");
			}
		}
		# The '(' construct
		elsif (s/^\(//) {
			&push_val(&eval_expr(*_));
			# A final '\' indicates an end of line
			&error("missing final parenthesis") if !s/^\\//;
		}
		# Found a ')' or end of line
		elsif (/^\)/ || /^$/) {
			s/^\)/\\/;						# Signals: left parenthesis found
			$expr = $_;						# Remove interpreted stuff
			&execute while $#val > 0;		# Executed stacked operations
			while ($#op >= 0) {
				$_ = pop(@op);
				&error("missing second operand for '$_' (diadic operator)");
			}
			return $val[0];
		}
		# Diadic operators
		elsif (s/^(\|\||&&|>=|<=|>|<|==|!=|=|\/=)//) {
			&update_stack($1);
		}
		# Unary operator '!'
		elsif (s/^!//) {
			push(@mono,'!');
		}
		# Everything else is a value which stands for itself (atom)
		elsif (s/^([\w'"%]+)//) {
			&push_val($1);
		}
		# Syntax error
		else {
			print "Syntax error: remaining is >>>$_<<<\n";
			$_ = "";
		}
	}
}

# Call eval_expr and check that everything is ok (e.g. the stack must be empty)
sub main'load_evaluate {
	package main;
	local($val);					# Value returned
	local(*expr) = shift(@_);		# Expression to be parsed
	while ($expr) {
		$val = &eval_expr(*expr);	# Expression will be modified
		print "extra closing parenthesis ignored.\n" if $expr =~ s/^\\\)*//;
		$expr = $val . $expr if $expr ne '';
	}
	$val;
}

# Compute the relative path under the once directory for a given name
sub dbr'load_hash_path {
	package dbr;
	local($hname) = @_;
	# Ensure at least 2 characters. Fill in missing chars with 'X'.
	$hname .= "X" if (length($hname) < 2);
	$hname .= "X" if (length($hname) < 2);
	$hname =~ s/[^A-Za-z0-9_]/X/g;	# Don't want funny chars in path name
	# Get only the 2 first characters
	local(@chars) = split(//, substr($hname, 0, 2));
	'/' . join('/', @chars);
}

# Fetch the entry in a dbr file and return the value of the timestamp and
# the line number in the file. Return (0,0) if no previous record was found
# for the name/tag association. An error is signaled by (-1,0). A line number
# different from 0, as in (0, 10), indicates that an entry was found but the
# selection did not succeed. Note that the timestamp returned is > 0 iff the
# entry was found and the selection was done completely.
# All the attached values are returned at the end of the list. It is possible
# to filter among those values by specifying a list of regular expressions, at
# the end of the argument list. An empty regular expression means the item is
# not to be filtered on (equivalent of '/.*/'). Expressions provided are
# taken as exact values to be matched against unless they start with '/' or '&'.
# A '/' denotes a regular expression to be applied, whilst '&' denotes function
# to be called with the actual value argument: function should return zero
# for rejection or any other value for selection.
sub dbr'load_info {
	package dbr;
	local($hname, $tag, @what) = @_;
	local($file);						# DBR file associated with '$hname'
	local(@values);						# Attached values to the item
	local($_);
	($hname, $tag) = &default($hname, $tag);
	$file = $cf'hashdir . &hash_path($hname);
	return (0,0) unless -f "$file";
	unless (open(DBR, $file)) {
		&'add_log("ERROR could not open dbr file $file: $!") if $'loglvl;
		return (-1, 0);
	}
	local($linenum) = 0;				# Value of line if found
	local($timestamp) = 0;				# Associated time stamp
	&'acs_rqst($file);					# Lock file (avoid concurrent updating)
	while (<DBR>) {
		if (s/^(\S+)\s([\w-]+)\s(\d+)\t*//) {
			next unless $1 eq $hname;
			next unless $2 eq $tag;
			$linenum = $.;				# Record line number
			$timestamp = int($3);		# And timestamp
			last if &match;				# Found it if matches @what filter
			$timestamp = 0;				# Not found yet
		} else {						# Invalid entry
			&'add_log("ERROR $file corrupted, line $.") if $'loglvl;
			$timestamp = -1;			# Signals error
			last;						# Abort processing
		}
	}
	&'free_file($file);					# Remove lock on file
	close DBR;							# Close file
	($timestamp, $linenum, @values);	# Return item information
}

# Apply match from @what, and fill in @values as a side effect if matched.
sub dbr'load_match {
	package dbr;
	local(@target) = split(/\t|\n/);	# Get values from line
	local($idx) = -1;					# Index within @target
	local($matched) = 1;				# Assume selection will match
	local($res);						# Eval result
	local($@);							# Eval error report string
	foreach $what (@what) {
		$idx++;							# Advance in @target
		next if $what eq '';			# Skip empty selection
		if ($what =~ m|^/|) {			# Regular expression
			$res = eval '$target[$idx] =~ ' . $what;
			&'add_log("WARNING dbr error: $@") if $@ && $'loglvl > 5;
			next if $@;
			$matched = $res;
		} elsif ($what =~ m|^&|) {		# Function to apply
			$res = eval "$what('" . $target[$idx] . "')";
			&'add_log("WARNING dbr error: $@") if chop($@) && $'loglvl > 5;
			next if $@;
			$matched = $res;
		} else {						# Regular string comparaison
			$matched = $target[$idx] eq $what;
		}
		last unless $matched;
	}
	@values = @target if $matched;		# Fill in values if selection ok
	$matched;							# Return matching status
}

# Update the entry ($hname, $tag) in file to hold the current timestamp. If the
# $linenum parameter is non-null, we know we may copy the old file until that
# line (excluded), then replace the current line with the new timestamp.
# If $linenum is null, then we may safely append the entry in the file. If
# the $linenum parameter is 'undef', then the user does not have it precomputed
# or wishes to have the line number re-computed.
# The new values held in @values replace the old ones for the entry. If 'undef'
# is given instead, then the corresponding entry is deleted from the database.
sub dbr'load_update {
	package dbr;
	local($hname, $tag, $linenum, @values) = @_;
	local($now) = time;					# Current time
	local($file);						# DBR file associated with '$hname'
	local($_);
	($hname, $tag) = &default($hname, $tag);
	$file = $cf'hashdir . &hash_path($hname);
	unless (-f "$file") {
		local($dirname) = $file =~ m|^(.*)/.*|;
		&'makedir($dirname);
	}
	$linenum = (&info($hname, $tag))[1] unless defined($linenum);
	if ($linenum == 0) {				# No entry previously recorded
		return unless @values;			# Nothing to delete
		unless(open(DBR, ">>$file")) {
			&'add_log("ERROR cannot append in $file: $!") if $'loglvl;
			return;
		}
		&'acs_rqst($file);				# Lock file (avoid concurrent updating)
		print DBR "$hname $tag $now\t";	# The name, command tag and timestamp
		print DBR join("\t", @values);	# Associated values
		print DBR "\n";
		close DBR;
		&'free_file($file);				# Remove lock on file
	} else {							# An entry existed already
		unless (open(DBR, ">$file.x")) {
			&'add_log("ERROR cannot create $file.x: $!") if $'loglvl;
			return;
		}
		unless (open(OLD, "$file")) {
			&'add_log("ERROR couldn't reopen $file: $!") if $'loglvl;
			close DBR;
			return;
		}
		&'acs_rqst($file);				# Lock file (avoid concurrent updating)
		while (<OLD>) {
			if ($. < $linenum) {		# Before line to update
				print DBR;				# Print line verbatim
			} elsif ($. == $linenum) {	# We reached line to be updated
				next unless @values;
				print DBR "$hname $tag $now\t";
				print DBR join("\t", @values);
				print DBR "\n";
			} else {					# Past updating point
				print DBR;				# Print line verbatim
			}
		}
		close OLD;
		close DBR;
		unless (rename("$file.x", "$file")) {
			&'add_log("ERROR cannot rename $file.x to $file: $!") if $'loglvl;
		}
		&'free_file($file);				# Remove lock on file
	}
}

# Delete entry. This is really a wrapper to the more general update routine
# and is provided as a convenience only.
sub dbr'load_delete {
	package dbr;
	local($hname, $tag, $linenum) = @_;
	&update($hname, $tag, defined($linenum) ? $linenum : undef, undef);
}

# Make sure the hashing name and the tag are correct, or use default values.
sub dbr'load_default {
	package dbr;
	local($hname, $tag) = @_;
	$hname =~ s/^\s+//;					# Leading blanks would perturb dbr
	$hname =~ s/\s/_/g;					# All other spaces replaced by _
	$hname = 'X' unless $hname;			# Hashing name cannot be empty
	$tag =~ s/\s/_/g;					# Tag has to be a single word
	$tag = 'UNKNOWN' unless $tag;		# Tag cannot be empty
	($hname, $tag);
}

# Cleaning operation. Remove all the entries in the file whose timestamp is
# older than the supplied date limit.
sub dbr'load_clean {
	package dbr;
	local($agemax) = @_;
	local($limit) = time - $agemax;		# Everything newer is kept
	&recursive_clean($cf'hashdir);		# Recursively scan directory
}

# Recursively scan the direcroy and deal with each file
sub dbr'load_recursive_clean {
	package dbr;
	local($dir) = @_;					# Directory to scan
	local(@contents);					# Contents of the directory
	unless (opendir(DIR, $dir)) {
		&'add_log("ERROR cannot open directory $dir: $!") if $'loglvl > 1;
		return;
	}
	@contents = readdir(DIR);			# Slurp the whole thing
	closedir DIR;						# And close dir, ready for recursion
	local($_);
	foreach (@contents) {
		next if $_ eq '.' || $_ eq '..';
		if (-d "$dir/$_") {
			&recursive_clean("$dir/$_");
			next;
		}
		&clean_file("$dir/$_");
	}
	unless (opendir(DIR, $dir)) {
		&'add_log("ERROR cannot re-open directory $dir: $!") if $'loglvl > 1;
		return;
	}
	@contents = readdir(DIR);			# Slurp the whole thing
	closedir DIR;
	unless (@contents > 2) {			# Has at least . and ..
		unless (rmdir($dir)) {			# Don't leave empty directories
			&'add_log("SYSERR rmdir: $!") if $'loglvl;
			&'add_log("ERROR could not remove directory $dir") if $'loglvl;
		}
	}
}

# Clean single dbr file, using $limit as the oldest allowed time stamp
sub dbr'load_clean_file {
	package dbr;
	local($file) = @_;			# File to be cleaned
	&'add_log("processing $file") if $'loglvl > 18;
	unless (open(FILE, $file)) {
		&'add_log("ERROR cannot open file $file: $!") if $'loglvl > 1;
		return;
	}
	unless (open(NEW, ">$file.x")) {
		&'add_log("ERROR cannot create $file.x: $!") if $'loglvl > 1;
		close FILE;
		return;
	}
	&'acs_rqst($file);			# Lock file to prevent concurrent mods
	local($warns) = 0;			# Avoid cascade warnings
	local($_, $.);
	while (<FILE>) {
		if (/^(\S+)\s([\w-]+)\s(\d+)\t*/) {
			# Variable $limit was set in 'clean'
			if ($3 > $limit) {			# File new enough
				next if (print NEW);	# Copy line verbatim
				&'add_log("SYSERR write: $!") if $'loglvl;
				&'add_log("WARNING truncated $file at line $.") if $'loglvl > 5;
				last;
			}
		} else {
			# Skip bad lines, up to a maximum of 10
			if (++$warns > 10) {
				&'add_log("WARNING $file truncated at line $.") if $'loglvl > 5;
				last;
			} else {
				&'add_log("NOTICE $file corrupted, line $.") if $'loglvl > 6;
				next;
			}
		}
	}
	close FILE;
	close NEW;
	unless (rename("$file.x", $file)) {
		&'add_log("ERROR cannot rename $file.x to $file: $!") if $'loglvl;
	}
	unless (-s "$file") {
		unless (unlink($file)) {	# Don't leave empty files behind
			&'add_log("SYSERR unlink: $!") if $'loglvl;
			&'add_log("ERROR could not remove $file") if $'loglvl;
		}
	}
	&'free_file($file);				# Remove lock on file
}

# Record the message ID of the current message and return 0 if the
# message was recorded for the first time or if there is no valid message ID.
# Return 1 if the message was already recorded, and hence was already seen.
# If tags are provided (string list of words, separated by commas), then
# information is only fetched/recorded for those tags.
sub main'load_history_tag {
	package main;
	local($tags) = @_;
	local($msg_id) = $Header{'Message-Id'};		# Message-ID header

	# If there is no message ID, use the concatenation of date + from fields.
	if ($msg_id) {
		# Keep only the first ID stored within <> brackets, clean it up
		($msg_id) = $msg_id =~ m|(<[^>]*>)\s*|;
		&header'msgid_cleanup(\$msg_id);	# Requires <> in message ID
		$msg_id =~ s/^<//;					# Remove leading "<"
		chop($msg_id);						# and trailing ">"
	} else {
		# Use date + from iff there is a date. We cannot use the from field
		# alone, obviously!! We also have to ensure there is an '@' in the
		# message id, which is the case unless the address is in uucp form.
		$msg_id = $Header{'Date'};
		local($from, $comment) = &parse_address($Header{'From'});
		$from =~ s/^([\w-.]+)!([\w-.]+)/\@$1:$2/;	# host!user -> @host:user
		$msg_id .= '.' . $from if $msg_id;
	}
	$msg_id =~ s/\s+/./g;			# Suppress all spaces
	$msg_id =~ s/\(a\)/@/;			# X-400 gateways sometimes use (a) for @
	return 0 unless $msg_id;		# Cannot record message without an ID

	# Hashing of the message ID is done based on the two first letters of
	# the host name (assuming message ID has the form whatever@host or
	# whatever@[internet.number]).
	local($stamp, $host) = $msg_id =~ m|^(.*)@([.\w]+)|;
	($stamp, $host) = $msg_id =~ m|^(.*)@\[([.\d]+)\]| unless $stamp;
	unless ($stamp) {
		&add_log("WARNING incorrect message ID <$msg_id>") if $loglvl > 5;
		return 0;					# Cannot record message if invalid ID
	}

	# Compute a tag array. If no tag given, insert a null tag so that we
	# enter the loop below anyway.

	$tags =~ s/\s+//g;
	local(@tags) = split(/,+/, $tags);
	push(@tags, '') unless @tags;

	# Now loop for each tag given. We record the message ID stamp followed
	# by a tab, then the tag between <>. If no tag is given, we look for any
	# occurence.

	local($time, $line);			# Time stamp, line number of DBR entry
	local(@regexp);					# DBR regular expression lookup
	local($seen) = 0;				# Assume new instance

	foreach $tag (@tags) {
		@regexp = ($stamp);
		push(@regexp, "<$tag>") if $tag ne '';
		($time, $line) = &dbr'info($host, 'HISTORY', @regexp);
		if ($time == -1) {			# An error occurred
			&add_log("ERROR while dbr-looking for '@regexp'") if $loglvl > 1;
			next;
		}
		if ($time > 0) {			# Message already recorded
			local($tagmsg) = $tag eq '' ? '' : " ($tag)";
			&add_log("history duplicate <$msg_id>" . $tagmsg) if $loglvl > 6;
			$seen++ unless history_ignore($msg_id, $tag);
		} else {					# Record message (appending)
			&dbr'update($host, 'HISTORY', 0, @regexp);
		}
	}
	return $seen;					# Return seen status
}

# Look at whether we should ignore the duplicate if -U was given
# We ignore the first match for a given tag, so if one of the tags here
# was already recorded in %ignored_history_tag, we ignore the -U switch.
# The reason is that different paths in the rules could lead to a UNIQUE
# command that is meant to trap the fact the message was already seen...
# Return TRUE if we need to ignore the duplicate for this time
sub main'load_history_ignore {
	package main;
	my ($msg_id, $tag) = @_;
	return 0 unless $disable_unique;		# return unless -U given
	if ($ignored_history_tag{$tag}++) {
		# We already ignored once for this tag
		add_log("not ignoring this duplicate <$msg_id>$tagmsg despite -U")
			if $loglvl > 6;
		return 0
	}
	my $tagmsg = $tag eq '' ? '' : " ($tag)";
	add_log("ignoring duplicate <$msg_id>$tagmsg since you gave -U")
		if $loglvl > 6;
	return 1;				# Ignore this duplicate
}

# Obsolete -- will be removed in next release
sub main'load_history_record {
	package main;
	&history_tag();
}

# Given a tuple (name, tag) and a period, make sure the command may be
# executed. If it can, update the timestamp and return true. false otherwise.
sub main'load_once_check {
	package main;
	local($hname, $tag, $period) = @_;
	$hname =~ s/\s//g;					# There cannot be spaces in the name
	local($ok) = 1;						# Is once ok ?
	local($timestamp) = 0;				# Time stamp attached to entry
	local($linenum) = 0;				# Line where entry was found
	($timestamp, $linenum) = &dbr'info($hname, 'ONCE', $tag);
	return 0 if $timestamp == -1;		# An error occurred
	local($now) = time;					# Number of seconds since The Epoch
	if (($timestamp + $period) > $now) {
		&'add_log("we have to wait for ($hname, $tag)") if $'loglvl > 18;
		return 0;
	}
	# Now we know we can execute the command. So update the database entry.
	# If the timestamp is 0, then an append has to be done, otherwise it's
	# a single replacement.
	if ($timestamp > 0) {
		&dbr'update($hname, 'ONCE', $linenum, $tag);
	} else {
		&dbr'update($hname, 'ONCE', 0, $tag);
	}
	1;
}

# Make directories for files
# E.g, for /usr/lib/perl/foo, it will check for all the directories /usr,
# /usr/lib, /usr/lib/perl and make them if they do not exist.
# Note: default mode is now 0777 since we have an umask config parameter.
sub main'load_makedir {
	package main;
	local($dir, $mode) = @_;	# directory name, mode (optional)
	local($parent);
	$mode = 0777 unless defined $mode;
	$dir =~ s|/$||;				# no trailing / or we'll try to make dir twice
	if (!-d $dir && $dir ne '') {
		# Make parent dir first
		&makedir($parent, $mode) if ($parent = $dir) =~ s|(.*)/.*|$1|;
		if (mkdir($dir, $mode)) {
			&add_log("creating directory $dir") if $loglvl > 19;
		} else {
			&add_log("ERROR cannot create directory $dir: $!")
				if $loglvl > 1;
		}
	}
}

# In case something got wrong
sub main'load_fatal {
	package main;
	local($reason) = shift;		# Why did we get here ?
	local($preext) = 0;
	local($added) = 0;
	local($curlen) = 0;

	# Make sure the lock file does not last. We don't need any lock now, as
	# we are going to die real soon anyway.
	unlink $lockfile if $locked;

	# Assume the whole message has not been read yet
	$fd = STDIN;				# Default input
	if ($file_name ne '') {
		$Header{'All'} = '';	# We're about to re-read the whole message
		open(MSG, $file_name);	# Ignore errors
		$fd = MSG;
		$preext = -s MSG;
	}
	if ($preext <= 0) {
		$preext = 100000;
		&add_log ("preext uses fixed value ($preext)") if $loglvl > 19;
	} else {
		&add_log ("preext uses file size ($preext)") if $loglvl > 19;
	}

	# We have to careful here, because when reading from STDIN
	# $Header{'All'} might not be empty
	$curlen = length($Header{'All'});
	&add_log ("pre-extended retaining $curlen old bytes") if $loglvl > 19;
	$Header{'All'} .= ' ' x $preext;
	substr($Header{'All'}, $curlen) = '';

	unless (-t $fd) {			# Do not get mail if connected to a tty
		while (<$fd>) {
			$added += length($_);
			if ($added > $preext) {
				$curlen = length($Header{'All'});
				&add_log ("extended after $curlen bytes") if $loglvl > 19;
				$Header{'All'} .= ' ' x $preext;
				substr($Header{'All'}, $curlen) = '';
				$added = $added - $preext;
			}
			$Header{'All'} .= $_;
		}
	}

	# It can happen that we get here before configuration file was read
	&add_log("FATAL $reason") if defined $loglvl;
	-t STDIN && print STDERR "$prog_name: $reason\n";

	# Try an emergency save, if mail is not empty
	if ($Header{'All'} ne '' && 0 == &emergency_save) {
		# The stderr should be redirected to some file
		$file_name =~ s|.*/(.*)|$1|;	# Keep only basename
		$file_name = "<stdin>" if $file_name eq '';
		print STDERR "**** $file_name not processed ($reason) ****\n";
		print STDERR $Header{'All'};
		($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);
		print STDERR "---- $date ----\n";
	}

	&resync;			# Resynchronize waiting file if necessary
	# Give an error exit status to filter
	exit 1;
}

# Emergency saving of message held in $Header{'All'}. If the 'emergdir'
# configuration parameter in ~/.mailagent is set to an existing directory, the
# first saving attempt is made there (each mail in a separate file).
sub main'load_emergency_save {
	package main;
	return 0 unless (defined $cf'home);	# ~/.mailagent not processed
	return 1 if -d "$cf'emergdir" && &dump_mbox("$cf'emergdir/ma$$");
	return 1 if &dump_mbox(&mailbox_name);
	return 1 if &dump_mbox("$cf'home/mbox.urgent");
	return 1 if &dump_mbox("$cf'home/mbox.urg$$");
	return 1 if &dump_mbox("/usr/spool/uucppublic/mbox.$cf'user");
	return 1 if &dump_mbox("/var/spool/uucppublic/mbox.$cf'user");
	return 1 if &dump_mbox("/usr/tmp/mbox.$cf'user");
	return 1 if &dump_mbox("/var/tmp/mbox.$cf'user");
	return 1 if &dump_mbox("/tmp/mbox.$cf'user");
	&add_log("ERROR unable to save mail in any emergency mailbox") if $loglvl;
	0;
}

# Dump $Header{'All'} in emergency mailbox
sub main'load_dump_mbox {
	package main;
	local($mbox) = shift(@_);
	local($ok) = 0;						# printing status
	local($existed) = 0;				# did the mailbox exist already ?
	local($old_size);					# Size the old mailbox had
	local($new_size);					# Size of the mailbox after saving
	local($should);						# Size it should have if saved properly
	$existed = 1 if -f $mbox;
	$old_size = $existed ? -s $mbox : 0;
	if (open(MBOX, ">>$mbox")) {
		(print MBOX $Header{'All'}) && ($ok = 1);
		print MBOX "\n";				# allow parsing by other mail tools
		close(MBOX) || ($ok = 0);
		$new_size = -s $mbox;			# Stat new mbox file, grab its size
		$should = $old_size +			# New ideal size is old size plus...
			length($Header{'All'}) +	# ... the length of the message saved
			1;							# ... the trailing new-line
		if ($should != $new_size) {
			&add_log("ERROR $mbox has $new_size bytes (should have $should)")
				if $loglvl;
			$ok = 0;					# Saving failed, sorry...
		}
		if ($ok) {
			&add_log("DUMPED in $mbox") if $loglvl > 5;
			return 1;
		} else {
			if ($existed) {
				&add_log("WARNING imcomplete mail appended to $mbox")
					if $loglvl > 5;
			} else {
				unlink "$mbox";			# remove incomplete file
			}
		}
	}
	0;
}

# Utility routine for resync() below: writes %waiting keys to opened file.
# The file is closed at the end of the operation.
# Returns true if OK.
sub main'load_write_waitkeys {
	package main;
	local(*FILE, @extra) = @_;
	local($ok) = 1;					# Assume resync is ok
	local($_);
	foreach (keys %waiting) {
		if ($waiting{$_}) {
			(print FILE "$_\n") || ($ok = 0);
			unless ($ok) {
				&add_log("SYSERR write: $!") if $loglvl;
				last;
			}
		}
	}
	# Even if !$ok, try appending any extra file, in case it works
	foreach (@extra) {
		(print FILE "$_\n") || ($ok = 0);
		unless ($ok) {
			&add_log("SYSERR write: $!") if $loglvl;
			last;
		}
	}
	(print FILE "\n") || ($ok = 0);	# Trailing blank line
	close(FILE) || ($ok = 0);
	&add_log("SYSERR close: $!") if !$ok && $loglvl;
	return $ok;
}

# Resynchronizes the waiting file if necessary.
#
# In order to have the filesystem reserve at least a block, we systematically
# write an empty line at the end of the waiting file, to avoid it being
# empty. That way, even when the filesystem is otherwise full, there is some
# space reserved to store data.
sub main'load_resync {
	package main;
	return if $cf'spool eq '';		# Agent wait is in spool directory
	&add_log("resynchronizing the waiting file") if $loglvl > 11;
	local *WAITING;
	local($ok) = 0;

	# We need to protect against concurrent accesses (by the C filter
	# or another mailagent), and also understand that those processes might
	# update the file WITHOUT locking. To guard as much as possible against
	# that, we read the file in and record keys that do not exist in our
	# own %waiting table.

	local($locked) = 0 == &acs_rqst($AGENT_WAIT);
	local(@extra) = ();

	&add_log("WARNING updating $AGENT_WAIT without lock")
		if !$locked && $loglvl > 5;

	open(WAITING, $AGENT_WAIT);
	local($_);
	while (<WAITING>) {
		chop;
		next unless length $_;
		push(@extra, $_) unless exists $waiting{$_};
	}
	close WAITING;

	local($amount) = 0 + @extra;
	local($s) = $amount == 1 ? '' : 's';
	&add_log("NOTICE found $amount unprocessed file$s in $AGENT_WAIT")
		if $amount && $loglvl > 6;

	# Try first to write a new copy of the file, and only rename it once
	# the copy has been written.

	if (open(WAITING, ">$AGENT_WAIT~")) {
		$ok = write_waitkeys(*WAITING, @extra);
		if (!$ok) {
			&add_log("ERROR could not update waiting file") if $loglvl;
			unlink "$AGENT_WAIT~";
		} elsif (rename("$AGENT_WAIT~", $AGENT_WAIT)) {
			&add_log("waiting file has been updated") if $loglvl > 18;
		} else {
			&add_log("ERROR cannot rename waiting file: $!") if $loglvl;
		}
	} else {
		&add_log("WARNING unable to write new waiting file: $!") if $loglvl > 5;
	}

	if ($ok || !-f $AGENT_WAIT) {
		&free_file($AGENT_WAIT) if $locked;
		return;
	}

	# If we could not create a new file, maybe the disk is full, or the write
	# permission bit on the file's directory was removed. Try to override
	# the existing file then.

	&add_log("NOTICE trying to write over existing $AGENT_WAIT") if $loglvl > 6;
	if (open(WAITING, ">$AGENT_WAIT")) {
		$ok = write_waitkeys(*WAITING, @extra);
		&add_log("ERROR mangled file $AGENT_WAIT") if !$ok && $loglvl;
	}

	&free_file($AGENT_WAIT) if $locked;
}

# List the current mails held in the queue, if any at all.
# See also the pqueue subroutine for other comments about the queue.
sub main'load_list_queue {
	package main;
	local(*DIR);
	unless (opendir(DIR, $cf'queue)) {
		&add_log("ERROR unable to open $cf'queue: $!");
		return;
	}
	local(@dir) = readdir DIR;		# Slurp the whole directory
	closedir DIR;
	local(@files) = grep(s!^(q|f|c)m!$cf'queue/${1}m! && !/$lockext$/o, @dir);
	undef @dir;
	if (-f $AGENT_WAIT) {
		if (open(WAITING, $AGENT_WAIT)) {
			while (<WAITING>) {
				chop;
				next unless length $_;	# Empty lines ignored
				push(@files, $_);
			}
			close WAITING;
		} else {
			&add_log("ERROR cannot open $AGENT_WAIT: $!") if $loglvl;
		}
	}
	# The @files array now contains the path name of all the queued mails
	# (at least those known to the mailagent).
	if (@files == 0) {
		print "Mailagent queue is empty.\n";
		return;
	}
	format STDOUT_TOP =
Filename      Size Queue time  Status    Sender / Recipient list
--------- -------- ----------- --------- --------------------------------------
.
	local($file);				# Base name of file (eventually stripped)
	local($directory);			# Directory where queued mail is stored
	local($queued);				# Queuing date
	local($status);				# Status of mail
	local($sender);				# Sender of mail
	local($star);				# The '*' identifies out of queue mails
	local($recipient);			# Recipient of mail
	local($buffer);				# Temporary buffer to build recipient list
	local($address);			# E-mail address candidate for recipient list
	local(%seen);				# Records addresses already seen
	$: = " ,";					# Break recipients on white space or colon
	format STDOUT =
@<<<<<<<<<@>>>>>>>@@<<<<<<<<<< @<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$file,    $size,$star,$queued, $status,  $sender
                                         ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                         $recipient
~                                        ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                         $recipient
~                                        ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                         $recipient
~                                        ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                         $recipient
~                                        ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                                         $recipient
~                                        ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<...
                                         $recipient
.
	local($n) = $#files + 1;
	local($s) = $n > 1 ? 's' : '';
	local($_);
	local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
		$atime,$mtime,$ctime,$blksize,$blocks);
	local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);

	print STDOUT "                   Mailagent Queue ($n request$s)\n";
	foreach (@files) {
		($directory, $file) = m|^(.*)/(.*)|;
		&parse_mail($_, 'head_only');
		next unless defined $Header{'All'};
		# Remove comments from all the addresses. The From field is used to
		# identify the (possibly forged) sender while the To and Cc fields
		# are concatenated to list the recipients;
		$sender = (&parse_address($Header{'From'}))[0];
		$buffer = $Header{'To'};
		$buffer .= ',' . $Header{'Cc'} if $Header{'Cc'};
		$recipient = '';
		undef %seen;
		while ($buffer =~ s/^(.*),(.*)/$1/) {
			$address = (&parse_address($2))[0];
			unless ($seen{$address}++) {
				$recipient .= ', ' if $recipient;
				$recipient .= $address;
			}
		}
		$address = (&parse_address($buffer))[0];
		unless ($seen{$address}++) {
			$recipient .= ', ' if $recipient;
			$recipient .= $address;
		}
		unless (-f $_) {
			&add_log("WARNING unable to stat $_");
			next;
		}
		($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
			$atime,$mtime,$ctime,$blksize,$blocks) = stat(_);
		$status = '';

		# If file has 'mbox.' as part of its name, then it is an emergency
		# saving done by the mailagent. If it starts with 'logname', then it
		# is an emergency saving done by the filter.

		$file =~ s/^mbox\.// && ($status = 'Backup');
		$file =~ s/^$cf'user\.// && ($status = 'Backup');

		# Check for callout queue file. If it is a 'cm' file, or it is not in
		# the queue and is recorded in the callout queue, then it is marked
		# as a callout file and the queue time printed will be the trigger
		# time.

		if (
			$file =~ /^cm/ ||
			($directory ne $cf'queue && &callout'trigger($_))
		) {
			$mtime = &callout'trigger($_);	# May be called twice, that's ok.
			$status = 'Callout';
		} elsif ($file =~ /^qm/ && (time - $mtime) < $cf'queuehold) {
			# Queue mails starting with 'qm' have been queued by the filter
			# program. To avoid race conditions, those mails are skipped for
			# some time (cf to pqueue subroutine).
			$status = 'Skipped' unless $status;		# Filter queued mail
		} else {
			# Processing of mail allowed (mailagent -q would flush it)
			$status = 'Deferred' unless $status;
		}

		# Ensure we always print 'Now' for queue time in TEST mode
		($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
			localtime($mtime);
		$queued = sprintf("%.2d/%.2d-%.2d:%.2d", ++$mon,$mday,$hour,$min);
		$queued = 'Now' if &'abs(time - $mtime) < 60
			|| ($test_mode && $file !~ /^cm/);
		$star = '';
		$star = '*' if $directory ne $cf'queue;	# Spot out-of-queue mails
		if ($status ne 'Callout') {
			if ((time - $mtime) > $cf'queuelost) {	# Also spot old mails
				$star = '#';
				$star = '@' if $directory ne $cf'queue;
			}
		} elsif (time > $mtime) {	# Spot callouts that should have triggered
			$star = '#';
			$star = '@' if $directory ne $cf'queue;
		}

		$status .= '*' if -f ($_ . $lockext);	# Locked file

		write(STDOUT);
	}
}

# Get mail from UNIX mailbox and queue each item
sub main'load_mbox_mail {
	package mbox;
	local($mbox) = @_;			# Where mail is stored
	unless (open(MBOX, "$mbox")) {
		&'add_log("ERROR cannot open $mbox: $!") if $'loglvl > 1;
		return -1;				# Failed
	}
	local(@buffer);				# Buffer used for look-ahead
	local(@blanks);				# Trailing blank lines are ignored
	local(@mail);				# Where mail is stored
	while (<MBOX>) {
		chop;
		if (/^\s*$/ && 0 == @buffer) {
			push(@blanks, $_);
			next;				# Remove empty lines before end of mail
		}
		if (/^From\s/) {
			push(@buffer, $_);
			next;
		}
		if (@buffer > 0) {
			if (/^$/) {
				&flush(1);		# End of header
				push(@mail, $_);
				next;
			}
			if (/^[\w\-]+:/) {
				$last_was_header = 1;
				push(@buffer, $_);
				next;
			}
			if (/^\s/ && $last_was_header) {
				push(@buffer, $_);
				next;
			}
			&flush(0);			# Not a header
			push(@mail, $_);
			next;
		}
		&flush_blanks;
		push(@mail, $_);
	}
	close MBOX;
	&flush(1);			# Flush mail buffer at end of file
	&flush_buffer;		# Maybe header was incomplete?
	&'add_log("WARNING incomplete last mail discarded")
		if $'loglvl > 5 && @mail > 0;
	0;					# Ok (but there might have been some queue problems)
}

# Flush blanks into @mail
sub mbox'load_flush_blanks {
	package mbox;
	return unless @blanks;
	foreach $blank (@blanks) {
		push(@mail, $blank);
	}
	@blanks = ();
}

# Flush look-ahead buffer into @mail
sub mbox'load_flush_buffer {
	package mbox;
	return unless @buffer;
	foreach $buffer (@buffer) {
		push(@mail, $buffer);
	}
	@buffer = ();
}

# Flush mail buffer onto queue
sub mbox'load_flush {
	package mbox;
	local($was_header) = @_;	# Did we reach a new header
	# NB: we don't have to worry if the very first mail does not have a From
	# line, as qmail will add a faked one if necessary.
	if ($was_header && @mail > 0) {
		&main'qmail(*mail);
		@mail = ();				# Reset mail buffer
	}
	&flush_buffer;				# Fill @mail with what we got so far in @buffer
	@blanks = ();				# Discard trailing blanks
}

# Initialize context from context file
sub context'load_init {
	package context;
	&default;						# Load a default context
	&load if -f $cf'context;		# Load context, overwriting default context
	&callout'init;					# Initialize callout queue
	&clean;							# Remove uneeded entries from context
}

# Provide a default context
sub context'load_default {
	package context;
	%Context = (
		'last-clean', '0',			# Last cleaning of hash files
	);
}

# Load the context entries
sub context'load_load {
	package context;
	unless(open(CONTEXT, "$cf'context")) {
		&'add_log("WARNING unable to open context file: $!") if $'loglvl > 5;
		return;
	}
	&'add_log("loading mailagent context") if $'loglvl > 15;
	local($_, $.);
	while (<CONTEXT>) {
		next if /^\s*#/;
		if (/^([\w\-]+)\s*:\s*(\S+)/) {
			$Context{$1} = $2;
			next;
		}
		&'add_log("WARNING context file corrupted, line $.") if $'loglvl > 5;
		last;
	}
	close CONTEXT;
}

# Clean context, removing useless entries
sub context'load_clean {
	package context;
	&delete('last-clean') if $cf'autoclean !~ /^on/i && &get('last-clean');
}

# Save a new context file, if it has changed since we read it.
sub context'load_save {
	package context;
	return unless $context_changed; 		# Do not save if no change
	local($existed) = -f $cf'context;
	&'acs_rqst($cf'context) if $existed;	# Lock existing file
	unless (open(CONTEXT, ">$cf'context")) {
		&'add_log("ERROR cannot overwrite context file: $!") if $'loglvl > 1;
		&'free_file($cf'context) if $existed;
		return;
	}
	&'add_log("saving context file $cf'context") if $'loglvl > 17;
	local($key, $value, $item);
	print CONTEXT "# Mailagent context, last updated " .
		scalar(localtime()) . "\n";
	while (($key, $value) = each %Context) {
		next unless $value;
		$item++;
		print CONTEXT $key, ': ', $value, "\n";
	}
	close CONTEXT;
	unlink "$cf'context" unless $item;		# Do not leave empty context
	&'add_log("deleted empty context") if $'loglvl > 17 && !$item;
	&'free_file($cf'context) if $existed;
}

# Add or set an entry in the context
sub context'load_set {
	package context;
	local($entry, $value) = @_;
	$Context{$entry} = $value;
	$context_changed++;
}

# Get a context entry value
sub context'load_get {
	package context;
	local($entry) = @_;
	defined $Context{$entry} ? $Context{$entry} : undef;
}

# Delete an entry from context
sub context'load_delete {
	package context;
	local($entry) = @_;
	unless (defined $Context{$entry}) {
		&'add_log("WARNING attempting to delete inexistant $entry context")
			if $'loglvl > 5;
		return;
	}
	delete $Context{$entry};
	$context_changed++;
}

# Remove entries in dbr hash files which are old enough. For this operation
# to be performed, the autoclean variable must be set to ON in ~/.mailagent,
# the cleanlaps indicates the period for those automatic cleanings, and agemax
# specifies the maximum allowed time within the database.
sub context'load_autoclean {
	package context;
	return unless $cf'autoclean =~ /^on/i;
	local($period) = &'seconds_in_period($cf'cleanlaps);
	return if (&get('last-clean') + $period) > time;
	# Retry time reached -- start auto cleaning
	&'add_log("autocleaning of dbr files") if $'loglvl > 8;
	$period = &'seconds_in_period($cf'agemax);
	&dbr'clean($period);
	&set('last-clean', time);		# Update last cleaning time
}

# Run all the contextual actions, each action returning if not needed or if
# the retry time was not reached. This routine is the main entry point in
# the package, and is the only one called from the outside world.
sub main'load_contextual_operations {
	package context;
	&autoclean;				# Clean dbr hash files
	&callout'flush;			# Flush the callout queue
	&save;					# Save new context
}

# Fetch value of a persistent variable
sub extern'load_val {
	package extern;
	local($name) = @_;
	local($time, $linenum, @value) = &dbr'info($name, 'VARIABLE');
	join("\t", @value);		# TAB is the record separator in dbr
}

# Update value of a persistent variable
sub extern'load_set {
	package extern;
	local($name, $value) = @_;
	&dbr'update($name, 'VARIABLE', undef, $value);
}

# Fetch age of the variable (elapsed time since last modification)
sub extern'load_age {
	package extern;
	local($name) = @_;
	local($time, $linenum) = &dbr'info($name, 'VARIABLE');
	time - $time;
}

# Parse mail and initialize special variables. The perl script used as hook
# does not have (usually) to do any parsing on the mail. Headers of the mail
# are available via the %header array and some special variables are set as
# conveniences.
sub hook'load_initvar {
	package mailhook;
	local($package) = @_;		# Package into which variables should be set
	local($init) = &'q(<<'EOP');
:	*header = *main'Header;		# User may fetch headers via %header
:	$msgpath = $main'folder_saved;
:	$sender = $header{'Sender'};
:	$subject = $header{'Subject'};
:	$precedence = $header{'Precedence'};
:	$from = $header{'From'};
:	$to = $header{'To'};
:	$cc = $header{'Cc'};
:	$lines = $header{'Lines'};
:	$length = $header{'Length'};
:	$envelope = $header{'Envelope'};
:	($reply_to) = &'parse_address($header{'Reply-To'});
:	($address, $friendly) = &'parse_address($from);
:	$login = &'login_name($address);
:	@to = split(/,/, $to);
:	@cc = split(/,/, $cc);
:	@relayed = split(/,\s*/, $header{'Relayed'});
:	# Leave only the address part in @to and @cc
:	grep(($_ = (&'parse_address($_))[0], 0), @to);
:	grep(($_ = (&'parse_address($_))[0], 0), @cc);
EOP
	eval(<<EOP);				# Initialize variables inside package
	package $package;
	$init
EOP
}

# Load hook script and run it
sub hook'load_run {
	package mailhook;
	local($hook) = @_;
	open(HOOK, $hook) || &'fatal("cannot open $hook: $!");
	local($body) = ' ' x (-s HOOK);
	{
		local($/) = undef;
		$body = <HOOK>;			# Slurp whole file
	}
	close(HOOK);
	unshift(@INC, $'privlib);	# Files first searched for in mailagent's lib
	eval $body;					# Load, compile and execute within mailhook
	if (chop($@)) {
		$@ =~ s/ in file \(eval\)//;
		&'add_log("ERROR $@") if $'loglvl;
		die("$hook aborted");
	}
}

# Record entry in new perl evaluation
sub interface'load_new {
	package interface;
	++$in_perl;					# Add one evalution level
}

# Reset an empty mailhook package by undefining all its symbols.
# (Warning: heavy wizardry used here -- look at perl's manpage for recipe.)
sub interface'load_reset {
	package interface;
	return if --$in_perl > 0;	# Do nothing if pending evals remain
	&'add_log("undefining variables from mailhook") if $'loglvl > 11;
	local($key, $val);			# Key/value from perl's symbol table
	# Loop over perl's symbol table for the mailhook package
	eval "*_mailhook = *::mailhook::" if $] > 5;	# Perl 5 support
	while (($key, $val) = each(%_mailhook)) {
		local(*entry) = $val;	# Get definitions of current slot
		# Temporarily disable those. They are causing problems with perl
		# 4.0 PL36 on some machines when running PERL escapes. Keep only
		# the removal of functions since the re-definition of routines is
		# the most harmful with perl 4.0.
		#undef $entry unless length($key) == 1 && $key !~ /^\w/;
		#undef @entry;
		#undef %entry unless $key =~ /^_/ || $key eq 'header';
		undef &entry if defined &entry && &valid($key);
		$_mailhook{$key} = *entry;	# Commit our changes
	}
}

# Return true if the function may safely be undefined
sub interface'load_valid {
	package interface;
	local($fun) = @_;			# Function name
	return 0 if $fun eq 'exit';	# This function is a convenience
	# We cannot undefine a filter function, which are listed (upper-cased) in
	# the %main'Filter table.
	return 1 unless length($fun) == ($fun =~ tr/a-z/A-Z/);
	return 1 unless $'Filter{$fun};
	0;
}

# Add a new interface function for user-defined commands
sub interface'load_add {
	package interface;
	local($cmd) = @_;			# Command name
	$cmd =~ tr/A-Z/a-z/;		# Cannonicalize to lower case
	eval &'q(<<EOP);			# Compile new mailhook perl interface function
:	sub mailhook'$cmd { &interface'dispatch; }
EOP
	if (chop($@)) {
		&'add_log("ERROR while adding 'sub $cmd': $@") if $'loglvl;
		&'add_log("WARNING cannot use '&$cmd' in perl hooks")
			if $'loglvl > 5;
	}
}

sub getdate'load_yyinit {
	package getdate;
	$daysec = 24 * 60 * 60;

	$AM = 1;
	$PM = 2;
	$DAYLIGHT = 1;
	$STANDARD = 2;
	$MAYBE = 3;

	$ID=257;
	$MONTH=258;
	$DAY=259;
	$MERIDIAN=260;
	$NUMBER=261;
	$UNIT=262;
	$MUNIT=263;
	$SUNIT=264;
	$ZONE=265;
	$DAYZONE=266;
	$AGO=267;
	$YYERRCODE=256;
	@yylhs = (                                               -1,
		0,    0,    1,    1,    1,    1,    1,    1,    7,    2,
		2,    2,    2,    2,    2,    2,    3,    3,    5,    5,
		5,    4,    4,    4,    4,    4,    4,    4,    4,    4,
		6,    6,    6,    6,    6,    6,    6,
	);
	@yylen = (                                                2,
		0,    2,    1,    1,    1,    1,    1,    1,    1,    2,
		3,    4,    4,    5,    6,    6,    1,    1,    1,    2,
		2,    3,    5,    2,    4,    5,    7,    3,    2,    3,
		2,    2,    2,    1,    1,    1,    2,
	);
	@yydefred = (                                             1,
		0,    0,    0,    0,   34,   35,   36,   17,   18,    2,
		3,    4,    5,    6,    0,    8,    0,   20,    0,   21,
	   10,   31,   32,   33,    0,    0,   37,    0,    0,   30,
		0,    0,    0,   25,   12,   13,    0,    0,    0,    0,
	   23,    0,   15,   16,   27,
	);
	@yydgoto = (                                              1,
	   10,   11,   12,   13,   14,   15,   16,
	);
	@yysindex = (                                             0,
	 -241, -255,  -37,  -47,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0, -259,    0,  -42,    0, -252,    0,
		0,    0,    0,    0, -249, -248,    0,  -44, -246,    0,
	  -55,  -31, -235,    0,    0,    0, -234, -232,  -28, -256,
		0, -230,    0,    0,    0,
	);
	@yyrindex = (                                             0,
		0,    0,    1,   79,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,   10,    0,   46,    0,   55,    0,
		0,    0,    0,    0,    0,    0,    0,   19,    0,    0,
	   64,   28,    0,    0,    0,    0,    0,    0,   37,   73,
		0,    0,    0,    0,    0,
	);
	@yygindex = (                                             0,
		0,    0,    0,    0,    0,    0,    0,
	);
	@yytable = (                                             26,
	   19,   29,   37,   43,   44,   17,   18,   27,   30,    7,
	   25,   31,   32,   33,   34,   38,    2,    3,   28,    4,
		5,    6,    7,    8,    9,   39,   40,   22,   41,   42,
	   45,    0,    0,    0,    0,    0,   26,    0,    0,    0,
		0,    0,    0,    0,    0,   24,    0,    0,    0,    0,
		0,    0,    0,    0,   29,    0,    0,    0,    0,    0,
		0,    0,    0,   11,    0,    0,    0,    0,    0,    0,
		0,    0,   14,    0,    0,    0,    0,    0,    9,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,   35,   36,    0,    0,    0,    0,
	   19,   20,   21,    0,   22,   23,   24,    0,   28,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
		0,    0,    0,    0,    0,    0,    0,    0,   19,   19,
		0,   19,   19,   19,   19,   19,   19,    7,    7,    0,
		7,    7,    7,    7,    7,    7,   28,   28,    0,   28,
	   28,   28,   28,   28,   28,   22,   22,    0,   22,   22,
	   22,   22,   22,   22,   26,   26,    0,   26,   26,   26,
	   26,   26,   26,   24,   24,    0,    0,   24,   24,   24,
	   24,   24,   29,   29,    0,    0,   29,   29,   29,   29,
	   29,   11,   11,    0,    0,   11,   11,   11,   11,   11,
	   14,   14,    0,    0,   14,   14,   14,   14,   14,    9,
		0,    0,    0,    9,    9,
	);
	@yycheck = (                                             47,
		0,   44,   58,  260,  261,  261,   44,  267,  261,    0,
	   58,  261,  261,   58,  261,   47,  258,  259,    0,  261,
	  262,  263,  264,  265,  266,  261,  261,    0,  261,   58,
	  261,   -1,   -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,    0,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,  260,  261,   -1,   -1,   -1,   -1,
	  258,  259,  260,   -1,  262,  263,  264,   -1,  261,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
	   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  258,  259,
	   -1,  261,  262,  263,  264,  265,  266,  258,  259,   -1,
	  261,  262,  263,  264,  265,  266,  258,  259,   -1,  261,
	  262,  263,  264,  265,  266,  258,  259,   -1,  261,  262,
	  263,  264,  265,  266,  258,  259,   -1,  261,  262,  263,
	  264,  265,  266,  258,  259,   -1,   -1,  262,  263,  264,
	  265,  266,  258,  259,   -1,   -1,  262,  263,  264,  265,
	  266,  258,  259,   -1,   -1,  262,  263,  264,  265,  266,
	  258,  259,   -1,   -1,  262,  263,  264,  265,  266,  261,
	   -1,   -1,   -1,  265,  266,
	);
	$YYFINAL=1;
	$YYSTACKSIZE = $YYSTACKSIZE || $YYMAXDEPTH || 500;
	$YYMAXDEPTH = $YYMAXDEPTH || $YYSTACKSIZE || 500;
	$yyss[$YYSTACKSIZE] = 0;
	$yyvs[$YYSTACKSIZE] = 0;
}

sub getdate'load_yy_err_recover {
	package getdate;
  if ($yyerrflag < 3)
  {
    $yyerrflag = 3;
    while (1)
    {
      if (($yyn = $yysindex[$yyss[$yyssp]]) && 
          ($yyn += $YYERRCODE) >= 0 && 
          $yycheck[$yyn] == $YYERRCODE)
      {
        $yyss[++$yyssp] = $yystate = $yytable[$yyn];
        $yyvs[++$yyvsp] = $yylval;
        next yyloop;
      }
      else
      {
        return(1) if $yyssp <= 0;
        --$yyssp;
        --$yyvsp;
      }
    }
  }
  else
  {
    return (1) if $yychar == 0;
    $yychar = -1;
    next yyloop;
  }
0;
} # yy_err_recover

sub getdate'load_yyparse {
	package getdate;
  $yynerrs = 0;
  $yyerrflag = 0;
  $yychar = (-1);

  $yyssp = 0;
  $yyvsp = 0;
  $yyss[$yyssp] = $yystate = 0;

yyloop: while(1)
  {
    yyreduce: {
      last yyreduce if ($yyn = $yydefred[$yystate]);
      if ($yychar < 0)
      {
        if (($yychar = &yylex) < 0) { $yychar = 0; }
      }
      if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 &&
              $yycheck[$yyn] == $yychar)
      {
        $yyss[++$yyssp] = $yystate = $yytable[$yyn];
        $yyvs[++$yyvsp] = $yylval;
        $yychar = (-1);
        --$yyerrflag if $yyerrflag > 0;
        next yyloop;
      }
      if (($yyn = $yyrindex[$yystate]) && ($yyn += $yychar) >= 0 &&
            $yycheck[$yyn] == $yychar)
      {
        $yyn = $yytable[$yyn];
        last yyreduce;
      }
      if (! $yyerrflag) {
        &yyerror('syntax error');
        ++$yynerrs;
      }
      return(1) if &yy_err_recover;
    } # yyreduce
    $yym = $yylen[$yyn];
    $yyval = $yyvs[$yyvsp+1-$yym];
    switch:
    {
		if ($yyn == 3) {
			$timeflag++;
			last switch;
		}
		if ($yyn == 4) {
			$zoneflag++;
			last switch;
		}
		if ($yyn == 5) {
			$dateflag++;
			last switch;
		}
		if ($yyn == 6) {
			$dayflag++;
			last switch;
		}
		if ($yyn == 7) {
			$relflag++;
			last switch;
		}
		if ($yyn == 9) {
			if ($timeflag && $dateflag && !$relflag) {
				$year = $yyvs[$yyvsp-0];
			}
			else {
				$timeflag++;
				$hh = int($yyvs[$yyvsp-0] / 100);
				$mm = $yyvs[$yyvsp-0] % 100;
				$ss = 0;
				$merid = 24;
			}
			last switch;
		}
		if ($yyn == 10) {
			$hh = $yyvs[$yyvsp-1];
			$mm = 0;
			$ss = 0;
			$merid = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 11) {
			$hh = $yyvs[$yyvsp-2];
			$mm = $yyvs[$yyvsp-0];
			$merid = 24;
			last switch;
		}
		if ($yyn == 12) {
			$hh = $yyvs[$yyvsp-3];
			$mm = $yyvs[$yyvsp-1];
			$merid = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 13) {
			$hh = $yyvs[$yyvsp-3];
			$mm = $yyvs[$yyvsp-1];
			$merid = 24;
			$daylight = $STANDARD;
			$ourzone = $yyvs[$yyvsp-0] % 100 + 60 * int($yyvs[$yyvsp-0] / 100);
			last switch;
		}
		if ($yyn == 14) {
			$hh = $yyvs[$yyvsp-4];
			$mm = $yyvs[$yyvsp-2];
			$ss = $yyvs[$yyvsp-0];
			$merid = 24;
			last switch;
		}
		if ($yyn == 15) {
			$hh = $yyvs[$yyvsp-5];
			$mm = $yyvs[$yyvsp-3];
			$ss = $yyvs[$yyvsp-1];
			$merid = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 16) {
			$hh = $yyvs[$yyvsp-5];
			$mm = $yyvs[$yyvsp-3];
			$ss = $yyvs[$yyvsp-1];
			$merid = 24;
			$daylight = $STANDARD;
			$ourzone = $yyvs[$yyvsp-0] % 100 + 60 * int($yyvs[$yyvsp-0] / 100);
			last switch;
		}
		if ($yyn == 17) {
			$ourzone = $yyvs[$yyvsp-0];
			$daylight = $STANDARD;
			last switch;
		}
		if ($yyn == 18) {
			$ourzone = $yyvs[$yyvsp-0];
			$daylight = $DAYLIGHT;
			last switch;
		}
		if ($yyn == 19) {
			$dayord = 1;
			$dayreq = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 20) {
			$dayord = 1;
			$dayreq = $yyvs[$yyvsp-1];
			last switch;
		}
		if ($yyn == 21) {
			$dayord = $yyvs[$yyvsp-1];
			$dayreq = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 22) {
			$month = $yyvs[$yyvsp-2];
			$day = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 23) {
			#
			# HACK ALERT!!!!
			# The 1000 is a magic number to attempt to force
			# use of 4 digit years if year/month/day can be
			# parsed. This was only done for backwards
			# compatibility in rh.
			#
			if ($yyvs[$yyvsp-4] > 1000) {
				$year = $yyvs[$yyvsp-4];
				$month = $yyvs[$yyvsp-2];
				$day = $yyvs[$yyvsp-0];
			}
			else {
				$month = $yyvs[$yyvsp-4];
				$day = $yyvs[$yyvsp-2];
				$year = $yyvs[$yyvsp-0];
			}
			last switch;
		}
		if ($yyn == 24) {
			$month = $yyvs[$yyvsp-1];
			$day = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 25) {
			$month = $yyvs[$yyvsp-3];
			$day = $yyvs[$yyvsp-2];
			$year = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 26) {
			$month = $yyvs[$yyvsp-4];
			$day = $yyvs[$yyvsp-3];
			$hh = $yyvs[$yyvsp-2];
			$mm = $yyvs[$yyvsp-0];
			$merid = 24;
			$timeflag++;
			last switch;
		}
		if ($yyn == 27) {
			$month = $yyvs[$yyvsp-6];
			$day = $yyvs[$yyvsp-5];
			$hh = $yyvs[$yyvsp-4];
			$mm = $yyvs[$yyvsp-2];
			$ss = $yyvs[$yyvsp-0];
			$merid = 24;
			$timeflag++;
			last switch;
		}
		if ($yyn == 28) {
			$month = $yyvs[$yyvsp-2];
			$day = $yyvs[$yyvsp-1];
			$year = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 29) {
			$month = $yyvs[$yyvsp-0];
			$day = $yyvs[$yyvsp-1];
			last switch;
		}
		if ($yyn == 30) {
			$month = $yyvs[$yyvsp-1];
			$day = $yyvs[$yyvsp-2];
			$year = $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 31) {
			$relsec +=  60 * $yyvs[$yyvsp-1] * $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 32) {
			$relmonth += $yyvs[$yyvsp-1] * $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 33) {
			$relsec += $yyvs[$yyvsp-1];
			last switch;
		}
		if ($yyn == 34) {
			$relsec +=  60 * $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 35) {
			$relmonth += $yyvs[$yyvsp-0];
			last switch;
		}
		if ($yyn == 36) {
			$relsec++;
			last switch;
		}
		if ($yyn == 37) {
			$relsec = -$relsec;
			$relmonth = -$relmonth;
			last switch;
		}
    } # switch
    $yyssp -= $yym;
    $yystate = $yyss[$yyssp];
    $yyvsp -= $yym;
    $yym = $yylhs[$yyn];
    if ($yystate == 0 && $yym == 0) {
      $yystate = $YYFINAL;
      $yyss[++$yyssp] = $YYFINAL;
      $yyvs[++$yyvsp] = $yyval;
      if ($yychar < 0) {
        if (($yychar = &yylex) < 0) { $yychar = 0; }
      }
      return(0) if $yychar == 0;
      next yyloop;
    }
    if (($yyn = $yygindex[$yym]) && ($yyn += $yystate) >= 0 &&
        $yyn <= $#yycheck && $yycheck[$yyn] == $yystate)
    {
        $yystate = $yytable[$yyn];
    } else {
        $yystate = $yydgoto[$yym];
    }
    $yyss[++$yyssp] = $yystate;
    $yyvs[++$yyvsp] = $yyval;
  } # yyloop
} # yyparse

sub getdate'load_dateconv {
	package getdate;
	local($mm, $dd, $yy, $h, $m, $s, $mer, $zone, $dayflag) = @_;
	local($time_of_day, $jdate);
	local($i);

	if ($yy < 0) {
		$yy = -$yy;
	}
	if ($yy < 138) {
		$yy += 1900;
	}
	$mdays[1] =
		28 + (($yy % 4) == 0 && (($yy % 100) != 0 || ($yy % 400) == 0));
	if ($yy < $epoch || $yy > 2037 || $mm < 1 || $mm > 12
		|| $dd < 1 || $dd > $mdays[--$mm]) {
		return -1;
	}
	$jdate = $dd - 1;
	for ($i = 0; $i < $mm; $i++) {
		$jdate += $mdays[$i];
	}
	for ($i = $epoch; $i < $yy; $i++) {
		$jdate += 365 + (($i % 4) == 0);
	}
	$jdate *= $daysec;
	$jdate += $zone * 60;
	if (($time_of_day = &timeconv($h, $m, $s, $mer)) < 0) {
		return -1;
	}
	$jdate += $time_of_day;
	if ($dayflag == $DAYLIGHT
		|| ($dayflag == $MAYBE && (localtime($jdate))[8])) {
		$jdate -= 60 * 60;
	}
	return $jdate;
}

sub getdate'load_dayconv {
	package getdate;
	local($ordday, $day, $now) = @_;
	local(@loctime);
	local($time_of_day);

	$time_of_day = $now;
	@loctime = localtime($time_of_day);
	$time_of_day += $daysec * (($day - $loctime[6] + 7) % 7);
	$time_of_day += 7 * $daysec * ($ordday <= 0 ? $ordday : $ordday - 1);
	return &daylcorr($time_of_day, $now);
}

sub getdate'load_timeconv {
	package getdate;
	local($hh, $mm, $ss, $mer) = @_;

	return -1 if ($mm < 0 || $mm > 59 || $ss < 0 || $ss > 59);

	if ($mer == $AM) {
		return -1 if ($hh < 1 || $hh > 12);
		return 60 * (($hh % 12) * 60 + $mm) + $ss;
	}
	if ($mer == $PM) {
		return -1 if ($hh < 1 || $hh > 12);
		return 60 * (($hh % 12 + 12) * 60 + $mm) + $ss;
	}
	if ($mer == 24) {
		return -1 if ($hh < 0 || $hh > 23);
		return 60 * ($hh * 60 + $mm) + $ss;
	}
	return -1;
}

sub getdate'load_monthadd {
	package getdate;
	local($sdate, $relmonth) = @_;
	local(@ltime);
	local($mm, $yy);

	return 0 if ($relmonth == 0);

	@ltime = localtime($sdate);
	$mm = 12 * $ltime[5] + $ltime[4] + $relmonth;
	$yy = int($mm / 12);
	$mm = $mm % 12 + 1;
	return &daylcorr(&dateconv($mm, $ltime[3], $yy, $ltime[2],
							   $ltime[1], $ltime[0], 24, $ourzone, $MAYBE),
					 $sdate);
}

sub getdate'load_daylcorr {
	package getdate;
	local($future, $now) = @_;
	local($fdayl, $nowdayl);

	$nowdayl = ((localtime($now))[2] + 1) % 24;
	$fdayl = ((localtime($future))[2] + 1) % 24;
	return ($future - $now) + 60 * 60 * ($nowdayl - $fdayl);
}

sub getdate'load_yylex {
	package getdate;
	local($pcnt, $sign);

	while (1) {
		$dtstr =~ s/^\s*//;

		if ($dtstr =~ /^([-+])/) {
			$sign = ($1 eq '-') ? -1 : 1;
			$dtstr =~ s/^.\s*//;
			if ($dtstr =~ /^(\d+)/) {
				# Fixed buggy and needless eval "" in case $1 is 09
				# (would fail complaining about bad octal) -- RAM, 10/01/2001
				$yylval = $1 * $sign;
				$dtstr =~ s/^\d+//;
				return $NUMBER;
			}
			else {
				return &yylex;
			}
		}
		elsif ($dtstr =~ /^(\d+)/) {
			# Fixed buggy and needless eval "" in case $1 is 09
			# (would fail complaining about bad octal) -- RAM, 10/01/2001
			$yylval = $1 + 0;
			$dtstr =~ s/^\d+//;
			return $NUMBER;
		}
		elsif ($dtstr =~ /^([a-zA-z][a-zA-Z.]*)/) {
			# Perl 5.0 bug: $1 may be reset to null if &lookup is dataloaded
			$sign = $1;		# Save it for perl 5.0 PL0
			$dtstr = substr($dtstr, length($sign));
			return &lookup($sign);
		}
		elsif ($dtstr =~ /^\(/) {
			$pcnt = 0;
			do {
				$dtstr = s/^(.)//;
				return 0 if !defined($1);
				$pcnt++ if ($1 eq '(');
				$pcnt-- if ($1 eq ')');
			} while ($pcnt > 0);
		}
		else {
			$yylval = ord(substr($dtstr, 0, 1));
			$dtstr =~ s/^.//;
			return $yylval;
		}
	}
}

sub getdate'load_lookup_init {
	package getdate;
	%mdtab = (
		"January",		"$MONTH,1",
		"February",		"$MONTH,2",
		"March",		"$MONTH,3",
		"April",		"$MONTH,4",
		"May",			"$MONTH,5",
		"June",			"$MONTH,6",
		"July",			"$MONTH,7",
		"August",		"$MONTH,8",
		"September",	"$MONTH,9",
		"Sept",			"$MONTH,9",
		"October",		"$MONTH,10",
		"November",		"$MONTH,11",
		"December",		"$MONTH,12",

		"Sunday",		"$DAY,0",
		"Monday",		"$DAY,1",
		"Tuesday",		"$DAY,2",
		"Tues",			"$DAY,2",
		"Wednesday",	"$DAY,3",
		"Wednes",		"$DAY,3",
		"Thursday",		"$DAY,4",
		"Thur",			"$DAY,4",
		"Thurs",		"$DAY,4",
		"Friday",		"$DAY,5",
		"Saturday",		"$DAY,6"
	);

	$HRS='*60';
	$HALFHR='30';

	%mztab = (
		"a.m.",		"$MERIDIAN,$AM",
		"am",		"$MERIDIAN,$AM",
		"p.m.",		"$MERIDIAN,$PM",
		"pm",		"$MERIDIAN,$PM",
		"nst",		"$ZONE,3 $HRS + $HALFHR",		# Newfoundland
		"n.s.t.",	"$ZONE,3 $HRS + $HALFHR",
		"ast",		"$ZONE,4 $HRS",			# Atlantic
		"a.s.t.",	"$ZONE,4 $HRS",
		"adt",		"$DAYZONE,4 $HRS",
		"a.d.t.",	"$DAYZONE,4 $HRS",
		"est",		"$ZONE,5 $HRS",			# Eastern
		"e.s.t.",	"$ZONE,5 $HRS",
		"edt",		"$DAYZONE,5 $HRS",
		"e.d.t.",	"$DAYZONE,5 $HRS",
		"cst",		"$ZONE,6 $HRS",			# Central
		"c.s.t.",	"$ZONE,6 $HRS",
		"cdt",		"$DAYZONE,6 $HRS",
		"c.d.t.",	"$DAYZONE,6 $HRS",
		"mst",		"$ZONE,7 $HRS",			# Mountain
		"m.s.t.",	"$ZONE,7 $HRS",
		"mdt",		"$DAYZONE,7 $HRS",
		"m.d.t.",	"$DAYZONE,7 $HRS",
		"pst",		"$ZONE,8 $HRS",			# Pacific
		"p.s.t.",	"$ZONE,8 $HRS",
		"pdt",		"$DAYZONE,8 $HRS",
		"p.d.t.",	"$DAYZONE,8 $HRS",
		"yst",		"$ZONE,9 $HRS",			# Yukon
		"y.s.t.",	"$ZONE,9 $HRS",
		"ydt",		"$DAYZONE,9 $HRS",
		"y.d.t.",	"$DAYZONE,9 $HRS",
		"hst",		"$ZONE,10 $HRS",		# Hawaii
		"h.s.t.",	"$ZONE,10 $HRS",
		"hdt",		"$DAYZONE,10 $HRS",
		"h.d.t.",	"$DAYZONE,10 $HRS",

		"gmt",		"$ZONE,0 $HRS",
		"g.m.t.",	"$ZONE,0 $HRS",
		"bst",		"$DAYZONE,0 $HRS",		# British Summer Time
		"b.s.t.",	"$DAYZONE,0 $HRS",
		"eet",		"$ZONE,-2 $HRS",		# European Eastern Time
		"e.e.t.",	"$ZONE,-2 $HRS",
		"eest",		"$DAYZONE,-2 $HRS",		# European Eastern Summer Time
		"e.e.s.t.",	"$DAYZONE,-2 $HRS",
		"met",		"$ZONE,-1 $HRS",		# Middle European Time
		"m.e.t.",	"$ZONE,-1 $HRS",
		"mest",		"$DAYZONE,-1 $HRS",		# Middle European Summer Time
		"m.e.s.t.",	"$DAYZONE,-1 $HRS",
		"wet",		"$ZONE,0 $HRS ",		# Western European Time
		"w.e.t.",	"$ZONE,0 $HRS ",
		"west",		"$DAYZONE,0 $HRS",		# Western European Summer Time
		"w.e.s.t.",	"$DAYZONE,0 $HRS",

		"jst",		"$ZONE,-9 $HRS",		# Japan Standard Time
		"j.s.t.",	"$ZONE,-9 $HRS",		# Japan Standard Time

		"aest",		"$ZONE,-10 $HRS",		# Australian Eastern Time
		"a.e.s.t.",	"$ZONE,-10 $HRS",
		"aesst",	"$DAYZONE,-10 $HRS",	# Australian Eastern Summer Time
		"a.e.s.s.t.",	"$DAYZONE,-10 $HRS",
		"acst",			"$ZONE,-(9 $HRS + $HALFHR)",	# Austr. Central Time
		"a.c.s.t.",		"$ZONE,-(9 $HRS + $HALFHR)",
		"acsst",		"$DAYZONE,-(9 $HRS + $HALFHR)",	# Austr. Central Summer
		"a.c.s.s.t.",	"$DAYZONE,-(9 $HRS + $HALFHR)",
		"awst",			"$ZONE,-8 $HRS",	# Australian Western Time
		"a.w.s.t.",		"$ZONE,-8 $HRS"		# (no daylight time there)
	);

	%unittab = (
		"year",		"$MUNIT,12",
		"month",	"$MUNIT,1",
		"fortnight","$UNIT,14*24*60",
		"week",		"$UNIT,7*24*60",
		"day",		"$UNIT,1*24*60",
		"hour",		"$UNIT,60",
		"minute",	"$UNIT,1",
		"min",		"$UNIT,1",
		"second",	"$SUNIT,1",
		"sec",		"$SUNIT,1"
	);

	%othertab = (
		"tomorrow",	"$UNIT,1*24*60",
		"yesterday","$UNIT,-1*24*60",
		"today",	"$UNIT,0",
		"now",		"$UNIT,0",
		"last",		"$NUMBER,-1",
		"this",		"$UNIT,0",
		"next",		"$NUMBER,2",
		"first",	"$NUMBER,1",
		# "second",	"$NUMBER,2",
		"third",	"$NUMBER,3",
		"fourth",	"$NUMBER,4",
		"fifth",	"$NUMBER,5",
		"sixth",	"$NUMBER,6",
		"seventh",	"$NUMBER,7",
		"eigth",	"$NUMBER,8",
		"ninth",	"$NUMBER,9",
		"tenth",	"$NUMBER,10",
		"eleventh",	"$NUMBER,11",
		"twelfth",	"$NUMBER,12",
		"ago",		"$AGO,1"
	);

	%milzone = (
		"a",		"$ZONE,1 $HRS",
		"b",		"$ZONE,2 $HRS",
		"c",		"$ZONE,3 $HRS",
		"d",		"$ZONE,4 $HRS",
		"e",		"$ZONE,5 $HRS",
		"f",		"$ZONE,6 $HRS",
		"g",		"$ZONE,7 $HRS",
		"h",		"$ZONE,8 $HRS",
		"i",		"$ZONE,9 $HRS",
		"k",		"$ZONE,10 $HRS",
		"l",		"$ZONE,11 $HRS",
		"m",		"$ZONE,12 $HRS",
		"n",		"$ZONE,-1 $HRS",
		"o",		"$ZONE,-2 $HRS",
		"p",		"$ZONE,-3 $HRS",
		"q",		"$ZONE,-4 $HRS",
		"r",		"$ZONE,-5 $HRS",
		"s",		"$ZONE,-6 $HRS",
		"t",		"$ZONE,-7 $HRS",
		"u",		"$ZONE,-8 $HRS",
		"v",		"$ZONE,-9 $HRS",
		"w",		"$ZONE,-10 $HRS",
		"x",		"$ZONE,-11 $HRS",
		"y",		"$ZONE,-12 $HRS",
		"z",		"$ZONE,0 $HRS"
	);

	@mdays = (31, 0, 31,  30, 31, 30,  31, 31, 30,  31, 30, 31);
	$epoch = 1970;
}

sub getdate'load_lookup {
	package getdate;
	local($id) = @_;
	local($abbrev, $idvar, $key, $token);

	$idvar = $id;
	if (length($idvar) == 3) {
		$abbrev = 1;
	}
	elsif (length($idvar) == 4 && substr($idvar, 3, 1) eq '.') {
		$abbrev = 1;
		$idvar = substr($idvar, 0, 3);
	}
	else {
		$abbrev = 0;
	}

	substr($idvar, 0, 1) =~ tr/a-z/A-Z/;
	if (defined($mdtab{$idvar})) {
		($token, $yylval) = split(/,/,$mdtab{$idvar});
		$yylval = eval "$yylval";
		return $token;
	}
	foreach $key (keys %mdtab) {
		if ($idvar eq substr($key, 0, 3)) {
			($token, $yylval) = split(/,/,$mdtab{$key});
			$yylval = eval "$yylval";
			return $token;
		}
	}

	$idvar = $id;
	if (defined($mztab{$idvar})) {
		($token, $yylval) = split(/,/,$mztab{$idvar});
		$yylval = eval "$yylval";
		return $token;
	}

	$idvar =~ tr/A-Z/a-z/;
	if (defined($mztab{$idvar})) {
		($token, $yylval) = split(/,/,$mztab{$idvar});
		$yylval = eval "$yylval";
		return $token;
	}

	$idvar = $id;
	if (defined($unittab{$idvar})) {
		($token, $yylval) = split(/,/,$unittab{$idvar});
		$yylval = eval "$yylval";
		return $token;
	}

	if ($idvar =~ /s$/) {
		$idvar =~ s/s$//;
	}
	if (defined($unittab{$idvar})) {
		($token, $yylval) = split(/,/,$unittab{$idvar});
		$yylval = eval "$yylval";
		return $token;
	}

	$idvar = $id;
	if (defined($othertab{$idvar})) {
		($token, $yylval) = split(/,/,$othertab{$idvar});
		$yylval = eval "$yylval";
		return $token;
	}

	if (length($idvar) == 1 && $idvar =~ /[a-zA-Z]/) {
		$idvar =~ tr/A-Z/a-z/;
		if (defined($milzone{$idvar})) {
			($token, $yylval) = split(/,/,$milzone{$idvar});
			$yylval = eval "$yylval";
			return $token;
		}
	}

	return $ID;
}

sub main'load_getdate {
	package getdate;
	local($dtstr, $now, $timezone) = @_;
	local(@lt);
	local($sdate);
	local($TZ);

	$odtstr = $dtstr;		# Save it for error report--RAM
	&yyinit;
	&lookup_init unless $lookup_init++;

	if (!$now) {
		$now = time;
	}

	if (!$timezone) {
		$TZ = defined($ENV{'TZ'}) ? ($ENV{'TZ'} ? $ENV{'TZ'} : '') : '';
		if( $TZ =~
		   /^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/) {
			$timezone = $2 * 60;
		}
		else {
			$timezone = 0;
		}
	}

	@lt = localtime($now);
	$year = 0;
	$month = $lt[4] + 1;
	$day = $lt[3];
	$relsec = $relmonth = 0;
	$timeflag = $zoneflag = $dateflag = $dayflag = $relflag = 0;
	$daylight = $MAYBE;
	$hh = $mm = $ss = 0;
	$merid = 24;

	$dtstr =~ tr/A-Z/a-z/;
	return -1 if &yyparse;
	return -1 if $timeflag > 1 || $zoneflag > 1 || $dateflag > 1 || $dayflag > 1;

	if (!$year) {
		$year = ($month > ($lt[4] + 1)) ? ($lt[5] - 1) : $lt[5];
	}

	if ($dateflag || $timeflag || $dayflag) {
		$sdate = &dateconv($month, $day, $year, $hh, $mm, $ss,
						   $merid, $timezone, $daylight);
		if ($sdate < 0) {
			return -1;
		}
	}
	else {
		$sdate = $now;
		if ($relflag == 0) {
			$sdate -= ($lt[0] + $lt[1] * 60 + $lt[2] * (60 * 60));
		}
	}

	$sdate += $relsec + &monthadd($sdate, $relmonth);
	$sdate += &dayconv($dayord, $dayreq, $sdate) if ($dayflag && !$dateflag);

	return $sdate;
}

# Mark error within date string with a '^' cursor--RAM
sub getdate'load_yyerror {
	package getdate;
	local($parsed) = length($odtstr) - length($dtstr);
	substr($odtstr, $parsed) = '^' .  substr($odtstr, $parsed + 1);
	&'add_log("syntax error in date: $odtstr") if $'loglvl > 5;
}

# Process "include-file" requests. The file is allowed to have shell comments
# and leading spaces are trimmed. The function returns an array, each item
# being one of the non-comment and non-empty lines found in the file.
sub main'load_include_file {
	package main;
	local($inc) = shift(@_);	# Include request "file-name"
	local($what) = shift(@_);	# What we are looking for (singular)
	local(*INCLUDE);			# Local file handle
	local($filename) = $inc =~ /^"(.*)"$/;
	local(@result);
	local($_);
	# Find file using mailfilter, maildir variables if not specified with an
	# absolute pathname (starting with a '/').
	$filename = &locate_file($filename);
	&add_log("loading ".&plural($what)." from $filename") if $loglvl > 18;
	if ($filename ne '' && open(INCLUDE, "$filename")) {
		while (<INCLUDE>) {
			next if /^\s*#/;	# Skip shell comments
			next if /^\s*$/;	# Skip blank lines
			chop;
			s/^\s+//;			# Remove leading spaces
			push(@result, $_);
			&add_log("loaded $what '$_'") if $loglvl > 19;
		}
		close INCLUDE;
	} elsif ($filename ne '') {		# Could not open file
		&add_log("WARNING couldn't open $filename for ".&plural($what).": $!")
			if $loglvl > 4;
	} else {
		&add_log("WARNING incorrect file inclusion request: $inc")
			if $loglvl > 4;
	}
	@result;		# List of non-comment lines held in file
}

# Pluralize names -- Adapted from a routine posted by Tom Christiansen in
# comp.lang.perl on June 20th, 1992.
sub main'load_plural {
	package main;
	local($_, $n) = @_;		# Word and amount (plural if not specified)
	$n = 2 if $n eq '';		# Pluralize word by default
	if ($n != 1) {			# 0 something is plural
		if ($_ eq 'was') {
			$_ = 'were';
		} else {
			s/y$/ies/   || s/s$/ses/  || s/([cs]h)$/$1es/ ||
			s/sis$/ses/ || s/ium$/ia/ || s/$/s/;
		}
	}
	"$_";			# How to write $n times the original $_
}

# Return only the hostname portion of the host name (no domain name)
sub main'load_myhostname {
	package main;
	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 main'load_hostname {
	package main;
	unless ($cache'hostname) {
		chop($cache'hostname = `$phostname`);
		$cache'hostname =~ tr/A-Z/a-z/;			# Cannonicalize to lower case
	}
	$cache'hostname;
}

# Attempt to save in a possible MMDF mailbox. The routine opens the mailbox
# and tries to determine what kind of mailbox it is, then selects the
# appropriate saving routine.
sub mmdf'load_save {
	package mmdf;
	local(*FD, $mailbox) = @_;	# File descriptor and mailbox name
	if (&is_mmdf($mailbox)) {	# Folder looks like an MMDF mailbox
		&save_mmdf(*FD, 'MDF');	# Use MMDF format then
	} else {
		&save_unix(*FD);		# Be conservative and use standard format
	}
}

# Save to a MMDF-style mailbox and return failure status with message length
# Can also be used to save MH messages if parameter $mmdf set to 'MH' (in which
# case the two ^A delimiter lines are ommitted).
sub mmdf'load_save_mmdf {
	package mmdf;
	local(*FD, $mmdf) = @_;		# File descriptor, MH/MDF format
	local($amount) = 0;			# Amount of bytes saved
	local($failed);
	local($from);
	local(@head) = split(/\n/, $'Header{'Head'});
	$from = shift(@head);		# The first From_ line has to be skipped
	unless ($from =~ /^From\s/) {
		&'add_log("WARNING leading From line absent") if $'loglvl > 5;
		unshift(@head, $from);	# Put it back if not a From_ line
	}
	unless ($mmdf eq 'MH') {
		(print FD "\01\01\01\01\n") || ($failed = 1);
		$amount += 5;
	}
	foreach $line (@head) {
		(print FD $line, "\n") || ($failed = 1);
		$amount += length($line) + 1;
	}
	(print FD $'FILTER, "\n\n") || ($failed = 1);
	(print FD $'Header{'Body'}) || ($failed = 1);
	&force_flushing(*FD);
	unless ($mmdf eq 'MH') {
		(print FD "\01\01\01\01\n") || ($failed = 1);
		$amount += 5;
	}
	$amount +=
		length($'Header{'Body'}) +	# Message body
		length($'FILTER) + 2;		# X-Filter line plus two newlines
	($failed, $amount);
}

# Save to a Unix-style mailbox and return failure status with message length
sub mmdf'load_save_unix {
	package mmdf;
	local(*FD) = @_;			# File descriptor
	local($amount) = 0;			# Amount of bytes saved
	local($failed);
	# First print the Header, then add the X-Filter: line, followed by body.
	(print FD $'Header{'Head'}) || ($failed = 1);
	(print FD $'FILTER, "\n\n") || ($failed = 1);
	(print FD $'Header{'Body'}) || ($failed = 1);
	&force_flushing(*FD);
	(print FD "\n") || ($failed = 1);		# Allow parsing by other tools
	$amount +=
		length($'Header{'Head'}) +	# Message header
		length($'Header{'Body'}) +	# Message body
		length($'FILTER) + 2 +		# X-Filter line plus two newlines
		1;							# Trailing new-line
	($failed, $amount);
}

# Force flushing on file descriptor, so that after next print, we may rest
# assured everything as been written on disk. That way, we may stat the file
# without closing it (since that would release any flock-style lock).
sub mmdf'load_force_flushing {
	package mmdf;
	local(*FD) = @_;			# File descriptor we want to flush
	select((select(FD), $| = 1)[0]);
}

# Guess whether the folder we are writing to is MMDF-style or not.
sub mmdf'load_is_mmdf {
	package mmdf;
	local($folder) = @_;		# The folder to be scanned
	open(FOLDER, "$folder") || return 0;	# Can't open -> not MMDF, say.
	local($_);					# First line from folder
	$_ = <FOLDER>;				# Can be empty
	close FOLDER;
	return 0 if /^From\s/;			# Looks like an Unix-style mailbox
	return 1 if /^\01\01\01\01\n/;	# This must be an MMDF-style mailbox
	# If we can't decide (most probably because $_ is empty), then choose
	# according to the 'mmdfbox' parameter.
	&'add_log("WARNING folder $folder may be corrupted")
		if $_ ne '' && $'loglvl > 5;
	$cf'mmdfbox =~ /on/i ? 1 : 0;	# Force MMDF if mmdfbox is ON
}

# Set permission on newly created folder message
sub mmdf'load_chmod {
	package mmdf;
	local($mode, $file) = @_;
	local($cnt) = chmod($mode, $file);
	local($omode) = sprintf("0%o", $mode);
	$file = &'tilda($file);
	if ($cnt) {
		&'add_log("file mode on $file set to $omode") if $'loglvl > 6;
	} else {
		&'add_log("ERROR unable to set mode $omode on $file: $!") if $'loglvl;
	}
	$cnt;	# Return 1 on success, for them to further check
}

# Read in the compression file into the @compress array. As usual, shell
# comments are ignored.
sub compress'load_init {
	package compress;
	unless (open(COMPRESS, "$cf'compress")) {
		&'add_log("WARNING cannot open compress file $cf'compress: $!")
			if $'loglvl > 5;
		return;
	}
	local($_);
	while (<COMPRESS>) {
		chop;
		next if /^\s*#/;			# Skip comments
		next if /^\s*$/;			# And blank lines
		$_ = &'perl_pattern($_);	# Shell pattern to perl one
		s/^~/$cf'home/;				# ~ substitution
		# Focus on basename unless absolute path
		$_ = '(?>.*/)'.$_ unless m|^/|;
		push(@compress, $_);		# Record pattern
	}
	close COMPRESS;

	unless (open(COMPSPEC, "$cf'compspec")) {
		# Configure a set of defaults if the user hasn't specified them manually
		# Fields are: tag extension compression_prog uncompress_prog cat_prog
		# The following legacy line removed as modern systems lack compress:
		# compress	.Z	compress	uncompress	zcat
		&add_compressor(<<'EOT');
gzip		.gz		gzip		gunzip		gunzip -c
bzip2		.bz2	bzip2		bunzip2		bzcat
EOT
		local($err) = "$!";
		&'add_log("WARNING cannot open compspec file $cf'compspec: $err")
			if $'loglvl > 5 && -f $cf'compspec;
		&'add_log("NOTICE using hardwired compressor defaults")
			if $'loglvl > 6;
	} else {
		while (<COMPSPEC>) {
			chop;
			next if /^\s*#/;			# Skip comments
			next if /^\s*$/;			# And blank lines
			s/^\s+//;
			s/\s+$//;
			&add_compressor($_);
		}
		close COMPSPEC;
	}

	unless (defined($Ext{$cf'comptag})) {
		&'add_log("ERROR invalid comptag: $cf'comptag") if $'loglvl;
		return;
	}
}

# Uncompress a folder, and record it in the %compress array for further
# recompression at the end of the mailagent processing. Return 1 for success.
# If the $retry parameter is set, other folders will be recompressed should
# this particular uncompression fail.
sub compress'load_uncompress {
	package compress;
	local($folder, $retry) = @_;	# Folder to be decompressed
	local($tag);
	&'add_log("entering uncompress") if $'loglvl > 15;
	return if defined $compress{$folder};	# We already dealt with that folder
	# Lock folder, in case someone is trying to deliver to the uncompressed
	# folder while we're decompressing it...
	if (0 != &'acs_rqst($folder)) {
		&'add_log("WARNING unable to lock compressed folder $folder")
			if $'loglvl > 5;
		return 0;				# Failure, don't uncompress, sorry
	}
	# Make sure there is a compressed file, and that the corresponding folder
	# is not already present. If there is no compressed file but the folder
	# already exists, mark it uncompressed.
	if ($tag = &is_compressed($folder)) {		# A compressed form exists
		local($ext) = $Ext{$tag};
		if (-f $folder) {				# As well as an uncompressed form
			&'add_log("WARNING both folders $folder and $folder$ext exist")
				if $'loglvl > 5;
			&'add_log("NOTICE ignoring compressed file") if $'loglvl > 6;
			$compress{$folder} = 0;		# Do not recompress, yet mark as dealt
			&'free_file($folder);		# Unlock folder
			return 1;
		}
		# Normal case: there is a compressed file and no uncompressed version
		local($uncompress) = $Uncompressor{$tag};
		local($status) = system("$uncompress $folder$ext");
		&'add_log("$uncompress returned $status") if $'loglvl > 15;
		if ($status) {			# Uncompression failed
			local($retrying);
			$retrying = " (retrying)" if $retry;
			&'add_log("ERROR can't uncompress $folder via $uncompress$retrying")
				if $'loglvl;
			# Maybe there is not enough disk space, and maybe we can get some
			# by recompressing the folders we have decompressed so far.
			if ($retry) {				# Attempt is to be retried
				&recompress;			# Recompress other folders, if any
				&'free_file($folder);	# Unlock folder
				&'add_log("leaving uncompress after retry") if $'loglvl > 15;
				return 0;				# And report failure
			}
			&'add_log("WARNING $folder present before delivery")
				if -f $folder && $'loglvl > 5;
			&'add_log("ERROR original $folder$ext lost")
				if ! -f "$folder$ext" && $'loglvl;
			$compress{$folder} = 0;		# Do not recompress, yet mark as dealt
		} else {						# Folder should be decompressed
			if (-f "$folder$ext") {
				&'add_log("WARNING compressed $folder still present")
					if $'loglvl > 5;
				$compress{$folder} = 0;	# Do not recompress it
			} else {
				$compress{$folder} = $tag;	# Folder recompressed after delivery
			}
			&'add_log("uncompressed $folder using $uncompress") if $'loglvl > 8;
		}
	} else {
		$compress{$folder} = $cf'comptag;	# Folder compressed after creation
	}
	&'free_file($folder);	# Unlock folder
	&'add_log("leaving uncompress") if ($'loglvl > 15);
	1;						# Success
}

# Compress a folder
sub compress'load_compress {
	package compress;
	local($folder) = @_;		# Folder to be compressed
	local($tag);
	return unless $compress{$folder};	# Folder not to be recompressed
	$tag = $compress{$folder};			# Which compression scheme was used
	delete $compress{$folder};			# Mark it compressed anyway
	if (&is_compressed($folder)) {		# A compressed form exists
		&'add_log("ERROR compressed $folder already present") if $'loglvl;
		return;
	}
	if (0 != &'acs_rqst($folder)) {		# Cannot compress if not locked
		&'add_log("WARNING $folder locked, skipping compression")
			if $'loglvl > 5;
		return;
	}
	local($compress) = $Compressor{$tag};
	local($ext) = $Ext{$tag};
	local($status) = system("$compress $folder");
	if ($status) {
		&'add_log("ERROR cannot compress $folder using $compress") if $'loglvl;
		if (-f $folder) {
			unless (unlink "$folder$ext") {
				&'add_log("ERROR cannot remove $folder$ext: $!") if $'loglvl;
			} else {
				&'add_log("NOTICE removing $folder$ext") if $'loglvl > 6;
			}
		} else {
			&'add_log("ERROR original $folder lost") if $'loglvl;
		}
	} else {
		&'add_log("WARNING uncompressed $folder still present")
			if -f $folder && $'loglvl > 5;
		&'add_log("compressed $folder using $compress") if $'loglvl > 8;
	}
	&'free_file($folder);
}

# Recompress all folders which have been delivered to
sub compress'load_recompress {
	package compress;
	foreach $file (keys %compress) {
		&compress($file);
	}
}

# Restore uncompressed folder if listed in the compression list
sub compress'load_restore {
	package compress;
	return unless $cf'compress;		# Do nothing if no compress parameter
	return unless -s $cf'compress;	# No compress list file, or empty
	&init unless @compress;	# Initialize array only once
	return unless defined $Ext{$cf'comptag};	# Invalid compression tag
	local($folder) = @_;			# Folder candidate for uncompression
	&'add_log("candidate folder is $folder") if $'loglvl > 18;

	# Loop over each pattern in the compression file and see if the folder
	# matches one of them. As soon as one matches, the folder is uncompressed
	# if necessary and the processing is over.
	foreach $pattern (@compress) {
		&'add_log("matching against '$pattern'") if $'loglvl > 19;
		if ($folder =~ /^$pattern$/) {
			&'add_log("matched '$pattern'") if $'loglvl > 18;
			# Give it two shots. The second parameter is a retrying flag.
			# The difference between the two is that recompression of other
			# uncompressed folders is attempted the first time if the folder
			# cannot be uncompressed (assuming low disk space).
			&uncompress($folder, 0) unless &uncompress($folder, 1);
			last;
		}
	}
}

# Check to see if a compressed version of a given folder exists.
# Returns the tag identifying the compression type.
sub compress'load_is_compressed {
	package compress;
	local($folder) = @_; 
	local($suffix);

	foreach $suffix (keys %Suffix) {
		next unless -f "$folder$suffix";
		&'add_log("folder $folder$suffix was compressed by $Suffix{$suffix}")
			if $'loglvl > 15;
		return $Suffix{$suffix};
	}

	return undef;	# Unable to identify any valid compression suffix
}

# Given a compressor definition like:
#
#	GNUzip		.gz	gzip		gunzip		gunzip -c
#
# fill in the internal data structures identifying the 'GNUzip' compressor.
# Those data structures are (private to this package):
#
#   %Ext: given a compress tag, yields the extension to be used
#   %Suffix: given the extension, which compression tag is this?
#   %Compressor: compression program by tag
#   %Uncompressor: uncompression program, by tag
#   %Ccat: cat program (for compressed input) by tag
#
# It is mandatory that no duplicate suffixes be used amongst the various
# compressor definitions. This is enforced by ignoring the faulty line!
sub compress'load_add_compressor {
	package compress;
	local($string) = @_;
	local($tag, $ext, $compress, $uncompress, $zcat) = split(/\t+/, $string, 5);
	if (defined $Suffix{$ext}) {
		local($ptag) = $Suffix{$ext};
		&'add_log("ERROR compressor suffix $ext for $tag already used by $ptag")
			if $'loglvl;
		return;			# Ignore duplicate suffix definition
	}
	$Ext{$tag} = $ext;
	$Suffix{$ext} = $tag;
	$Compressor{$tag} = $compress;
	$Uncompressor{$tag} = $uncompress;
	$Ccat{$tag} = $zcat;
}

# Parse the newcmd file and record all new commands in the mailagent data
# structures.
sub newcmd'load_load {
	package newcmd;
	return unless -s $cf'newcmd;	# Empty or non-existent file

	# Security checks. We cannot extend the mailagent commands if the file
	# describing those new commands is not owned by the user or ir world
	# writable. Indeed, someone could redefine default commands like LEAVE
	# and use that to break into the user account.
	return unless &'file_secure($cf'newcmd, 'new command');

	unless (open(NEWCMD, $cf'newcmd)) {
		&'add_log("ERROR cannot open $cf'newcmd: $!") if $'loglvl;
		&'add_log("WARNING new commands not loaded") if $'loglvl > 5;
		return;
	}

	local($home) = $cf'home;
	$home =~ s/(\W)/\\$1/g;			# Escape possible meta-characters like '+'

	local($_);
	local($cmd, $path, $function, $status, $seen);
	while (<NEWCMD>) {
		next if /^\s*#/;			# Skip comments
		next if /^\s*$/;			# Skip blank lines
		($cmd, $path, $function, $status, $seen) = split(' ');
		$cmd =~ tr/a-z/A-Z/;		# Cannonicalize to upper-case
		$path =~ s/~/$cf'home/;		# Perform ~ substitution
		unless (-e $path && -r _) {
			$path =~ s/^$home/~/;
			&'add_log("ERROR command '$cmd' bound to unreadable file $path")
				if $'loglvl > 1;
			next;					# Skip invalid command
		}
		unless (&'file_secure($path, "user command $cmd")) {
			&'add_log("ERROR command '$cmd' is not secure")
				if $'loglvl > 1;
			next;					# Skip unsecure command
		}
		# Load command into data structures by setting internal tables
		$'Filter{$cmd} = "newcmd'run";		# Main dispatcher for new commands
		$Usercmd{$cmd} = $path;				# Record command path
		$Loaded{$path} = 0;					# File not loaded yet
		$Run{$cmd} = $function;				# Perl function to call
		$'Nostatus{$cmd} = 1 if $status =~ /^f|n/i;
		$'Rfilter{$cmd} = 1 unless $seen =~ /^t|y/i;
		&interface'add($cmd);				# Add interface for perl hooks

		$path =~ s/^$home/~/;
		&'add_log("new command $cmd in $path (&$function)")
			if $'loglvl > 18;
	}
	close NEWCMD;
}

# This is the main dispatcher for user-defined command.
# Our caller 'run_command' has set up some special variables, like $mfile
# and $cmd_name, which are used here. Someday, I'll have to encapsulate that
# in a better way--RAM.
sub newcmd'load_run {
	package newcmd;
	# Make global variables visible in this package. Variables which should
	# not be changed are marked 'read only'.
	local($cmd) = $'cmd;					# Full command line (read only)
	local($cmd_name) = $'cmd_name;			# Command name (read only)
	local($mfile) = $'mfile;				# File name (read only)
	local(*ever_saved) = *'ever_saved;		# Saving already occurred?
	local(*folder_saved) = *'folder_saved;	# Last folder saved to
	local(*cont) = *'cont;					# Continuation status
	local(*lastcmd) = *'lastcmd;			# Last failure status stored
	local(*wmode) = *'wmode;				# Filter mode

	&'add_log("user-defined command $cmd_name") if $'loglvl > 15;

	# Let's see if we already have loaded the perl script which is responsible
	# for implementing this command.
	local($path) = $Usercmd{$cmd_name};
	unless ($path) {
		&'add_log("ERROR unknown user-defined command $cmd_name") if $'loglvl;
		return 1;					# Command failed (should not happen)
	}
	local($function) = $Run{$cmd_name};

	unless (&dynload'load('newcmd', $path, $function)) {
		&'add_log("ERROR cannot load code for user-defined $cmd_name")
			if $'loglvl;
		return 1;			# Command failed
	}

	# At this point, we know we have some code to call in order to run the
	# user-defined command. Prepare the special array @ARGV and initialize
	# the mailhook variable in the current package.
	&hook'initvar('newcmd');		# Initialize convenience variables
	local(@ARGV);					# Argument vector for command

	require Text::ParseWords;
	*shellwords = \&Text::ParseWords::old_shellwords;
	eval '@ARGV = &shellwords($cmd)';

	# We don't need to protect the following execution within an eval, since
	# we are currently inside one, via run_command.
	local($failed) = &$function($cmd);		# Call user-defined function

	# Log our action
	local($msg) = $failed ? "and failed" : "successfully";
	&'add_log("ran $cmd_name [$mfile] $msg") if $'loglvl > 6;

	$failed;			# Propagate failure status
}

# Quotation removal routine
sub main'load_q {
	package main;
	local($_) = @_;
	s/^://gm;
	$_;
}

# Hooks constants definitions
sub hook'load_init {
	package hook;
	$HOOK_UNKNOWN = "hook'unknown";		# Hook type was not recognized
	$HOOK_PROGRAM = "hook'program";		# Hook is a filter program
	$HOOK_AUDIT = "hook'audit";			# Hook is an audit-like script
	$HOOK_DELIVER = "hook'deliver";		# Hook is a deliver-like script
	$HOOK_RULES = "hook'rules";			# Hook is a rule file
	$HOOK_PERL = "hook'perl";			# Hook is a perl script
}

# Deal with the hook
sub hook'load_process {
	package hook;
	&init unless $init_done++;			# Initialize hook constants
	local($hook) = @_;
	local($type) = &type($hook);		# Get hook type
	&hooking($hook, $type);				# Print log message
	unless (chdir $cf'home) {
		&'add_log("WARNING cannot chdir to $cf'home: $!") if $'loglvl > 5;
	}
	eval '&$type($hook)';				# Call hook (inside eval to allow die)
	&'eval_error;						# Report errors and propagate status
}

# Determine the nature of the hook. The top 128 bytes are scanned for a magic
# number starting with #: and followed by some words. The type of the hook
# is determined by the first word (case insensitively).
sub hook'load_type {
	package hook;
	local($file) = @_;			# Name of hook file
	-f "$file" || return $HOOK_UNKNOWN;		
	-x _ || return $HOOK_UNKNOWN;
	open(HOOK, $file) || return $HOOK_PROGRAM;
	local($hook);
	sysread(HOOK, $hook, 128);	# Consider only top 128 bytes
	close(HOOK);
	local($name) = $hook =~ /^#:\s*(\w+)/;
	$name =~ tr/A-Z/a-z/;
	return $HOOK_AUDIT if $name eq 'audit';
	return $HOOK_DELIVER if $name eq 'deliver';
	return $HOOK_RULES if $name eq 'rules';
	return $HOOK_PERL if $name eq 'perl';
	$HOOK_PROGRAM;				# No magic token found
}

# The hook file is not valid
sub hook'load_unknown {
	package hook;
	local($hook) = @_;
	die("$hook is not a hook file");
}

# Mail is to be piped to the hook program (on stdin)
sub hook'load_program {
	package hook;
	local($hook) = @_;
	&'add_log("hook is a plain program") if $'loglvl > 17;
	local($failed) = &'shell_command($hook, $'MAIL_INPUT, $'NO_FEEDBACK);
	die("cannot run $hook") if $failed;
}

# Mail is to be filetered with rules from hook file
sub hook'load_rules {
	package hook;
	local($hook) = @_;
	&'add_log("hook contains mailagent rules") if $'loglvl > 17;
	die("unsecure hook") unless &'file_secure($hook, 'rule hook');
	local($'wmode) = 'INITIAL';		# Force working mode of INITIAL
	local($failed, $saved) = &'apply($hook);
	die("cannot apply rules") if $failed;
	unless ($saved) {
		&'add_log("NOTICE not saved, leaving in mailbox") if $'loglvl > 5;
		&'xeqte("LEAVE");
	}
}

# Mail is to be filtered through a perl script
sub hook'load_perl {
	package hook;
	local($hook) = @_;
	&'add_log("hook is a perl script") if $'loglvl > 17;
	die("unsecure hook") unless &'exec_secure($hook, 'perl hook');
	local($failed) = &'perl($hook);
	die("cannot run perl hook") if $failed;
}

# Hook is an audit script. Set up a suitable environment and execute the
# script after having forked a new process. To avoid name clashes, the script
# is compiled in a dedicated 'mailhook' package and executed.
# Note: the only difference with the perl hook is that we need to fork an
# extra process to run the hook, since it might use a plain 'exit', which would
# be desastrous on the mailagent.
sub hook'load_audit {
	package hook;
	local($hook) = @_;
	&'add_log("hook is an audit script") if $'loglvl > 17;
	die("unsecure hook") unless &'exec_secure($hook, 'audit hook');
	local($pid) = fork;
	$pid = -1 unless defined $pid;
	if ($pid == 0) {				# Child process
		&initvar('mailhook');		# Initialize special variables
		&run($hook);				# Load hook and run it
		exit(0);
	} elsif ($pid == -1) {
		&'add_log("ERROR cannot fork: $!") if $'loglvl;
		die("cannot audit with hook");
	}
	# Parent process comes here
	wait;
	die("audit hook failed") unless $? == 0;
}

# A delivery script is about the same as an audit script, except that the
# output on stdout is monitored and understood as mailagent commands to be
# executed upon successful return.
sub hook'load_deliver {
	package hook;
	local($hook) = @_;
	&'add_log("hook is a deliver script") if $'loglvl > 17;
	die("unsecure hook") unless &'exec_secure($hook, 'deliver hook');
	# Fork and let the child do all the work. The parent simply captures the
	# output from child's stdout.
	local($pid);
	$pid = open(HOOK, "-|");	# Implicit fork
	unless (defined $pid) {
		&'add_log("ERROR cannot fork: $!") if $'loglvl;
		die("cannot deliver to hook");
	}
	if (0 == $pid) {			# Child process
		&initvar('mailhook');	# Initialize special variables
		&run($hook);			# Load hook and run it
		exit(0);				# Everything went well
	}
	# Parent process comes here
	local($output) = ' ' x (-s HOOK);
	{
		local($/) = undef;		# We wish to slurp the whole output
		$output = <HOOK>;
	}
	close HOOK;					# An implicit wait -- status put in $?
	unless (0 == $?) {
		&'add_log("ERROR hook script failed") if $'loglvl;
		die("non-zero exit status") unless $output;
		die("commands ignored");
	}
	if ($output eq '') {
		&'add_log("WARNING no commands from delivery hook") if $'loglvl > 5;
	} else {
		&main'xeqte($output);	# Run mailagent commands
	}
}

# Log hook operation before it happens, as we may well exec() another program.
sub hook'load_hooking {
	package hook;
	local($hook, $type) = @_;
	local($home) = $cf'home;
	$home =~ s/(\W)/\\$1/g;		# Escape possible meta-characters
	$type =~ s/^hook'//;
	$hook =~ s/^$home/~/;
	&'add_log("HOOKING [$'mfile] to $hook ($type)") if $'loglvl > 4;
}

# 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 main'load_file_secure {
	package main;
	my ($file, $type, $exec) = @_;
	return 1 unless -e $file;	# Missing file considered secure

	# We're resolving symlinks recursively
	# NB: Race condition between our checks and the perusal of the file!
	#	--RAM, 2016-09-13

	if (-l $file) {				# File is a symbolic link
		my $target = &symfile_secure($file, $type);
		unless (defined $target) {
			# Symbolic link is not secure
			unless ($exec) {
				&add_log(
					"WARNING sensitive $type file $file is an " .
					"unsecure symbolic link"
				) if $loglvl > 5;
			}
			return 0;	# Unsecure file
		}
		$file = $target;
		if ($exec) {
			&add_log("NOTICE running $type $file actually runs $target")
				if $loglvl > 6;
		}
	}

	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 main'load_symdir_secure {
	package main;
	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 main'load_symfile_secure {
	package main;
	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 main'load_symdir_check {
	package main;
	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 main'load_symfile_check {
	package main;
	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 main'load_check_st_mode {
	package main;
	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 main'load_exec_secure {
	package main;
	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 main'load_cdir {
	package main;
	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;
}

# Initialize builtin server commands
sub cmdserv'load_init {
	package cmdserv;
	%Builtin = (					# Builtins and their implemetation routine
		'addauth',	'run_addauth',	# Append to power clearance file
		'approve',	'run_approve',	# Record password for forthcoming command
		'delpower',	'run_delpower',	# Delete power from system
		'getauth',	'run_getauth',	# Get power clearance file
		'newpower',	'run_newpower',	# Add a new power to the system
		'passwd',	'run_passwd',	# Change power password, alternate syntax
		'password',	'run_password',	# Set new password for power
		'power',	'run_power',	# Ask for new power
		'powers',	'run_powers',	# A list of powers, along with clearances
		'release',	'run_release',	# Abandon power
		'remauth',	'run_remauth',	# Remove people from clearance file
		'set',		'run_set',		# Set internal variables
		'setauth',	'run_setauth',	# Set power clearance file
		'user',		'run_user',		# Commands on behalf of new user
	);
	%Conceal = (					# Words to be hidden in transcript
		'power',	'2',			# Protect power password
		'password',	'2',			# Second argument is password
		'passwd',	'2,3',			# Both old and new passwords are concealed
		'newpower',	'2',			# Power password
		'delpower',	'2,3',			# Power password and security
		'getauth',	'2',			# Power password if no system clearance
		'setauth',	'2',			# Power password
		'addauth',	'2',			# Power password
		'remauth',	'2',			# Power passowrd
		'approve',	'1',			# Approve passoword
	);
	%Collect = (					# Commands collecting more data from mail
		'newpower',	1,				# Takes list of allowed addresses
		'setauth',	1,				# Takes new list of allowed addresses
		'addauth',	1,				# Allowed addresses to be added
		'remauth',	1,				# List of addresses to be deleted
	);
	%Set = (						# Internal variables which may be set
		'debug',	'flag',			# Debugging mode
		'eof',		'var',			# End of file marker (default is EOF)
		'pack',		'var',			# Packing mode for file sending
		'path',		'var',			# Destination address for file sending
		'trace',	'flag',			# The trace flag
	);
}

# Load command file into memory, setting %Command, %Type, %Path and %Extra
# arrays, all indexed by a command name.
sub cmdserv'load_load {
	package cmdserv;
	$loaded = 1;					# Do not come here more than once
	&init;							# Initialize builtins
	return unless -s $cf'comserver;	# Empty or non-existent file
	return unless &'file_secure($cf'comserver, 'server command');
	unless (open(COMMAND, $cf'comserver)) {
		&'add_log("ERROR cannot open $cf'comserver: $!") if $'loglvl;
		&'add_log("WARNING server commands not loaded") if $'loglvl > 5;
		return;
	}

	local($_);
	local($cmd, $type, $hide, $collect, $path, @extra);
	local(%known_type) = (
		'perl',		1,				# Perl script loaded dynamically
		'shell',	1,				# Program to run via fork/exec
		'help',		1,				# Help, send back files from dir
		'end',		1,				# End processing of requests
		'flag',		1,				# A variable flag
		'var',		1,				# An ascii variable
	);
	local(%set_type) = (
		'flag',		1,				# Denotes a flag variable
		'var',		1,				# Denotes an ascii variable
	);

	while (<COMMAND>) {
		next if /^\s*#/;			# Skip comments
		next if /^\s*$/;			# Skip blank lines
		($cmd, $type, $hide, $collect, $path, @extra) = split(' ');
		$path =~ s/~/$cf'home/;		# Perform ~ substitution

		# Perl commands whose function name is not defined will bear the same
		# name as the command itself. If no path was specified, use the value
		# of the servdir configuration parameter from ~/.mailagent and assume
		# each command is stored in a cmd or cmd.pl file. Same for shell
		# commands, expected in a cmd or cmd.sh file. However, if the shell
		# command is not found there, it will be located at run-time using the
		# PATH variable.
		@extra = ($cmd) if $type eq 'perl' && @extra == 0;
		if ($type eq 'perl' || $type eq 'shell') {
			if ($path eq '-') {
				$path = "$cf'servdir/$cmd";
				$path = "$cf'servdir/$cmd.pl" if $type eq 'perl' && !-e $path;
				$path = "$cf'servdir/$cmd.sh" if $type eq 'shell' && !-e $path;
				$path = '-' if $type eq 'shell' && !-e $path;
			} elsif ($path !~ m|^/|) {
				$path = "$cf'servdir/$path";
			}
		}

		# If path is specified, make sure it is valid
		if ($path ne '-' && !(-e $path && (-r _ || -x _))) {
			local($home) = $cf'home;
			$home =~ s/(\W)/\\$1/g;		# Escape possible metacharacters (+)
			$path =~ s/^$home/~/;
			&'add_log("ERROR command '$cmd' bound to invalid path $path")
				if $'loglvl > 1;
			next;					# Ignore invalid command
		}

		# Verify command type
		unless ($known_type{$type}) {
			&'add_log("ERROR command '$cmd' has unknown type $type")
				if $'loglvl > 1;
			next;					# Skip to next command
		}

		# If command is a variable, record it in the %Set array. Since all
		# variables are proceseed separately from commands, it is perfectly
		# legal to have both a command and a variable bearing the same name.
		if ($set_type{$type}) {
			$Set{$cmd} = $type;		# Record variable as being of given type
			next;
		}

		# Load command into internal data structures
		$Command{$cmd}++;			# Record known command
		$Type{$cmd} = $type;
		$Path{$cmd} = $path;
		$Extra{$cmd} = join(' ', @extra);
		$Conceal{$cmd} = $hide if $hide ne '-';
		$Collect{$cmd}++ if $collect =~ /^y/i;
	}
	close COMMAND;
}

# Process server commands held in the body, either by batching them or by
# executing them right away. A transcript is sent to the sender.
# Requires a previous call to 'setuid'.
sub cmdserv'load_process {
	package cmdserv;
	local(*body) = @_;				# Mail body
	local($_);						# Current line processed
	local($metoo);					# Send blind carbon copy to me too?

	&load unless $loaded;			# Load commands unless already done
	$cmdenv'jobnum = $'jobnum;		# Propagate job number
	$metoo = $cf'email if $cf'scriptcc =~ /^on/i;

	# Make sure sender address is not hostile
	unless (&addr'valid($cmdenv'uid)) {
		&add_log("ERROR $cmdenv'uid is an hostile sender address")
			if $'loglvl > 1;
		return 1;	# Failed, will discard whole mail message then
	}

	# Set up a mailer pipe to send the transcript back to the sender
	#
	# We used to do a simple:
	#	open(MAILER, "|$cf'sendmail $cf'mailopt $cmdenv'uid $metoo")
	# here but this had a nasty side effect with smart mailers: a
	# lengthy command could cause a timeout, breaking the pipe and leading
	# to a failure.
	#
	# Intead, we just create a temporary file somewhere, and immediately
	# unlink it. Keeping the fd preciously lets us manipulate this temporary
	# file with the insurance that it will not leave any trace should we
	# fail abruptly.

	unless (open(MAILER, "+>$cf'tmpdir/serv.mail$$")) {
		&'add_log("ERROR cannot create temporary mail transcript: $!")
			if $'loglvl > 1;
	}

	# We may fork and have to close one end of the MAILER pipe, so make sure
	# no unflushed data ever remain...
	select((select(MAILER), $| = 1)[0]);

	# Build up initial header. Be sure to add a junk precedence, since we do
	# not want to get any bounces.
	# For some reason, perl 4.0 PL36 fails with the here document construct
	# when using dataloading.
	print MAILER
"To: $cmdenv'uid
Subject: Mailagent session transcript
Precedence: junk
$main'MAILER

    ---- Mailagent session transcript for $cmdenv'uid ----
";

	# Start message processing. Stop as soon as an ending command is reached,
	# or when more than 'maxerrors' errors have been detected. Also stop
	# processing when a signature is reached (introduced by '--').

	foreach (@body) {
		if ($cmdenv'collect) {			# Collecting data for command
			if ($_ eq $cmdenv'eof) {	# Reached end of "file"
				$cmdenv'collect = 0;	# Stop collection
				&execute;				# Execute command
				undef @cmdenv'buffer;	# Free memory
			} else {
				push(@cmdenv'buffer, $_);
			}
			next;
		}
		if ($cmdenv'errors > $cf'maxerrors && !&root) {
			&finish('too many errors');
			last;
		}
		if ($cmdenv'requests > $cf'maxcmds && !&root) {
			&finish('too many requests');
			last;
		}
		next if /^\s*$/;			# Skip blank lines
		print MAILER "\n";			# Separate each command
		s/^\s*//;					# Strip leading spaces
		&cmdenv'set_cmd($_);		# Set command environment
		$cmdenv'approve = '';		# Clear approve password
		&user_prompt;				# Copy line to transcript
		if (/^--\s*$/) {			# Signature reached
			&finish('.signature');
			last;
		}
		if ($Disabled{$cmdenv'name}) {		# Skip disabled commands
			$cmdenv'errors++;
			print MAILER "Disabled command.\n";
			print MAILER "FAILED.\n";
			&'add_log("DISABLED $cmdenv'log") if $'loglvl > 1;
			next;
		}
		unless (defined $Builtin{$cmdenv'name}) {
			unless (defined $Command{$cmdenv'name}) {
				$cmdenv'errors++;
				print MAILER "Unknown command.\n";
				print MAILER "FAILED.\n";
				&'add_log("UNKNOWN $cmdenv'log") if $'loglvl > 1;
				next;
			}
			if ($Type{$cmdenv'name} eq 'end') {	# Ending request?
				&finish("user's request");		# Yes, end processing then
				last;
			}
		}
		if (defined $Collect{$cmdenv'name}) {
			$cmdenv'collect = 1;		# Start collect mode
			next;						# Grab things in @cmdenv'buffer
		}
		&execute;				# Execute command, report in transcript
	}

	# If we are still in collecting mode, then the EOF marker was not found
	if ($cmdenv'collect) {
		&'add_log("ERROR did not reach eof mark '$cmdenv'eof'")
			if $'loglvl > 1;
		&'add_log("FAILED $cmdenv'log") if $'loglvl > 1;
		print MAILER "Could not find eof marker '$cmdenv'eof'.\n";
		print MAILER "FAILED.\n";
	}

	print MAILER <<EOM;

    ---- End of mailagent session transcript ----
EOM

	# We used to simply close MAILER at this point, but it is now a fd on
	# a temporary file. We're going to rewind in and copy it onto the SENDMAIL
	# real mailer descriptor.

	unless (open(SENDMAIL, "|$cf'sendmail $cf'mailopt $cmdenv'uid $metoo")) {
		&'add_log("ERROR cannot start $cf'sendmail to mail transcript: $!")
			if $'loglvl > 1;
		unless (open(SENDMAIL, ">> $cf'emergdir/serv-msg.$$")) {
			&'add_log("ERROR can't even dump into $cf'emergdir/serv-msg.$$: $!")
				if $'loglvl > 1;
			# Last chance, print on STDOUT
			open(SENDMAIL, '>&STDOUT');
			&'add_log("NOTICE dumping server transcript on stdout")
				if $'loglvl > 6;
			print STDOUT "*** dumping server transcript: ***\n";
		}
	}

	unless (seek(MAILER, 0, 0)) {
		&'add_log("ERROR cannot seek back to start of transcript: $!")
			if $'loglvl > 1;
	}

	local($l);
	while (defined ($l = <MAILER>)) {
		print SENDMAIL $l;
	}
	close MAILER;			# Bye bye temporary file

	unless (close SENDMAIL) {
		&'add_log("ERROR cannot mail transcript to $cmdenv'uid")
			if $'loglvl > 1;
	}
	0;	# Success
}

# Execute command recorded in the cmdenv environment. For each type of command,
# the routine 'exec_type' is called and returns 0 if ok. Builtins are dealt
# separately by calling the corresponding perl function.
sub cmdserv'load_execute {
	package cmdserv;
	$cmdenv'requests++;				# One more request
	local($log) = $cmdenv'log;		# Save log, since it could be modified
	local($failed) = &dispatch;		# Dispatch command
	if ($failed) {
		&'add_log("FAILED $log") if $'loglvl > 1;
		$cmdenv'errors++;
		print MAILER "FAILED.\n";
	} else {
		&'add_log("OK $log") if $'loglvl > 2;
		print MAILER "OK.\n";
	}
}

# Dispatch command held in $cmdenv'name and return failure status (0 means ok).
sub cmdserv'load_dispatch {
	package cmdserv;
	local($failed) = 0;
	&'add_log("XEQ ($cmdenv'name) as $cmdenv'user") if $'loglvl > 10;
	if (defined $Builtin{$cmdenv'name}) {	# Deal separately with builtins
		eval "\$failed = &$Builtin{$cmdenv'name}";	# Call builtin function
		if (chop($@)) {
			print MAILER "Perl failure: $@\n";
			$@ .= "\n";		# Restore final char for &'eval_error call
			&'eval_error;	# Log error
			$@ = '';		# Clear evel error condition
			$failed++;		# Make sure failure is recorded
		}
	} else {
		# Command may be unknwon if called from 'user <email> command' or
		# from an 'approve <password> comamnd' type of invocation.
		if (defined $Type{$cmdenv'name}) {
			eval "\$failed = &exec_$Type{$cmdenv'name}";
		} else {
			print MAILER "Unknown command.\n";
			$cmdenv'errors++;
			$failed++;
		}
	}
	$failed;		# Report failure status
}

# Shell command
sub cmdserv'load_exec_shell {
	package cmdserv;
	# Check for unsecure characters in shell command
	if ($cmdenv'cmd =~ /([=\$^&*([{}`\\|;><?])/ && !&root) {
		$cmdenv'errors++;
		print MAILER "Unsecure character '$1' in command line.\n";
		return 1;		# Failed
	}

	# Initialize input script (if command operates in 'collect' mode)
	local($error) = 0;		# Error flag
	local($input) = '';		# Input file, when collecting
	if (defined $Collect{$cmdenv'name}) {
		$input = "$cf'tmpdir/input.cmd$$";
		unless (open(INPUT, ">$input")) {
			&'add_log("ERROR cannot create $input: $!") if $'loglvl;
			$error++;
		} else {
			foreach $collected (@cmdenv'buffer) {
				(print INPUT $collected, "\n") || $error++;
				&'add_log("SYSERR write: $!") if $error && $'loglvl;
				last if $error;
			}
			close(INPUT) || $error++;
			&'add_log("SYSERR close: $!") if $error == 1 && $'loglvl;
		}
		if ($error) {
			print MAILER "Cannot create input file ($!).\n";
			&'add_log("ERROR cannot initialize input file") if $'loglvl;
			unlink $input;
			return 1;		# Failed
		}
	}

	# Ensure the command we're about to execute is secure
	local(@argv) = split(' ', $cmdenv'cmd);
	$argv[0] = $Path{$cmdenv'name} if defined $Path{$cmdenv'name};
	local($cmd) = &'locate_program($argv[0]);
	unless ($cmd =~ m|/|) {
		&'add_log("ERROR cannot locate $cmd") if $'loglvl;
		unlink $input if $input;
		print MAILER "Unable to locate command.\n";
		return 1;			# Failed
	}
	unless (&'exec_secure($cmd, 'server command')) {
		&'add_log("ERROR unsecure command $cmd") if $'loglvl;
		unlink $input if $input;
		print MAILER "Unable to locate command.\n";	# Don't tell them the truth!
		return 1;			# Failed
	}

	# Create shell command file, whose purpose is to set up the environment
	# properly and do the appropriate file descriptors manipulations, which
	# is easier to do at the shell level, and cannot fully be done in perl 4.0
	# (see dup2 hack below).
	$cmdfile = "$cf'tmpdir/mess.cmd$$";
	unless (open(CMD, ">$cmdfile")) {
		&'add_log("ERROR cannot create $cmdfile: $!") if $'loglvl;
		print MAILER "Cannot create file comamnd file ($!).\n";
		unlink $input if $input;
		return 1;		# Failed
	}

	# Initialize command environment
	local($key, $val);		# Key/value from perl's symbol table
	local($value);
	# Loop over perl's symbol table for the cmdenv package
	eval "*_cmdenv = *::cmdenv::" if $] > 5;	# Perl 5 support
	while (($key, $val) = each %_cmdenv) {
		local(*entry) = $val;		# Get definitaions of current slot
		&'add_log("considering variable $key") if $'loglvl > 15;
		next unless defined $entry;	# No variable slot
		next if $key !~ /^[a-z]\w+$/i;		# Skip invalid names for shell
		($value = $entry) =~ s/'/'"'"'/g;	# Keep simple quotes
		(print CMD "$key='$value' export $key\n") || $error++;
		&'add_log("env set $key='$value'") if $'loglvl > 15;
	}
	# Now add command invocation and input redirection. Standard input will be
	# the collect buffer, if any, and file descriptor #3 is a path to the
	# session transcript.
	local($redirect);
	local($extra) = $Extra{$cmdenv'name};
	$redirect = "<$input" if $input;
	(print CMD "cd $cf'home\n") || $error++;	# Make sure we start from home
	(print CMD "exec 3>&2 2>&1\n") || $error++;	# See dup2 hack below
	(print CMD "$argv[0] $extra @argv[1..$#argv] $redirect\n") || $error++;
	close(CMD) || $error++;
	close CMD;
	if ($error) {
		&'add_log("ERROR cannot initialize $cmdfile: $!") if $'loglvl;
		unlink $cmdfile;
		unlink $input if $input;
		print MAILER "Cannot initialize command file ($!).\n";
		return 1;			# Failed
	}

	&include($cmdfile, 'command', '<<< ') if $cmdenv'debug;

	# Set up trace file
	$trace = "$cf'tmpdir/trace.cmd$$";
	unless (open(TRACE, ">$trace")) {
		&'add_log("ERROR cannot create $trace: $!") if $'loglvl;
		unlink $cmdfile;
		unlink $input if $input;
		print MAILER "Cannot create trace file ($!).\n";
		return 1;			# Failed
	}

	# Now fork a child which will redirect stdout and stderr onto the trace
	# file and exec the command file.

	local($pid) = fork;			# We fork here
	unless (defined $pid) {		# Apparently, we could not fork...
		&'add_log("SYSERR fork: $!") if $'loglvl;
		close TRACE;
		unlink $cmdfile, $trace;
		unlink $input if $input;
		print MAILER "Cannot fork ($!).\n";
		return 1;			# Failed
	}

	# Child process runs the command
	if ($pid == 0) {				# Child process
		# Perform a dup2(MAILER, 3) to allow file descriptor #3 to be a way
		# for the shell script to reach the session transcript. Since perl
		# insists on closing all file descriptors >2 ($^F) during the exec, we
		# remap the current STDERR to MAILER temporarily. That way, it will
		# be transmitted to the child, which is a shell script doing an
		# 'exec 3>&2 2>&1', meaning the file #3 is the original MAILER and
		# stdout and stderr for the script go to the same trace file, as
		# intiallly attached to stdout.
		#
		open(STDOUT, '>&TRACE');	# Redirect stdout to the trace file
		open(STDERR, '>&MAILER');	# Temporarily mapped to the MAILER file
		close(STDIN);				# Make sure there is no input

		# For HPUX-10.x, grrr... have to use /bin/ksh otherwise that silly
		# posix shell closes all the file descriptors greater than 2, defeating
		# all our cute setting here...

		local($shell) = &servshell;

		# Using a sub-block ensures exec() is followed by nothing
		# and makes mailagent "perl -cw" clean, whatever that means ;-)
		{ exec "$shell $cmdfile" }	# Don't let perl use sh -c

		&'add_log("SYSERR exec: $!") if $'loglvl;
		&'add_log("ERROR cannot exec $shell $cmdfile") if $'loglvl;
		print MAILER "Cannot exec command file ($!).\n";
		exit(9);
	}

	close TRACE;		# Only child uses it
	wait;				# Wait for child
	unlink $cmdfile;	# Has been used and abused...
	unlink $input if $input;

	if ($?) {			# Child exited with non-zero status
		local($status) = $? >> 8;
		&'add_log("ERROR child exited with status $status") if $'loglvl > 1;
		print MAILER "Command returned a non-zero status ($status).\n";
		$error = 1;
	}
	&include($trace, 'trace', '<<< ') if $error || $cmdenv'trace;
	unlink $trace;
	$error;				# Failure status
}

# Perl command
sub cmdserv'load_exec_perl {
	package cmdserv;
	local($name) = $cmdenv'name;		# Command name
	local($fn) = $Extra{$name};			# Perl function to execute
	$fn = $name unless $fn;				# If none specified, use command name
	unless (&dynload'load('cmdenv', $Path{$name}, $fn)) {
		&'add_log("ERROR cannot load script for command $name") if $'loglvl;
		print MAILER "Cannot load $name command.\n";
		return 1;		# Failed
	}
	# Place in the cmdenv package context and call the function, propagating
	# the error status (1 for failure). Arguments are pre-split on space,
	# simply for convenience, but the command is free to parse the 'cmd'
	# variable itself.
	package cmdenv;
	local(*MAILER) = *cmdserv'MAILER;	# Propagate file descriptor
	local($fn) = $cmdserv'fn;			# Propagate function name
	local(@argv) = split(' ', $cmd);
	shift(@argv);						# Remove command name
	local($res) = eval('&$fn(@argv)');	# Call function, get status
	if (chop $@) {
		&'add_log("ERROR in perl $name: $@") if $'loglvl;
		print MAILER "Perl error: $@\n";
		$res = 1;
	}
	$res;		# Propagate error status
}

# Help command. Start by looking in the user's help directory, then in
# the public mailagent help directory. Users may disable help for a
# command by making an empty file in their own help dir.
sub cmdserv'load_exec_help {
	package cmdserv;
	local(@topic) = split(' ', $cmdenv'cmd);
	local($topic) = $topic[1];	# Help topic wanted
	local($help);				# Help file
	unless ($topic) {			# General builin help
		# Doesn't work with a here document form... (perl 4.0 PL36)
		print MAILER
"Following is a list of the known commands. Some additional help is available
on a command basis by using 'help <command>', unless the command name is
followed by a '*' character in which case no further help may be obtained.
Commands collecting input until an EOF mark are flagged with a trailing '='.

";
		local(@cmds);			# List of known commands
		local($star);			# Does command have a help file?
		local($plus);			# Does command require additional input?
		local($online) = 0;		# Number of commands currently printed on line
		local($print);			# String printed for each command
		local($fieldlen) = 18;	# Amount of space dedicated to each command
		push(@cmds, keys(%Builtin), keys(%Command));
		foreach $cmd (sort @cmds) {
			$help = "$cf'helpdir/$cmd";
			$help = "$'privlib/help/$cmd" unless -e $help;
			$star = -s $help ? '' : '*';
			$plus = defined($Collect{$cmd}) ? '=' : '';
			# We print 4 commands on a single line
			$print = $cmd . $plus . $star;
			print MAILER $print, ' ' x ($fieldlen - length($print));
			if ($online++ == 3) {
				$online = 0;
				print MAILER "\n";
			}
		}
		print MAILER "\n" if $online;	# Pending line not completed yet
		print MAILER "\nEnd of command list.\n";
		return 0;	# Ok
	}
	$help = "$cf'helpdir/$topic";
	$help = "$'privlib/help/$cmd" unless -e $help;
	unless (-s $help) {
		print MAILER "Help for '$topic' is not available.\n";
		return 0;	# Not a failure
	}
	&include($help, "$topic help", '');	# Include file and propagate status
}

# Approve command in advance by specifying a password. The syntax is:
#    approve <password> [command]
# and the password is simply recorded in the command environment. Then parsing
# of the command is resumed.
# NOTE: cannot approve a command which collects input (yet).
sub cmdserv'load_run_approve {
	package cmdserv;
	local($x, $password, @command) = split(' ', $cmdenv'cmd);
	$cmdenv'approve = $password;			# Save approve password
	&cmdenv'set_cmd(join(' ', @command));	# Set command environment
	&dispatch;			# Execute command and propagate status
}

# Ask for new power. The syntax is:
#    power <name> <password>
# Normally, 'root' does not need to request for any other powers, less give
# any password. However, for simplicity and uniformity, we simply grant it
# with no checks.
sub cmdserv'load_run_power {
	package cmdserv;
	local($x, $name, $password) = split(' ', $cmdenv'cmd);
	if (!$cmdenv'trusted) {		# Server has to be running in trusted mode
		&power'add_log("WARNING cannot gain power '$name': not in trusted mode")
			if $'loglvl > 5;
	} elsif (&root || &power'grant($name, $password, $cmdenv'uid)) {
		&power'add_log("granted power '$name' to $cmdenv'uid") if $'loglvl > 2;
		&cmdenv'addpower($name);
		return 0;		# Ok
	}
	print MAILER "Permission denied.\n";
	1;		# Failed
}

# Release power. The syntax is:
#    release <name>
# If the 'root' power is released, other powers obtained while root or before
# are kept. That way, it makes sense to ask for powers as root when the
# password for some power has been changed. It is wise to release a power once
# it is not needed anymore, since it may prevent mistakes.
sub cmdserv'load_run_release {
	package cmdserv;
	local($x, $name) = split(' ', $cmdenv'cmd);
	&cmdenv'rempower($name);
	0;		# Always ok
}

# List all powers with their clearances. The syntax is:
#    powers <regexp>
# and the 'system' power is needed to get the list. The root power or security
# power is needed to get the root or security information. If no arguments are
# specified, all the non-privileged powers (if you do not have root or security
# clearance) are listed. If arguments are given, they are taken as regular
# expression filters (perl way).
sub cmdserv'load_run_powers {
	package cmdserv;
	local($x, @regexp) = split(' ', $cmdenv'cmd);
	unless (&cmdenv'haspower('system') || &cmdenv'haspower('security')) {
		print MAILER "Permission denied.\n";
		return 1;
	}
	unless (open(PASSWD, $cf'passwd)) {
		&power'add_log("ERROR cannot open password file $cf'passwd: $!")
			if $'loglvl;
		print MAILER "Cannot open password file ($!).\n";
		return 1;
	}
	print MAILER "List of currently defined powers:\n";
	local($_);
	local($power);			# Current power analyzed
	local($matched);		# Did power match the regular expression?
	while (<PASSWD>) {
		($power) = split(/:/);
		# If any of the following regular expressions is incorrect, a die will
		# be generated and caught by the enclosing eval.
		$matched = @regexp ? 0 : 1;
		foreach $regexp (@regexp) {
			eval '$power =~ /$regexp/ && ++$matched;';
			if (chop($@)) {
				print MAILER "Perl failure: $@\n";
				$@ = '';
				close PASSWD;
				return 1;
			}
			last if $matched;
		}
		next unless $matched;
		print MAILER "\nPower: $power\n";
		if (
			($power eq 'root' || $power eq 'security') &&
			!&cmdenv'haspower($power)
		) {
			print MAILER "(Cannot list clearance file: permission denied.)\n";
			next;
		}
		&include(&power'authfile($power), "$power clearance");
	}
	close PASSWD;
	0;
}

# Set new power password. The syntax is:
#    password <name> <new>
# To change a power password, you need to get the corresponding power or be
# system, hence showing you know the password for that power or have greater
# privileges. To change the 'root' and 'security' passwords, you need the
# corresponding security clearance.
sub cmdserv'load_run_password {
	package cmdserv;
	local($x, $name, $new) = split(' ', $cmdenv'cmd);
	local($required) = $name;
	$required = 'system' unless &cmdenv'haspower($name);
	$required = $name if $name eq 'root' || $name eq 'security';
	unless (&cmdenv'haspower($required)) {
		print MAILER "Permission denied (not enough power).\n";
		&power'add_log("ERROR $cmdenv'uid tried a password change for '$name'")
			if $'loglvl > 1;
		return 1;
	}
	return &change_password($name, $new);
}

# Set new power password. The syntax is:
#    passwd <name> <old> <new>
# You do not need to have the corresponding power to change the password since
# the old password is requested. This is a short for the sequence:
#    power <name> <old>
#    password <name> <new>
#    release <name>
# excepted that even root has to give the correct old password if this form
# is used.
sub cmdserv'load_run_passwd {
	package cmdserv;
	local($x, $name, $old, $new) = split(' ', $cmdenv'cmd);
	unless (&power'authorized($name, $cmdenv'uid)) {
		&power'add_log("ERROR $cmdenv'uid tried a password change for '$name'")
			if $'loglvl > 1;
		print MAILER "Permission denied (lacks authorization).\n";
		return 1;
	}
	unless (&power'valid($name, $old)) {
		&power'add_log("ERROR $cmdenv'uid gave wrong old password for '$name'")
			if $'loglvl > 1;
		print MAILER "Permission denied (invalid pasword).\n";
		return 1;
	}
	return &change_password($name, $new);
}

# Change password for power 'name' to be $new.
# All security checks have been performed at this point, so we may indeed
# attempt the change. Note that this subroutine is common for the two
# passwd and password commands.
# Returns 0 if OK, 1 on error.
sub cmdserv'load_change_password {
	package cmdserv;
	local($name, $new) = @_;
	if (0 == &power'set_passwd($name, $new)) {
		&power'add_log("user $cmdenv'uid changed password for power '$name'")
			if $'loglvl > 2;
		return 0;
	}
	&power'add_log("ERROR user $cmdenv'uid failed change password for '$name'")
		if $'loglvl > 1;
	print MAILER "Could not change password, sorry.\n";
	1;
}

# Change user ID, i.e. e-mail address. The syntax is:
#    user [<email> [command]]
# and is used to execute some commands on behalf of another user. If a command
# is specified, it is immediately executed with the new identity, which only
# lasts for that time. Otherwise, the remaining commands are executed with that
# new ID. If no email is specified, the original sender ID is restored.
# All the powers are lost when a user command is executed, but this is only
# temporary when the command is specified on the same line.
sub cmdserv'load_run_user {
	package cmdserv;
	local($x, $user, @command) = split(' ', $cmdenv'cmd);
	local(%powers);
	local($powers);
	if (0 == @command && $cmdenv'powers ne '') {
		print MAILER "Wiping out current powers ($cmdenv'powers).\n";
		&cmdenv'wipe_powers;
	}
	if (0 != @command && $cmdenv'powers ne '') {
		%powers = %cmdenv'powers;
		$powers = $cmdenv'powers;
		print MAILER "Current powers temporarily lost ($cmdenv'powers).\n";
		&cmdenv'wipe_powers;
	}
	unless ($user) {			# Reverting to original sender ID
		$cmdenv'user = $cmdenv'uid;
		print MAILER "Back to original identity ($cmdenv'uid).\n";
		return 0;
	}
	if (0 == @command) {
		$cmdenv'user = $user;
		print MAILER "New user identity: $cmdenv'user.\n";
		return 0;
	}

	&cmdenv'set_cmd(join(' ', @command));	# Set command environment
	local($failed) = &dispatch;				# Execute command

	if (%powers) {
		$cmdenv'powers = $powers;
		%cmdenv'powers = %powers;
		print MAILER "Restored powers ($powers).\n";
	}

	$failed;		# Propagate failure status
}

# Add a new power to the system. The syntax is:
#    newpower <name> <password> [alias]
# followed by a list of approved names who may request that power. The 'system'
# power is required to add a new power. An alias should be specified if the
# name is longer than 12 characters. The 'security' power is required to create
# the root power, and root power is needed to create 'security'.
sub cmdserv'load_run_newpower {
	package cmdserv;
	local($x, $name, $password, $alias) = split(' ', $cmdenv'cmd);
	if (
		($name eq 'root' && !&cmdenv'haspower('security')) ||
		($name eq 'security' && !&cmdenv'haspower('root')) ||
		!&cmdenv'haspower('system')
	) {
		print MAILER "Permission denied.\n";
		return 1;
	}
	&newpower($name, $password, $alias);
}

# Actually add the new power to the system, WITHOUT any security checks. It
# is up to the called to ensure the user has correct permissions. Return 0
# if ok and 1 on error.
# The clearance list is taken from @cmdenv'buffer.
sub cmdserv'load_newpower {
	package cmdserv;
	local($name, $password, $alias) = @_;
	local($power) = &power'getpwent($name);
	if (defined $power) {
		print MAILER "Power '$name' already exists.\n";
		return 1;
	}
	if (length($name) > 12 && !defined($alias)) {
		# Compute a suitable alias name, which never appears externally anyway
		# so it's not really important to use cryptic ones. First, reduce the
		# power name to 10 characters.
		$alias = $name;
		$alias =~ tr/aeiouy//d;
		$alias = substr($alias, 0, 6) . substr($alias, -6);
		if (&power'used_alias($alias)) {
			$alias = substr($alias, 0, 10);
			local($tag) = 'AA';
			local($try) = 100;
			local($attempt);
			while ($try--) {
				$attempt = "$alias$tag";
				last unless &power'used_alias($attempt);
				$tag++;
			}
			$alias = $attempt;
			if (&power'used_alias($alias)) {
				print MAILER "Cannot auto-select any unused alias.\n";
				return 1;	# Failed
			}
		}
		print MAILER "(Selecting alias '$alias' for this power.)\n";
	}
	# Make sure alias is not too long. Don't try to shorten any user-specified
	# alias if they took care of giving one instead of letting mailagent
	# pick one up...
	if (defined($alias) && length($alias) > 12) {
		print MAILER "Alias name too long (12 characters max).\n";
		return 1;
	}
	if (defined($alias) && &power'used_alias($alias)) {
		print MAILER "Alias '$alias' is already in use.\n";
		return 1;
	}
	if (defined($alias) && !&power'add_alias($name, $alias)) {
		print MAILER "Cannot add alias, sorry.\n";
		return 1;
	}
	unless (&power'set_auth($name, *cmdenv'buffer)) {
		print MAILER "Cannot set authentication file, sorry.\n";
		return 1;
	}
	if (-1 == &power'setpwent($name, "<$password>", '')) {
		print MAILER "Cannot add power, sorry.\n";
		return 1;
	}
	if (-1 == &power'set_passwd($name, $password)) {
		print MAILER "Warning: could not insert password.\n";
	}
	&power'add_log("NEW power '$name' created by $cmdenv'uid") if $'loglvl > 2;
	0;
}

# Delete a power from the system. The syntax is:
#    delpower <name> <password> [<security>]
# deletes a power and its associated user list. The 'system' power is required
# to delete most powers except 'root' and 'security'. The 'security' power may
# only be deleted by security and the root power may only be deleted when the
# security password is also specified.
sub cmdserv'load_run_delpower {
	package cmdserv;
	local($x, $name, $password, $security) = split(' ', $cmdenv'cmd);
	if (
		($name eq 'security' && !&cmdenv'haspower($name)) ||
		($name eq 'root' && !&power'valid('security', $security)) ||
		!&cmdenv'haspower('system')
	) {
		print MAILER "Permission denied (not enough power).\n";
		return 1;
	}
	unless (&root) {
		unless (&power'valid($name, $password)) {
			print MAILER "Permission denied (invalid password).\n";
			return 1;
		}
	}
	&delpower($name);
}

# Actually delete a power from the system, WITHOUT any security checks. It
# is up to the called to ensure the user has correct permissions. Return 0
# if ok and 1 on error.
sub cmdserv'load_delpower {
	package cmdserv;
	local($name) = @_;
	local($power) = &power'getpwent($name);
	if (!defined $power) {
		print MAILER "Power '$name' does not exist.\n";
		return 1;
	}
	local($auth) = &power'authfile($name);
	if ($auth ne '/dev/null' && !unlink($auth)) {
		&'add_log("SYSERR unlink: $!") if $'loglvl;
		&'add_log("ERROR could not remove clearance file $auth") if $'loglvl;
		print MAILER "Warning: could not remove clearance file.\n";
	}
	unless (&power'del_alias($name)) {
		print MAILER "Warning: could not remove power alias.\n";
	}
	if (0 != &power'rempwent($name)) {
		print MAILER "Failed (cannot remove password entry).\n";
		return 1;
	}
	&power'add_log("DELETED power '$name' by $cmdenv'uid") if $'loglvl > 2;
	0;
}

# Replace current clearance file. The syntax is:
#    setauth <name> <password>
# and requires no special power if the password is given or if the power is
# already detained. Otherwise, the system power is needed. For 'root' and
# 'security' clearances, the corresponding power is needed as well.
sub cmdserv'load_run_setauth {
	package cmdserv;
	local($x, $name, $password) = split(' ', $cmdenv'cmd);
	local($required) = $name;
	$required = 'system' unless &cmdenv'haspower($name);
	$required = $name if $name eq 'root' || $name eq 'security';
	unless (&cmdenv'haspower($required)) {
		unless (&power'valid($name, $password)) {
			print MAILER "Permission denied.\n";
			return 1;
		}
	}
	unless (&power'set_auth($name, *cmdenv'buffer)) {
		print MAILER "Cannot set authentication file, sorry.\n";
		return 1;
	}
	0;
}

# Add users to clearance file. The syntax is:
#    addauth <name> <password>
# and requires no special power if the password is given or if the power is
# already detained. Otherwise, the system power is needed. For 'root' and
# 'security' clearances, the corresponding power is needed as well.
sub cmdserv'load_run_addauth {
	package cmdserv;
	local($x, $name, $password) = split(' ', $cmdenv'cmd);
	local($required) = $name;
	$required = 'system' unless &cmdenv'haspower($name);
	$required = $name if $name eq 'root' || $name eq 'security';
	unless (&cmdenv'haspower($required)) {
		unless (&power'valid($name, $password)) {
			print MAILER "Permission denied.\n";
			return 1;
		}
	}
	unless (&power'add_auth($name, *cmdenv'buffer)) {
		print MAILER "Cannot add to authentication file, sorry.\n";
		return 1;
	}
	0;
}

# Remove users from clearance file. The syntax is:
#   remauth <name> <password>
# and requires no special power if the password is given or if the power is
# already detained. Otherwise, the system power is needed. For 'root' and
# 'security' clearances, the corresponding power is needed as well.
sub cmdserv'load_run_remauth {
	package cmdserv;
	local($x, $name, $password) = split(' ', $cmdenv'cmd);
	local($required) = $name;
	$required = 'system' unless &cmdenv'haspower($name);
	$required = $name if $name eq 'root' || $name eq 'security';
	unless (&cmdenv'haspower($required)) {
		unless (&power'valid($name, $password)) {
			print MAILER "Permission denied.\n";
			return 1;
		}
	}
	unless (&power'rem_auth($name, *cmdenv'buffer)) {
		print MAILER "Cannot remove from authentication file, sorry.\n";
		return 1;
	}
	0;
}

# Get current clearance file. The syntax is:
#    getauth <name> <password>
# and requires no special power if the password is given or if the power is
# already detained. Otherwise, the system power is needed for all powers,
# and for 'root' or 'security', the corresponding power is required.
sub cmdserv'load_run_getauth {
	package cmdserv;
	local($x, $name, $password) = split(' ', $cmdenv'cmd);
	local($required) = $name;
	$required = 'system' unless &cmdenv'haspower($name);
	$required = $name if $name eq 'root' || $name eq 'security';
	unless (&cmdenv'haspower($required)) {
		unless (&power'valid($name, $password)) {
			print MAILER "Permission denied.\n";
			return 1;
		}
	}
	local($file) = &power'authfile($name);
	&include($file, "$name clearance", '');	# Include file, propagate status
}

# Set internal variable. The syntax is:
#    set <variable> <value>
# and the corresponding variable from cmdenv package is set.
# If <variable> is missing, dump all the known variables.
sub cmdserv'load_run_set {
	package cmdserv;
	local($x, $var, @args) = split(' ', $cmdenv'cmd);
	if ($var eq '') {				# Dump defined variables
		local($type, $val);
		foreach $name (keys %Set) {
			$type = $Set{$name};	# Variable type 'flag' or 'var'
			$val = eval "defined(\$cmdenv'$name) ? \$cmdenv'$name : undef";
			next unless defined $val;
			$val = $val ? 'true' : 'false' if $type eq 'flag';
			$val = "'$val'" if $type ne 'flag';
			print MAILER "$name=$val\n";
		}
		return 0;
	}
	unless (defined $Set{$var}) {
		print MAILER "Unknown or read-only variable '$var'.\n";
		return 1;		# Failed
	}
	local($type) = $Set{$var};		# The variable type
	local($_);						# Value to assign to variable
	local($val);					# Final assigned value
	if ($type eq 'flag') {
		$_ = $args[0];
		if ($_ eq '' || /on/i || /yes/i || /true/i) {
			$val = 1;
		} else {
			$val = 0;
		}
	} else {
		$val = join(' ', @args);
	}
	eval "\$cmdenv'$var = \$val";	# Set variable in cmdenv package
	0;
}

# Emit the user prompt in transcript, then copy current line
sub cmdserv'load_user_prompt {
	package cmdserv;
	if (&root) {
		print MAILER "####> ";			# Command with no restrictions at all
	} elsif ($cmdenv'powers ne '') {
		print MAILER "====> ";			# Command with local privileges
	} elsif ($cmdenv'user ne $cmdenv'uid) {
		print MAILER "~~~~> ";			# Command on behalf of another user
	} else {
		print MAILER "----> ";			# Command from and for current user
	}
	print MAILER "$cmdenv'log\n";
}

# Include file in transcript, returning 1 on failure and 0 on success
# If the third parameter is given, then it is used as leading marks, and
# the enclosing digest lines are omitted.
sub cmdserv'load_include {
	package cmdserv;
	local($file, $description, $marks) = @_;
	unless (open(FILE, $file)) {
		&'add_log("ERROR cannot open $file: $!") if $'loglvl;
		print MAILER "Cannot open $description file ($!).\n";
		return 1;
	}
	local($_);
	print MAILER "   --- Beginning of file ($description) ---\n"
		unless defined $marks;
	while (<FILE>) {
		(print MAILER) unless defined $marks;
		(print MAILER $marks, $_) if defined $marks;
	}
	close FILE;
	print MAILER "   --- End of file ($description) ---\n"
		unless defined $marks;
	0;		# Success
}

# Signals end of processing
sub cmdserv'load_finish {
	package cmdserv;
	local($why) = @_;
	print MAILER "End of processing ($why)\n";
	&'add_log("END ($why)") if $'loglvl > 6;
}

# Check whether user has root powers or not.
sub cmdserv'load_root {
	package cmdserv;
	&cmdenv'haspower('root');
}

# Allow server to run in trusted mode (where powers may be gained).
sub cmdserv'load_trusted {
	package cmdserv;
	if ($cmdenv'auth) {			# Valid envelope in mail header
		$cmdenv'trusted = 1;	# Allowed to gain powers
	} else {
		&'add_log("WARNING unable to switch into trusted mode")
			if $'loglvl > 5;
	}
}

# Disable a list of commands, and only those commands.
sub cmdserv'load_disable {
	package cmdserv;
	local($cmds) = @_;		# List of disabled commands
	undef %Disabled;		# Reset disabled commands, start with fresh set
	foreach $cmd (split(/[\s,]+/, $cmds)) {
		$Disabled{$cmd}++;
	}
	$cmdenv'disabled = join(',', sort keys %Disabled);	# No duplicates
}

# Get shell to run our commands
sub cmdserv'load_servshell {
	package cmdserv;
	local($shell) = defined($cf'servshell) ? $cf'servshell : 'sh';
	$shell = &'locate_program($shell);
	if (defined($cf'servshell) && !-x($shell)) {
		&'add_log("WARNING invalid configured servshell $shell, using sh")
			if $'loglvl > 2;
		$shell = 'sh';
	}
	$shell;
}

# Set user identification (e-mail address) within cmdenv package
sub cmdenv'load_inituid {
	package cmdenv;
	# Convenience variables are part of the basic environment for all the
	# server commands. This includes the $envelope variable, which is the
	# user who has issued the request (real uid).
	&hook'initvar('cmdenv');
	$auth = 1;				# Assume valid envelope
	$uid = (&'parse_address($envelope))[0];
	if ($uid eq '') {		# No valid envelope
		&'add_log("NOTICE no valid mail envelope") if $'loglvl > 6;
		$uid = (&'parse_address($sender))[0];
		$auth = 0;			# Will not be able to run in trusted mode
	}
	$user = $uid;			# Until further notice, euid = ruid
	$path = $uid;			# And files are sent to the one who requested them
	undef %powers;			# Reset power table
	$powers = '';			# The linear version of powers
	$errors = 0;			# Number of failed requests so far
	$requests = 0;			# Total number of requests processed so far
	$eof = 'EOF';			# End of file indicator in collection mode
	$collect = 0;			# Not in collection mode
	$trace = 0;				# Not in trace mode
	$trusted = 0;			# Not in trusted mode
}

# Set command parameters
sub cmdenv'load_set_cmd {
	package cmdenv;
	($cmd) = @_;
	($name) = $cmd =~ /^([\w-]+)/;	# Get command name
	$name =~ tr/A-Z/a-z/;			# Cannonicalize to lower case

	# Passwords in commands may need to be concealed
	if (defined $cmdserv'Conceal{$name}) {
		local(@argv) = split(' ', $cmd);
		local(@pos) = split(/,/, $cmdserv'Conceal{$name});
		foreach $pos (@pos) {
			$argv[$pos] = '********' if defined $argv[$pos];
		}
		$log = join(' ', @argv);
	} else {
		$log = $cmd;
	}
}

# Add a new power to the list once the user has been authenticated.
sub cmdenv'load_addpower {
	package cmdenv;
	local($newpower) = @_;
	$powers{$newpower}++;
	$powers = join(':', keys %powers);
}

# Remove power from the list.
sub cmdenv'load_rempower {
	package cmdenv;
	local($oldpower) = @_;
	delete $powers{$oldpower};
	$powers = join(':', keys %powers);
}

# Wipe out all the powers
sub cmdenv'load_wipe_powers {
	package cmdenv;
	undef %powers;
	$powers = '';
}

# Check whether user has a given power... Note that 'root' has all powers
# but 'security'.
sub cmdenv'load_haspower {
	package cmdenv;
	local($wanted) = @_;
	$wanted eq 'security' ?
		defined($powers{$wanted}) :
		(defined($powers{'root'}) || defined($powers{$wanted}));
}

# Grant power to user, returning 1 if ok, 0 if failed.
sub power'load_grant {
	package power;
	local($name, $clear_passwd, $user) = @_;
	unless (&'file_secure($cf'passwd, 'password')) {
		&add_log("WARNING cannot grant power '$name'") if $'loglvl > 5;
		return 0;		# Failed
	}
	unless (&valid($name, $clear_passwd)) {
		&add_log("ERROR user '$user' gave invalid password for power '$name'")
			if $'loglvl > 1;
		return 0;		# Power not granted
	}
	unless (&authorized($name, $user)) {
		&add_log("ERROR user '$user' may not request power '$name'")
			if $'loglvl > 1;
		return 0;		# Power not granted
	}
	1;			# Power may be granted
}

# Check whether user is authorized to get this power or change its password.
# Returns 1 if user may proceed, 0 otherwise.
sub power'load_authorized {
	package power;
	local($name, $user) = @_;
	local($auth) = &authfile($name);
	unless (&'file_secure($auth, 'authentication')) {
		&add_log("WARNING cannot authenticate power '$name'") if $'loglvl > 5;
		return 0;		# Failed
	}
	unless (open(AUTH, $auth)) {
		&add_log("ERROR cannot open auth file $auth for power '$name': $!")
			if $'loglvl > 1;
		return 0;		# Cannot verify identity -> cannot grant power
	}
	local($_);
	local($ok) = 0;
	study $user;				# Various searches will be attempted
	while (<AUTH>) {
		chop;
		$_ = &'perl_pattern($_);	# Shell style patterns may be used
		if ($user =~ /^$_$/) {		# User may request for this power
			$ok = 1;				# Ok, we found him
			last;
		}
	}
	close(AUTH);
	$ok;			# Boolean status
}

# Check whether a power password is valid or not. Returns 0 if password is
# invalid or the power is undefined, 1 when password is ok.
sub power'load_valid {
	package power;
	local($name, $clear_passwd) = @_;
	unless (&'file_secure($cf'passwd, 'password')) {
		&add_log("WARNING cannot verify password for power '$name'")
			if $'loglvl > 5;
		return 0;		# Failed
	}
	local($power, $passwd, $comment) = &getpwent($name);
	return 0 unless defined $power;			# Unknown power -> illegal password
	if ($passwd =~ s/^<(.*)>$/$1/) {		# Password given as <clear>
		$clear_passwd eq $passwd;
	} else {								# Password encrypted
		crypt($clear_passwd, $passwd) eq $passwd;
	}
}

# Compute file name where list of authorized users is kept.
sub power'load_authfile {
	package power;
	local($name) = @_;
	return $cf'powerdir . "/$name" if length($name) <= 12;
	unless (open(ALIASES, $cf'powerlist)) {
		&add_log("ERROR cannot open power list $cf'powerlist: $!")
			if $'loglvl > 1;
		return '/dev/null';
	}
	local($_);
	local($power, $alias);
	while (<ALIASES>) {
		($power, $alias) = split(' ');
		if ($power eq $name) {
			close ALIASES;
			return $cf'powerdir . "/$alias"
		}
	}
	close ALIASES;
	return '/dev/null';
}

# Set clearance file, returning 1 for success, 0 for failure
sub power'load_set_auth {
	package power;
	local($name, *text) = @_;
	local($file) = &authfile($name);
	if (-e $file) {
		unless (unlink $file) {
			&add_log("SYSERR unlink: $!") if $'loglvl;
			&add_log("WARNING appending to $file (should have replaced it)")
				if $'loglvl > 5;
		}
	}
	local($ok) =
		&'file_edit($file, 'power clearance', undef, join("\n", @text));
	$ok;
}

# Append users to clearance file, returning 1 on success and 0 on failure
sub power'load_add_auth {
	package power;
	local($name, *text) = @_;
	local($file) = &authfile($name);
	local($ok) =
		&'file_edit($file, 'power clearance', undef, join("\n", @text));
	$ok;
}

# Remove users from clearance file, returning 1 on success and 0 on failure
sub power'load_rem_auth {
	package power;
	local($name, *text) = @_;
	local($file) = &authfile($name);
	local(@pairs);	# Search/replace pairs for file_edit
	foreach $addr (@text) {
		push(@pairs, $addr, undef);
	}
	local($ok) = &'file_edit($file, 'power clearance', @pairs);
	$ok;
}

# Is alias already used?
sub power'load_used_alias {
	package power;
	local($alias) = @_;
	open(ALIAS, $cf'powerlist) || return 0;
	local($_);
	local($pow, $ali);
	local($found) = 0;
	while (<ALIAS>) {
		($pow, $ali) = split(' ');
		$found = 1 if $ali eq $alias;
		last if $found;
	}
	close ALIAS;
	$found;		# Return true when alias already used
}

# Add new power alias, returning 1 for ok and 0 for failure.
sub power'load_add_alias {
	package power;
	local($power, $alias) = @_;
	local($ok) =
		&'file_edit($cf'powerlist, 'power aliases', undef, "$power $alias");
	&add_log("aliased power '$power' into '$alias'") if $'loglvl > 6 && $ok;
	$ok;
}

# Delete power from alias file, returning 1 for ok and 0 for failure.
sub power'load_del_alias {
	package power;
	local($power) = @_;
	local($ok) =
		&'file_edit($cf'powerlist, 'power aliases', "/^$power\\s/", undef);
	&add_log("ERROR cannot delete power '$power' from aliases")
		if $'loglvl > 1 && !$ok;
	&add_log("deleted power '$power' from aliases")
		if $'loglvl > 6 && $ok;
	$ok;
}

# Set power password, returning 0 if ok, -1 for failure
sub power'load_set_passwd {
	package power;
	local($name, $clear_newpasswd) = @_;

	# Make sure entry already exists (i.e. power is defined)
	local($power, $passwd, $comment) = &getpwent($name);
	return -1 unless defined $power;		# Unknown power

	# Choose a salt randomly, using the two lowest bytes of current time stamp
	local($t) = time;
	local($c1, $c2) = ($t, $t & 0xffff);
	$c1 -= ($t & 0xff) * ($c2 + (($t & 0xffff0000) >> 16));
	$c1 = $c1 > 0 ? $c1 : -$c1;
	local(@saltset) = ('a' .. 'z', 'A' .. 'Z', '0' .. '9', '.', '/');
	local($salt) = $saltset[$c1 % @saltset] . $saltset[$c2 % @saltset];
	$passwd = crypt($clear_newpasswd, $salt);

	# Set new password entry
	&setpwent($power, $passwd, $comment);	# Propagate status
}

# Get password entry, and return ($power, $password, $comment) if found or
# undef if error or not found.
sub power'load_getpwent {
	package power;
	local($wanted) = @_;		# Power entry wanted
	unless (open(PASSWD, "$cf'passwd")) {
		&add_log("ERROR cannot open password file: $!") if $'loglvl;
		return undef;
	}
	local($power, $password, $comment);
	local($_);
	while (<PASSWD>) {
		chop;
		($power, $password, $comment) = split(/:/);
		if ($power eq $wanted) {
			close PASSWD;
			return ($power, $password, $comment);
		}
	}
	close PASSWD;
	undef;			# Not found
}

# Set password entry, given ($power, $password, $comment) and return 0 for
# success, -1 on failure.
sub power'load_setpwent {
	package power;
	local($power, $password, $comment) = @_;
	local($ok) = &'file_edit(
		$cf'passwd, 'password',
		"?^$power:?", "$power:$password:$comment"
	);
	&add_log("ERROR cannot set new password entry for '$power'")
		if $'loglvl > 1 && !$ok;
	$ok ? 0 : -1;
}

# Remove passoword entry, returning 0 for success and -1 on failure.
sub power'load_rempwent {
	package power;
	local($power) = @_;
	local($ok) = &'file_edit(
		$cf'passwd, 'password',
		"/^$power:/", undef
	);
	&add_log("ERROR cannot remove password entry for '$power'")
		if $'loglvl > 1 && !$ok;
	$ok ? 0 : -1;
}

# Replaces main'add_log by remapping to powerlog...
# Opens new user-defined logfile 'powerlog' to extract power-related
# messages there. If not defined in ~/.mailagent, messages will go to the
# default log file. A copy of the log message is kept there anyway.
sub power'load_add_log {
	package power;
	local($msg) = @_;
	&usrlog'new('powerlog', $cf'powerlog, 'COPY') if $cf'powerlog;
	&'usr_log('powerlog', $msg);
}

# Inplace file edition, with one letter backup file. The routine returns a
# success status, i.e. 1 if ok and 0 if anything went wrong.
sub main'load_file_edit {
	package main;
	local($name, $desc, @pairs) = @_;
	local(@backup) = ('~', '#', '@', '%', '=');
	local($bak);		# File used for backup
	local(*OLD, *NEW);	# Localize filehandles
	local($error) = 0;	# Error flag

	return 1 unless @pairs;		# Nothing to do

	if (-d $name) {
		&add_log("ERROR cannot edit a directory!! ($name)") if $loglvl;
		return 0;		# Failed
	}

	# First, lock file to prevent concurrent access
	if (0 != &acs_rqst($name)) {
		&add_log("WARNING cannot lock $desc file $name") if $loglvl > 5;
	}

	# If no search pattern are provided at all, then we only need to do some
	# appending, and therefore need only the NEW file.
	local($i);
	local($need_editing) = 0;
	for ($i = 0; $i < @pairs; $i += 2) {			# Scan only search items
		$need_editing = 1 if defined $pairs[$i];	# Search pattern defined?
		last if $need_editing;
	}

	# Now try to find a suitable backup character, which is only needed when
	# we really need to search something for replacing. If we only append to
	# the file, no backup is necessary.
	if ($need_editing) {				# Not trying to append
		foreach $c (@backup) {			# Loop for suitable backup char
			unless (-e "$name$c") {		# No such file?
				$bak = "$name$c";		# Ok, grab this extension
				last;
			}
		}
		unless ($bak) {					# Nothing found?
			&add_log("ERROR cannot create backup for $desc file $name")
				if $loglvl;
			&free_file($name);			# Release lock
			return 0;					# Error
		}
	}

	# Open the necessary files, only NEW for appending, or OLD and NEW for
	# editing (when a search pattern is provided).
	if ($need_editing) {			# Not trying to append -> needs backup
		unless (open(OLD, $name)) {
			&add_log("ERROR cannot open $desc file $name: $!") if $loglvl;
			&free_file($name);		# Release lock
			return 0;				# Error
		}
		unless (open(NEW, ">$bak")) {
			&add_log("ERROR cannot create backup for $desc file as $bak: $!")
				if $loglvl;
			close OLD;				# We won't need it anymore
			&free_file($name);		# Release lock
			return 0;				# Error
		}
	} else {						# Merely trying to append to the old file
		unless (open(NEW, ">>$name")) {
			&add_log("ERROR cannot append to $desc file $name: $!")
				if $loglvl;
			&free_file($name);		# Release lock
			return 0;				# Error
		}
		for ($i = 1; $i < @pairs; $i += 2) {		# Scan only replace items
			next unless defined $pairs[$i];
			unless (print NEW $pairs[$i], "\n") {
				&add_log("SYSERR write: $!") if $loglvl;
				$error++;
			}
			last if $error;			# Abort immediately if error
		}
		unless (close NEW) {
			&add_log("SYSERR close: $!") if $loglvl;
			$error++;
		}
		&free_file($name);			# Release lock
		if ($error) {
			&add_log("WARNING $desc file $name may be corrupted")
				if $loglvl > 5;
		}
		return $error ? 0 : 1;		# Return success (1) if file not corrupted
	}

	local(@search);			# Searching patterns
	local(@replace);		# Replacing strings
	local(@insert);			# Insertion flag for ?? patterns
	local(@type);			# Type of searching pattern

	# Build the search and replacing arrays, a search/replace pair being
	# identified by entries at the same index
	for ($i = 0; $i < @pairs; $i++) {
		push(@search, $pairs[$i++]);
		push(@replace, $pairs[$i]);
	}

	# Here, we must go through the line by line scanning of the OLD file until
	# a match occurs, at which time the replacing string is written (or the
	# record skipped when the replacing string is not defined). The search
	# string can be a verbatim string, a pattern, a numeric value understood as
	# a line number or a function to call, giving the line as parameter, along
	# with the current line number and understanding a true value as a match.
	# If the search pattern is introduced by '?' instead of '/', then the
	# replacement value is inserted at the end if no match occurred.

	local($NUMBER, $STRING, $PATTERN, $SUB) = (0 .. 3);
	local($_);

	# Build type array and set up entries in @insert when ?? patterns are used
	foreach (@search) {
		unless (defined $_) {		# No search pattern means appending
			push(@type, undef);
			next;
		}
		if (/^\d+$/) {				# Plain value is a line number
			push(@type, $NUMBER);
			$_ = int($_);
		} elsif (m|^([/?])|) {		# Looks like a pattern
			push(@type, $PATTERN);
			$insert[$#type] = 1 if $1 eq '?';
			s|^[/?](.*)[/?]$|$1|;
		} elsif (m|^&|) {		# Function to apply
			push(@type, $SUB);
			s/^&//;
		} else {							# Must be a verbatim string then
			push(@type, $STRING);
		}
	}
	local($.);
	local($found);
	local($val);		# Searching value
	local($type);		# Current searching type
	local($replace);	# Replacing value
	local($studied);	# Was line studied?

	# Now loop over the OLD file and write into NEW
	while (<OLD>) {
		chop;
		$studied = @type < 3 ? 1 : 0;		# Do not study if small amount
		$found = 0;
		for ($i = 0; $i < @type; $i++) {
			$type = $type[$i];
			next unless defined $type;		# Already dealt with or no search
			$val = $search[$i];				# Searching value
			if ($type == $NUMBER && $. == $val) {
				$type[$i] = undef;			# Avoid further inspection
				$found++;
			} elsif ($type == $STRING && $_ eq $val) {
				$found++;
			} elsif ($type == $PATTERN) {
				study unless $studied++;	# Optimize pattern matching
				($found++, $insert[$i] = 0) if /$val/;
			} elsif ($type == $SUB && &$val($_, $.)) {
				$found++;
			}
			last if $found;
		}
		if ($found) {
			$replace = $replace[$i];
			if (defined $replace) {
				(print NEW $replace, "\n") || $error++;
			}
		} else {
			(print NEW $_, "\n") || $error++;
		}
		if ($error) {
			&add_log("SYSERR write: $!") if $loglvl;
			last;
		}
	}

	# If insertion was wanted on no-match, and no error has ever occurred, then
	# do the necessary insertions now. Also add all those replacing values
	# associated with an undefined search string.

	unless ($error) {
		for ($i = 0; $i < @type; $i++) {
			next unless $insert[$i] || !defined($type[$i]);
			next unless defined $replace[$i];
			(print NEW $replace[$i], "\n") || $error++;
		}
		&add_log("SYSERR write: $!") if $error && $loglvl;
	}

	# Edition is completed. Close files and make sure NEW is correctly flushed
	# to disk by checking the return value from close.

	close OLD;
	unless (close NEW) {
		&add_log("SYSERR close: $!") if $loglvl;
		$error++;
	}

	# If no error has occurred so far, rename backup file as the original file
	# name, in effect putting an end to the editing phase.

	if ($error == 0 && !rename($bak, $name)) {
		&add_log("SYSERR rename: $!") if $loglvl;
		$error++;
	}
	&free_file($name);			# Lock may now safely be released

	if ($error) {
		&add_log("ERROR cannot inplace edit $desc file $name") if $loglvl;
		unless (unlink $bak) {
			&add_log("SYSERR unlink: $!") if $loglvl;
			&add_log("ERROR cannot remove temporary file $bak") if $loglvl;
		}
		return 0;				# Editing failed
	}

	&add_log("edited $desc file $name") if $loglvl > 18;

	1;		# Success
}

# Load function within a package and returns undef if the package cannot be
# loaded, 0 if the file was loaded but contained some syntax error and 1 if
# loading was successful. If the function parameter is also specified, then
# the file is supposed to define that function, so we make sure it is so.
sub dynload'load_load {
	package dynload;
	local($package, $file, $function) = @_;
	local($key) = "$package:$file";
	unless ($Loaded{$key}) {					# No reading attempt made yet
		local($res) = &parse($package, $file);	# Load and parse file
		$Loaded{$key} = 0;						# Mark loading attempt
		unless (defined($res) && $res) {		# Error
			return defined($res) ? $res : undef;
		}
	}

	if (defined $function) {	# File supposed to have defined a function
		# Make sure the function is defined by eval'ing a small script in the
		# context of the package where the file was loaded. Indeed, the package
		# name is implicit and defaults to that loading package.
		local($defined);
		eval("package $package; \$dynload'defined = 1 if defined &$function");
		unless ($defined) {
			&'add_log("ERROR script $file did not provide &$function")
				if $'loglvl;
			return 0;			# Definition failed
		}
	}

	$Loaded{$key} = 1;			# Mark and propagate success
}

# Load file into memory and parse it. Returns undef if file cannot be loaded,
# 0 on parsing error and 1 if ok.
sub dynload'load_parse {
	package dynload;
	local($package, $file) = @_;
	unless (open(PERL, $file)) {
		&'add_log("SYSERR open: $!") if $'loglvl;
		&'add_log("ERROR cannot load $file into $package") if $'loglvl;
		return undef;		# Cannot load file
	}
	local($body) = ' ' x (-s PERL);		# Pre-extend variable
	{
		local($/) = undef;				# Slurp the whole thing
		$body = <PERL>;					# Load into memory
	}
	close PERL;
	local(@saved) = @INC;				# Save perl INC path (might change)
	unshift(@INC, $'privlib);			# Required files first searched there
	eval "package $package;" . $body;	# Eval code into memory
	@INC = @saved;						# Restore original require search path
	$Loaded{$key} = 0;					# Be conservative and assume error...

	if (chop($@)) {				# Script has an error
		&'add_log("ERROR in $file: $@") if $'loglvl;
		$@ = '';				# Clear error
		return 0;				# Eval failed
	}
	1;		# Ok so far
}

# Inspect their request closely, trying to guess what they really want. The
# general pattern they can give us is:
#     something:routine
# where something may be a command name or a path name, or may be missing
# entirely up to the ':' separator, and routine is a qualified or unqualified
# routine name, using the single quote as package separator, and not :: as in
# perl5 or C++ -- I loathe that token, maybe because I loathe C++ so much?
# Returns success condition, or undef if file cannot be loaded (missing?).
sub dynload'load_do {
	package dynload;
	local($routine) = @_;
	$routine =~ s/::/'/;	# Despite what leading comment says, be perl5 aware
	local($something);
	$routine =~ s/^([^:]*):// && ($something = $1);
	$routine = "main'$routine" unless $routine =~ /'/;
	return 1 if $something eq '' && defined &$routine;	# Already there
	return 0 if $something eq '';		# Not there, no clue how to get it

	# Ok, at that point we know the routine is not there, but by looking
	# at $something, we might be able to find out where that routine might
	# be found... First check whether it is the name of a user-defined command
	# in which case we load that file and get the command. Otherwise, the
	# remaining is taken as a path where the routine may be found.

	local($cmd) = $something;
	local($path);
	$cmd =~ tr/a-z/A-Z/;				# Cannonicalize to upper case
	if (defined $newcmd'Usercmd{$cmd}) {
		$path = $newcmd'Usercmd{$cmd};	# Get command's path
	} else {
		$path = $something;				# Must be a path then
		$path =~ s/~/$cf'home/;			# ~ substitution
	}

	local($package);
	($package, $routine) = $routine =~ m|(.*)'(.*)|;

	return &load($package, $path, $routine);
}

# Create a new symbol name each time it is invoked. That name is suitable for
# usage as a perl variable name.
sub main'load_gensym {
	package main;
	$Gensym = 'AAAAA' unless $Gensym;
	$Gensym++;
}

# Defines known macro types. Each type is associated with a function which will
# be called to deal with the macro substitution for that type and returning the
# proper value. The arguments passed to it are the glob to the gensym array and
# the macro name, in case we have to deal with an FN-type value. The value for
# the macro is at index 0 in the gensym array.
sub usrmac'load_init {
	package usrmac;
	%Type = (
		'SCALAR',	'sub_scalar',		# Scalar value
		'EXPR',		'sub_expr',			# Expression to be eval'ed each time
		'CONST',	'sub_const',		# Constant eval'ed only once
		'FN',		'sub_fn',			# Perl function to be called
		'PROG',		'sub_prog',			# A program to call
		'PROGC',	'sub_progc',		# Program to call once, result cached
	);
}

# Add a new macro in the table. If one already existed, the new value is pushed
# before the old one and will be used in subsequent substitutions.
sub usrmac'load_push {
	package usrmac;
	local($name, $value, $type) = @_;	# Name, value and type
	local($gensym);						# Generated array name storing values
	&init unless $init_done++;
	$gensym = defined $Name{$name} ? $Name{$name} : &'gensym;
	$Name{$name} = $gensym;				# Make a nested data structure
	eval "unshift(\@$gensym, \$value, \$Type{\$type})";
	&'add_log("ERROR usrmac'push: $@") if $@;
}

# Create a brand new macro or replace the one currently visible.
sub usrmac'load_new {
	package usrmac;
	local($name, $value, $type) = @_;	# Name, value and type
	local($gensym);						# Generated array name storing values
	&init unless $init_done++;
	$gensym = defined $Name{$name} ? $Name{$name} : &'gensym;
	$Name{$name} = $gensym;				# Make a nested data structure
	eval "\@$gensym\[0, 1\] = (\$value, \$Type{\$type})";
	&'add_log("ERROR usrmac'new: $@") if $@;
}

# Remove topmost macro definition
sub usrmac'load_pop {
	package usrmac;
	local($name) = @_;					# Macro to undefine at this level
	return unless defined $Name{$name};	# Nothing here it would seem
	local($gensym) = $Name{$name};		# Array storing macro definition
	eval "shift(\@$gensym); shift(\@$gensym)";
	&'add_log("ERROR usrmac'pop: $@") if $@;
}

# Delete the whole (possibly stacked) macro entries under a given name.
sub usrmac'load_delete {
	package usrmac;
	local($name) = @_;
	return unless defined $Name{$name};	# Ooops... Has already been done
	local($gensym) = $Name{$name};		# Array storing macro definition
	eval "undef \@$gensym";				# Delete the value array
	&'add_log("ERROR usrmac'delete: $@") if $@;
	delete $Name{$name};				# As well as the entry in name table
}

# Save the valid macro names we currently have. Returns an array of names.
sub usrmac'load_save {
	package usrmac;
	keys %Name;		# List of currently defined macros
}

# Restore the name space we had at the time the save was made, deleting all the
# macro names which are now defined and were not present at that time. Note
# that stacked macro definitions are deleted in one block.
sub usrmac'load_restore {
	package usrmac;
	local(@names) = @_;			# Names we had at that time
	local(%saved);				# Tell us whether a name was saved or not
	foreach $key (@names) {		# Build a hash table of names for faster access
		$saved{$key}++;
	}
	foreach $key (keys %Name) {	# Delete all macros not defined at save time
		&delete($key) unless $saved{$key};
	}
}

# Perform the user-defined macro substitution and return the value string.
# (called from macros_subst in macros.pl).
sub macro'load_usr {
	package usrmac;
	local($name) = @_;		# Macro name
	return '' unless defined $Name{$name};	# Unknown macro
	local($gensym) = $Name{$name};			# Get value array
	return '' unless $gensym;				# Key present, but nothing there
	local($glob) = eval "*$gensym";			# Type glob to value array
	local(*array) = $glob;					# From now on, @array is set
	local($function) = $array[1];			# How to deal with that macro type
	$function = $Type{'SCALAR'} unless $function;
	&$function($glob, $name);				# Propagate return value
}

# Substitute a scalar value, simply return the verbatim value we got.
sub usrmac'load_sub_scalar {
	package usrmac;
	local(*ary, $name) = @_;
	$ary[0];
}

# Evaluate a perl expression and return the scalar result
sub usrmac'load_sub_expr {
	package usrmac;
	local(*ary, $name) = @_;
	eval $ary[0];
}

# Evaluate a perl expression and cache the result as a scalar value
sub usrmac'load_sub_const {
	package usrmac;
	local(*ary, $name) = @_;
	local($result) = eval $ary[0];
	&cache(*ary, $result);			# Cache and propagate result
}

# Call a perl function to evaluate the macro. Function should be a fully
# qualified name, with package info, unless it is explicitely defined in
# the usrmac package.
sub usrmac'load_sub_fn {
	package usrmac;
	local(*ary, $name) = @_;
	eval "&$ary[0](\$name)";
}

# Call an external program, grab its output and remove final character. Then
# return that as a result of the substitution. That program should execute
# quickly. Use a PROGC type to cache the result if the value returned does not
# change. In the argument list, %n is taken as the macro name.
sub usrmac'load_sub_prog {
	package usrmac;
	local(*ary, $name) = @_;
	local($prog) = $ary[0];
	$prog =~ s/%%/#%#/g;			# Escape %
	$prog =~ s/%n/$name/g;			# Replace %n by macro name
	$prog =~ s/#%#/%/g;				# %% turns out as a single %
	local($result);					# To store program output
	chop($result = `$prog 2>&1`);	# Invoke program, merge stdout and stderr
	$result;						# Return output
}

# Same a sub_prog but cache the result as a scalar value to avoid other calls
# to that same program.
sub usrmac'load_sub_progc {
	package usrmac;
	local(*ary, $name) = @_;
	local($result) = &sub_prog(*ary, $name);
	&cache(*ary, $result);			# Cache and propagate result
}

# Cache computed value by making it a SCALAR-type macro value so that further
# calls to evaluate that macro will simply return that cached information.
# The result value passed as argument is returned unchanged.
sub usrmac'load_cache {
	package usrmac;
	local(*ary, $result) = @_;
	$ary[0] = $result;				# Cache result for further invocations
	$ary[1] = $Type{'SCALAR'};		# Make value a simple scalar
	$result;						# Return computed value
}

# Perform ~name expansion ala ksh...
# (banish csh from your vocabulary ;-)
sub main'load_tilda_expand {
	package main;
	local($path) = @_;
	return $path unless $path =~ /^~/;
	$path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e;			# ~name
	$path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e;	# ~
	$path;
}

# Attempt to save in a MH directory folder. Note that the profile entry
# Msg-Protect is honored, unless overridden by a PROTECT command.
sub mh'load_save {
	package mh;
	local($folder) = @_;		# MH folder name (without leading '+')
	&profile;					# Get MH profile, once and for all
	local($fmode);				# File protection mode
	$folder = "$cf'home/$Profile{'path'}/$folder";
	local($mode) = oct("0$Profile{'folder-protect'}" || '0700');
	$fmode = oct("0$Profile{'msg-protect'}") if defined $Profile{'msg-protect'};
	$fmode = $env'protect if defined $env'protect;
	&'makedir($folder, $mode);	# Create folder dir with right permissions
	&save_msg($folder, $fmode, 'MH');	# Propagate failure status
}

# Save in a directory, not really an MH folder.
# Message protection is adjusted if a PROTECT was issued.
sub mh'load_savedir {
	package mh;
	local($folder) = @_;		# Directory folder name
	local($fmode);				# File protection mode
	$fmode = $env'protect if defined $env'protect;
	&save_msg($folder, $fmode, 'DIR');	# Propagate failure status
}

# Common subroutine to &save and &savedir
sub mh'load_save_msg {
	package mh;
	local($folder, $fmode, $mh) = @_;
	unless (-d $folder) {
		&'add_log("ERROR $mh folder $folder is not a directory")
			if $'loglvl > 1;
		return 1;	# Failed
	}
	local($name) = &new_msg($folder);
	unless ($name) {
		&'add_log("ERROR cannot get message number in $mh folder $folder")
			if $'loglvl > 1;
		return 1;	# Failed
	}

	# Now initiate saving by opening file for appending, then calling the
	# MMDF-style saving routine with MH type (skips emission of ^A lines).

	unless (open(MHMSG, ">>$name")) {
		&'add_log("ERROR cannot reopen $name: $!") if $'loglvl > 1;
		return 1;	# Failed, don't unlink message
	}

	# There is no need to lock the file here, since MH will never select an
	# existing file when computing a new message number.

	local($failed, $amount) = &mmdf'save_mmdf(*MHMSG, 'MH');

	# Now the size of the message must be *exactly* the amount returned.
	close MHMSG;
	local($size) = -s $name;

	&'add_log("ERROR $name has $size bytes (should have $amount)")
		if $size != $amount && $'loglvl;

	$failed = 1 if $size != $amount;
	&mmdf'chmod($fmode, $name) if defined $fmode;	# Ignore chmod errors

	# Update the unseen sequence, if needed and saving succeeded. An entry
	# is also made in the logfile for easy grep'ing and locating of messages
	# saved in directories.

	&unseen($name)
		if $mh eq 'MH' && $Profile{'unseen-sequence'} ne '' && !$failed;

	# Mark as unseen in log when saved within a directory
	&'add_log("UNSEEN " . &'tilda($name)) if $'loglvl > 6;

	$'folder_saved = $name;		# Keep track of last folder we save into
	return $failed;				# Return failure status
}

# Read MH profile, fill in %Profile entries.
sub mh'load_profile {
	package mh;
	return if %Profile;
	# Make sure there is at least a valid Path entry, in case they made a
	# mistake and asked for MH folder saving without a valid .mh_profile...
	local($dflt) = defined($'XENV{'maildir'}) ? $'XENV{'maildir'} : 'Mail';
	$dflt = &'tilda($dflt);		# Restore possible leading '~'
	$dflt =~ s|^~/||;			# Strip down (relative path under ~)
	$Profile{'path'} = $dflt;
	local($mhprofile) = &'tilda_expand($cf'mhprofile || '~/.mh_profile');
	unless (open(PROFILE, $mhprofile)) {
		&'add_log("ERROR cannot open MH profile '$mhprofile': $!")
			if $'loglvl > 1;
		return;
	}
	local($_);
	while (<PROFILE>) {
		next unless /^([^:]+):\s*(.*)/;
		$Profile{"\L$1"} = $2;
	}
	close PROFILE;
}

# Compute new message number/name.
# If true MH folder, get next available number. If directory, see if there is
# a .msg_prefix file to use as a basename. Otherwise, select an MH message
# number.
sub mh'load_new_msg {
	package mh;
	local($dir) = @_;
	unless (opendir(DIR, $dir)) {
		&'add_log("ERROR unable to open dir $dir: $!") if $'loglvl > 1;
		return 0;		# Marks failure
	}
	if (0 != &'acs_rqst($dir)) {
		&'add_log("WARNING could not lock dir $dir") if $'loglvl > 5;
	}
	local(@dir) = readdir DIR;		# Slurp it as a whole
	closedir DIR;

	# See if we have to use message prefix
	local($prefix) = $cf'msgprefix || '.msg_prefix';
	local($msg) = "$dir/$prefix";
	local($msg_prefix) = '';
	if (-f $msg) {					# Not an MH folder it would seem
		unless (open(PREFIX, $msg)) {
			&'add_log("ERROR can't open msg prefix $msg: $!") if $'loglvl > 1;
			# Continue, will use MH-style numbering then
		} else {
			chop($msg_prefix = <PREFIX>);	# First line gives prefix
			close PREFIX;
		}
	}

	# If prefix is used, keep only those messages starting with that prefix.
	# Otherwise, keep only numbers.
	local($pat) = $msg_prefix eq '' ? '/^\d+$/' : "s/^$msg_prefix(\\d+)\$/\$1/";
	eval '@dir = grep(' . $pat . ', @dir)';

	# Now sort in ascending order and get highest number
	@dir = sort { $a <=> $b; } @dir;
	local($highest) = pop(@dir) || 0;		# Ensure numeric default value

	# Now create new message before unlocking the directory. Use appending
	# instead of plain creation in case our lock was not honoured for some
	# reason.
	$highest++;
	local($new) = "$dir/$msg_prefix$highest";
	unless (open(NEW, ">>$new")) {
		&'add_log("ERROR cannot create $new: $!") if $'loglvl > 1;
		$new = 0;	# Signal no creation (directory still locked)
	} else {
		close NEW;	# File is now created
	}

	&'free_file($dir);		# Unlock directory
	return $new;			# Return message name, or 0 if error
}

# Mark MH message as unseen by adding it to the sequences listed in the
# profile entry Unseen-Sequence.
sub mh'load_unseen {
	package mh;
	local($name) = @_;		# Full path of unseen mail message
	local($dir, $num) = $name =~ m|(.*)/(\d+)|;
	unless ($num) {
		&'add_log("WARNING cannot mark $name as unseen (not an MH message)")
			if $'loglvl > 5;
		return;
	}

	# Lock the .mh_sequences file first. It's a pity MH does not itself lock
	# this file when syncing it... (routine m_sync() in MH 6.8).

	local($seqfile) = "$dir/.mh_sequences";
	if (0 != &'acs_rqst($seqfile)) {
		&'add_log("WARNING could not lock MH sequence in $dir")
			if $'loglvl > 5;
	}

	# Create new .mh_sequences file
	local($seqnew) = $'long_filenames ? "$seqfile.x" : "${seqfile}X";
	unless (open(MHSEQ, ">$seqnew")) {
		&'add_log("ERROR cannot create new MH sequence file in $dir: $!")
			if $'loglvl > 1;
		&'free_file($seqfile);
		return;
	}

	open(OLDSEQ, $seqfile);	# May not exist yet, so no error check

	# Get the name of the sequences we need to update, save in %seq.
	local(%seq);
	foreach $seq (split(/,/, $Profile{'unseen-sequence'})) {
		$seq =~ s/^\s*//;	# Remove leading and trailing spaces
		$seq =~ s/\s*$//;
		$seq{$seq}++;		# Record unseen sequence
	}

	# Now loop over the existing sequences in the old .mh_sequences file
	# and update them. If some unseen sequences were not present yet, create
	# them.

	local($_);
	local($seqname);

	while (<OLDSEQ>) {
		if (s/^(\S+)://) {	# Found a sequence
			$seqname = $1;
			unless (defined $seq{$seqname}) {
				print MHSEQ "$seqname:", $_;
				next;
			}
			# Ok, it's an useen sequence and we need to update it
			chop;
			print MHSEQ "$seqname: ", &seqadd($_, $num), "\n";
			delete $seq{$seqname};
		} else {
			print MHSEQ $_;	# Whatever it was, propagate it
		}
	}
	close OLDSEQ;

	foreach $seq (keys %seq) {	# Create remaining sequences
		print MHSEQ "$seq: $num\n";
	}
	close MHSEQ;

	unless (rename($seqnew, $seqfile)) {
		&'add_log("ERROR cannot rename $seqnew as $seqfile: $!")
			if $'loglvl > 1;
	}

	&'free_file($seqfile);
}

# Add a message to an MH sequence (sorted on input).
sub mh'load_seqadd {
	package mh;
	local($seq, $num) = @_;
	local(@seq) = split(' ', $seq);
	local($min, $max);	# Ranges in sequences are min-max
	local($i);
	local(@new);		# New sequence we are building
	local($item);		# Current item
	for ($i = 0; $i < @seq; $i++) {
		$item = $seq[$i];
		if ($num == 0) {	# Message already inserted
			push(@new, $item);
			next;			# Flush sequence
		}
		if ($item =~ /-/) {
			($min, $max) = $item =~ /(\d+)-(\d+)/;
		} else {
			$min = $max = $item;
		}
		if ($num > $max) {	# New message has to be inserted later on
			if ($num == $max + 1) {
				push(@new, "$min-$num");
				$num = 0;	# Signals: inserted
			} else {
				push(@new, $item);
			}
			next;
		}
		# Here, $num <= $max
		if ($num < $min) {	# Item to be inserted before
			if ($num == $min - 1) {
				push(@new, "$num-$max");
			} else {
				push(@new, $num);
				push(@new, $item);
			}
		} else {
			push(@new, $item);	# Item already within that range !?
		}
		$num = 0;				# Item was inserted
	}
	push(@new, $num) if $num;	# At sequence's tail if not inserted yet
	return join(' ', @new);		# Return new sequence
}

# Catch all common signals
sub main'load_catch_signals {
	package main;
	unless (defined &emergency) {
		&add_log("WARNING no emergency routine to trap signals") if $loglvl > 4;
		return;
	}
	$SIG{'HUP'} = "emergency";
	$SIG{'INT'} = "emergency";
	$SIG{'QUIT'} = "emergency";
	$SIG{'PIPE'} = "emergency";
	$SIG{'IO'} = "emergency";
	$SIG{'BUS'} = "emergency";
	$SIG{'ILL'} = "emergency";
	$SIG{'SEGV'} = "emergency";
	$SIG{'ALRM'} = "emergency";
	$SIG{'TERM'} = "emergency";
}

# Init constants -- must be called after mailagent context was loaded
sub callout'load_init {
	package callout;
	$AGENT = 'agent';		# Action is a mailagent command
	$SHELL = 'shell';		# Action is a standalone shell command
	$CMD = 'cmd';			# Action is a shell command on a mail message
	$first_callout = &context'get('next-callout');	# undef if not there
	$callout_changed = 0;	# Records changes in callout queue
}

# Load callout queue file into memory. Before exiting, mailagent will flush
# it again to the disk if it has been modified in some way. It is not an error
# for the file not to exist: it means the callout queue has been emptied.
sub callout'load_load {
	package callout;
	unless (open(CALLOUT, $cf'callout)) {
		&'add_log("WARNING unable to open callout queue file: $!")
			if -f $cf'callout && $'loglvl > 5;
		return;
	}
	&'add_log("loading mailagent callout queue") if $'loglvl > 15;
	local($_, $.);
	while (<CALLOUT>) {
		next if /^\s*#/;
		if (/^(\d+)\s+(\w+)\s+(\S+)\s+(.*)/) {
			$Calltype{$1} .= "$2\0";
			$Callfile{$1} .= "$3\0";
			$Callout{$1} .= "$4\0";
			next;
		}
		&'add_log("WARNING callout queue corrupted, line $.") if $'loglvl > 5;
		last;
	}
	close CALLOUT;
	return unless %Callout;		# Nothing loaded, empty file...

	local($next_callout) = (sort keys %Callout)[0];
	if ($next_callout != $first_callout) {
		&'add_log(
			"NOTICE next-callout is $first_callout, should be $next_callout"
		) if $'loglvl > 6;
		&'add_log("WARNING inconsistency in mailagent context (next-callout)")
			if $'loglvl > 5;
	}
	$first_callout = $next_callout;		# Trust callout queue over context
}

# Enqueue a new job to be performed after a certain time. If the job is to be
# launched before the first one in the queue, the next-callout value in the
# mailagent context is updated.
# Return the queued file name, or '-' if none, undef on errors.
sub callout'load_queue {
	package callout;
	local($time, $action, $type, $no_input) = @_;
	&'add_log("queueing callout on $time ($action)") if $'loglvl > 15;
	$callout_changed++;
	&load unless %Callout;
	local($qname) = '-';			# File not queued by default
	if ($type ne $SHELL && !$no_input) {
		# 'agent' or 'cmd' callouts have input by default, unless $no_input
		# is specified in the arguments.
		local(@mail);				# Temporary mail storage
		@mail = split(/\n/, $'Header{'All'});
		$qname = &'qmail(*mail, 'cm');
		unless (defined $qname) {
			&'add_log("ERROR cannot record $type callout $action for $time")
				if $'loglvl > 1;
			return undef;
		}
	}
	$Callfile{$time} .= "$qname\0";	# Add queue name to the list
	$Calltype{$time} .= "$type\0";	# Add type to the list
	$Callout{$time} .= "$action\0";	# Add action at this time stamp
	$first_callout = $time
		if !defined($first_callout) || $time < $first_callout;
	&'add_log("first callout time is now $first_callout") if $'loglvl > 15;
	return $qname;
}

# Return trigger time for a callout, based on its file name. This is primarily
# used to list the callout queue. If no callout is found, returns 0.
sub callout'load_trigger {
	package callout;
	local($file) = @_;
	local($directory, $base) = $file =~ m|(.*)/(.*)|;
	$file = $directory eq $cf'queue ? $base : $file;
	&load unless %Callout;
	local($time, $files);
	foreach $time (keys %Callfile) {
		$files = $Callfile{$time};
		next unless "\0$files" =~ /\0$file\0/;
		return $time;
	}
	return 0;
}

# Run the queue, by poping off the first set in the queue, and executing
# it. If by that time another timeout expires, loop again.
sub callout'load_run {
	package callout;
	&'add_log("running callout queue") if $'loglvl > 15;
	$callout_changed++;
	&load unless %Callout;
	local(@type, @action, @file);
	local($type, $action, $file);
	do {
		chop($type = $Calltype{$first_callout});	# Remove trailing \0
		chop($action = $Callout{$first_callout});
		chop($file = $Callfile{$first_callout});
		@type = split(/\0/, $type);
		@action = split(/\0/, $action);
		@file = split(/\0/, $file);
		while ($type = shift(@type)) {
			$action = shift(@action);
			$file = shift(@file);
			&spawn($type, $action, $file);		# Spawn callout action
		}
		delete $Calltype{$first_callout};
		delete $Callout{$first_callout};
		delete $Callfile{$first_callout};
		$first_callout = (sort keys %Callout)[0];
	} while ($first_callout && time >= $first_callout);
	&'add_log("callout queue flushed") if $'loglvl > 15;
}

# Flush the callout queue to the disk. This operation launches the commands
# that have expired, then rewrites a new callout queue file to the disk if
# required. When all the jobs from the queue have been run, the callout file
# is removed and the next-callout value is deleted from the context.
# NOTE: this is called by &main'contextual_operations in pl/context.pl, before
# the new mailagent context is actually saved to the disk. Therefore, we are
# able to update next-callout for the next mailagent run.
sub callout'load_flush {
	package callout;
	return unless defined $first_callout;
	&run if time >= $first_callout;		# Run queue if time reached
	return unless $callout_changed;		# Done if no change since &init
	&save;
	&context'set('next-callout', $first_callout);
}

# Save the callout queue on disk. If the %Callout table is empty, the
# callout file is removed.
sub callout'load_save {
	package callout;
	local($count) = scalar(keys %Callout);
	unless ($count) {
		&'add_log("removing mailagent callout queue") if $'loglvl > 15;
		unlink($cf'callout);
		return;
	}
	&'add_log("saving $count entries in callout queue") if $'loglvl > 15;

	local($existed) = -f $cf'callout;
	&'acs_rqst($cf'callout) if $existed;	# Lock existing file

	unless (open(CALLOUT, ">$cf'callout")) {
		&'add_log("ERROR cannot overwrite callout queue $cf'callout: $!")
			if $'loglvl > 1;
		&'free_file($cf'callout) if $existed;
		return;
	}

	print CALLOUT "# Mailagent callout queue, last updated " .
		scalar(localtime()) . "\n";

	local(@type, @action, @file);
	local($type, $action, $file);

	# De-compile callout data structure back into a human-readable table
	foreach $time (sort keys %Callout) {
		chop($type = $Calltype{$time});		# Remove trailing \0
		chop($action = $Callout{$time});
		chop($file = $Callfile{$time});
		@type = split(/\0/, $type);			# Type and action lists per time
		@action = split(/\0/, $action);
		@file = split(/\0/, $file);
		while ($type = shift(@type)) {
			$action = shift(@action);
			$file = shift(@file);
			print CALLOUT "$time\t$type\t$file\t$action\n";
		}
	}

	close CALLOUT;
	&'free_file($cf'callout) if $existed;
}

# Spawn callout action given its type, and the mail file on which the action
# takes place. If the file name is '-', then no input, but only for shell
# commands.
sub callout'load_spawn {
	package callout;
	local($type, $action, $file) = @_;
	local($sub) = 'spawn_' . $type;
	local($file_name) = $file;		# Where mail is held (within queue usually)
	local(%'Header);				# Where filtering information is stored
	&'add_log("spawning $action on $file ($type)") if $'loglvl > 14;
	# File name is absolute if not within mailagent's queue, otherwise it
	# is only a relative path name, as returned by &qmail. Shell commands
	# specify '-', meaning no input is to be taken.
	$file_name = $cf'queue . '/' . $file_name unless $file_name =~ m|^/|;
	if (defined &$sub) {
		&'add_log("setting up mailagent data structures for $file")
			if $'loglvl > 15;
		&'parse_mail($file_name) if $file ne '-';	# Fill in %Header
		&'add_log("spawning callout $type type on $file: $action")
			if $'loglvl > 15;
		local($failed);
		$failed = &$sub($action);		# Invoke call-out action
		$failed = $failed ? 'FAILED' : 'OK';
		&'add_log("$failed CALLOUT ($type) [$file] $action") if $'loglvl > 7;
	} else {
		&'add_log("ERROR unknown callout type $type -- skipping $action")
			if $'loglvl;
	}
	unlink $file_name unless $file eq '-';
}

# Spawn filtering command
sub callout'load_spawn_agent {
	package callout;
	local($action) = @_;
	local($mode) = '_CALLOUT_';	# Initial working mode
	local($'wmode) = $mode;		# Needed for statistics routines
	umask($cf'umask);			# Reset default umask
	&'xeqte($action);			# Run action
	umask($cf'umask);			# Reset umask anyway
	return 0;
}

# Spawn command-on-mail, i.e. shell command with mail on stdin
sub callout'load_spawn_cmd {
	package callout;
	local($action) = @_;
	return &'shell_command($action, $'MAIL_INPUT, $'NO_FEEDBACK);
}

# Spawn shell command
sub callout'load_spawn_shell {
	package callout;
	local($action) = @_;
	return &'shell_command($action, $'NO_INPUT, $'NO_FEEDBACK);
}

# 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 addr'load_valid {
	package addr;
	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 addr'load_simplify {
	package addr;
	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 addr'load_match {
	package addr;
	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 addr'load_close {
	package addr;
	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;
}

# Initialize constants
sub utmp'load_init {
	package utmp;
	# (configured and automatically generated section)
	$utmp = '/var/run/utmp';
	$packfmt = 'x8A32x4A32x308';		# ..pad.. ut_line[] ..pad.. ut_name[] ..pad.. 
	$length = 384;					# sizeof(struct utmp)
	@fields = ('pad', 'line', 'pad', 'user', 'pad');
	# (end of configured section)

	undef @utmp;		# Array where user/tty pairs are stored
	$lmtime = 0;		# Last modification time
	$init = 1;			# Marks init as being done
}

# Update the vision of the utmp file, if changed.
# Returns the amount of records anyway.
sub utmp'load_update {
	package utmp;
	&init unless $init;
	my $ST_MTIME = 9 + $[;	# Field st_mtime from inode structure
	local($mtime) = (stat($utmp))[$ST_MTIME];
	return 0 + @utmp unless $mtime > $lmtime;
	$lmtime = $mtime;
	&reload;
}

# Reload the utmp file into @utmp, returning the amount of records.
sub utmp'load_reload {
	package utmp;
	&init unless $init;
	open(UTMP, $utmp) || warn "Can't open $utmp: $!\n";
	undef @utmp;		# Array where user/tty pairs are stored
	local($buf);		# Where each "line" of utmp is read
	local(%utmp);		# Used to extract user and line informations
	local(@uline);		# Where line is unpaked
	while (sysread(UTMP, $buf, $length)) {
		@uline = unpack($packfmt, $buf);
		foreach $field (@fields) {
			next if $field eq 'pad';		# Padding was not unpacked
			$utmp{$field} = shift(@uline);	# Decompile structure
		}
		push(@utmp, $utmp{'user'} . ' ' . $utmp{'line'});
	}
	close UTMP;
	return 0 + @utmp;	# Amount of records
}

# Return the ttys on which a given user is logged
sub utmp'load_ttys {
	package utmp;
	local($user) = @_;			# User's login name
	&update;					# Make sure we use most recent data
	local(@u) = @utmp;			# Work on a copy
	grep(s/^$user\s//, @u);		# Returns array of ttys
}

# Perform biffing, given the folder where delivery was made print out a
# biff-like message on each of the user's terminal where a 'biff y' command
# was issued to effectively request biffing (i.e. on ttys where the 'x' bit
# was set).
sub main'load_biff {
	package main;
	local($folder, $type) = @_;
	local(@ttys) = &utmp'ttys($cf'user);
	@ttys = <tty*> if $test_mode;	# For regression tests
	&add_log("$cf'user is logged on @ttys") if $loglvl > 15;
	my %done;						# Solaris might give same tty twice
	foreach $tty (@ttys) {
		&biff'notify($tty, $folder, $type) unless $done{$tty}++;
	}
}

# This is the real notifier routine. When reached, we know we have to attempt
# biffing on the specified tty if its 'x' bit is set. Mail biffing is
# controlled by some config variables.
sub biff'load_notify {
	package biff;
	local($tty, $path, $type) = @_;
	$tty = "/dev/$tty" unless $'test_mode;	# Re-anchor name in file system
	return unless -x $tty;		# Return if no biffing wanted on that tty

	my ($row, $col) = termios'size($tty);
	&'add_log("WARNING cannot compute size of $tty: $row")
		if defined($row) && !defined($col) && $'loglvl > 3;
	my $assuming = "";
	unless (defined $col) {
		($row, $col) = (24, 80);
		$assuming = "assuming ";
	}
	&'add_log("biffing $cf'user on $tty ($assuming$row x $col)")
		if $'loglvl > 8;

	local($folder) = &'tilda($path);	# Replace home directory with a ~
	local($n) = "\n\r";					# Use \r in case tty is in raw mode

	# Biffing context containing the amount of lines we can still emit before
	# reaching the size of the window, and the amount of columns we have for
	# displaying the text.
	local @context = ($row, $col);

	unless (open(TTY, ">$tty")) {
		&'add_log("ERROR cannot write on $tty: $!") if $'loglvl;
		&'add_log("WARNING unable to biff for $folder ($type) on $tty")
			if $'loglvl > 5;
		return;
	}

	# Headers to print are in 'biffhead', or default to the following list
	# We set it now so that it can be seen by both &headers and &all
	# Don't show "To" or "Cc" if biffing for a news article

	local(@head) = ('From', 'To', 'Subject', 'Date');
	@head = split(/,\s*/, $cf'biffhead) if defined $cf'biffhead;
	@head = grep(!/^(To|Cc)$/, @head) if $type eq "news";

	# Set proper 'mtype' parameter, used by the biffing %t macro.
	local($mtype) = $type eq "news" ? "article" : "mail";

	# If the 'biffmsg' parameter is defined, then this file defines the
	# biffing format to be used. Otherwise, a default hardwired format is
	# used.

	local($msg);
	($msg = $env'biffmsg) =~ s/~/$cf'home/ if defined $env'biffmsg;
	if (defined $msg) {
		&custom($msg, $type);	# Customized message
	} else {
		&default;				# Default message
	}

	close TTY;
}

# Customized biffing
sub biff'load_custom {
	package biff;
	local($format, $type) = @_;
	unless (open(FORMAT, $format)) {
		&'add_log("ERROR cannot open biff format $format: $!") if $'loglvl > 1;
		&default;			# Use default format then
		return;
	}

	# Declare all the possible locals for type-specific folder macros, so
	# that &macros_subst() may see them anyway.
	local($dir);			# Parent directory
	local($base);			# Base name, "number" for MH and dir
	local($fbase);			# Base under folder directory for type, or $path
	local($fpath);			# Folder path (one above for MH and dir folders)
	local($plus) = '';		# A '+' character if MH folder, nothing otherwise
	local($folddir);		# Folder directory

	if ($type eq 'news') {
		($dir, $base) = ('', $folder);
	} else {
		($dir, $base) = $folder =~ m|^(.*)/(.*)|;
	}

	# Add distinct macros for each kind of folder: file, dir, MH or news.
	if ($type eq 'MH' || $type eq 'dir') {
		($dir, $base) = $path =~ m|^(.*)/(.*)|;
		$fpath = $dir;		# Last component is a message "number"
	} else {
		$fpath = $path;
	}

	if ($type eq 'MH') {
		&mh'profile;		# Read MH profile if not already done
		$folddir = "$cf'home/$mh'Profile{'path'}";
		$plus = '+';
	} elsif ($type eq 'news') {
		$folddir = '';
		$fbase = $fpath;
	} else {
		$folddir = $'XENV{'maildir'};		# Folder directory location
		$folddir =~ s/~/$cf'home/g;			# ~ substitytion
		$folddir = "$cf'home/Mail" unless $folddir;	# Default folders in ~/Mail
	}

	if ($type ne 'news') {
		local($foldmatch);
		($foldmatch = $folddir) =~ s/(\W)/\\$1/g;	# Quote meta-characters
		($fbase = $fpath) =~ s|^$foldmatch/||;
	}

	# Lastly, using %:l gets the standard %l. This requires knowing about
	# &macros_subst() internals for substition (% replaced by ^B!).
	&macro'overload(<<'EOM');	# Install customized set
a	&biff'beep		e
b	\07
d	$biff'folddir
f	$biff'folder
m	$biff'plus
p	$biff'path
t	$biff'mtype
B	$biff'fbase
D	$biff'dir
F	$biff'base
P	$biff'fpath
-A	&biff'all		e
-H	&biff'headers	e
-B	&biff'body(0)	e
-T	&biff'body(1)	e
:	\02!
EOM
	local($_);
	my $reformat = $cf'biffnice =~ /^on/i;
	my $width = $context[1];
	while (<FORMAT>) {
		chop;
		my @lines = split($n, &'macros_subst(*_));
		if (@lines) {
			foreach my $l (@lines) {
				if ($reformat) {
					local @tmp;
					&format($l, $width, *tmp);	# Format line into @tmp
					$l = join($n, @tmp);
				}
				print TTY $l, $n;
			}
		} else {
			print TTY $n;
		}
	}
	close FORMAT;
	&macro'unload;			# Release customized macros
}

# Default biffing
sub biff'load_default {
	package biff;
	my $header = "New $mtype for $cf'user has arrived in $folder:";
	my $width = $context[1];
	my $lines = int(length($header) / $width) + 1;
	$lines-- if 0 == length($header) % $width;
	print TTY "$n\07$header$n";
	print TTY "----$n";
	$context[0] -= $lines + 1;		# Header line plus dashes
	print TTY &all;
	print TTY "$n----\07$n";
}

# The %-A biffing macro returns header and body, separated by a blank line
sub biff'load_all {
	package biff;
	local($res) = &headers;
	# Note: we don't care whether headers were effectively printed: as long
	# as there is something in @head, we print a newline, thereby indicating
	# to the user his variable was taken into account, but the header was
	# really missing.
	$res .= $n if @head;
	$res .= $n . &body(0);	# No final \n\r for macro substitution
	$res;
}

# Returns mail headers defined in @head, on the opened TTY
# If the header length is greater than the tty width, it is trimmed and
# three dots '...' are emitted to show something was truncated.
# Also known as the %-H macro
sub biff'load_headers {
	package biff;
	local($res) = '';
	my $width = $context[1];		# tty columns
	foreach $head (@head) {
		next unless defined $'Header{$head};
		local($line) = unquote_printable("$head: $'Header{$head}");
		$line =~ s/[\x0-\x1f\x7f]//g;
		$line = substr($line, 0, $width - 4) . '...' if length($line) >= $width;
		$res .= "$line$n";
	}
	chop($res);			# Remove final \n\r for macro substitution
	chop($res);
	$res;
}

# Is line a blank one?
sub biff'load_is_blank {
	package biff;
	my ($l) = @_;
	return $l =~ /^[\W_]*$/;	# Contains only non-words and underscores
}

# Keep only printable ASCII chars from biffable lines in specified body array
# Control chars are swallowed, non-ASCII chars converted to '.'.
sub biff'load_to_ascii {
	package biff;
	my ($aref, $lines) = @_;	# Body as array ref, amount of lines to convert
	my $n = $lines > @{$aref} ? @{$aref} : $lines;
	for (my $i = 0; $i < $n; $i++) {
		$aref->[$i] =~ s/(.)/mangle_ascii($1)/ge;
	}
}

# Print first $cf'bifflines lines or $cf'bifflen charaters, whichever
# comes first. Assumes TTY already opened correctly
# Also known as the %-B macro if called body(0), or %-T if called body(1).
sub biff'load_body {
	package biff;
	local($trim) = @_;			# Whether top reply text should be trimmed
	local($len) = defined $cf'bifflen ? $cf'bifflen : 560;
	local($lines) = defined $cf'bifflines ? $cf'bifflines : 7;
	local(@body) = split(/\r?\n/, ${$'Header{'=Body='}});
	local($skipnl) = $cf'biffnl =~ /OFF/i;	# Skip blank lines?
	local($_);
	local($res) = '';

	# Setting bifflen or bifflines to 0 means no body
	return '' if $len == 0 || $lines == 0;

	my ($content, $entity, $enc, $biffenc);
	($content, $entity) = unmime(\@body) if $'Header{'Mime-Version'};

	my $convert_to_ascii = 0;
	if (length($content)) {
		&'add_log("biffing $entity entity is $content") if $'loglvl > 8;
		my $charset;
		$charset = $1 if $content =~ /\bcharset="?([-\w]+)/;
		if (defined $charset) {
			$enc = Encode::find_encoding($charset);
			unless (ref $enc) {
				&'add_log("WARNING unknown charset '$charset', handling as ASCII")
					if $'loglvl > 1;
				$convert_to_ascii = 1;
			}

			# If the encoding is the same as the one used in the terminal,
			# we have no conversion to make.  Reset $enc.
			$biffenc = Encode::find_encoding($cf'biffchars);
			$enc = undef if
				!(ref $biffenc) ||
				(ref $enc && $biffenc->name eq $enc->name);
		}
	}

	if (ref $enc) {
		&'add_log("biff converting " . $enc->name . " into " . $biffenc->name)
			if $'loglvl > 8;
	}

	strip_html(\@body) if $content =~ /html\b/;
	&trim(*body) if $trim;		# Smart trim of leading reply text
	to_ascii(\@body, $lines) if $convert_to_ascii;
	&mh(*body, $len) if $cf'biffmh =~ /^on/i;

	my $reformat = $cf'biffnice =~ /^on/i;
	my $width = $context[1];
	my $tl = 8;					# tab length

	while ($len > 0 && $lines > 0 && defined ($_ = shift(@body))) {
		if (ref $enc) {
			my $data = $enc->decode($_);
			$_ = $biffenc->encode($data);
		}
		next if $skipnl && is_blank($_);
		my $line_length = 0;
		1 while s|\t|' ' x ($tl - length($`) % $tl)|e;	# Expand tabs
		s/[\x0-\x1f\x7f]//g;					# Remove all control chars
		if ($reformat) {
			local @tmp;
			&format($_, $width, *tmp);			# Format line into @tmp
			@tmp = grep(!is_blank($_), @tmp) if $skipnl;
			foreach my $l (@tmp) {
				$line_length += length $l;		# Do not count newlines
				$lines--;
			}
			$_ = join($n, @tmp);
		} else {
			$line_length = length $_;
			$lines -= int($line_length / $width) + 1;
			$lines++ if 0 == $line_length % $width;
		}
		# Check for overflow, in case we use mh-style biffing and no
		# reformatting occurred: we may be facing a huge string!
		if (length($_) > $len) {
			$res .= substr($_, 0, $len) . $n;
		} else {
			$res .= $_ . $n;
		}
		$len -= $line_length;
	}
	$res .= "...more...$n" if @body > 0 || $len < 0;
	chop($res);					# Remove final \n\r for macro substitution
	chop($res);
	$res;
}

# Trim out leading reply text held in array of lines, with in-place updating.
# The purpose is to remove from the biffing text all the leading lines
# beginning with the same single non-alphanumeric character. To allow citation
# notification such as "Quoting John Doe:", the leading line is skipped when
# the next line starts with a non-alphanumeric character.
# Removed text is replaced by something like '[trimmed 20 lines]'.
# The purpose is to convey as much useful information as possible in the
# limited biffing space.
# NOTE: This routine does not understand a marginal form of quoting whereby
# the name or login of the quoted person is inserted before the quote character,
# such as "ram> this is quoted material from ram".
sub biff'load_trim {
	package biff;
	local(*ary) = @_;			# Array of lines
	local($first_line) = 1;		# False when leading non-blank line found
	local($quote_char) = '';	# Quotation character
	local($i);

	# First, locate index of first non-blank line
	for ($i = 0; $i < @ary; $i++) {
		last if $ary[$i] !~ /^\s*$/;
	}

	# Now look for a quotation character. If on the first line, allow a
	# one-line look-ahead to skip the (assumed to be) attribution line.
	local($_);
	local($quote);			# Attrib line index, valid iff $first_line == 0
	for (; $i < @ary; $i++) {
		$_ = $ary[$i];
		next if /^\s*$/;			# Allow arbitrary amount of blank lines
		if (/^(\W)/) {
			$quote_char = $1;
			last;
		}
		last unless $first_line;	# Skip first line
		$first_line = 0;
		$quote = $i;				# Save attribution line position in array
	}

	# At this point, either we have found a citation notification and the
	# used quotation character is in $quote_char, or nothing has been found
	# and we can return: no trimming was possible.

	return unless $quote_char;

	# Starting from the current index (pointing to the beginning of the
	# quoting), scan forward and discard all the following lines starting
	# with this quoting character.

	local($start) = $i;			# Save index where '[trimmed...]' will appear

	# Go to the end of the quotation, skipping interleaved blank lines
	for ($i++; $i < @ary; $i++) {
		$_ = $ary[$i];
		if (substr($_, 0, 1) ne $quote_char) {
			last unless /^\s*$/;	# End of quotation if non-blank line
			last if $i == @ary;		# End if reached last line in the body
			$_ = $ary[$i+1];		# Look ahead...
			next if /^\s*$/;		# Another blank line following...
			last unless substr($_, 0, 1) eq $quote_char;
		}
	}

	# Now $i points to the first line not being part of the initial quotation.
	# Therefore, we may splice it out of the array altogether.
	# Leave it alone if the length of the whole quotation is less than a
	# configurable amount (a single line by default).

	local($amount) = $i - $start;
	return if $amount < (defined $cf'bifftrlen ? $cf'bifftrlen : 2);

	# Under normal conditions, the first trimmed line is replaced by a
	# message stating that some lines have been trimmed off. But if bifftrim
	# is turned to OFF, then no trimming notification is given, automatically
	# turning off biffquote.

	local($trim_quote) = $cf'biffquote =~ /^off/i;	# Trim attribution line?

	if ($cf'bifftrim =~ /^off/i) {
		$start--;			# Shift up so that the first line be skipped
		$amount++;
		$trim_quote = 1;	# Automatically turn off biffquote...
	} else {
		$ary[$start] = "\[trimmed $amount line" . ($amount == 1 ? '' : 's') .
			" starting with a leading '$quote_char' character";
		$ary[$start] .= " & attribution line"
			if $first_line == 0 && $trim_quote;
		$ary[$start] .= "\]";
	}

	# Now perform the whole quotation trimming. The starting index is set to
	# '$start + 1' to skip the [trimmed...] message. The $start variable has
	# been previously decremented if that message is not meant to appear!

	splice(@ary, $start + 1, $amount - 1) if $amount > 1;

	# The attribution line is removed if biffquote is OFF; we know it is
	# present when $first_line has been reset to 0 above. Must be done after
	# the previous splice since the attribution line comes before the quotation
	# and offsets would be mangled when the line is removed!

	splice(@ary, $quote, 1) if $first_line == 0 && $trim_quote;
}

# Produces an mh-style biffing string by removing all new-lines in the string,
# replacing them by spaces, and collading every consecutive spaces into one.
# Actually, it takes an array glob containing the body line by line, and it
# produces a single string, as big as the maximum biffing lenght states,
# splicing the array to replace its first line with the produced string and
# removing those lines that were used to make that string.
sub biff'load_mh {
	package biff;
	local(*ary, $len) = @_;		# Body array, maximum biffing length
	local($line) = '';			# Compacted body output
	local($i);
	local($_);
	for ($i = 0; $i < @ary && $len > 0; $i++, $len -= length($_)) {
		$_ = $ary[$i];
		if (/^\s*$/) {			# Blank line
			$_ = '';			# Ignore it, and do not count it
			next;
		}
		tr/ \t/  /s;			# Strip consecutive tabs/spaces
		s/^\s//;				# Strip leading space
		s/\s$//;				# Strip trailing space
		$line .= $_ . ' ';
	}
	chop($line);				# Remove trailing extra space
	$ary[0] = $line;			# This is all we keep

	# We stopped compating at index $i - 1, and indices start at 0. This means
	# lines in the range [0, $i-1] are now all stored as $ary[0], and lines
	# from [1, $i-1] must be removed from the array ($i-1 lines).
	# We keep the extra lines so that a "...more..." indication can be given
	# if needed.

	splice(@ary, 1, $i - 1);	# Remove lines that are now part of $ary[0]
}

# Format body to fit into tty width by inserting the generated lines in an
# array, one line per item.
sub biff'load_format {
	package biff;
	# Body to be formatted, tty width, array for result
	local($body, $width, *ary) = @_;
	local($tmp);				# Buffer for temporary formatting
	local($kept);				# Length of current line
	local($len) = $width - 1;	# Amount of characters kept
	$len = 1 if $len < 1;		# Avoid infinite loop if bad parameter
	# Format body, separating lines on [;,:.?!] or space.
	while (length($body) > $len) {
		$tmp = substr($body, 0, $len);		# Keep first $len chars
		$tmp =~ s/^(.*)([;,:.?!\s]).*/$1$2/;# Cut at last space or punctuation
		$kept = length($tmp);				# Amount of chars we kept
		$tmp =~ s/\s*$//;					# Remove trailing spaces
		$tmp =~ s/^\s*//;					# Remove leading spaces
		push(@ary, $tmp);					# Create a new line
		$body = substr($body, $kept, length $body);
	}
	push(@ary, $body);			# Remaining information on one line
}

# Quick removal of quoted-printable escapes within the headers
# We pay attention to the charset and recode data to the charset specified
# as "biffchars" in the configuration.
sub biff'load_unquote_printable {
	package biff;
	my ($l) = @_;
	# The to_txt() routine being used MUST NOT be dataloaded or $1 would be
	# reset to '' on the first invocation.  It's a perl bug (seen in 5.10)
	# By precaution, we also do not dataload b64_to_txt().
	$l =~ s/=\?([\w-]+)\?Q\?(.*?)\?=/to_txt($1,$2)/sieg && $l =~ s/_/ /g;
	$l =~ s/=\?([\w-]+)\?B\?(.*?)\?=/b64_to_txt($1,$2)/sieg;
	&'add_log("unquoted '$_[0]' to '$l'") if $'loglvl > 19 && $_[0] ne $l;
	return $l;
}

# Recursive MIME parsing to extract the first text entity content
#
# Input is (aref, eref, boundary, n)
# where:
#	aref			is the array containing the body being parsed
#	eref			is where we can stuff the entity content
#	boundary		is the current MIME boundary
#	n				is the running count of the entity number
#
# Returns (content_type, parsed_header, n)
# where:
# 	content_type	is the retained entity content-type
#	parsed_header	is a ref on the parsed header hashtable
#	n				is the entity number
sub biff'load_unmime_recursive {
	package biff;
	my ($aref, $eref, $boundary, $n) = @_;

	&'add_log("searching text part for biffing, boundary=$boundary, n=$n")
		if $'loglvl > 16;

	my $entity_content;
	my $header;
	my $grabbed = 0;

	for (;;) {
		unless ($grabbed) {
			last unless skip_past($aref, $boundary);
		}
		$grabbed = 0;
		$header = parse_header($aref);
		my $content = lc($header->{'Content-Type'});
		$content =~ s/\(.*?\)\s*//g;
		&'add_log("parsed entity header: content is $content") if $'loglvl > 19;
		$n++;
		if ($content =~ m|^text/|) {
			# We found (another) text part, collect it...
			&'add_log("collecing text n=$n") if $'loglvl > 19;
			my @entity;
			my $end = !skip_past($aref, $boundary, \@entity);
			$grabbed = 1;		# Avoid skipping at next loop iteration
			if (
				$end ||
				$content =~ m|^text/plain\b|	# Found the best one
			) {
				@$eref = @entity;
				$entity_content = $content;
				&'add_log("done with n=$n, content=$content") if $'loglvl > 19;
				last;
			}
		} elsif ($content =~ m|^multipart/|) {
			my ($bound) = $content =~ /boundary=(\S+);/;
			($bound) = $content =~ /boundary=(\S+)/ unless length $bound;
			$bound = $1 if $bound =~ /^"(.*)"/ || $bound =~ /^'(.*)'/;
			&'add_log("collecing recursively n=$n, boundary=$bound")
				if $'loglvl > 19;

			($entity_content, $header, $n) =
				unmime_recursive($aref, $eref, $bound, $n);

			if ($entity_content =~ m|^text/plain\b|) {
				&'add_log("done with n=$n, content=$content") if $'loglvl > 19;
				last;
			}
		}
	}

	return ($entity_content, $header, $n);
}

# Un-MIME the body by removing all the embedded MIME part stuff and looking
# for the first text entity in the message.
# The supplied array is updated in-place and will contain on return the
# lines of the MIME entity that was retained.
# Returns the type of the retained MIME entity and the number of the entity
# for logging, saying "global" for the whole message.
# NB: if no text part is found, the array will be empty upon return.
sub biff'load_unmime {
	package biff;
	my ($aref) = @_;
	my $content = $'Header{'Content-Type'};
	$content =~ s/\(.*?\)\s*//g;		# Removed allowed RFC822 comments

	&'add_log("global MIME content-type is $content") if $'loglvl > 16;
	return ($content, "global") unless $content =~ m|^multipart/|i;

	my ($boundary) = $content =~ /boundary=(\S+);/;
	($boundary) = $content =~ /boundary=(\S+)/ unless length $boundary;
	$boundary = $1 if $boundary =~ /^"(.*)"/ || $boundary =~ /^'(.*)'/;

	# We perform a recursive MIME parsing here because the first part of
	# the message could be a multipart/alternative, with sub MIME sections
	# containing the text entity we're looking for.
	#		--RAM, 2016-09-14

	my @entity;
	my ($entity_content, $header, $n) =
		unmime_recursive($aref, \@entity, $boundary, 0);

	my $entity = "${n}th";
	$entity =~ s/1th$/1st/;
	$entity =~ s/2th$/2nd/;
	$entity =~ s/3th$/3rd/;

	&'add_log("kept $entity entity $entity_content for biffing")
		if $'loglvl > 18;

	# Maybe the entity bears a transfer encoding?
	my $entity_encoding = $header->{'Content-Transfer-Encoding'};
	$entity_encoding =~ s/\(.*?\)\s*//g;

	# XXX code duplication with body_check(), factorize some day...
	my $output;
	my $error;
	my $len = 0;

	foreach my $x (@entity) {
		$len += length $x;
	}

	if ($entity_encoding =~ /^base64\s*$/i) {
		base64'reset($len);
		foreach my $d (@entity) {
			base64'decode($d);
		}
		$error = base64'error_msg();
		$output = base64'output();
	} elsif ($entity_encoding =~ /^quoted-printable\s*$/i) {
		qp'reset($len);
		foreach my $d (@entity) {
			qp'decode($d);
		}
		$error = qp'error_msg();
		$output = qp'output();
	} else {
		$error = "no encoding";
	}

	my $error_msg = length($error) ? $error : "none";
	&'add_log("decoded $entity entity ($entity_encoding), error=$error_msg")
		if $'loglvl > 18;

	if (length $error) {
		@$aref = @entity;
	} else {
		@$aref = split(/\r?\n/, $$output);
	}
	return ($entity_content, $entity);
}

# Skip past named boundary in the supplied array
# If $collect is a defined ARRAY ref, push there all the lines we see until
# the next boundary.
# Return false when we see the LAST boundary in the message, meaning there
# are no more parts to consider.
sub biff'load_skip_past {
	package biff;
	my ($aref, $boundary, $collect) = @_;
	my $l;
	while (defined ($l = shift @$aref)) {
		return 0 if $l eq "--$boundary--";
		return 1 if $l eq "--$boundary";
		push(@$collect, $l) if defined $collect;
	}
	return undef;	# Not found
}

# Parse embedded MIME headers, returning hash ref
sub biff'load_parse_header {
	package biff;
	my ($aref) = @_;
	my %header;
	my $val;
	my $last_header;
	my $l;
	my $saw_something = 0;
	while (defined ($l = shift @$aref)) {
		last if $l =~ /^$/ && $saw_something;
		$saw_something++;
		if ($l =~ /^\s/) {
			$l =~ s/^\s+/ /;
			$header{$last_header} .= $l if length $last_header;
		} elsif (my ($field, $value) = $l =~ /^([!-9;-~\w-]+):\s*(.*)/) {
			$last_header = header'normalize($field);
			if ($header{$last_header} ne '') {
				$header{$last_header} .= "\n" . $value;
			} else {
				$header{$last_header} = $value;
			}
		}
	}
	return \%header;
}

# Strip HTML in-place and remove spurious blank lines
# This is done only on a best-effort basis to make the biff output nice
sub biff'load_strip_html {
	package biff;
	my ($aref) = @_;
	my @out;
	my $in_style = 0;
	my $is_nl;
	my $last_was_nl = 0;
	my $l;

	while (defined ($l = shift @$aref)) {
		$in_style++ while $l =~ s/<style\b.*?>//;
		$in_style-- while $l =~ s|</style>||;
		next if $in_style;
		$l =~ s/<[^\0]*?>//g;
		$l =~ s/&(\w)cedil;/$1/g;	# Transform into ASCII...
		$l =~ s/&(\w)acute;/$1/g;
		$l =~ s/&(\w)grave;/$1/g;
		$l =~ s/&(\w)circ;/$1/g;
		$l =~ s/&(\w)uml;/$1/g;
		$l =~ s/&quot;/'/g;
		$l =~ s/&nbsp;/ /g;
		$l =~ s/&#160;/ /g;       # Same as &nbsp;
		# Corect only for the ASCII part...
		$l =~ s/&#(\d+);/($1 > 31 && $1 < 256) ? chr($1) : "?"/ge;
		$l =~ s/&amp;/&/g;        # Must come last
		$l =~ s/^\s*//;
		$is_nl = 0 == length($l);
		next if $last_was_nl && $is_nl;
		$last_was_nl = $is_nl;
		push(@out, $l);
	}

	@$aref = @out;
}

# %Spec contains special actions that must be peformed when the original
# value of a variable is restored. For instance, when restoring the umask, a
# system call must also be performed to restore the correct system value.
# That code is called *after* the variable has retained its previous value.
# %Spec is indexed by variable name and must contain valid perl code.
sub env'load_init {
	package env;
	%Spec = (
		'umask',	'umask($umask)',
	);
	@Env = (		# Variables handled by local environment
		'umask',
		'vacperiod', 'vacfile',
		'biff', 'biffmsg',
	);
	foreach $var (@Env) {
		$SETUP .= "\$$var = \$cf'$var;\n";	# Copy value from config
	}
}

# Set-up initial environment for rules.
# This routine is called once for every mail parsed.
sub env'load_setup {
	package env;
	&init unless %Spec;
	eval $SETUP if $SETUP ne '';
	&'add_log("ERROR env'setup: $@") if $@;
	undef %Var;

	#
	# Default environment setting not copied from configuration...
	#

	$vacation = 1;		# Vacation message allowed, if configured of course
	undef $protect;		# Default protection (from umask setting) applies
	$beep = 1;			# When biffing, %b expands to one ^G.
}

# Make a local modification to a variable
sub env'load_local {
	package env;
	local($var, $value) = @_;	# Variable name, new value
	eval "\$Var{'".$var."'} = defined(\$$var) ? \$".$var.' : undef;'
		unless defined $Var{$var};
	eval "\$$var = \$value;" unless $@;
	&'add_log("ERROR env'local: $@") if $@;
}

# Erase all instances of a variable. If there was a local instance, it is
# destroyed as well as any global one. To erase a local instance only if
# there is one, use &env'undef.
sub env'load_unset {
	package env;
	local($var) = @_;			# Variable name
	eval "undef \$$var;";
	eval "delete \$Var{'".$var."'};" unless $@;
	&'add_log("ERROR env'unset: $@") if $@;

}

# Undefine last occurrence of a variable.
sub env'load_undef {
	package env;
	local($var) = @_;			# Variable name
	eval "\$$var = defined \$Var{'$var'} ? \$Var{'$var'} : undef;\n";
	&'add_log("ERROR env'undef: $@") if $@;
}

# Restore variables to the value held in the %Var table (key = variable name).
# If an action is required by the resetting of a variable, it is performed
# following the directive from the %Spec table.
sub env'load_restore {
	package env;
	return unless %Var;
	local($code) = '';		# Code built to restore original variable values
	foreach $var (keys %Var) {
		$code .= "\$$var = \$Var{'$var'};\n";
		$code .= $Spec{$var} . ";\n" if defined $Spec{$var};
	}
	eval $code if $code ne '';
	&'add_log("ERROR env'restore: $@") if $@;
	undef %Var;
}

# Cleanup environment processing
sub env'load_cleanup {
	package env;
	&restore;		# For possible side-effects in %Spec
}

# Given a command list, an option syntax specification, and a glob on the
# array containing the command arguments, set the $sw_* variables for each
# of the recognized options and returns true if ok.
sub opt'load_get {
	package opt;
	local($me, $argumentative, *argv) = @_;
	local(@args, $_, $first, $rest);
	local($errs) = 0;

	@args = split(/ */, $argumentative);
	while (@argv) {
		$_ = $argv[0];
		do { shift(@argv), next } if /^\s+$/;	# Skip spaces (see &parse)
		last unless /^-(\w)(.*)/;
		($first, $rest) = ($1, $2);
		$pos = index($argumentative, $first);
		if ($pos >= 0) {
			if ($args[$pos+1] eq ':') {
				shift(@argv);
				if ($rest eq '') {
					++$errs unless @argv;
					$rest = shift(@argv);
				}
				eval "\$sw_$first = \$rest;";
			} else {
				eval "\$sw_$first = 1";
				if($rest eq '') {
					shift(@argv);
				} else {
					$argv[0] = "-$rest";
				}
			}
		} else {
			&'add_log("WARNING: unknown option -$first for $me")
				if $'loglvl > 5;
			++$errs;
			if ($rest ne '') {
				$argv[0] = "-$rest";
			} else {
				shift(@argv);
			}
		}
	}
	$errs == 0;
}

# Reset the switch variables by saving their current values and undefining them
sub opt'load_reset {
	package opt;
	unless (defined &RESET) {
		local($reset) = "sub RESET {\n";
		foreach $opt ('a'..'z', 'A'..'Z', '1'..'9','_') {
			$reset .=
				"push(\@sw_$opt, defined(\$sw_$opt) ? \$sw_$opt : undef);
				undef \$sw_$opt;\n";
		}
		$reset .= "}\n";
		eval $reset;
	}
	&RESET;
}

# Restore the previous value for all the available switch variables
sub opt'load_restore {
	package opt;
	unless (defined &RESTORE) {
		local($restore) = "sub RESTORE {\n";
		foreach $opt ('a'..'z', 'A'..'Z', '1'..'9','_') {
			$restore .= "\$sw_$opt = pop(\@sw_$opt);\n";
		}
		$restore .= "}\n";
		eval $restore;
	}
	&RESTORE;
}

# Parse the options for a given filtering command. Although we are breaking
# the command into words for the sake of option parsing, we must ensure we
# are not actually destroying multiple spaces in the arguments.
# Returns the new command string with all the (recognized) options stripped.
sub opt'load_parse {
	package opt;
	local($cmd, $argumentative) = @_;
	local($me);
	local(@argv) = split(/(\s+)/, $cmd);	# Preserve spaces into @argv
	$me = shift(@argv);						# Remove command name
	$me =~ tr/a-z/A-Z/;						# Translate to upper-case
	&get($me, $argumentative, *argv);		# Ignore return status
	return join('', "$me ", @argv);
}

# Setup a decent mailagent environment, and returns a proper exit status,
# i.e. 0 for success and 1 for failure.
sub cf'load_setup {
	package cf;
	*main'add_log = *main'stdout_log;	# Setup a decent logging routine

	# To allow for automatic -I testing, we set-up the following two
	# variables specially for the test suite when invoked with the
	# undocumented -TEST option.

	local($cfset'home);					# Computed HOME directory
	local($cfset'privlib);				# Installed mailagent libdir
	if ($'test_mode) {
		$cfset'home = $ENV{'HOME'};					# agent/test/out
		$cfset'privlib = "$cfset'home/../../files";	# agent/files
	} else {
		$cfset'home = &'tilda_expand('~');
		$cfset'privlib = &'tilda_expand($'privlib);
	}

	umask(077);							# Default mode: rw for user only!
	$home = $cfset'home;				# Required by &main'tilda...

	# Setup a default configuration
	unless (&cfset'init) {
		&'add_log("trouble initializing configuration -- help required");
		return 1;
	}

	# Now load new configuration and perform sanity checks
	&'get_configuration;
	unless (defined $main'loglvl) {
		&'add_log("trouble getting new configuration -- check it up");
		return 1;
	}

	&cfset'check;		# Check the configuration
	return 0;			# OK
}

# Initialize configuration, returning true on success.
sub cfset'load_init {
	package cfset;
	unless (-d $home) {
		&'add_log("cannot locate home directory -- all I have is '$home'");
		return 0;	# failed
	}
	unless (-w $home) {
		&'add_log("you lack write permissions in $home");
		return 0;	# failed
	}

	local($pwdhome) = $'test_mode ? $ENV{'HOME'} : (getpwuid($<))[7];
	if (defined $ENV{'HOME'} && $ENV{'HOME'} ne $pwdhome) {
		&'add_log("your HOME environment variable disagrees with /etc/passwd");
		&'add_log("HOME: $ENV{'HOME'}, /etc/passwd: $pwdhome");
	}

	$ENV{'HOME'} = $home;					# This is set by filter normally

	return 0 unless &read_setup;			# Get setup.cf for defaults
	return &merge if -e "$home/.mailagent";	# Merge if already exists

	# Ok, at this point, we need to create a default ~/.mailagent that
	# will enable the user to run mailagent correctly.

	&'add_log("creating ~/.mailagent...");

	unless (open(TEMPLATE, "$privlib/mailagent.cf")) {
		&'add_log("cannot open $privlib/mailagent.cf: $!");
		return 0;	# failed
	}

	unless (open(CONFIG, ">$home/.mailagent")) {
		&'add_log("cannot create $home/.mailagent: $!");
		return 0;	# failed
	}

	# Build up a default configuratiuon from the mailagent.cf template.
	# If some variables have configured defaults in setup.cf, then use that.
	# Otherwise, copy the line, propagating the "commented out" status.

	local($_);
	local($c, $var, $sp1, $sp2, $val, $comment);
	while (<TEMPLATE>) {
		if (
			($c, $var, $sp1, $sp2, $val, $comment) =
			/^(#?)(\w+)(\s*):(\s*)([^#\n]*)(#.*)?/
		) {
			next if $var =~ /^p_/;				# Skip p_host examples
			if (defined $Var{$var}) {			# Has a computable default
				($val) = $val =~ m/(\s+)$/;		# Keep spaces before comment
				print CONFIG "$c$var$sp1:$sp2", &dflt($var), "$val$comment\n";
			} else {
				print CONFIG;		# No computable default, print verbatim
			}
		} else {
			print CONFIG;
		}
	}
	close CONFIG;
	close TEMPLATE;
}

# Merge existing configuration with possible new variables, returning
# true on success. Called from &init, after setup.cf loading when an
# existing ~/.mailagent is detected.
sub cfset'load_merge {
	package cfset;
	local($old) = '.mailagent';
	local($new) = "$old.new";
	local($bak) = "$old.bak";

	&'add_log("merging ~/.mailagent...");

	unless (open(OLD, "$home/$old")) {
		&'add_log("cannot open $home/$old: $!");
		return 0;	# failed
	}

	# Fist pass on old file to get at the currently defined variables

	local(%seen);		# Records variables in current configuration
	local($_);
	while (<OLD>) {
		$seen{$1}++ if /^#?(\w+)\s*:/;
	}
	seek(OLD, 0, 0);	# Rewind

	unless (open(TEMPLATE, "$privlib/mailagent.cf")) {
		&'add_log("cannot open $privlib/mailagent.cf: $!");
		return 0;	# failed
	}

	# Now grab all the "known" variables in the mailagent.cf template.
	# Those tell us about the possible new variables that may have been
	# introduced since  the time ~/.mailagent was first created.

	local(%known);
	while (<TEMPLATE>) {
		$known{$1}++ if /^#?(\w+)\s*:/;
	}
	seek(TEMPLATE, 0, 0);	# Rewind

	unless (open(NEW, ">$home/$new")) {
		&'add_log("cannot create $home/$new: $!");
		return 0;	# failed
	}

	# Start duplicating existing configuration
	while (<OLD>) {
		print NEW;			# Print line verbatim
	}
	close OLD;

	local(%missing);
	local($missing) = 0;

	# Look for possible new variables added since last configuration
	foreach $var (keys %known) {
		next if $var =~ /^p_/;				# Skip p_host examples
		$missing{$var}++ unless defined $seen{$var};
		$missing++ unless defined $seen{$var};
	}

	if ($missing) {
		local($s) = $missing == 1 ? '' : 's';
		&'add_log("adding $missing extra variable$s to ~/.mailagent...");
		print NEW <<EOM;

#
# Extra variables added to configuration -- version $'mversion PL$'patchlevel
#

EOM
	} else {
		close NEW;
		close TEMPLATE;
		&'add_log("existing configuration was up-to-date");
		unlink("$home/$new") || &'add_log("WARNING can't unlink $new: $!");
		return 1;	# OK
	}

	# Add all new variables. If they have configured defaults in setup.cf,
	# then use that. Otherwise, copy the line verbatim from the mailagent.cf
	# template. We propagate the "commented out" status as necessary.

	local($c, $var, $sp1, $sp2, $val, $comment);
	while (<TEMPLATE>) {
		if (
			($c, $var, $sp1, $sp2, $val, $comment) =
			/^(#?)(\w+)(\s*):(\s*)([^#\n]*)(#.*)?/
		) {
			next unless defined $missing{$var};
			if (defined $Var{$var}) {			# Has a computable default
				($val) = $val =~ m/(\s+)$/;		# Keep spaces before comment
				print NEW "$c$var$sp1:$sp2", &dflt($var), "$val$comment\n";
			} else {
				print NEW;		# No computable default, print verbatim
			}
		}
	}
	close NEW;
	close TEMPLATE;

	local($status) = 1;

	unless (rename("$home/$old", "$home/$bak")) {
		&'add_log("ERROR unable to rename $old into $bak: $!");
	} else {
		&'add_log("renamed $old into $bak");
	}

	unless (rename("$home/$new", "$home/$old")) {
		&'add_log("ERROR unable to intall new $old: $!");
		$status = 0;
	} else {
		&'add_log("new $old installed");
	}

	return $status;	# OK, unless ~/.mailagent not installed
}

# Check the current loaded configuration.
# We ensure all the required files/directories are there, and that the path
# setting on this machine is good enough to locate perl and mailagent.
sub cfset'load_check {
	package cfset;
	&'add_log("checking your configuration...");

	# Check file/directory existence and consistency...
	local($path);		# Computed value for given configuration parameter
	local($type);		# File/directory type
	foreach $var (keys %File) {
		eval '$path = $cf' . "'$var";
		&'add_log("ERROR in &cfset'check: $@") if chop($@);
		next if $@ ne '';
		$type = $File{$var};
		next unless $type;
		next if $path eq '' && $type =~ /^[fd]/;	# Missing, but optional
		$path = &'tilda_expand($path);
		if ($type =~ /^[fd]/) {
			&exists($path, $type, $var);	# Check existing file/dir
		} elsif ($path eq '') {
			&'add_log("ERROR mandatory parameter '$var' not defined");
		} else {
			&create($path, $type, $var);	# Create missing file/dir
		}
	}

	# Check home directory consistency...
	local($pwdhome) = $'test_mode ? $ENV{'HOME'} : (getpwuid($<))[7];
	unless ($pwdhome eq $cf'home) {
		&'add_log("WARNING home config parameter disagrees with /etc/passwd");
		&'add_log("home: $cf'home, /etc/passwd: $pwdhome");
	}

	# Make sure path setting is correct...
	&path_check;
	&path_check('mailagent');
	&path_check('perl');
}

# Get the setup.cf file, and create two data structures:
#   %Var:  indexed by variable name, yielding a perl expression to compute
#          the default value of that variable.
#   %File: indexed by variable name, yields whether it refers to a file
#          or a directory. Used to check-up the configuration.
# Return true on success.
sub cfset'load_read_setup {
	package cfset;
	unless (open(SETUP, "$privlib/setup.cf")) {
		&'add_log("cannot open $privlib/setup.cf: $!");
		return 0;	# failed
	}
	local($_);
	while (<SETUP>) {
		next if /^#/;			# Skip comments
		next if /^\s*$/;		# Skip blank lines
		if (/^(\w+)\s*:\s*(.*)/) {			# var: perl-expr
			$Var{$1} = $2;					# specifies a computation for var
		} elsif (/^(\w+)\s*=\s*(.*)/) {		# var= F file
			$File{$1} = $2;					# tells what $var points to
		} else {
			&'add_log("WARNING setup.cf file corrupted at line $.");
		}
	}
	close SETUP;
	return 1;		# OK
}

# Compute a default specified by the setup.cf file.
sub cfset'load_dflt {
	package cfset;
	local($var) = @_;
	local($perl) = $Var{$var};
	local($dflt);
	eval '$dflt = ' . $perl;
	&'add_log("ERROR while computing default for $var: $@") if chop($@);
	return $dflt;
}

# Check that a given file/directory is of the correct kind.
# Returns true if file/directory exists.
sub cfset'load_exists {
	package cfset;
	local($path, $type, $var) = @_;
	local($what) = $type =~ /^[Dd]/ ? 'directory' : 'file';
	local($prefix) = &prefix($path, $type);
	local($short) = &'tilda("$prefix/$path");
	unless (-e "$prefix/$path") {
		&'add_log("no $prefix/$path for $what '$var' yet") if $cf'level > 14;
		return 0;
	}
	&'add_log("checking $what '$var' at $prefix/$path") if $cf'level > 11;
	if ($type =~ /^[Dd]/) {
		&'add_log("ERROR $short is not a directory (variable $var)")
			unless -d "$prefix/$path";
	} else {
		&'add_log("ERROR $short is not a file (variable $var)")
			if -d "$prefix/$path";
	}
	return 1;		# Exists, but may be of the wrong type
}

# Create file/directory, using type sepcification from the setup.cf file.
sub cfset'load_create {
	package cfset;
	local($path, $type, $var) = @_;
	return if &exists($path, $type, $var);
	local($what) = $type =~ /^D/ ? 'directory' : 'file';
	local($file) = $type =~ /^\w\s*(.*)/;
	$file =~ s/\s*\(.*\)\s*//;		# Remove ($spool)-like location hints
	local($from) = $file ? "from default $file" : '(empty)';
	local($prefix) = &prefix($path, $type);
	local($target) = "$prefix/$path";
	$target =~ tr|/||s;				# If $path starts with /, $prefix is ''
	local($short) = &'tilda($target);
	&'add_log("creating mandatory $what $short $from for variable $var");
	if ($type =~ /^D/) {
		&'makedir($target);
	} else {
		local($dir, $base) = $target =~ m|(.*)/(.*)|;
		&'makedir($dir);
		unless (open(BASE, ">$dir/$base")) {
			&'add_log("ERROR cannot create $dir/$base: $!") if $cf'level;
			return;
		}
		if ($file && !open(FILE, "$privlib/$file")) {
			&'add_log("ERROR cannot open $privlib/$file: $!") if $cf'level;
		} else {
			local($_);
			while (<FILE>) {
				print BASE;
			}
			close FILE;
		}
		close BASE;
	}
}

# Compute suitable prefix to put in front of variable value before checking
# for file existence or performing creation. In the absence of specified
# prefix, the file is anchored under the home directory if it does not
# begin with a /.
#
# If a file is spefied as:
#        mailbox = f ($maildrop)
# in the setup.cf file, then it means the optional file is implicitely located
# under another configuration variable or specified path. Use that if necessary.
# Note that if a variable is specified, it is assumed to be a configuration
# variable and is therefore evaluated in the cf package. It is possible to
# fully qualify that name if necessary...
#
# Returns the suitable prefix (with ~ substitution).
sub cfset'load_prefix {
	package cfset;
	local($path, $type) = @_;	# Path, file type such as "f ($var)"
	local($prefix) = $type =~ /\((.*)\)/;	# Grab ($var) or (/usr/bin) prefix
	eval "package cf; \$cfset'prefix = \"$cfset'prefix\";" if $prefix;
	$prefix = '~' unless $prefix || $path =~ m|^/|;
	return $prefix ? &'tilda_expand($prefix) : '';
}

# Check path setting.
# Without any argument, simply checks that each path directory is correct.
# Otherwise, try to locate the argument within the path.
sub cfset'load_path_check {
	package cfset;
	local($prog) = @_;
	local($host) = &'hostname;
	$host =~ s/^(\w+).*/$1/;		# Trim domain name
	local($lpath);					# Value of local path (p_host)
	eval '$lpath = $cf' . "'p_$host";
	&'add_log("ERROR in cfset'path_check: $@") if chop($@);

	local($direxp);		# Expanded version of the directory
	local($found) = 0;
	foreach $dir (split(/:/, "$lpath:$cf'path")) {
		next if $dir eq '';
		$direxp = &'tilda_expand($dir);
		unless (defined $prog || -d $direxp) {
			&'add_log("WARNING path component '$dir' not found!");
		}
		if (defined $prog && -e "$direxp/$prog" && -x _ && !-d _) {
			$found++;
			last;
		}
	}
	&'add_log("WARNING cannot locate '$prog' in set-up path")
		if defined($prog) && !$found;
}

# Compute a suitable default path and return it. We try to include directories
# under the user home directory, and directories containing some programs
# like 'ls', 'pg', 'perl' and 'mailagent'.
# NB: This routine is not called directly but via setup.cf and &dflt.
sub cfset'load_default_path {
	package cfset;
	local($path) = '';		# The build-up path
	local($short);			# Path with tilda substitution
	foreach $dir (split(/:/, $ENV{'PATH'})) {
		next if $dir eq '' || $dir =~ /^\.\.?$/;
		$short = &'tilda($dir);
		if ($short ne $dir) {
			$path .= "$short:";
			next;
		}
		$path .= "$dir:" if &contains($dir, 'ls', 'pg', 'perl', 'mailagent');
	}
	chop($path);			# Remove trailing ':'
	return $path;
}

# Returns true if the specified dir exists, has the x bit set and contains
# one of the specified programs.
sub cfset'load_contains {
	package cfset;
	local($dir, @progs) = @_;
	return 0 if !-d $dir || !-x _;
	foreach $prog (@progs) {
		return 1 if -e "$dir/$prog" && -x _;
	}
	return 0;	# Not found
}

# Initialialize the base64 decoding values
sub base64'load_init {
	package base64;
	@values = (
	   # 0  1  2  3  4  5  6  7  8  9          0123456789
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            -  00 ->  09
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            -  10 ->  19
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            -  20 ->  29
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            -  30 ->  39

		-1,-1,-1,62,-1,-1,-1,63,             # ()*+'-./   -  40 ->  47
		52,53,54,55,56,57,58,59,60,61,       # 0123456789 -  48 ->  57
		-1,-1,-1,-1,-1,-1,-1, 0, 1, 2,       # :;<=>?@ABC -  58 ->  67
		 3, 4, 5, 6, 7, 8, 9,10,11,12,       # DEFGHIJKLM -  68 ->  77
		13,14,15,16,17,18,19,20,21,22,       # NOPQRSTUVW -  78 ->  87
		23,24,25,-1,-1,-1,-1,-1,-1,26,       # XYZ[\]^_`a -  88 ->  97
		27,28,29,30,31,32,33,34,35,36,       # bcdefghijk -  98 -> 107
		37,38,39,40,41,42,43,44,45,46,       # lmnopqrstu - 108 -> 117
		47,48,49,50,51,                      # vwxyz      - 118 -> 122

			  -1,-1,-1,-1,-1,-1,-1,-1,       #            - 123 -> 130
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 131 -> 140
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 141 -> 150
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 151 -> 160
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 161 -> 170
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 171 -> 180
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 181 -> 190
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 191 -> 200
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 201 -> 210
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 211 -> 220
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 221 -> 230
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 231 -> 240
		-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,       #            - 241 -> 250
		-1,-1,-1,-1,-1                       #            - 251 -> 255
	);
	$alphabet =
		"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
}

# Reset the encoder/decoder
# Must be called before invoking encode() or decode().
# Once called, one must ONLY invoke encode() or decode() but never intermix
# calls to these two routines.  To switch, one must invoke reset() again.
sub base64'load_reset {
	package base64;
	my ($len) = @_;
	&init unless $init_done++;
	my $data = " " x ($len || 64 * 1024);	# pre-extend
	$data = "";
	$output = \$data;
	$input = 0;
	$pad = 0;
	@byte = ();
	$offset = 0;
	undef $error;
	undef $op;
}

# Decode new data from the base64 stream
# Invoke as many times as necessary, until the end of the stream is reached.
# Call output() to actually fetch the decoded string.
sub base64'load_decode {
	package base64;
	my ($data) = @_;
	return if defined $error;		# Stop as soon as an error occurred
	$op = "d" unless defined $op;
	if ($op ne "d") {
		$error = "mixed decode() within encode() calls";
		return;
	}
	my $len = length $data;
	for (my $i = 0; $i < $len; $i++) {
		my $c = substr($data, $i, 1);
		my $v;
		if ($c eq '=') {
			$v = 0;
			if ($pad++ >= 2) {
				$error = "too much padding";
				return;
			}
		} else {
			$v = $values[ord($c)];
			if ($v < 0) {
				$error = "invalid character '$c'";
				return;
			}
		}

		# In the following picture, we represent how the 4 bytes of input,
		# each consisting of only 6 bits of information forming a base64 digit,
		# are concatenated back into 3 bytes of binary information.
		#
		# input digit      0     1      2      3
		#               <----><-----><-----><---->
		#              +--------+--------+--------+
		#              |01234501|23450123|45012345|
		#              +--------+--------+--------+
		# output byte      0        1        2

		if ($input == 0) {
			$byte[0] = $v << 2;
		} elsif ($input == 1) {
			$byte[1] = ($v & 0x0f) << 4;
			$byte[0] |= $v >> 4;
		} elsif ($input == 2) {
			$byte[2] = ($v & 0x03) << 6;
			$byte[1] |= $v >> 2;
		} else {
			$byte[2] |= $v;
			$input = -1;
			$$output .= chr($byte[0]) . chr($byte[1]) . chr($byte[2]);
		}
		$input++;
		$offset++;
	}
}

# Encode new data into the base64 stream
# Invoke as many times as necessary, until the end of the stream is reached.
# Call output() to actually fetch the encoded string.
sub base64'load_encode {
	package base64;
	my ($data) = @_;
	return if defined $error;		# Stop as soon as an error occurred
	$op = "e" unless defined $op;
	if ($op ne "e") {
		$error = "mixed encode() within decode() calls";
		return;
	}
	my $len = length $data;
	for (my $i = 0; $i < $len; $i++) {
		my $c = substr($data, $i, 1);
		my $v = unpack("C", $c);

		# In the following picture, we represent how the 3 bytes of input
		# are split into groups of 6 bits, each group being encoded as a
		# single base64 digit.
		#
		# input byte       0        1        2
		#              +--------+--------+--------+
		#              |01234501|23450123|45012345|
		#              +--------+--------+--------+
		#               <----><-----><-----><---->
		# output digit     0     1      2      3
		#
		# Every times we have 16 blocks of 4 chars, we emit a "\n" to avoid
		# too long lines.

		if ($input == 0) {
			$byte[0] = $v >> 2;
			$byte[1] = ($v & 0x3) << 4;
			$$output .= "\n" if $offset && 0 == $offset % 57;
		} elsif ($input == 1) {
			$byte[1] |= $v >> 4;
			$byte[2] |= ($v & 0xf) << 2;
		} else {
			$byte[2] |= $v >> 6;
			$byte[3] = $v & 0x3f;
			$input = -1;
			$$output .=
				substr($alphabet, $byte[0], 1) .
				substr($alphabet, $byte[1], 1) .
				substr($alphabet, $byte[2], 1) .
				substr($alphabet, $byte[3], 1);
			@byte = ();
		}
		$input++;
		$offset++;
	}
}

# Return a reference to the output of the encoded/decoded base64 stream
sub base64'load_output {
	package base64;
	return $output unless defined $op;	# Neither encode() nor decode() called
	if ($op eq 'd') {
		&'add_log("WARNING truncated base64 input (length = $offset)")
			if $input && $'loglvl > 2;
		$$output =~ s/\0*$//;
	} elsif ($op eq 'e') {
		my $pad = $offset % 3;
		if ($pad == 1) {
			$$output .=
				substr($alphabet, $byte[0], 1) .
				substr($alphabet, $byte[1], 1) . "==";
		} elsif ($pad == 2) {
			$$output .=
				substr($alphabet, $byte[0], 1) .
				substr($alphabet, $byte[1], 1) .
				substr($alphabet, $byte[2], 1) . "=";
		}
		$$output .= "\n";
	} else {
		&'add_log("ERROR unknown base64 operation '$op'") if $'loglvl;
	}
	return $output;
}

# Check whether output is valid so far
sub base64'load_is_valid {
	package base64;
	return defined($error) ? 0 : 1;
}

# Generate error message for non-valid base64
sub base64'load_error_msg {
	package base64;
	return "" unless defined $error;
	return "$error at offset $offset";
}

# Reset the encoder/decoder
# Must be called before invoking encode() or decode().
# Once called, one must ONLY invoke encode() or decode() but never intermix
# calls to these two routines.  To switch, one must invoke reset() again.
sub qp'load_reset {
	package qp;
	my ($len) = @_;
	my $data = " " x ($len || 64 * 1024);	# pre-extend
	$data = "";
	$output = \$data;
	$offset = 0;
	undef $error;
	undef $op;
}

# Decode new line from the quoted-printable stream
# Invoke as many times as necessary, until the end of the stream is reached.
# Call output() to actually fetch the decoded string.
sub qp'load_decode {
	package qp;
	local ($_) = @_;
	return if defined $error;		# Stop as soon as an error occurred
	$op = "d" unless defined $op;
	if ($op ne "d") {
		$error = "mixed decode() within encode() calls";
		return;
	}
	my $soft = 0;
	s/[ \t]+$//;					# Trailing white spaces
	$soft = 1 if s/^=$//;			# Soft line break
	$soft = 1 if s/([^=])=$/$1/;	# Soft line break, but not for trailing ==
	s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
	$$output .= $_;
	$$output .= "\n" unless $soft;
	$offset += length($_);
}

# Encode new line into the base64 stream
# Invoke as many times as necessary, until the end of the stream is reached.
# Call output() to actually fetch the encoded string.
sub qp'load_encode {
	package qp;
	local ($_) = @_;
	return if defined $error;		# Stop as soon as an error occurred
	$op = "e" unless defined $op;
	if ($op ne "e") {
		$error = "mixed encode() within decode() calls";
		return;
	}
	s/([^ \t\n!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~])/
		sprintf("=%02X", ord($1))/eg;
	# Trailing white space must be encoded or will be stripped at decode time
	s/([ \t]+)$/join('', map { sprintf("=%02X", ord($_)) } split('', $1))/egm;

	# Ensure lines are smaller than 76 chars
	# No one-liner here as we cannot break up =xx escapes!
	# The trick is to break after 73 chars (76 - 3) and then add 1 or 2 chars
	# if they are not '=', thereby ensuring we're not breaking up in the
	# middle of a sequence.

	while (length($_) >= 76) {
		my $str = substr($_, 0, 73);
		s/^.{73}//;
		$str .= $1 if substr($_, 0, 1) ne "=" && s/^(.)//;
		$str .= $1 if substr($_, 0, 1) ne "=" && s/^(.)//;
		$$output .= "$str=\n";
	}
	$$output .= $_ . "\n" if length $_;

	$offset += length $_;
}

# Return a reference to the output of the encoded/decoded base64 stream
sub qp'load_output {
	package qp;
	return $output unless defined $op;	# Neither encode() nor decode() called
	if ($op eq 'd') {
		# Nothing to be done
	} elsif ($op eq 'e') {
		$$output .= "\n" unless $$output =~ /\n$/s;
	} else {
		&'add_log("ERROR unknown quoted-printable operation '$op'") if $'loglvl;
	}
	return $output;
}

# Check whether output is valid so far
sub qp'load_is_valid {
	package qp;
	return defined($error) ? 0 : 1;
}

# Generate error message for non-valid base64
sub qp'load_error_msg {
	package qp;
	return "" unless defined $error;
	return "$error at offset $offset";
}

# Initialize constants
sub termios'load_init {
	package termios;
	# (configured and automatically generated section)
	$TIOCGWINSZ = 0x5413;	# The TIOCGWINSZ ioctl()
	$packfmt = 'SS';		# ws_row ws_col 
	$length = 8;			# sizeof(struct winsize)
	@fields = ('row', 'col', );
	# (end of configured section)

	$inited = 1;
}

# Decompile the winsize structure, returning (row, col)
sub termios'load_decompile {
	package termios;
	my ($buf) = @_;
	my @f = unpack($packfmt, $buf);
	my %win;
	foreach my $field (@fields) {
		next if $field eq 'pad';		# Padding just skipped over
		$win{$field} = shift @f;		# This field was decoded by unpack()
	}
	return ($win{'row'}, $win{'col'});
}

# Determine the tty size, returning (row, col).
# Returns () if we cannot determine the size due to missing termios.
# Returns an (error) if there was an error during size computation.
sub termios'load_size {
	package termios;
	my ($tty) = @_;
	&init unless $inited;
	return () unless defined $TIOCGWINSZ;	# No termios
	local *TTY;
	open(TTY, $tty) || return ("cannot open $tty: $!");
	my $win = ' ' x $length;
	my $res = ioctl(TTY, $TIOCGWINSZ, $win);
	close TTY;
	return ("ioctl(TIOCGWINSZ) on $tty failed: $!") unless defined $res;
	return decompile($win);
}

#
# End of dataloading section.
#

