#!/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.12 1995/09/15 13:54:28 ram Exp $
#
#  Copyright (c) 1990-1993, 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.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 = 'hostname';

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

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

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

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

# Current version number and patchlevel
$mversion = '3.0';
$patchlevel = '44';

# 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/lib/mailagent';

# News posting program
$inews = '/usr/bin/inews';

# Mail sending program
$mailer = '/usr/sbin/sendmail';

# 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
		local($*) = 1;
		$_ = 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;
	}
	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 PL$patchlevel\n";
		exit 0;
	}
	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)
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().
$agent_wait = "agent.wait";		# Waiting file for out-of-the-queue mails
$privlib = "$cf'home/../.." if $test_mode;	# Tests ran from test/out

$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 (!$run_queue) {				# Do not enter here if -q
	if (0 != &analyze_mail($file_name)) {	# Analyze the mail
		&add_log("ERROR while processing main message--queing it")
			if ($loglvl > 0);
		&queue_mail($file_name, 'fm');
		unlink $lockfile;
		exit 0;					# Do not continue
	} else {
		$file = $file_name;		# Never corrupt $file_name
		$file =~ s|.*/(.*)|$1|;	# Keep only basename
		$file = "<stdin>" if $file eq '';
		local($len) = 0 + $Header{'Length'};	# Force numeric value
		&add_log("FILTERED [$file] $len bytes") if $loglvl > 4;
	}
}

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;

	while (&pqueue) {			# Eventually process the queue
		sleep 30 if $sleep;		# Wait in case new mail arrives
	}
} 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'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; }

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

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_check { &auto_main'header_check; }
sub auto_main'header_check { &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; }

#
# Analyzing mail
#

sub main'init_special { &auto_main'init_special; }
sub auto_main'init_special { &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'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_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'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; }

#
# 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'fake_date { &auto_header'fake_date; }
sub auto_header'fake_date { &main'dataload; }

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

sub header'format { &auto_header'format; }
sub auto_header'format { &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'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'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; }

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

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

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

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

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

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'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 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'symdir_check { &auto_main'symdir_check; }
sub auto_main'symdir_check { &main'dataload; }

sub main'check_st_mode { &auto_main'check_st_mode; }
sub auto_main'check_st_mode { &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'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; }

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

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

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

# Load the calling function from DATA segment and call it. This function is
# called only once per routine to be loaded.
sub main'dataload {
	local($__packname__) = (caller(1))[3];
	$__packname__ =~ s/::/'/;
	local($__rpackname__) = $__packname__;
	local($__at__) = $@;
	$__rpackname__ =~ s/^auto_//;
	&perload'load_from_data($__rpackname__);
	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($pos) = $Datapos{$_[0]};			# Offset within DATA
	# Avoid side effects by protecting special variables which will be changed
	# by the dataloading operation.
	local($., $_, $@);
	$pos = &fetch_function_code unless $pos;
	die "Function $_[0] 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($*) = 1;
	die "End of file found while loading $_[0].\n" unless $body =~ /^\}$/;
	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($start) = 0;
	local($., $_);
	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{$_[0]};		# 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     426893
	                addr'match     426149
	             addr'simplify     425440
	                addr'valid     425140
	                  biff'all     433456
	                 biff'body     434366
	               biff'custom     431225
	              biff'default     433208
	               biff'format     441352
	              biff'headers     433937
	                   biff'mh     440038
	               biff'notify     430021
	                 biff'trim     436187
	             callout'flush     421110
	              callout'init     416269
	              callout'load     416844
	             callout'queue     418070
	               callout'run     419728
	              callout'save     421475
	             callout'spawn     422918
	       callout'spawn_agent     424090
	         callout'spawn_cmd     424467
	       callout'spawn_shell     424624
	           callout'trigger     419238
	                  cf'parse      30906
	                  cf'setup     447392
	               cfset'check     453770
	            cfset'contains     459090
	              cfset'create     456573
	        cfset'default_path     458543
	                cfset'dflt     455883
	              cfset'exists     456157
	                cfset'init     448549
	               cfset'merge     450617
	          cfset'path_check     457529
	          cfset'read_setup     455248
	           cmdenv'addpower     381518
	           cmdenv'haspower     382012
	            cmdenv'inituid     379905
	           cmdenv'rempower     381678
	            cmdenv'set_cmd     380970
	        cmdenv'wipe_powers     381839
	          cmdserv'delpower     373001
	           cmdserv'disable     379543
	          cmdserv'dispatch     353209
	         cmdserv'exec_help     360616
	         cmdserv'exec_perl     359341
	        cmdserv'exec_shell     354089
	           cmdserv'execute     352736
	            cmdserv'finish     378909
	           cmdserv'include     378318
	              cmdserv'init     343423
	              cmdserv'load     345557
	          cmdserv'newpower     370062
	           cmdserv'process     348839
	              cmdserv'root     379106
	       cmdserv'run_addauth     374799
	       cmdserv'run_approve     362668
	      cmdserv'run_delpower     372315
	       cmdserv'run_getauth     376452
	      cmdserv'run_newpower     369474
	        cmdserv'run_passwd     367074
	      cmdserv'run_password     366231
	         cmdserv'run_power     363187
	        cmdserv'run_powers     364600
	       cmdserv'run_release     364037
	       cmdserv'run_remauth     375625
	           cmdserv'run_set     377090
	       cmdserv'run_setauth     373980
	          cmdserv'run_user     368053
	           cmdserv'trusted     379246
	       cmdserv'user_prompt     377698
	   compress'add_compressor     327877
	         compress'compress     324130
	             compress'init     319801
	    compress'is_compressed     326887
	       compress'recompress     325460
	          compress'restore     325634
	       compress'uncompress     321338
	         context'autoclean     284153
	             context'clean     282233
	           context'default     281593
	            context'delete     283608
	               context'get     283458
	              context'init     281308
	              context'load     281739
	              context'save     282415
	               context'set     283308
	                 dbr'clean     261150
	            dbr'clean_file     262410
	               dbr'default     260665
	                dbr'delete     260443
	             dbr'hash_path     254219
	                  dbr'info     255641
	                 dbr'match     256908
	       dbr'recursive_clean     261389
	                dbr'update     258496
	                dynload'do     399294
	              dynload'load     396823
	             dynload'parse     397879
	               env'cleanup     444751
	                  env'init     442484
	                 env'local     443313
	               env'restore     444369
	                 env'setup     442859
	                 env'undef     443984
	                 env'unset     443757
	                extern'age     285559
	                extern'set     285374
	                extern'val     285149
	          getdate'dateconv     302414
	           getdate'dayconv     303244
	          getdate'daylcorr     304464
	            getdate'lookup     310252
	       getdate'lookup_init     305671
	          getdate'monthadd     304067
	          getdate'timeconv     303595
	    getdate'yy_err_recover     295983
	           getdate'yyerror     313320
	            getdate'yyinit     289392
	             getdate'yylex     304717
	           getdate'yyparse     296566
	              header'check     136053
	              header'clean     135458
	          header'fake_date     136848
	             header'format     137713
	               header'init     133446
	          header'normalize     137381
	               header'push     136544
	              header'reset     133669
	              header'valid     133985
	            header'warning     134692
	                hook'audit     335745
	              hook'deliver     336431
	              hook'hooking     337580
	                 hook'init     332662
	              hook'initvar     285937
	                 hook'perl     335157
	              hook'process     333082
	              hook'program     334458
	                hook'rules     334736
	                  hook'run     286843
	                 hook'type     333727
	              hook'unknown     334309
	             interface'add     288981
	             interface'new     287358
	           interface'reset     287590
	           interface'valid     288580
	                 lock'base      37061
	                  lock'dir      37183
	                 lock'file      36574
	              macro'domain     132210
	                macro'info     131940
	            macro'internet     132360
	                 macro'org     132093
	            macro'overload     133006
	                 macro'usr     404060
	             main'acs_rqst      34982
	         main'action_parse      48120
	              main'add_log      38417
	                main'after     190081
	          main'alarm_clock     172475
	      main'alter_execution     105797
	           main'alter_flow     191583
	         main'alter_header     181347
	          main'alter_value     183882
	         main'analyze_mail      58047
	      main'annotate_header     183036
	                main'apply     163388
	          main'apply_match     110456
	          main'apply_rules      62290
	                 main'biff     429551
	               main'bounce     160142
	         main'builtin_path     231753
	           main'builtin_rr     231352
	        main'catch_signals     415748
	                 main'cdir     342836
	        main'check_st_mode     342357
	            main'checklock      41996
	        main'compile_rules     232805
	        main'complete_list     192757
	main'contextual_operations     284936
	        main'default_rules     236879
	                   main'do     188793
	             main'do_abort     192458
	            main'do_reject     192064
	           main'do_restart     192260
	          main'domain_addr      25708
	            main'dump_mbox     271209
	           main'dump_rules     237756
	           main'email_addr      25342
	            main'emergency     268572
	       main'emergency_save     270490
	           main'empty_body     196901
	                main'error     250097
	           main'eval_error      28806
	            main'eval_expr     252075
	             main'evaluate     253822
	           main'exact_rule     237638
	              main'execute     250644
	      main'execute_command     173456
	  main'expr_selector_match     112862
	                main'fatal     268853
	            main'feed_back     177723
	            main'file_edit     389654
	          main'file_secure     338273
	           main'fork_child      27857
	              main'forward     158815
	            main'free_file      37450
	               main'gensym     400562
	           main'get_action      47291
	    main'get_configuration      18935
	             main'get_line      43298
	             main'get_mode      44158
	          main'get_pattern      45396
	         main'get_selector      44648
	              main'getdate     311907
	        main'handle_output     176036
	        main'header_append      56991
	         main'header_check      54344
	         main'header_found     138868
	       main'header_prepend      57226
	        main'header_resync     179840
	       main'history_record     266687
	          main'history_tag     264200
	             main'hostname     315596
	         main'include_file     313755
	             main'init_all      19286
	        main'init_builtins     231183
	       main'init_constants      19786
	             main'init_env      21778
	          main'init_filter      78220
	     main'init_interpreter     248957
	         main'init_matcher     107308
	       main'init_pseudokey      21946
	         main'init_special      57528
	        main'internet_info     126670
	               main'jobnum      29012
	            main'last_name     126320
	                main'leave     139454
	           main'list_queue     273739
	          main'locate_file     122924
	           main'login_name     125191
	                main'macro     152444
	         main'macros_subst     127775
	            main'mail_back     176377
	         main'mailbox_name      26365
	         main'make_pattern     108392
	              main'makedir     268022
	                main'match     109403
	           main'match_list     118346
	         main'match_single     116282
	            main'match_var     119307
	            main'mbox_lock      22619
	            main'mbox_mail     279298
	          main'mbox_unlock      24800
	              main'message     153783
	               main'mrange     122128
	                   main'mv     224611
	           main'myhostname     315382
	               main'notify     154110
	           main'once_check     266902
	        main'parse_address     124142
	           main'parse_mail      50370
	                 main'perl     185051
	         main'perl_pattern     107963
	               main'plural     314918
	         main'popen_failed     172102
	                 main'post     161155
	               main'pqueue     226500
	           main'print_rule     241696
	    main'print_rule_number     237355
	              main'process     145349
	             main'push_val     250293
	                    main'q     332548
	                main'qmail     217563
	           main'queue_mail     219296
	          main'read_config      29456
	        main'read_filerule      42841
	        main'read_linerule      43052
	           main'read_stats     197808
	            main'reception      73041
	         main'report_stats     207528
	              main'require     187790
	        main'reset_backref     120965
	               main'resync     272527
	           main'right_mode      69491
	         main'rule_cleanup     237177
	            main'run_abort      85790
	            main'run_after     100634
	         main'run_annotate      94860
	            main'run_apply      99717
	           main'run_assign      95185
	             main'run_back      90072
	             main'run_beep     101550
	            main'run_begin      86120
	             main'run_biff     102545
	           main'run_bounce      87780
	         main'run_builtins     231983
	          main'run_command      75258
	           main'run_delete      84195
	               main'run_do     101190
	             main'run_feed      89454
	          main'run_forward      87472
	             main'run_give      88912
	             main'run_keep      94604
	            main'run_leave      82581
	            main'run_macro      84381
	          main'run_message      84634
	              main'run_nop      94232
	           main'run_notify      84982
	             main'run_once      91288
	             main'run_pass      89181
	             main'run_perl      98989
	             main'run_pipe      88642
	             main'run_post      88080
	          main'run_process      81806
	          main'run_protect     101900
	           main'run_purify      89726
	            main'run_queue      98571
	           main'run_record      86389
	           main'run_reject      85472
	          main'run_require      99296
	          main'run_restart      85631
	           main'run_resync      85946
	              main'run_run      88376
	             main'run_save      83003
	           main'run_saving     103539
	           main'run_select      92637
	           main'run_server      82068
	            main'run_split      96257
	            main'run_store      83156
	            main'run_strip      94344
	            main'run_subst      96102
	               main'run_tr      95947
	            main'run_umask     100155
	           main'run_unique      86940
	         main'run_vacation      97654
	            main'run_write      83847
	             main's_action     203747
	            main's_default     203192
	             main's_failed     203916
	           main's_filtered     202886
	              main's_match     203039
	            main's_noretry     204288
	               main's_once     204125
	              main's_saved     203489
	               main's_seen     203622
	           main's_vacation     203341
	          main'same_device     226076
	                 main'save     140036
	          main'save_folder     141774
	            main'save_hook     145078
	            main'save_mail     193455
	         main'save_message     106576
	    main'seconds_in_period     248140
	       main'selector_match     115010
	         main'send_message     154956
	         main'send_receipt     229337
	        main'set_functions     249609
	       main'set_priorities     249387
	        main'shell_command     170436
	         main'special_user      70833
	                main'split     164464
	           main'stderr_log      38772
	           main'stdout_log      39171
	         main'symdir_check     340930
	        main'symdir_secure     340042
	                main'tilda      26041
	         main'tilda_expand     406868
	           main'trace_dump     197321
	           main'track_rule      73555
	       main'update_backref     121428
	         main'update_stack     251349
	                main'usage      17912
	              main'usr_log      40154
	            main'void_func     237522
	         main'waiting_mail     223951
	          main'write_stats     200018
	             main'xeq_back     179378
	                main'xeqte      74002
	                mbox'flush     280842
	         mbox'flush_blanks     280492
	         mbox'flush_buffer     280669
	                mh'new_msg     410791
	                mh'profile     409857
	                   mh'save     407232
	               mh'save_msg     408176
	                mh'savedir     407896
	                 mh'seqadd     414603
	                 mh'unseen     412578
	                mmdf'chmod     319316
	       mmdf'force_flushing     318423
	              mmdf'is_mmdf     318628
	                 mmdf'save     315970
	            mmdf'save_mmdf     316465
	            mmdf'save_unix     317536
	               newcmd'load     328460
	                newcmd'run     330614
	                   opt'get     445041
	                 opt'parse     446933
	                 opt'reset     446007
	               opt'restore     446377
	           power'add_alias     386401
	            power'add_auth     385438
	             power'add_log     389361
	            power'authfile     384445
	          power'authorized     382954
	           power'del_alias     386711
	            power'getpwent     387926
	               power'grant     382250
	            power'rem_auth     385707
	            power'rempwent     388850
	            power'set_auth     384986
	          power'set_passwd     387087
	            power'setpwent     388489
	          power'used_alias     386016
	               power'valid     383849
	           rules'alternate     246618
	            rules'cache_ok     244591
	             rules'hashkey     246167
	          rules'read_cache     243465
	         rules'write_cache     242272
	            rules'write_fd     245248
	         rules'writevar_fd     245801
	          stats'diff_rules     204605
	          stats'fill_stats     206320
	         stats'print_array     202647
	      stats'print_commands     212650
	       stats'print_general     211509
	        stats'print_header     215601
	 stats'print_rules_summary     214745
	         stats'print_stats     209821
	       stats'print_summary     210900
	          stats'rule_stats     216493
	        stats'uniform_rule     214342
	             usrlog'delete      39912
	                usrlog'new      39459
	          usrlog'write_log      40480
	              usrmac'cache     406561
	             usrmac'delete     402832
	               usrmac'init     401016
	                usrmac'new     402005
	                usrmac'pop     402442
	               usrmac'push     401537
	            usrmac'restore     403575
	               usrmac'save     403268
	          usrmac'sub_const     404964
	           usrmac'sub_expr     404808
	             usrmac'sub_fn     405293
	           usrmac'sub_prog     405684
	          usrmac'sub_progc     406176
	         usrmac'sub_scalar     404665
	                 utmp'init     427588
	               utmp'reload     428395
	                 utmp'ttys     429095
	               utmp'update     428130

#
# 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 [-dhilqtFIV] [-s{umary}] [-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 : sepcify 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.
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;
	require 'ctime.pl';
	# 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 = 02;				# Writable by world (no .ph files here)
	$S_IWGRP = 020;				# Writable by group

	# 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
	$NO_FEEDBACK = 0;			# No feedback wanted
	$FEEDBACK = 1;				# Feed result of command back into %Header

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

	# 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) = &ctime(time);
	$now =~ s/\s(\d:\d\d:\d\d)\b/0$1/;	# Add leading 0 if hour < 10
	chop($now);
	$FAKE_FROM = "From mailagent " . $now;

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

# 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,
		'Head', 1,
		'All', 1
	);
}

# 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.
sub main'load_email_addr {
	package main;
	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
sub main'load_domain_addr {
	package main;
	local($_);							# Our host name
	$_ = $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 = "/usr/spool/mail";		# Default spooling area
		-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+//;
		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
		local($*) = 1;
		$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//g;		# Remove added ~ substitutions
		$eval =~ s/^\$//g;						# Remove leading '$'
		$eval =~ s/ = "(.*)";/: $1/g;			# 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' 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 = 'compress' unless defined $comptag;
	$locksafe = 'ON' unless defined $locksafe;

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

	$umask = oct($umask) if $umask =~ /^0/;	 # Translate umask into decimal

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

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

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

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

	1;		# Ok
}

# 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.
sub main'load_acs_rqst {
	package main;
	local($file, $format) = @_;		# file to be locked, lock format
	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 defined $format;
	while ($max) {
		$max--;
		if (-f $lockfile) {
			sleep($delay);				# busy: wait
			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
			sleep($delay);				# busy: wait
		}
	}
	if ($max) {
		$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);

	local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
		localtime(time);
	$date = sprintf("%.2d/%.2d/%.2d %.2d:%.2d:%.2d",
		$year,++$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
		$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($_);
	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;
	}
	$Userpath = "";					# Reset path from possible previous @PATH 

	# Pre-extend 'All', 'Body' and 'Head'
	$Header{'All'} = ' ' x 5000;
	$Header{'Body'} = ' ' x 4500;
	$Header{'Head'} = ' ' x 500;
	$Header{'All'} = '';
	$Header{'Body'} = '';
	$Header{'Head'} = '';

	&add_log ("parsing mail") if $loglvl > 18;
	while (<$fd>) {
		$Header{'All'} .= $_;
		if (1../^$/) {						# EOH is a blank line
			next if /^$/;					# Skip EOH marker
			$Header{'Head'} .= $_;			# Record line in header

			if (/^\s/) {					# It is a continuation line
				s/^\s+/ /;					# Swallow multiple spaces
				chop;						# Remove final new-line
				$Header{$last_header} .= "\n$_" if $last_header ne '';
				&add_log("WARNING bad continuation in header, line $.")
					if $last_header eq '' && $loglvl > 4;
			} elsif (/^([\w-]+)\s*:\s*(.*)/) {	# We found a new header
				# 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.
				($field, $value) = ($1, $2);	# Bug in perl 5.000 (dataloaded)
				$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 {
			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;
	&header_check($first_from, $lines);	# Sanity checks
}

# 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)
#
# We guarantee the following header entries:
#   From:         the value of the From field
#   To:           to whom the mail was sent
#   Lines:        number of lines in the message
#   Length:       number of bytes in the message
#   Reply-To:     the address we may use to reply
#   Sender:       the value of the Sender field, same as From usually
#   Envelope:     the actual sender of the message, empty if cannot compute
#
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.
	local($*) = 1;
	foreach $field ('Apparently-To', 'To', 'Cc') {
		$Header{$field} =~ s/\n/,/g;	# Remove new-lines
		$Header{$field} =~ s/,$/\n/;	# Restore last new-line
	}
	$* = 0;

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

	# Set number of lines in body, unless there is already a Lines:
	# header in which case we trust it. Same for Length.
	$Header{'Lines'} = $lines unless defined($Header{'Lines'});
	$Header{'Length'} = $length unless defined($Header{'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;
}

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

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

# 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

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

	# Parse the mail message in file
	&parse_mail($file);			# Parse the mail and fill-in H tables
	return 0 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($*) = 0;
		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
				$* = 1;
				# Remove that X-Filter line, LEAVE will add one anyway
				$Header{'Head'} =~ s/^X-Filter:\s*mailagent.*for $address\n//;
				$* = 0;
				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
		}
	}

	&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
	local(%Variable);			# User-defined variables

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

# 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 another 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");
	&add_log("VIA $sender") if $sender ne '' &&
		(&parse_address($sender))[0] ne (&parse_address($from))[0];
	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($lastcmd) = 0;			# Failure status from last 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) = $file_name =~ m|.*/(.*)|;	# Basename of mail file
	$mfile = $file_name unless $mfile;			# There was no / in name
	$mfile = '<stdin>' unless $mfile;			# No $file_name if from STDIN
	&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
		'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',
		'BIFF',		'l',
		'MACRO',	'rdp',
		'POST',		'l',
		'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,
		'NOP', 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
	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;
	&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
	$newstate = 'INITIAL' unless $newstate;
	$wmode = $newstate;			# $wmode comes from analyze_mail
	&add_log("BEGUN new 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
		$wmode = '_SEEN_';		# Enter special mode ($wmode from analyze_mail)
		&add_log("NOTICE entering seen mode") if $loglvl > 5;
		&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
	local($failed) = &shell_command($program, $MAIL_INPUT, $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
	local($failed) = &shell_command($program, $MAIL_INPUT, $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 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

	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;
	&add_log("NOP [$mfile]") if $loglvl > 7;
	0;
}

# 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?
	} else {
		$eval = $value;					# Leading and trailing ' trimmed
	}
	$value = $eval if $eval && $@ eq '';
	if ($var =~ s/^://) {
		&extern'set($var, $value);		# Persistent variable is set
	} else {
		$Variable{$var} = $value;		# User defined variable is set
	}
	&add_log("ASSGINED '$value' to '$var' [$mfile]") if $loglvl > 7;
	0;
}

# Run the TR command
sub main'load_run_tr {
	package main;
	local($variable, $tr) = $cms =~ m|^(#?:?\w+)\s+(.*)|;
	&alter_value($variable, "tr$tr");
}

# Run the SUBST command
sub main'load_run_subst {
	package main;
	local($variable, $s) = $cms =~ m|^(#?:?\w+)\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
		$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 '') {
		$wmode = $mode;
		&add_log("entering new state $wmode") if $loglvl > 6;
	}
	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 = (
		'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',
	);
	%Amatcher = (
		'From',				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. If the pattern starts with a
# leading /, nothing is done. Otherwise, a set of / are added.
# match (1st case).
sub main'load_make_pattern {
	package main;
	local($_) = shift(@_);
	unless (m|^/|) {				# Pattern does not start with a /
		$_ = &perl_pattern($_);		# Simple words specified via shell patterns
		$_ = "/^$_\$/";				# Anchor pattern
	}
	# 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.
	s|^/(.*)/|/($1)/|;		# Enclose whole pattern within ()
	$_;						# 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"
		local(@filepat) = &include_file($pattern, 'pattern');
		# 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. Otherwise, the field is left alone.
	# Of course, 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
		$buffer = (&parse_address($buffer))[0] if $pattern =~ m|^/\^|;
		if ($pattern =~ m|^[-\w.*?]+\s*$|) {	# Single name may have - or .
			$buffer = (&parse_address($buffer))[0];
			$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
	if ($range ne '<1,->') {			# Optimize: count lines only if needed
		$lines = $Header{$selector} =~ tr/\n/\n/;
	}
	local($min, $max) = &mrange($range, $lines);
	return 0 unless $min;				# No matching possible if null range
	local($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/, $Header{$selector});
		@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
	} else {
		$buffer = $Header{$selector};
	}
	$* = 1;								# Multi-line matching is attempted
	@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
	$* = 0;
	$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.
sub main'load_mrange {
	package main;
	local($range, $items) = @_;
	local($min, $max) = (1, 9_999_999);
	local($rmin, $rmax) = $range =~ /<\s*([\d-]*)\s*,\s*([\d-]*)\s*>/;
	$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;
}

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

# Extract last name from a login name like First_name.Last_name and put it
# in lowercase. Hence, Raphael.Manfredi will become manfredi. Since '_' or '.'
# characters could be legitimely used in a login name (or distribution list),
# we remove it only when followed by an upper-cased letter.
sub main'load_last_name {
	package main;
	local($_) = shift(@_);			# The sender's login name
	s/.*\.([A-Z]\w*)/$1/;			# Keep only the last name (. separation)
	s/.*_([A-Z]\w*)/$1/;			# Same as above (_ separation)
	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 . $mydomain 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(/\./, $mydomain)) if @parts == 1;
	}
	unshift(@parts, '') if @parts == 2;		# No host name
	@parts[($#parts - 2) .. $#parts];		# ($host, $domain, $country)
}

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

	# 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/g;					# Year (last two digits)
	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', &fake_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
sub header'load_fake_date {
	package header;
	require 'ctime.pl';
	local($date) = &'ctime(time);
	# Traditionally, MTAs add a ',' right after week day
	# Moreover, RFC-822 and RFC-1123 require a leading 0 if hour < 10
	$date =~ s/^(\w+)(\s)/$1,$2/;
	$date =~ s/\s(\d:\d\d:\d\d)\b/0$1/;
	chop($date);					# Ctime adds final new-line
	$date;
}

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

# Format header field to fit into 78 columns, each continuation line being
# indented by 8 chars. Returns the new formatted header string.
sub header'load_format {
	package header;
	local($field) = @_;			# Field to be formatted
	local($tmp);				# Buffer for temporary formatting
	local($new) = '';			# Constructed formatted header
	local($kept);				# Length of current line
	local($len) = 78;			# Amount of characters kept
	local($cont) = ' ' x 8;		# Continuation lines starts with 8 spaces
	# 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
		$tmp =~ s/\s*$//;					# Remove trailing spaces
		$tmp =~ s/^\s*//;					# Remove leading spaces
		$new .= $cont if $new;				# Continuation starts with 8 spaces
		$len = 70;							# Account continuation for next line
		$new .= "$tmp\n";
		$field = substr($field, $kept, 9999);
	}
	$new .= $cont if $new;					# Add 8 chars if continuation
	$new .= $field;							# Remaining information on one line
}

# 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
	unless ($mailbox) {				# Empty mailbox (e.g. SAVE %1 with no match)
		&add_log("WARNING empty folder name, using mailbox") if $loglvl > 5;
		$mailbox = &mailbox_name;
	}
	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/;
			# 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$$";
		$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 '/bin/sh', "$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, $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 ($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) = &email_addr;	# 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(@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";
	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;
	}
	# 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";
	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($address) = &email_addr;	# Address of user
	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;
	# Protect Sender: lines in the original message and clean-up header
	local($last_was_header);		# Set to true when header is skipped
	foreach (split(/\n/, $Header{'Head'})) {
		s/^Sender:\s*(.*)/Prev-Sender: $1/;
		next if /^From\s/;					# First From line...
		if (
			/^To:/ ||
			/^Cc:/ ||
			/^Apparently-To:/ ||
			/^Distribution:/ ||				# No mix-up, please
			/^X-Mailer:/ ||					# Mailer identification
			/^Newsgroups:/ ||				# Reply from news reader
			/^Return-Receipt-To:/ ||		# Sendmail's acknowledgment
			/^Received:/ ||					# We want to remove received
			/^Errors-To:/ ||				# Error report redirection
			/^Resent-[\w-]*:/				# Resent tags
		) {
			$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
		print NEWS $_, "\n";
	}
	# 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";
	}
	# 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 "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;
	}
	$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) {
		&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
}

# Execute the command, ran in an eval to protect against SIGPIPE signals
sub main'load_execute_command {
	package main;
	local($program, $input, $feedback) = @_;
	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 == $FEEDBACK) {	# Need trace if feedback
				kill 'SIGPIPE', $ppid;		# Parent still waiting
				exit 1;
			}
		}
		open(STDERR, ">&STDOUT");			# Make it follow pipe
		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 body
		print WRITE $Header{'Body'};
	} elsif ($input == $MAIL_INPUT) {		# Pipes the whole mail
		print WRITE $Header{'All'};
	} 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 == $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
	} elsif ($feedback == $FEEDBACK) {
		&feed_back;						# 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;
	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 .= $_;
			}
		}
		$Header{'Head'} = $head;
	}
	close TRACE;
	$Header{'Body'} = $temp unless $input == $HEADER_INPUT;
	$Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'};
}

# 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 'All' 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};
	}
	# There is some code duplication with parse_mail()
	local($lines) = 0;
	local($first_from);						# First From line records sender
	local($last_header);					# Current normalized header field
	local($in_header) = 1;					# Bug in the range operator
	local($value);							# Value of current field
	foreach (split(/\n/, $Header{'All'})) {
		if ($in_header) {					# Still in header of message
			$in_header = 0 if /^$/;			# End of header
			if (/^\s/) {					# It is a continuation line
				s/^\s+/ /;					# Swallow multiple spaces
				$Header{$last_header} .= "\n$_" if $last_header ne '';
			} elsif (/^([\w-]+):\s*(.*)/) {	# We found a new header
				$value = $2;				# Bug in perl 4.0 PL19
				$last_header = &header'normalize($1);
				# Multiple headers like 'Received' are separated by a new-
				# line character. All headers end on a non new-line.
				if ($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 {
			$lines++;						# One more line in body
		}
	}
	&header_check($first_from, $lines);	# 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/^([\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'};
}

# 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'fake_date . "\n" unless $opt'sw_d;
	$annotation .= &header'format("$field: $value") . "\n" if $value;
	&header_append($annotation);	# Add field into %Header
	0;
}

# The "TR" and "SUBST" commands
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 . ']';
	} 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;
	}

	# 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 'shellwords.pl';
	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($cmd_cmd) = $opt'sw_c;
	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 '') {
		$wmode = $mode;
		&add_log("entering new state $wmode") if $loglvl > 6;
	}
	&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(*ROncem, "%@");		# 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;
	require 'ctime.pl';
	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) = &'ctime($lasttime);
	local($now) = &'ctime($current_time);
	local($n, $s);
	chop $now;
	chop $last;
	# 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;
	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" if -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") if $loglvl > 0;
		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($status) = 0;
	if (open(WAITING, ">>$agent_wait")) {
		if (print WAITING "$tmp_queue\n") {
			$status = 1;			# Mail more or less safely queued
			&add_log("NOTICE processing deferred for $tmp_queue")
				if $loglvl > 3;
		} else {
			&add_log("ERROR could not record $tmp_queue in $agent_wait")
				if $loglvl > 1;
		}
		close WAITING;
	} else {
		&add_log("ERROR unable to open $agent_wait") if $loglvl > 0;
		&add_log("WARNING left mail in $tmp_queue") if $loglvl > 1;
	}
	$status;		# 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") if $loglvl;
		return 1;
	}
	unless (open(TO, ">$to")) {
		&add_log("SYSERR open: $!") if $loglvl;
		&add_log("ERROR cannot open target $to") 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|, @dir);
	local(@filter_files) = grep(s|^qm|$cf'queue/qm|, @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.
	if (-f "$cf'queue/$agent_wait") {
		if (open(WAITING, "$cf'queue/$agent_wait")) {
			while (<WAITING>) {
				chop;
				push(@files, $_);		# Process this file too
				$waiting{$_} = 1;		# Record it comes from waiting file
			}
			close WAITING;
		} else {
			&add_log("ERROR cannot open $cf'queue/$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
		}
		if (0 == &analyze_mail($file_name)) {
			unlink $file;
			++$processed;
			$waiting{$file} = 0 if $waiting{$file};
			$file =~ s|.*/(.*)|$1|;	# Keep only basename
			$length = $Header{'Length'};
			&add_log("FILTERED [$file] $length bytes") if $loglvl > 4;
		} else {
			$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("was unable to process queue") if $loglvl > 5;
	}
	&resync;			# Resynchronize waiting file
	$processed;			# Return the number of files processed
}

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

	# Compute host name (fully qualified, i.e. with domain name)
	chop($hostname = `$phostname`);
	$hostname .= $mydomain if $hostname =~ /^\w+$/;

	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.
	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 (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;
		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
}

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

# 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

	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
}

# 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 defined(@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 defined(@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("WARNING cannot open directory $dir: $!") if $'loglvl > 5;
		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("WARNING cannot re-open directory $dir: $!") if $'loglvl > 5;
		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("WARNING cannot open file $file: $!") if $'loglvl > 5;
		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 ID stored within <> brackets
		($msg_id) = $msg_id =~ m|^<(.*)>\s*$|;
	} 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++;
		} else {					# Record message (appending)
			&dbr'update($host, 'HISTORY', 0, @regexp);
		}
	}
	return $seen;					# Return seen status
}

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

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

# In case something got wrong
sub main'load_fatal {
	package main;
	local($reason) = shift;		# Why did we get here ?
	# 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;
	}
	unless (-t $fd) {			# Do not get mail if connected to a tty
		while (<$fd>) {
			$Header{'All'} .= $_;
		}
	}
	# It can happen that we get here before configuration file was read
	if (defined $loglvl) {
		&add_log("FATAL $reason") if $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,++$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;
}

# Resynchronizes the waiting file if necessary (i.e if it exists and %waiting
# is not an empty array).
sub main'load_resync {
	package main;
	local(@key) = keys %waiting;	# Keys of H table are file names
	local($ok) = 1;					# Assume resync is ok
	local($printed) = 0;			# Nothing printed yet
	return if $#key < 0 || "$cf'queue" eq '' || ! -f "$cf'queue/$agent_wait";
	&add_log("resynchronizing the waiting file") if $loglvl > 11;
	if (open(WAITING, ">$cf'queue/$agent_wait~")) {
		foreach (@key) {
			if ($waiting{$_}) {
				print WAITING "$_\n" || ($ok = 0);
				$printed = 1;
			}
		}
		close(WAITING) || ($ok = 0);
		if ($printed) {
			if (!$ok) {
				&add_log("ERROR could not update waiting file") if $loglvl;
				unlink "$cf'queue/$agent_wait~";
			} elsif (rename("$cf'queue/$agent_wait~","$cf'queue/$agent_wait")) {
				&add_log("waiting file has been updated") if $loglvl > 18;
			} else {
				&add_log("ERROR cannot rename waiting file") if $loglvl;
			}
		} else {
			unlink "$cf'queue/$agent_wait";
			unlink "$cf'queue/$agent_wait~";
			&add_log ("removed waiting file") if $loglvl > 18;
		}
	} else {
		&add_log("ERROR unable to write new waiting file") if $loglvl;
	}
}

# 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!, @dir);
	undef @dir;
	if (-f "$cf'queue/$agent_wait") {
		if (open(WAITING, "$cf'queue/$agent_wait")) {
			while (<WAITING>) {
				chop;
				push(@files, $_);
			}
			close WAITING;
		} else {
			&add_log("ERROR cannot open $cf'queue/$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;
		}
		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
	require 'ctime.pl';
	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 " . &'ctime(time);
	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);
	# The following 'do' usage fixes up a weird parsing bug with perl5.001,
	# whilst remaining compatible with perl4. Thanks to ukai@hplj.hpl.hp.com
	do 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'};
:	$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);
:	# 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 < 100) {
		$yy += 1900;
	}
	$mdays[1] =
		28 + (($yy % 4) == 0 && (($yy % 100) != 0 || ($yy % 400) == 0));
	if ($yy < $epoch || $yy > 2001 || $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+)/) {
				$yylval = eval "$1 * $sign";
				$dtstr =~ s/^\d+//;
				return $NUMBER;
			}
			else {
				return &yylex;
			}
		}
		elsif ($dtstr =~ /^(\d+)/) {
			$yylval = eval "$1";
			$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 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 iwht 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
			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
		$_ = '.*/'.$_ unless m|^/|;	# Focus on basename unless absolute path
		push(@compress, $_);		# Record pattern
	}
	close COMPRESS;

	unless (open(COMPSPEC, "$cf'compspec")) {
		# Configure a set of defaults if the user hasn't specified them manually
#compress	.Z	compress	uncompress	zcat
		&add_compressor(<<'EOT');
gzip		.gz	gzip		gunzip		gunzip -c
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 defined @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 'shellwords.pl';
	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($_) = @_;
	local($*) = 1;
	s/^://g;
	$_;
}

# 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;
	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;
	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;
	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;
	# 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.
sub main'load_file_secure {
	package main;
	local($file, $type) = @_;	# File to be checked
	return 1 unless -e $file;	# Missing file considered secure
	if (-l $file) {				# File is a symbolic link
		&add_log("WARNING sensitive $type file $file is a symbolic link")
			if $loglvl > 5;
		return 0;		# Unsecure file
	}
	local($ST_MODE) = 2 + $[;	# Field st_mode from inode structure
	unless (-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 is world writable!") if $loglvl > 5;
		return 0;		# Unsecure file
	}

	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) {
		&add_log("WARNING $type file is group writable!") if $loglvl > 5;
		return 0;		# Unsecure file
	}
	local($dir);		# directory where file is located
	$dir = '.' unless ($dir) = ($file =~ m|(.*)/.*|);
	unless (-O $dir) {
		&add_log("WARNING you do not own directory of $type 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
}

# 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
	return 0 if $level++ > $MAX_LINKS;
	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
}

# 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 of $type file $dir is world writable!")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}
	return 1 unless $both;
	if ($st_mode & $S_IWGRP) {
		&add_log("WARNING directory of $type file $dir is group writable!")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}
	1;
}

# 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
	unless (open(MAILER, "|$cf'sendmail $cf'mailopt $cmdenv'uid $metoo")) {
		&'add_log("ERROR cannot start $cf'sendmail to 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
	unless (close MAILER) {
		&'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
		}
	}

	# 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);
	$redirect = "<$input" if $input;
	local(@argv) = split(' ', $cmdenv'cmd);
	local($extra) = $Extra{$cmdenv'name};
	$argv[0] = $Path{$cmdenv'name} if defined $Path{$cmdenv'name};
	(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
		exec "sh $cmdfile";			# Don't let perl use sh -c
		&'add_log("SYSERR exec: $!") if $'loglvl;
		&'add_log("ERROR cannot exec /bin/sh $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 which collect input until an eof mark are marked 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";
		return 1;
	}
	return 0 if 0 == &power'set_passwd($name, $new);
	print MAILER "Could not change password, sorry.\n";
	1;
}

# 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)) {
		print MAILER "Permission denied (lacks authorization).\n";
		return 1;
	}
	unless (&power'valid($name, $old)) {
		print MAILER "Permission denied (invalid pasword).\n";
		return 1;
	}
	return 0 if 0 == &power'set_passwd($name, $new);
	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 (defined %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";
	}
	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;
	}
	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.
sub cmdserv'load_run_set {
	package cmdserv;
	local($x, $var, @args) = split(' ', $cmdenv'cmd);
	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
	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
}

# 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 defined %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{$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 defined %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 defined %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 defined %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 defined %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;
	}

	require 'ctime.pl';
	print CALLOUT "# Mailagent callout queue, last updated " . &'ctime(time);

	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/adm/utmp';
	$packfmt = 'x8A12x8A8x20';		# ..pad.. ut_line[] ..pad.. ut_name[] ..pad.. 
	$length = 56;					# 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;
	require 'stat.pl';
	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;
	foreach $tty (@ttys) {
		&biff'notify($tty, $folder, $type);
	}
}

# 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

	&'add_log("biffing $cf'user on $tty") 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

	unless (open(TTY, ">$tty")) {
		&'add_log("ERROR cannot open $tty: $!") if $'loglvl;
		&'add_log("WARNING unable to biff for $folder ($type)") 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

	local(@head) = ('From', 'To', 'Subject', 'Date');
	@head = split(/,\s*/, $cf'biffhead) if defined $cf'biffhead;

	# 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

	($dir, $base) = $folder =~ m|^(.*)/(.*)|;

	# Add distinct macros for each kind of folder: file, dir or MH.
	if ($type eq 'MH' || $type eq 'dir') {
		($dir, $base) = $path =~ m|^(.*)/(.*)|;
		$fpath = $dir;		# Last component is a message "number"
	} else {
		$fpath = $path;
	}
	if ($type ne 'MH') {
		$folddir = $'XENV{'maildir'};		# Folder directory location
		$folddir =~ s/~/$cf'home/g;			# ~ substitytion
		$folddir = "$cf'home/Mail" unless $folddir;	# Default folders in ~/Mail
	} else {
		&mh'profile;		# Read MH profile if not already done
		$folddir = "$cf'home/$mh'Profile{'Path'}";
		$plus = '+';
	}

	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
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($_);
	while (<FORMAT>) {
		chop;
		print TTY &'macros_subst(*_), $n;
	}
	close FORMAT;
	&macro'unload;			# Release customized macros
}

# Default biffing
sub biff'load_default {
	package biff;
	print TTY "$n\07New mail for $cf'user has arrived in $folder:$n";
	print TTY "----$n";
	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
# Also known as the %-H macro
sub biff'load_headers {
	package biff;
	local($res) = '';
	foreach $head (@head) {
		$res .= "$head: $'Header{$head}$n" if defined $'Header{$head};
	}
	chop($res);			# Remove final \n\r for macro substitution
	chop($res);
	$res;
}

# 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(/\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;

	&trim(*body) if $trim;		# Smart trim of leading reply text
	&mh(*body, $len) if $cf'biffmh =~ /^on/i;

	while ($len > 0 && $lines > 0 && defined ($_ = shift(@body))) {
		next if /^\W*$/ && $skipnl;
		# 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 -= length($_);		# Nobody will quibble over missing newline...
		$lines--;
	}
	$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;			# Replace first body line with compacted string

	# 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).

	splice(@ary, 1, $i - 1);	# Remove lines that are now part of $ary[0]

	# Now optionally reformat the first line so that it fits into 80 columns.
	# The line is formatted into an array, and that array is spliced back
	# into @ary.

	return unless $cf'biffnice =~ /^on/i;
	local(@tmp);
	&format($line, *tmp);		# Format line into @tmp
	splice(@ary, 0, 1, @tmp);	# Insert formatted string back
}

# Format body to fit into 78 columns by inserting the generated lines in an
# array, one line per item.
sub biff'load_format {
	package biff;
	local($body, *ary) = @_;	# Body to be formatted, array for result
	local($tmp);				# Buffer for temporary formatting
	local($kept);				# Length of current line
	local($len) = 79;			# Amount of characters kept
	# 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, 9999);
	}
	push(@ary, $body);			# Remaining information on one line
}

# %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 defined %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 defined %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);		# Check existing file/dir
		} elsif ($path eq '') {
			&'add_log("ERROR mandatory parameter '$var' not defined");
		} else {
			&create($path, $type);		# 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.
sub cfset'load_exists {
	package cfset;
	local($path, $type) = @_;
	return unless -e $path;
	local($what) = $type =~ /^[Dd]/ ? 'directory' : 'file';
	local($short) = &'tilda($path);
	if ($type =~ /^[Dd]/) {
		&'add_log("ERROR $short is not a directory") unless -d $path;
	} else {
		&'add_log("ERROR $short is not a file") if -d $path;
	}
}

# Create file/directory, using type sepcification from the setup.cf file.
sub cfset'load_create {
	package cfset;
	local($path, $type) = @_;
	return &exists(path, $type) if -e $path;
	local($what) = $type =~ /^D/ ? 'directory' : 'file';
	local($file) = $type =~ /^\w\s*(.*)/;
	local($from) = $file ? "from default $file" : '(empty)';
	local($short) = &'tilda($path);
	&'add_log("creating mandatory $what $short $from");
	if ($type =~ /^D/) {
		&'makedir($path);
	} else {
		local($dir, $base) = $path =~ 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;
	}
}

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

#
# End of dataloading section.
#

