#!/usr/local/bin/perl -T

#------------------------------------------------------------------------------
# This is amavisd-new.
# It is a high-performance interface between message transfer agent (MTA)
# and virus scanners and/or spam scanners.
#
# It is a performance-enhanced and feature-enriched version of amavisd
# (which in turn is a daemonized version of AMaViS), initially based
# on amavisd-snapshot-20020300).
#
# All work since amavisd-snapshot-20020300:
#   Copyright (C) 2002  Mark Martinec,  All Rights Reserved.
# with contributions from the amavis-* mailing lists and individuals,
# as acknowledged in the release notes.
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# Author: Mark Martinec <mark.martinec@ijs.si>
# Patches and problem reports are welcome.
#
# The latest version of this program is available at:
#   http://www.ijs.si/software/amavisd/
#------------------------------------------------------------------------------

# Here is a boilerplate from the amavisd(-snapshot) version,
# which is the version that served as a base code for the initial
# version of amavisd-new. License terms were the same:
#
#   Author:  Chris Mason <cmason@unixzone.com>
#   Current maintainer: Lars Hecking <lhecking@users.sourceforge.net>
#   Based on work by:
#         Mogens Kjaer, Carlsberg Laboratory, <mk@crc.dk>
#         Juergen Quade, Softing GmbH, <quade@softing.com>
#         Christian Bricart <shiva@aachalon.de>
#   This script is part of the AMaViS package.  For more information see:
#     http://amavis.org/
#   Copyright (C) 2000 - 2002 the people mentioned above
#   This software is licensed under the GNU General Public License (GPL)
#   See:  http://www.gnu.org/copyleft/gpl.html
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
#Index of packages in this file
#  Amavis::Conf
#  Amavis::Timing
#  Amavis::Lock
#  Amavis::Log
#  Amavis::Util
#  Amavis::rfc2821_2822_Tools
#  Amavis::Lookup::SQL
#  Amavis::Lookup::SQLfield
#  Amavis::Lookup::RE
#  Amavis::Lookup
#  Amavis::Expand
#  Amavis::In::Connection
#  Amavis::In::Message::PerRecip
#  Amavis::In::Message
#  Amavis::Out::EditHeader
#  Amavis::Out::Local
#  Amavis::Out
#  Amavis::UnmangleSender
#  Amavis::Unpackers::NewFilename
#  Amavis::Unpackers::OurFiler
#  Amavis::Unpackers
#  Amavis::Notify
#  Amavis
#optionally compiled-in packages: ---------------------------------------------
#  Amavis::In::AMCL
#  Amavis::In::SMTP
#  Amavis::AV
#  Amavis::SpamControl
#------------------------------------------------------------------------------


#
package Amavis::Conf;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    @EXPORT = ();
    @EXPORT_OK = ();
    %EXPORT_TAGS = (
	'confvars' => [qw(
	    $myversion
	    $DEBUG @debug_sender_acl
	    $daemonize $pid_file $lock_file
	    $daemon_user $daemon_group $daemon_chroot_dir $path
	    $DO_SYSLOG $SYSLOG_LEVEL $LOGFILE $log_level
	    $TEMPBASE
	    @av_scanners
	    $max_servers $max_requests $child_timeout
	    $warnvirussender $warnvirusrecip $warnspamsender
	    $log_templ
	    $unix_socketname $inet_socket_port $inet_socket_bind @inet_acl
	    $myhostname $localhost_name
	    $insert_received_line
	    $mta_in_type $gets_addr_in_quoted_form
	    $mta_out_type $forward_method
	    $relayhost_is_client
	    $X_HEADER_TAG $X_HEADER_LINE $remove_existing_x_scanned_headers
	    $QUARANTINEDIR %local_delivery_aliases
	    $final_virus_destiny $final_banned_destiny $final_spam_destiny
	    $recipient_delimiter $replace_existing_extension
	    $localpart_is_case_sensitive
	    $addr_extension_banned $addr_extension_virus $addr_extension_spam
	    $MAXLEVELS $MAXFILES
	    $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR
	    $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR
	    $bypass_decode_parts $banned_filename_re
	    $keep_decoded_original_re
	    %bypass_checks @bypass_checks_acl
	    %bypass_virus_checks @bypass_virus_checks_acl $bypass_virus_checks_re
	    %bypass_spam_checks @bypass_spam_checks_acl $bypass_spam_checks_re
	    %virus_lovers @virus_lovers_acl $virus_lovers_re
	    %banned_files_lovers @banned_files_lovers_acl
	    %spam_lovers @spam_lovers_acl $spam_lovers_re
	    %whitelist_sender @whitelist_sender_acl $whitelist_sender_re
	    %blacklist_sender @blacklist_sender_acl $blacklist_sender_re
	    $viruses_that_fake_sender_re
	    @lookup_sql_dsn
	)],
	'notifyconf' => [qw(
	    $notify_method
	    $mailfrom_notify_admin
	    $mailfrom_notify_sender
	    $mailfrom_notify_recip
	    $mailfrom_notify_spamadmin
	    $mailfrom_to_quarantine
	    %virus_admin %spam_admin $virus_admin $spam_admin $mailto
	    $notify_sender_templ
	    $notify_virus_sender_templ $notify_spam_sender_templ
	    $notify_virus_admin_templ  $notify_spam_admin_templ
	    $notify_virus_recips_templ $notify_spam_recips_templ
	    $warn_offsite @local_domains $local_domains_re
	    $virus_quarantine_to $spam_quarantine_to
	)],
	'unpack' => [qw(
	    $arc $gzip $bzip2 $file $lha $unarj $uncompress $unrar $zoo
	)],
	'sa' => [qw(
	    $sa_kill_level_deflt $sa_tag_level_deflt
	    $sa_spam_subject_tag $helpers_home
	    $sa_local_tests_only $sa_debug $sa_mail_body_size_limit
	)],
	'platform' => [qw(
	    $can_truncate
	)],
    );
    Exporter::export_tags qw(confvars notifyconf unpack sa platform);
} # BEGIN

use POSIX qw(uname);

use vars @EXPORT;

$myversion = 'amavisd-new-20021116';

# Create debugging output - yes: log to stderr; no: log to syslog/file
$DEBUG = 0;

# Cause Net::Server parameters 'background' and 'setsid' to be set,
# resulting in the program to detach itself from the terminal
$daemonize = 1;

# Net::Server pre-forking settings - defaults, overruled by amavisd.conf
$max_servers   =  2;  # number of pre-forked children
$max_requests  = 10;  # retire a child after that many accepts

$child_timeout = 8*60; # abort child if it does not complete each task in n sec

# Can file be truncated?
# Set to 1 if 'truncate' works (it is XPG4-UNIX standard feature,
#                               not required Posix).
# Things will go faster with SMTP-in, otherwise (e.g. with milter)
# it makes no difference as file truncation will not be used.
$can_truncate = 1;

#
# Customizable notification messages, logging

$SYSLOG_LEVEL = "mail.info";

# Where to find SQL server(s) and database to support SQL lookups?
# A list of triples: (dsn,user,passw). Specify more than one
# for multiple (backup) SQL servers.
#
#@lookup_sql_dsn =
#   ( ['DBI:mysql:mail:host1', 'some-username1', 'some-password1'],
#     ['DBI:mysql:mail:host2', 'some-username2', 'some-password2'] );

#
# Receiving mail related

# $unix_socketname = '/var/amavis/amavisd.sock'; # traditional amavis client protocol
# $inet_socket_port = 10024;      # accept SMTP on this TCP port
$inet_socket_bind = '127.0.0.1';  # limit socket bind to loopback interface

@inet_acl = qw( 127.0.0.1 );  # allow SMTP access only from localhost

$gets_addr_in_quoted_form = 0;

# Temporary directory
$TEMPBASE = "/var/amavis";

$notify_method  = 'smtp:127.0.0.1:10025';
$forward_method = 'smtp:127.0.0.1:10025';

$insert_received_line = 1; # insert 'Received:' header field? (not with milter)

# $myhostname is used by SMTP server module in the initial SMTP welcome line,
# in inserted 'Received:' lines, Message-ID in notifications, log entries, ...
$myhostname = (uname)[1];

# $localhost_name is the name of THIS host running amavisd
# (typically 'localhost'). It is used in HELO SMTP command
# when reinjecting mail back to MTA via SMTP for final delivery.
$localhost_name = 'localhost';

# whom quarantined messages appear to be sent from (envelope sender)
$mailfrom_to_quarantine = undef; # original sender if undef, or set explicitly

# where to send quarantined viruses (or spam)
#   It may be a simple scalar string, or a ref to a hash lookup table,
#   which makes possible to set up per-recipient quarantine addresses.
#   Specify e-mail address containing '@',
#   or just a local part, which will be mapped by %local_delivery_aliases
#   into local mailbox name or directory.
$virus_quarantine_to = undef;              # dflt: no virus quarantine
$spam_quarantine_to  = undef;              # dflt: no spam quarantine

#$virus_quarantine_to = 'virus-quarantine';# quarantine to $QUARANTINEDIR
#$spam_quarantine_to  = 'spam-quarantine'; # quarantine to $QUARANTINEDIR

# quarantine directory or mailbox file or empty
#   (only used if $virus_quarantine_to specifies direct local delivery)
$QUARANTINEDIR = undef;     # no quarantine unless overridden by config

# string to prepend to Subject header field when message qualifies as spam
$sa_spam_subject_tag = undef;   # example: '***SPAM*** '

$sa_local_tests_only = 0;
$sa_debug = 0;


# ISP features:
#
# Exclude certain recipients from virus filtering by adding their lower-cased
# e-mail address (or domain only) to the hash %virus_lovers, or to the
# access list @virus_lovers_acl - see README.lookups and examples at
# subroutines lookup_hash() and lookup_acl(). Make sure the appropriate
# form (e.g. external/internal) of address is used in case of virtual domains,
# or when mapping external to internal addresses, etc. - this is MTA dependent.
#
# Notifications would still be generated however, and infected mail
# (if passed) gets additional header:
#   X-AMaViS-Alert: INFECTED, message contains virus: ...
# (header not inserted with milter interface!)
#
# NOTE (milter interface only): in case of multiple recipients,
# it is only possible to drop or accept the message in its entirety - for all
# recipients. If all of them are virus lovers, we'll accept mail, but if
# at least one recipient is not a virus lover, we'll discard it.
#
# Similar in concept to %virus_lovers, a hash %bypass_checks, and access list
# @bypass_checks_acl, are used to skip entirely the decoding, unpacking
# and content checking, but only if ALL mail recipients are members of the
# hash %bypass_checks or match the list @bypass_checks_acl.
# This is mainly a time-saving option.
#
# %bypass_checks/@bypass_checks_acl does NOT GUARANTEE the message
# will NOT be checked for viruses - this may still happen when there is
# more than one recipient for a message, and not all of them match
# %bypass_checks/@bypass_checks_acl. To guarantee virus delivery
# (but see milter limitations above), a recipient must also match
# %virus_lovers/@virus_lovers_acl/$virus_lovers_re.

# NOTE: it would not be clever to base this check on sender address,
# since there are no guarantees that it is genuine. Many viruses
# and spam messages fake sender address. To achieve selective filtering
# based on the source of the mail (e.g. IP address, MTA port number, ...),
# use mechanisms provided by MTA if available.

# Similar to %bypass_checks/@bypass_checks_acl but affecting only
# virus scanning or spam scanning respectively, are the lookup tables:
#   %bypass_virus_checks/@bypass_virus_checks_acl/$bypass_virus_checks_re, and
#   %bypass_spam_checks/@bypass_spam_checks_acl/$bypass_spam_checks_re

# Hashes for many entries are faster but more limited, acl is more general
# but can be slower if list is long. For lots of entries or for dynamically
# changing settings use SQL lookups.

# See README.lookups for further detail.


# What to do with the message (this is independent of quarantining):
#   reject:  tell MTA to generate a non-delivery notification
#   discard: drop the message and pretend it was delivered
#   pass:    deliver/accept the message

#*destiny:
#
# undef (retry) indicates some kind of temporary or unexpected problem
#		and must cause mail to be requeued or somehow retried later;
#		mail must not be lost;
#
# >0 (accept) all is fine, mail passed all required tests
#		and should be handed (back) to MTA for final delivery,
#		or MTA instructed to continue with its delivery;
#
# =0 (discard) the message contains a virus or failed some other
#		criterium (e.g. spam test) and MUST NOT be forwarded
#		to its recipients, just lose it (but may be quarantined);
#		This does not preclude some other amavis-generated
#		notifications to be sent if desired.
#
# <0 (reject) mail must not (or: will not) be delivered to its final
#		recipients, but the sender should preferably get a reject,
#		e.g. SMTP permanent reject response, or MTA non-delivery
#		notification. Amavis washes its hands and lets MTA on the
#		incoming side do the reject if it can. It this can not be done,
#		just discard the message (same as with 0), and preferably
#		log the event in case someone inquires about his message.
#
#		This action is appropriate for example if during mail
#		reinjection back to MTA, the MTA insists it does not want
#		to accept the mail back for final delivery (5xx permanent
#		reject, e.g. policy violation), or some other local criteria
#		indicates the mail should be rejected or returned to sender.
#		Depending on MTA interface, this may be implemented by
#		rejecting the message on the input pipe (e.g. amavis client
#		can be given a 'permanent reject' status code, or the incoming
#		SMTP session be given 5xx reject response).

$final_virus_destiny  =  0;      # -1=reject, 0=discard, 1=pass
$final_banned_destiny =  1;      # -1=reject, 0=discard, 1=pass
$final_spam_destiny   = -1;      # -1=reject, 0=discard, 1=pass

# If you decide to pass viruses (or spam) to certain users using
# %virus_lovers/@virus_lovers_acl/$virus_lovers_re, (or *spam_lovers*),
# %bypass_checks/@bypass_checks_acl, or $final_virus_destiny=1
# ($final_spam_destiny=1), you can set the variable $addr_extension_virus
# ($addr_extension_spam) to some string, and the recipient address will have
# this string appended as an address extension to the local-part of the
# address. This extension can be used by final local delivery agent to place
# such mail in different folders. Leave these two variables undefined or empty
# strings to prevent appending address extensions. Setting has no effect
# on users which will not be receiving viruses (spam). Recipients which
# do not match access list @local_domains/$local_domains_re are not affected.
#
# LDAs usually default to stripping away address extension if no special
# handling for it is specified, so having this option enabled normally
# does no harm, provided the $recipients_delimiter character matches
# the setting at the final MTA's LDA.

$addr_extension_banned = undef;  # or set to: 'banned' for example
$addr_extension_virus  = undef;  # or set to: 'virus'  for example
$addr_extension_spam   = undef;  # or set to: 'spam'   for example

# Delimiter between local part of the recipient address and address extension
# (which can optionally be added, see variables $addr_extension_virus and
# $addr_extension_spam). E.g. recipient address <user@domain.example> gets
# changed to <user+virus@domain.example>.
#
# Delimiter should match equivalent (final) MTA delimiter setting.
# (e.g. for Postfix add 'recipient_delimiter = +' to main.cf).
# Setting it to an empty string or to undef disables this feature
# regardless of $addr_extension_virus and $addr_extension_spam settings.

$recipient_delimiter = '+';
$replace_existing_extension = 1;   # true: replace ext; false: append ext

# Affects matching of localpart of e-mail addresses (left of '@')
# in lookups: true = case sensitive, false = case insensitive
$localpart_is_case_sensitive = 0;

# $mailfrom has been split into several variables to allow for finer
# granularity in choosing sender name (which may also be empty,
# producing null reverse path <>, which is useful for sender notifications).
# The following variables are preferred instead:
#   $mailfrom_notify_admin, $mailfrom_notify_sender, $mailfrom_notify_recip,
#   $mailfrom_notify_spamadmin, $mailfrom_to_quarantine
use vars qw($mailfrom);


# read and evaluate configuration file
sub read_config($) {
    my($config_file) = @_;
    -e($config_file) or die "Cannot find config file $config_file";
    -r(_)            or die "Cannot read config file $config_file";
    do $config_file or die "Error in config file $config_file: $@";
    # compatibility with $mailfrom:
    if (!$mailfrom_notify_admin && !$mailfrom_notify_sender &&
	!$mailfrom_notify_recip && !$mailfrom_notify_spamadmin) {
	$mailfrom_notify_admin = $mailfrom_notify_sender    = $mailfrom;
	$mailfrom_notify_recip = $mailfrom_notify_spamadmin = $mailfrom;
    }
    # compatibility with "yes"/"no" for some variables
    for ($DEBUG, $DO_SYSLOG, $warn_offsite,
	 $warnvirussender, $warnvirusrecip, $warnspamsender) { $_ = 0 if /^\s*NO\s*$/i }
    # some sensible defaults for essential settings
    $helpers_home = $TEMPBASE  if !defined $helpers_home;
}

1;
#
package Amavis::Timing;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&init &section_time &report);
}
use subs @EXPORT_OK;

use Time::HiRes qw(time);

use vars qw(@timing);

# clear array @timing and enter start time
sub init() {
    @timing = ();
    section_time('init');
}

# enter current time reading into array @timing
sub section_time($) {
    push(@timing, shift, time);
}

# returns a string - a report of elapsed time by section
sub report() {
    section_time('rundown');
    my($notneeded, $t0) = (shift(@timing), shift(@timing));
    my($total) = $timing[$#timing] - $t0;
    if ($total < 0.0000001) { $total = 0.0000001 }
    my(@sections);
    while (@timing) {
	my($section, $t) = (shift(@timing), shift(@timing));
	push(@sections, sprintf("%s: %.0f (%.0f%%)",
			$section, ($t-$t0)*1000, ($t-$t0)*100.0/$total ) );
	$t0 = $t;
    }
    sprintf("TIMING [total %.0f ms] - %s",
	    $total*1000, join(", ", @sections));
}

1;

#
package Amavis::Lock;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    @EXPORT = qw(&lock &unlock);
}
use Fcntl qw(:flock);

use subs @EXPORT;

sub lock($) {
    my $file = shift;
    flock($file, LOCK_EX) or die "Can't lock $file: $!";
    seek($file, 0, 2) or die "Can't position $file to its tail: $!";
}

sub unlock($) {
    my $file = shift;
    flock($file, LOCK_UN) or die "Can't unlock $file: $!";
}

1;

#
package Amavis::Log;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&init &write_log);
}
use subs @EXPORT_OK;

use POSIX qw(strftime);
use Unix::Syslog qw(:macros :subs);
use IO::File;
use File::Basename;

BEGIN {
    import Amavis::Conf qw($myversion $myhostname);
    import Amavis::Lock;
}

use vars qw($loghandle);  # log file handle
use vars qw($myname);
use vars qw($syslog_facility $syslog_priority);
use vars qw($log_to_stderr $do_syslog $logfile $log_lvl);

sub init($$$$$$) {
    my($ident, $syslog_level);
    ($ident,$log_to_stderr,$do_syslog,$syslog_level,$logfile,$log_lvl) = @_;

    # Avoid taint bug in some versions of Perl (likely in 5.004, 5.005).
    # The 5.6.1 is fine. To test, run this one-liner:
    #   perl -Te '"$0 $$"; $r=$$; print eval{kill(0,$$);1}?"OK\n":"BUG\n"'
    basename($0) =~ /^(.*)$/; $myname = $1;

    if ($syslog_level =~ /^\s*(\w+)\.(\w+)\s*$/) {
	$syslog_facility = eval("LOG_\U$1");
	$syslog_priority = eval("LOG_\U$2");
    }
    $syslog_facility = LOG_DAEMON   if $syslog_facility !~ /^\d+$/;
    $syslog_priority = LOG_WARNING  if $syslog_priority !~ /^\d+$/;
    if ($do_syslog) {
	openlog($ident, LOG_PID, $syslog_facility);
    } else {
	$loghandle = IO::File->new(">>$logfile")
	    or die "Failed to open log file: $!";
	$loghandle->autoflush(1);
    }
    write_log("starting.  $myname at $myhostname $myversion", undef);
}

# Log either to syslog or a file
sub write_log($$) {
    my($errmsg,$am_id) = @_;

    my($really_log_to_stderr) = $log_to_stderr || (!$do_syslog && !$loghandle);

    my($logline);
    if ($really_log_to_stderr || !$do_syslog) {  # create syslog-alike
	$logline = sprintf("%s %s %s[%s]: ",
			  strftime("%b %e %H:%M:%S", localtime),
			  $myhostname, $myname, $$);
    }
    if (length($errmsg) > 2000) {  # crop at some arbitrary limit
	$errmsg = substr($errmsg,0,2000) . "...";
    }
    $logline .= (!defined($am_id) ? '' : "($am_id) ") . $errmsg;
    chomp($logline);  # just in case somebody left-in a LF
    if ($really_log_to_stderr) {
	print STDERR $logline,"\n";
    } elsif ($do_syslog) {
	syslog($syslog_priority, "%s", $logline);
    } else {
	lock($loghandle);
	print $loghandle $logline,"\n";
	unlock($loghandle);
    }
}

1;

#
package Amavis::Util;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&am_id &do_log &debug_oneshot &retcode &prolong_timer
	&sanitize_str &min &max &strip_tempdir &rmdir_recursively &rmdir_flat);
}
use subs @EXPORT_OK;
use POSIX qw(WEXITSTATUS WIFEXITED WTERMSIG WIFSIGNALED);

BEGIN {
    import Amavis::Conf qw($DEBUG $log_level);
    import Amavis::Log qw(write_log);
    import Amavis::Timing qw(section_time);
}

# Set or get Amavis internal message id.
# This message id performs a similar function to queue-id in MTA responses.
# It may only be used in generating text part of SMTP responses,
# or in generating log entries.
use vars qw($amavis_task_id);  # internal message id (accessible via &am_id)
sub am_id(;$) {
    if (@_) {   # set, if argument present
	$amavis_task_id = shift;
	$0 = "amavisd ($amavis_task_id)";
    }
    $amavis_task_id;  # return current value
}

# write log entry
sub do_log($$) {
    my($level,$errmsg) = @_;
    $level = 0  if $DEBUG || debug_oneshot();
    write_log($errmsg, am_id())  if $level <= $log_level;
}

use vars qw($debug_oneshot);
sub debug_oneshot(;$$) {
    if (@_) {
	my($new_debug_oneshot) = shift;
	if (($new_debug_oneshot?1:0) != ($debug_oneshot?1:0)) {
	    do_log(0, "DEBUG_ONESHOT: TURNED ".
			($new_debug_oneshot ? "ON" : "OFF"));
	    do_log(0, shift)  if @_; # caller-provided extra log entry, usually
				     # the one that caused debug_oneshot call
	}
	$debug_oneshot = $new_debug_oneshot;
    }
    $debug_oneshot;
}

sub retcode($) {
    my $code = shift;
    return WEXITSTATUS($code) if WIFEXITED($code);
    return 128+WTERMSIG($code) if WIFSIGNALED($code);
    return 255;
}

sub prolong_timer($;$) {
    my($which_section,$child_remaining_time) = @_;
    if (!defined($child_remaining_time)) {
	$child_remaining_time = alarm(0);  # check how much time is left
    }
    do_log(4, "prolong_timer after $which_section: ".
	      "remaining time = $child_remaining_time s");
    $child_remaining_time = 60  if $child_remaining_time < 60;
    alarm($child_remaining_time); # restart/prolong the timer
}

# Mostly for debugging and reporting purposes:
# Convert nonprintable characters in the argument
# to \[rnftbe], or \octal code, and '\' to '\\',
# returning the sanitized string.
sub sanitize_str($;$) {
    my($str,$no_eightbit) = @_;
    my(%map) = ("\r"=>'\\r', "\n"=>'\\n', "\f"=>'\\f', "\t"=>'\\t',
		"\b"=>'\\b', "\e"=>'\\e', "\\"=>'\\\\');
    if ($no_eightbit) {
	$str =~ s/([\000-\037\177-\377\134])/
		  exists($map{$1}) ? $map{$1} : sprintf("\\%03o",ord($1))/eg;
    } else {
	$str =~ s/([\000-\037\177\200-\237\377\134])/
		  exists($map{$1}) ? $map{$1} : sprintf("\\%03o",ord($1))/eg;
    }
    $str;
}

# Checks tempdir after being cleaned.
# It should only contain subdirectory 'parts', nothing else.
#
sub check_tempdir($) {
    my($dir) = shift;
    my($f); local(*DIR);
    opendir(DIR, $dir) or die "Can't open directory $dir: $!";
    while (defined($f = readdir(DIR))) {
	if (! -d("$dir/$f") ) {
	    die "Unexpected file $dir/$f"  if $f ne 'email.txt';
	} elsif ($f =~ /^\.\.?$/ || $f eq 'parts') {}
	else { die "Unexpected subdirectory $dir/$f" }
    }
    closedir(DIR) or die "Can't close directory $dir: $!";
    1;
}

# Remove all files and subdirectories from the temporary directory,
# leaving only the directory itself and its empty subdirectory ./parts .
# Leaving directories for reuse represents an important saving in time,
# as directory creation + deletion is quite an expensive operation,
# requiring atomic file system operation, including flushing buffers to disk.
#
sub strip_tempdir($) {
    my($dir) = shift;
    rmdir_recursively("$dir/parts",1)  if -e "$dir/parts";
    # All done. Check for any remains in the top directory just in case
    check_tempdir($dir);
    1;
}

#
# Removes a directory, along with its contents
sub rmdir_recursively($;$) {
    my($dir, $exclude_itself) = @_;
    do_log(4,"rmdir_recursively: $dir, excl=$exclude_itself");
    my($f); my($cnt) = 0;
    local(*DIR);
    opendir(DIR, $dir) or die "Can't open directory $dir: $!";
    while (defined($f = readdir(DIR))) {
	next if $f !~ /^(.+)$/;
	$f = $1;  # untaint
	if (-d "$dir/$f") {
	    rmdir_recursively("$dir/$f",0)  unless $f =~ /^\.\.?$/;
	} else {
	    $cnt++;
	    unlink("$dir/$f") or die "Can't remove file $dir/$f: $!";
	}
    }
    closedir(DIR) or die "Can't close directory $dir: $!";
    section_time("unlink-$cnt-files");
    if (!$exclude_itself) {
	rmdir($dir) or die "Can't remove directory $dir: $!";
	section_time('rmdir');
    }
    1;
}

#
# Removes a directory, along with its contents
# Does not do it recursively - refuses to delete any subdirectories
sub rmdir_flat($) {
    my $dir = shift;
    do_log(4,"rmdir_flat: $dir");
    my $f;
    opendir(DIR, $dir) or die "Can't open directory $dir: $!";
    while (defined($f = readdir(DIR))) {
	next if $f !~ /^(.+)$/;
	$f = $1;  # untaint
	if (-d "$dir/$f") {
	    die "Refused to unlink a subdirectory $dir/$f" unless $f =~ /^\.\.?$/;
	} else {
	    unlink("$dir/$f") or die "Can't remove file $dir/$f: $!";
	}
    }
    closedir(DIR) or die "Can't close directory $dir: $!";
    rmdir($dir) or die "Can't remove directory $dir: $!";
    1;
}

# Returns the smallest number from the list, or undef
sub min(@) {
    my($r) = @_==1 && ref($_[0]) ? $_[0] : \@_;  # accept list, or a list ref
    my($m); for (@$r) { $m = $_  if defined $_ && (!defined $m || $_ < $m) }
    $m;
}

# Returns the largest number from the list, or undef
sub max(@) {
    my($r) = @_==1 && ref($_[0]) ? $_[0] : \@_;  # accept list, or a list ref
    my($m); for (@$r) { $m = $_  if defined $_ && (!defined $m || $_ > $m) }
    $m;
}

1;

#
package Amavis::rfc2821_2822_Tools;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = qw(
	&rfc2822_timestamp &received_line &split_address &split_localpart
	&quote_rfc2821_local &qquote_rfc2821_local &unquote_rfc2821_local
	&one_response_for_all
	&EX_OK &EX_UNAVAILABLE &EX_TEMPFAIL &EX_NOPERM);
}

use subs @EXPORT;

use POSIX qw(strftime);

BEGIN {
  eval {require 'sysexits.ph'};  # try to use the installed version
  # define the most important constants if undefined
  do { sub EX_OK()          {0}  } unless defined(&EX_OK);
  do { sub EX_UNAVAILABLE() {69} } unless defined(&EX_UNAVAILABLE);
  do { sub EX_TEMPFAIL()    {75} } unless defined(&EX_TEMPFAIL);
  do { sub EX_NOPERM()      {77} } unless defined(&EX_NOPERM);
}

BEGIN {
    import Amavis::Conf qw($myhostname $localhost_name $forward_method);
    import Amavis::Util qw(do_log sanitize_str);
}

# Given a Unix time, return the local time zone offset at that time
# as a string +HHMM or -HHMM, appropriate for the RFC2822 date format.
# Works also for non-full-hour zone offsets.   (c) Mark Martinec, GPL
#
sub get_zone_offset($) {
    my($t) = @_;
    my($d) = 0;   # local zone offset in seconds
    for (1..3) {  # match the date (with a safety loop limit just in case)
	my($r) = sprintf("%04d%02d%02d", (localtime($t))[5,4,3]) cmp
		 sprintf("%04d%02d%02d", (gmtime($t+$d))[5,4,3]);
	if ($r == 0) { last } else { $d += $r*24*3600 };
    }
    my($sl,$su) = (0,0);
    for ((localtime($t))[2,1,0]) { $sl = $sl*60 + $_ };
    for ((gmtime($t+$d))[2,1,0]) { $su = $su*60 + $_ };
    $d += $sl-$su;           # add HMS difference (in seconds)
    my($sign) = $d >= 0 ? '+' : '-';   $d = -$d if $d<0;
    $d = int(($d+30)/60.0);  # give minutes, rounded
    sprintf("%s%02d%02d", $sign, int($d/60), $d%60);
}

# Given a Unix time, provide date-time timestamp as specified in RFC 2822,
# to be used in headers such as 'Date:' and 'Received:'
#
sub rfc2822_timestamp(;$) {
    my($t) = @_ ? shift : time;
    my(@lt) = localtime($t);
    my($zone_name) = strftime("%Z", @lt);
    my($s) = strftime("%a, %e %b %Y %H:%M:%S ", @lt);
    $s .= get_zone_offset($t);
    $s .= " (" . $zone_name . ")"  if $zone_name !~ /^\s*$/;
    $s;
};

sub received_line($$$$) {
    my($conn, $msginfo, $id, $folded) = @_;
    my($smtp_proto,$recips) = ($conn->smtp_proto, $msginfo->recips);
    my($s) = sprintf("from %s%s\n by %s%s (amavisd-new)",
	$conn->smtp_helo,
	($conn->client_ip eq '' ? '' : " ([".$conn->client_ip."])"),
	$localhost_name,
	($conn->socket_ip eq '' ? '' : sprintf(" (%s [%s:%s])",
		    $myhostname, $conn->socket_ip, $conn->socket_port)) );
    $s .= "\n with $smtp_proto" if $smtp_proto =~ /^(ES|S|L)MTP$/i;
    $s .= "\n id $id"           if $id ne '';
    # do not disclose if many
    $s .= "\n for " . qquote_rfc2821_local(@$recips)  if @$recips==1;
    $s .= ";\n " . rfc2822_timestamp($msginfo->rx_time);
    $s =~ s/\n//g  if !$folded;
    $s;
}

# Splits unquoted fully qualified e-mail address, or an address
# with missing domain part. Returns a pair: (localpart, domain).
# The domain part (if nonemty) includes the '@' as the first character.
# If the syntax is badly broken, everything ends up as the localpart.
# The domain part can be an address literal, as specified by rfc2822.
#
sub split_address($) {
    my($mailbox) = @_;
    $mailbox =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\[\]\\] )*  \]
				|  [^@"<>\[\]\\\s] )*
			 ) $/xs ? ($1,$2) : ($mailbox,'');
}

# split_localpart() splits localpart of an e-mail address at the first
# occurrence of the delimiter character. (based on equivalent routine
# in Postfix)
#
# Reserved addresses are not split: postmaster, mailer-daemon,
# double-bounce. Addresses that begin with owner-, or addresses
# that end in -request are not split when the owner_request_special
# parameter is set.

sub split_localpart($$) {
    my($localpart, $delimiter) = @_;
    my($owner_request_special) = 0;  # configurable ???
    my($extension);
    if ($localpart =~ /^(postmaster|mailer-daemon|double-bounce)$/i) {
	# do not split these, regardless of what the delimiter is
    } elsif ($delimiter eq '-' && $owner_request_special
	     && $localpart =~ /^owner-|-request$/i) {
	# backwards compatibility: don't split owner-foo or foo-request
    } elsif ($localpart =~ /^(.+?)\Q$delimiter\E(.*)$/s) {
	($localpart,$extension) = ($1,$2);
	# do not split the address if the result would have a null localpart
    }
    ($localpart,$extension);
}

# quote_rfc2821_local() quotes the local part of a mailbox address
# (given in internal (unquoted) form), and returns external (quoted)
# mailbox address, as per rfc2821.
#
# Internal (unquoted) form is used internally by AMaViS and other mail sw,
# external (quoted) form is used in SMTP commands and message headers.
#
# The quote_rfc2821_local() conversion is necessary because addresses
# we get from certain MTAs are raw, with stripped-off quoting.
# To re-insert message back via SMTP, the local-part of the address needs
# to be quoted again if it contains reserved characters or otherwise
# does not obey the dot-atom syntax, as specified per rfc2821.
# Failing to do that gets us into trouble: amavis accepts message from MTA,
# but is unable to hand it back to MTA after checking, receiving
# '501 Bad address syntax' with every attempt.
#
sub quote_rfc2821_local($) {
    my($mailbox) = @_;
    # atext: any character except controls, SP, and specials (rfc2821/rfc2822)
    my($atext) = "a-zA-Z0-9!#\$%&'*/=?^_`{|}~+-";
    # my($specials) = '()<>\[\]\\\\@:;,."';
    my($localpart,$domain) = split_address($mailbox);
    if ($localpart !~ /^[$atext]+(\.[$atext]+)*$/o) {  # not dot-atom
	$localpart =~ s/(["\\])/\\$1/g;                # quoted-pair
	$localpart = '"' . $localpart . '"';  # make a qcontent out of it
    }
    $domain = ''  if $domain eq '@';  # strip off empty domain entirely
    $localpart . $domain;
}

# wraps the result of quote_rfc2821_local into angle brackets <...> ;
# If given a list, it returns a list (possibly converted to
# comma-separated scalar), quoting each element;
#
sub qquote_rfc2821_local(@) {
    my(@r) = map { $_ eq '' ? '<>' : ('<'.quote_rfc2821_local($_).'>') } @_;
    wantarray ? @r : join(', ',@r);
}

# unquote_rfc2821_local() strips away the quoting from the local part
# of an external (quoted) mailbox address, and returns internal (unquoted)
# mailbox address, as per rfc2821.
#
# Internal (unquoted) form is used internally by AMaViS and other mail sw,
# external (quoted) form is used in SMTP commands and message headers.
#
sub unquote_rfc2821_local($) {
    my($mailbox) = @_;

    # the angle-bracket stripping is not really a duty of this subroutine,
    # as it should have been already done elsewhere, but for the time being
    # we do it here:
    if ($mailbox =~ /^ \s* < ( .* ) > \s* $/xs) { $mailbox = $1 }
    my($localpart,$domain) = split_address($mailbox);
    $localpart =~ s/ " | \\(.) | \\$ /$1/xsg;  # unquote quoted-pairs
    $localpart . $domain;
}

# Prepare a single SMTP response and an exit status as per sysexits.h
# from individual per-recipient response codes, taking into account
# sendmail milter specifics. Returns a pair: (smtp response, exit status).
#
sub one_response_for_all($) {
    my($msginfo) = @_;
    my($smtp_resp,$exit_code,$dsn_needed);

    my($per_recip_data) = $msginfo->per_recip_data;
    my($any_not_done) = scalar(grep {!$_->recip_done} @$per_recip_data);
    if ($forward_method ne '' && $any_not_done)
	{ die "Explicit forwarding, but not all recips done" }
    if (!@$per_recip_data) {  # no recipients, nothing to do
	$smtp_resp = "250 2.5.0 Ok"; $exit_code = EX_OK;
	do_log(5, "one_response_for_all: no recipients, '$smtp_resp'");
    }
    if (!defined $smtp_resp) {
	for my $r (@$per_recip_data) {  # any 4xx code ?
	    if ($r->recip_smtp_response =~ /^4/)   # pick the first 4xx code
		{ $smtp_resp = $r->recip_smtp_response; last }
	}
	if (!defined $smtp_resp) {
	    for my $r (@$per_recip_data) {  # any invalid code ?
		if ($r->recip_smtp_response !~ /^[245]/) {  # pick the first
		    $smtp_resp = "451 4.5.0 Bad SMTP response code??? <" .
				 $r->recip_smtp_response . ">";
		    last;
		}
	    }
	}
	if (defined $smtp_resp) {
	    $exit_code = EX_TEMPFAIL;
	    do_log(5, "one_response_for_all: 4xx found, '$smtp_resp'");
	}
    }
    # NOTE: a 2xx SMTP response code is set both by internal DISCARD,
    # and a genuine successful delivery. To distinguish between the two
    # we need to check $r->recip_destiny as well.
    #
    if (!defined $smtp_resp) {
	# if destiny for _all_ recipients is discard (0) => DISCARD
	my($notall);
	for my $r (@$per_recip_data) {
	    if ($r->recip_destiny == 0) {  # pick the first DISCARD code
		$smtp_resp = $r->recip_smtp_response  if !defined $smtp_resp;
	    } else { $notall++; last }     # one is not discard, nogood
	}
	if ($notall) { $smtp_resp = undef }
	if (defined $smtp_resp) {
	    $exit_code = $forward_method ne '' ? 99 : EX_OK;
	    do_log(5, "one_response_for_all: all DISCARD, '$smtp_resp'");
	}
    }
    if (!defined $smtp_resp) {
	# destiny for _all_ recipients is discard or reject => REJECT
        # (and there is at least one reject)
	my($notall,$done_level);
	for my $r (@$per_recip_data) {
	    if ($r->recip_destiny == 0) {
		# ok, this one is discard, let's see the rest
	    } elsif ($r->recip_smtp_response =~ /^5/) { # pick the first REJECT
		# prefer to report SMTP response code of genuine rejects
		# from MTA, over internal rejects by content filters
		if (!defined $smtp_resp || $r->recip_done > $done_level) {
		    $smtp_resp = $r->recip_smtp_response;
		    $done_level = $r->recip_done;
		}
	    } else { $notall++; last }     # one is presumably PASS, nogood
	}
	if ($notall) { $smtp_resp = undef }
	if (defined $smtp_resp) {
	    $exit_code = EX_UNAVAILABLE;
	    do_log(5, "one_response_for_all: some REJECTs, '$smtp_resp'");
	}
    }
    if (!defined $smtp_resp) {
	# mixed destiny: discard+reject+pass => CONTINUE,
	# but generate dsn for rejects, and don't deliver to non-pass
	# recipients (which have recip_done already set)
	my($rej_cnt) = 0; my($drop_cnt) = 0;
	for my $r (@$per_recip_data) {
	    my($dest,$resp) = ($r->recip_destiny, $r->recip_smtp_response);
	    if ($dest > 0 && $resp =~ /^2/) {   # genuine successful delivery
		$smtp_resp = $resp  if !defined $smtp_resp;
	    }
	    $rej_cnt++   if $resp =~ /^5/;
	    $drop_cnt++  if $dest == 0;
	}
	if (!defined $smtp_resp && $any_not_done) {  # e.g. milter
	    $smtp_resp = "250 2.5.0 Ok, continue delivery";
	}
	defined $smtp_resp
	    or die "one_response_for_all: why did we come to this section?";
	$smtp_resp .= ", but"  if $rej_cnt || $drop_cnt;
	$smtp_resp .= " $rej_cnt REJECT" . ($rej_cnt==1?'':'S')  if $rej_cnt;
	$smtp_resp .= ", and"  if $rej_cnt && $drop_cnt;
	$smtp_resp .= " $drop_cnt DROP" . ($drop_cnt==1?'':'S')  if $drop_cnt;
	$exit_code = EX_OK;
	$dsn_needed = $rej_cnt ? 1 : 0;
	do_log(5, "one_response_for_all: " .
		  ($rej_cnt+$drop_cnt > 0 ? 'mixed' : 'success') .
		  ", '$smtp_resp'");
    }
    ($smtp_resp, $exit_code, $dsn_needed);
}

1;

#
package Amavis::Lookup::SQL;
use strict;
BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}
BEGIN {
    import Amavis::Util qw(do_log);
    import Amavis::Conf qw($recipient_delimiter $localpart_is_case_sensitive
			   @local_domains $local_domains_re);
    import Amavis::Timing qw(section_time);
    import Amavis::rfc2821_2822_Tools qw(split_address split_localpart);
}

sub new($$$$$$) {
    my($class, $dbh,
	$keyname, $tablenames, $fieldnames, $joins_ref, $order) = @_;
    # $tablenames and $fieldnames are comma-separated lists (a string)
    my($self) = bless {}, $class;
    $self->{dbh} = $dbh;  # save DBI handle
    for my $n (1..6) {  # prepare select statements with different no. of args
	my($sel) = sprintf("SELECT %s FROM %s",
			join(',', $keyname, split(/\s*,\s*/,$fieldnames,-1)),
			$tablenames);
	my(@where) = sprintf("%s IN (%s)", $keyname, join(',', ('?')x$n ) );
	$sel .= ' WHERE '.join(' AND ',
			map{"($_)"} @$joins_ref,@where) if @$joins_ref+@where;
	$sel .= ' ORDER BY '.$order  if $order ne '';
	do_log(5,"SQL prepare: ".$sel);
	$self->{"sth$n"} = $dbh->prepare($sel);  $self->{keyname} = $keyname;
    }
    $self;
}

# lookup_sql() performs a lookup for an e-mail address against a SQL map.
# If a match is found it returns whatever the map returns (a reference
# to a hash containing values of requested fields), otherwise returns undef.
# A match aborts further fetching sequence.
#
# SQL lookups (e.g. for user+foo@example.com) are performed in order
# which can be requested by 'ORDER BY' in the SELECT statement,
# otherwise it is unspecified, which is only useful if just specific entries
# exist in a database (full address, not only domain part or mailbox part).
#
# The following order is recommended:
#  - lookup for user+foo@example.com
#  - lookup for user@example.com (only if $recipient_delimiter nonempty)
#  - lookup for user+foo (only if domain part is local)
#  - lookup for user     (only local; only if $recipient_delimiter is nonempty)
#  - lookup for @example.com
#  - lookup for @.       (catchall)
# NOTE:
#  this is different from hash and ACL lookups in three important aspects:
#    - naked key (without '@') implies mailbox name, not domain name;
#    - subdomains are not looked at, only full domain names are matched;
#    - the naked mailbox name lookups are only performed when the domain part
#      matches the '@local_domains' ACL, or the full address matches
#      the $local_domains_re regexp list.
#
# The domain part is always lowercased when constructing a key,
# the localpart is not lowercased when $localpart_is_case_sensitive is true.
#
sub lookup_sql($$) {
    my($self,$addr) = @_;
    if (exists $self->{cache} && exists $self->{cache}->{$addr}) {  # cached ?
	my($match) = $self->{cache}->{$addr};
	if (!defined($match)) {
	    do_log(5, "lookup_sql (cached): \"$addr\" no match");
	} else {
	    do_log(5, "lookup_sql (cached): \"$addr\" matches, result=(".
		join(", ", map {$_.'=>"'.$match->{$_}.'"'} sort keys(%$match))
						.")" );
	}
	return $match;
    }
    my($localpart,$domain) = split_address($addr);
    $domain = lc($domain);
    $localpart = lc($localpart)  if !$localpart_is_case_sensitive;
    # chop off leading @, and trailing dots
    $domain = $1  if $domain =~ /^\@?(.*?)\.*$/s;
    my(@keys); my($extension);
    if ($recipient_delimiter ne '') {
	($localpart, $extension) =
		split_localpart($localpart, $recipient_delimiter);
    }
    push(@keys, $localpart.$recipient_delimiter.$extension.'@'.$domain)
	if $extension ne '';              # user+foo@example.com
    push(@keys, $localpart.'@'.$domain);  # user@example.com
    if (Amavis::Lookup::lookup($addr, \@local_domains, $local_domains_re)) {
	push(@keys, $localpart.$recipient_delimiter.$extension)
	    if $extension ne '';          # user+foo
	push(@keys, $localpart);          # user
    }
    push(@keys, '@'.$domain);             # @example.com
    push(@keys, '@.');                    # @.  (catchall)
    for (@keys) { $_=$1 if /^(.*)$/ }     # untaint keys
    do_log(5, "lookup_sql - query keys: ".join(', ', map{"\"$_\""}@keys));
    my($n) = sprintf("%d",scalar(@keys));
    my($sth) = $self->{"sth$n"};
    $sth->execute(@keys);  # do the query
    my($a_ref,$found,$match); $match = {};
    while ( defined($a_ref=$sth->fetch) ) {  # fetch query results
        my(@names) = @{$sth->{NAME_lc}};
	$found = 1; $match = {}; @$match{@names} = @$a_ref;
	my($keyname) = @names[0];  my($keyvalue) = $a_ref->[0];
	do_log(5, "lookup_sql: key($keyname)=\"$keyvalue\" matches, result=(".
		join(", ", map {$_.'=>"'.$match->{$_}.'"'} @names) .")" );
	last if $found; # first match wins, the loop is for possible future use
    }
    $sth->finish();
    do_log(5, "lookup_sql, no match")  if !$found;
    # save for future use, but only within processing of this message
    $self->{cache}->{$addr} = $match;
    section_time('lookup_sql');
    $match;
}

1;

#
package Amavis::Lookup::SQLfield;
use strict;
BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    @ISA = qw(Exporter);
}
BEGIN { import Amavis::Util qw(do_log) }

sub new($$$;$) {
    my($class, $sql_query,$fieldname, $fieldtype) = @_;
    return undef  if !defined($sql_query);
    my($self) = bless {}, $class;
    $self->{sql_query} = $sql_query;
    $self->{fieldname} = lc($fieldname);
    $self->{fieldtype} = uc($fieldtype);  # B=boolean, N=numeric, other:string
    $self;
}

sub lookup_sql_field($$) {
    my($self,$addr) = @_;
    my($match);
    if (!defined($self)) {
	do_log(5, "lookup_sql_field - undefined, no match");
    } else {
	my($field) = $self->{fieldname};
	if (!defined($self->{sql_query})) {
	    do_log(5, "lookup_sql_field($field) - null query, no match");
	} else {
	    my($h_ref) = $self->{sql_query}->lookup_sql($addr);
	    if (!defined($h_ref)) {
		do_log(5, "lookup_sql_field($field), no match");
	    } elsif (!exists($h_ref->{$field})) {
		$match = 1; # a special case: just a key present and no fields
		do_log(5, "lookup_sql_field($field) (no such field), ".
			  "matches, result=$match");
	    } else {
		$match = $h_ref->{$field};  my($found) = defined $match;
		if (!defined($match)) {  # keep undef for NULL field values
		} elsif ($self->{fieldtype} eq 'B') {   # boolean
		    # convert values 'N' 'F' and ' ' to 0
		    # to allow value to be used directly as a Perl boolean
		    $match = 0  if $match =~ /^\s*[NnFf ]\s*$/;
		} elsif ($self->{fieldtype} eq 'N') {   # numeric
		    $match = $match + 0;  # unify different numeric forms
		} elsif ($self->{fieldtype} eq 'S') {   # string
		    $match =~ s/ +$//;    # trim trailing spaces
		}
		do_log(5, "lookup_sql_field($field)" .
			(!$found ? ", no match" : " matches, result=$match") );
	    }
	}
    }
    $match;
}
1;

#
package Amavis::Lookup::RE;
use strict;
BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    @ISA = qw(Exporter);
}
BEGIN { import Amavis::Util qw(do_log) }

# Make an object out of the supplied access control list
# to make it easier later to distinguish it from simple ACL array
sub new($$) { my($class) = shift;  bless [@_], $class }

# lookup_re() performs a lookup for an e-mail address against
# access control list made up of regular expressions.
#
# The full unmodified e-mail address is always used, so splitting to
# localpart and domain or lowercasing is NOT performed. This means
# the routine is general enough to be useful for other RE tests,
# such as looking for banned file names.
#
# Each element of the list can be ref to a pair, or directly a regexp
# ('Regexp' object created by qr operator, or just a (less efficient)
# string containing a regular expression). If it is a pair, the first
# element is treated as a regexp, and the second provides a value in case
# the regexp matches. If not a pair, the implied result of a match is 1.
#
# The regular expression is taken as-is, no extra anchoring or setting
# case insensitivity is done, so use qr'(?i)^user@example\.com$',
# and not a sloppy qr'user@example.com', which can easily backfire.
# Also, if qr is used with a delimiter other than ', make sure to quote the @
#
# Example (equivalent to the example in lookup_acl):
#    $acl_re = Amavis::Lookup::RE->new(
#                       qr'@me\.ac\.uk$'i, [qr'[@.]ac\.uk$'i=>0], qr'\.uk$'i );
#    ($r,$k) = $acl_re->lookup_re('user@me.ac.uk');
# or $r = lookup('user@me.ac.uk', $acl_re);
#
# 'user@me.ac.uk'   matches me.ac.uk, returns true and search stops
# 'user@you.ac.uk'  matches .ac.uk, returns false (because of =>0) and search stops
# 'user@them.co.uk' matches .uk, returns true and search stops
# 'user@some.com'   does not match anything, falls through and returns false (undef)

sub lookup_re($$) {
    my($self,$addr) = @_;
    my($found, $fullkey, $result);
    for my $e (@$self) {
	my($key);    # missing value implies result 1
	if (ref($e) eq 'ARRAY') {  # a pair: (regexp,result)
	   ($key,$result) = ($e->[0], @$e<2 ? 1 : $e->[1]);
	} else {                     # a single regexp
	   ($key,$result) = ($e,1);
	}
      # do_log(5, "lookup_RE: key=\"$addr\", matching against RE $key");
	if ($addr =~ /$key/) { $found++; $fullkey = "$key"; last }
    }
    $fullkey = $result = undef  if !$found;
    do_log(5, "lookup_RE: key=\"$addr\"" . (!$found ? ", no match"
		: " matches \"$fullkey\", result=$result") );
    !wantarray ? $result : ($result,$fullkey);
}

1;

#
package Amavis::Lookup;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&lookup &lookup_ip_acl);
}
use subs @EXPORT_OK;

BEGIN {
    import Amavis::Util qw(do_log);
    import Amavis::Conf qw($recipient_delimiter $localpart_is_case_sensitive
			   @local_domains $local_domains_re);
    import Amavis::Timing qw(section_time);
    import Amavis::rfc2821_2822_Tools qw(split_address split_localpart);
}

# lookup_hash() performs a lookup for an e-mail address against a hash map.
# If a match is found returns whatever the map returns,
# otherwise returns undef. A match aborts further search sequence.
#
# Hash lookups (e.g. for user+foo@sub.example.com) are performed in the
# following sequence:
#  - lookup for user+foo@sub.example.com
#  - lookup for user@sub.example.com (only if $recipient_delimiter nonempty)
#  - lookup for sub.example.com
#  - lookup for .sub.example.com
#  - lookup for .example.com
#  - lookup for .com
#  - lookup for .
#  - lookup user+foo@
#  - lookup user@  (only if $recipient_delimiter is nonempty)
#
# The domain part is always matched case-insensitively,
# the localpart is lowercased iff $localpart_is_case_sensitive is true.
#
sub lookup_hash($$) {
    my($addr, $hash_ref) = @_;
    (ref($hash_ref) eq 'HASH') or die "lookup_hash: arg2 must be a hash ref";
    return undef  if !%$hash_ref;  # empty hash can't match anything
    my($localpart,$domain) = split_address($addr);  $domain = lc($domain);
    $localpart = lc($localpart)  if !$localpart_is_case_sensitive;
    # chop off leading @, and trailing dots
    $domain = $1  if $domain =~ /^\@?(.*?)\.*$/s;
    my($extension);
    if ($recipient_delimiter ne '') {
	($localpart, $extension) =
		split_localpart($localpart, $recipient_delimiter);
    }
    my($key, $match, $found);
    if ($extension ne '') {  # hash lookup for user+foo@sub.example.com
	$key = $localpart.$recipient_delimiter.$extension.'@'.$domain;
	($match = $$hash_ref{$key}, $found++)  if exists $$hash_ref{$key};
	do_log(5, "lookup_hash: key=\"$key\"" .
		  (!$found ? ", no match" : " matches, result=$match") );
    }
    if (!$found) {   # hash lookup for user@sub.example.com
	$key = $localpart . '@' . $domain;
	($match = $$hash_ref{$key}, $found++)  if exists $$hash_ref{$key};
	do_log(5, "lookup_hash: key=\"$key\"" .
		  (!$found ? ", no match" : " matches, result=$match") );
    }
    if (!$found) {   # hash lookup for sub.example.com
	$key = $domain;
	($match = $$hash_ref{$key}, $found++)  if exists $$hash_ref{$key};
	do_log(5, "lookup_hash: key=\"$key\"" .
		  (!$found ? ", no match" : " matches, result=$match") );
    }
    my($d) = $domain;
    while (!$found) {   # hash lookup for .sub.example.com .example.com .com .
	$key = "." . $d;
	if (exists($$hash_ref{$key})) { $match = $$hash_ref{$key}; $found++ }
	do_log(5, "lookup_hash: key=\"$key\"" .
		  (!$found ? ", no match" : " matches, result=$match") );
	last if $d eq '';
	$d = ($d =~ /^([^.]*)\.(.*)$/s) ? $2 : '';
    }
    if (!$found && $extension ne '') {  # hash lookup for user+foo@
	$key = $localpart . $recipient_delimiter . $extension . '@';
	($match = $$hash_ref{$key}, $found++)  if exists $$hash_ref{$key};
	do_log(5, "lookup_hash: key=\"$key\"" .
		  (!$found ? ", no match" : " matches, result=$match") );
    }
    if (!$found) {   # hash lookup for user@
	$key = $localpart . '@';
	($match = $$hash_ref{$key}, $found++)  if exists $$hash_ref{$key};
	do_log(5, "lookup_hash: key=\"$key\"" .
		  (!$found ? ", no match" : " matches, result=$match") );
    }
    # special case: just a key presence => 1
    $match = 1  if $found && !defined $match;
    $match;
}

# lookup_acl() performs a lookup for an e-mail address against
# access control list.
#
# Domain name of the supplied address is compared with each member of the
# access list in turn, the first match wins (terminates the search),
# and its value decides whether the result is true (yes, permit, pass)
# or false (no, deny, drop). Falling through without a match
# produces false (undef). Search is case-insensitive.
#
# If a list member contains a '@', the full e-mail address is compared,
# otherwise if a list member has a leading dot, the domain name part is
# matched only, and the domain as well as its subdomains can match. If there
# is no leading dot, the domain must match exactly (subdomains do not match).
#
# The presence of character '!' prepended to the list member decides
# whether the result will be true (without a '!') or false (with '!')
# in case this list member matches and terminates the search.
#
# Because search stops at the first match, it only makes sense
# to place more specific patterns before the more general ones.
#
# Although not a special case, it is good to remember that '.' always matches,
# so '.' would stop the search and return true, whereas '!.' would stop the
# search and return false (0) (which is normally not very useful,
# as false (undef) is also implied at the end of the list).
#
# Examples:
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'me.ac.uk' matches me.ac.uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'you.ac.uk' matches .ac.uk, returns false (because of '!') and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'them.co.uk' matches .uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'some.com' does not match anything, falls through and returns false (undef)
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk !. )
#   'some.com' similar to previous, except it returns 0 instead of undef
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk . )
#   'some.com' matches catchall ".", and returns true
#
# more complex example: @acl = qw(
#   !The.Boss@dept1.xxx.com .dept1.xxx.com
#   .dept2.xxx.com .dept3.xxx.com lab.dept4.xxx.com
#   sub.xxx.com !.sub.xxx.com
#   me.d.aaa.com him.d.aaa.com !.d.aaa.com .aaa.com
# );

sub lookup_acl($$) {
    my($addr, $acl_ref) = @_;
    (ref($acl_ref) eq 'ARRAY') or die "lookup_acl: arg2 must be a list ref";

    my($lcaddr) = lc($addr);
    my($localpart,$domain) = split_address($addr);
    $domain = lc($domain);
    # chop off leading @ and trailing dots
    $domain = $1  if $domain =~ /^\@?(.*?)\.*$/s;
    my($found, $fullkey, $result);
    for my $e (@$acl_ref) {
	$result = 1; $fullkey = lc($e); my($key) = $fullkey;
	if ($key =~ /^(!+)(.*)$/s) { # starts with exclamation mark(s)
	  $key = $2;
	  $result = 1-$result  if (length($1) & 1);  # negate if odd
	}
	if ($key =~ /\@/) {          # contains '@', check full address
	    $found++  if $lcaddr eq $key;
	} elsif ($key =~ /^\.(.*)$/s) {# starts with a dot: domain or subdomain
	    $found++  if $domain =~ /^ (.*? (\.|\Z))? \Q$1\E \Z/xs;
	} else {                     # match domain (but not its subdomains)
	    $found++  if $domain eq $key;
	}
	last  if $found;
    }
    $fullkey = $result = undef  if !$found;
    do_log(5, "lookup_acl: key=\"$addr\"" . (!$found ? ", no match"
		: " matches \"$fullkey\", result=$result") );
    !wantarray ? $result : ($result,$fullkey);
}

# Perform a lookup for an e-mail address against any number of supplied maps:
# - SQL map,
# - a simpler and fast hash map,
# - more versatile access control list,
# - a list of regular expressions,
# - a (defined) scalar always matches, and returns itself as the 'map' value
#   (useful as a catchall for final pass or fail);
# (see lookup_hash, lookup_acl, and lookup_sql for details).
#
# If a match is found (a defined value) returns whatever the map returns,
# otherwise returns undef. First match aborts further search sequence.
#
sub lookup($@) {
    my($addr, @tables) = @_;
    my($match);
    for my $t (@tables) {
	if (!ref($t)) {   # a scalar always matches
	    $match = $t;
	    do_log(5, "lookup: (scalar) matches, result=\"$match\"")
		if defined $match;
	} elsif (ref($t) eq 'HASH' ) { $match = lookup_hash($addr,$t);
	} elsif (ref($t) eq 'ARRAY') { $match = lookup_acl($addr,$t);
	} elsif ($t->isa('Amavis::Lookup::RE')) {
	    $match = $t->lookup_re($addr);
	} elsif ($t->isa('Amavis::Lookup::SQL')) {
	    $match = $t->lookup_sql($addr);
	} elsif ($t->isa('Amavis::Lookup::SQLfield')) {
	    $match = $t->lookup_sql_field($addr);
	} else {
	    die "TROUBLE: lookup argument is an unknown object: ".ref($t);
	}
	last if defined $match;
    }
    $match;
}

# lookup_ip_acl() performs a lookup for an IP address against
# access control list of network or host addresses.
#
# IP address is compared with each member of the access list in turn,
# the first match wins (terminates the search), and its value decides
# whether the result is true (yes, permit, pass) or false (no, deny, drop).
# Falling through without a match produces false (undef).
#
# The presence of character '!' prepended to the list member decides
# whether the result will be true (without a '!') or false (with '!')
# in case this list member matches and terminates the search.
#
# Because search stops at the first match, it only makes sense
# to place more specific patterns before the more general ones.
#
# Network can be specified in classless notation n.n.n.n/k, or using
# a mask n.n.n.n/m.m.m.m . Missing mask implies /32, i.e. a host address.
#
# Although not a special case, it is good to remember that '0/0' always matches.
#
# NOTE: IPv4 syntax is assumed, IPv6 is not supported.
#
# Example
#   given: @acl = qw( !192.168.1.12 172.16.3.3 !172.16.3/255.255.255.0
#		      10/8 172.16/12 192.168/16 );
# matches rfc1918 private address space except host 192.168.1.12
# and net 172.16.3/24 (but host 172.16.3.3 within 172.16.3/24 still matches)
#
sub lookup_ip_acl($$) {
    my($ip, $nets_ref) = @_;
    (ref($nets_ref) eq 'ARRAY') or die "lookup_ip_acl: arg2 must be a list ref";
    my($ipbin) = unpack('N', pack('C4', split(/\./, $ip, -1)));
    my($found, $fullkey, $result);
    for my $net (@$nets_ref) {
	$fullkey = $net; my($key) = $fullkey; $result = 1;
	if ($key =~ /^(!+)(.*)$/s) {  # starts with exclamation mark(s)
	  $key = $2;
	  $result = 1-$result  if (length($1) & 1);  # negate if odd
	}
	my($netip,$mask) = ($key =~ m#^([^/]*)/(.*)$#s) ? ($1,$2) : ($key,32);
	my($netipbin) = unpack('N', pack('C4', split(/\./, $netip, -1)));
	if ($mask =~ /^(\d+\.){3}\d+$/) {  #  /m.m.m.m
	    $mask = unpack('N', pack('C4',split(/\./,$mask,-1)));
	} else {
	    $mask = 32  if $mask !~ /^\d+$/ || $mask>32 || $mask<0;
	    $mask = unpack('N', pack('B32', ('1' x $mask . '0' x (32-$mask))));
	}
	$found++  if ($ipbin & $mask) == ($netipbin & $mask);

#	my($maskcompl) = $mask ^ 0xffffffff;
#	my($hostpart) = $ipbin & $maskcompl;
#	if ($maskcompl != 0 && ($hostpart == 0 || $hostpart == $maskcompl)) {
#	    # broadcast address never matches (host part 0 or -1)
#	} elsif ( ($ipbin & $mask) == ($netipbin & $mask) ) { $found++ }

	last  if $found;
    }
    $fullkey = $result = undef  if !$found;
    do_log(5, "lookup_ip_acl: key=\"$ip\"" . (!$found ? ", no match"
		: " matches \"$fullkey\", result=$result") );
    !wantarray ? $result : ($result,$fullkey);
}

1;

#
package Amavis::Expand;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&expand);
}
use subs @EXPORT_OK;

# Given a string reference and a hashref of predefined (builtin) macros,
# expand() performs a macro expansion and returns a ref to the resulting string
#
# This is a simple, yet fully fledged macro processor with proper lexical
# analysis, call stack, implied quoting levels, user supplied builtin macros,
# two builtin flow-control macros: selector and iterator, plus a macro #,
# which discards input tokens until NEWLINE (like 'dnl' in m4).
# Also recognized are the usual \c and \nnn forms for specifying special
# characters, where c can be any of: r, n, f, b, e, a, t.  Lexical analysis
# of the input string is preformed only once, macro result values are not in
# danger of being lexically parsed again. No new macros can be defined by
# processing input string (at least in this version).
#
# Simple caller-provided macros have a single character name (usually a letter)
# and can evaluate to a string (possibly empty or undef), or an array of
# strings. It can also be a subroutine reference, in which case the subroutine
# will be called whenever macro value is needed. The subroutine must return
# a scalar: a string, or an array reference, which will be treated as if
# it were specified directly.
#
# Two forms of simple macro calls are known: %x and %#x (where x is a single
# letter macro name, i.e. a key in a user-supplied hash):
#   %x   evaluates to the hash value associated with the name x;
#        if the value is an array ref, the result is a single concatenated
#        string of values separated with comma-space pairs;
#   %#x  evaluates to a number: if the macro value is a scalar, returns 0
#        for all-whitespace value, and 1 otherwise. If a value is an array ref,
#        evaluates to the number of elements in the array.
# The simple macro is evaluated only in nonquoted context, i.e. top-level
# text or in the first argument of a selector (see below). A literal percent
# character can be produced by %% or \%.
#
# More powerful expansion is provided by two builtin macros, using syntax:
#   [? arg1 | arg2 | ... ]    a selector
#   [  arg1 | arg2 | ... ]    an iterator
# where [, [?, | and ] are required tokens. To take away the special meaning
# of these characters they can be quoted by a backslash, e.g. \[? or \\ .
# Arguments are arbitrary text, possibly multiline, whitespace counts.
# Nested macro calls are permitted, proper bracket nesting must be observed.
#
# SELECTOR lets its first argument be evaluated immediately, and implicitly
# protects the remaining arguments. The first argument chooses which of the
# remaining arguments is selected as a result value. The result is only then
# evaluated, remaining arguments are discarded without evaluation. The first
# argument is usually a number (with optional leading and trailing whitespace).
# If it is a non-numeric string, it is treated as 0 for all-whitespace, and
# as 1 otherwise. Value 0 selects the very next (second) argument, value 1
# selects the one after it, etc. If the value is greater than the number
# of available arguments, the last one (but never the first) is selected.
# If there is only one alternative available but the value is greater than 0,
# an empty string is returned.
#   Examples:
#     [? 2   | zero | one | two | three ]  -> two
#     [? foo | none | any | two | three ]  -> any
#     [? 24  | 0    | one | many ]         -> many
#     [? 2   |No recipients]               -> (empty string)
#     [? %#R |No recipients|One recipient|%#R recipients]
#     [? %q  |No quarantine|Quarantined as %q]
# Note that a selector macro call can be used as a form of if-then-else,
# except that the 'then' and 'else' parts are swapped!
#
# ITERATOR in its full form takes three arguments (and ignores any extra
# arguments after that):
#     [ %x | body-usually-containing-%x | separator ]
# All iterator's arguments are implicitly quoted, iterator performs its own
# substitutions (described below). The result of an iterator call is a body
# (the second argument) repeated as many times as there are elements in the
# array denoted by the first argument. In each instance of a body
# all occurrences of token %x in the body are replaced with each successive
# element of the array. Resulting body instances are then glued together
# with a string given as the third argument. The result is finally evaluated
# as any top-level text for possible further expansion.
#
# There are two simplified forms of iterator call:
#     [ body | separator ]
# or  [ body ]
# where missing separator is considered a null string, and the missing formal
# argument name is obtained by looking for the first token of the form %x
# in the body.
#   Examples:
#     [%V| ]     a space-separated list of virus names
#
#     [%V|\n]    a newline-separated list of virus names
#
#     [%V|
#     ]          same thing: a newline-separated list of virus names
#
#     [
#         %V]    a list of virus names, each preceeded by NL and spaces
#
#     [ %R |%s --> <%R>|, ]  a comma-space separated list of sender/recipient
#                name pairs where recipient is iterated over the list
#                of recipients. (Only the (first) token %x in the first
#                argument is significant, other characters are ignored.)
#
#     [%V|[%R|%R + %V|, ]|; ]  produce all combinations of %R + %V elements
#
# A combined example:
#     [? %#C |#|Cc: [<%C>|, ]]
#     [? %#C ||Cc: [<%C>|, ]\n]#     ... same thing
# evaluates to an empty string if there are no elements in the %C array,
# otherwise it evaluates to a line:  Cc: <addr1>, <addr2>, ...\n
# The '#' removes input characters until and including newline after it.
# It can be used for clarity to allow newlines be placed in the source text
# but not resulting in empty lines in the expanded text. In the second example
# above, a backslash at the end of the line would achieve the same result,
# although the method is different: \NEWLINE is removed during initial lexical
# analysis, while # is an internal macro which, when called, actively discards
# tokens following it, until NEWLINE (or end of input) is encountered.
# Whitespace (including newlines) around the first argument %#C of selector
# call is ignored and can be used for clarity.
#
# These all produce the same result:
#     To: [%T|%T|, ]
#     To: [%T|, ]
#     To: %T
#
# See further practical examples in the supplied notification messages;
# see also README.customize file.
#
#   Author: Mark Martinec <Mark.Martinec@ijs.si>, 2002
#
sub expand($$) {
    my($str_ref)      =shift; # a ref to a source string to be macro expanded;
    my($builtins_href)=shift; # a hashref, mapping builtin macro names (single
			      # char) to macro values: strings or array refs
    my($lex_lbr, $lex_lbrq, $lex_rbr, $lex_sep, $lex_h) =
      \('[', '[?', ']', '|', '#');  # lexical elements to be used as references
    my(%lexmap);  # maps string to reference in order to protect lexels
    for (keys(%$builtins_href))
      { $lexmap{"%$_"} = \"%$_"; $lexmap{"%#$_"} = \"%#$_" }
    for ($lex_lbr, $lex_lbrq, $lex_rbr, $lex_sep, $lex_h) { $lexmap{$$_} = $_ }
    # parse lexically
    my(@tokens) = $$str_ref =~ /\G \# | \[\?? | [\]|] | % \#? . | \\ [^0-7] |
                    \\ [0-7]{1,3} | [^\[\]\\|%\n#]+ | [^\n]+? | \n /gcsx;
    # replace lexical element strings with object references,
    # unquote backslash-quoted characters and %%, and drop backslash-newlines
    my(%esc) = (r=>"\r", n=>"\n", f=>"\f", b=>"\b", e=>"\e", a=>"\a", t=>"\t");
    for (@tokens) {
      if (exists $lexmap{$_})    { $_ = $lexmap{$_} }	# replace with refs
      elsif ($_ eq "\\\n")       { $_ = '' }		# drop \NEWLINE
      elsif (/^%(%)$/)           { $_ = $1 }		#  %% -> %
      elsif (/^(%#?.)$/)         { $_ = \$1 }
      elsif (/^\\([0-7]{1,3})$/) { $_ = chr(oct($1)) }	# \nnn
      elsif (/^\\(.)$/) { $_ = (exists($esc{$1}) ? $esc{$1} : $1) }
    }
    my($level) = 0; my($quote_level) = 0;
    my(@macro_type,@arg); my($output_str) = ''; my($whereto) = \$output_str;
    while (@tokens > 0) {
      my($t) = shift(@tokens);
      if ($t eq '') {  # ignore leftovers
      } elsif ($quote_level>0 && ref($t) && ($t==$lex_lbr || $t==$lex_lbrq)) {
        $quote_level++;
        ref($whereto) eq 'ARRAY' ? push(@$whereto, $t) : ($$whereto .= $t);
      } elsif (ref($t) && $t == $lex_lbr) {   # begin iterator macro call
        $quote_level++; $level++;
        unshift(@arg,[[]]); unshift(@macro_type,''); $whereto = $arg[0][0];
      } elsif (ref($t) && $t == $lex_lbrq) {  # begin selector macro call
        $level++;
        unshift(@arg,[[]]); unshift(@macro_type,''); $whereto = $arg[0][0];
        $macro_type[0] = 'select';
      } elsif ($quote_level>1 && ref($t) && $t==$lex_rbr) {
        $quote_level--;
        ref($whereto) eq 'ARRAY' ? push(@$whereto, $t) : ($$whereto .= $t);
      } elsif ($level==1 && ref($t) && $t==$lex_sep) {  # next argument
        if ($quote_level==0 && $macro_type[0] eq 'select' && @{$arg[0]}==1)
          { $quote_level++ }
        if ($quote_level==1) {
          unshift(@{$arg[0]}, []); $whereto = $arg[0][0];  # begin next arg
        } else {
          ref($whereto) eq 'ARRAY' ? push(@$whereto, $t) : ($$whereto .= $t);
        }
      } elsif ($quote_level>0 && ref($t) && $t==$lex_rbr) {
        $quote_level--;  # quote level just dropped to 0, this is now a call
        $level--  if $level > 0;
        my(@result);
        if ($macro_type[0] eq 'select') {
          my($sel,@alternatives) = reverse @{$arg[0]};  # list of refs
          $sel = !ref($sel) ? '' : join('',@$sel); # turn ref into string
          if ($sel =~ /^\s*$/) { $sel = 0 }
          elsif ($sel =~ /^\s*(\d+)\s*$/) { $sel = 0+$1 }  # make numeric
          else { $sel = 1 }
          # provide an empty second alternative if we only have one specified
          push(@alternatives,[])  if @alternatives < 2 && $sel > 0;
          if ($sel < 0) { $sel = 0 }
          elsif ($sel > $#alternatives) { $sel = $#alternatives }
          @result = @{$alternatives[$sel]};
        } else {  # iterator
          my($cvar_r,$sep_r,$body_r,$cvar);  # place meaning to arguments
          if (@{$arg[0]}>=3) { ($cvar_r,$body_r,$sep_r) = reverse @{$arg[0]} }
          else { ($body_r,$sep_r) = reverse @{$arg[0]}; $cvar_r = $body_r }
          # find the formal argument name (iterator)
          for (@$cvar_r) { if (ref && $$_=~/^%(.)$/) { $cvar = $1; last } }
          if (exists($builtins_href->{$cvar})) {
            my($values_r) = $builtins_href->{$cvar};
	    while (ref($values_r) eq 'CODE') { $values_r = &$values_r }
            $values_r = [ $values_r ]  if !ref($values_r);
            my($ind); my($re) = qr/^%\Q$cvar\E$/;
            for my $val (@$values_r) {
              push(@result, @$sep_r)  if ++$ind>1 && ref($sep_r);
              push(@result, map {(ref && $$_=~/$re/) ? $val : $_} @$body_r);
            }
          }
        }
        shift(@macro_type);  # pop the call stack
        shift(@arg); $whereto = $level>0 ? $arg[0][0] : \$output_str;
        unshift(@tokens, @result);  # active macro call, reevaluate result
      } else { # quoted, plain string, simple macro call, or a misplaced token
        my($s) = '';
        if ($quote_level>0 || !ref($t)) { $s = $t;  # quoted or string
        } elsif ($t == $lex_h) {  # discard tokens to (and including) newline
          while (@tokens) { last if shift(@tokens) eq "\n" }
        } elsif ($$t =~ /^%\#(.)$/) {  # provide number of elements
          if (!exists($builtins_href->{$1})) { $s = 0;	# no such
          } else {
	    $s = $builtins_href->{$1};
	    while (ref($s) eq 'CODE') { $s = &$s }	# subroutine callback
	    # for array: number of elements; for scalar: nonwhite=1, other 0
	    $s = ref($s) ? @$s : ($s !~ /^\s*$/);
	  };
	} elsif ($$t =~ /^%(.)$/) {    # provide values of a builtin macro
          if (!exists($builtins_href->{$1})) { $s = '';	# no such
          } else {
	    $s = $builtins_href->{$1};
	    while (ref($s) eq 'CODE') { $s = &$s }	# subroutine callback
	    $s = join(', ',@$s)  if ref($s);
	  };
        } else { $s = $$t }   # misplaced token, e.g. a top level | or ]
        ref($whereto) eq 'ARRAY' ? push(@$whereto, $s) : ($$whereto .= $s);
      }
    }
    return \$output_str;
}

1;

#
package Amavis::In::Connection;

# Keeps relevant information about the how we received the message:
# client connection information, SMTP envelope and SMTP parameters

use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}

sub new
  { my($class) = @_; bless {}, $class }
sub client_ip       # client IP address
  { my($self)=shift; !@_ ? $self->{client_ip} : ($self->{client_ip}=shift) }
sub socket_ip       # IP address of our interface that received connection
  { my($self)=shift; !@_ ? $self->{socket_ip} : ($self->{socket_ip}=shift) }
sub socket_port     # TCP port of our interface that received connection
  { my($self)=shift; !@_ ? $self->{socket_port}:($self->{socket_port}=shift) }
sub proto           # TCP/UNIX
  { my($self)=shift; !@_ ? $self->{proto}     : ($self->{proto}=shift) }
sub smtp_proto      # SMTP/ESMTP
  { my($self)=shift; !@_ ? $self->{smtp_proto}: ($self->{smtp_proto}=shift) }
sub smtp_helo       # (E)SMTP HELO/EHLO parameter
  { my($self)=shift; !@_ ? $self->{smtp_helo} : ($self->{smtp_helo}=shift) }

1;

#
package Amavis::In::Message::PerRecip;

use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}

# per-recipient data are kept in an array of n-tuples:
#   (recipient-address, destiny, done, smtp-response-text, remote-mta, ...)
sub new     # NOTE: this class is a list, not hash
  { my($class) = @_; bless [(undef) x 6], $class }

# subs to set or access individual elements of a n-tuple by name
sub recip_addr       # recipient envelope e-mail address
  { my($self)=shift; !@_ ? $$self[0] : ($$self[0]=shift) }
sub recip_addr_modified
  { my($self)=shift; !@_ ? $$self[1] : ($$self[1]=shift) }
sub recip_destiny    # -1: reject,  0: drop,  +1: pass
  { my($self)=shift; !@_ ? $$self[2] : ($$self[2]=shift) }
sub recip_done       # false: not done, true: done (1: faked, 2: truly sent)
  { my($self)=shift; !@_ ? $$self[3] : ($$self[3]=shift) }
sub recip_smtp_response # rfc2821 response (3-digit + enhanced resp + text)
  { my($self)=shift; !@_ ? $$self[4] : ($$self[4]=shift) }
sub recip_remote_mta # remote MTA that issued the smtp response
  { my($self)=shift; !@_ ? $$self[5] : ($$self[5]=shift) }

sub recip_final_addr {  # return recip_addr_modified if set, else recip_addr
  my($self)=shift;
  my($newaddr) = $self->recip_addr_modified;
  defined $newaddr ? $newaddr : $self->recip_addr;
}

1;

#
package Amavis::In::Message;
# the main purpose of this class is to contain information
# about the message being processed

use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}
BEGIN {
    import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp);
    import Amavis::In::Message::PerRecip;
}

sub new
  { my($class) = @_; bless {}, $class }
sub rx_time         # Unix time (s since epoch) of message reception by amavisd
  { my($self)=shift; !@_ ? $self->{rx_time}    : ($self->{rx_time}=shift) }
sub msg_size        # ESMTP SIZE parameter value
  { my($self)=shift; !@_ ? $self->{msg_size}   : ($self->{msg_size}=shift) }
sub body_type       # ESMTP BODY parameter value
  { my($self)=shift; !@_ ? $self->{body_type}  : ($self->{body_type}=shift) }
sub sender          # envelope sender
  { my($self)=shift; !@_ ? $self->{sender}     : ($self->{sender}=shift) }
sub sender_contact  # unmangled sender address or undef
  { my($self)=shift; !@_ ? $self->{sender_c}   : ($self->{sender_c}=shift) }
sub sender_source   # unmangled sender address or info from the trace
  { my($self)=shift; !@_ ? $self->{sender_src} : ($self->{sender_src}=shift) }
sub mime_entity     # MIME::Parser entity holding the message
  { my($self)=shift; !@_ ? $self->{mime_entity}: ($self->{mime_entity}=shift)}
sub mail_text       # rfc2822 msg: (open) file handle, or multiline string ref
  { my($self)=shift; !@_ ? $self->{mail_text}  : ($self->{mail_text}=shift) }
sub header_edits    # Amavis::Out::EditHeader object or undef
  { my($self)=shift; !@_ ? $self->{hdr_edits}  : ($self->{hdr_edits}=shift) }
sub orig_header     # original header - an arrayref of lines, with trailing LF
  { my($self)=shift; !@_ ? $self->{orig_header}: ($self->{orig_header}=shift) }
sub orig_header_size # size of original header
  { my($self)=shift; !@_ ? $self->{orig_hdr_s} : ($self->{orig_hdr_s}=shift) }
sub orig_body_size  # size of original body
  { my($self)=shift; !@_ ? $self->{orig_bdy_s} : ($self->{orig_bdy_s}=shift) }
sub body_digest     # message digest of original body
  { my($self)=shift; !@_ ? $self->{body_digest}: ($self->{body_digest}=shift) }

# The order of entries in the list is the original order in which
# recipient addresses (e.g. obtained via 'MAIL TO:') were received.
# Only the entries that were accepted (via SMTP response code 2xx)
# are placed in the list. The ORDER MUST BE PRESERVED and no recipients
# may be added or removed from the list! This is vital in order to be able
# to produce correct per-recipient responses to a LMTP client!
# 'destiny' values match the meaning for 'final_*_destiny':
#   -1=reject, 0=discard, 1=pass

sub per_recip_data {   # get or set a listref of envelope recipient n-tuples
    my($self)=shift;
    # store a given listref of n-tuples (originals, not copies!)
    if (@_) { @{$self->{recips}} = @{$_[0]} }
    # return a listref to the original n-tuples,
    # caller may modify the data if he knows what he is doing
    $self->{recips};
}

sub recips {           # get or set a listref of envelope recipients
    my($self)=shift;
    if (@_) {  # store a copy of a given listref of recipient addresses
	# wrap scalars (strings) into n-tuples
	$self->per_recip_data([ map {
	    my($per_recip_obj) = Amavis::In::Message::PerRecip->new;
	    $per_recip_obj->recip_addr($_); $per_recip_obj->recip_destiny(1);
	    $per_recip_obj } @{$_[0]} ]);
    }
    return  if !defined wantarray;  # don't bother
    # return listref of recipient addresses
    [ map { $_->recip_addr } @{$self->per_recip_data} ];
}

1;

#
package Amavis::Out::EditHeader;

# Accumulates instructions on what lines need to be added to the message
# header, deleted, or how to change existing lines, then via a call
# to write_header() performs these edits on the fly.

use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}
BEGIN {
    import Amavis::Timing qw(section_time);
    import Amavis::Util qw(do_log sanitize_str);
}
use MIME::Words;

sub new {
    my($class) = @_;
    bless {}, $class;
}
sub prepend_header($$$;$) {
    my($self, $field_name, $field_body, $structured) = @_;
    unshift(@{$self->{prepend}}, hdr($field_name, $field_body, $structured));
}
sub append_header($$$;$) {
    my($self, $field_name, $field_body, $structured) = @_;
    push(@{$self->{append}}, hdr($field_name, $field_body, $structured));
}
sub delete_header($$) {
    my($self, $field_name) = @_;
    $self->{edit}{lc($field_name)} = undef;
}
sub edit_header($$$;$) {
    my($self, $field_name, $field_edit_sub, $structured) = @_;
    # $field_edit_sub will be called with 2 args: field name and field body;
    # it should return the replacement field body (no field name and colon),
    # with or without the trailing NL
    !defined($field_edit_sub) || ref($field_edit_sub) eq 'CODE'
	or die "edit_header: arg#3 must be undef or a subroutine ref";
    $self->{edit}{lc($field_name)} = $field_edit_sub;
}

# Insert space after colon if not present, RFC2047-encode if field body
# contains non-ASCII characters, fold long lines if needed,
# prepend space before each NL if missing, append NL if missing;
# Header fields with only spaces are not allowed.
# (rfc2822: Each line of characters MUST be no more than 998 characters,
# and SHOULD be no more than 78 characters, excluding the CRLF.
#
sub hdr($$;$) {
    my($field_name, $field_body, $structured) = @_;
    if ($field_name =~ /^(X-.*|Subject|Comments)$/i &&
	$field_body =~ /[\000-\010\013-\037\177-\377]/
    ) { # encode according to RFC 2047
	$field_body =~ s/\n[ \t]/ /g;  chomp($field_body);   # unfold
	$field_body = MIME::Words::encode_mimeword($field_body, 'q');
    }
    my($str) = $field_name . ':';
    $str .= ' '  if $field_body !~ /^[ \t]/;
    $str .= $field_body;
    chomp($str);                   # chop off trailing NL if present
    $str =~ s/(\n[^ \t])/\n $1/g;  # insert a space at line folds
    if ($structured) {
	my(@sublines) = split(/\n/,$str,-1);
	$str = ''; my($s) = ''; my($s_l) = 0;
	for (@sublines) {  # join shorter field sections
	    if ($s !~ /^\s*$/ && $s_l+length > 78) {
		$str .= "\n"  if $str ne '';
		$str .= $s; $s = ''; $s_l = 0;
	    }
	    $s .= $_;  $s_l += length($_);
	}
	if ($s !~ /^\s*$/) {
	    $str .= "\n"  if $str ne '';
	    $str .= $s;
	}
    } elsif (length($str) > 999) {
       ## to be done
    }
    $str .= "\n";                  # append final NL
    do_log(5, "header: ".sanitize_str($str));
    $str;
}

# Copy mail header to the supplied method (line by line)
# while adding, removing, or changing certain header lines as required;
# Returns number of original 'Received:' lines to make simple loop detection
# possible (as required by rfc2821 section 6.2).
#
# Assumes input file is properly positioned, leaves it positioned
# at the beginning of the body.
#
sub write_header($$$) {
    my($self,$msg,$out_fh) = @_;
    $out_fh = IO::Wrap::wraphandle($out_fh);    # assure an IO::Handle-like obj
    my($is_mime) = ref($msg) && $msg->isa('MIME::Entity');
    my(@header);
    if ($is_mime) {
	@header = map { /^[ \t]*\n?$/ ? ()    # remove empty lines, assure NL
				    : (/\n$/ ? $_ : $_."\n") } @{$msg->header};
    }
    my($received_cnt) = 0; my($str) = '';
    for (@{$self->{prepend}}) { $str .= $_ }
    if ($str ne '') { $out_fh->print($str) or die "sending mail header1: $!" }
    if (!defined($msg)) {
	# existing header empty
    } elsif (!exists($self->{edit}) || !scalar(%{$self->{edit}})) {
	# no edits needed, do it the fast way
	if ($is_mime) {
	    # NOTE: can't use method print_header, as it assumes file glob
	    for my $h (@header) {
		$out_fh->print($h) or die "sending mail header2: $!";
	    }
	} else {  # assume file handle
	    while (<$msg>) {         # copy header only, read line by line
		last if $_ eq "\n";  # end of header
		$out_fh->print($_) or die "sending mail header3: $!";
	    }
	}
    } else {
	my($curr_head, $next_head);
	while ( defined($next_head = $is_mime ? shift @header : <$msg>) ) {
	    if ($next_head =~ /^[ \t]/) { $curr_head .= $next_head }  # folded
	    else {  # new header
		if (!defined($curr_head)) { # no previous complete header
		} elsif ($curr_head !~ /^([!-9;-\176]+)[ \t]*:(.*)$/s) {
		    # invalid header, but we don't care
		    $out_fh->print($curr_head) or die "sending mail header4: $!";
		} else {  # count, edit, or delete
		    # obsolete rfc822 syntax allowed whitespace before colon
		    my($field_name,$field_body) = ($1,$2);
		    my($field_name_lc) = lc($field_name);
		    $received_cnt++  if $field_name_lc eq 'received';
		    if (! exists($self->{edit}{$field_name_lc})) {  # unchanged
			$out_fh->print($curr_head) or die "sending mail header5: $!";
		    } else {
			my($edit) = $self->{edit}{$field_name_lc};
			if (defined($edit)) {  # edit, not delete
			    chomp($field_body);
			    ### $field_body =~ s/\n([ \t])/$1/sg;  # unfold
			    $out_fh->print(hdr($field_name,
					      &$edit($field_name,$field_body)))
				or die "sending mail header6: $!";
			}
		    }
		}
		last if $next_head eq "\n";  # end-of-header reached
		$curr_head = $next_head;
	    }
	}
    }
    $str = '';
    for (@{$self->{append}}) { $str .= $_ }
    $str .= "\n";  # end of header - separator line
    $out_fh->print($str) or die "sending mail header7: $!";
    section_time('write-header');
    $received_cnt;
}
1;

#
package Amavis::Out::Local;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(&mail_to_local_mailbox);
}

use IO::File;
use IO::Wrap;

BEGIN {
    import Amavis::Conf qw($gzip $bzip2 %local_delivery_aliases
			   $notify_method $can_truncate);
    import Amavis::Lock;
    import Amavis::Util qw(do_log am_id);
    import Amavis::Timing qw(section_time);
    import Amavis::rfc2821_2822_Tools;
    import Amavis::Out::EditHeader;
}

use subs @EXPORT_OK;

# Deliver to local mailboxes only, ignore the rest: either to directory
# (maildir style), or file (Unix mbox).  (normally used as a quarantine method)
#
sub mail_to_local_mailbox(@) {
    my($via,$msginfo,$initial_submission,$filter) = @_;
    my(@per_recip_data) = grep {!$_->recip_done && (!$filter || &$filter($_))}
			       @{$msginfo->per_recip_data};
    return 1  if !@per_recip_data;
    my($msg) = $msginfo->mail_text; # a scalar reference, or a file handle
    if (defined($msg) && !$msg->isa('MIME::Entity')) {
	# at this point, we have no idea what the user gave us...
	# a globref? a FileHandle?
	$msg = IO::Wrap::wraphandle($msg); # now we have an IO::Handle-like obj
    }
    my($sender) = $msginfo->sender;
    for my $r (@per_recip_data) {
	my($recip) = $r->recip_final_addr;
	next  if $recip eq '';
	my($localpart,$domain) = split_address($recip);
	my($smtp_response);

	# Emulate aliases map by %local_delivery_aliases - this would otherwise
	# be done by MTA's local delivery agent if we gave the message to MTA.
	# This way we keep interface compatible with other mail delivery
	# methods. The hash value may be a ref to a pair of fixed strings,
	# or a subroutine ref (which must return a pair) to allow delayed
	# (lazy) evaluation when some part of the pair is not yet known
	# at initialization time.

	{ # a block is used as a 'switch' statement - 'last' will exit from it
	    if (!exists $local_delivery_aliases{$localpart}) {
		do_log(2, "skip local delivery(1): <$sender> -> <$recip>");
		$smtp_response = "250 2.6.0 Ok, skip local delivery(1)";
		last;  # exit block, not the loop
	    }
	    my($alias) = $local_delivery_aliases{$localpart};
	    my($mbxname, $suggested_filename);
	    if (ref($alias) eq 'ARRAY') {
		($mbxname, $suggested_filename) = @$alias;
	    } elsif (ref($alias) eq 'CODE') {   # lazy evaluation
		($mbxname, $suggested_filename) = &$alias;
	    } else {
		($mbxname, $suggested_filename) = ($alias, undef);
	    }
	    if ($mbxname eq '') {
		do_log(2, "skip local delivery(2): <$sender> -> <$recip>");
		$smtp_response = "250 2.6.0 Ok, skip local delivery(2)";
		last;  # exit block, not the loop
	    }
	    my($ux);  # is it a UNIX-style mailbox?
	    if (!-d $mbxname) { # assume a filename (need not exist yet)
		$ux = 1;  # $mbxname is a UNIX-style mailbox (one file)
	    } else {		# a directory
		$ux = 0;  # $mbxname is a amavis/maildir style mailbox (a directory)
		if ($suggested_filename eq '') {  # make up a default file name
		    $suggested_filename = sprintf("msg-%s-%s",
				strftime("%Y%m%d-%H%M%S",localtime), am_id());
		}
		# one mail per file, will create specified file
		$mbxname = "$mbxname/$suggested_filename";
	    }
	    do_log(1, "local delivery: <$sender> -> <$recip>, mbx=$mbxname");
	    my($pos,$pipe);
	    stat($mbxname);
	    eval {  # try to open the mailbox file for writing
		if (!$ux) {  # new file, traditional amavis, or maildir
		    if (-e _) {
			die "File $mbxname already exists, refuse to overwrite";
		    }
		    if (defined($gzip) && $mbxname =~ /\.gz$/) {
			open(MP,"|$gzip -c >$mbxname") or die "gzip failed: $!";
			$pipe = 1;
		    } else {
			open(MP,">$mbxname") or die "Can't create $mbxname: $!";
		    }
		} else {     # append to UNIX-style mailbox
		    # deliver only to non-executable regular files
		    if (!-e _) {
			open(MP,">$mbxname") or die "Can't create $mbxname: $!";
		    } elsif (!-f _) {
			die "Mailbox $mbxname is not a regular file, refuse to deliver";
		    } elsif (-x _ || -X _) {
			die "Mailbox file $mbxname is executable, refuse to deliver";
		    } else {
			open(MP,">>$mbxname") or die "Can't append to $mbxname: $!";
		    }
		    lock(\*MP);  # also seeks to the end, so we don't have to
		    $pos = tell MP;
		}
		if (defined($msg) && !$msg->isa('MIME::Entity')) {
		    $msg->seek(0,0) or die "Can't rewind mail file: $!";
		}
	    };
	    if ($@ ne '') {
		chomp($@);
		$smtp_response = $@ eq "timed out" ? "450 4.4.2" : "451 4.5.0";
		$smtp_response .= " Local delivery(1) to $mbxname failed: $@";
		last;  # exit block, not the loop
	    }
	    eval {  # if things fail from here on, try to restore mailbox state
		printf MP ("From %s  %s\n",
			   quote_rfc2821_local($sender), scalar(localtime) )
		    or die "Can't write to $mbxname: $!"  if $ux;
		my($hdr_edits) = $msginfo->header_edits;
		$hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
		$hdr_edits->delete_header('Return-Path');
		$hdr_edits->prepend_header('Delivered-To',
		    quote_rfc2821_local($recip));
		$hdr_edits->prepend_header('Return-Path',
		    qquote_rfc2821_local($sender));
		my($received_cnt) = $hdr_edits->write_header($msg,\*MP);
		if ($received_cnt > 110) {
		    # loop detection required by rfc2821 section 6.2
		    # Do not modify the signal text, it gets matched elsewhere!
		    die "Too many hops: $received_cnt 'Received:' header lines\n";
		}
		if (!$ux) { # do it in blocks for speed if we can
		    while ( $msg->read($_,16384) > 0 ) {
			print MP $_ or die "Can't write to $mbxname: $!";
		    }
		} else {    # for UNIX-style mailbox delivery: escape 'From '
		    while(<$msg>) {
			print MP '>' or die "Can't write to $mbxname: $!" if /^From /;
			print MP $_ or die "Can't write to $mbxname: $!";
		    }
		}
		# must append an empty line for a Unix mailbox format
		print MP "\n" or die "Can't write to $mbxname: $!"  if $ux;
	    };
	    my($failed) = 0;
	    if ($@ ne '') {  # trouble
		chomp($@);
		if ($ux && defined($pos) && $can_truncate) {
		    # try to restore UNIX-style mailbox to previous size;
		    # Produces a fatal error if truncate isn't implemented
		    # on your system.
		    truncate(MP,$pos) or die "Can't truncate file $mbxname: $!";
		}
		$failed = 1;
	    }
	    unlock(\*MP)  if $ux;
	    close(MP) or die ("Can't close $mbxname: " . ($pipe ? $? : $!) );
	    if (!$failed)                    { $smtp_response =
		"250 2.6.0 Ok, delivered to $mbxname";
	    } elsif ($@ eq "timed out")      { $smtp_response =
		"450 4.4.2 Local delivery to $mbxname timed out";
	    } elsif ($@ =~ /too many hops/i) { $smtp_response =
		"550 5.4.6 Rejected delivery to mailbox $mbxname: $@";
	    } else                           { $smtp_response =
		"451 4.5.0 Local delivery to mailbox $mbxname failed: $@";
	    }
	}  # end of block, 'last' within block brings us here
	do_log(0, $smtp_response)  if $smtp_response !~ /^2/;
	$smtp_response .= ", id=" . am_id();
	$r->recip_smtp_response($smtp_response);
	$r->recip_done(2);
	section_time('save-to-local-mailbox');
    }
}

1;

#
package Amavis::Out;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = qw(&mail_dispatch &relayhost_client
	&EX_OK &EX_UNAVAILABLE &EX_TEMPFAIL &EX_NOPERM);
}

BEGIN {
  eval {require 'sysexits.ph'};  # try to use the installed version
  # define the most important constants if undefined
  do { sub EX_OK()          {0}  } unless defined(&EX_OK);
  do { sub EX_UNAVAILABLE() {69} } unless defined(&EX_UNAVAILABLE);
  do { sub EX_TEMPFAIL()    {75} } unless defined(&EX_TEMPFAIL);
  do { sub EX_NOPERM()      {77} } unless defined(&EX_NOPERM);
}

use IO::File;
use IO::Wrap;
use Net::Cmd;
use Net::SMTP 2.24;

BEGIN {
    import Amavis::Conf qw($DEBUG $localhost_name
			   $notify_method $relayhost_is_client);
    import Amavis::Util qw(do_log am_id retcode prolong_timer sanitize_str);
    import Amavis::Timing qw(section_time);
    import Amavis::rfc2821_2822_Tools;
    import Amavis::Out::Local qw(mail_to_local_mailbox);
    import Amavis::Out::EditHeader;
}

sub mail_dispatch($$$;$) {
    my($via) = shift;
    if ($via =~ /^smtp:/i) {
	mail_via_smtp($via,@_);
    } elsif ($via =~ /^pipe:/i) {
	mail_via_pipe($via,@_);
    } elsif ($via =~ /^local:/i) {
	# used by the quarantine code to relieve it of the need to know
	# which delivery method needs to be used
	my($msginfo,$initial_submission,$filter) = @_;
	# deliver what is local (does not contain '@')
	mail_to_local_mailbox($via,$msginfo,$initial_submission,
			      sub {shift->recip_final_addr !~ /\@/ ? 1 : 0} );
	if (grep {! $_->recip_done } @{$msginfo->per_recip_data}) {
	    # deliver the rest
	    if ($notify_method =~ /^smtp:/i) {
		mail_via_smtp($notify_method,@_);
	    } elsif ($notify_method =~ /^pipe:/i) {
		mail_via_pipe($notify_method,@_);
	    }
	}
    };
}

use vars qw($relayhost_client);
sub relayhost_client   # access to $relayhost_client
    { !@_ ? $relayhost_client : ($relayhost_client=shift) }


# trivial OO wrapper around Net::SMTP::datasend
sub new_smtp_data
    { my($class,$sh) = @_; bless \$sh, $class }
sub print
    { my($self) = shift; $$self->datasend(@_) }

# Send mail using SMTP
# (e.g. forwarding original mail or sending notification)
# May throw exception (die) if temporary failure (4xx) or other problem
#
sub mail_via_smtp(@) {
    my($via,$msginfo,$initial_submission,$filter) = @_;

    $via =~ /^smtp:([^:]*):([^:]*)(:.*)?$/i  or die "Bad fwd method: $via";
    my($relayhost,$relayhost_port) = ($1,$2);
    if ($relayhost_is_client && relayhost_client() ne '')
	{ $relayhost = relayhost_client() }
    my(@per_recip_data) = grep {!$_->recip_done && (!$filter || &$filter($_))}
			       @{$msginfo->per_recip_data};
    my($logmsg) = sprintf("%s via SMTP: [%s:%s] <%s>",
	($initial_submission ? 'SEND' : 'FWD'),
	$relayhost, $relayhost_port, $msginfo->sender);
    if (!@per_recip_data) { do_log(5, "$logmsg, no recipients"); return 1 }
    do_log(1, $logmsg . " -> " .
	join(",", map {"<".$_->recip_final_addr.">"} @per_recip_data));
    my($msg) = $msginfo->mail_text; # a scalar reference, or a file handle
    my($smtp_handle,$smtp_response);
    my($smtp_code, $smtp_status, $smtp_msg, $received_cnt);
    my($any_valid_recips, $any_valid_recips_and_data_sent);
    if (defined($msg) && !$msg->isa('MIME::Entity')) {
	# at this point, we have no idea what the user gave us...
	# a globref? a FileHandle?
	$msg = IO::Wrap::wraphandle($msg); # now we have an IO::Handle-like obj
	$msg->seek(0,0) or die "Can't rewind mail file: $!";
    }
    # NOTE: Net::SMTP uses alarm to do its own timing.
    #       We need to restart our timer when Net::SMTP is done using it !!!
    my($remaining_time) = alarm(0);  # check how much time is left, stop timer
    eval {
	# Timeout should be more than MTA normally takes to check DNS and RBL,
	# which may take a minute or more in case of unreachable DNS.
	# Specifying shorter timeout will cause alarm to terminate the wait
	# for SMTP status line prematurely, resulting in status code 000.
	# rfc2821 (section 4.5.3.2) requires timeout to be at least 5 minutes
	$smtp_handle = Net::SMTP->new("$relayhost:$relayhost_port",
	    Hello => $localhost_name, Timeout => 4*60, Debug => 0);
	defined($smtp_handle) or die "Can't connect to $relayhost port $relayhost_port";
	section_time('fwd-connect');

	do_log(5, "Remote host claims to be ".$smtp_handle->domain);

	$smtp_handle->mail(qquote_rfc2821_local($msginfo->sender))
	    or die "sending MAIL FROM\n";
	section_time('fwd-mail-from');

	for my $r (@per_recip_data) { # send recipient addresses
	    $smtp_handle->recipient(qquote_rfc2821_local($r->recip_final_addr));
	    my($smtp_status) = $smtp_handle->status;
	    if ($smtp_status == CMD_OK) {
		$any_valid_recips++;
	    } elsif ($smtp_status == CMD_PENDING) {
		# hm, what to do, this is bad
		do_log(0, "response to RCPT TO pending, assuming it will be ok");
	    } else {  # not ok
		my($smtp_code) = $smtp_handle->code;
		my($smtp_msg) = $smtp_handle->message; chomp($smtp_msg);
		# remove nonprintable characters
		$smtp_msg =~ s/[\000-\040\177\200-\237\377]+/ /g;
		$smtp_msg =~ s/\s+$//;             # trim trailing white space
		my($smtp_resp) = "$smtp_code $smtp_msg";
		do_log(5, "response to RCPT TO: \"$smtp_resp\"");
		if ($smtp_resp =~ /^ (\d{3}) \s+ ([245] \. \d{1,3} \. \d{1,3})?
				     \s* (.*) $/xs) {
		    my($resp_code,$resp_enhcode,$resp_msg) = ($1,$2,$3);
		    if ($resp_enhcode eq '' && $resp_code =~ /^([245])/ ) {
			$resp_enhcode = "$1.1.0";  # insert enhanced code
			$smtp_resp = "$smtp_code $resp_enhcode $smtp_msg";
		    }
		}
		$r->recip_smtp_response($smtp_resp);
		$r->recip_remote_mta($relayhost);
		$r->recip_done(2);
	    }
	}
	section_time('fwd-rcpt-to');
	if ($any_valid_recips) {  # send the message
	    $smtp_handle->data or die "sending DATA command\n";
	    my($smtp_data_fh) = Amavis::Out->new_smtp_data($smtp_handle);
	    my($hdr_edits) = $msginfo->header_edits;
	    $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
	    $received_cnt = $hdr_edits->write_header($msg, $smtp_data_fh);
	    if ($received_cnt > 100) {
		# loop detection required by rfc2821 6.2
		# Do not modify the signal text, it gets matched elsewhere!
		die "Too many hops: $received_cnt 'Received:' header lines\n";
	    }
	    if (!defined($msg)) {
		# empty mail body
	    } elsif ($msg->isa('MIME::Entity')) {
		$msg->print_body($smtp_data_fh);
	    } else {
		# Using fixed-size reads instead of line-by-line approach
		# makes feeding mail back to MTA (e.g. Postfix) more than
		# twice as fast for larger mail.
		while ( $msg->read($_,16384) > 0 ) {
		    $smtp_handle->datasend($_)
			or die "sending mail body from file\n";
		}
	    }
	    section_time('fwd-data');
	    # don't check status of dataend here, it may not yet be available
###???	    $smtp_handle->dataend or die "finishing sending data\n";
	    $smtp_handle->dataend;
	    $any_valid_recips_and_data_sent = 1;

	    # figure out the final SMTP response
	    $smtp_code = $smtp_handle->code;
	    $smtp_status = $smtp_handle->status;
	    my(@msgs) = $smtp_handle->message;
	    # only the 'command()' resets messages list, so now we have both:
	    # 'End data with <CR><LF>.<CR><LF>' and 'Ok: queued as...' in @msgs
	    my($smtp_msg) = $msgs[$#msgs]; chomp($smtp_msg);  # take the last one
	    # remove nonprintable characters
	    $smtp_msg =~ s/[\000-\040\177\200-\237\377]+/ /g;
	    $smtp_msg =~ s/\s+$//;             # trim trailing white space
	    $smtp_response = "$smtp_code $smtp_msg";
	    do_log(5, "response to data end: \"$smtp_response\"");
	    if ($smtp_response =~ /^[245]/) {
		$smtp_response = sprintf("%s %d.6.0 %s, id=%s, from MTA: %s",
				 $smtp_code, $smtp_status,
				 ($smtp_status==2 ? 'Ok' : 'Failed'),
				 am_id(), $smtp_response);
	    }
	}
    };
    my($err) = $@;
    prolong_timer('fwd-rundown', $remaining_time); # restart the timer
    if ($err ne '') {  # fetch info about failure
	if (!defined($smtp_handle)) { $smtp_msg = '' }
	else {
	    $smtp_code = $smtp_handle->code;
	    $smtp_status = $smtp_handle->status;
	    $smtp_msg = $smtp_handle->message; chomp($smtp_msg);
	}
	# remove nonprintable characters
	$smtp_msg =~ s/[\000-\040\177\200-\237\377]+/ /g;
	$smtp_msg =~ s/\s+$//;                # trim trailing white space
    }
    # send a QUIT regardless of success so far
    $smtp_handle->quit  if defined $smtp_handle;
    if ($err eq '' && defined $smtp_handle && $smtp_handle->status != CMD_OK) {
	do_log(0, "Warning: sending SMTP QUIT command failed");
    }
    if ($err eq '') {    # no errors
	if ($any_valid_recips_and_data_sent && $smtp_response !~ /^[245]/) {
	    $smtp_response = sprintf("451 4.6.0 Bad SMTP code, id=%s, from MTA: \"%s\"",
				 am_id(), $smtp_response);
	}
    } else {
        chomp($err);
	if ($err eq "timed out" || $err =~ /: Timeout$/) {
	    $smtp_response = sprintf("450 4.4.2 Timed out, %s %s, id=%s",
					   $smtp_code, $smtp_msg, am_id());
	} elsif ($err =~ /^Can't connect/) {
	    $smtp_response = sprintf("450 4.4.1 %s, id=%s", $err, am_id());
	} elsif ($err =~ /^Too many hops/) {
	    $smtp_response = sprintf("550 5.4.6 Rejected: %s, id=%s",
				     $err, am_id());
	} elsif ($smtp_status == CMD_ERROR) {  # 5xx
	    $smtp_response = sprintf("%s 5.5.0 Rejected by MTA: %s %s, id=%s",
			    ($smtp_code !~ /^5\d\d$/ ? "550" : $smtp_code),
			    $smtp_code, $smtp_msg, am_id());
	} elsif ($smtp_status == CMD_PENDING) {  # 0
	    $smtp_response = sprintf("450 4.4.2 No response (%s): id=%s",
					   $err, am_id());
	} else {
	    $smtp_response = sprintf(
		"%s 4.5.0 from MTA (%s): %s %s, id=%s",
		($smtp_code !~ /^4\d\d$/ ? "451" : $smtp_code),
		$err, $smtp_code, $smtp_msg, am_id());
	}
    }
    if (! $any_valid_recips_and_data_sent) {
	do_log(3, "mail_via_smtp: no recipients, DATA skipped");
    } else {
	do_log(($smtp_response=~/^2/ ? 3 : 0),"mail_via_smtp: $smtp_response");
    }
    if (defined $smtp_response) {
	for my $r (@per_recip_data) {
	    next  if $r->recip_done;
	    $r->recip_smtp_response($smtp_response);
	    $r->recip_remote_mta($relayhost);
	    $r->recip_done(2);
	}
    }
    section_time('fwd-rundown');
    1;
}

# Send mail using external program 'sendmail' (also available with Postfix
# and Exim) - used for forwarding original mail or sending notifications.
# May throw exception (die) if temporary failure (4xx) or other problem
#
sub mail_via_pipe(@) {
    my($via,$msginfo,$initial_submission,$filter) = @_;

    $via =~ /^pipe:(.*)$/i  or die "Bad fwd method: $via";
    my($pipe_args) = $1;
    $pipe_args =~ s/^flags=\S*\s*//i;  # flags are currently ignored, q implied
    $pipe_args =~ s/^argv=//i;
    my(@per_recip_data) = grep {!$_->recip_done && (!$filter || &$filter($_))}
			       @{$msginfo->per_recip_data};
    my($logmsg) = sprintf("%s via PIPE: <%s>",
	($initial_submission ? 'SEND' : 'FWD'), $msginfo->sender);
    if (!@per_recip_data) { do_log(5,"$logmsg, no recipients"); return 1 }
    do_log(1, $logmsg . " -> " .
	join(",", map {"<".$_->recip_final_addr.">"} @per_recip_data));
    my($msg) = $msginfo->mail_text; # a scalar reference, or a file handle
    if (defined($msg) && !$msg->isa('MIME::Entity')) {
	# at this point, we have no idea what the user gave us...
	# a globref? a FileHandle?
	$msg = IO::Wrap::wraphandle($msg); # now we have an IO::Handle-like obj
	$msg->seek(0,0) or die "Can't rewind mail file: $!";
    }
    return 1  if !@per_recip_data;
    my(@pipe_args) = split(' ',$pipe_args);
    my(@command) = shift @pipe_args;
    for (@pipe_args) {
	if (/^\${sender}$/i) {
	    push(@command, quote_rfc2821_local($msginfo->sender));
	} elsif (/^\${recipient}$/i) {
	    push(@command, map { quote_rfc2821_local($_->recip_final_addr) }
			       @per_recip_data);
	} else { push(@command, $_) }
    }
    do_log(5,"mail_via_pipe running command: ".join(' ',@command));
    $SIG{PIPE} = 'IGNORE';  # write to broken pipe throws a signal
    my($pid) = open(MP, '|-');
    defined($pid) or die "Can't fork: $!";
    if (!$pid) {  # child
	# The sendmail command line expects addresses quoted as per RFC 822.
	#   "funny user"@some.domain
	# For compatibility with Sendmail, the Postfix sendmail command line
	# also accepts address formats that are legal in RFC 822 mail headers:
	#   Funny Dude <"funny user"@some.domain>
	exec(@command);
	exec('/bin/false');# must not exit, we have to avoid DESTROY handlers
	exit EX_TEMPFAIL;  # just in case
	# NOTREACHED
    }
    # parent
    my($hdr_edits) = $msginfo->header_edits;
    $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
    my($received_cnt) = $hdr_edits->write_header($msg,\*MP);
    if ($received_cnt > 100) {  # loop detection required by rfc2821 6.2
	# deal with it later, for now just skip the body
    } elsif (!defined($msg)) {
	# empty mail body
    } elsif ($msg->isa('MIME::Entity')) {
	$msg->print_body(\*MP);
    } else {
	while ( $msg->read($_,16384) > 0 ) {
	    print MP $_ or die "Submitting mail text failed: $!";
	}
    }
    my($smtp_response);
    if ($received_cnt > 100) {  # loop detection required by rfc2821 6.2
	do_log(0, "Too many hops: $received_cnt 'Received:' header lines");
	kill(15,$pid);   # kill the process running mail submission program
	close(MP);  # and ignore status
	$smtp_response = "550 5.4.6 Rejected: " .
	    "Too many hops: $received_cnt 'Received:' header lines";
    } else {
	close(MP);  my($status) = retcode($?);
	# sendmail program (Postfix variant) can return the following exit codes:
	# EX_OK (=0), EX_DATAERR, EX_SOFTWARE, EX_TEMPFAIL, EX_UNAVAILABLE
	if ($status == EX_OK) {
	    $smtp_response = "250 2.6.0 Ok";  # submitted to MTA
	} elsif ($status == EX_TEMPFAIL) {
	    $smtp_response = "450 4.5.0 Temporary failure submitting message";
	} elsif ($status == EX_UNAVAILABLE) {
	    $smtp_response = "550 5.5.0 Mail submission service unavailable";
	} else {
	    $smtp_response = "451 4.5.0 Unknown failure submitting message";
	}
    }
    $smtp_response .= ", id=" . am_id();
    for my $r (@per_recip_data) {
	next  if $r->recip_done;
	$r->recip_smtp_response($smtp_response);
	$r->recip_done(2);
    }
    section_time('fwd-pipe');
    1;
}

1;

#
package Amavis::UnmangleSender;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&best_try_originator &first_received_from);
}
use subs @EXPORT_OK;

BEGIN {
    import Amavis::Conf qw($viruses_that_fake_sender_re);
    import Amavis::Util qw(do_log sanitize_str);
    import Amavis::rfc2821_2822_Tools qw(split_address);
}
use Mail::Address;

# Returns the envelope sender address, or reconstructs it if there is
# a good reason to believe the envelope address has been changed or forged,
# as is common for some varieties of viruses. Returns best guess of the
# sender address, or undef if it can not be determined.
#
sub unmangle_sender($$$) {
    my $sender = shift;	# rfc2821 envelope sender address
    my $from   = shift;	# rfc2822 'From:' header, may include comment
    my $virusname_list = shift; # list ref containing names of detected viruses
    # based on ideas from Furio Ercolessi, Mike Atkinson, Mark Martinec

    my($best_try_originator) = $sender;
    my($localpart,$domain) = split_address($sender);
    # extract the RFC2822 'from' address, ignoring phrase and comment
    chomp($from);
    $from = (Mail::Address->parse($from))[0];
    $from = $from->address  if $from ne '';
    # NOTE: rfc2822 allows multiple addresses in the From field!

    if (grep { /magistr/i } @$virusname_list) {
	for my $j (0..2) {  #  assemble possible `shifted' candidates
	    next if $j >= length($localpart);
	    my($try) = $sender;
	    substr($try,$j,1) = chr(ord(substr($try,$j,1))-1);
	    if ($from =~ /^\Q$try\E$/i) { $best_try_originator = $try; last }
	}
    }
#
#   Virus names are AV-checker vendor specific, but many use same
#   or similar virus names. This requires attention and adjustments
#   from Amavis administrators.
#
    if (grep { /badtrans/i } @$virusname_list) {
	if ($from =~ /^     # these are fake built-in addresses
	    (joanna\@mail\.utexas\.edu | powerpuff\@videotron\.ca |
	     (mary\@c-com | support\@cyberramp | admin\@gte |
	      administrator\@border) \.net |
	     (monika\@telia | jessica\@aol | spiderroll\@hotmail |
	      lgonzal\@hotmail | andy\@hweb-media | Gravity49\@aol |
	      tina0828\@yahoo | JUJUB271\@AOL | aizzo\@home) \.com
	     ) $/xi
	) { # discard recipient's address used as a fake 'MAIL FROM:'
	    $best_try_originator = undef;
	} else {
	    $best_try_originator = $1  if $from =~ /^_(.+)$/ &&
					  lc($sender) ne lc($1);
	}
    }
    for my $vn (@$virusname_list) {
	my($result,$patt) = $viruses_that_fake_sender_re->lookup_re($vn);
	if ($result) {
	    do_log(2,"Virus $vn matches pattern $patt, sender addr ignored");
	    $best_try_originator = undef;
	    last;
	}
    }
}

# Given a dotted-quad IP address try reverse DNS resolve, and then
# forward DNS resolve. If they match, return domain name,
# otherwise return the IP address in brackets. (works for IPv4 only)
#
sub ip_addr_to_name($) {
    my($addr) = shift;  # quad-dot address string
    my($binaddr) = pack('C4',split(/\./,$addr)); # to binary string
    my(@addr) = gethostbyaddr($binaddr,2);  # IP -> name
    if (@addr) {
	my($name,$aliases,$addrtype,$length,@addrs) = @addr;
	if ($name =~ /\.[a-zA-Z]+$/) {
	    my(@raddr) = gethostbyname($name);  # name -> IP
	    my($rname,$raliases,$raddrtype,$rlength,@raddrs) = @raddr;
	    for my $ra (@raddrs) { return $name  if lc($ra) eq lc($binaddr) }
	}
    }
    '[' . $addr . ']';  # return IP address in brackets if nothing matches
}

# Obtain and parse the first entry (chronologically) in the 'Received:' header
# path trace - to be used as the value of the macro %t in customized messages
#
sub first_received_from($) {
    my($entity) = shift;
    my($first_received);
    if (defined($entity)) {
	my($received) = $entity->head->get('received',-1);  # last Received: header
	$received =~ s/\n([ \t])/$1/g;	# unfold
	$received =~ s/[\r\n]/ /g;	# turn remaining CR or NL into spaces
	$first_received = $received;
	if ($received =~			# not an exact science this parsing
	    /^ (?: \( [^)]* \) | < [^>]* > | \[ [^]]* \] | [^(<\[] )*?
		\b from \s+
		( (?: \( [^)]* \) | < [^>]* > | \[ [^]]* \] | [^(<\[] )*? )
		(\s+ (by|via|with|id|for) \s+ .*)?
		\s* ; [^;]*? $/xi) {
		    $first_received = $1;
	}
    }
    $first_received;
};

# For the purpose of informing administrators try to obtain true sender
# address or at least its site, as certain viruses have a nasty habit
# of faking envelope sender address. Return a pair of addresses:
# - the first (if defined) appears valid and may be used for sender
#   notifications;
# - the second should only be used in generating customizable notification
#   messages (macro %o), NOT to be used as address for sending notifications,
#   as it can contain nonvalid address (but can be more informative).
#
sub best_try_originator($$$) {
    my($sender,$entity,$virusname_list) = @_;
    return ($sender,$sender)  if !defined($entity); # don't bother if no header
    my($originator) = unmangle_sender($sender, $entity->head->get('from',0),
				      $virusname_list);
    return ($originator,$originator)  if defined($originator);
    my($first_received) = first_received_from($entity);
    my($first_received_from_ip);
    if ($first_received =~
	/ \[ (\d{1,3} \. \d{1,3} \. \d{1,3} \. \d{1,3}) \] /x) {
	$first_received_from_ip = $1;
    } elsif ($first_received =~
	/ (\d{1,3} \. \d{1,3} \. \d{1,3} \. \d{1,3}) (?!\d) /x) {
	$first_received_from_ip = $1;
    }
    $originator = '?@' . ip_addr_to_name($first_received_from_ip)
					if defined $first_received_from_ip;
    (undef, $originator);
}

1;

#
package Amavis::Unpackers::NewFilename;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}
BEGIN {
    import Amavis::Util qw(do_log);
}

sub new($;$) {               # create a file name generator object
    my($class,$maxfiles) = @_;
    bless {
	num_of_issued_names => 0,
	first_issued_ind => 1,  last_issued_ind => 0,
	maxfiles => $maxfiles,  # may be undef, to disable limit
	type => {},
    }, $class;
}

sub parts_list_reset($) {   # clear a list of recently issued names
    my($self) = shift;
    $self->{num_of_issued_names} = 0;
    $self->{first_issued_ind} = $self->{last_issued_ind} + 1;
}

sub parts_list($) {         # returns a ref to a list of recently issued names
    my($self) = shift;
    [ map { sprintf("part-%05d",$_) }
	($self->{first_issued_ind} .. $self->{last_issued_ind}) ];
}

sub generate_new_name($) {  # make-up a new name and return it
    my($self) = shift;
    if (defined($self->{maxfiles}) &&
	$self->{num_of_issued_names} >= $self->{maxfiles}) {
	die "Maximum number of files ($self->{maxfiles}) exceeded";
    }
    $self->{num_of_issued_names}++; $self->{last_issued_ind}++;
    my($name) = sprintf("part-%05d", $self->{last_issued_ind});
    do_log(5, "Issued a new file name: ".$name);
    $name;
}

# remember full file type as obtained by calling 'file' utility
sub file_type_long($$;$) {
    my($self,$part) = (shift,shift);
    $self->{ltype}->{$part} = shift  if @_;
    $self->{ltype}->{$part};
}

# remember short/categorized file type
sub file_type($$;$) {
    my($self,$part) = (shift,shift);
    $self->{stype}->{$part} = shift  if @_;
    $self->{stype}->{$part};
}

1;

#
package Amavis::Unpackers::OurFiler;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter MIME::Parser::Filer); # subclass of MIME::Parser::Filer
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = ();
}
# This package will be used by mime_decode().
#
# We don't want no heavy MIME::Parser machinery for file name extension
# guessing, decoding charsets in filenames (and listening to complaints
# about it), checking for evil filenames, checking for filename contention, ...
# (which can not be turned off completely by ignore_filename(1) !!!)
# Just enforce our file name! And while at it, collect generated filenames.
#
sub new($$$) {
    my($class, $dir, $file_generator_object) = @_;
    $dir =~ s/\/+$//;  # chop off trailing slashes from directory name
    bless {
	directory => $dir,  file_generator_object => $file_generator_object,
    }, $class;
}

sub output_path($@) {
    my($self,$head) = @_;
    # invent new bare file name
    my($name) = $self->{file_generator_object}->generate_new_name;
    $self->{directory} . "/$name";  # return it with prepended directory
}

1;

#
package Amavis::Unpackers;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&init &mime_decode &decompose_part
		    &determine_file_types &check_for_banned_filenames);
}
use MIME::Parser;
use MIME::Words;
use Convert::TNEF;
use Convert::UUlib qw(:constants);
use Compress::Zlib;
use Archive::Tar;
use Archive::Zip qw(:CONSTANTS :ERROR_CODES);
use File::Copy;

BEGIN {
    import Amavis::Util qw(do_log retcode sanitize_str min max
			   rmdir_flat rmdir_recursively);
    import Amavis::Timing qw(section_time);
    import Amavis::Conf qw(:confvars :unpack);
    import Amavis::Lookup qw(lookup);
}

use subs @EXPORT_OK;

use vars qw($threshold);  # Magic number to detect DoS attacks
use vars qw($avail_quota);  # available bytes quota for unpacked mail
use vars qw($rem_quota);    # remaining bytes quota for unpacked mail
use vars qw($file_generator_object);
sub init($$) {
    my($mail_size);  ($file_generator_object,$mail_size) = @_;
    $threshold = 14;
    $avail_quota = $rem_quota =   # quota in bytes
	max($MIN_EXPANSION_QUOTA,
	    $mail_size*$MIN_EXPANSION_FACTOR,
	    min($MAX_EXPANSION_QUOTA, $mail_size*$MAX_EXPANSION_FACTOR));
    do_log(4, "Original mail size: $mail_size; quota set to: $avail_quota bytes");
}

# generate unique filename (bare names, no directory)
sub getfilename() { $file_generator_object->generate_new_name }

sub consumed_bytes($$) {
    my($bytes,$bywhom) = @_;
    my($perc) = !$avail_quota ? '' : sprintf(", (%.0f%%)",
			100*($avail_quota-($rem_quota-$bytes))/$avail_quota);
    do_log(5, "Charging $bytes bytes to remaining quota $rem_quota".
	      " (out of $avail_quota$perc) - by $bywhom");
    if ($bytes > $rem_quota && $rem_quota >= 0) {
	# Do not modify the signal text, it gets matched elsewhere!
	my($msg) = "Exceeded storage quota $avail_quota bytes by $bywhom; last chunk $bytes bytes";
	do_log(0,$msg);  die "$msg\n";
    }
    $rem_quota -= $bytes;
};

# save MIME preamble and epilogue (if nontrivial) as extra (pseudo)parts
sub mime_decode_pre_epi($$$) {
    my($pe_name,$pe_lines,$tempdir) = @_;
    if (defined $pe_lines && @$pe_lines) {
	do_log(5, "mime_decode_$pe_name: ".scalar(@$pe_lines)." lines");
	if (@$pe_lines>5 || "@$pe_lines" !~ m(^[a-zA-Z0-9/\@:;,. \t\n_-]*$)s) {
	    my($newpart) = "$tempdir/parts/" . getfilename();
	    open(PRE, ">$newpart") or die "Can't create $pe_name $newpart: $!";
	    for (@$pe_lines) {
		print PRE $_  or die "Can't write $pe_name to $newpart: $!";
		consumed_bytes(length($_),'mime_decode_pre_epi');
	    }
	    close(PRE) or die "Can't close $pe_name $newpart: $!";
	}
    }
}

# Break up mime parts
sub mime_decode($$) {
    my($fileh,$tempdir) = @_;
    # $fileh may be an open file handle, or a file name of a part

    my($parser) = MIME::Parser->new;
    $parser->filer(Amavis::Unpackers::OurFiler->new(
				"$tempdir/parts", $file_generator_object));
    $parser->ignore_errors(1);  # also is the default
    $parser->extract_nested_messages("NEST"); # parse embedded message/rfc822
    $parser->extract_uuencode(1);
    my($entity);
    if (ref($fileh)) {  # assume open file handle
	do_log(4,"Extracting mime components");
	$fileh->seek(0,0) or die "Can't rewind mail file: $!";
	$entity = $parser->parse($fileh);
    } else {            # assume parts file name
	do_log(4,"Extracting mime components from $fileh");
	$entity = $parser->parse_open("$tempdir/parts/$fileh");
    }
    my($err) = $parser->last_error;
    $err =~ s/\s+$//;  $err =~ s/[ \t\r]*\n+/; /g;
    $err = sanitize_str($err); $err =~ s/\s+/ /g;
    $err = substr($err,0,250) . '...'  if length($err) > 250;
    do_log(1, "warning - MIME::Parser $err")  if $err ne '';

    # traverse MIME::Entity object breadth-first,
    # extracting preambles and epilogues as extra (pseudo)parts
    my(@unvisited) = ($entity);
    while (@unvisited) {
	my($ent) = shift(@unvisited);
	mime_decode_pre_epi('preamble', $ent->preamble, $tempdir);
	my($body) = $ent->bodyhandle;  my($fn);
	do_log(4, "mime_decode: Content-type: " . $ent->mime_type .
		  (!$body ? "" : ( ", name: ".$ent->head->recommended_filename) ));
	if (defined $body) {
	    consumed_bytes(
		defined($fn=$body->path) ? -s $fn : length($body->as_string),
		'mime_decode');
	}
	mime_decode_pre_epi('epilogue', $ent->epilogue, $tempdir);
	push(@unvisited, $ent->parts);
    }
    section_time('mime_decode');
    $entity;
}

sub check_for_banned_filenames($$$$) {
    my($acl_re, $entity, $parts, $file_generator_object) = @_;
    my(@banned);
    if (defined $parts && @$parts && $file_generator_object) {
	do_log(3, "Checking for banned (contents-based) file types, " .
		   scalar(@$parts) . " parts");
	for my $part (@$parts) {
	    my($ft) = $file_generator_object->file_type($part);
	    if ($ft ne '') {   # file type as determined by 'file' util
		do_log(5, "check_for_banned ($part) - file type: $ft");
		my($result,$patt) = $acl_re->lookup_re($ft);
		if ($result) {
		    push(@banned, $ft);
		    do_log(2, "Banned file contents type: $ft (patt: $patt)");
		}
	    }
	}
    }
    my(@unvisited) = defined $entity ? ($entity) : ();
    do_log(3, "Checking for banned MIME types and names")  if @unvisited;
    while (@unvisited) {   # traverse MIME::Entity object breadth-first
	my($ent) = shift(@unvisited);
	my(@rn);  # recommended file names, both raw and RFC 2047 decoded
	if ($ent->bodyhandle) {
	    my($head) = $ent->head;  my($val,$val_decoded);
	    $val = $head->mime_attr('content-disposition.filename');
	    if ($val ne '') {
		push(@rn,$val);
		$val_decoded = MIME::Words::decode_mimewords($val);
		push(@rn,$val_decoded)  if $val_decoded ne $val;
	    }
	    $val = $head->mime_attr('content-type.name');
	    if ($val ne '') {
		push(@rn,$val)  if !grep {$_ eq $val} @rn;
		$val_decoded = MIME::Words::decode_mimewords($val);
		push(@rn,$val_decoded)  if !grep {$_ eq $val_decoded} @rn;
	    }
	}
	my($mt,$et) = ($ent->mime_type, $ent->effective_type);
	do_log(5, "check_for_banned - mime-type: $mt");
	do_log(5, "check_for_banned - eff. mime-type: $et")  if $et ne $mt;
	do_log(5, "check_for_banned - declared names: ".join(", ",@rn)) if @rn;
	my($result,$patt) = $acl_re->lookup_re($mt);   # mime type
	if ($result) {
	    push(@banned, $mt);
	    do_log(2, "Banned Content-Type: $mt (patt: $patt)");
	}
	if ($et ne $mt) {
	    ($result,$patt) = $acl_re->lookup_re($et); # effective mime type
	    if ($result) {
		push(@banned, $et);
		do_log(2, "Banned efective Content-Type: $et (patt: $patt)");
	    }
	}
	for my $rn (@rn) {
	    ($result,$patt) = $acl_re->lookup_re($rn); # recommended file name
	    if ($result) {
		push(@banned, $rn);
		do_log(2, "Banned declared file name: $rn (patt: $patt)");
	    }
	}
	push(@unvisited, $ent->parts);
    }
    for (@banned) { $_ = sanitize_str($_); $_ = '"'.$_.'"' if / / }
    \@banned;  # return a listref of violations, possibly empty
}

# call 'file' utility for each part,
# and associate (save) full and short types with each part
#
sub determine_file_types($$$) {
    my($partslist,$tempdir,$file_generator_object) = @_;

    for my $part (@$partslist) {
	my($filename) = "$tempdir/parts/$part";
	my($filetype) = qx($file -b $filename 2>/dev/null);
	my($ret) = retcode($?);
	$ret==0 or die "'file' utility ($file) failed, status=$ret";
	chomp($filetype);
	section_time('get-file-type');

	local($_) = $filetype;  my($ty);

	# try to classify some common types and give them short type name

	/^(ASCII|text|uuencoded|xxencoded|binhex)/i and $ty = '.asc';

### 'file' is a bit too trigger happy to claim something is 'mail text'
#	/mail text/i                  and $ty = '.mail';

	/^ISO-8859.*\btext/i          and $ty = '.txt';
	/^Non-ISO.*ASCII\b.*\btext/i  and $ty = '.txt';
	/^UTF-8 Unicode\b.*\btext/i   and $ty = '.txt';
	/HTML document text/i         and $ty = '.html';
	/^PGP armored data/i          and $ty = '.pgp.asc';
	/^PGP armored data signed message/i and $ty = '.pgp.asc';

	/^JPEG image data/i           and $ty = '.jpg';
	/^GIF image data/i            and $ty = '.gif';
	/^PNG image data/i            and $ty = '.png';
	/^TIFF image data/i           and $ty = '.tif';
	/^MP3\b/i                     and $ty = '.mp3';
	/^MPEG\b.*\bstream data/i     and $ty = '.mpeg';

	/^PostScript document text/i  and $ty = '.ps';
	/^PDF document/i              and $ty = '.pdf';
	/^Rich Text Format data/i     and $ty = '.rtf';
	/^Microsoft Office Document/i and $ty = '.doc';
	/^LaTeX\b.*\bdocument text/i  and $ty = '.lat';
	/^TeX DVI file/i              and $ty = '.dvi';
	/^XML document text/i         and $ty = '.xml';
	/^exported SGML document text/i and $ty = '.sgml';
	/^compiled Java class data/i  and $ty = '.java';
	/^data$/i                     and $ty = '.dat';
	/^empty$/i                    and $ty = '.empty';

	/^gzip compressed/i           and $ty = '.gz';
	/^compress'd/i                and $ty = '.Z';
	/^bzip2 compressed/i          and $ty = '.bz2';
	/^(?:GNU |POSIX )?tar archive/i and $ty = '.tar';
	/^Zip archive/i               and $ty = '.zip';
	/^RAR archive/i               and $ty = '.rar';
	/^LHA.*archive/i              and $ty = '.lha';
	/^ARC archive/i               and $ty = '.arc';
	/^ARJ archive/i               and $ty = '.arj';
	/^Zoo archive/i               and $ty = '.zoo';
	/^(Transport Neutral Encapsulation Format|TNEF)/i and $ty = '.tnef';
	/executable/i                 and $ty = '.exe';

	do_log(4, "File-type of $part: $filetype" .
		  (defined $ty ? "; ($ty)" : "") );
	$file_generator_object->file_type_long($part, $filetype);
	$file_generator_object->file_type($part, $ty);
    };
}

# Decompose the part
sub decompose_part($$$) {
    my($part,$tempdir,$file_generator_object) = @_;

    my($filename) = "$tempdir/parts/$part";
    my($filetype) = $file_generator_object->file_type_long($part);
    my($ty)       = $file_generator_object->file_type($part);
    my($hold);
#   do_log(4, "decompose_part: $part $filetype ($ty)");

    # possible return values from eval:
    # 0 - truly atomic, unknown or archiver failure; consider atomic
    # 1 - some archiver format, successfully unpacked, result replaces original
    # 2 - probably unpacked, but keep the original (eg self-extracting archive)
    my($sts) = eval {
	return 0  if !defined($ty);  # consider atomic if unknown
	local($_) = $ty;

	/^\.mail$/ && return do {mime_decode($part,$tempdir); 2};
	/^\.asc$/  && return do_ascii($part,$tempdir);
	/^\.Z$/    && defined $uncompress
	    && return do_uncompress($part,$tempdir,"$uncompress -c");
	/^\.bz2$/  && defined $bzip2
	    && return do_uncompress($part,$tempdir,"$bzip2 -d -c");
	/^\.gz$/   && defined $gzip
	    && return do_uncompress($part,$tempdir,"$gzip -d -c");
        /^\.gz$/   && return do_gunzip($part,$tempdir);  # fallback
	/^\.tar$/  && return do_tar($part,$tempdir);
	/^\.zip$/  && return do_unzip($part,0,$tempdir);
	/^\.rar$/  && return do_unrar($part,0,$tempdir);
	/^\.lha$/  && return do_lha($part,0,$tempdir);
	/^\.arc$/  && return do_arc($part,$tempdir);
	/^\.arj$/  && return do_unarj($part,$tempdir);
	/^\.zoo$/  && return do_zoo($part,$tempdir);
	/^\.tnef$/ && return do_tnef($part,$tempdir);
	/^\.exe$/  && return do_executable($part,$tempdir);

	# Falling through (e.g. HTML) - no match, consider atomic
	return 0;
    };
    if ($@ ne '') {
	chomp($@);
	if ($@ =~ /^Exceeded storage quota/) { $hold = $@ }
	else {
	    do_log(0,"Decoding of $part ($filetype) failed, ".
		 "leaving it unpacked: $@");
	}
	$sts = 2;
    }
    if ($sts == 1 && lookup($filetype, $keep_decoded_original_re)) {
	# don't trust this file type or unpacker,
	# keep both the original and the unpacked file
	do_log(5, "file type is $filetype, retain original $part");
	$sts = 2;
    }
    if ($sts == 1) {
	unlink($filename) or die "Can't unlink $filename: $!";
    }
    do_log(4, "decompose_part: $part - " .
	      ['atomic', 'archive, unpacked', 'source retained']->[$sts]);
    section_time('decompose_part');
    $hold;
}

#
# Uncompression/unarchiving routines
# Possible return codes:
# 0 - cannot extract/unpack further (treat as atomic)
# 1 - decoded/extracted from $part  (continue recursive extraction)
# 2 - $part is self-extracting executable (atomic AND continue extraction)

# if ASCII text, try multiple decoding methods as provided by UUlib
# (includes uuencoding, xxencoding, Base64 and BinHex)
sub do_ascii($$) {
    my($part,$tempdir) = @_;
    my($sts,$count);
    $sts = Convert::UUlib::Initialize();
    $sts==RET_OK or die "Convert::UUlib::Initialize failed: " .
			Convert::UUlib::strerror($sts);
    ($sts,$count) = Convert::UUlib::LoadFile("$tempdir/parts/$part");
    if ($sts != RET_OK) {
	my($errmsg) = Convert::UUlib::strerror($sts) . ": $!";
	$errmsg .= ", (???" . Convert::UUlib::strerror(
	           Convert::UUlib::GetOption(OPT_ERRNO)) .
		   "???)"  if $sts==RET_IOERR;
	die "Convert::UUlib::LoadFile failed: $errmsg";
    }
    do_log(4,"do_ascii: Decoding part $part ($count items)");
    my($uu); my($any_errors,$any_decoded);
    Convert::UUlib::SetOption(OPT_IGNMODE, 1);
    for (my $j=0; $uu=Convert::UUlib::GetFileListItem($j); $j++) {
	do_log(0, sprintf(
	    "do_ascii(%d): state=0x%02x, enc=%s%s, est.size=%s, name=%s",
	     $j, $uu->state, Convert::UUlib::strencoding($uu->uudet),
	     ($uu->mimetype ne '' ? ", mimetype=".$uu->mimetype : ''),
	     $uu->size, $uu->filename));
	if (! ($uu->state & FILE_OK) ) {
	    $any_errors++;
	    do_log(0, "do_ascii: Convert::UUlib info: $j not decodeable, " .
		      $uu->state);
	} else {
	    my($newpart) = "$tempdir/parts/" . getfilename();
	    $sts = $uu->decode($newpart);
	    consumed_bytes(-s($newpart), 'do_ascii');
	    if ($sts==RET_OK) {
		$any_decoded++;
	    } elsif ($sts==RET_NODATA || $sts==RET_NOEND) {
		$any_errors++;
		do_log(0, "do_ascii: Convert::UUlib error: " .
			  Convert::UUlib::strerror($sts));
	    } else {
		$any_errors++;
		my($errmsg) = Convert::UUlib::strerror($sts) . ": $!";
		$errmsg .= ", " . Convert::UUlib::strerror(
		     Convert::UUlib::GetOption(OPT_ERRNO))  if $sts==RET_IOERR;
		die "Convert::UUlib failed: $errmsg";
	    }
	}
    }
    Convert::UUlib::CleanUp();
    ($any_decoded && !$any_errors) ? 1 : $any_errors ? 2 : 0;
}

# use Archive-Zip
sub do_unzip($$$) {
    my($part,$exec,$tempdir) = @_;

    do_log(4,"Unzipping $part");
    my($zip) = Archive::Zip->new;
    my(@err_nm) = qw(AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR);

    # Need to set up a temporary minimal error handler
    # because we now test inside do_zip whether the $part
    # in question is a zip archive
    Archive::Zip::setErrorHandler(sub{return 5});
    my($sts) = $zip->read("$tempdir/parts/$part");
    Archive::Zip::setErrorHandler(sub{die @_});
    if ($sts != AZ_OK) {
	do_log(4,"do_unzip: not a zip: $err_nm[$sts] ($sts)");
	return 0;
    }
    local *OUTPART;
    my($any_unsupp_compmeth, $any_encrypted);
    for my $mem ($zip->members()) {
	my($compmeth) = $mem->compressionMethod;
	if ($compmeth!=COMPRESSION_DEFLATED && $compmeth!=COMPRESSION_STORED) {
	    $any_unsupp_compmeth = $compmeth;
	} elsif ($mem->isEncrypted) {
	    $any_encrypted++;
	} elsif (!$mem->isDirectory) {
	    my($oldc) = $mem->desiredCompressionMethod(COMPRESSION_STORED);
	    $sts = $mem->rewindData();
	    $sts == AZ_OK
		or die "$part: error rew. member data: $err_nm[$sts] ($sts)";
	    my($newpart) = "$tempdir/parts/" . getfilename();
	    open(OUTPART,">$newpart") or die "Can't create file $newpart: $!";
	    while ($sts == AZ_OK) {
		my($buf_ref); ($buf_ref,$sts) = $mem->readChunk();
		$sts == AZ_OK || $sts == AZ_STREAM_END
		    or die "$part: error reading member: $err_nm[$sts] ($sts)";
		print OUTPART ($$buf_ref) or die "Can't write to $newpart: $!";
		consumed_bytes(length($$buf_ref), 'do_unzip');
	    }
	    close(OUTPART) or die "Can't close $newpart: $!";
	    $mem->desiredCompressionMethod($oldc);
	    $mem->endRead();
	}
    }
    if ($any_unsupp_compmeth)
	{ do_log(0, "$part: unsupported compr. method: $any_unsupp_compmeth") }
    if ($any_encrypted)
	{ do_log(4, "$part: skipped $any_encrypted encrypted member(s)") }
    $exec ? 2 : 1;
}

# use external decompressor program from the gzip/bzip2/compress family
# (there *is* a perl module for bzip2, but it is not ready for prime time)
sub do_uncompress($$$) {
    my($part,$tempdir,$decompressor) = @_;
    return 0  if !$decompressor;
    do_log(4,"do_uncompress $part by $decompressor");
    my($newpart) = "$tempdir/parts/" . getfilename();
    local *OUTPART;
    open(OUTPART, ">$newpart") or die "Can't create file $newpart: $!";
    my($rv) = run_command(\*OUTPART, "$tempdir/parts/$part", 0,
			  split(' ',$decompressor) );
    my($retcode) = retcode($rv);
    do_log(5, sprintf('do_uncompress($decompressor) status %d (signal %d)',
		      $rv>>8, $rv&255));
    close(OUTPART) or die "Can't close $newpart: $!";
    if ($retcode) {
	unlink($newpart) or die "Can't unlink $newpart: $!";
	die "Error running $decompressor on $part, status: $retcode";
    }
    1;
}

# use Zlib to inflate
sub do_gunzip($$) {
    my($part,$tempdir) = @_;

    do_log(4,"Inflating gzip archive $part");

    local *OUTPART;
    my($gz) = gzopen("$tempdir/parts/$part", "rb")
	or die "Error opening $tempdir/parts/$part: $!";
    my($newpart) = "$tempdir/parts/" . getfilename();
    open(OUTPART, ">$newpart") or die "Can't create $newpart: $!";
    my($buffer);
    while ($gz->gzread($buffer) > 0) {
	print OUTPART $buffer or die "Can't write to $newpart: $!";
	consumed_bytes(length($buffer),'do_gunzip');
    }
    close(OUTPART) or die "Can't close $newpart: $!";
    if ($gzerrno != Z_STREAM_END) {
	unlink($newpart) or die "Can't unlink $newpart: $!";
	return 0;
    }
    1;
}

# untar any tar archives with Archive-Tar
# extract each file individually
sub do_tar($$) {
    my($part,$tempdir) = @_;

    # Work around bug in Archive-Tar
    my $tar = eval { Archive::Tar->new("$tempdir/parts/$part") };
    unless (defined($tar)) {
	chomp($@);
	do_log(4, "Faulty archive $part, ".sanitize_str($@) );
	return 0;
    }
    local *OUTPART;
    do_log(4,"Untarring $part");
    my @list = $tar->list_files();
    for (@list) {
	next  if /\/$/;   # Ignore directories
	# this is bad (reads whole file into scalar)
	# need some error handling, too
	my $data = $tar->get_content($_);
	my $newpart = "$tempdir/parts/" . getfilename();
	open(OUTPART, ">$newpart") or die "Can't create $newpart: $!";
	print OUTPART $data or die "Can't write to $newpart: $!";
	consumed_bytes(length($data),'do_tar');
	close(OUTPART) or die "Can't close $newpart: $!";
    }
    1;
}

# use external program to expand RAR archives
sub do_unrar($$$) {
    my($part,$exec,$tempdir) = @_;

    return 0  if !$unrar;

    # Check whether we can really unrar it
    my $rv1 = system($unrar, 't', '-p-', '-inul', "$tempdir/parts/$part");
    my $bad = !grep {$_==retcode($rv1)} (0,1,3); # SUCCESS, WARNING, CRC_ERROR
    do_log(4, sprintf("unrar 't' returned status %d (signal %d), command: %s",
		      $rv1>>8, $rv1&255, $unrar))  if $bad;
    return 0  if $bad;

    do_log(4,"Expanding RAR archive $part");

    # We have to jump through hoops because there is no simple way to
    # just list all the files

    my(@list); my($hypcount) = 0; my($encryptedcount) = 0;
    my($proc_fh) = run_command(undef, undef, 0,
			       $unrar, 'v', "$tempdir/parts/$part");
    while( defined($_ = $proc_fh->getline) ) {
	chomp;
	if (/^unexpected end of archive/) {
	    last;
	} elsif (/^------/) {
	    $hypcount++;
	    last if $hypcount == 2;
	} elsif ($hypcount == 1) {
	    if (/^\s{3}/) {
		# skip information lines
	    } elsif (/^\*/) {
		# discard password-protected files - makes no sense extracting
		$encryptedcount++;
	    } elsif (/\/$/) {
		# discard directories (???not that there are any)
	    } else {
		s/^.//;  # discard first character (space or an asterisk)
		push(@list, $_);
	    }
	}
    }
    # consume all remaining output to avoid broken pipe
    while( defined($proc_fh->getline) ) {}
    $proc_fh->close or die "Can't get a list of archive members from unrar: $?";

    if (!@list && $encryptedcount > 0) {
	do_log(0, sprintf("unrar: all %d members are encrypted, AV checks skipped",
			  $encryptedcount));
    }
    if (@list) {
	my $rv = store_mgr($tempdir, \@list, $unrar, 'p', '-p-', '-inul',
			   "$tempdir/parts/$part");
	do_log(0, sprintf("unrar returned status %d (signal %d)",
			  $rv>>8, $rv&255)) if $rv;
    }
    $exec ? 2 : 1;
}

# use external program to expand LHA archives
sub do_lha($$$) {
    my($part,$exec,$tempdir) = @_;

    return 0  if !$lha;

    # Check whether we can really lha it
    my($checkerr);
    my($proc_fh) = run_command(undef, undef, 1,
			       $lha, 'lq', "$tempdir/parts/$part");
    while( defined($_ = $proc_fh->getline) ) {
	$checkerr = 1  if /Checksum error/i;
    }
    $proc_fh->close;
    return 0  if $? || $checkerr;

    do_log(4,"Expanding LHA archive $part");

    my(@list);
    $proc_fh = run_command(undef, undef, 0,
			   $lha, 'lq', "$tempdir/parts/$part");
    while( defined($_ = $proc_fh->getline) ) {
	chomp;
	next  if /\/$/;
	push(@list, (split(/\s+/))[-1] );
    }
    $proc_fh->close or die "Error2 running LHA: $?";
    if (@list) {
	my $rv = store_mgr($tempdir, \@list, $lha, 'pq', "$tempdir/parts/$part");
	do_log(0, sprintf("lha returned status %d (signal %d)",
			  $rv>>8, $rv&255)) if $rv;
    }
    $exec ? 2 : 1;
}

# use external program to expand ARC archives;
# works with original arc, or a GPL licensed 'nomarch'
# (http://rus.members.beeb.net/nomarch.html)
sub do_arc($$) {
    my($part,$tempdir) = @_;

    return 0  if !$arc;
    my($is_nomarch) = $arc =~ /nomarch/i;
    do_log(4,"Unarcing $part, using " . ($is_nomarch ? "nomarch" : "arc") );

    my $cmdargs = ($is_nomarch ? "-l -U" : "ln") . " $tempdir/parts/$part";
    my @list = qx($arc $cmdargs 2>/dev/null);
    map { s/^([^ \t\n]*).*$/$1/s } @list;   # keep only filenames
    if (@list) {
	my $rv = store_mgr($tempdir, \@list, $arc, ($is_nomarch ? ('-p', '-U') : 'p'),
			   "$tempdir/parts/$part");
	do_log(0, sprintf("arc returned status %d (signal %d)",
			  $rv>>8, $rv&255)) if $rv;
    }
    1;
}

# use external program to expand ZOO archives
sub do_zoo($$) {
    my($part,$tempdir) = @_;

    return 0  if !$zoo;
    do_log(4,"Expanding ZOO archive $part");

    # Zoo needs extension of .zoo!
    symlink("$tempdir/parts/$part", "$tempdir/parts/$part.zoo");

    my(@list) = qx($zoo lf1q $tempdir/parts/$part);
    if (@list) {
	chop(@list);
	my $rv = store_mgr($tempdir, \@list, $zoo, 'xpqqq:',
			   "$tempdir/parts/$part");
	do_log(0, sprintf("zoo returned status %d (signal %d)",
			  $rv>>8, $rv&255)) if $rv;
	unlink("$tempdir/parts/$part.zoo")
	    or die "Can't unlink $tempdir/parts/$part.zoo: $!";
    }
    1;
}

# use external program to expand ARJ archives
sub do_unarj($$) {
    my($part,$tempdir) = @_;

    return 0  if !$unarj;
    do_log(4,"Expanding ARJ archive $part");

    # unarj needs extension of .arj!
    symlink("$tempdir/parts/$part", "$tempdir/parts/$part.arj")
	or die "Can't symlink $tempdir/parts/$part $tempdir/parts/$part.arj: $!";

    # unarj has very limited extraction options!  This may not be secure!
    mkdir("$tempdir/arj", 0750) or die "Can't mkdir $tempdir/arj: $!";
    chdir("$tempdir/arj") or die "Can't chdir to $tempdir/arj: $!";

    my($rv) = system("$unarj e $tempdir/parts/$part >/dev/null");

    # nonzero exit status does not mean no files were extracted!
    # (example: status 1 may indicate one of the members has a bad CRC)

    my $f;
    opendir(ARJDIR, "$tempdir/arj")
	or die "Can't open directory $tempdir/arj: $!";
    while (defined($f = readdir(ARJDIR))) {
	next if ($f =~ /^\.\.?$/) && -d("$tempdir/arj/$f");
	my $newpart = "$tempdir/parts/" . getfilename();
	$f = $1  if $f =~ /^(.*)$/;   # fool the taint checker
	move("$tempdir/arj/$f", $newpart)
	    or die "Can't move $tempdir/arj/$f to $newpart: $!";
	consumed_bytes(-s($newpart), 'do_unarj');
    }
    closedir(ARJDIR) or die "Can't close directory: $!";
    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
    rmdir_flat("$tempdir/arj")  if -d "$tempdir/arj";

    unlink("$tempdir/parts/$part.arj")
	or die "Can't unlink $tempdir/parts/$part.arj: $!";

    do_log(0, sprintf("unarj returned status %d (signal %d)",
		      $rv>>8, $rv&255)) if $rv;
    die "Command $unarj failed: $!"  if $rv == 0xff00;
    die "$unarj failed, status 127"  if $rv == 0x7f00;
    1;
}

# use Convert-TNEF
sub do_tnef($$) {
    my($part,$tempdir) = @_;

    do_log(4,"Extracting TNEF attachment $part");

    chdir("$tempdir/parts") or die "Can't chdir to $tempdir/parts: $!";
    my $tnef = Convert::TNEF->read_in("$tempdir/parts/$part",{ignore_checksum=>"true"});
    if (!$tnef) {
    	chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
	return 0;  # Not TNEF - treat as atomic
    }
    local *OUTPART;
    for ($tnef->attachments) {
	if (my $handle = $_->datahandle) {
	    my $newpart = "$tempdir/parts/" . getfilename();

	    open(OUTPART, ">$newpart") or die "Can't create $newpart: $!";
	    if (defined(my $file = $handle->path)) {
		copy($file, \*OUTPART);
	    } else {
		my($s) = $handle->as_string;
		print OUTPART $s or die "Can't write to $newpart: $!";
		consumed_bytes(length($s),'do_tnef');
	    }
	    close(OUTPART) or die "Can't close $newpart: $!";
	    consumed_bytes(-s($newpart), 'do_tnef');
	}
    }
    $tnef->purge;
    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
    1;
}

# Check for self-extracting archives.  Note that we don't rely on
# file magic here since it's not reliable.  Instead we will try each
# archiver.
sub do_executable($$) {
    my($part,$tempdir) = @_;

    do_log(4,"Check whether $part is a self-extracting archive");

    # ZIP?
    return 2 if eval{do_unzip($part,1,$tempdir)};
    chomp($@);
    do_log(0,"do_executable/do_unzip failed, ignoring: $@") if $@;

    # RAR?
    return 2 if eval{do_unrar($part,1,$tempdir)};
    chomp($@);
    do_log(0,"do_executable/do_unrar failed, ignoring: $@") if $@;

    # LHA?
    return 2 if eval{do_lha($part,1,$tempdir)};
    chomp($@);
    do_log(0,"do_executable/do_unlha failed, ignoring: $@") if $@;

    return 0;
}

#
# Utility routines

# Run specified command as a subprocess, and read from it.
# If $fileh is defined, copy (binary) subprocess output to a it,
# otherwise just return a file handle for reading from the subprocess.
# NOTE: use IO::Handle to assure the process will be
# automatically reclaimed in case of failure.
#
sub run_command($$$$@) {
    my($fileh, $inpfile, $join_stderr, $cmd, @args) = @_;
    my($cmd_text) = join(' ',$cmd,@args);
    $inpfile = '/dev/null'  if !defined $inpfile;
    my($proc_fh) = IO::File->new;
    my($pid) = $proc_fh->open('-|');  # fork
    defined($pid) or die "Can't fork: $!";
    if (!$pid) {  # child
	eval {  # no 'die' in child process, or we get two running daemons!
	    # close all unneeded files
	    !defined $fileh || close($fileh)  or "Can't close \$fileh: $!";
	    close(STDIN) or "Can't close STDIN: $!";
	    close(main::stdin) or "Can't close main::stdin: $!";
	    open(STDIN,$inpfile) or "Can't reopen STDIN on $inpfile: $!";
	    fileno(STDIN)==0 or die "run_command: STDIN not fd0";
	    if ($join_stderr) {
#TODO: this is causing a problem, open fails with 'Invalid argument'
#		open(STDERR, ">&STDOUT") or die "Can't dup stdout to stderr: $!";
	    }
	    exec($cmd,@args)
		or die "Can't exec program $cmd: $!"; # will end up in parent's $?
	};
	chomp($@); do_log(0,"run_command: child process failed to exec: $@");
	exec('/bin/false');  # must not exit, we have to avoid DESTROY handlers
	exit 1; # better safe than sorry
        # NOTREACHED
    }
    # parent
    if (!defined $fileh) {
	do_log(5, "run_command, returning FH to [$pid]: $cmd_text");
	return $proc_fh;   # return file handle to subprocess
    } else {
	do_log(5, "run_command, reading from [$pid]: $cmd_text");
	my($len, $buf, $offset, $written);
	while ($len = $proc_fh->sysread($buf,16384)) {
	    $offset = 0;
	    while ($len > 0) {  # handle partial writes
		$written = syswrite($fileh, $buf, $len, $offset);
		defined($written) or die "System write error: $!";
		consumed_bytes($written, "run_command($cmd)");
		$len -= $written; $offset += $written;
	    }
	}
	$proc_fh->close;
	return $?;  # return subprocess termination status
    }
}
# my($k,$v,$fn);
# while (($k,$v) = each(%::)) {
#   local(*e)=$v; $fn=fileno(\*e);
#   printf STDERR ("%-10s %-10s %s\n",$k,$v,$fn)  if defined $fn;
# }

# extract listed files from archive and store in new file
sub store_mgr($$$@) {
    my($tempdir, $list, $cmd, @args) = @_;

    local *FH;
    my(@rv);
    for (@$list) {
	next if /\/$/;		# Ignore directories
	my($newpart) = "$tempdir/parts/" . getfilename();

	open(FH, ">$newpart") or die "Can't create $newpart: $!";
	my $rv = run_command(\*FH, undef, 0, $cmd, @args, $_);
	do_log(5, sprintf('extracting %s to file %s using %s, status %d (signal %d)',
		  sanitize_str($_), $newpart, $cmd, $rv>>8, $rv&255));
	push(@rv,$rv);
	close(FH) or die "Can't close $newpart: $!";
    }
    @rv = grep {$_ != 0} @rv;
    @rv ? $rv[0] : 0;	# just return the first
			# nonzero status (if any), or 0
}

1;

#
package Amavis::Notify;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&delivery_status_notification &delivery_short_report
		    &string_to_mime_entity);
}

BEGIN {
    import Amavis::Util qw(do_log sanitize_str);
    import Amavis::Timing qw(section_time);
    import Amavis::Conf qw(:notifyconf $myhostname);
    import Amavis::Lookup qw(lookup);
    import Amavis::Expand qw(expand);
    import Amavis::rfc2821_2822_Tools;
}
use MIME::Entity;

use subs @EXPORT_OK;

# Convert mail (that was obtained by macro-expanding notification templates)
# into proper MIME::Entity object. Some ad-hoc solutions are used
# for compatibility with previous version.
#
sub string_to_mime_entity($) {
    my($mail_as_string_ref) = @_;
    my($entity); my($m_hdr,$m_body);
    ($m_hdr,$m_body) = ($1,$3) if $$mail_as_string_ref=~/^(.*?\n)(\n|$)(.*)$/s;
    # make sure _our_ source line number is reported in case of failure
    eval {$entity = MIME::Entity->build(
	Type => 'text/plain', Encoding => '-SUGGEST',
	Data => $m_body); 1}  or do {chomp($@); die $@};
    my($head) = $entity->head;
    # insert header fields from template into MIME::Head entity
    $m_hdr =~ s/\n([ \t])/$1/s;  # unfold template header
    for my $hdr_line (split(/\n/,$m_hdr)) {
	if ($hdr_line =~ /^([^:]*):\s*(.*)$/) {
	    my($fhead,$fbody) = ($1,$2);
	    # encode according to RFC 2047 if necessary
	    if ($fhead =~ /^(X-.*|Subject|Comments)$/i &&
		$fbody =~ /[\000-\010\013-\037\177-\377]/
	    ) { $fbody = MIME::Words::encode_mimeword($fbody, 'q') }
	    # make sure _our_ source line number is reported in case of failure
	    eval {$head->replace($fhead,$fbody); 1} or do {chomp($@); die $@};
	}
    }
    $entity;  # return the built MIME::Entity
}

# Generate delivery status notification according to rfc1892 and rfc1894.
# Return dsn message object if dsn is needed, or undef otherwise.
#
sub delivery_status_notification($$$$$) {
    my($conn, $msginfo, $report_success_dsn_also,
       $builtins_ref, $template_ref) = @_;
    my($dsn_time) = time;  # time of dsn creation - now
    my($notification);
    if ($msginfo->sender_contact eq '') {
	# must not respond to null return path
	do_log(4, "Not sending DSN to empty return path");
    } elsif ($msginfo->mime_entity->head->get("precedence")
	     =~ /bulk|list|junk/i ) {
	# don't send notifications in response to mail from mailing lists
	do_log(4, "Not sending DSN in response to bulk mail");
    } else {
	my($from_mta,$client_ip) = ($conn->smtp_helo, $conn->client_ip);
	my($msg);  # constructed dsn text according to rfc1894
	$msg .= "Reporting-MTA: dns; $myhostname\n";
	$msg .= "Received-From-MTA: smtp; $from_mta ([$client_ip])\n"
	    if $from_mta ne '';
	$msg .= "Arrival-Date: " . rfc2822_timestamp($msginfo->rx_time) . "\n";

	my($any);  # any recipients with failed delivery?
	for my $r (@{$msginfo->per_recip_data}) {
	    my($remote_mta) = $r->recip_remote_mta;
	    my($smtp_resp)  = $r->recip_smtp_response;
	    if (! $r->recip_done) {
		do_log(0, "TROUBLE: recipient not done: <" .
			  $r->recip_addr . "> " . $smtp_resp);
	    }
	    my($smtp_resp_code, $smtp_resp_enhcode, $smtp_resp_msg);
	    if ($smtp_resp =~ /^ (\d{3}) \s+ ([245] \. \d{1,3} \. \d{1,3})?
				 \s* (.*) $/xs) {
		($smtp_resp_code,$smtp_resp_enhcode,$smtp_resp_msg)=($1,$2,$3);
	    } else { $smtp_resp_msg = $smtp_resp }
	    my($smtp_resp_class) = $smtp_resp_code =~ /^(\d)/ ? $1 : '0';
	    if ($smtp_resp_enhcode eq '' && $smtp_resp_class =~ /^([245])$/ ) {
		$smtp_resp_enhcode = "$1.0.0";
	    }
	    # skip success notifications
	    next  unless $smtp_resp_class ne '2' || $report_success_dsn_also;
	    $any++;
	    $msg .= "\n";  # empty line between groups of per-recipient fields
	    if ($remote_mta ne '' && $r->recip_final_addr ne $r->recip_addr) {
		$msg .= "X-NextToLast-Final-Recipient: rfc822; " .
			quote_rfc2821_local($r->recip_addr) . "\n";
		$msg .= "Final-Recipient: rfc822; " .
			quote_rfc2821_local($r->recip_final_addr) . "\n";
	    } else {
		$msg .= "Final-Recipient: rfc822; " .
			quote_rfc2821_local($r->recip_addr) . "\n";
	    }
	    $msg .= "Action: " .
		    ($smtp_resp_class eq '2' ? 'delivered' : 'failed') . "\n";
	    $msg .= "Status: $smtp_resp_enhcode\n";
	    $msg .= "Diagnostic-Code: smtp; $smtp_resp\n";
	    $msg .= "Remote-MTA: dns; $remote_mta\n" if $remote_mta ne '';
	    $msg .= "Last-Attempt-Date: " . rfc2822_timestamp($dsn_time) ."\n";
	}
	return $notification  if !$any; # don't bother, we won't be sending DSN

	my($to_hdr)   = qquote_rfc2821_local($msginfo->sender_contact);
	my($from_hdr) = $mailfrom_notify_sender ne ''   # used in 'From:' hdr
			? qquote_rfc2821_local($mailfrom_notify_sender)
			: "amavisd-new <postmaster\@$myhostname>";
# rfc1894: The From field of the message header of the DSN SHOULD contain
# the address of a human who is responsible for maintaining the mail system
# at the Reporting MTA site (e.g.  Postmaster), so that a reply to the
# DSN will reach that person.

	# use the provided template text
	my(%mybuiltins) = %$builtins_ref;  # make a local copy
        $mybuiltins{'f'} = $from_hdr; $mybuiltins{'T'} = $to_hdr;
        $mybuiltins{'d'} = rfc2822_timestamp($dsn_time);
        my($dsn) = expand($template_ref,\%mybuiltins);

	my($dsn_entity) = string_to_mime_entity($dsn);
	$dsn_entity->make_multipart;
	my($head) = $dsn_entity->head;

	eval {$head->replace('From',$from_hdr); 1} or do {chomp($@); die $@};
	eval {$head->replace('To',  $to_hdr);   1} or do {chomp($@); die $@};
	eval {$head->replace('Date',rfc2822_timestamp($dsn_time)); 1}
	    or do {chomp($@); die $@};

	my($field) = Mail::Field->new('Content_type'); # underline, not hyphen!
	$field->type("multipart/report; report-type=delivery-status");
	$field->boundary(MIME::Entity::make_boundary());
	$head->replace('Content-type', $field->stringify);
	$head = undef;

	# make sure _our_ source line number is reported in case of failure
	eval {$dsn_entity->attach(
		Type => 'message/delivery-status', Encoding => '7bit',
		Description => 'Delivery error report',
		Data => $msg); 1}                   or do {chomp($@); die $@};
	eval {$dsn_entity->attach(
		Type => 'text/rfc822-headers', Encoding => '-SUGGEST',
		Description => 'Undelivered-message headers',
		Data => $msginfo->orig_header); 1}  or do {chomp($@); die $@};
	$notification = Amavis::In::Message->new;
	$notification->sender('');
	$notification->recips([$msginfo->sender_contact]);
	$notification->mail_text($dsn_entity);
    }
    $notification;
}

# Return a pair of arrayrefs of short per-recipient delivery reports
# that can be used in the free format first MIME part of delivery
# status notifications. The first array contains recipients
# with successful real delivery status, the second one all the rest.
#
sub delivery_short_report($) {
    my($msginfo) = @_;
    my(@succ_entries, @other_entries);
    for my $r (@{$msginfo->per_recip_data}) {
	my($remote_mta) = $r->recip_remote_mta;
	my($smtp_resp)  = $r->recip_smtp_response;
	my($qrecip_addr) = scalar(qquote_rfc2821_local($r->recip_addr));
	if ($r->recip_destiny > 0 && ($smtp_resp =~ /^2/ || !$r->recip_done)) {
	    push(@succ_entries, $qrecip_addr);
	} else {
	    push(@other_entries, sprintf("%s:%s\n   %s", $qrecip_addr,
		    ($remote_mta eq ''?'':" $remote_mta said:"), $smtp_resp));
	}
    }
    (\@succ_entries, \@other_entries);
}

1;

#
package Amavis;
require 5.005;   # need qr operator
use strict;

use POSIX qw(strftime);
use IO::File;
# body digest for caching, either SHA1 or MD5
#use Digest::SHA1;
use Digest::MD5;
use Net::Server 0.83;
use Net::Server::PreForkSimple;
use DBI;

BEGIN {
    import Amavis::Conf qw(:confvars :notifyconf :sa);
    import Amavis::Util qw(do_log debug_oneshot am_id retcode prolong_timer
			   sanitize_str min max);
    import Amavis::Timing qw(section_time);
    import Amavis::Log;
    import Amavis::Lookup qw(lookup lookup_ip_acl);
    import Amavis::rfc2821_2822_Tools;
    import Amavis::Out;
    import Amavis::Out::EditHeader;
    import Amavis::UnmangleSender qw(best_try_originator first_received_from);
    import Amavis::Unpackers qw(mime_decode decompose_part
			     determine_file_types check_for_banned_filenames);
    import Amavis::Expand qw(expand);
    import Amavis::Notify qw(delivery_status_notification
			     delivery_short_report string_to_mime_entity);
    import Amavis::In::Connection;
    import Amavis::In::Message;
}

# Make it a subclass of Net::Server::PreForkSimple
# to override method &process_request (and others if desired)
use vars qw(@ISA);
@ISA = qw(Net::Server::PreForkSimple);

delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

use vars qw($extra_code_in_amcl $extra_code_in_smtp
	    $extra_code_antivirus $extra_code_antispam);

use vars qw($spam_level $spam_status $spam_report);

use vars qw($virus_lovers_sql $banned_files_lovers_sql $spam_lovers_sql
	    $bypass_virus_checks_sql $bypass_spam_checks_sql
	    $spam_tag_level_sql $spam_kill_level_sql);

use vars qw(%scan_cache $body_digest);
use vars qw(%builtins);  # customizable notification messages

use vars qw($child_invocation_count $child_task_count);
  # $child_invocation_count  # counts child re-use from 1 to max_requests
  # $child_task_count   # counts check_mail() calls - this normally runs
			# in sync with $child_invocation_count, but with
			# SMTP-input there may be more than one message
			# passed during a single SMTP session

use vars qw($VIRUSFILE $CONN $MSGINFO);
use vars qw($av_output @virusname @banned_filename);

use vars qw($amcl_in_obj $smtp_in_obj); # Amavis::In::AMCL and In::SMTP objects

### Net::Server hook
### This hook occurs after chroot, change of user, and change of group has
### occured.  It allows for preparation before looping begins.
sub pre_loop_hook {
    # this needs to be done only after chroot, otherwise paths will be wrong
    find_external_programs( [split(/:/, $path, -1)] );
    # do some sanity checking
    stat($TEMPBASE);
    -e(_) or die "No TEMPBASE directory: $daemon_chroot_dir $TEMPBASE";
    -d(_) or die "TEMPBASE is not a directory: $daemon_chroot_dir $TEMPBASE";
    -w(_) or die "TEMPBASE is not writable: $daemon_chroot_dir $TEMPBASE";
    if ($QUARANTINEDIR ne '' && -d($QUARANTINEDIR) && !-w(_)) {
	die "QUARANTINEDIR directory not writable: $daemon_chroot_dir $QUARANTINEDIR";
    }
}

### log routine Net::Server hook
### (Sys::Syslog MUST NOT be specified as a value of 'log_file'!)
#
# Redirect Net::Server logging to use Amavis' do_log().
# The main reason is that Net::Server uses Sys::Syslog
# (and has two bugs in doing it, at least the Net-Server-0.82),
# and Amavis users are acustomed to Unix::Syslog.
sub write_to_log_hook {
    my($self,$level,$msg) = @_;
    my($prop) = $self->{server};
    chomp($msg); $msg =~ s/([^ -~])/sprintf("%%%02X",ord($1))/eg;
    do_log(1, "Net::Server: " . $msg);  # just call Amavis' traditional logging
    1;
}

### user customizable Net::Server hook
sub child_init_hook {
    my($self) = shift;
    $0 = 'amavisd (virgin child)';
}

### user customizable Net::Server hook
sub post_accept_hook {
    my($self) = shift;
    $child_invocation_count++;
    Amavis::Timing::init();  # establish initial time right after 'accept'
    $0 = 'amavisd (child)';
}

### user customizable Net::Server hook
### if this hook returns 1 the request is processed
### if this hook returns 0 the request is denied
sub allow_deny_hook {
    my($self) = shift;
    my($prop) = $self->{server};
    my($sock) = $prop->{client};

    ### unix sockets should be immune to this check
    return 1  if UNIVERSAL::can($sock,'NS_proto') && $sock->NS_proto eq 'UNIX';

    my($permit,$fullkey) = lookup_ip_acl($prop->{peeraddr}, \@inet_acl);
    if (!$permit) {
	if (!defined($fullkey)) {
	    do_log(0, "DENIED ACCESS from IP " . $prop->{peeraddr});
	} else {
	    do_log(0, sprintf("DENIED ACCESS from IP %s, blocked by rule %s",
			      $prop->{peeraddr}, $fullkey));
	}
	return 0;
    }
    1;
}

# "safely" connect to a database.  take a list of database connection
# parameters and try each until one succeeds.
#  -- based on code from Ben Ransford <amavis@uce.ransford.org> 2002-09-22
sub connect_to_sql(@) {
    my(@dsns) = @_;  # a list of DSNs to try connecting to sequentially
    my($dbh);
    for my $tmpdsn (@dsns) {
	my($dsn, $username, $password) = @$tmpdsn;
	do_log(5, "connect_to_sql: trying '$dsn'");
	$dbh = DBI->connect($dsn, $username, $password,
			    {PrintError => 0, RaiseError => 0, Taint => 1} );
	if ($dbh) { do_log(5,"connect_to_sql: '$dsn' succeeded"); last }
	do_log(0, "connect_to_sql: unable to connect to DSN '$dsn'");
    }
    do_log(0, "connect_to_sql: unable to connect to any DSN at all!"
	  )  if !$dbh && @dsns>1;
    $dbh;
}

# connect to the SQL server and prepare queries
# (called at the beginning of child's life from process_request)
sub prepare_sql_queries() {
    return  if !@lookup_sql_dsn;
    my($sql_dbh) = connect_to_sql(@lookup_sql_dsn);
    section_time('sql-connect');
    if (!defined($sql_dbh)) {
	do_log(0, "Error connecting to database, SQL lookups disabled: " .
		  $DBI::errstr);
    } else {
	$sql_dbh->{'RaiseError'} = 1;
	# prepare SELECT statements
	my($sql) = Amavis::Lookup::SQL->new($sql_dbh,
		'users.email', 'users, policy', 'policy.*',
		['users.policy_id=policy.id'], 'users.priority DESC');
	# prepare lookup objects with incorporated field names
	$virus_lovers_sql =
		Amavis::Lookup::SQLfield->new($sql, 'virus_lover', 'B');
	$banned_files_lovers_sql =
		Amavis::Lookup::SQLfield->new($sql, 'banned_file_lover', 'B');
	$spam_lovers_sql =
		Amavis::Lookup::SQLfield->new($sql, 'spam_lover', 'B');
	$bypass_virus_checks_sql =
		Amavis::Lookup::SQLfield->new($sql, 'bypass_virus_checks','B');
	$bypass_spam_checks_sql =
		Amavis::Lookup::SQLfield->new($sql, 'bypass_spam_checks', 'B');
	$spam_tag_level_sql =
		Amavis::Lookup::SQLfield->new($sql, 'spam_tag_level',  'N');
	$spam_kill_level_sql =
		Amavis::Lookup::SQLfield->new($sql, 'spam_kill_level', 'N');
	section_time('sql-prepare');
    }
    undef @lookup_sql_dsn;   # destroy sensitive information
}

### The heart of the program
### user customizable Net::Server hook
sub process_request {
    my($self) = shift;
    my($prop) = $self->{server};
    my($sock) = $prop->{client};

    # Net::Server assigns STDIN and STDOUT to the socket

    $| = 1;
    local $SIG{ALRM} = sub { die "timed out\n" }; # do not modify the sig text!
    eval {
	alarm($child_timeout);

	prepare_sql_queries()  if $child_invocation_count == 1;

	my($conn) = Amavis::In::Connection->new;
	$CONN = $conn;     # ugly - save in a global

	$conn->proto($sock->NS_proto);

	relayhost_client(undef);
	if ($sock->NS_proto eq 'UNIX') {      # traditional amavis client
	    $amcl_in_obj = Amavis::In::AMCL->new  if !$amcl_in_obj;
	    $amcl_in_obj->process_amavis_client_request(
		$sock, $conn, \&check_mail);
	    do_log(2, Amavis::Timing::report());  # report elapsed times
	} elsif ($sock->NS_proto eq 'TCP') {  # assume SMTP
	    $conn->socket_ip($prop->{sockaddr});
	    $conn->socket_port($prop->{sockport});
	    $conn->client_ip($prop->{peeraddr});
	    relayhost_client($prop->{peeraddr});
	    if (!$extra_code_in_smtp) {
		die ("incomming TCP connection, but dynamic code ".
		     "to handle SMTP or LMTP not loaded");
	    } else {
		my($lmtp) = $prop->{sockport} != 25 &&
			    $prop->{sockport} != $inet_socket_port;
		$smtp_in_obj = Amavis::In::SMTP->new  if !$smtp_in_obj;
		$smtp_in_obj->process_smtp_request(
		    $sock, $lmtp, $conn, \&check_mail);
	    }
	} else {
	    die ("unsupported protocol: " . $sock->NS_proto);
	}
    };
    alarm(0);  # stop the timer
    if ($@ ne '') {
	chomp($@);
	my($msg) = $@ eq "timed out"
			? "Child task exceeded $child_timeout seconds, abort"
			: "TROUBLE?: $@";
	do_log(0, $msg);
	$smtp_in_obj->preserve_evidence(1)  if $smtp_in_obj;
	# kills a child, hopefully preserving tempdir, but does not kill parent
	die ("(" . am_id() . ") " . $msg . "\n");
    }
    if ($child_task_count >= $max_requests &&
	$child_invocation_count < $max_requests) {
	# in case of multiple-transaction protocols (e.g. SMTP, LMTP)
	# we do not like to keep running indefinitely at the MTA's mercy
	do_log(0,"Requesting a process rundown after $child_task_count tasks");
	$self->done(1);
    }
}

### override Net::Server::PreForkSimple::done
### to be able to rundown the child process prematurely
sub done(@) {
    my($self) = shift;
    if (@_) {
	$self->{server}->{done} = shift;
    } elsif (!$self->{server}->{done}) {
	$self->{server}->{done} = $self->SUPER::done;
    }
    $self->{server}->{done};
}

### Net::Server hook
sub post_process_request_hook {
    debug_oneshot(0);
    $0 = 'amavisd (child)';
}

### Child is about to be terminated
### user customizable Net::Server hook
sub child_finish_hook {
    my($self) = shift;
#   do_log(0, "Amavis::In::SMTP::DESTROY will be called from 'child_finish_hook'");
    $smtp_in_obj = undef;  # calls Amavis::In::SMTP::DESTROY
    $amcl_in_obj = undef;  # (currently does nothing for Amavis::In::AMCL)
}

sub END {  # runs before exiting the module
#   do_log(0, "Amavis::In::SMTP::DESTROY will be called from 'END'");
    $smtp_in_obj = undef;  # calls Amavis::In::SMTP::DESTROY
    $amcl_in_obj = undef;  # (currently does nothing for Amavis::In::AMCL)
}

# Checks the message stored on a file. File must already
# be open on file handle $msginfo->mail_text; it need not be positioned
# properly, check_mail must not close the file handle.
#
sub check_mail($$$$) {
    my($conn, $msginfo, $dsn_per_recip_capable, $tempdir) = @_;
    my($fh) = $msginfo->mail_text;
    my(@recips) = @{$msginfo->recips};

    $MSGINFO = $msginfo;   # ugly - save in a global, to make it accessible
			   # to %builtins
    # check_mail() may be called several times per child lifetime and/or
    # per-SMTP session. The variable $child_task_count is mainly used
    # by AV-scanner interfaces, e.g. to initialize when invoked
    # for the first time during child process lifetime.
    $child_task_count++;

    # reset certain global variables for each task
    $VIRUSFILE = undef;
    $av_output = undef; @virusname = (); @banned_filename = ();
    $spam_level = undef; $spam_status = undef; $spam_report = undef;

    $body_digest = get_body_digest($fh,$msginfo);

    my($mail_size) = $msginfo->orig_header_size + 1 + $msginfo->orig_body_size;
#   my($mail_size2) = $msginfo->msg_size; # use ESMTP size estimate if available
#   my($mail_size3) = -s "$tempdir/email.txt";  # get it from a file system
#   do_log(0, "MAIL SIZES: $mail_size, $mail_size2, $mail_size3");

    my($file_generator_object) =    # 0 disables the $MAXFILES limit
	Amavis::Unpackers::NewFilename->new($MAXFILES ? $MAXFILES : undef);
    Amavis::Unpackers::init($file_generator_object, $mail_size);
    my($smtp_resp,$exit_code,$preserve_evidence);

    do_log(1, sprintf("Checking: <%s> -> %s",
		      $msginfo->sender, join(',',map{"<$_>"}@recips)) );
    my($am_id) = am_id();

    my($hold);       # set to some string to cause the message to be
                     # placed on hold (frozen) by MTA. This can be used
                     # in cases when we stumble across some permanent problem
                     # making us unable to decide if the message is to be
                     # really delivered.
    my($which_section);
    eval {
	$which_section = "creating_partsdir";
	if (-d "$tempdir/parts") {
	    # mkdir is a costly operation (must be atomic, flushes buffers).
	    # If we can re-use directory 'parts' from the previous invocation
	    # it saves us precious time. Together with matching rmdir this can
	    # amount to 10-15 % of total elapsed time !!!
	} else {
	    mkdir("$tempdir/parts", 0750)
		or die "Can't create directory $tempdir/parts: $!";
	    section_time('mkdir parts');
	}
	chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";

	# FIRST: what kind of e-mail did we get? call content scanners

	# already in cache?
	if (!grep {!lookup($_,\%bypass_checks,\@bypass_checks_acl)} @recips) {
	    $which_section = "bypass";  # skip all content checks
	    do_log(1, "BYPASS checks for recip " .
		      join(",",map {"<$_>"}@recips));
	} elsif (defined($body_digest) && exists($scan_cache{$body_digest})) {
	    # cached
	    $which_section = "cached";
	    do_log(1, "cached $body_digest from <".$msginfo->sender.">");
	    my($bs) = $scan_cache{$body_digest};
	    @banned_filename = !ref($bs->{'FB'}) ? () : @{$bs->{'FB'}}; # copy
	    @virusname       = !ref($bs->{'VN'}) ? () : @{$bs->{'VN'}}; # copy
	    $av_output   = $bs->{'VO'}; $spam_level  = $bs->{'SL'};
	    $spam_status = $bs->{'SS'}; $spam_report = $bs->{'SR'};

	} else {  # need to call content scanners

	    # check for banned mime file name or banned mime-type
	    if ($banned_filename_re) {
		if (!defined($msginfo->mime_entity)) {
		    $which_section = "mime_decode";
		    $msginfo->mime_entity(mime_decode($fh,$tempdir));
		    prolong_timer($which_section);
		}
		$which_section = "filename_check_mime";
		my($banned_filenames_ref) =
		    check_for_banned_filenames($banned_filename_re,
					  $msginfo->mime_entity, undef, undef);
		push(@banned_filename, @$banned_filenames_ref);
		$scan_cache{$body_digest}{'FB'} =     # cache it
		    [@banned_filename]  if defined $body_digest;
	    }

	    my($will_do_virus_scanning) =   # virus scanning will be needed?
		$extra_code_antivirus &&
		grep {!lookup($_, $bypass_virus_checks_sql,
				  \%bypass_virus_checks,
				  \@bypass_virus_checks_acl,
				  $bypass_virus_checks_re)} @recips;

	    # decoding parts as deep as possible, but only if needed
	    if (!$bypass_decode_parts &&
		($will_do_virus_scanning ||
		    ($banned_filename_re && !@banned_filename) )
	    ) { # decode_parts can take a lot of time !!!
		if (!defined($msginfo->mime_entity)) {
		    $which_section = "mime_decode";
		    $msginfo->mime_entity(mime_decode($fh,$tempdir));
		    prolong_timer($which_section);
		}
		$which_section = "decoding";
		my(@parts); my($depth) = 1;
		# fetch all not-yet-visited part names, and start a new cycle
		TIER: while ( @parts=@{$file_generator_object->parts_list} ) {
		    if ($depth > $MAXLEVELS) {
			$hold = "Maximum decoding depth ($MAXLEVELS) exceeded";
			last;
		    }
		    $file_generator_object->parts_list_reset; # new names cycle
		    # clip to avoid very long log entries
		    my(@chopped_parts) = @parts > 5 ? @parts[0..4] : @parts;
		    do_log(4, sprintf("decode_parts: level=%d, #parts=%d : %s",
			$depth, scalar(@parts), join(', ', @chopped_parts,
			(@chopped_parts<=@parts ? () : "...")) ));

		    determine_file_types(\@parts, $tempdir,
					 $file_generator_object);
		    if ($banned_filename_re) {
			# check for banned file content as guessed by 'file'
			my($banned_filenames_ref) =
			    check_for_banned_filenames($banned_filename_re,
				undef, \@parts, $file_generator_object);
			push(@banned_filename, @$banned_filenames_ref);
			$scan_cache{$body_digest}{'FB'} =     # cache it
			    [@banned_filename]  if defined $body_digest;
		    }
		    for my $part (@parts) {
			if (! -f "$tempdir/parts/$part") {
			    do_log(0, "decode_parts: INFO, new name requested, but file not created: $part");
			} else {
			    $hold = decompose_part($part, $tempdir,
						   $file_generator_object);
			    last TIER  if defined $hold;
			}
		    }
		    $depth++;
		}
		section_time('parts');
		prolong_timer($which_section);
	    }

	    # protect virus scanner from mail bombs
	    if ($hold ne '') { $will_do_virus_scanning = 0 }

	    # virus scanning
	    if (!$extra_code_antivirus) {
		do_log(5, "No anti-virus code loaded, skipping this section");
	    } elsif ($will_do_virus_scanning) {
		if (!defined($msginfo->mime_entity)) {
		    $which_section = "mime_decode";
		    $msginfo->mime_entity(mime_decode($fh,$tempdir));
		    prolong_timer($which_section);
		}
		$which_section = "virus_scan";
		# some virus scanners behave badly if interrupted,
		# so for now just turn off the timer
		my($remaining_time) = alarm(0);  # check how much time is left, stop timer
		my($av_ret);
		eval {
		    my($virusname_list);
		    ($av_ret,$av_output,$virusname_list) =
			Amavis::AV::virus_scan($tempdir, $child_task_count==1);
		    @virusname = @$virusname_list;  # copy
		};
		section_time('AV-scan');
		prolong_timer($which_section, $remaining_time); # restart the timer
		if ($@ ne '') {
		    chomp($@);
		    die "$@\n"  if $@ ne "timed out";
		    @virusname = (); $av_ret = 0;  # assume not a virus!
		    do_log(0, "virus_scan TIMED OUT, ASSUME NOT A VIRUS !!!");
		}
		defined($av_ret) or die "All virus scanners failed!";
		if ($av_ret && defined $body_digest) {  # virus found
		    # save results to cache
		    $scan_cache{$body_digest}{'VO'} = $av_output;
		    $scan_cache{$body_digest}{'VN'} = [@virusname]; #copy!
		}
	    }

	    # spam scanning
	    if (!$extra_code_antispam) {
		do_log(5, "No anti-spam code loaded, skipping this section");
	    } elsif (!@virusname && !@banned_filename &&
		grep {!lookup($_, $bypass_spam_checks_sql,
				  \%bypass_spam_checks,
				  \@bypass_spam_checks_acl,
				  $bypass_spam_checks_re)} @recips) {
		$which_section = "spam_scan";
		($spam_level, $spam_status, $spam_report) =
		    Amavis::SpamControl::spam_scan($conn,$msginfo,
				$tempdir,$file_generator_object);
		prolong_timer($which_section);
		if (defined $body_digest) {  # save results to cache
		    $scan_cache{$body_digest}{'SL'} = $spam_level;
		    $scan_cache{$body_digest}{'SS'} = $spam_status;
		    $scan_cache{$body_digest}{'SR'} = $spam_report;
		}
	    }
	}

	$msginfo->sender_contact($msginfo->sender); # save the original addr
	$msginfo->sender_source($msginfo->sender);  # save the original addr
	# ensure we have $entity defined when we expect we'll need it
	if (@virusname) {
	    # if the result was cached, header hasn't been parsed yet,
	    # but we need it to construct notifications
	    if (!defined($msginfo->mime_entity)) {
		$which_section = "mime_decode";
		$msginfo->mime_entity(mime_decode($fh,$tempdir));
		prolong_timer($which_section);
	    }
	    # best attempt at determining true sender of the junk - normally
	    # the same as envelope sender
	    my($sender_contact,$sender_source) = best_try_originator(
		$msginfo->sender, $msginfo->mime_entity, \@virusname);
	    $msginfo->sender_contact($sender_contact); # save it
	    $msginfo->sender_source($sender_source);   # save it
	}

	# SECOND: now that we know what we got, decide what to do with it

	prolong_timer($which_section);
	my($considered_spam_by_some_recips);

	if (@virusname || @banned_filename) {  # virus or banned filename found
	    $which_section = "deal_with_virus_or_banned";
	    my(@offended_recips);  # recipients that consider this mail bad
	    for my $r (@{$msginfo->per_recip_data}) {
		if ($r->recip_done) {    # already dealt with
		} elsif (@virusname &&
			 lookup($r->recip_addr, $virus_lovers_sql,
				\%virus_lovers, \@virus_lovers_acl,
				$virus_lovers_re)) {
		    # not considered unwanted by this recipient
		} elsif (@banned_filename && lookup($r->recip_addr,
			   $banned_files_lovers_sql,
			   \%banned_files_lovers, \@banned_files_lovers_acl)) {
		    # not considered unwanted by this recipient
		} else {
		    push(@offended_recips, $r);  # considered unwanted
		}
	    }
	    my($final_destiny) = @virusname ? $final_virus_destiny
					    : $final_banned_destiny;
	    for my $r (@offended_recips) {
		if ($final_destiny <= 0) {  # drop or reject
		    # change mail destiny for those not wanting such contents
		    $r->recip_destiny($final_destiny);  # drop or reject
		    my($reason);
		    if (@virusname)
			{ $reason = "VIRUS: "  . join(", ", @virusname) }
		    elsif (@banned_filename)
			{ $reason = "BANNED: " . join(", ", @banned_filename) }
		    $r->recip_smtp_response( ($final_destiny < 0
			    ? "550 5.7.0 Message content rejected"
			    : "250 2.7.0 Ok, discarded") .
			    ", id=$am_id - ".sanitize_str($reason,1));
		    $r->recip_done(1);
		} else {  # pass (recip_destiny already set to pass)
		    my($ext) = @virusname ? $addr_extension_virus
			     : @banned_filename ? $addr_extension_banned : '';
		    if ($recipient_delimiter ne '' && $ext ne '' &&
			lookup($r->recip_addr, \@local_domains,$local_domains_re)
		    ) { # append appropriate address extensions
			# to mailbox names if desired, but only to those
			# that match @local_domains/$local_domains_re list
			my($localpart,$domain) = split_address($r->recip_addr);
			if ($replace_existing_extension) {
			    # strip away existing address extensions
			    $localpart =~ s/^(.*?)\Q$recipient_delimiter\E.*$/$1/s;
			}
			$r->recip_addr_modified(
			   $localpart . $recipient_delimiter . $ext . $domain);
		    }
		}
	    }
	    $which_section = "virus_or_banned quar+notif";
	    do_virus($conn,$msginfo);   # send notifications, quarantine it

	} else {  # not a virus, perhaps some recipients consider it spam?
	    # spaminess is an individual matter, we must compare spam level
	    # with each recipient setting, there is no generic criterium
	    # that the mail is spam

	    $which_section = "deal_with_spam";
	    my(@offended_recips);  # recipients that consider this mail spam
	    for my $r (@{$msginfo->per_recip_data}) {
		if ($r->recip_done) {    # already dealt with
		} elsif (lookup($r->recip_addr, $spam_lovers_sql) ||
			 $spam_level < lookup($r->recip_addr,
				$spam_kill_level_sql, $sa_kill_level_deflt) ||
			 lookup($r->recip_addr, \%spam_lovers,
				\@spam_lovers_acl, $spam_lovers_re) ) {
		    # not considered spam by this recipient
		} else {
		    push(@offended_recips, $r);  # considered spam
		}
	    }
	    for my $r (@offended_recips) {
		if ($final_spam_destiny <= 0) {  # drop or reject
		    # change mail destiny for those not wanting spam
		    $r->recip_destiny($final_spam_destiny);  # drop or reject
		    $r->recip_smtp_response( ($final_spam_destiny < 0
			    ? "550 5.7.0 Message content rejected"
			    : "250 2.7.0 Ok, discarded, UBE") . ", id=$am_id");
		    $r->recip_done(1);
		} else {  # pass (recip_destiny already set to pass)
		    if ($recipient_delimiter ne '' &&
			$addr_extension_spam ne '' &&
			lookup($r->recip_addr, \@local_domains,$local_domains_re)
		    ) { # append appropriate address extensions
			# to mailbox names if desired, but only to those
			# that match @local_domains/$local_domains_re list
			my($localpart,$domain) = split_address($r->recip_addr);
			if ($replace_existing_extension) {
			    # strip away existing address extensions
			    $localpart =~ s/^(.*?)\Q$recipient_delimiter\E.*$/$1/s;
			}
			$r->recip_addr_modified($localpart.
			    $recipient_delimiter.$addr_extension_spam.$domain);
		    }
		}
	    }
	    $considered_spam_by_some_recips = scalar(@offended_recips);
	    $which_section = "spam quar+notif";
	    do_spam($conn,$msginfo)  if $considered_spam_by_some_recips;
	}

	# THIRD: now that we know what to do with it, do it!

	prolong_timer($which_section);

	if ($forward_method ne '') {
	    # message must be delivered explicitly
	    $which_section = "forwarding";

	    # UNFINISHED: if spam levels are different for multiple recipients,
	    #   they should get individually delivered mail. For now the
	    #   first recipient dictates the spam thresholds for all !!!

	    my($hdr_edits) = Amavis::Out::EditHeader->new;
	    $hdr_edits = add_forwarding_header_edits(
		$conn,$msginfo,$hdr_edits,1,$hold);
	    $msginfo->header_edits($hdr_edits);
	    # will forward only to those recipients not yet marked
	    # as 'done' by the above content filtering sections
	    mail_dispatch($forward_method,$msginfo,0);
	}
	prolong_timer($which_section);

	$which_section = "delivery-notification";
	my($dsn_needed);
	($smtp_resp, $exit_code, $dsn_needed) = one_response_for_all($msginfo);
	if ($dsn_needed && !$dsn_per_recip_capable ||
	    $warnvirussender && @virusname ||
	    $warnspamsender && $considered_spam_by_some_recips) {
	    # generate delivery status notification according to rfc1892
	    # and rfc1894, but only if necessary
	    my($notification) = delivery_status_notification(
		$conn, $msginfo, scalar(@virusname), \%builtins,
		@virusname ? \$notify_virus_sender_templ
		 : $considered_spam_by_some_recips ? \$notify_spam_sender_templ
		 : \$notify_sender_templ);
	    if (defined $notification) {  # dsn needed
		mail_dispatch($notify_method,$notification,1);  # send delivery notification
		my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
		    one_response_for_all($notification);      # check status
		# if dsn can not be delivered, try to send it to postmaster
		if ($n_smtp_resp !~ /^2/ || $n_dsn_needed) {  # double bounce?
		    do_log(0, "DOUBLE BOUNCE: can not send DSN: $n_smtp_resp");
		    $notification->recips(['postmaster']);
		    mail_dispatch($notify_method,$notification,1);  # attempt double bounce
		}
		# $notification->purge;
	    }
	}
	prolong_timer($which_section);
	$which_section = "finishing";

	# generate customized log report - this is usually the only log entry
	# interesting to administrators during normal operation
	my($strr) = expand(\$log_templ,\%builtins); chomp($$strr);
	do_log(0, $$strr)  if $$strr !~ /^\s*$/;

    };  # end eval
    if ($@ ne '') {
	chomp($@);
	$preserve_evidence = 1;
	my($msg) = "$which_section FAILED: $@";
	do_log(0, "TROUBLE in check_mail: $msg");
	$smtp_resp = "451 4.5.0 Error in processing, id=$am_id, $msg";
	$exit_code = EX_TEMPFAIL;
	for my $r (@{$msginfo->per_recip_data}) {
	    next  if $r->recip_done;
	    $r->recip_smtp_response($smtp_resp);
	    $r->recip_done(1);
	}
    }
    if ($hold ne '') { $preserve_evidence = 1 };
    if (!$preserve_evidence && debug_oneshot()) {
	do_log(0, "DEBUG_ONESHOT CAUSES EVIDENCE TO BE PRESERVED");
	$preserve_evidence = 1;
    };
    $MSGINFO = undef;  # release global reference to msginfo object
    ($smtp_resp,$exit_code,$preserve_evidence);
}

sub add_forwarding_header_edits($$$$$) {
    my($conn, $msginfo, $hdr_edits, $allow_edits, $hold) = @_;
    $hdr_edits->prepend_header('Received',
	received_line($conn,$msginfo,am_id(),1),
	1)  if $insert_received_line && $mta_in_type ne 'milter';

    # discard existing X-AMaViS-HOLD header field, only allow our own
    $hdr_edits->delete_header('X-Amavis-Hold');
    if ($hold ne '') {
	$hdr_edits->append_header('X-Amavis-Hold', $hold);
	do_log(0, 'Placing on HOLD: '.$hold);
    }
    if ($extra_code_antivirus) {
	if ($X_HEADER_LINE && $X_HEADER_TAG =~ /^[!-9;-\176]+$/) {
	    $hdr_edits->delete_header($X_HEADER_TAG)  if $allow_edits &&
		$remove_existing_x_scanned_headers;
	    $hdr_edits->append_header($X_HEADER_TAG, $X_HEADER_LINE);
	}
	$hdr_edits->delete_header('X-Amavis-Alert');
	$hdr_edits->append_header('X-Amavis-Alert',
	    "INFECTED, message contains virus:\n " .
	    join(",\n ",@virusname), 1)  if @virusname;
	if (@banned_filename) {
	    my(@b) = @banned_filename > 3 ? @banned_filename[0..2]
					  : @banned_filename;
	    my($msg) = "BANNED FILENAME, message contains " .
		(@banned_filename == 1 ? 'part' : 'parts') . " named:\n ".
		join(",\n ",@b) . (@banned_filename > @b ? ", ..." : "");
	    $hdr_edits->append_header('X-Amavis-Alert', $msg, 1);
	}
    }
    if ($extra_code_antispam) {
# NOT FINISHED: the first recipient gives the levels to all recipients !!!
	my($tag_level)  = lookup($msginfo->recips->[0],
				$spam_tag_level_sql,  $sa_tag_level_deflt);
	my($kill_level) = lookup($msginfo->recips->[0],
				$spam_kill_level_sql, $sa_kill_level_deflt);
	$hdr_edits->edit_header('Subject', sub {$sa_spam_subject_tag . $_[1]})
	    if $allow_edits && $sa_spam_subject_tag ne '' && $spam_level>=$kill_level;
	$hdr_edits->delete_header('X-Spam-Status');
	$hdr_edits->delete_header('X-Spam-Flag');
	$hdr_edits->delete_header('X-Spam-Level');
	$hdr_edits->delete_header('X-Spam-Report');
	if ($spam_level >= $tag_level) {
	    my($full_spam_status) =
		sprintf("%s,\n hits=%3.1f\n tagged_above=%3.1f\n required=%3.1f\n %s",
		    ($spam_level >= $kill_level ? 'Yes' : 'No'),
		    $spam_level, $tag_level, $kill_level, $spam_status);
	    $hdr_edits->append_header('X-Spam-Status', $full_spam_status, 1);
	    if ($spam_level >= $kill_level) {
		$hdr_edits->append_header('X-Spam-Flag', 'YES');
		$hdr_edits->append_header('X-Spam-Level',
		    '*' x (min( max(int($spam_level+0.5),0), 40) ));
#		$hdr_edits->append_header('X-Spam-Report',
#		    $spam_report, 1)  if $spam_report ne '';
	    }
	}
    }
    $hdr_edits;
}

sub do_quarantine($$$$) {
    my($conn,$msginfo,$hdr_edits,$recips_ref) = @_;

    # NOTE: RFC2821 mentions possible headers X-SMTP-MAIL and X-SMTP-RCPT
    # Exim uses: Envelope-To,  Sendmail uses X-Envelope-To
    $hdr_edits->prepend_header('X-Envelope-To',  # or: X-Quarantined-To
	join(",\n ",qquote_rfc2821_local(@{$msginfo->recips})), 1);
    # Return path will be in Return-Path, no need for extra header
#   $hdr_edits->prepend_header('X-SMTP-MAIL',    # or: X-Quarantined-From
#	qquote_rfc2821_local($msginfo->sender));

    # ignore status, possible problems were already logged or exception thrown
    my($quar_msg) = Amavis::In::Message->new;
    $quar_msg->sender($mailfrom_to_quarantine ne '' ?
			$mailfrom_to_quarantine : $msginfo->sender);
    do_log(5, "DO_QUARANTINE, sender: ".$quar_msg->sender);
    $quar_msg->recips($recips_ref);
    $quar_msg->header_edits($hdr_edits);
    $quar_msg->mail_text($msginfo->mail_text);
    mail_dispatch('local:',$quar_msg,1);
    my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
	one_response_for_all($quar_msg);  # check status
    if ($n_smtp_resp !~ /^2/ || $n_dsn_needed) {
	# abort if quarantining not successful
	die "Can not quarantine: '$n_smtp_resp'";
    }
}

# If virus found - quarantine it and send notifications
sub do_virus($$) {
    my($conn,$msginfo) = @_;

    # suggest a name to be used as 'X-Quarantine-id:' or file name
    $VIRUSFILE = sprintf("virus-%s-%s",
			 strftime("%Y%m%d-%H%M%S",localtime), am_id());
    my($hdr_edits) = Amavis::Out::EditHeader->new;
    $hdr_edits->prepend_header('X-Quarantine-id', "<$VIRUSFILE>");
    $hdr_edits->append_header('X-AMaViS-Alert',
	"INFECTED, message contains virus:\n " .
	join(",\n ",@virusname), 1)  if @virusname;
    if (@banned_filename) {
	my(@b) = @banned_filename>3 ?@banned_filename[0..2] :@banned_filename;
	my($msg) = "BANNED FILENAME, message contains " .
	    (@banned_filename == 1 ? 'part' : 'parts') . " named:\n ".
	    join(",\n ",@b) . (@banned_filename > @b ? ", ..." : "");
	$hdr_edits->append_header('X-Amavis-Alert', $msg, 1);
    }

    my(@q_addr);   # obtain per-recipient quarantine address(es)
    do_log(5, "do_virus: looking for per-recipient quarantine")
	if ref($virus_quarantine_to) ne '';
    for my $r (@{$msginfo->per_recip_data}) {
	my($a) = lookup($r->recip_addr, $virus_quarantine_to);
	push(@q_addr, $a)  if $a ne '' && !grep {$_ eq $a} @q_addr;
    }
    do_quarantine($conn, $msginfo, $hdr_edits, \@q_addr)  if @q_addr;

    $hdr_edits = Amavis::Out::EditHeader->new;

    # try to find a per-sender administrator
    my($admin) = lookup($msginfo->sender, \%virus_admin,$virus_admin,$mailto);
    if ($admin eq '') {
	do_log(4, "Skip virus_admin notification for <".$msginfo->sender.
		  ">, no admin specified");
    } else {  # notify virus admin
	my($notification) = Amavis::In::Message->new;
	$notification->sender($mailfrom_notify_admin);
	$notification->recips([$admin]);
	my(%mybuiltins) = %builtins;  # make a local copy
	$mybuiltins{'T'} = [ quote_rfc2821_local($admin) ]; # used in 'To:'
	$mybuiltins{'f'} = $mailfrom_notify_admin ne ''     # used in 'From:'
			? qquote_rfc2821_local($mailfrom_notify_admin)
			: "amavisd-new <postmaster\@$myhostname>";
	$notification->mail_text(string_to_mime_entity(
	    expand(\$notify_virus_admin_templ,\%mybuiltins) ));
	$notification->header_edits($hdr_edits);
	mail_dispatch($notify_method,$notification,1);
	my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
	    one_response_for_all($notification);      # check status
	if ($n_smtp_resp !~ /^2/ || $n_dsn_needed)
	    { do_log(0, "FAILED to notify virus admin: $n_smtp_resp") }
	# $notification->purge;
    }

    if (!$warnvirusrecip) {
	# warn_recip() is disabled by default because of possible problems
	# with mailing lists. Enable only if you know what you're doing!
    } else {
	my(@locals) = grep { ! $_->recip_done && ($warn_offsite ||
		  lookup($_->recip_addr, \@local_domains, $local_domains_re)) }
			   @{$msginfo->recips};
	if (@locals) {
	    my($notification) = Amavis::In::Message->new;
	    $notification->sender($mailfrom_notify_recip);
	    $notification->recips(\@locals);
	    my(%mybuiltins) = %builtins;  # make a local copy
	    $mybuiltins{'f'} = $mailfrom_notify_recip ne ''  # used in 'From:'
			? qquote_rfc2821_local($mailfrom_notify_recip)
			: "amavisd-new <postmaster\@$myhostname>";
	    $notification->mail_text(string_to_mime_entity(
		expand(\$notify_virus_recips_templ,\%mybuiltins) ));
	    $notification->header_edits($hdr_edits);
	    mail_dispatch($notify_method,$notification,1);
	    my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
		one_response_for_all($notification);      # check status
	    if ($n_smtp_resp !~ /^2/ || $n_dsn_needed)
		{ do_log(0, "FAILED to notify virus recipients: $n_smtp_resp")}
	    # $notification->purge;
	}
    }
}

#
# If Spam found - quarantine it and log report
sub do_spam($$) {
    my($conn,$msginfo) = @_;
    # suggest a name to be used as 'X-Quarantine-id:' or file name
    $VIRUSFILE = sprintf("spam-%s-%s-%s", $body_digest,
			 strftime("%Y%m%d-%H%M%S",localtime), am_id());
    # NOT FINISHED: the first recipient gives the levels to all recipients !!!
    my($tag_level)  = lookup($msginfo->recips->[0],
				$spam_tag_level_sql,  $sa_tag_level_deflt);
    my($kill_level) = lookup($msginfo->recips->[0],
				$spam_kill_level_sql, $sa_kill_level_deflt);
    my($full_spam_status) =
	sprintf("%s,\n hits=%3.1f\n tagged_above=%3.1f\n required=%3.1f\n %s",
		($spam_level >= $kill_level ? 'Yes' : 'No'),
		$spam_level, $tag_level, $kill_level, $spam_status);
#   my($s) = $spam_status;  $s =~ s/\n //g;
    my($s) = $full_spam_status;  $s =~ s/\n / /g;

    do_log(5, "do_spam: looking for per-recipient quarantine")
	if ref($spam_quarantine_to) ne '';
    my(@q_addr);   # obtain per-recipient quarantine address(es)
    for my $r (@{$msginfo->per_recip_data}) {
	my($a) = lookup($r->recip_addr, $spam_quarantine_to);
	push(@q_addr, $a)  if $a ne '' && !grep {$_ eq $a} @q_addr;
    }
    if (!@q_addr) {
	do_log(0, sprintf("spam from=<%s>, to=%s, %s",
			$msginfo->sender_source,
			join(',', map{"<$_>"} @{$msginfo->recips}),
			$s));
    } else {   # try to quarantine it
	my($hdr_edits) = Amavis::Out::EditHeader->new;
	$hdr_edits->prepend_header('X-Quarantine-id', "<$VIRUSFILE>");
	$hdr_edits->append_header('X-Spam-Status', $full_spam_status, 1);
	$hdr_edits->append_header('X-Spam-Level',
				'*' x (min( max(int($spam_level+0.5),0), 40) ));
	do_quarantine($conn, $msginfo, $hdr_edits, \@q_addr);
	do_log(0, sprintf("spam from=<%s>, to=%s, %s, quarantine %s (%s)",
		      $msginfo->sender_source,
		      join(',', map{"<$_>"} @{$msginfo->recips}),
		      $s, $VIRUSFILE, join(',',@q_addr) ));
    }
    my($hdr_edits) = Amavis::Out::EditHeader->new;

    # try to find a per-sender administrator
    my($admin) = lookup($msginfo->sender, \%spam_admin,$spam_admin,$mailto);
    if ($admin eq '') {
	do_log(4, "Skip spam_admin notification for <".$msginfo->sender.
		  ">, no admin specified");
    } else {  # Notify admin
	my($notification) = Amavis::In::Message->new;
	$notification->sender($mailfrom_notify_spamadmin);
	$notification->recips([$admin]);
	my(%mybuiltins) = %builtins;  # make a local copy
	$mybuiltins{'T'} = [ quote_rfc2821_local($admin) ]; # used in 'To:'
	$mybuiltins{'f'} = $mailfrom_notify_spamadmin ne '' # used in 'From:'
			? qquote_rfc2821_local($mailfrom_notify_spamadmin)
			: "amavisd-new <postmaster\@$myhostname>";
	$notification->mail_text(string_to_mime_entity(
	    expand(\$notify_virus_admin_templ,\%mybuiltins) ));
	$notification->header_edits($hdr_edits);
	mail_dispatch($notify_method,$notification,1);
	my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
	    one_response_for_all($notification);      # check status
	if ($n_smtp_resp !~ /^2/ || $n_dsn_needed)
	    { do_log(0, "FAILED to notify spam admin: $n_smtp_resp") }
	# $notification->purge;
    }
}

# Calculate message digest;
# While at it, also get the message size and store original header,
# since we need it for the %H macro, and MIME::Tools may modify it.

sub get_body_digest($$) {
    my($fh,$msginfo) = @_;
    $fh->seek(0,0) or die "Can't rewind mail file: $!";
    local($_);

# choose message digest method:
    my($ctx) = Digest::MD5->new;    # 128 bits (32 hex digits)
#   my($ctx) = Digest::SHA1->new;   # 160 bits (40 hex digits), slightly slower

    my(@orig_header); my($header_size) = 0; my($body_size) = 0;
    while (<$fh>) {   # skip mail header
	last  if $_ eq "\n";
	$header_size += length($_);  push(@orig_header,$_);  # with trailing LF
    }
    my($len);
    while ( ($len=read($fh,$_,16384)) > 0 ) {
	$ctx->add($_);  $body_size += $len;
    }
    my($signature) = $ctx->hexdigest;
#   my($signature) = $ctx->b64digest;

    if ($signature =~ /^( [0-9a-fA-F]{32} (?: [0-9a-fA-F]{8} )? )$/x) {
	$signature = $1;  # checked (either 32 or 40 char), untaint
    }
    # store information obtained
    $msginfo->orig_header(\@orig_header);
    $msginfo->orig_header_size($header_size);
    $msginfo->orig_body_size($body_size);
    $msginfo->body_digest($signature);

    section_time('body hash');
    do_log(2, "body hash: $signature");
    $signature;
}

# Obtain Message-ID header
sub get_msg_id($) {
    my($entity) = @_;
    my($msgid);
    if (defined $entity)
	{ $msgid = $entity->head->get("Message-ID"); chomp($msgid) }
    $msgid;
}

sub find_program_path($$) {
    my($fv_list, $path_list_ref) = @_;
    $fv_list = [$fv_list]  if !ref $fv_list;
    my($found) = undef;
    for my $fv (@$fv_list) {
	my(@fv_cmd) = split(' ',$fv);
	if (!@fv_cmd) {               # empty, not available
	} elsif ($fv_cmd[0] =~ /^\//) {  # absolute path
	    if (-f $fv_cmd[0]) { $found = join(' ',@fv_cmd) }
	} elsif ($fv_cmd[0] =~ /\//) {   # relative path
	    die "find_program_path: relative paths not implemented: @fv_cmd\n";
	} else {                      # walk through the specified PATH
	    for my $p (@$path_list_ref) {
		if (-f "$p/$fv_cmd[0]") {
		    $found = $p . '/' . join(' ',@fv_cmd);
		    last;
		}
	    }
	}
	last if defined $found;
    }
    $found;
}

sub find_external_programs($) {
    my($path_list_ref) = @_;
    for my $f (qw($file $arc $gzip $bzip2 $lha $unarj $uncompress $unrar $zoo)) {
	my($g) = $f;  $g =~ s/\$/Amavis::Conf::/;
	my($fv_list) = eval('$'.$g);
	my($found) = find_program_path($fv_list,$path_list_ref);
	{ no strict 'refs'; $$g = $found }  # NOTE: a symbolic reference
	if (!defined $found) {
	    do_log(0, sprintf("No %-14s not using it", "$f,"));
	} else {
	    do_log(0, sprintf("Found %-11s at %s%s", $f,
		$daemon_chroot_dir ne '' ?"(chroot: $daemon_chroot_dir/) " :'',
		$found));
	}
    }
    for my $f (@av_scanners) {  # map program name hints to full paths
	if (ref($f->[1]) eq 'CODE') {
	    do_log(0, "Using internal av scanner code for ".$f->[0]);
	} else {
	    my($found) = $f->[1] = find_program_path($f->[1],$path_list_ref);
	    if (!defined $found) {
		do_log(3, "No av scanner: ".$f->[0]);
		$f = undef;  # release its storage
	    } else {
		do_log(0, sprintf("Found av scanner %-11s at %s%s", $f->[0],
		    $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) "
					     : '',
		    $found));
	    }
	}
    }
}

#
# Main program starts here
#

# Read dynamic source code, and logging and notification message templates
# at the end of the Amavis package
#
do{ local($/) = "__DATA__\n";   # set line terminator to this string
    map { chomp($_ = <Amavis::DATA>) }
	($extra_code_in_amcl, $extra_code_in_smtp,
	 $extra_code_antivirus, $extra_code_antispam,
	 $log_templ,
	 $notify_sender_templ,
	 $notify_virus_sender_templ,
	 $notify_virus_admin_templ,
	 $notify_virus_recips_templ,
	 $notify_spam_sender_templ,
	 $notify_spam_admin_templ);
}; # restore line terminator
close(\*Amavis::DATA) or "Can't close *Amavis::DATA: $!";

# discarding leading NL inserted by 'configure'
map { s/^\n// } ($log_templ, $notify_sender_templ,
	$notify_virus_sender_templ, $notify_spam_sender_templ,
	$notify_virus_admin_templ,  $notify_spam_admin_templ,
	$notify_virus_recips_templ, $notify_spam_recips_templ);
$log_templ = $1  if $log_templ =~ /^(.*)\n+$/; # discard trailing NL

# Be paranoid
umask(0027);

# try to find absolute path name of oneself
my($amavisd_path) = find_program_path($0, [split(/:/, $path, -1)]);
$amavisd_path = $1  if $amavisd_path =~ m{^([A-Za-z0-9/._=+-]+)$};    # untaint

my($config_file) = '/etc/amavisd.conf';  # default location of config file
if (@ARGV >= 2 && $ARGV[0] eq '-c') {    # override by command line option -c
    shift @ARGV; $config_file = shift @ARGV;
    $config_file = $1  if $config_file =~ m{^([A-Za-z0-9/._=+-]+)$};  # untaint
}
# Read config file, which may override default settings
Amavis::Conf::read_config($config_file);

$pid_file = "$TEMPBASE/amavisd.pid"  if !defined($pid_file); # backw compatible
$lock_file= "$TEMPBASE/amavisd.lock";

# Master configuration

if ($unix_socketname eq '') { $extra_code_in_amcl = undef }
else {
    eval $extra_code_in_amcl or die "Problem in the In::AMCL code: $@";
    $extra_code_in_amcl = 1;   # release memory occupied by the source code
}
if ($inet_socket_port eq '') { $extra_code_in_smtp = undef }
else {
    eval $extra_code_in_smtp or die "Problem in the In::SMTP code: $@";
    $extra_code_in_smtp = 1;   # release memory occupied by the source code
}

if (!@av_scanners) {
    $extra_code_antivirus = undef;
} elsif (lookup("\001", \%bypass_virus_checks, \@bypass_virus_checks_acl,
			$bypass_virus_checks_re)) {
    # do a simple test which (by using an impossible domain)
    # which should indicate if the lookup tables contain a catchall
    $extra_code_antivirus = undef;
} else {
    eval $extra_code_antivirus or die "Problem in the antivirus code: $@";
    $extra_code_antivirus = 1; # release memory occupied by the source code
}

if (lookup("\001", \%bypass_spam_checks, \@bypass_spam_checks_acl,
		   $bypass_spam_checks_re)) {
    $extra_code_antispam = undef;
} else {
    eval $extra_code_antispam or die "Problem in the antispam code: $@";
    $extra_code_antispam = 1; # release memory occupied by the source code
}

my($cmd) = lc($ARGV[0]);
if ($cmd =~ /^(start|debug|foreground)?$/) {
    $DEBUG = 1      if $cmd eq 'debug';
    $daemonize = 0  if $cmd eq 'foreground';
} elsif ($cmd !~ /^reload|stop$/) {
    die "Unknown argument.  Usage:\n  $0 [ -c config-file ] ( [ start ] | debug | stop | reload )\n";
} else {
    $pid_file ne '' or die "pid_file config parameter not defined, can't $cmd\n";
    -f $pid_file    or die "No pid_file $pid_file, can't $cmd the process\n";
    my($amavisd_pid);
    open(PID_FILE, $pid_file) or die "Can't read file $pid_file: $!\n";
    while (<PID_FILE>) { chomp; $amavisd_pid = $1 if /^(\d+)$/ }
    close(PID_FILE) or die "Can't close file $pid_file: $!";
    defined($amavisd_pid) or die "Invalid PID in the $pid_file, can't $cmd\n";
    my($sig) = $cmd eq 'reload' ? 'HUP' : 'TERM';
    kill($sig,$amavisd_pid) or die "Can't $sig amavisd[$amavisd_pid]: $!\n";
    exit 0;
}
$daemonize = 0  if $DEBUG;

# Set path, home and term explictly.  Don't trust environment
$ENV{PATH} = $path          if $path ne '';
$ENV{HOME} = $helpers_home  if $helpers_home ne '';
$ENV{TERM} = 'dumb';

# Fetch all remaining required code and compile it once-and-for-all at the
# parent process, so that forked children can inherit and share already
# compiled code in memory. Children will still need to 'use' modules
# if they want to inherit from their name space.
#
my(@modules) =   # required modules:
    qw( Exporter POSIX Fcntl Socket Errno Time::HiRes
	IO::File IO::Socket IO::Socket::UNIX IO::Wrap Unix::Syslog
	File::Basename File::Copy Mail::Address Mail::Header Mail::Internet
	MIME::Words MIME::Head MIME::Entity MIME::Parser Digest::MD5
	Net::Cmd Net::SMTP Net::Server Net::Server::PreForkSimple
	Convert::TNEF Convert::UUlib Compress::Zlib Archive::Tar Archive::Zip
	MIME::Decoder::Base64 MIME::Decoder::Binary MIME::Decoder::Gzip64
	MIME::Decoder::NBit MIME::Decoder::QuotedPrint MIME::Decoder::UU
      );
#	auto::POSIX::setgid auto::POSIX::setuid
my(@missing);
for my $m (@modules) {
	$_ = $m; $_ .= /^auto::/ ? '.al' : '.pm'; s[::][/]g;
	eval {require $_} or push(@missing,$_);
}
die "ERROR: MISSING REQUIRED MODULES: ".join(", ",@missing)."\n"  if @missing;

Amavis::Log::init("amavis", !$daemonize,
    $DO_SYSLOG, $SYSLOG_LEVEL, $LOGFILE, $log_level);

do_log(1, "Found myself: $amavisd_path -c $config_file");
do_log(1, "AMCL-in protocol code ".($extra_code_in_amcl?'':" NOT")." loaded");
do_log(1, "SMTP-in protocol code ".($extra_code_in_smtp?'':" NOT")." loaded");
do_log(1, "ANTI-VIRUS code       ".($extra_code_antivirus?'':" NOT")." loaded");
do_log(1, "ANTI-SPAM  code       ".($extra_code_antispam?'':" NOT")." loaded");

if (!$extra_code_antivirus) { @av_scanners = () }  # release storage

Amavis::SpamControl::init()  if $extra_code_antispam;

# Prepare a hash of macros to be used in notification message expansion.
# A key (macro name) must be a single character. Most characters are
# allowed, but to be on the safe side and for clarity it is suggested
# that only letters are used. Upper case letters may (as a mnemonic)
# suggest the value is an array, lower case may suggest the value is
# a scalar string - but this is only a convention and not enforced.
#
# A value may be a reference to a subroutine which will be called later at
# the time of macro expansion. This way we can provide a method for obtaining
# information which is not yet available, such as AV scanner results,
# or provide a lazy evaluation for more expensive calculations.
# Subroutine will be called in scalar context with no arguments.
# It may return a scalar string (or undef), or an array reference.

%builtins = (
    d => sub {rfc2822_timestamp()}, # provide RFC 2822 date-time (current time)
    h => $myhostname, # dns name of this host, or configurable name
    l => sub {lookup($MSGINFO->sender,\@local_domains,$local_domains_re)?1:undef}, # sender is local
    s => sub {qquote_rfc2821_local($MSGINFO->sender)}, # original envelope sender in <>
    S => sub {$MSGINFO->sender_contact}, # unmangled sender / sender address to be notified
    o => sub {$MSGINFO->sender_source},  # best attempt at determining
				# true sender (origin) of the virus
				# - normally the same as %s
    R => sub {$MSGINFO->recips},# original message recipients list
    D => sub {my($y,$n)=delivery_short_report($MSGINFO); $y}, # short dns: succ
    N => sub {my($y,$n)=delivery_short_report($MSGINFO); $n}, # short dns: fail
    t => sub {first_received_from($MSGINFO->mime_entity)}, # first entry in the Received: trace
    m => sub {get_msg_id($MSGINFO->mime_entity)}, # Message-ID of the message
    n => \&am_id,		# amavis internal message id (for log entries)
    i => sub {$VIRUSFILE},	# some quarantine id, e.g. quarantine filename
    q => sub { $virus_quarantine_to =~ /\@/ ? $virus_quarantine_to
		: (-d $QUARANTINEDIR ? "$QUARANTINEDIR/$VIRUSFILE"
				     : $QUARANTINEDIR) },
    v => sub {$av_output},	# scanner output, usually a list of viruses
    F => sub {\@banned_filename}, # list of banned file names
    V => sub {\@virusname},	# list of virus names
    H => sub {[map {my $h=$_; chomp($h); $h} @{$MSGINFO->orig_header}]},# orig hdr
    A => sub {[split(/\n/, $spam_report)]}, # SpamAssassin report lines
  # macros f, T, C, B will be defined by each warn_* as appropriate
  # (representing From:, To:, Cc:, and Bcc: respectively)
);

# Map local virtual username to a mailbox (e.g. to a quarantine filename
# or a directory). Used by mail_to_local_mailbox(), e.g. for direct
# local quarantining. The hash value may be a ref to a pair of fixed
# strings, or a subroutine ref (which must return a pair of strings
# (a list, not a list ref)) which makes possible lazy evaluation
# when some part of the pair is not known before the final delivery time.
#
# The first string in a pair must be either:
#   - empty or undef, which will disable saving the message,
#   - a filename, indicating a Unix-style mailbox,
#   - a directory name, indicating a maildir-style mailbox,
#     in which case the second string may provide a suggested file name.
#
%local_delivery_aliases = (
  'virus-quarantine' => sub { ($QUARANTINEDIR,  $VIRUSFILE) },
  'spam-quarantine'  => sub { ($QUARANTINEDIR, "$VIRUSFILE.gz") },
  'user-quarantine'  =>			# just an example
	sub { my($s) = $MSGINFO->sender;
	      $s =~ s/[^a-zA-Z0-9._=@]/-/; $s =~ s/\@/=/;
	      ( $QUARANTINEDIR,
		sprintf("user-%s-%s-%05d.gz",  # suggested file name
			$s, strftime("%Y%m%d-%H%M%S",localtime), $$) )
	    },
  'outgoing-quarantine' =>			# another example
	sub { ("$QUARANTINEDIR/outgoing.mbox", undef) },
  'incoming-quarantine' =>			# another example
	sub { ("$QUARANTINEDIR/incoming.mbox", undef) },
);

# set up Net::Server configuration
my $server = bless {
    server => {
	# command line arguments to be used after HUP must be untainted
	commandline => [$amavisd_path, '-c', $config_file], # deflt: [$0,@ARGV]

	# listen on the following sockets (one or more):
	port => [ ($unix_socketname eq '' ? () :
			"$unix_socketname|unix"), # traditional amavis client
		  ($inet_socket_port eq '' ? () :
			"$inet_socket_port/tcp"), # accept SMTP on this port
		],
	# limit socket bind (e.g. to the loopback interface)
	host => ($inet_socket_bind eq '' ? '*' : $inet_socket_bind),

	max_servers  => $max_servers,  # number of pre-forked children
	max_requests => $max_requests, # restart child after that many accept's

	user  => $daemon_user,
	group => $daemon_group,
	pid_file   => $pid_file,
	lock_file  => $lock_file,  # serialize lockfile
	background => $daemonize ? 1 : undef,
	setsid     => $daemonize ? 1 : undef,
	chroot     => $daemon_chroot_dir ne '' ? $daemon_chroot_dir : undef,
	no_close_by_child => 1,

	# controls log level for Net::Server internal log messages:
	#   0=err, 1=warning, 2=notice, 3=info, 4=debug
	log_level => ($DEBUG ? 4 : 2),
	log_file  => undef,  # will be overridden to call do_log()
    },
}, 'Amavis';

$0 = 'amavisd (master)';
$server->run;  # transfer control to Net::Server

# shouldn't get here
exit 1;

# we read text from DATA sections to avoid any interpretations
# of special characters (e.g. \ or ') by Perl
#
__DATA__
#
package Amavis::In::AMCL;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}

use subs @EXPORT;
use IO::File;

BEGIN {
    import Amavis::Conf qw(:confvars);
    import Amavis::Util qw(do_log am_id debug_oneshot rmdir_recursively);
    import Amavis::Lookup qw(lookup);
    import Amavis::Timing qw(section_time);
    import Amavis::rfc2821_2822_Tools;
    import Amavis::In::Message;
    import Amavis::In::Connection;
    import Amavis::rfc2821_2822_Tools qw(/^EX_/);
}

sub new($) { my($class) = @_;  bless {}, $class }

# Accept a single request for virus checking via UNIX socket from amavis client
# (used with sendmail milter and traditional (non-SMTP) MTA interface)
#
sub process_amavis_client_request($$$) {
    my($self, $sock, $conn, $check_mail) = @_;
    # $sock:       connected socket from Net::Server
    # $conn:       information about client connection
    # $check_mail: subroutine ref to be called with file handle

    my($msginfo) = Amavis::In::Message->new;

    my($fh,$tempdir);
    my($protocol_succeeded) = 0;  # got all data from amavis client
    my($which_section) = "initialization";
    eval {
	my($inbuff);
	#
	# Receive TEMPDIR/SENDER/RCPTS/LDA/LDAARGS from client
	#
	my $yval = "\1";  # value to return to the client if AOK

	$which_section = "RX_tempdir";
	defined(recv($sock, $inbuff, 8192, 0)) or die "recv (1) failed: $!";
	$inbuff =~ /^( \Q$TEMPBASE\E \/ (?! .* \.{2,} .*) [-\w.]+ )$/xso
	    or die "Invalid temporary directory $inbuff";
	$tempdir = $1;  # untaint the directory name
	# set new amavis message id
	am_id( ($tempdir =~ /amavis-(milter-)?(.+?)$/ ? $2 : undef) );
	defined(send($sock, $yval, 0)) or die "send ack (1) failed: $!";

	$which_section = "RX_sender";
	defined(recv($sock, $inbuff, 8192, 0)) or die "recv (2) failed: $!";
	defined(send($sock, $yval, 0))     or die "send ack (2) failed: $!";
	$inbuff = unquote_rfc2821_local($inbuff) if $gets_addr_in_quoted_form;
	$msginfo->sender($inbuff);
	debug_oneshot(1)  if lookup($msginfo->sender,\@debug_sender_acl);

	# Simple "protocol"
	# \2 means LDA; \3 means EOT (end of transmission)

	$which_section = "RX_recipients";
	my(@recips); my(@ldaargs);
	my($outvar) = \@recips;
	for (;;) {
	    defined(recv($sock,$inbuff,8192,0)) or die "recv (3) failed: $!";
	    last if ($inbuff eq "\3");
	    if ($inbuff eq "\2") {
		$outvar = \@ldaargs;
		$which_section = "RX_LDA";
	    } else {
		$inbuff = unquote_rfc2821_local($inbuff)
		    if $gets_addr_in_quoted_form && $outvar==\@recips;
		push(@$outvar, $inbuff);
	    }
	    defined(send($sock, $yval, 0)) or die "send ack (3) failed: $!";
	}
	$msginfo->recips(\@recips); $msginfo->rx_time(time);
	$protocol_succeeded = 1;  # protocol obtained all required data
	# amavis client is now expecting final status code

	$which_section = "opening_mail_file";
	# created by amavis client, just open it
	$fh = IO::File->new("$tempdir/email.txt")
	    or die "Can't open file $tempdir/email.txt: $!";
	$msginfo->mail_text($fh);
	section_time('got data');
	do_log(1, sprintf("AM.CL %s: <%s> -> %s", $tempdir, $msginfo->sender,
			  join(',', map{"<$_>"}@recips) ));
    };
    my($smtp_resp, $exit_code, $preserve_evidence);
    if ($@ ne '') {
	chomp($@);
	do_log(0,"$which_section FAILED, retry: " . $@);
	$fh->close  if $fh;
	$fh = undef; $msginfo->mail_text(undef);
	$exit_code = EX_TEMPFAIL;
	# keep directory for inspection
    } else {
	# check_mail() expects open file on $fh, need not be rewound
	($smtp_resp, $exit_code, $preserve_evidence) =
	    &$check_mail($conn,$msginfo,0,$tempdir);
	$fh->close or die "Can't close temp file: $!"   if $fh;
	$fh = undef; $msginfo->mail_text(undef);
	if ($tempdir eq '' || !-d $tempdir) {
	    # do nothing
	} elsif ($preserve_evidence) {
	    do_log(0, "tempdir is to be PRESERVED: $tempdir");
	} else {
	    do_log(4, "tempdir being removed: $tempdir");
	    rmdir_recursively($tempdir);
	}
	if ($forward_method eq '' && $exit_code != EX_TEMPFAIL) { # e.g. milter
# TODO: this must be based on exit_code: all or none must be done
#	    for my $r (@{$msginfo->per_recip_data}) {
#		# a limited helper program can not do it, but should have been done
#		my($addr,$newaddr) = ($r->recip_addr, $r->recip_addr_modified);
#		if ($r->recip_done) {
#		    do_log(0, "TODO: recip addr <$addr> should be removed");
#		} elsif ($newaddr ne $addr) {
#		    do_log(0, "TODO: recip addr <$addr> should be replaced with <$newaddr>");
#		}
#	    }
	}
    }
    if ($mta_in_type eq 'qmail' && $exit_code == EX_TEMPFAIL) {
	$exit_code = 81;  # qmail is different?!
    }
    do_log(3, "mail checking ended: exit_code=$exit_code ($smtp_resp)");
    send($sock, $exit_code, 0)      if $protocol_succeeded;
}

1;

__DATA__
#
package Amavis::In::SMTP;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}
use POSIX qw(strftime);
use Time::HiRes qw(time);

BEGIN {
    import Amavis::Conf qw($TEMPBASE $myhostname
	$child_timeout $can_truncate @debug_sender_acl);
    import Amavis::Util qw(do_log am_id prolong_timer debug_oneshot
	sanitize_str strip_tempdir rmdir_recursively);
    import Amavis::Lookup qw(lookup);
    import Amavis::Timing qw(section_time);
    import Amavis::rfc2821_2822_Tools;
    import Amavis::In::Message;
    import Amavis::In::Connection;
}

sub new($) {
    my($class) = @_;
    my($self) = bless {}, $class;
    $self->{proto} = undef;             # currently doing SMTP / ESMTP / LMTP
    $self->{pipelining}  = undef;       # may we buffer responses?
    $self->{smtp_outbuf} = undef;       # SMTP responses buffer for PIPELINING
    $self->{fh_pers} = undef;           # persistent file handle for email.txt
    $self->{tempdir_persistent} = undef;# temporary directory for check_mail
    $self->{preserve} = undef;          # don't delete tempdir on exit
    $self->{tempdir_empty} = 1;         # anything of interest in tempdir?
    $self->{session_closed_normally} = undef; # closed properly with QUIT
    $self;
}

sub preserve_evidence  # try to preserve temporary files etc in case of trouble
  { my($self)=shift; !@_ ? $self->{preserve} : ($self->{preserve}=shift) }

sub DESTROY {
    my($self) = shift;
#   do_log(0, "Amavis::In::SMTP::DESTROY called");
    $self->{fh_pers}->close
	or die "Can't close temp file: $!"  if $self->{fh_pers};
    if (defined $self->{tempdir_pers} && -d $self->{tempdir_pers}) {
	# this will not be included in the TIMING report,
	# but it only occurs infrequently and doesn't take that long
	if ($self->preserve_evidence && !$self->{tempdir_empty}) {
	    do_log(0, "tempdir is to be PRESERVED: ".$self->{tempdir_pers});
	} else {
	    do_log(2, "tempdir being removed: ".$self->{tempdir_pers});
	    rmdir_recursively($self->{tempdir_pers});
	}
    }
    if (! $self->{session_closed_normally}) {
	$self->smtp_resp(1,"421 4.3.2 Service shutting down, closing channel");
    }
}

sub prepare_tempdir($) {
    my($self) = @_;
    if (! defined $self->{tempdir_pers} ) {
	# invent a name for a temporary directory for this child, and create it
	my($now_iso8601) = strftime("%Y%m%dT%H%M%S", localtime);
	$self->{tempdir_pers} = sprintf("%s/amavis-%s-%05d",
					$TEMPBASE, $now_iso8601, $$);
    }
    if (! -d $self->{tempdir_pers} ) {
	mkdir($self->{tempdir_pers}, 0750)
	    or die "Can't create directory $self->{tempdir_pers}: $!";
	$self->{tempdir_empty} = 1;
	section_time('mkdir tempdir');
    }
    # prepare temporary file for writing (and reading later)
    my($fname) = $self->{tempdir_pers} . "/email.txt";
    if (! $self->{fh_pers} || ! -f $fname) {
	$self->{fh_pers} = IO::File->new($fname, "w+", 0640)
	    or die "Can't create file $fname: $!";
	section_time('create email.txt');
    } else {
	$self->{fh_pers}->seek(0,0) or die "Can't rewind mail file: $!";
	$self->{fh_pers}->truncate(0) or die "Can't truncate mail file: $!";
    }
}

# Accept a SMTP or LMTP connect (which can do any number of SMTP transactions,
# but usually does one) and call content checking for each message received
#
sub process_smtp_request($$$$) {
    my($self, $sock, $lmtp, $conn, $check_mail) = @_;
    # $sock:       connected socket from Net::Server
    # $lmtp:       use LMTP protocil instead of (E)SMTP
    # $conn:       information about client connection
    # $check_mail: subroutine ref to be called with file handle

    my($msginfo);
    $self->{pipelining} = 0;    # may we buffer responses?
    $self->{smtp_outbuf} = [];  # SMTP responses buffer for PIPELINING

# wicked SpamAssassin closes STDIN when running with local_tests_only=>0 !!!
# give it some toy to play with, if it must!
# open(DUMMY,'/dev/null') or die "Can't read /dev/null: $!";
# *STDIN  = \*DUMMY;
# *STDOUT = \*DUMMY;
# *STDERR = \*DUMMY;

    my($myheloname);
#   $myheloname = $myhostname;
#   $myheloname = 'localhost';
#   $myheloname = '[127.0.0.1]';
    $myheloname = '[' . $conn->socket_ip . ']';

    my($sender,@recips); my($got_rcpt);
    $conn->smtp_proto($self->{proto} = $lmtp ? 'LMTP' : 'SMTP');
    $self->smtp_resp(1, "220 $myheloname " . ($lmtp ? 'LMTP' : 'ESMTP') .
			" amavisd-new service ready");
    my($terminating); my($seq) = 0;
    while(<$sock>) {
	prolong_timer('reading SMTP command');
	{ # a block is used as a 'switch' statement - 'last' will exit from it
	    my($cmd) = $_;
	    do_log(4, $self->{proto} . "< " . sanitize_str($cmd));
	    !/^ \s* ([A-Za-z]+) (?: \s+ (.*?) )? \s* \r\n $/x && do {
		$self->smtp_resp(1,"500 5.5.2 Error: bad syntax", 1, $cmd); last;
	    };
	    $_ = uc($1); my($args) = $2;
	    /^RSET|DATA|QUIT$/ && $args ne '' && do {
		$self->smtp_resp(1,"501 5.5.4 Error: $_ does not accept arguments", 1,$cmd);
		last;
	    };
	    /^RSET$/ && do { $sender = undef; @recips = (); $got_rcpt = 0;
			     $msginfo = undef;  # forget previous
			     $self->smtp_resp(0,"250 2.0.0 Ok $_"); last };
	    /^NOOP$/ && do { $self->smtp_resp(1,"250 2.0.0 Ok $_"); last };
	    /^QUIT$/ && do {
		$self->smtp_resp(1,"221 2.0.0 $myheloname (amavisd) closing transmission channel");
		$terminating=1; last;
	    };
###	    !$lmtp && /^HELO$/ && do {  # strict
	    /^HELO$/ && do {
		$sender = undef; @recips = (); $got_rcpt = 0;  # implies RSET
		$msginfo = undef;  # forget previous
		$self->{pipelining} = 0; $self->smtp_resp(0,"250 $myheloname");
		$lmtp = 0; $conn->smtp_proto($self->{proto} = 'SMTP');
		$conn->smtp_helo($args); section_time('SMTP HELO'); last;
	    };
###	    (!$lmtp && /^EHLO$/ || $lmtp && /^LHLO$/) && do {  # strict
	    (/^EHLO$/ || /^LHLO$/) && do {
		$sender = undef; @recips = (); $got_rcpt = 0;  # implies RSET
		$msginfo = undef;  # forget previous
		$lmtp = /^EHLO$/ ? 0 : 1;
		$conn->smtp_proto($self->{proto} = $lmtp ? 'LMTP' : 'ESMTP');
		$self->{pipelining} = 1;
		$self->smtp_resp(0,"250 $myheloname\n" . join("\n",
			qw(PIPELINING SIZE 8BITMIME ENHANCEDSTATUSCODES)));
		$conn->smtp_helo($args); section_time("SMTP $_");
		last;
	    };
	    /^VRFY$/ && do {
		$self->smtp_resp(1,"502 5.5.1 Command $_ not implemented", 1, $cmd);
		# if ($args eq '') {
		#	$self->smtp_resp(1,"501 5.5.2 Syntax: VRFY address", 1, $cmd);
		# } else {
		#	$self->smtp_resp(1,"252 2.0.0 Cannot VRFY user, but will accept ".
		#		    "message and attempt delivery", 1, $cmd);
		# }
		last;
	    };
	    /^HELP$/ && do {
		$self->smtp_resp(1,"214 2.0.0 See amavisd-new home page at:\n".
				   "http://www.ijs.si/software/amavisd/");
		last;
	    };
	    /^MAIL$/ && do {  # begin new transaction
		if (defined($sender)) {
		    $self->smtp_resp(0,"503 5.5.1 Error: nested MAIL command", 1, $cmd);
		    $sender = undef; @recips = (); $got_rcpt = 0;
		    last;
		}
		# begin SMTP transaction
		if (!$seq) {# the first connect
		    section_time('SMTP pre-MAIL');  
		} else {    # establish new time reference for each transaction
		    Amavis::Timing::init();
		}
		$seq++;
		am_id(sprintf("%05d-%02d%s", $$,
		    $Amavis::child_invocation_count, ($seq>1 ? "-$seq" : "")));
		$self->prepare_tempdir;
		$msginfo = Amavis::In::Message->new;
		$msginfo->rx_time(time);

		# permit some sloppy syntax without angle brackets
		if ($args !~ /^FROM: \s*
			      ( < (?: " (?: \\. | [^\\"] )* " | [^"@]* )
				  (?: @ (?: \[ (?: \\. | [^\]] )* \] |
					    [^\[\]\\>] )* )?
			        > |
			        [^<\s] (?: " (?: \\. | [^\\"] )* " | [^"\s] )*
			      ) (?: \s+ ([^<>]+) )? $/isx ) {
		    $self->smtp_resp(0,"501 5.5.2 Syntax: MAIL FROM: <address>", 1, $cmd);
		    last;
		}
		my($addr,$opt) = ($1,$2);  my($bad);
		for (split(' ',$opt)) {
		    if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]*  ) =
			    ( [^= \000-\037\177-\377]+ ) $/x) {
			$self->smtp_resp(0,"501 5.5.4 Syntax error in MAIL FROM parameters",
				  1, $cmd);
			$bad = 1; last;
		    } else {
			my($name,$val) = (uc($1), $2);
			if ($name eq 'SIZE' && $val=~/^\d{1,20}$/) {
			    $msginfo->msg_size($val+0);
			} elsif ($name eq 'BODY' && $val=~/^7BIT|8BITMIME$/i) {
			    $msginfo->body_type(uc($val));
			} else {
			    $self->smtp_resp(0,"504 5.5.4 MAIL command parameter error: ".
					"$name=$val", 1, $cmd);
			    $bad = 1; last;
			}
		    }
		}
		if (!$bad) {
		   $addr = ($addr =~ /^<(.*)>$/s) ? $1 : $addr;
		   $self->smtp_resp(0,"250 2.1.0 Sender $addr OK");
		   $sender = unquote_rfc2821_local($addr);
		   debug_oneshot(lookup($sender,\@debug_sender_acl)?1:0,
				 $self->{proto}."< ".sanitize_str($cmd));
		};
		last;
	    };
	    /^RCPT$/ && do {
		if (!defined($sender)) {
		    $self->smtp_resp(0,"503 5.5.1 Need MAIL command before RCPT", 1, $cmd);
		    $sender = undef; @recips = (); $got_rcpt = 0;
		    last;
		}
		$got_rcpt++;
		# permit some sloppy syntax without angle brackets
		if ($args !~ /^TO: \s*
			      ( < (?: " (?: \\. | [^\\"] )* " | [^"@]* )
				  (?: @ (?: \[ (?: \\. | [^\]] )* \] |
					    [^\[\]\\>] )* )?
			        > |
			        [^<\s] (?: " (?: \\. | [^\\"] )* " | [^"\s] )*
			      ) (?: \s+ ([^<>]+) )? $/isx ) {
		    $self->smtp_resp(0,"501 5.5.2 Syntax: RCPT TO: <address>", 1, $cmd);
		    last;
		}
		if ($2 ne '') {
		    $self->smtp_resp(0,"504 5.5.4 RCPT command parameter not implemented: $2", 1, $cmd);
		### $self->smtp_resp(0,"555 5.5.4 RCPT command parameter unrecognized: $2", 1, $cmd);
		} else {
		    my($addr,$opt) = ($1,$2);
		    $addr = ($addr =~ /^<(.*)>$/s) ? $1 : $addr;
		    $self->smtp_resp(0,"250 2.1.5 Recipient $addr OK");
		    push(@recips, unquote_rfc2821_local($addr));
		};
		last;
	    };
	    /^DATA$/ && !@recips && do {
		if (!defined($sender)) {
		    $self->smtp_resp(1,"503 5.5.1 Need MAIL command before DATA", 1, $cmd);
		} elsif (!$got_rcpt) {
		    $self->smtp_resp(1,"503 5.5.1 Need RCPT command before DATA", 1, $cmd);
		} elsif ($lmtp) {  # rfc2033 requires 503 code!
		    $self->smtp_resp(1,"503 5.1.1 Error (DATA): no valid recipients", 1, $cmd);
		} else {
		    $self->smtp_resp(1,"554 5.1.1 Error (DATA): no valid recipients", 1, $cmd);
		}
		last;
	    };
	    /^DATA$/ && do {
		alarm($child_timeout);  # MTA timer starts here (?)
		my($complete,$invitation_sent);
		eval {
		    $msginfo->sender($sender); $msginfo->recips(\@recips);
		    do_log(1, sprintf("%s:%s %s: <%s> -> %s Received: %s",
			      $conn->smtp_proto, $conn->socket_port,
			      $self->{tempdir_pers}, $sender,
			      join(',', map{"<$_>"}@recips),
			      join(' ',
				($msginfo->msg_size  eq '' ? ()
				 : 'SIZE='.$msginfo->msg_size),
				($msginfo->body_type eq '' ? ()
				 : 'BODY='.$msginfo->body_type),
				received_line($conn,$msginfo,am_id(),0) )
			      ) );
		    $self->smtp_resp(1,"354 End data with <CR><LF>.<CR><LF>");
		    $invitation_sent = 1;
		    section_time('SMTP pre-DATA-flush') if $self->{pipelining};
		    $self->{tempdir_empty} = 0;
		    do{ local($/) = "\r\n";   # set line terminator to CRLF
			while(<$sock>) {  # use native I/O for speed
			  # do_log(5, $self->{proto} ."< " . sanitize_str($_));
			    if (/^\./) {
				if (/^\.\r\n$/) { $complete = 1; last }
				s/^\.(.+\r\n)$/$1/s;  # rfc 2821 by the letter
			    }
			    chomp; # remove \r\n (=$/), faster than s/\r\n$/\n/
			    print {$self->{fh_pers}} $_,"\n"
				or die "Can't write to mail file: $!";
			}
		    }; # restores line terminator
		    do_log(4, $self->{proto} . "< .\\r\\n")  if $complete;
		    $self->{fh_pers}->flush or die "Can't flush mail file: $!";
		    # On some systems you have to do a seek whenever you
		    # switch between reading and writing. Amongst other things,
		    # this may have the effect of calling stdio's clearerr(3).
		    $self->{fh_pers}->seek(0,1) or die "Can't seek on file: $!";
		    section_time('SMTP DATA');
		};
		if ($@ ne '' || !$complete) {  # error or connection broken
		    chomp($@);
		    $@ = 'incomplete'  if !$complete && $@ eq '';
		    do_log(0, $self->{proto} . " TROUBLE: $@");
		    # either send: '421 Shutting down', or alternatively:
		    #   '451 Aborted, error in processing' and NOT shut down!
		    if ($invitation_sent) {
			$self->smtp_resp(1,"451 4.5.0 Aborted, error in processing: " . $@);
		    } else {
			$self->smtp_resp(1,"451 4.5.0 End data with <CR><LF>.<CR><LF>".
				    " Aborted, error: " . $@);
		    }
		### $terminating = 1;
		} else {  # all OK
		    #
		    # Is it acceptable to do all this processing here,
		    # before returning response???  According to rfc1047
		    # it is not a good idea! But at the moment we do not have
		    # much choice, amavis has no queueing mechanism and can not
		    # accept responsibility for delivery.
		    #
		    # check contents before responding
		    # check_mail() expects open file on $self->{fh_pers},
		    # need not be rewound
		    $msginfo->mail_text($self->{fh_pers});
		    my($smtp_resp, $exit_code, $preserve_evidence) =
			&$check_mail($conn,$msginfo,
				     $lmtp,$self->{tempdir_pers});
		    if ($preserve_evidence) { $self->preserve_evidence(1) }
		    if (!$lmtp) {
			do_log(4, "sending SMTP response: \"$smtp_resp\"");
			$self->smtp_resp(0, $smtp_resp);
		    } else {
			for my $r (@{$msginfo->per_recip_data}) {
			    do_log(4, sprintf(
				"sending LMTP response for <%s>: \"%s\"",
				$r->recip_addr, $r->recip_smtp_response));
			    $self->smtp_resp(0, $r->recip_smtp_response);
			}
		    }
		};
		if ($self->preserve_evidence && !$self->{tempdir_empty}) {
		    # keep evidence in case of trouble
		    do_log(0,"PRESERVING EVIDENCE in ".$self->{tempdir_pers});
		    $self->{fh_pers}->close or die "Can't close mail file: $!";
		    $self->{fh_pers} = undef; $self->{tempdir_pers} = undef;
		    $self->{tempdir_empty} = 1;
		}
		# cleanup, but leave directory (and file handle
		# if possible) for reuse
		if ($self->{fh_pers} && !$can_truncate) {
		    # truncate is not standard across all Unix variants,
		    # it is not Posix, but is XPG4-UNIX.
		    # So if we can't truncate a file and leave it open,
		    # we have to create it anew later, at some cost.
		    #
		    $self->{fh_pers}->close or die "Can't close mail file: $!";
		    $self->{fh_pers} = undef;
		    unlink($self->{tempdir_pers}."/email.txt")
			or die "Can't delete file ".
				$self->{tempdir_pers}."/email.txt: $!";
		    section_time('delete email.txt');
		}
		if (defined $self->{tempdir_pers}) { # prepare for the next one
		    strip_tempdir($self->{tempdir_pers});
		    $self->{tempdir_empty} = 1;
		}
		$sender = undef; @recips = (); $got_rcpt = 0;
		$self->preserve_evidence(0);  # reset
		# report elapsed times by section for each transaction
		# (the time for the QUIT remains unaccounted for)
		do_log(2, Amavis::Timing::report());  Amavis::Timing::init();
		last;
	    };  # DATA
	    # catchall (EXPN, TURN, unknown):
	    $self->smtp_resp(1,"502 5.5.1 Error: command ($_) not implemented", 1, $cmd);
	  # $self->smtp_resp(1,"500 5.5.2 Error: command ($_) not recognized", 1, $cmd);
	};
	last  if $terminating;  # exit SMTP-session loop

	# rfc2920 requires a flush whenever the local TCP input buffer is
	# emptied. Since we can't check it (unless we use sysread & select),
	# we should do a flush here to be in compliance. We could only break
	# the requirement if we knew we talk with a local MTA client which
	# uses client-side pipelining.
	$self->smtp_resp_flush;
    }
    $self->smtp_resp_flush; # just in case, the session might have been disconnected
    do_log(0, $self->{proto} .
	": INFO client broke the connection without a QUIT")  if !$terminating;
    $self->{session_closed_normally} = 1;   # protocol properly run down
    # closes connection after child_finish_hook
}

# sends a SMTP response consisting of 3-digit code and an optional message;
# slow down evil clients by delaying response on permanent errors
sub smtp_resp($$$;$$) {
    my($self, $flush,$resp, $penalize,$line) = @_;
    if ($penalize) {
	do_log(0, $self->{proto} .
		  ": $resp; PENALIZE: " . sanitize_str($line));
	sleep 5;
	section_time('SMTP penalty wait');
    }
    if ($resp !~ /^([1-5]\d\d)( |-|$)([245]\.\d{1,3}\.\d{1,3}(?: |$))?(.*)$/s)
	{ die "Internal error(2): bad SMTP response code: '$resp'" }
    my($resp_code,$continuation,$enhanced,$tail) = ($1,$2,$3,$4);
    my($lead_len) = length($resp_code) + 1 + length($enhanced);
    while (length($tail) > 512-2-$lead_len || $tail =~ /\n/) {
	# rfc2821: The maximum total length of a reply line including the
	# reply code and the <CRLF> is 512 characters.  More information
	# may be conveyed through multiple-line replies.
	my($head) = substr($tail,0,512-2-$lead_len);
	if ($head =~ /^([^\n]*\n)/) { $head = $1 }
	$tail = substr($tail,length($head)); chomp($head);
	push(@{$self->{smtp_outbuf}}, $resp_code.'-'.$enhanced.$head);
    }
    push(@{$self->{smtp_outbuf}},$resp_code.$continuation.$enhanced.$tail);
    $self->smtp_resp_flush   if $flush || !$self->{pipelining} ||
				@{$self->{smtp_outbuf}} > 200;
}

sub smtp_resp_flush($) {
    my($self) = shift;
    if (@{$self->{smtp_outbuf}}) {
	for my $resp (@{$self->{smtp_outbuf}}) {
	    do_log(4, $self->{proto} . "> " . sanitize_str($resp));
	};
	print map($_."\r\n", @{$self->{smtp_outbuf}});
	@{$self->{smtp_outbuf}} = ();
    }
}

1;

__DATA__
#
package Amavis::AV;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}

use Errno qw(EPIPE ENOTCONN);
use Socket;
use IO::Socket;
use IO::Socket::UNIX;

use subs @EXPORT_OK;
use vars @EXPORT;

BEGIN {
  import Amavis::Conf qw(:confvars);
  import Amavis::Util qw(do_log am_id retcode sanitize_str);
}

# same args and returns as run_av() below,
# but prepended with a $query, which is the string to be sent to the daemon
sub ask_daemon {
    my( $query, $tempdir,
	$av_name, $command, $socketname,
	$sts_clean, $sts_infected, $how_to_get_names, # regexps
      ) = @_;
    my($scan_status,$output,@virusname);
    my($sock) = IO::Socket::INET->new($socketname);
    defined($sock) or die "Can't connect to $socketname: $!";
    $sock->print($query) or die "Can't send to $socketname: $!";
    $sock->flush or die "Can't flush socket: $!";
    $output = join('',$sock->getlines);  chomp($output);
    $sock->close or die "Can't close connection: $!";
    do_log(2,"$av_name result: ".sanitize_str($output));
    if ($output =~ /$sts_infected/) {
	@virusname = $output =~ /$how_to_get_names/g;
	$scan_status = 1;      # no errors, virus(es)
    } elsif ($output =~ /$sts_clean/) {
	$scan_status = 0;      # no errors, no viruses
    } else {
	do_log(0,"$av_name FAILED - unknown status: ".sanitize_str($output));
    }
    ($scan_status,$output,\@virusname);
}

# same args and returns as run_av() below
sub ask_oav {
    my($tempdir,$av_name) = @_;
    ask_daemon("SCAN $tempdir/parts\n", @_);
}

# same args and returns as run_av() below
sub ask_fprotd {
    my($tempdir,$av_name) = @_;
    my($scan_status,$output,$virusnames);
    local(*DIR);
    opendir(DIR, "$tempdir/parts/")
	or die "Can't open directory $tempdir/parts/: $!";
    my(@files) = grep { -f $_ } map { "$tempdir/parts/$_" } readdir(DIR);
    closedir(DIR) or die "Can't close directory: $!";
    for my $fn (@files) {
	($scan_status,$output,$virusnames) =
	    ask_daemon("GET $fn?-dumb%20-archive HTTP/1.0\r\n\r\n", @_);
	last  if $scan_status;  # no point checking further
	# hum, shouldn't we stop here if an error is detected, too?
	# last  if !defined $scan_status;
    }
    ($scan_status,$output,$virusnames);
}

# same args and returns as run_av() below
#
use vars qw(%st_socket_created %st_sock); # keep persistent state (per-socket)
sub sophie_trophie {
    my($tempdir, $av_name,$command,$socketname) = @_;
    my($scan_status,$output,@virusname); my($retries) = 0;
    $SIG{PIPE} = 'IGNORE';  # 'send' to broken pipe throws a signal
    for (;;) {  # gracefully handle cases when av child times out or restarts
	eval {
	    if (!$st_socket_created{$socketname}) {
		$st_sock{$socketname} = IO::Socket::UNIX->new(
		    Type => SOCK_STREAM)
		    or die "Can't create Unix domain socket: $!\n";
		$st_socket_created{$socketname} = 1;
		do_log(3, "$av_name: Connecting to socket $socketname" .
			  (!$retries ? '' : ", retry #$retries") );
		$st_sock{$socketname}->connect(pack_sockaddr_un($socketname))
		    or die "Can't connect to socket $socketname: $!\n";
	    }
	    do_log(3,"$av_name: Sending directory name $tempdir/parts/");
	    # UGLY: bypass send method in IO::Socket to be able to retrieve
	    # status/errno directly from 'send', not from 'getpeername':
	    defined send($st_sock{$socketname}, "$tempdir/parts/\n", 0)
		or die "Can't send to socket $socketname: $!\n";
	    defined $st_sock{$socketname}->recv($output, 256)
		or die "Can't receive from socket $socketname: $!\n";
	    $! = undef;
	    $output ne '' or die "Empty result from $socketname\n";
	};
	last  if $@ eq '';
	# error handling (most interesting error codes are EPIPE and ENOTCONN)
	chomp($@); my($err) = "$!"; my($errn) = 0+$!;
	++$retries <= 4  or die "Too many retries to talk to $av_name ($@)";
	if ($retries <= 1 && $errn == EPIPE) {  # common, don't cause concern
	    do_log(1,"$av_name broken pipe (don't worry), retrying ($retries)");
	} else {
	    do_log( ($retries>1?0:1), "$@, retrying ($retries)");
	    sleep(1 + 5*($retries-1));  # slow down a possible runaway
	}
	if ($st_socket_created{$socketname}) {
	    # prepare for a retry, ignore 'close' status
	    $st_sock{$socketname}->close;
	    $st_sock{$socketname} = undef; $st_socket_created{$socketname} = 0;
	}
    }
    # LF-terminated, older Sophie (Trophie?) filled the buffer with nulls
    $output =~ s/[\000\r\n]+$//;
    # older Sophie/Trophie didn't append colon and error text if $stat == -1
    if ($output !~ /^ ([-+]? \d*) (?: : (.*?) )? $/xs) {
	do_log(0,"$av_name FAILED: can't parse: ".sanitize_str($output));
    } else {
	my($stat,$rest) = ($1,$2);
	$rest = $1  if $rest =~ /^'(.*?)'$/s;
	do_log(2,"$av_name result: $stat" . ($rest eq '' ? '' : ":$rest"));
#	if ($stat == 0 && $rest !~ /^Error:/) {
	if ($stat == 0) {
	    $scan_status = 0;      # no errors, no viruses
	} elsif ($stat == 1) {
	    @virusname = ($rest);  # no errors, virus(es)
	    $scan_status = 1;      # no errors, virus(es)
	} elsif ($stat == -1 || $rest =~ /^Error:/) {
	    do_log(0,"$av_name FAILED - $stat:$rest");
	} else {
	    do_log(0,"$av_name FAILED - TROUBLE: <$output>");
	}
    }
    ($scan_status,$output,\@virusname);
}

# Call a virus scanner and parse the its output.
# Returns a triplet (or die in case of failure).
# The first element of the triplet is interpreted as follows:
# - true if virus found,
# - 0 if no viruses found,
# - undef if it did not complete its jobs;
# the second element is a string, the text as output by the virus scanner;
# the third element is ref to a list of virus names found (if any).
#   (it is guaranteed the list will be nonempty if virus was found)
#
sub run_av {
    my( $tempdir,  # this arg is extra, not part of n-tuple
	$av_name, $command, $args,
	$sts_clean,    # a ref to a list of status values, or a regexp
	$sts_infected, # a ref to a list of status values, or a regexp
	$how_to_get_names, # ref to sub, or a regexp to get list of virus names
	$pre_code, $post_code,  # routines to be invoked before and after av
      ) = @_;
    $args =~ s[{}]["$tempdir/parts"]g;  # replace {} with directory name
    my($scan_status,$output,$virusnames);
    if (defined $pre_code) { &$pre_code(@_) }
    if (ref($command) eq 'CODE') {
	do_log(2,"Using $av_name: (built-in interface)");
	($scan_status,$output,$virusnames) = &$command(@_);
    } else {
	my($full_command) = "$command $args </dev/null 2>&1";
	do_log(2,"Using $av_name: $full_command");
	$output = qx($full_command);  chomp($output);
	my($retval) = retcode($?);
	do_log(2, "run_av: $command status=$retval, ".sanitize_str($output));
	# test for infected first, in case both expressions match
	if (ref($sts_infected) eq 'ARRAY' ? (grep {$_==$retval} @$sts_infected)
			: $output =~ /$sts_infected/) {  # is infected
	    $virusnames = []; # get a list of virus names by parsing output
	    @$virusnames = ref($how_to_get_names) eq 'ARRAY'
				? &$how_to_get_names($output)
				: $output =~ /$how_to_get_names/g;
	    @$virusnames = map {defined $_ ? $_ : ()} @$virusnames;
	    $scan_status = 1; # 'true' indicates virus found
	} elsif (ref($sts_clean) eq 'ARRAY' ? (grep {$_==$retval} @$sts_clean)
			: $output =~ /$sts_clean/) {     # is clean
	    $scan_status = 0; # 'false' (but defined) indicates no viruses
	} else {
	    do_log(0,"Virus scanner failure: $command (error code: $retval)");
	}
    }
    if (defined $post_code) { &$post_code(@_) }
    $virusnames = []        if !defined $virusnames;
    @$virusnames = (undef)  if $scan_status && !@$virusnames;  # nonnil
    ($scan_status, $output, $virusnames);
}

sub virus_scan($$) {
    my($tempdir,$firsttime) = @_;
    my($scan_status,$output,$virusnames); my($anyone_done); my(@errors); 
    for my $av (@av_scanners) {
	next  if !defined $av;
	eval { ($scan_status,$output,$virusnames) = run_av($tempdir,@$av) };
	if ($@ ne '') {
	    my($err) = $@; chomp($err); $err = "AV ($av->[0]) FAILED: $err";
	    do_log(0,$err); push(@errors,$err);
	};
	$anyone_done++  if defined $scan_status;
	last  if $scan_status;  # stop if we found a virus
    }
    if (!$anyone_done)
	{ die ("virus_scan ALL FAILED: ".join("; ",@errors)."\n") }
    ($scan_status, $output, $virusnames);  # return a triplet
}

1;

__DATA__
package Amavis::SpamControl;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.00';
    @ISA = qw(Exporter);
}
use FileHandle;
use Mail::SpamAssassin;
use Mail::SpamAssassin::NoMailAudit;

BEGIN {
    import Amavis::Conf qw(:sa
	%whitelist_sender @whitelist_sender_acl $whitelist_sender_re
	%blacklist_sender @blacklist_sender_acl $blacklist_sender_re);
    import Amavis::Util qw(do_log sanitize_str prolong_timer);
    import Amavis::Timing qw(section_time);
    import Amavis::Lookup qw(lookup);
}

use subs @EXPORT_OK;

use vars qw($spamassasin_obj);

sub init() {
    do_log(5, "Initializing Mail::SpamAssassin");
    $spamassasin_obj = Mail::SpamAssassin->new({
	debug => $sa_debug,
	dont_copy_prefs   => 1,
	local_tests_only  => $sa_local_tests_only,
	home_dir_for_helpers => $helpers_home,
	stop_at_threshold => 0,
    });
    $spamassasin_obj->compile_now;	# ensure all modules etc. are preloaded
    do_log(5, "Initializing Mail::SpamAssassin - done");
    alarm(0);              # seems like SA forgets to clear alarm in some cases
}

# - returns true if spam detected,
# - returns 0 if no spam found,
# - throws exception (die) in case of errors,
#   or just returns undef if it did not complete its jobs
#
sub spam_scan($$$$) {
    my($conn,$msginfo,$tempdir,$file_generator_object) = @_;

    my($spam_level, $spam_status, $spam_report);
    my($bayes_spam, $bayes_spam_prob, $bayes_report);

    do_log(5, "spam_scan: checking sender whitelist/blacklist for <" .
	      $msginfo->sender.">");
    my($wl) = lookup($msginfo->sender, \%whitelist_sender,
		     \@whitelist_sender_acl, $whitelist_sender_re);
    my($bl) = lookup($msginfo->sender, \%blacklist_sender,
		     \@blacklist_sender_acl, $blacklist_sender_re);
    if ($wl) {
	if ($bl) {
	    do_log(0, "spam_scan: whitelisted AND blacklisted sender!? <" .
		  $msginfo->sender . ">, spam check skipped, wl overrules" );
	} else {
	    do_log(1, "spam_scan: whitelisted sender <" .
		  $msginfo->sender . ">, spam check skipped" );
	}
	$spam_level = 0; $spam_status = "tests=sender_whitelisted";
    } elsif ($bl) {
	do_log(1, "spam_scan: blacklisted sender <" .
		  $msginfo->sender . ">, declared spam" );
	$spam_level = 9999; $spam_status = "tests=sender_blacklisted";
    } else {
#	($bayes_spam, $bayes_spam_prob, $bayes_report) = is_spam_naive_bayes(
#	    $conn,$msginfo,$tempdir,$file_generator_object);
#	if (defined($bayes_spam) && !$bayes_spam) {
#	    $spam_level = 0; $spam_status = "tests=bayes-ham";
#	}
    }
    if (!defined($spam_level)) {
	if (defined $sa_mail_body_size_limit &&
	      $msginfo->orig_body_size > $sa_mail_body_size_limit) {
	    do_log(1, "spam_scan: not wasting time on SA, message body ".
		      "longer than $sa_mail_body_size_limit bytes");
	} else {
	    my($fh) = $msginfo->mail_text;
	    $fh->seek(0,0) or die "Can't rewind mail file: $!";
	    my(@lines); my($body_lines) = 0;
	    # read mail into memory in preparation for SpamAssasin
	    while (<$fh>) { push(@lines,$_); last if $_ eq "\n" }  # header
	    while (<$fh>) { push(@lines,$_); $body_lines++ }       # body
	    section_time('SA msg read');

	    my($sa_required, $sa_tests);
	    my($remaining_time) = alarm(0);  # check how much time is left
	    eval {
		alarm(20);  # prepared to wait no more than n seconds
		my($mail_obj) = Mail::SpamAssassin::NoMailAudit->new(
					data => \@lines,  add_From_line => 0);
		section_time('SA parse');
		do_log(5, "CALLING NoMailAudit::check");
		my($per_msg_status) = $spamassasin_obj->check($mail_obj);
		do_log(5, "RETURNED FROM NoMailAudit::check");
		alarm(0);

		$spam_level  = $per_msg_status->get_hits;
		$sa_required = $per_msg_status->get_required_hits; # not used
		$sa_tests    = $per_msg_status->get_names_of_tests_hit;
		$spam_report = $per_msg_status->get_report;

		#Experimental, unfinished:
		# $per_msg_status->rewrite_mail;
		# my($entity) = nomailaudit_to_mime_entity($mail_obj);

		$per_msg_status->finish();
	    };
	    section_time('SA check');
	    prolong_timer('spam_scan_SA', $remaining_time); # restart the timer
	    if ($@ ne '') {  # SA timed out?
		chomp($@);
		die "$@\n"  if $@ ne "timed out";
	    }
	    $sa_tests = join(",\n ", split(/,\s*/,$sa_tests));
	    $spam_status = "tests=" . $sa_tests;
	}
    }
    ($spam_level, $spam_status, $spam_report);
}

#sub nomailaudit_to_mime_entity($) {
#   my($mail_obj) = @_;  # expect a Mail::SpamAssassin::NoMailAudit object
#   my(@m_hdr) = $mail_obj->header;  # in array context returns array of lines 
#   my($m_body) = $mail_obj->body;   # returns array ref
#   my($entity);
#   # make sure _our_ source line number is reported in case of failure
#   eval {$entity = MIME::Entity->build(
#	Type => 'text/plain', Encoding => '-SUGGEST',
#	Data => $m_body); 1}  or do {chomp($@); die $@};
#   my($head) = $entity->head;
#   # insert header fields from template into MIME::Head entity
#   for my $hdr_line (@m_hdr) {
#	# make sure _our_ source line number is reported in case of failure
#	eval {$head->replace($fhead,$fbody); 1} or do {chomp($@); die $@};
#   }
#   $entity;  # return the built MIME::Entity
#}

1;

__DATA__
#
# =============================================================================
# This text section should contain a single (non-commented) line.
# It governs how an AMaViS log entry is compiled when a virus is encountered.
# An empty text will prevent a log entry when a virus is encountered.
# Syntax is explained in the README.customize file.
#
$log_templ = '[? %#V |[? %#F |[?%#D|Not-Delivered|Passed]|BANNED name/type (%F)]|INFECTED (%V)], #
[?%o|(?)|<%o>] -> [<%R>|,][? %i ||, quarantine %i], Message-ID: %m';
__DATA__
#
# =============================================================================
# This is a template for (neutral) DELIVERY STATUS NOTIFICATIONS to sender.
# For syntax and customization instructions see README.customize
#
Subject: Undeliverable mail
Message-ID: <DSN%n@%h>

This nondelivery report was generated by the amavisd-new program
at host %h. Our internal reference code for your message
is %n.

Your message[?%m|| %m] could not be delivered to:[
  %N]
__DATA__
#
# =============================================================================
# This is a template for VIRUS/BANNED-FILE SENDER NOTIFICATIONS.
# For syntax and customization instructions see README.customize
#
Subject: [? %#V |[? %#F ||BANNED FILENAME (%F)]|VIRUS (%V)] IN YOUR MAIL 
[? %m  |#|In-Reply-To: %m]
Message-ID: <VS%n@%h>

[? %#V |[? %#F ||BANNED FILENAME ALERT]|VIRUS ALERT]

Our virus checker found
[? %#V |#|    [? %#V |viruses|virus|viruses]: %V]
[? %#F |#|    banned [? %#F |filenames|filename|filenames]: %F]
in your email to the following [? %#R |recipients|recipient|recipients]:[
-> %R]

[? %#D |Delivery of the email was stopped!

]#
Please check your system for viruses,
or ask your system administrator to do so.

For your reference, here are headers from your email:
------------------------- BEGIN HEADERS -----------------------------
[%H
]\
-------------------------- END HEADERS ------------------------------
__DATA__
#
# =============================================================================
# This is a template for VIRUS ADMINISTRATOR NOTIFICATIONS.
# For syntax and customization instructions see README.customize
#
Date: %d
From: %f
Subject: [? %#V |[? %#F ||BANNED FILENAME (%F)]|VIRUS (%V)]#
 FROM[?%l|| LOCAL] [?%o|(?)|<%o>]
To: [? %#T |undisclosed-recipients: ;|[<%T>|, ]]
[? %#C |#|Cc: [<%C>|, ]]
Message-ID: <VA%n@%h>

[? %#V |No viruses were found.
|A virus (%V) was found.
|Two viruses (%V) were found.
|%#V viruses were found.
]
[? %#F
|#|A banned filename (%F) was found.
|Two banned filenames (%F) were found.
|%#F banned filenames were found.
]
The mail originated from: <%o>

[? %t |#|According to the 'Received:' trace, the message originated at:
   %t
]
[? %#S |Notification to sender will not be mailed.

]#
[? %#D |#|The message WAS delivered to:[
%D]
]
[? %#N |#|The message WAS NOT delivered to:[
%N]
]
[? %v  |#|Virus scanner output:
   %v
]
[? %q  |Not quarantined.|The message has been quarantined as:
   %q
]
------------------------- BEGIN HEADERS -----------------------------
[%H
]\
-------------------------- END HEADERS ------------------------------
__DATA__
#
# =============================================================================
# This is a template for VIRUS RECIPIENTS NOTIFICATIONS.
# For syntax and customization instructions see README.customize
#
Date: %d
From: %f
Subject: [? %#V |[? %#F ||BANNED FILENAME]|VIRUS (%V)] #
 IN MAIL TO YOU (from [?%o|(?)|<%o>])
To: [? %#T |undisclosed-recipients: ;|[<%T>|, ]]
[? %#C |#|Cc: [<%C>|, ]]
Message-ID: <VR%n@%h>

[? %#V |[? %#F ||BANNED FILENAME ALERT]|VIRUS ALERT]

Our content checker found
[? %#V |#|    %V\n[? %#V |viruses|virus|viruses] #]
[? %#F |#|    %F\nbanned [? %#F |filenames|filename|filenames] #]
in an email to you [? %o |from unknown sender.|from:

   %o]

Please contact your system administrator for details.
[? %i ||
The ID of your quarantined message is:

   %i
]\
__DATA__
#
# =============================================================================
# This is a template for SPAM SENDER NOTIFICATIONS.
# For syntax and customization instructions see README.customize
#
Subject: UNSOLICITED BULK EMAIL from you (%V)
[? %m  |#|In-Reply-To: %m]
Message-ID: <SS%n@%h>

Your message to:[
-> %R]

was qualified as unsolicited bulk e-mail (UBE).

[? %q |Not quarantined.|The message has been quarantined as ID:
   %q]

SpamAssassin report:
[%A
]\
__DATA__
#
# =============================================================================
# This is a template for SPAM ADMINISTRATOR NOTIFICATIONS.
# For syntax and customization instructions see README.customize
#
Date: %d
From: %f
Subject: SPAM FROM[?%l|| LOCAL] [?%o|(?)|<%o>]
To: [? %#T |undisclosed-recipients: ;|[<%T>|, ]]
[? %#C |#|Cc: [<%C>|, ]]
[? %#B |#|Bcc: [<%B>|, ]]
Message-ID: <SA%n@%h>

Unsolicited bulk email \
[? %o |from unknown or forged sender.|from:
   %o]

[? %t |#|According to the 'Received:' trace, the message originated at:
   %t
]
[? %#D ||The message WAS delivered to:[
%D]

]#
[? %#N ||The message WAS NOT delivered to:[
%N]

]#
[? %q |Not quarantined.|The message has been quarantined as:
   %q]

SpamAssassin report:
[%A
]\

------------------------- BEGIN HEADERS -----------------------------
[%H
]\
-------------------------- END HEADERS ------------------------------
