#!/usr/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::Boot
#  Amavis::Conf
#  Amavis::Timing
#  Amavis::Lock
#  Amavis::Log
#  Amavis::Util
#  Amavis::rfc2821_2822_Tools
#  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::Lookup::SQLfield
#  Amavis::Lookup::SQL
#  Amavis::Lookup::LDAP
#  Amavis::In::AMCL
#  Amavis::In::SMTP
#  Amavis::AV
#  Amavis::SpamControl
#------------------------------------------------------------------------------

#
package Amavis::Boot;
use strict;

# Fetch all required modules (or nicely report missing ones), and compile them
# 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.
#
sub fetch_modules($$@) {
    my($reason,$required,@modules) = @_;
    my(@missing);
    for my $m (@modules) {
	local($_) = $m; $_ .= /^auto::/ ? '.al' : '.pm'; s[::][/]g;
	eval {require $_} or push(@missing,$m);
    }
    die "ERROR: MISSING $reason:\n" .
	join('', map {"  $_\n"} @missing)  if $required && @missing;
};

BEGIN {
    fetch_modules('REQUIRED BASIC MODULES', 1, qw(
	Exporter POSIX Fcntl Socket Errno Carp Time::HiRes
	IO::File IO::Socket IO::Wrap IO::Stringy
	Digest::MD5 Unix::Syslog File::Basename File::Copy
	Mail::Field Mail::Address Mail::Header Mail::Internet
	MIME::Base64 MIME::QuotedPrint MIME::Words
	MIME::Head MIME::Body MIME::Entity MIME::Parser
	Net::Cmd Net::SMTP Net::Server Net::Server::PreForkSimple
	MIME::Decoder::Base64 MIME::Decoder::Binary MIME::Decoder::Gzip64
	MIME::Decoder::NBit MIME::Decoder::QuotedPrint MIME::Decoder::UU
      ) );
      # auto::POSIX::setgid auto::POSIX::setuid
};

1;

#
package Amavis::Conf;
use strict;

# prototypes
sub D_REJECT(); sub D_BOUNCE(); sub D_DISCARD(); sub D_PASS();

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.15';
    @ISA = qw(Exporter);
    @EXPORT = ();
    @EXPORT_OK = ();
    %EXPORT_TAGS = (
	'confvars' => [qw(
	    $myversion $mydomain
	    $MYHOME $TEMPBASE $QUARANTINEDIR
	    $DEBUG @debug_sender_acl
	    $daemonize $pid_file $lock_file
	    $daemon_user $daemon_group $daemon_chroot_dir $path
	    $DO_SYSLOG $SYSLOG_LEVEL $LOGFILE $log_level
	    @av_scanners @av_scanners_backup
	    $max_servers $max_requests $child_timeout
	    $warnvirussender $warnspamsender
	    $warnbannedsender $warnbadhsender
	    $warnvirusrecip $warnbannedrecip
	    $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 $remove_existing_spam_headers
	    %local_delivery_aliases
	    $hdr_encoding $bdy_encoding
	    $final_virus_destiny $final_spam_destiny
	    $final_banned_destiny $final_bad_header_destiny
	    $recipient_delimiter $replace_existing_extension
	    $localpart_is_case_sensitive
	    $addr_extension_banned $addr_extension_virus $addr_extension_spam
	    $smtpd_recipient_limit
	    $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_virus_checks @bypass_virus_checks_acl $bypass_virus_checks_re
	    %bypass_spam_checks @bypass_spam_checks_acl $bypass_spam_checks_re
	    %bypass_banned_checks @bypass_banned_checks_acl $bypass_banned_checks_re
	    %bypass_header_checks @bypass_header_checks_acl $bypass_header_checks_re
	    %virus_lovers @virus_lovers_acl $virus_lovers_re
	    %spam_lovers @spam_lovers_acl $spam_lovers_re
	    %banned_files_lovers @banned_files_lovers_acl $banned_files_lovers_re
	    %bad_header_lovers @bad_header_lovers_acl $bad_header_lovers_re
	    %whitelist_sender @whitelist_sender_acl $whitelist_sender_re
	    $per_recip_whitelist_sender_lookup_tables
	    %blacklist_sender @blacklist_sender_acl $blacklist_sender_re
	    $per_recip_blacklist_sender_lookup_tables
	    $viruses_that_fake_sender_re
	    @lookup_sql_dsn $sql_key_fieldname
	    $sql_select_policy $sql_select_white_black_list
	    $enable_ldap $default_ldap $virus_lovers_ldap
	    $banned_files_lovers_ldap $bypass_virus_checks_ldap
	    $bypass_spam_checks_ldap $spam_tag_level_ldap
	    $spam_tag2_level_ldap $spam_kill_level_ldap
	    $spam_modifies_subj_ldap $local_domains_ldap
	    %local_domains @local_domains_acl $local_domains_re
	)],
	'notifyconf' => [qw(
	    $notify_method
	    $notify_xmailer_header
	    $virus_quarantine_method
	    $spam_quarantine_method
	    $mailfrom_notify_sender
	    $mailfrom_notify_admin
	    $mailfrom_notify_recip
	    $mailfrom_notify_spamadmin
	    $mailfrom_to_quarantine
	    $hdrfrom_notify_sender
	    $hdrfrom_notify_admin
	    $hdrfrom_notify_spamadmin
	    %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
	    $virus_quarantine_to
	    $spam_quarantine_to $spam_quarantine_bysender_to
	)],
	'unpack' => [qw(
	    $file $arc $gzip $bzip2 $lzop $lha $unarj $uncompress $unfreeze
	    $unrar $zoo $cpio
	)],
	'sa' => [qw(
	    $helpers_home
	    $sa_tag_level_deflt $sa_tag2_level_deflt $sa_kill_level_deflt
	    $sa_spam_subject_tag $sa_spam_modifies_subj
	    $sa_local_tests_only $sa_debug $sa_mail_body_size_limit
	    $sa_auto_whitelist
	)],
	'platform' => [qw(
	    $can_truncate
	    $unicode_aware
	    $eol
	    &D_REJECT &D_BOUNCE &D_DISCARD &D_PASS
	)],
    );
    Exporter::export_tags qw(confvars notifyconf unpack sa platform);
} # BEGIN

use POSIX qw(uname);
use Errno qw(ENOENT);

use vars @EXPORT;

$myversion = 'amavisd-new-20030616-p2';

$eol = "\n";  # native record separator in files: LF or CRLF or even CR
$unicode_aware = $]>=5.008 && length("\x{263a}")==1 && eval { require Encode };

# serves only as a quick default for other configuration settings
$MYHOME = '/var/amavis';
$mydomain = '!change-mydomain-variable!.example.com';# purposely broken default

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

# Definitions of LDAP lookup queries.
#
# hostname      : The hostname of the LDAP server we connect to.
#                 (Default = 'localhost')
# port          : The port where LDAP sends queries. (Default = 389)
# timeout       : Timeout (in sec) passed when connecting the remote
#                 server. (Default = 120)
# tls           : Enable TLS/SSL if true. (Default = 0)
# base          : The DN that is the base object entry relative to
#                 which the search is to be performed. (Default = undef)
# scope         : Scope can be 'base', 'one' or 'sub'. (Default = 'sub')
# query_filter  : The filter used to find the amavis account. The string
#                 must contain a '%m' token that will be replaced by the
#                 actual e-mail address.
#                 (Default = '(&(objectClass=amavisAccount)(mail=%m))')
# res_attr      : (Default = undef)
# res_filter    : (Default = %r)
# bind_dn       : If binding is needed, this is where you specify the
#                 DN to bind as. (Default = undef)
# bind_password : Binding password. (Default = undef)
#
# $default_ldap = {
#   hostname => 'ldap.example.com', tls => 1,
#   base => 'dc=example,dc=com', scope => 'sub',
#   query_filter => '(&(objectClass=amavisAccount)(mail=%m))'}
# };
#
# $virus_lovers_ldap = {res_attr => 'amavisVirusLover'};
# $banned_files_lovers_ldap = {res_attr => 'amavisBannedFilesLover'};
# $bypass_virus_checks_ldap = {res_attr => 'amavisBypassVirusChecks'};
# $bypass_spam_checks_ldap = {res_attr => 'amavisBypassSpamChecks'};
# $spam_tag_level_ldap = {res_attr => 'amavisSpamTagLevel'};
# $spam_kill_level_ldap = {res_attr => 'amavisSpamKillLevel'};
#
# $spam_whitelist_sender_ldap = {
#   query_filter => '(&(objectClass=amavisAccount)(mail=%m)
#                      (amavisWhitelistSender=%s))',
#   res_filter => 'OK'};
# $spam_blacklist_sender_ldap = {
#   query_filter => '(&(objectClass=amavisAccount)(mail=%m)
#                      (amavisBlacklistSender=%s))',
#   res_filter => 'OK'};
#
# $local_domains_ldap = {
#   query_filter => '(&(objectClass=mailDomain)(dc=%m))
#   res_filter => 'OK'};
#
# 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'] );

# The SQL select clause to fetch per-recipient policy settings
# The %k will be replaced by a comma-separated list of query addresses
# (e.g. full address, domain only, catchall).  Use ORDER, if there
# is a chance that multiple records will match - the first match wins
# If field names are not unique (e.g. 'id'), the later field overwrites the
# earlier in a hash returned by lookup, which is why we use '*,users.id'.
$sql_select_policy =
    'SELECT *,users.id FROM users,policy'.
    ' WHERE (users.policy_id=policy.id) AND (users.email IN (%k))'.
    ' ORDER BY users.priority DESC';

# The SQL select clause to check sender in per-recipient whitelist/blacklist
# The first SELECT argument '?' will be users.id from recipient SQL lookup,
# the %k will be sender addresses (e.g. full address, domain only, catchall).
$sql_select_white_black_list =
    'SELECT wb FROM wblist,mailaddr'.
    ' WHERE (rid=?) AND (sid=mailaddr.id) AND (mailaddr.email IN (%k))'.
    ' ORDER BY mailaddr.priority DESC';

#
# 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_port = [10024,10026,10027];  # ...possibly on more than one
$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 = 1;

$notify_method  = 'smtp:127.0.0.1:10025';
$forward_method = 'smtp:127.0.0.1:10025';
$virus_quarantine_method = 'local:virus-%i-%n';
$spam_quarantine_method  = 'local:spam-%b-%i-%n';

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

# encoding (charset in MIME context terminology)
# to be used in RFC 2047-encoded ...
$hdr_encoding = 'iso-8859-1';   # ... header field bodies
$bdy_encoding = 'iso-8859-1';   # ... notification body text

$smtpd_recipient_limit = 1000;  # max recipients (RCPT TO) - sanity limit

# $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. The lookup key is a recipient address
$virus_quarantine_to = undef;              # dflt: no virus quarantine
$spam_quarantine_to  = undef;              # dflt: no spam quarantine

# similar to $spam_quarantine_to, but the lookup key is the sender address
$spam_quarantine_bysender_to = undef;      # dflt: no by-sender 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_spam_modifies_subj = 1;     # true for compatibility; can be a lookup table

$sa_local_tests_only = 0;
$sa_debug = 0;

# See amavisd.conf and README.lookups for details.

# What to do with the message (this is independent of quarantining):
#   Reject:  tell MTA to generate a non-delivery notification,  MTA gets 5xx
#   Bounce:  generate a non-delivery notification by ourselves, MTA gets 250
#   Discard: drop the message and pretend it was delivered,     MTA gets 250
#   Pass:    deliver/accept the message
#
# Bounce and Reject are similar: in both cases sender gets a non-delivery
# notification, either generated by MTA, or by amavisd-new. The notification
# issued by amavisd-new may be more informative, while on the other hand
# MTA may be able to do a true reject on the original SMTP session
# (e.g. with sendmail milter), or else it just generates normal non-delivery
# notification / bounce (e.g. with Postfix, Exim). As a consequence,
# with Postfix and Exim the Bounce is more informative than Reject, and
# sendmail-milter users may prefer Reject.
#
# Bounce and Discard are similar: in both cases amavisd-new confirms
# to MTA the message reception with success code 250. The difference is
# in sender notification: Bounce sends a non-delivery notification to sender,
# Discard does not, the message is silently dropped. Quarantine and
# admin notifications are not affected by any of these settings.
#
# COMPATIBITITY NOTE: the separation of *_destiny values into
#   D_BOUNCE, D_REJECT, D_DISCARD and D_PASS made settings $warnvirussender
#   and $warnspamsender only still useful with D_PASS. The combination of
#   D_DISCARD + $warn*sender=1 is mapped into D_BOUNCE for compatibility.

# intentionally leave value -1 unassigned for compatibility
sub D_REJECT () { -3 }
sub D_BOUNCE () { -2 }
sub D_DISCARD() {  0 }
sub D_PASS   () {  1 }

# The following symbolic constants can be used in *destiny settings:
#
# D_PASS     mail will pass to recipients, regardless of bad contents;
#
# D_DISCARD  mail will not be delivered to its recipients, sender will NOT be
#            notified. Effectively we lose mail (but will be quarantined
#            unless disabled). Not a decent thing to do for a mailer.
#
# D_BOUNCE   mail will not be delivered to its recipients, a non-delivery
#            notification (bounce) will be sent to the sender by amavisd-new;
#            Exception: bounce (DSN) will not be sent if a virus name matches
#            $viruses_that_fake_sender_re, or to messages from mailing lists
#            (Precedence: bulk|list|junk);
#
# D_REJECT   mail will not be delivered to its recipients, sender should
#            preferably get a reject, e.g. SMTP permanent reject response
#            (e.g. with milter), or non-delivery notification from MTA
#            (e.g. Postfix). If this is not possible (e.g. different recipients
#            have different tolerances to bad mail contents and not using LMTP)
#            amavisd-new sends a bounce by itself (same as D_BOUNCE).
#
# Notes:
#   D_REJECT and D_BOUNCE are similar, the difference is in who is responsible
#            for informing the sender about non-delivery, and how informative
#            the notification can be (amavisd-new knows more than MTA);
#   With D_REJECT, MTA may reject original SMTP, or send DSN (delivery status
#            notification, colloquially called 'bounce') - depending on MTA;
#            Best suited for sendmail milter, especially for spam.
#   With D_BOUNCE, amavisd-new (not MTA) sends DSN (can better explain the
#            reason for mail non-delivery, but unable to reject the original
#            SMTP session). Best suited for Postfix and other dual-MTA setups.

$final_virus_destiny  = D_BOUNCE;      # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
$final_banned_destiny = D_BOUNCE;      # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
$final_spam_destiny   = D_REJECT;      # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
$final_bad_header_destiny = D_PASS;    # D_REJECT, D_BOUNCE, D_DISCARD, D_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_virus_checks/@bypass_virus_checks_acl, or $final_virus_destiny=D_PASS
# ($final_spam_destiny=D_PASS), 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_acl/$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_sender, $mailfrom_notify_admin, $mailfrom_notify_recip,
#   $mailfrom_notify_spamadmin, $mailfrom_to_quarantine
use vars qw($mailfrom);

# Define aliase names in this module to make it simpler to call
# these routines from amavisd.conf
*read_text   = \&Amavis::Util::read_text;
*read_l10n_templates = \&Amavis::Util::read_l10n_templates;
*read_hash   = \&Amavis::Util::read_hash;
*ask_daemon  = \&Amavis::AV::ask_daemon;
*sophos_savi = \&Amavis::AV::sophos_savi;
sub new_RE { Amavis::Lookup::RE->new(@_) };

# alias for backward compatibility with older config files
#   (@local_domains replaced by @local_domains_acl for consistency)
use vars qw(@local_domains);
*local_domains = \@local_domains_acl;

# read and evaluate configuration file
sub read_config($) {
    my($config_file) = @_;
    my($msg);
    my($errn) = stat($config_file) ? 0 : 0+$!;
    if ($errn == ENOENT) { $msg = "does not exist" }
    elsif ($errn)        { $msg = "inaccessible: $!" }
    elsif (! -f _)	 { $msg = "not a regular file" }
    elsif (! -r _)	 { $msg = "not readable" }
    if (defined $msg) { die "Config file $config_file $msg" }
    do $config_file;
    if ($@ ne '') { die "Error in config file $config_file: $@" }
    # compatibility with $mailfrom:
    if (!$mailfrom_notify_admin && !$mailfrom_notify_recip &&
	!$mailfrom_notify_spamadmin) {
	$mailfrom_notify_admin = $mailfrom_notify_recip = $mailfrom;
	$mailfrom_notify_spamadmin = $mailfrom;
    }
    # compatibility with "yes"/"no" for some variables
    for ($DEBUG, $DO_SYSLOG, $warn_offsite, $warnvirussender, $warnvirusrecip,
	$warnspamsender, $warnbannedsender, $warnbadhsender)
	{ $_ = 0 if /^\s*NO\s*$/i }
    # some sensible defaults for essential settings
    $TEMPBASE = $MYHOME                 if !defined $TEMPBASE;
    $helpers_home = $MYHOME             if !defined $helpers_home;
    $pid_file  = "$MYHOME/amavisd.pid"  if !defined $pid_file;
    $lock_file = "$MYHOME/amavisd.lock" if !defined $lock_file;
    $hdrfrom_notify_sender = "amavisd-new <postmaster\@$myhostname>"
	if !defined $hdrfrom_notify_sender;
    $hdrfrom_notify_admin = $mailfrom_notify_admin ne ''
	? $mailfrom_notify_admin : $hdrfrom_notify_sender
	if !defined $hdrfrom_notify_admin;
    $hdrfrom_notify_spamadmin = $mailfrom_notify_spamadmin ne ''
	? $mailfrom_notify_spamadmin : $hdrfrom_notify_sender
	if !defined $hdrfrom_notify_spamadmin;
    # compatibility with deprecated $warn*sender and old *_destiny values
    # map old values <0, =0, >0 into D_REJECT/D_BOUNCE, D_DISCARD, D_PASS
    for ($final_virus_destiny,$final_banned_destiny,$final_spam_destiny) {
	if ($_ > 0) { $_ = D_PASS }
	elsif ($_ < 0 && $_ != D_BOUNCE && $_ != D_REJECT) {  # compatibility
	    # favour favour Reject with sendmail milter, Bounce with others
	    $_ = $forward_method eq '' ? D_REJECT : D_BOUNCE;
	}
    }
    if ($final_virus_destiny == D_DISCARD && $warnvirussender)
	{ $final_virus_destiny = D_BOUNCE }
    if ($final_spam_destiny == D_DISCARD && $warnspamsender)
	{ $final_spam_destiny = D_BOUNCE }
    if ($final_banned_destiny == D_DISCARD && $warnbannedsender)
	{ $final_banned_destiny = D_BOUNCE }
    if ($final_bad_header_destiny == D_DISCARD && $warnbadhsender)
	{ $final_bad_header_destiny = D_BOUNCE }
}

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

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.15';
    @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.15';
    @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.15';
    @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(:platform $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"'
    $myname = $1  if basename($0) =~ /^(.*)$/;

    if ($syslog_level =~ /^\s*([a-z0-9]+)\.([a-z0-9]+)\s*$/i) {
	$syslog_facility = eval("LOG_\U$1");
	$syslog_priority = eval("LOG_\U$2");
    }
    $syslog_facility = LOG_DAEMON   if $syslog_facility !~ /^\d+$(?!\n)/;
    $syslog_priority = LOG_WARNING  if $syslog_priority !~ /^\d+$(?!\n)/;
    if ($do_syslog) {
	openlog($ident, LOG_PID, $syslog_facility);
    } else {
	$loghandle = IO::File->new($logfile, 'a')
	    or die "Failed to open log file $logfile: $!";
	$loghandle->autoflush(1);
    }
    my($msg) = "starting.  $myname at $myhostname $myversion";
    $msg .= ", eol=\"$eol\""   if $eol ne "\n";
    $msg .= ", Unicode aware"  if $unicode_aware;
    $msg .= ", LC_ALL=$ENV{LC_ALL}"  if $ENV{LC_ALL}  ne '';
    $msg .= ", LC_TYPE=$ENV{LANG}"   if $ENV{LC_TYPE} ne '';
    $msg .= ", LANG=$ENV{LANG}"      if $ENV{LANG}    ne '';
    write_log($msg, 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($prefix);
    if ($really_log_to_stderr || !$do_syslog) {  # create syslog-alike
	$prefix = sprintf("%s %s %s[%s]: ",
			  strftime("%b %e %H:%M:%S", localtime),
			  $myhostname, $myname, $$);
    }
    $am_id = "($am_id) "  if defined $am_id;
    $errmsg = Amavis::Util::sanitize_str($errmsg);
#   if (length($errmsg) > 2000) {  # crop at some arbitrary limit (< LINE_MAX)
#	$errmsg = substr($errmsg,0,2000) . "...";
#   }
    if ($really_log_to_stderr) {
	print STDERR $prefix,$am_id,$errmsg,$eol;
    } elsif ($do_syslog) {
	my($pre); my($logline_size) = 980;   # less than  1023 - prefix
	while (length($am_id.$pre.$errmsg) > $logline_size) {
	    my($avail) = $logline_size - length($am_id.$pre."...");
	    syslog($syslog_priority, "%s",
		$am_id . $pre . substr($errmsg,0,$avail) . "...");
	    $pre = "..."; $errmsg = substr($errmsg,$avail);
	}
	syslog($syslog_priority, "%s", $am_id.$pre.$errmsg);
    } else {
	lock($loghandle);
	print $loghandle $prefix,$am_id,$errmsg,$eol;
	unlock($loghandle);
    }
}

1;

#
package Amavis::Util;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.15';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&safe_encode &am_id &do_log &debug_oneshot
	&retcode &prolong_timer &sanitize_str &min &max
	&strip_tempdir &rmdir_recursively &rmdir_flat
	&read_text &read_l10n_templates &read_hash &run_command);
}
use subs @EXPORT_OK;
use POSIX qw(WEXITSTATUS WIFEXITED WTERMSIG WIFSIGNALED);
use Errno qw(ENOENT);
# use Encode;  # Perl 5.8  UTF-8 support

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

# A wrapper for Encode::encode, avoiding a bug in Perl 5.8.0 which causes
# Encode::encode to loop and fill memory when given a tainted string
sub safe_encode($$;$) {
    if (!$unicode_aware) { $_[1] }  # just return the second argument
    else {
	my($encoding, $str, $check) = @_;
	$check = 0  if !defined($check);
	my($taint) = substr($str,0,0);        # taintedness of the string
	$str =~ /^(.*)$(?!\n)/s;  $str = $1;  # untaint
	$taint . Encode::encode($encoding, $str, $check); # retain taintedness
    }
}

# 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 = Time::HiRes::alarm(0);  # check how much time is left
    }
    do_log(4, sprintf("prolong_timer after $which_section: ".
	      "remaining time = %.3f s", $child_remaining_time));
    $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 '\\',
# and Unicode characters to \x{xxxx}, returning the sanitized string.
sub sanitize_str {
    my($str,$keep_eol) = @_;
    my(%map) = ("\r"=>'\\r', "\n"=>'\\n', "\f"=>'\\f', "\t"=>'\\t',
		"\b"=>'\\b', "\e"=>'\\e', "\\"=>'\\\\');
    if ($keep_eol) {
	$str =~ s/([^\012\040-\133\135-\176])/  # and \240-\376 ?
		  exists($map{$1}) ? $map{$1} :
		    sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
    } else {
	$str =~ s/([^\040-\133\135-\176])/      # and \240-\376 ?
		  exists($map{$1}) ? $map{$1} :
		    sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%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 eq '.' || $f eq '..' || $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;
    my($errn) = stat("$dir/parts") ? 0 : 0+$!;
    rmdir_recursively("$dir/parts",1)  if $errn != ENOENT;
    # 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 !~ /^(.+)$(?!\n)/s;
	$f = $1;  # untaint
	if (-d "$dir/$f") {
	    rmdir_recursively("$dir/$f",0)  unless ($f eq '.' || $f eq '..');
	} 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 !~ /^(.+)$(?!\n)/s;
	$f = $1;  # untaint
	if (-d "$dir/$f") {
	    die "Refused to unlink a subdirectory $dir/$f"
		unless ($f eq '.' || $f eq '..');
	} 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;
}

# read a multiline string from file - may be called from amavisd.conf
sub read_text($;$) {
    my($filename,$encoding) = @_;
    my($inp) = IO::File->new;
    $inp->open($filename,'r')
	or die "Can't open file $filename for reading: $!";
    if ($unicode_aware && $encoding ne '') {
	binmode($inp,":encoding($encoding)")
	    or die "Can't set :encoding($encoding) on file $filename: $!";
    }
    my($str) = '';  # must not be undef, work around a Perl UTF8 bug
    while(<$inp>) { $str .= $_ }
    $inp->close or die "Can't close file $filename: $!";
    $str;
}

# attempt to read all user-visible replies from a l10n dir
# This function auto-fills $notify_sender_templ, $notify_virus_sender_templ,
# $notify_virus_admin_templ, $notify_virus_recips_templ,
# $notify_spam_sender_templ and $notify_spam_admin_templ from files named
# template-dsn.txt, template-virus-sender.txt, template-virus-admin.txt,
# template-virus-recipient.txt, template-spam-sender.txt,
# template-spam-admin.txt.  If this is available, it uses the charset
# file to do automatic charset conversion.
sub read_l10n_templates($;$) {
    my($dir) = @_;
    if (@_ > 1)  # compatibility with Debian
	{ my($l10nlang,$l10nbase) = @_; $dir = "$l10nbase/$l10nlang" }
    my($file_chset) = Amavis::Util::read_text("$dir/charset");
    my($taint) = substr($file_chset,0,0);
    if ($file_chset =~ m{^(?:#[^\n]*\n)*([^./\n\s]+)(\s*[#\n].*)?$}s) {
	$file_chset = $1.$taint;
    } else {
	die "Invalid charset $file_chset\n";
    }
    $notify_sender_templ =
	Amavis::Util::read_text("$dir/template-dsn.txt",          $file_chset);
    $notify_virus_sender_templ =
	Amavis::Util::read_text("$dir/template-virus-sender.txt", $file_chset);
    $notify_virus_admin_templ =
	Amavis::Util::read_text("$dir/template-virus-admin.txt",  $file_chset);
    $notify_virus_recips_templ =
	Amavis::Util::read_text("$dir/template-virus-recipient.txt",$file_chset);
    $notify_spam_sender_templ =
	Amavis::Util::read_text("$dir/template-spam-sender.txt",  $file_chset);
    $notify_spam_admin_templ =
	Amavis::Util::read_text("$dir/template-spam-admin.txt",   $file_chset);
}

# read a lookup hash from file - may be called from amavisd.conf .
#
# Format: one address per line, anything from # to the end of line is
# treated as a comment, but '#' within correctly quoted rfc2821 addresses
# is not treated as a comment (e.g. a hash sign within
# "strange # \"foo\" address"@example.com is valid).
# Leading and trailing whitespace is discarded, empty lines (containing only
# whitespace and comment) are ignored. Addresses are converted from quoted
# form into internal (raw) form and inserted as keys into a given hash,
# with a value of 1 (true). The $hashref argument is returned for convenience,
# so that one can say for example:
#   $per_recip_whitelist_sender_lookup_tables = {
#     '.my1.example.com' => read_hash({},'/var/amavis/my1-example-com.wl'),
#     '.my2.example.com' => read_hash({},'/var/amavis/my2-example-com.wl') }
#
sub read_hash(@) {
    unshift(@_,{})  if !ref $_[0]; # first argument is optional, defaults to {}
    my($hashref,$filename,$keep_case) = @_;

    my($inp) = IO::File->new;
    $inp->open($filename,'r') or die "Can't open file $filename for reading: $!";
    while(<$inp>) {   # carefully handle comments, # within "" does not count
	chomp; my($line)='';
	for my $t (/\G (" (?: \\" | [^"] )* " | [^#"]+ | . ) /gcx) {
	    last if $t eq '#';
	    $line .= $t;
	}
	$line =~ s/^\s+//; $line =~ s/\s+$//; # trim leading and trailing space
	next  if $line eq '';
	my($addr) = Amavis::rfc2821_2822_Tools::unquote_rfc2821_local($line);
        $addr = lc($addr)  if !$keep_case;
      # do_log(5, "read_hash: address: <$addr>");
	$hashref->{$addr} = 1;
    }
    $inp->close or die "Can't close file $filename: $!";
    $hashref;
}

# Run specified command as a subprocess (like qx operator, but more careful
# with error reporting and cancels :utf8 mode). Return a file handle open
# for reading from the subprocess.  NOTE: using IO::Handle to ensure the
# subprocess will be automatically reclaimed in case of failure.
#
sub run_command($$@) {
    my($stdin_from, $stderr_to, $cmd, @args) = @_;
    my($cmd_text) = join(' ',$cmd,@args);
    $stdin_from = '/dev/null'  if $stdin_from eq '';
    my($msg) = join(' ',$cmd,@args,"<$stdin_from");
    $msg .= " 2>$stderr_to"  if $stderr_to ne '';
    my($pid);
    my($proc_fh) = IO::File->new;
    eval { $pid = $proc_fh->open('-|') };  # fork
    if ($@ ne '') { chomp($@); die "run_command (open pipe): $@" }
    defined($pid) or die "run_command: can't fork: $!";
    if (!$pid) {  # child
	eval { # can't use die in child process, or we get two running daemons!
	    # close all unneeded files
	    close(STDIN)         or die "Can't close STDIN: $!";
	    close(main::stdin)   or die "Can't close main::stdin: $!";
	    open(STDIN,"<$stdin_from\0")
		or die "Can't reopen STDIN on $stdin_from: $!";
	    fileno(STDIN)==0     or die "run_command: STDIN not fd0";
	    if ($stderr_to ne '') {
		open(STDERR, ">$stderr_to")
		    or die "Can't open STDERR to $stderr_to: $!";
		fileno(STDERR)==2 or die "run_command: STDERR not fd2";
	    }
	    exec {$cmd} ($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 $cmd_text: $@");
	exec('/bin/false');  # must not exit, we have to avoid DESTROY handlers
	exit 1; # better safe than sorry
        # NOTREACHED
    }
    # parent
    do_log(5, "run_command: [$pid] $msg");
    binmode($proc_fh,":bytes")
	or die "Can't cancel :utf8 mode on pipe: $!"  if $unicode_aware;
    $proc_fh;   # return subprocess file handle
}

1;

#
package Amavis::rfc2821_2822_Tools;
use strict;

BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.15';
    @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(locale_h 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(:platform
	$myhostname $localhost_name $forward_method);
    import Amavis::Util qw(do_log);
}

# 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);
    # can't use %z because some systems do not support it (is treated as %Z)
    my($old_locale) = setlocale(LC_TIME, "C");
    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*$(?!\n)/;
    setlocale(LC_CTYPE, $old_locale);
    $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, port %s)",
	$conn->smtp_helo,
	($conn->client_ip eq '' ? '' : " ([".$conn->client_ip."])"),
	$localhost_name,
	($conn->socket_ip eq '' ? ''
	    : sprintf(" (%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) = @_;
    my($taint) = substr($mailbox,0,0);
    $mailbox =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\[\]\\] )*  \]
				|  [^@"<>\[\]\\\s] )*
			 ) $(?!\n)/xs ? ($1.$taint, $2.$taint) : ($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); my($taint) = substr($localpart,0,0);
    if ($localpart =~ /^(postmaster|mailer-daemon|double-bounce)$(?!\n)/i) {
	# do not split these, regardless of what the delimiter is
    } elsif ($delimiter eq '-' && $owner_request_special
	     && $localpart =~ /^owner-|-request$(?!\n)/i) {
	# backwards compatibility: don't split owner-foo or foo-request
    } elsif ($localpart =~ /^(.+?)\Q$delimiter\E(.*)$(?!\n)/s) {
	($localpart,$extension) = ($1.$taint, $2.$taint);
	# 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]+)*$(?!\n)/so) {  # 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) = @_;
    my($taint) = substr($mailbox,0,0);
    # 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:
    $mailbox = $1.$taint  if $mailbox =~ /^ \s* < ( .* ) > \s* $(?!\n)/xs;
    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,$dsn_per_recip_capable) = @_;
    my($smtp_resp,$exit_code,$dsn_needed);

    my($sender) = $msginfo->sender;
    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 <$sender>: 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_done && $r->recip_smtp_response !~ /^[245]/) {
		    $smtp_resp = '451 4.5.0 Bad SMTP response code??? "' .
				 $r->recip_smtp_response . '"';
		    last;  # pick the first
		}
	    }
	}
	if (defined $smtp_resp) {
	    $exit_code = EX_TEMPFAIL;
	    do_log(5, "one_response_for_all <$sender>: 4xx found, '$smtp_resp'");
	}
    }
    # NOTE: a 2xx SMTP response code is set both by internal Discard
    # and by 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 D_DISCARD => Discard
	my($notall);
	for my $r (@$per_recip_data) {
	    if ($r->recip_destiny == D_DISCARD) { # pick the first DISCARD code
		$smtp_resp = $r->recip_smtp_response  if !defined $smtp_resp;
	    } else { $notall++; last }           # one is not a discard, nogood
	}
	if ($notall) { $smtp_resp = undef }
	if (defined $smtp_resp) {
	    $exit_code = $forward_method eq '' ? 99 : EX_OK;
	    do_log(5, "one_response_for_all <$sender>: all DISCARD, '$smtp_resp'");
	}
    }
    if (!defined $smtp_resp) {
	# destiny for _all_ recipients is Discard or Reject => 5xx
        # (and there is at least one Reject)
	my($notall,$done_level); my($bounce_cnt) = 0;
	for my $r (@$per_recip_data) {
	    my($dest,$resp) = ($r->recip_destiny, $r->recip_smtp_response);
	    if ($dest == D_DISCARD) {
		# ok, this one is discard, let's see the rest
	    } elsif ($resp =~ /^5/ && $dest != D_BOUNCE) {
		# 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 = $resp; $done_level = $r->recip_done;
		}
	    } else { $notall++; last }     # one must be Pass or Bounce, nogood
	}
	if ($notall) { $smtp_resp = undef }
	if (defined $smtp_resp) {
	    $exit_code = EX_UNAVAILABLE;
	    do_log(5, "one_response_for_all <$sender>: REJECTs, '$smtp_resp'");
	}
    }
    if (!defined $smtp_resp) {
	# mixed destiny => 2xx, but generate dsn for bounces and rejects
	my($rej_cnt) = 0; my($bounce_cnt) = 0; my($drop_cnt) = 0;
	for my $r (@$per_recip_data) {
	    my($dest,$resp) = ($r->recip_destiny, $r->recip_smtp_response);
	    if ($resp=~/^2/ && $dest==D_PASS) {   # genuine successful delivery
		$smtp_resp = $resp  if !defined $smtp_resp;
	    }
	    $drop_cnt++   if $dest == D_DISCARD;
	    if ($resp =~ /^5/)
		{ if ($dest==D_BOUNCE) { $bounce_cnt++ } else { $rej_cnt++ } }
	}
	$exit_code = EX_OK;
	if (!defined $smtp_resp) {  # no genuine Pass/2xx
	    $smtp_resp = "250 2.5.0 Ok"; # declare success, we'll handle bounce
	    if ($any_not_done) { $smtp_resp .= ", continue delivery" }
	    elsif ($forward_method eq '') { $exit_code = 99 }  # milter DISCARD
	}
	$smtp_resp .= ", but "  if $rej_cnt+$bounce_cnt+$drop_cnt > 0;
	$smtp_resp .= join(", and ",
			   (!$rej_cnt    ? () : "$rej_cnt REJECT"),
			   (!$bounce_cnt ? () : "$bounce_cnt BOUNCE"),
			   (!$drop_cnt   ? () : "$drop_cnt DISCARD") );
	$dsn_needed = ( $bounce_cnt > 0 ||
		        ($rej_cnt > 0 && !$dsn_per_recip_capable) ) ? 1 : 0;
	do_log(5, "one_response_for_all <$sender>: " .
		  ($rej_cnt+$bounce_cnt+$drop_cnt > 0 ? 'mixed' : 'success') .
		  ", dsn_needed=$dsn_needed, '$smtp_resp'");
    }
    ($smtp_resp, $exit_code, $dsn_needed);
}

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 @
#
# The pattern allows for capturing of parenthesized substrings, which can
# then be referenced from the result string using the $1, $2, ... notation,
# as with the Perl m// operator. The number after the $ may be a multi-digit
# number. To avoid possible ambiguity the ${n} or $(n) form may be used.
# Substring numbering starts with 1. Nonexistent references evaluate to empty
# strings. If any substitution is done, the result inherits the taintedness
# of $addr. Keep in mind that the $ character needs to be backslash-quoted
# in qq() strings. Example:
#   $virus_quarantine_to = new_RE(
#     [ qr'^(.*)@example\.com$'i => 'virus-${1}@example.com' ],
#     [ qr'^(.*)(@[^@]*)?$'i     => 'virus-${1}${2}' ] );
#
# 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($taint) = substr($addr,0,0);  # empty string, tainted if $addr tainted
    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");
	my(@m) = $addr =~ /$key/;
	if (@m) {
	    $found++; $fullkey = $key;
	    my($any) =
		$result =~ s[ \$ ( (\d+) | { (\d+) } | \( (\d+) \) ) ]
			    [ my($j)=$2+$3+$4; $j<1 ? '' : $m[$j-1] ]gxse;
	    # bring taintedness of input to the result
	    $result .= $taint  if $any;
	    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.15';
    @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(:platform
	$recipient_delimiter $localpart_is_case_sensitive
	%local_domains @local_domains_acl $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 user+foo@
#  - lookup for user@  (only if $recipient_delimiter is nonempty)
#  - lookup for sub.example.com
#  - lookup for .sub.example.com
#  - lookup for .example.com
#  - lookup for .com
#  - lookup for .
#
# 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($taint) = substr($addr,0,0);
    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.$taint  if $domain =~ /^\@?(.*?)\.*$(?!\n)/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 && $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") );
    }
    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 =~ /^([^.]*)\.(.*)$(?!\n)/s) ? $2 : '';
    }
    # 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($taint) = substr($addr,0,0);

    my($lcaddr) = lc($addr);
    my($localpart,$domain) = split_address($addr);
    $domain = lc($domain);
    # chop off leading @ and trailing dots
    $domain = $1.$taint  if $domain =~ /^\@?(.*?)\.*$(?!\n)/s;
    my($found, $fullkey, $result);
    for my $e (@$acl_ref) {
	$result = 1; $fullkey = lc($e); my($key) = $fullkey;
	if ($key =~ /^(!+)(.*)$(?!\n)/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 =~ /^\.(.*)$(?!\n)/s) {# leading dot: domain or subdomain
	    $found++  if $domain =~ /^ (.*? (\.|$(?!\n)))? \Q$1\E $(?!\n)/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,
# - LDAP 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, lookup_sql and lookup_ldap 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::LDAP')) {
	    $match = $t->lookup_ldap($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;
	my($taint) = substr($key,0,0);
	if ($key =~ /^(!+)(.*)$(?!\n)/s) {  # starts with exclamation mark(s)
	  $key = $2.$taint;
	  $result = 1-$result  if (length($1) & 1);  # negate if odd
	}
	my($netip,$mask) = ($key =~ m{^([^/]*)/(.*)$(?!\n)}s) ?
				($1.$taint, $2.$taint) : ($key,32);
	my($netipbin) = unpack('N', pack('C4', split(/\./, $netip, -1)));
	if ($mask =~ /^(\d+\.){3}\d+$(?!\n)/) {  #  /m.m.m.m
	    $mask = unpack('N', pack('C4',split(/\./,$mask,-1)));
	} else {
	    $mask = 32  if $mask !~ /^\d+$(?!\n)/ || $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.15';
    @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 (/^%(%)$(?!\n)/)     { $_ = $1 }		#  %% -> %
      elsif (/^(%#?.)$(?!\n)/s)  { $_ = \$1 }
      elsif (/^\\([0-7]{1,3})$(?!\n)/) { $_ = chr(oct($1)) }	# \nnn
      elsif (/^\\(.)$(?!\n)/s)   { $_ = (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*$(?!\n)/) { $sel = 0 }
          elsif ($sel =~ /^\s*(\d+)\s*$(?!\n)/) { $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 && $$_=~/^%(.)$(?!\n)/s) { $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$(?!\n)/;
            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 =~ /^%\#(.)$(?!\n)/s) {  # 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*$(?!\n)/);
	  };
	} elsif ($$t =~ /^%(.)$(?!\n)/s) {  # 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.15';
    @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/LMTP
  { 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.15';
    @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 10], $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    # D_REJECT, D_BOUNCE, D_DISCARD, D_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_smtp_response  # smtp response as issued by remote MTA
  { my($self)=shift; !@_ ? $$self[5] : ($$self[5]=shift) }
sub recip_remote_mta # remote MTA that issued the smtp response
  { my($self)=shift; !@_ ? $$self[6] : ($$self[6]=shift) }
sub recip_mbxname    # mailbox file name when delivered to 'local:'
  { my($self)=shift; !@_ ? $$self[7] : ($$self[7]=shift) }
sub recip_whitelisted_sender  # recip considers this sender whitelisted
  { my($self)=shift; !@_ ? $$self[8] : ($$self[8]=shift) }
sub recip_blacklisted_sender  # recip considers this sender blacklisted
  { my($self)=shift; !@_ ? $$self[9] : ($$self[9]=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.15';
    @ISA = qw(Exporter);
}
BEGIN {
    import Amavis::Conf qw( :platform );
    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 message body
  { my($self)=shift; !@_ ? $self->{body_digest}: ($self->{body_digest}=shift) }
sub quarantined_to  # list of quarantine mailbox names or addresses if quarantined
  { my($self)=shift; !@_ ? $self->{quarantine} : ($self->{quarantine}=shift) }
sub dsn_sent        # delivery status notification was sent(1) or faked(2)
  { my($self)=shift; !@_ ? $self->{dsn_sent}   : ($self->{dsn_sent}=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'

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(D_PASS);  # default is Pass
	    $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.15';
    @ISA = qw(Exporter);
}
BEGIN {
    import Amavis::Conf qw(:platform $hdr_encoding);
    import Amavis::Timing qw(section_time);
    import Amavis::Util qw(do_log safe_encode);
}
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.
# '$structured' indicates that folding is only allowed at positions
# indicated by \n in the provided header body.
#
sub hdr($$;$) {
    my($field_name, $field_body, $structured) = @_;
    if ($field_name =~ /^(X-.*|Subject|Comments)$(?!\n)/si &&
	$field_body =~ /[^\011\012\040-\176]/ # nonprintable except TAB and LF?
    ) { # encode according to RFC 2047
	$field_body =~ s/\n[ \t]/ /g;  chomp($field_body);   # unfold
	my($field_body_octets) = safe_encode($hdr_encoding, $field_body);
	$field_body = MIME::Words::encode_mimeword($field_body_octets,
						   'Q', $hdr_encoding);
    } else {  # supposed to be in plain ASCII, let's make sure it is
	$field_body = safe_encode('ascii', $field_body);
    }
    $field_name = safe_encode('ascii', $field_name);
    my($str) = $field_name . ':';
    $str .= ' '  if $field_body !~ /^[ \t]/;
    $str .= $field_body;
    $str =~ s/\n([^ \t\n])/\n $1/g; # insert a space at line folds if missing
    $str =~ s/\n([ \t]*\n)+/\n/g;   # remove empty lines
    chomp($str);                    # chop off trailing NL if present
    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*$(?!\n)/) {
	    $str .= "\n"  if $str ne '';
	    $str .= $s;
	}
    } elsif (length($str) > 999) {
	## to be done
    }
    $str .= "\n";                  # append final NL
    do_log(5, "header: $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?$(?!\n)/ ? () #remove empty lines, assure NL
			     : (/\n$(?!\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 $eol;  # 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]*:(.*)$(?!\n)/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($taint) = substr($curr_head,0,0);
		    my($field_name,$field_body) = ($1.$taint, $2.$taint);
		    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/g;  # unfold
			    $out_fh->print(hdr($field_name,
					      &$edit($field_name,$field_body)))
				or die "sending mail header6: $!";
			}
		    }
		}
		last if $next_head eq $eol;  # end-of-header reached
		$curr_head = $next_head;
	    }
	}
    }
    $str = '';
    for (@{$self->{append}}) { $str .= $_ }
    $str .= $eol;  # 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.15';
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(&mail_to_local_mailbox);
}

use Errno qw(ENOENT);
use IO::File;
use IO::Wrap;

BEGIN {
    import Amavis::Conf qw(:platform $gzip $bzip2
			   %local_delivery_aliases $notify_method);
    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($taint) = substr($via,0,0);
    $via =~ /^local:(.*)$(?!\n)/si or die "Bad local method: $via";
    my($via_arg) = $1.$taint;
    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);

	# %local_delivery_aliases emulates aliases map - 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.
	# If no matching entry is found, the key ($localpart) is treated as
	# a mailbox filename if nonempty, or else quarantining is skipped.

	my($mbxname, $suggested_filename);
	{ # a block is used as a 'switch' statement - 'last' will exit from it
	    my($alias) = $local_delivery_aliases{$localpart};
	    if (ref($alias) eq 'ARRAY') {
		($mbxname, $suggested_filename) = @$alias;
	    } elsif (ref($alias) eq 'CODE') {   # lazy evaluation
		($mbxname, $suggested_filename) = &$alias;
	    } elsif ($alias ne '') {
		($mbxname, $suggested_filename) = ($alias, undef);
	  # } else {
	  #	($mbxname, $suggested_filename) = ($localpart, undef);
	    }
	    if ($mbxname eq '') {
		my($why) = !exists $local_delivery_aliases{$localpart} ? 1
			   : $alias eq '' ? 2 : 3;
		do_log(2, "skip local delivery($why): <$sender> -> <$recip>");
		$smtp_response = "250 2.6.0 Ok, skip local delivery($why)";
		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 '') {
		    $suggested_filename = $via_arg ne '' ? $via_arg : 'msg-%i-%n';
		    $suggested_filename =~ s/%b/$msginfo->body_digest/eg;
		    $suggested_filename =~ s/%i/strftime("%Y%m%d-%H%M%S",localtime)/eg;
		    $suggested_filename =~ s/%n/am_id()/eg;
		}
		# one mail per file, will create specified file
		$mbxname = "$mbxname/$suggested_filename";
	    }
	    do_log(1, "local delivery: <$sender> -> <$recip>, mbx=$mbxname");
	    my($pos,$pipe);
	    my($errn) = stat($mbxname) ? 0 : 0+$!;
	    local $SIG{CHLD} = 'DEFAULT';
	    local $SIG{PIPE} = 'IGNORE'; # write to broken pipe throws a signal
	    local(*MP);
	    eval {  # try to open the mailbox file for writing
		if (!$ux) {  # new file, traditional amavis, or maildir
		    if ($errn == ENOENT) {  # good, no file, as expected
		    } elsif (!$errn && -e _) {
			die "File $mbxname already exists, refuse to overwrite";
		    }
		    if (defined($gzip) && $mbxname =~ /\.gz$(?!\n)/) {
			open(MP,"|$gzip -c >$mbxname")         # uses shell!
			    or die "gzip failed: $!";
			$pipe = 1;
		    } else {
			open(MP,"> $mbxname\0") or die "Can't create $mbxname: $!";
		    }
		} else {     # append to UNIX-style mailbox
		    # deliver only to non-executable regular files
		    if ($errn == ENOENT) {
			open(MP,"> $mbxname\0") or die "Can't create $mbxname: $!";
		    } elsif (!$errn && !-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\0") or die "Can't append to $mbxname: $!";
		    }
		    binmode(MP,":bytes")
			or die "Can't cancel :utf8 mode: $!" if $unicode_aware;
		    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$eol",
			   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 '
		    my($blank_line) = 1;
		    while(<$msg>) {
			print MP '>' or die "Can't write to $mbxname: $!"
			   if $blank_line && /^From /;
			print MP $_ or die "Can't write to $mbxname: $!";
			$blank_line = $_ eq "\n";
		    }
		}
		# must append an empty line for a Unix mailbox format
		print MP $eol  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);
	$r->recip_mbxname($mbxname)  if defined $mbxname;
	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.15';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = qw(&mail_dispatch
	&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;
use POSIX qw(strftime);

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

# modify delivery method string if $relayhost_is_client and mail came in by TCP
sub dynamic_destination($$) {
    my($method,$conn) = @_;
    if ($relayhost_is_client && $method =~ /^smtp\b/i
	&& defined($conn) && $conn->client_ip ne '') {
	my($new_method) = sprintf("smtp:%s:%d",
				  $conn->client_ip, $conn->socket_port + 1);
	if ($new_method ne $method) {
	    do_log(3,"dynamic destination override: $method -> $new_method");
	    $method = $new_method;
	}
    }
    $method;
}

sub mail_dispatch($$$$;$) {
    my($via,$conn) = (shift,shift);
    if ($via =~ /^smtp\b/i) {
	mail_via_smtp(dynamic_destination($via,$conn), @_);
    } elsif ($via =~ /^pipe:/i) {
	mail_via_pipe($via,@_);
    } elsif ($via =~ /^bsmtp:/i) {
	mail_via_bsmtp($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(dynamic_destination($notify_method,$conn), @_);
	    } elsif ($notify_method =~ /^pipe:/i) {
		mail_via_pipe($notify_method,@_);
	    } elsif ($notify_method =~ /^bsmtp:/i) {
		mail_via_bsmtp($notify_method,@_);
	    }
	}
    };
}

#sub Net::Cmd::debug_print {
#    my($cmd,$out,$text) = @_;
#    do_log(0, "*** ".$cmd->debug_text($out,$text))  if $out;
#}

# trivial OO wrapper around Net::SMTP::datasend
sub new_smtp_data
    { my($class,$sh) = @_; bless \$sh, $class }
sub print {
    my($self) = shift;
    $$self->datasend(\@_)         # datasend may be given an array ref
	or die "datasend timed out while sending header\n";
}

# Send mail using SMTP - do multiple transactions if necessary
# (e.g. due to '452 Too many recipients')
#
sub mail_via_smtp(@) {
    my($via,$msginfo,$initial_submission,$filter) = @_;
    my($num_recips_undone) = scalar(
	grep {!$_->recip_done && (!$filter || &$filter($_))}
	     @{$msginfo->per_recip_data} );
    while ($num_recips_undone > 0) {
	mail_via_smtp_single(@_);  # send what we can in one transaction
	my($num_recips_undone_after) = scalar(
	    grep {!$_->recip_done && (!$filter || &$filter($_))}
		 @{$msginfo->per_recip_data} );
	if ($num_recips_undone_after >= $num_recips_undone) {
	    do_log(0, "Number of recipients ($num_recips_undone_after) ".
		      "not reduced in SMTP transaction, abandon the effort");
	    last;
	}
	if ($num_recips_undone_after > 0) {
	    do_log(0, sprintf("Sent to %s recipients via SMTP, %s still to go",
			      $num_recips_undone - $num_recips_undone_after,
			      $num_recips_undone_after));
	}
	$num_recips_undone = $num_recips_undone_after;
    }
    1;
}

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

    my($which_section) = 'fwd_init';
    my($taint) = substr($via,0,0);
    $via =~ /^smtp:([^:]*):([^:]*)(:.*)?$(?!\n)/si
	or die "Bad fwd method: $via";
    my($relayhost,$relayhost_port) = ($1.$taint, $2.$taint);
    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, nothing to do"); 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_msg, $received_cnt);
    my($any_valid_recips) = 0; my($any_tempfail_recips) = 0;
    my($any_valid_recips_and_data_sent) = 0; my($in_datasend_mode) = 0;
    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 {
	$which_section = 'fwd-connect';
	# 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, ExactAddresses => 1,
	    Timeout => max(60, min(5*60,$remaining_time)), # for each operation
	  # Debug => debug_oneshot(),
	  # LocalAddr => 10.11.12.13,   # (bind) source IP address
	  );
	defined($smtp_handle)
	    or die "Can't connect to $relayhost port $relayhost_port, $!";
	do_log(5, "Remote host claims to be ".$smtp_handle->domain);

	section_time($which_section);
	prolong_timer($which_section, $remaining_time);  # restart timer
	$remaining_time = undef;

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

	$which_section = 'fwd-rcpt-to';  my($skipping_resp);
	for my $r (@per_recip_data) { # send recipient addresses
	    if (defined $skipping_resp) {
		$r->recip_smtp_response($skipping_resp); $r->recip_done(2);
		next;
	    }
	    $smtp_handle->recipient(qquote_rfc2821_local($r->recip_final_addr));
	    $smtp_code = $smtp_handle->code;
	    $smtp_msg = $smtp_handle->message; chomp($smtp_msg);
	    my($smtp_resp) = "$smtp_code $smtp_msg";
	    if ($smtp_code =~ /^2/) {
		$any_valid_recips++;
	    } elsif ($smtp_code =~ /^0/) {
		# timeout, what to do, this is bad
		do_log(0, "response to RCPT TO not yet available, assuming it will be ok");
	    } else {  # not ok
		do_log(5, "response to RCPT TO: \"$smtp_resp\"");
		$r->recip_remote_mta($relayhost);
		$r->recip_remote_mta_smtp_response($smtp_resp);
		$smtp_resp =~ s/^552/452/;  # compatibility advised by rfc2821
		if ($smtp_resp =~ /^ (\d{3}) \s+ ([245] \. \d{1,3} \. \d{1,3})?
				     \s* (.*) $(?!\n)/xs) {
		    my($resp_code,$resp_enhcode,$resp_msg) = ($1,$2,$3);
		    if ($resp_enhcode eq '' && $resp_code =~ /^([245])/ ) {
			my($c) = $1;
			$resp_enhcode = ($resp_code eq '452') ? "$c.5.3"
					    : "$c.1.0";  # insert enhanced code
			$smtp_resp = "$smtp_code $resp_enhcode $smtp_msg";
		    }
		}
		if ($smtp_resp =~ /^452/) { # too many recipients - see rfc2821
		    do_log(0, sprintf('Only %d recips sent in one go: "%s"',
				      $any_valid_recips, $smtp_resp));
		    $skipping_resp = $smtp_resp;
		} elsif ($smtp_resp =~ /^4/) {
		    $any_tempfail_recips++;
		}
		$r->recip_smtp_response($smtp_resp); $r->recip_done(2);
	    }
	}
	section_time($which_section); prolong_timer($which_section);
	$smtp_code = $smtp_msg = undef;

	if ($any_valid_recips && !$any_tempfail_recips) {  # send the message
	    $which_section = 'fwd-data';
	    $smtp_handle->data or die "sending DATA command\n";
	    $in_datasend_mode = 1;

	    my($smtp_resp) = $smtp_handle->code . " " . $smtp_handle->message;
	    chomp($smtp_resp);
	    do_log(5, "response to DATA: \"$smtp_resp\"");

	    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.

# to reduce the likelyhood of a qmail bare-LF bug (bare LF reported
# when CR and LF are separated by a TCP packet boundary) one may use
# this 'while' line, instead of the normal one:
###		while (defined($_=$msg->getline)) {

		while ( $msg->read($_,16384) > 0 ) {
		    $smtp_handle->datasend($_)
			or die "datasend timed out while sending body\n";
		}

	    }
	    section_time($which_section); prolong_timer($which_section);

	    $which_section = 'fwd-data-end';
	    # don't check status of dataend here, it may not yet be available
	    $smtp_handle->dataend;
	    $in_datasend_mode = 0; $any_valid_recips_and_data_sent = 1;
	    section_time($which_section); prolong_timer($which_section);

	    $which_section = 'fwd-rundown-1';
	    # figure out the final SMTP response
	    $smtp_code = $smtp_handle->code;
	    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
	    # and only the last SMTP response code in $smtp_handle->code
	    my($smtp_msg) = $msgs[$#msgs]; chomp($smtp_msg); #take the last one
	    $smtp_response = "$smtp_code $smtp_msg";
	    do_log(5, "response to data end: \"$smtp_response\"");
	    for my $r (@per_recip_data) {
		next  if $r->recip_done;
		$r->recip_remote_mta($relayhost);
		$r->recip_remote_mta_smtp_response($smtp_response);
	    }
	    if ($smtp_code =~ /^[245]/) {
		my($smtp_status) = substr($smtp_code,0,1);
		$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) = $@; my($saved_section_name) = $which_section;
    if ($err ne '') { chomp($err); $err = ' ' if $err eq '' }  # careful chomp
    prolong_timer($which_section, $remaining_time); # restart the timer
    $which_section = 'fwd-rundown';
    if ($err ne '') {  # fetch info about failure
	do_log(3, "mail_via_smtp: session failed: $err");
	if (!defined($smtp_handle)) { $smtp_msg = '' }
	else {
	    $smtp_code = $smtp_handle->code;
	    $smtp_msg = $smtp_handle->message; chomp($smtp_msg);
	}
    }
    # terminate the SMTP session if still alive
    if (!defined $smtp_handle) {
	# nothing
    } elsif ($in_datasend_mode) {
	# We are aborting SMTP session.  DATA send mode must NOT be normally
	# terminated with a dataend (dot), otherwise recipient will receive
	# a chopped-off mail (and possibly be receiving it over and over again
	# during each MTA retry.
	do_log(0, "mail_via_smtp: NOTICE: aborting SMTP session, $err");
	$smtp_handle->close;  # abruptly terminate the SMTP session
    } else {
	$smtp_handle->timeout(15);  # don't wait too long for response
	$smtp_handle->quit;         # send a QUIT regardless of success so far
	if ($err eq '' && $smtp_handle->status != CMD_OK) {
	    do_log(0, "Warning: sending SMTP QUIT command failed: " .
		      $smtp_handle->code . " " . $smtp_handle->message);
	}
    }
    # prepare final smtp response and log abnormal events
    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);
	}
    } elsif ($err eq "timed out" || $err =~ /: Timeout$/) {
	my($msg) = ($in_datasend_mode && $smtp_code =~ /^354/) ? ''
			: ", $smtp_code $smtp_msg";
	$smtp_response = sprintf("450 4.4.2 Timed out during %s%s, id=%s",
				 $saved_section_name, $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_code =~ /^5/) {  # 5xx
	$smtp_response = sprintf("%s 5.5.0 Rejected by MTA: %s %s, id=%s",
			    ($smtp_code !~ /^5\d\d$(?!\n)/ ?"550" :$smtp_code),
			    $smtp_code, $smtp_msg, am_id());
    } elsif ($smtp_code =~ /^0/) {  # 000
	$smtp_response = sprintf("450 4.4.2 No response during %s (%s): id=%s",
				 $saved_section_name, $err, am_id());
    } else {
	$smtp_response =
	     sprintf("%s 4.5.0 from MTA during %s (%s): %s %s, id=%s",
		     ($smtp_code !~ /^4\d\d$(?!\n)/ ? "451" : $smtp_code),
		     $saved_section_name, $err, $smtp_code,$smtp_msg, am_id());
    }

    do_log(($smtp_response=~/^2/ ? 3 : 0), "mail_via_smtp: $smtp_response");
    if (!$any_valid_recips || $any_tempfail_recips) {
	do_log(3, "mail_via_smtp: DATA skipped, $any_valid_recips, ".
		  "$any_tempfail_recips, $any_valid_recips_and_data_sent");
    }
    if (defined $smtp_response) {
	for my $r (@per_recip_data) {
	    if (! $r->recip_done) {  # mark it as done
		$r->recip_smtp_response($smtp_response); $r->recip_done(2);
	    } elsif ($any_valid_recips_and_data_sent &&
		     $r->recip_smtp_response =~ /^452/) {  # 'undo' the RCPT TO
		# '452 Too many recipients' situation - needs to be handled
		# in more than one transaction
		$r->recip_smtp_response(undef); $r->recip_done(undef);
	    }
	}
    }
    section_time($which_section);
    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) = @_;
    my($taint) = substr($via,0,0);
    $via =~ /^pipe:(.*)$(?!\n)/si  or die "Bad fwd method: $via";
    my($pipe_args) = $1.$taint;
    $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, nothing to do"); 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) {
	# 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>
	# Although addresses passed as args to sendmail initial submission
	# should not be <...> bracketed, for some reason original sendmail
	# issues a warning on null reverse-path, but gladly accepty <>.
	# As this is not strictly wrong, we comply to make it happy.
	if (/^\${sender}$(?!\n)/i) {
	    push(@command, map { /^(.*)$(?!\n)/s; $1 }  # untaint
			   map { $_ eq '' ? '<>' : quote_rfc2821_local($_) }
			       $msginfo->sender);
	} elsif (/^\${recipient}$(?!\n)/i) {
	    push(@command, map { /^(.*)$(?!\n)/s; $1 }  # untaint
			   map { $_ eq '' ? '<>' : quote_rfc2821_local($_) }
			   map { $_->recip_final_addr } @per_recip_data);
	} else { push(@command, $_) }
    }
    do_log(5,"mail_via_pipe running command: ".join(' ',@command));
    local $SIG{CHLD} = 'DEFAULT';
    local $SIG{PIPE} = 'IGNORE';  # write to broken pipe throws a signal
    local(*MP); my($pid);
    eval { $pid = open(MP,'|-') };  # fork
    if ($@ ne '') { chomp($@); die "mail_via_pipe (open pipe): $@" }
    defined($pid) or die "mail_via_pipe: can't fork: $!";
    if (!$pid) {  # child
	exec {$command[0]} (@command);
	exec('/bin/false');  # must not exit, we have to avoid DESTROY handlers
	exit EX_TEMPFAIL;    # just in case
	# NOTREACHED
    }
    # parent
    binmode(MP,":bytes") or die "Can't cancel :utf8 $!"  if $unicode_aware;
    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 {
	my($err); close(MP) or $err=$!; 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, ".
			     "status=$status ($? $err)";
	}
    }
    $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;
}

sub mail_via_bsmtp(@) {
    my($via,$msginfo,$initial_submission,$filter) = @_;
    my($taint) = substr($via,0,0);
    $via =~ /^bsmtp:(.*)$(?!\n)/si or die "Bad fwd method: $via";
    my($bsmtp_file_final) = $1.$taint;
    $bsmtp_file_final =~ s/%b/$msginfo->body_digest/eg;
    $bsmtp_file_final =~ s/%i/strftime("%Y%m%d-%H%M%S",localtime)/eg;
    $bsmtp_file_final =~ s/%n/am_id()/eg;
    my($bsmtp_file_tmp) = $bsmtp_file_final . ".tmp";
    my(@per_recip_data) = grep {!$_->recip_done && (!$filter || &$filter($_))}
			       @{$msginfo->per_recip_data};
    my($logmsg) = sprintf("%s via BSMTP: <%s>",
	($initial_submission ? 'SEND' : 'FWD'), $msginfo->sender);
    if (!@per_recip_data) { do_log(5,"$logmsg, nothing to do"); return 1 }
    do_log(1, $logmsg . " -> " .
	join(",", map {"<".$_->recip_final_addr.">"} @per_recip_data) .
	", file " . $bsmtp_file_final);
    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: $!";
    }
    local(*MP);
    eval {
	open(MP,"> $bsmtp_file_tmp\0")
	    or die "Can't create BSMTP file $bsmtp_file_tmp: $!";
	binmode(MP,":bytes") or die "Can't set :bytes, $!"  if $unicode_aware;
	print MP ("EHLO ",$localhost_name,$eol) or die "print failed (EHLO): $!";
	printf MP ("MAIL FROM:%s BODY=8BITMIME$eol", # avoid conversion to 7bit
		   qquote_rfc2821_local($msginfo->sender))
	    or die "print failed (MAIL FROM): $!";
	for my $r (@per_recip_data) {
	    print MP ("RCPT TO:",qquote_rfc2821_local($r->recip_final_addr),$eol)
		or die "print failed (RCPT TO): $!";
	}
	print MP ("DATA",$eol) or die "print failed (DATA): $!";
	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
	    die "Too many hops: $received_cnt 'Received:' header lines";
	} elsif (!defined($msg)) {  # empty mail body
	} elsif ($msg->isa('MIME::Entity')) {
	    $msg->print_body(\*MP);
	} else {
	    while (<$msg>) {
		print MP "." or die "print failed-.data: $!"  if /^\./;
		print MP $_  or die "print failed-data: $!";
	    }
	}
	print MP (".",$eol) or die "print failed (final dot): $!";
      # print MP ("QUIT",$eol) or die "print failed (QUIT): $!";
	close(MP) or die "Can't close BSMTP file $bsmtp_file_tmp: $!";
	rename($bsmtp_file_tmp, $bsmtp_file_final)
	    or die "Can't rename BSMTP file to $bsmtp_file_final: $!";
    };
    my($err) = $@;  my($smtp_response);
    if ($err eq '') {
	$smtp_response = "250 2.6.0 Ok, queued as BSMTP $bsmtp_file_final";
    } else {
        chomp($err);
	unlink($bsmtp_file_tmp) or do_log(0,
		  "Can't delete half-finished BSMTP file $bsmtp_file_tmp: $!");
	close(MP);  # ignore status
	if ($err =~ /too many hops/i) {
	    $smtp_response = "550 5.4.6 Rejected: $err";
	} else {
	    $smtp_response = "451 4.5.0 Writing $bsmtp_file_tmp failed: $err";
	}
    }
    $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-bsmtp');
    1;
}

1;

#
package Amavis::UnmangleSender;
use strict;

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

BEGIN {
    import Amavis::Conf qw(:platform $viruses_that_fake_sender_re);
    import Amavis::Util qw(do_log);
    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);
    { local($1,$2,$3,$4);  # avoid Perl 5.8.0 bug, $1 gets tainted
      $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 (lc($from) eq lc($try)) { $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
	     ) $(?!\n)/xi
	) { # discard recipient's address used as a fake 'MAIL FROM:'
	    $best_try_originator = undef;
	} else {
	    my($taint) = substr($from,0,0);
	    $best_try_originator = $1.$taint  if $from =~ /^_(.+)$(?!\n)/s
						 && 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;
	}
    }
    $best_try_originator;
}

# 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]+$(?!\n)/) {
	    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:
	$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* ; [^;]*? $(?!\n)/xi) {
		    my($taint) = substr($received,0,0);
		    $first_received = $1.$taint;
	}
	$received =~ s/[ \t]+$(?!\n)//;	# trim trailing spaces
    }
    $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.15';
    @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}) {
	# do not change the text in die without adjusting decompose_part()
	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.15';
    @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/\/+$(?!\n)//;  # 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.15';
    @ISA = qw(Exporter);
    %EXPORT_TAGS = ();
    @EXPORT = ();
    @EXPORT_OK = qw(&init &mime_decode &decompose_part
		    &determine_file_types &check_for_banned_filenames
		    &check_header_validity);
}
use Errno qw(ENOENT);
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 prolong_timer sanitize_str min max
			   rmdir_flat rmdir_recursively run_command);
    import Amavis::Timing qw(section_time);
    import Amavis::Conf qw(:platform :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 following 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_-]*$(?!\n)}s) {
	    my($newpart) = "$tempdir/parts/" . getfilename();
	    local *PRE;
	    open(PRE, ">$newpart") or die "Can't create $pe_name $newpart: $!";
	    binmode(PRE,":bytes")
		or die "Can't cancel :utf8 mode: $!"  if $unicode_aware;
	    my($len);
	    for (@$pe_lines) {
		print PRE $_  or die "Can't write $pe_name to $newpart: $!";
		$len += length($_);
	    }
	    close(PRE) or die "Can't close $pe_name $newpart: $!";
	    consumed_bytes($len,'mime_decode_pre_epi');
	}
    }
}

# 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(0);
    $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: $!";
	local($1,$2,$3,$4);  # avoid Perl 5.8.0 bug, $1 gets tainted
	$entity = $parser->parse($fileh);
    } else {            # assume $fileh is a file name
	do_log(4,"Extracting mime components from $fileh");
	local($1,$2,$3,$4);  # avoid Perl 5.8.0 bug, $1 gets tainted
	$entity = $parser->parse_open("$tempdir/parts/$fileh");
    }
    my($err) = $parser->last_error;
    $err =~ s/\s+$(?!\n)//;  $err =~ s/[ \t\r]*\n+/; /g;  $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_header_validity($$) {
    my($conn, $msginfo) = @_;
    my(@bad); my($curr_head);
    for my $next_head (@{$msginfo->orig_header},"\n") {
	if ($next_head =~ /^[ \t]/) { $curr_head .= $next_head }  # folded
	else {  # new header
	    if (!defined($curr_head)) { # no previous complete header
	    } else {
		my($taint) = substr($curr_head,0,0);
		# obsolete rfc822 syntax allowed whitespace before colon
		my($field_name,$field_body) =
		    $curr_head =~ /^([!-9;-\176]+)[ \t]*:(.*)$(?!\n)/s
		    ? ($1.$taint, $2.$taint) : (undef,$curr_head);
		my($msg1,$msg2);
		if ($curr_head =~ /^(.*?)([\000\015])(.*)$(?!\n)/s) {
		    $msg1 = "Improper use of control character";
		} elsif ($curr_head =~ /^(.*?)([\200-\377])(.*)$(?!\n)/s) {
		    $msg1 = "Non-encoded 8-bit data";
		} elsif ($curr_head =~ /^(.*?)([^\000-\377])(.*)$(?!\n)/s) {
		    $msg1 = "Non-encoded Unicode character";
		}
		if (defined $msg1) {
		    my($pre,$ch,$post) = ($1.$taint, $2.$taint, $3.$taint);
		    if (length($post) > 20) {
			$post = substr($post,0,15) . "...";
		    }
		    if (length($pre)-length($field_name)-2 > 50-length($post)){
			$pre = "$field_name: ..." .
				substr($pre,length($pre)-(45-length($post)));
		    }
		    $msg1 .= sprintf(" (char %02X hex) in message header '%s'",
				     ord($ch), $field_name);
		    $msg2 = sanitize_str($pre);
		    my($msg2_pre_l) = length($msg2);
		    $msg2 .= sanitize_str($ch.$post);
		    push(@bad, "$msg1\n  $msg2\n  " . (' ' x $msg2_pre_l).'^');
		}
	    }
	    last if $next_head eq $eol;  # end-of-header reached
	    $curr_head = $next_head;
	}
    }
    @bad;
}

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) {
	    for my $ft ($file_generator_object->file_type($part),
			$file_generator_object->file_type_long($part) ) {
	        next  if $ft eq '';
		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) = @_;

    $file ne '' or die "Unix utility file(1) not available, but is needed";
    for my $part (@$partslist) {
	my($filename) = "$tempdir/parts/$part";
	my($filetype) = '';
	my($proc_fh) = run_command(undef, '/dev/null', $file, $filename);
	while( defined($_ = $proc_fh->getline) ) { $filetype .= $_ }
	my($err); $proc_fh->close or $err=$!; my($ret) = retcode($?);
	$ret==0 or die "'file' utility ($file) failed, status=$ret ($? $err)";

	chomp($filetype); my($taint) = substr($filetype,0,0);
	# remove file name
	$filetype = $1.$taint  if $filetype=~/^.+?: (.*)$(?!\n)/s;
	section_time('get-file-type');
	local($_) = $filetype;  my($ty);

	# try to classify some common types and give them short type name
	# _last_ match wins!

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

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

	/^ISO-8859.*\btext/i          and $ty = '.txt';
	/^Non-ISO.*ASCII\b.*\btext/i  and $ty = '.txt';
	/^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';
	/^RIFF.*\bAVI/                and $ty = '.avi';

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

	/^frozen/i                    and $ty = '.F';
	/^compress'd/i                and $ty = '.Z';
	/^gzip compressed/i           and $ty = '.gz';
	/^bzip2 compressed/i          and $ty = '.bz2';
	/^lzop compressed/i           and $ty = '.lzo';
	/^Zip archive/i               and $ty = '.zip';
	/^RAR archive/i               and $ty = '.rar';
	/^LHA.*archive/i              and $ty = '.lha';  # or .lzh
	/^ARC archive/i               and $ty = '.arc';
	/^ARJ archive/i               and $ty = '.arj';
	/^Zoo archive/i               and $ty = '.zoo';
	/^(?:GNU |POSIX )?tar archive\b/i and $ty = '.tar';
	/^(?:ASCII )?cpio archive\b/i and $ty = '.cpio';
	/^(Transport Neutral Encapsulation Format|TNEF)/i and $ty = '.tnef';
	/executable/i                 and $ty = '.exe';
	/script text executable/i     and $ty = '.txt';

	/^can't stat\b/               and $ty = '.empty'; # file(1) diagnostics
	/^empty$/i                    and $ty = '.empty';

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

# recursively descend into a directory $dir containing potentially unsafe
# files with unpredictable names, soft links, etc., rename each regular
# nonempty file to directory $outdir giving it a generated name,
# and discard all the rest, including the directory $dir.
# Return number of bytes that 'sanitized' files now occupy.
#
sub flatten_and_tidy_dir($$) {
    my($dir,$outdir) = @_;
    do_log(4,"flatten_and_tidy_dir: processing directory \"$dir\"");
    my($f); my($cnt_r,$cnt_u) = (0,0); my($consumed_bytes) = 0;
    local(*DIR);
    opendir(DIR, $dir) or die "Can't open directory $dir: $!";
    while (defined($f = readdir(DIR))) {
	my($msg);  my($errn) = lstat("$dir/$f") ? 0 : 0+$!;
	if ($errn == ENOENT) { $msg = "does not exist" }
	elsif ($errn)        { $msg = "inaccessible: $!" }
	elsif (!-r _)        { $msg = "not readable" }
	if (defined $msg) { die "flatten_and_tidy_dir: \"$dir/$f\" $msg" }
	next  if ($f eq '.' || $f eq '..') && -d _;
	$f = $1  if $f =~ /^(.+)$(?!\n)/s;   # untaint
	if (-d _) {
	    $consumed_bytes += flatten_and_tidy_dir("$dir/$f",$outdir);
	} elsif (-l _) {
	    $cnt_u++; unlink("$dir/$f") or die "Can't remove soft link \"$dir/$f\": $!";
	} elsif (!-f _) {
	    do_log(4,"flatten_and_tidy_dir: NONREGULAR FILE \"$dir/$f\"");
	    $cnt_u++; unlink("$dir/$f") or die "Can't remove nonregular file \"$dir/$f\": $!";
	} elsif (-z _) {
	    $cnt_u++; unlink("$dir/$f") or die "Can't remove \"$dir/$f\": $!";
	} else {
	    $consumed_bytes += -s _;
	    my($newpart) = $outdir . '/' . getfilename();
	    do_log(5,"flatten_and_tidy_dir: renaming \"$dir/$f\" to $newpart");
	    $cnt_r++;
	    rename("$dir/$f", $newpart)
		or die "Can't rename \"$dir/$f\" to $newpart: $!";
	}
    }
    closedir(DIR) or die "Can't close directory \"$dir\": $!";
    section_time("ren${cnt_r}-unl${cnt_u}-files");
    rmdir($dir) or die "Can't remove directory \"$dir\": $!";
    section_time('rmdir');
    $consumed_bytes;
}

# 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|uue|hqx)$/  && return do_ascii($part,$tempdir);
	/^\.F$/    && defined $unfreeze
	    && return do_uncompress($part,$tempdir,"$unfreeze -c");
	/^\.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
	/^\.lzo$/  && defined $lzop
	    && return do_uncompress($part,$tempdir,"$lzop -d -c");
	/^\.cpio$/ && defined $cpio && return do_cpio($part,$tempdir);
#	/^\.tar$/  && defined $cpio && return do_cpio($part,$tempdir);
	/^\.tar$/  && return do_tar($part,$tempdir);  # fallback
	/^\.zip$/  && return do_unzip($part,0,$tempdir);
	/^\.rar$/  && return do_unrar($part,0,$tempdir);
	/^\.(lha|lzh)$/ && 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/ ||
	    $@ =~ /^Maximum number of files.*exceeded/) { $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 atomic and stop unpacking
#  1 stuff was extracted, and continue unpacking
#  2 atomic and continue unpacking ; may be sfx, ascii etc.

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

    # prevent uunconc.c/UUDecode() from trying to create temp file in /
    $ENV{TMPDIR} = $TEMPBASE  if $ENV{TMPDIR} eq '';

    $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(4, 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(1, "do_ascii: Convert::UUlib info: $j not decodeable, " .
		      $uu->state);
	} else {
	    my($newpart) = "$tempdir/parts/" . getfilename();
	    $! = undef;
	    $sts = $uu->decode($newpart);  # decode to file $newpart
	    my($err_decode) = "$!";

	    my($statmsg);
	    my($errn) = stat($newpart) ? 0 : 0+$!;
	    if ($errn == ENOENT) { $statmsg = "does not exist" }
	    elsif ($errn)        { $statmsg = "inaccessible: $!" }
	    elsif (! -f _)	 { $statmsg = "not a regular file" }
	    if (defined $statmsg)
		{ $statmsg = ", stat on decoded: $newpart $statmsg" }

	    consumed_bytes(0+(-s _), 'do_ascii');
	    if ($sts==RET_OK && !defined($statmsg)) {
		$any_decoded++;
	    } elsif ($sts==RET_NODATA || $sts==RET_NOEND) {
		$any_errors++;
		do_log(0, "do_ascii: Convert::UUlib error: " .
			  Convert::UUlib::strerror($sts) . $statmsg);
	    } else {
		$any_errors++;
		my($errmsg) = Convert::UUlib::strerror($sts).":: $err_decode";
		$errmsg .= ", " . Convert::UUlib::strerror(
		     Convert::UUlib::GetOption(OPT_ERRNO))  if $sts==RET_IOERR;
		die ("Convert::UUlib failed: " . $errmsg . $statmsg);
	    }
	}
    }
    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_unzip 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: $!";
	    binmode(OUTPART) or die "Can't set $newpart to binmode: $!";
	    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, "do_unzip: $part, unsupported compr. method: $any_unsupp_compmeth") }
    if ($any_encrypted)
	{ do_log(4, "do_unzip: $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();
    my($rv) = run_command_copy($newpart,
			       run_command("$tempdir/parts/$part", undef,
					   split(' ',$decompressor) ));
    my($retcode) = retcode($rv);
    do_log(5, sprintf('do_uncompress(%s) status %d (signal %d)',
		      $decompressor, $rv>>8, $rv&255));
    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 "do_gunzip: Error opening $tempdir/parts/$part: $gzerrno";
    my($newpart) = "$tempdir/parts/" . getfilename();
    open(OUTPART, ">$newpart") or die "Can't create $newpart: $!";
    binmode(OUTPART) or die "Can't set $newpart to binmode: $!";
    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) {
	do_log(0,"do_gunzip: Error reading $tempdir/parts/$part: $gzerrno");
	unlink($newpart) or die "Can't unlink $newpart: $!";
	$gz->gzclose();
	return 0;
    }
    $gz->gzclose();
    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, $@");
	return 0;
    }
    local *OUTPART;
    do_log(4,"Untarring $part");
    my @list = $tar->list_files();
    for (@list) {
	next  if /\/$(?!\n)/;   # 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: $!";
	binmode(OUTPART) or die "Can't set $newpart to binmode: $!";
	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;
    my(@common_rar_switches) = qw(-c- -p- -av- -idp);
    my($err,$retval,$rv1);

    # unrar exit codes: SUCCESS=0, WARNING=1, FATAL_ERROR=2, CRC_ERROR=3,
    #  LOCK_ERROR=4, WRITE_ERROR=5, OPEN_ERROR=6, USER_ERROR=7, MEMORY_ERROR=8,
    #  CREATE_ERROR=9, USER_BREAK=255

    # Check whether we can really unrar it
    $rv1 = system($unrar, 't', '-inul', @common_rar_switches, '--',
		  "$tempdir/parts/$part");
    $err = $!; $retval = retcode($rv1);
    if ($retval == 7) {  # USER_ERROR
	do_log(0, "do_unrar: $unrar does not recognize all switches, ".
		  "it is probably too old. Retrying without '-av- -idp'. ".
		  "Upgrade: http://www.rarlab.com/");
	@common_rar_switches = qw(-c- -p-);  # retry without new switches
	$rv1 = system($unrar, 't', '-inul', @common_rar_switches, '--',
		      "$tempdir/parts/$part");
	$err = $!; $retval = retcode($rv1);
    }
    if (!grep {$_==$retval} (0,1,3)) {
	# not one of: SUCCESS, WARNING, CRC_ERROR
	# NOTE: password protected files in the archive cause CRC_ERROR
	do_log(4, sprintf("unrar 't' returned status %d (signal %d, %s), command: %s",
		      $retval, $rv1&255, $err, $unrar));
	return 0;
    }

    # We have to jump hoops because there is no simple way to
    # just list all the files
    do_log(4,"Expanding RAR archive $part");

    my(@list); my($hypcount) = 0; my($encryptedcount) = 0; my($lcnt) = 0;
    my($member_name); my($bytes) = 0;

    my($proc_fh) = run_command(undef,undef, $unrar,
		      'v', @common_rar_switches, '--', "$tempdir/parts/$part");
    while( defined($_ = $proc_fh->getline) ) {
	chomp;
	if (/^unexpected end of archive/) {
	    last;
	} elsif (/^------/) {
	    $hypcount++;
	    last if $hypcount >= 2;
	} elsif ($hypcount == 1) {
	    $lcnt++;
	    if ($lcnt % 2 == 0) {  # information line (every other line)
		if (!/^\s+(\d+)\s+(\d+)\s+\d+%/) {
		    do_log(0, "do_unrar: can't parse info line for \"$member_name\": $_");
		} elsif (defined $member_name) {
		    do_log(5, "do_unrar: member: \"$member_name\", size: $1");
		    if ($1 > 0) { $bytes += $1; push(@list,$member_name) }
		}
		$member_name = undef;
	    } elsif (/^\*/) {
		# discard password-protected files - makes no sense extracting
		$encryptedcount++;  $member_name = undef;
	    } else {
		s/^.//s;  # discard first character (space or an asterisk)
		$member_name = $_;
	    }
	}
    }
    # consume all remaining output to avoid broken pipe
    while( defined($proc_fh->getline) ) {}
    $err=undef; $proc_fh->close or $err=$!; $retval = retcode($?);

    my($rem_quota_saved) = $rem_quota;
    consumed_bytes($bytes,'do_unrar-pre'); # pre-check on estimated size
    $rem_quota = $rem_quota_saved;     # if it survives, do it for real later

    if (!grep {$_==$retval} (0,1)) {   # not one of: SUCCESS, WARNING
	die "unrar: can't get a list of archive members: status=$retval ($? $err)";
    }
    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,
      #			   qw(p -inul -kb), @common_rar_switches, '--',
      #			   "$tempdir/parts/$part");
	my($proc_fh) = run_command(undef, '/dev/null', $unrar,
			  qw(x -inul -ver -o- -kb), @common_rar_switches, '--',
			  "$tempdir/parts/$part", "$tempdir/parts/rar/");
	my($output) = '';
	while( defined($_ = $proc_fh->getline) ) { $output .= $_ }
	my($err); $proc_fh->close or $err=$!; my($retval) = retcode($?);
	if (!grep {$_==$retval} (0,1,3)) {  # not one of: SUCCESS, WARNING, CRC
	    do_log(0, "unrar returned status $retval ($? $err)")  if $retval;
	}
	my($errn) = stat("$tempdir/parts/rar") ? 0 : 0+$!;
	if ($errn != ENOENT) {
	    my($b)=flatten_and_tidy_dir("$tempdir/parts/rar","$tempdir/parts");
	    consumed_bytes($b,'do_unrar');
	}
    }
    $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,"&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, $lha, 'lq', "$tempdir/parts/$part");
    while( defined($_ = $proc_fh->getline) ) {
	chomp;
	next  if /\/$(?!\n)/;  # ignore directories
	push(@list, (split(/\s+/))[-1] );  #***??? split on whitespace ???
    }
    $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($proc_fh) = run_command(undef, '/dev/null', $arc, split(' ',$cmdargs));
    my(@list) = $proc_fh->getlines;
    my($err); $proc_fh->close or $err=$!; my($retval) = retcode($?);
    $retval==0 or do_log(0, "do_arc: status=$retval ($? $err)");

#*** no spaces in filenames allowed???
    map { s/^([^ \t\r\n]*).*$(?!\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($proc_fh) = run_command(undef, undef,
			       $zoo, 'lf1q', "$tempdir/parts/$part.zoo");
    my(@list) = $proc_fh->getlines;
    my($err); $proc_fh->close or $err=$!; my($retval) = retcode($?);
    $retval==0 or do_log(0, "do_zoo: status=$retval ($? $err)");

    if (@list) {
	chomp(@list);
	my $rv = store_mgr($tempdir, \@list, $zoo, 'xpqqq:',
			   "$tempdir/parts/$part.zoo");
	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");

    $ENV{ARJ_SW}='-i -jo -b5 -2h -jyc -ja1'; # options to arj, ignored by unarj

    # 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/parts/arj", 0750) or die "Can't mkdir $tempdir/parts/arj: $!";
    chdir("$tempdir/parts/arj") or die "Can't chdir to $tempdir/parts/arj: $!";
    # avoiding shell: don't call system("... >/dev/null")
    my($proc_fh) = run_command(undef, '/dev/null',
			       $unarj, 'e', "$tempdir/parts/$part");
    my($output) = '';
    while( defined($_ = $proc_fh->getline) ) { $output .= $_ }
    my($err); $proc_fh->close or $err=$!; my($retval) = retcode($?);
    # nonzero exit status does not mean no files were extracted!
    # (example: status 1 may indicate one of members has a bad CRC)
    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";

    my($errn) = stat("$tempdir/parts/arj") ? 0 : 0+$!;
    if ($errn != ENOENT) {
	my($bytes) = flatten_and_tidy_dir("$tempdir/parts/arj", "$tempdir/parts");
	consumed_bytes($bytes, 'do_unarj');
    }
    unlink("$tempdir/parts/$part.arj")
	or die "Can't unlink $tempdir/parts/$part.arj: $!";
    die "unarj returned status $retval ($err)"  if $retval;
    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: $!";
	    binmode(OUTPART) or die "Can't set $newpart to binmode: $!";
	    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;
}

# cpio supports the following archive formats: binary, old ASCII,
#   new ASCII, crc, HPUX binary, HPUX old ASCII, old tar, and POSIX.1 tar
sub do_cpio($$) {
    my($part,$tempdir) = @_;
    return 0  if !$cpio;
    do_log(4,"Expanding cpio archive $part");  my($bytes) = 0;
    my($proc_fh) = run_command("$tempdir/parts/$part", undef,
				$cpio, qw(-t -n -v --quiet) );
    while( defined($_ = $proc_fh->getline) ) {
	chomp;
	if (!/^(?:\S+\s+){4}(\d+)\s+((?:\S+\s+){2}\S+)\s+(.*)$/) {
	    do_log(0, "do_cpio: can't parse toc line: $_");
	} else {
	    do_log(5, "do_cpio: member: \"$3\", size: $1");
	    $bytes += $1  if $1>0;
	}
    }
    # consume remaining output to avoid broken pipe
    while( defined($proc_fh->getline) ) {}
    my($err); $proc_fh->close or $err=$!; my($retval) = retcode($?);

    my($rem_quota_saved) = $rem_quota;
    consumed_bytes($bytes,'do_cpio-pre'); # pre-check on estimated size
    $rem_quota = $rem_quota_saved;      # if it survives, do it for real

    mkdir("$tempdir/parts/cpio", 0750) or die "Can't mkdir $tempdir/parts/cpio: $!";
    chdir("$tempdir/parts/cpio") or die "Can't chdir to $tempdir/parts/cpio: $!";
    my($proc_fh) = run_command("$tempdir/parts/$part", '/dev/null', $cpio,
		   qw(-i --no-absolute-filenames --no-preserve-owner --quiet));
    my($output) = '';
    while( defined($_ = $proc_fh->getline) ) { $output .= $_ }
    $err=undef; $proc_fh->close or $err=$!; $retval = retcode($?);
    do_log(0, "cpio returned status $retval ($? $err) $output")  if $retval;
    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
    my($b)=flatten_and_tidy_dir("$tempdir/parts/cpio","$tempdir/parts");
    consumed_bytes($b,'do_cpio');
    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;
}

# my($k,$v,$fn);
# while (($k,$v) = each(%::)) {
#   local(*e)=$v; $fn=fileno(\*e);
#   printf STDERR ("%-10s %-10s %s$eol",$k,$v,$fn)  if defined $fn;
# }

# Given a file handle (typically opened to a piped subprocess, as returned
# from run_command), copy from it to a specified output file in binary mode.
sub run_command_copy($$) {
    my($outfile,$ifh) = @_;
    my($ofh) = IO::File->new;
    $ofh->open($outfile,'w') or die "Can't create file $outfile: $!";
    binmode($ofh) or die "Can't set file $outfile to binmode: $!";
    binmode($ifh) or die "Can't set binmode on pipe: $!";
    my($len, $buf, $offset, $written);
    while ($len = $ifh->sysread($buf,16384)) {
	$offset = 0;
	while ($len > 0) {  # handle partial writes
	    $written = syswrite($ofh, $buf, $len, $offset);
	    defined($written) or die "syswrite to $outfile failed: $!";
	    consumed_bytes($written, "run_command_copy");
	    $len -= $written; $offset += $written;
	}
    }
    $ifh->close; my($rv) = $?;
    $ofh->close or die "Can't close $outfile: $!";
    $rv;  # return subprocess termination status
}

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

    local *FH;
    my(@rv);
    for my $f (@$list) {
	next  if $f =~ /\/$(?!\n)/;  # ignore directories
	if ($f =~ m{^(\.?[A-Za-z0-9_][A-Za-z0-9/._=~-]*)$(?!\n)} ) {
	    $f = $1;  # untaint apparently safe arguments
	} else {      # this is not too bad, as run_command does not use shell
	    do_log(1, "store_mgr: NOTICE: untainting funny argument \"$f\"");
	    $f = $1   if $f =~ /^(.*)$(?!\n)/s;  # untaint
	}
	my($newpart) = "$tempdir/parts/" . getfilename();
	do_log(5, sprintf('store_mgr: extracting "%s" to file %s using %s',
			  $f, $newpart, $cmd));
	my $rv = run_command_copy($newpart,
				  run_command(undef, undef, $cmd, @args, $f));
	do_log(5, sprintf('store_mgr: extracted by %s, status %d (signal %d)',
			  $cmd, $rv>>8, $rv&255));
	push(@rv,$rv);
    }
    @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.15';
    @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 safe_encode);
    import Amavis::Timing qw(section_time);
    import Amavis::Conf qw(:platform :notifyconf $myhostname $forward_method
	$hdr_encoding $bdy_encoding);
    import Amavis::Lookup qw(lookup);
    import Amavis::Expand qw(expand);
    import Amavis::rfc2821_2822_Tools;
}
# use Encode;  # Perl 5.8  UTF-8 support
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);
    my($taint) = substr($$mail_as_string_ref,0,0);
    ($m_hdr,$m_body) = ($1.$taint, $3.$taint)
	if $$mail_as_string_ref =~ /^(.*?\r?\n)(\r?\n|$(?!\n))(.*)$(?!\n)/s;
    $m_body = safe_encode($bdy_encoding, $m_body);
    # make sure _our_ source line number is reported in case of failure
    eval {$entity = MIME::Entity->build(
	Type => 'text/plain', Encoding => '-SUGGEST', Charset => $bdy_encoding,
	(defined $notify_xmailer_header && $notify_xmailer_header eq ''
	    ? ()  # leave the MIME::Entity default
	    : ('X-Mailer' => $notify_xmailer_header) ), # X-Mailer hdr or undef
	Data => $m_body); 1}  or do {chomp($@); die $@};
    my($head) = $entity->head;
    # insert header fields from template into MIME::Head entity
    $m_hdr =~ s/\r?\n([ \t])/$1/g;  # unfold template header
    for my $hdr_line (split(/\r?\n/,$m_hdr)) {
	if ($hdr_line =~ /^([^:]*):\s*(.*)$(?!\n)/s) {
	    my($fhead,$fbody) = ($1.$taint, $2.$taint);
	    # encode according to RFC 2047 if necessary
	    if ($fhead =~ /^(X-.*|Subject|Comments)$(?!\n)/si &&
		$fbody =~ /[^\011\012\040-\176]/ # nonprint. except TAB and LF?
	    ) { # encode according to RFC 2047
		my($fbody_octets) = $fbody;  # non- UTF-8 -aware
		if ($unicode_aware && Encode::is_utf8($fbody)) {
		    $fbody_octets = safe_encode($hdr_encoding, $fbody);
		    do_log(5,"string_to_mime_entity UTF-8 body:  $fbody");
		    do_log(5,"string_to_mime_entity body octets: $fbody_octets");
		}
		$fbody = MIME::Words::encode_mimeword($fbody_octets,
						      'Q', $hdr_encoding);
	    } else {  # supposed to be in plain ASCII, let's make sure it is
		$fbody = safe_encode('ascii', $fbody);
	    }
	    $fhead = safe_encode('ascii', $fhead);
	    do_log(5, sprintf("string_to_mime_entity %s: %s", $fhead,$fbody));
	    # 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 eq '') { # must not respond to null reverse path
	do_log(4, "Not sending DSN to empty return path");
    } 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) {
		if ($forward_method eq '') {  # e.g. milter
		    # as far as we are concerned all is ok, delivery by MTA-in
		    $smtp_resp = "250 2.5.0 Ok, continue delivery";
		} else {
		    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* (.*) $(?!\n)/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";
	    my($rem_smtp_resp) = $r->recip_remote_mta_smtp_response;
	    if ($remote_mta eq '' || $rem_smtp_resp eq '') {
		$msg .= "Diagnostic-Code: smtp; $smtp_resp\n";
	    } else {
		$msg .= "Remote-MTA: dns; $remote_mta\n";
		$msg .= "Diagnostic-Code: smtp; $rem_smtp_resp\n";
	    }
	    $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);

	# use the provided template text
	my(%mybuiltins) = %$builtins_ref;  # make a local copy
        $mybuiltins{'f'} = $hdrfrom_notify_sender; $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;

# 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.
	eval {$head->replace('From',$hdrfrom_notify_sender); 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($mailfrom_notify_sender);  # should be empty!
	$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 == D_PASS
	    && ($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 Errno qw(ENOENT);
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;

BEGIN {
    import Amavis::Conf qw(:platform :confvars :notifyconf :sa);
    import Amavis::Util qw(do_log debug_oneshot am_id prolong_timer
			   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
				check_header_validity);
    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);
@ISA = qw(Net::Server::PreForkSimple);

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

use vars qw($extra_code_sql $extra_code_ldap
	    $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($user_id_sql
	    $virus_lovers_sql $spam_lovers_sql
	    $banned_files_lovers_sql $bad_header_lovers_sql
	    $bypass_virus_checks_sql $bypass_spam_checks_sql
	    $bypass_banned_checks_sql $bypass_header_checks_sql
	    $spam_tag_level_sql $spam_tag2_level_sql $spam_kill_level_sql
	    $spam_modifies_subj_sql $local_domains_sql $wb_listed_sql
	    $spam_quarantine_to_sql);

use vars qw($default_ldap $user_id_ldap
	    $virus_lovers_ldap $spam_lovers_ldap
	    $banned_files_lovers_ldap $bad_header_lovers_ldap
	    $bypass_virus_checks_ldap $bypass_spam_checks_ldap
	    $bypass_banned_checks_ldap $bypass_header_checks_ldap
	    $spam_tag_level_ldap $spam_tag2_level_ldap $spam_kill_level_ldap
	    $spam_modifies_subj_ldap $local_domains_ldap $wb_listed_ldap
	    $spam_quarantine_to_ldap);

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 @detecting_scanners
	    @banned_filename @bad_headers);

use vars qw($amcl_in_obj $smtp_in_obj); # Amavis::In::AMCL and In::SMTP objects
use vars qw($sql_policy $sql_wblist);   # Amavis::Lookup::SQL 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 {
    local $SIG{CHLD} = 'DEFAULT';
    # this needs to be done only after chroot, otherwise paths will be wrong
    find_external_programs( [split(/:/, $path, -1)] );
    # do some sanity checking
    my($name) = $TEMPBASE;
    $name = "$daemon_chroot_dir $name"  if $daemon_chroot_dir ne '';
    my($errn) = stat($TEMPBASE) ? 0 : 0+$!;
    if ($errn == ENOENT) { die "No TEMPBASE directory: $name" }
    elsif ($errn)        { die "TEMPBASE directory inaccessible, $!: $name" }
    elsif (! -d _)       { die "TEMPBASE is not a directory: $name" }
    elsif (! -w _)       { die "TEMPBASE is not writeable: $name" }
    if ($QUARANTINEDIR ne '') {
	my($name) = $QUARANTINEDIR;
	$name = "$daemon_chroot_dir $name"  if $daemon_chroot_dir ne '';
	my($errn) = stat($QUARANTINEDIR) ? 0 : 0+$!;
	if ($errn == ENOENT)  { }  # ok
	elsif ($errn)         { die "QUARANTINEDIR inaccessible, $!: $name" }
	elsif (-d _ && !-w _) { die "QUARANTINEDIR directory not writeable: $name" }
    }
    Amavis::SpamControl::init()  if $extra_code_antispam;
}

### 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};
    local $SIG{CHLD} = 'DEFAULT';
    chomp($msg);  do_log(1, "Net::Server: ".$msg);  # just call Amavis' traditional logging
    1;
}

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

### user customizable Net::Server hook
sub post_accept_hook {
    my($self) = shift;
    local $SIG{CHLD} = 'DEFAULT';
    $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};
    local $SIG{CHLD} = 'DEFAULT';

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

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

    # Net::Server assigns STDIN and STDOUT to the socket
    if ($unicode_aware) {
	binmode(STDIN, ":bytes") or die "Can't cancel :utf8 mode on STDIN: $!";
	binmode(STDOUT,":bytes") or die "Can't cancel :utf8 mode on STDOUT: $!";
	binmode($sock, ":bytes") or die "Can't cancel :utf8 mode on socket: $!";
    }
    $| = 1;
    local $SIG{ALRM} = sub { die "timed out\n" }; # do not modify the sig text!
    eval {
	prolong_timer('new request - timer reset', $child_timeout); #timer init
	if ($extra_code_sql && @lookup_sql_dsn && $child_invocation_count==1) {
	    $sql_policy = $sql_wblist = undef;
	    my($sql_dbh)= Amavis::Lookup::SQL::connect_to_sql(@lookup_sql_dsn);
	    section_time('sql-connect');
	    if (!defined($sql_dbh)) {
	      # do_log(0, "SQL lookups disabled");
		die "SQL server(s) not reachable, ABORTING";
	    } else {
		$sql_dbh->{'RaiseError'} = 1;
		$sql_policy = Amavis::Lookup::SQL->new(
				$sql_dbh, $sql_select_policy);
		$sql_wblist = Amavis::Lookup::SQL->new(
				$sql_dbh, $sql_select_white_black_list
			      )  if defined $sql_select_white_black_list;
		# make lookup objects with incorporated field names
		# fieldtype: B=boolean, N=numeric, S=string,
		#            B-, N-, S-   returns undef if field does not exist
		#            B0: boolean, nonexistent field treated as false,
		#            B1: boolean, nonexistent field treated as true
		my $nf = sub {Amavis::Lookup::SQLfield->new($sql_policy,@_)}; #shorthand
		$user_id_sql		= $nf->('id',                  'N');
		$virus_lovers_sql       = $nf->('virus_lover',         'B0');
		$spam_lovers_sql        = $nf->('spam_lover',          'B-');
		$banned_files_lovers_sql= $nf->('banned_files_lover',  'B-');
		$bad_header_lovers_sql  = $nf->('bad_header_lover',    'B-');
		$bypass_virus_checks_sql= $nf->('bypass_virus_checks', 'B0');
		$bypass_spam_checks_sql = $nf->('bypass_spam_checks',  'B0');
		$bypass_banned_checks_sql=$nf->('bypass_banned_checks','B-');
		$bypass_header_checks_sql=$nf->('bypass_header_checks','B-');
		$spam_tag_level_sql     = $nf->('spam_tag_level',      'N' );
	        $spam_tag2_level_sql    = $nf->('spam_tag2_level',     'N' );
		$spam_kill_level_sql    = $nf->('spam_kill_level',     'N' );
		$spam_modifies_subj_sql = $nf->('spam_modifies_subj',  'B-');
		$spam_quarantine_to_sql = $nf->('spam_quarantine_to',  'S-');
		$local_domains_sql      = $nf->('local',               'B1');
		section_time('sql-prepare');
	    }
	    undef @lookup_sql_dsn;   # destroy sensitive information
	}
	if ($extra_code_ldap && $child_invocation_count==1) {
	    # $ldap_wblist : TODO
	    my $lf = sub {
		Amavis::Lookup::LDAP->new($default_ldap, @_) if $_[0]
	    }; #shorthand
	    $virus_lovers_ldap        = $lf->($virus_lovers_ldap);
	    $spam_lovers_ldap         = $lf->($spam_lovers_ldap);
	    $banned_files_lovers_ldap = $lf->($banned_files_lovers_ldap);
	    $bad_header_lovers_ldap   = $lf->($bad_header_lovers_ldap);
	    $bypass_virus_checks_ldap = $lf->($bypass_virus_checks_ldap);
	    $bypass_spam_checks_ldap  = $lf->($bypass_spam_checks_ldap);
	    $bypass_banned_checks_ldap= $lf->($bypass_banned_checks_ldap);
	    $bypass_header_checks_ldap= $lf->($bypass_header_checks_ldap);
	    $spam_tag_level_ldap      = $lf->($spam_tag_level_ldap);
	    $spam_tag2_level_ldap     = $lf->($spam_tag2_level_ldap);
	    $spam_kill_level_ldap     = $lf->($spam_kill_level_ldap);
	    $spam_modifies_subj_ldap  = $lf->($spam_modifies_subj_ldap);
	    $spam_quarantine_to_ldap  = $lf->($spam_quarantine_to_ldap);
	    $local_domains_ldap       = $lf->($local_domains_ldap);
	}

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

	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});
	    if (!$extra_code_in_smtp) {
		die ("incomming TCP connection, but dynamic code ".
		     "to handle SMTP or LMTP not loaded");
	    } else {
		my($lmtp);  # false by default, start as a SMTP server
#		$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(1,"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 {
    local $SIG{CHLD} = 'DEFAULT';
    debug_oneshot(0);
    $0 = 'amavisd (child)';
}

### Child is about to be terminated
### user customizable Net::Server hook
sub child_finish_hook {
    my($self) = shift;
    local $SIG{CHLD} = 'DEFAULT';
#   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 = (); @detecting_scanners = ();
    @banned_filename = (); @bad_headers = ();
    $spam_level = undef; $spam_status = undef; $spam_report = undef;

    # comment out to retain SQL cache entries for the whole child lifetime:
    $sql_policy->clear_cache  if defined $sql_policy;
    $sql_wblist->clear_cache  if defined $sql_wblist;

    $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);
    my($banned_filename_checked);
    my($virus_presence_checked,$spam_presence_checked);

    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 (defined($body_digest) && exists($scan_cache{$body_digest})) {
	    $which_section = "cached";
	    my($bs) = $scan_cache{$body_digest};
	    $banned_filename_checked = defined $bs->{'FB'} ? 1 : 0;
	    $virus_presence_checked  = defined $bs->{'VN'} ? 1 : 0;
	    $spam_presence_checked   = defined $bs->{'SL'} ? 1 : 0;
	    do_log(1, sprintf("cached %s from <%s> (%s,%s,%s)", $body_digest,
			      $msginfo->sender, $banned_filename_checked,
			      $virus_presence_checked,$spam_presence_checked));
	    @banned_filename  = !ref($bs->{'FB'}) ? () : @{$bs->{'FB'}}; # copy
	    @virusname        = !ref($bs->{'VN'}) ? () : @{$bs->{'VN'}}; # copy
	    @detecting_scanners=!ref($bs->{'VD'}) ? () : @{$bs->{'VD'}}; # copy
	    $av_output   = $bs->{'VO'}; $spam_level  = $bs->{'SL'};
	    $spam_status = $bs->{'SS'}; $spam_report = $bs->{'SR'};
	}

	if (grep {!lookup($_,
			$bypass_header_checks_sql, $bypass_header_checks_ldap,
			\%bypass_header_checks, \@bypass_header_checks_acl,
			$bypass_header_checks_re)} @recips) {
	    @bad_headers = check_header_validity($conn, $msginfo);
	}

	if ($banned_filename_checked) {
	    do_log(5, "banned_filename_presence cached, skipping check");
	} elsif (!$banned_filename_re) {
	    do_log(5, "banned_filename_presence skipped, no tests");
	} elsif (!grep {!lookup($_,
			  $bypass_banned_checks_sql,$bypass_banned_checks_ldap,
			  \%bypass_banned_checks, \@bypass_banned_checks_acl,
			  $bypass_banned_checks_re)} @recips) {
	    do_log(5, "bypassing of banned_filename_presence requested");
	} else {
	    # check for banned mime file name or banned mime-type
	    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;
	    $banned_filename_checked = 1;
	}

	if ($virus_presence_checked) {
	    do_log(5, "virus_presence cached, skipping virus_scan");
	} else {
	    my($will_do_virus_scanning) =   # virus scanning will be needed?
		$extra_code_antivirus &&
		grep {!lookup($_, $bypass_virus_checks_sql,
		    		  $bypass_virus_checks_ldap,
				  \%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} ) {
		    $which_section = "decoding1";
		    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 ? () : "...")) ));

		    $which_section = "decoding2-get-file-types";
		    determine_file_types(\@parts, $tempdir,
					 $file_generator_object);
		    if (!$banned_filename_re) {
		    } elsif (!grep {!lookup($_,
			  $bypass_banned_checks_sql,$bypass_banned_checks_ldap,
			  \%bypass_banned_checks, \@bypass_banned_checks_acl,
			  $bypass_banned_checks_re)} @recips) {
		    } else {
			$which_section = "decoding3-check-banned";
			# 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;
		    }
		    $which_section = "decoding4";
		    for my $part (@parts) {
			my($errn) = stat("$tempdir/parts/$part") ? 0 : 0+$!;
			if ($errn == ENOENT) {
			    do_log(0, "decode_parts: NOTICE: new name requested, but file not created: $part");
			} else {
			    $which_section = "decoding-decompose-parts";
			    $hold = decompose_part($part, $tempdir,
						   $file_generator_object);
			    $which_section = "decoding5";
			    last TIER  if defined $hold;
			}
		    }
		    $depth++;
		}
		section_time('parts'); prolong_timer('decoding');
	    }

	    # 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($vn,$ds);  ($av_ret,$av_output,$vn,$ds) =
			Amavis::AV::virus_scan($tempdir, $child_task_count==1);
		    @virusname = @$vn; @detecting_scanners = @$ds;  # copy
		};
		prolong_timer($which_section, $remaining_time); # restart 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 (defined $body_digest) {  # save results to cache
		    $scan_cache{$body_digest}{'VO'} = $av_output;
		    $scan_cache{$body_digest}{'VN'} = [@virusname];  # copy!
		    $scan_cache{$body_digest}{'VD'} = [@detecting_scanners];
		}
		$virus_presence_checked = 1;
	    }
	}

	# consider doing spam scanning
	my($any_wbl, $all_wbl);
	($any_wbl,$all_wbl) = Amavis::SpamControl::white_black_list(
	    $conn,$msginfo,$sql_wblist,$user_id_sql)  if $extra_code_antispam;
	if ($spam_presence_checked) {
	    do_log(5, "spam_presence cached, skipping spam_scan");
	} elsif (!$extra_code_antispam) {
	    do_log(5, "No anti-spam code loaded, skipping spam_scan");
	} elsif (@virusname || @banned_filename) {
	    do_log(5, "infected or banned contents, skipping spam_scan");
	} elsif ($all_wbl) {
	    do_log(5, "sender white/blacklisted, skipping spam_scan");
	} elsif (!grep {!lookup($_,
			  $bypass_spam_checks_sql, $bypass_spam_checks_ldap,
			  \%bypass_spam_checks, \@bypass_spam_checks_acl,
			  $bypass_spam_checks_re)} @recips) {
	    do_log(5, "bypassing of spam checks requested");
	} else {
	    $which_section = "spam_scan";
	    ($spam_level, $spam_status, $spam_report) =
		Amavis::SpamControl::spam_scan($conn,$msginfo);
	    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;
	    }
	    $spam_presence_checked = 1;
	}
	$msginfo->sender_contact($msginfo->sender); # store the original addr
	$msginfo->sender_source($msginfo->sender);  # store the original addr

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

	my($considered_spam_by_some_recips);

	if (@virusname || @banned_filename) {  # virus or banned filename found
	    $which_section = "deal_with_virus_or_banned";
	    my($final_destiny) = @virusname ? $final_virus_destiny
			 : @banned_filename ? $final_banned_destiny : D_PASS;
	    for my $r (@{$msginfo->per_recip_data}) {
		next  if $r->recip_done;  # already dealt with
		if ($final_destiny == D_PASS) {
		    # recipient wants this message, malicious or not
		} elsif ((!@virusname ||            # not a virus or we want it
			  lookup($r->recip_addr,
				 $virus_lovers_sql, $virus_lovers_ldap,
				 \%virus_lovers, \@virus_lovers_acl,
				 $virus_lovers_re))
			 &&
			 (!@banned_filename ||      # not banned or we want it
			  lookup($r->recip_addr,
				 $banned_files_lovers_sql, $banned_files_lovers_ldap,
				 \%banned_files_lovers, \@banned_files_lovers_acl,
				 $banned_files_lovers_re)) ) {
		    # clean, or recipient wants it
		} else {   # change mail destiny for those not wanting malware
		    $r->recip_destiny($final_destiny);
		    my($reason);
		    if (@virusname)
			{ $reason = "VIRUS: "  . join(", ", @virusname) }
		    elsif (@banned_filename)
			{ $reason = "BANNED: " . join(", ", @banned_filename) }
		    $r->recip_smtp_response( ($final_destiny == D_DISCARD
				? "250 2.7.1 Ok, discarded"
				: "550 5.7.1 Message content rejected")
			. ", id=$am_id - $reason");
		    $r->recip_done(1);
		}
		# add address extensions if enabled and passing the message
		my($ext) = @virusname ? $addr_extension_virus
			   : @banned_filename ? $addr_extension_banned : '';
		if ($recipient_delimiter ne '' && $ext ne '' &&
		    $r->recip_destiny == D_PASS &&
		    lookup($r->recip_addr, $local_domains_sql,
			   $local_domains_ldap, \%local_domains,
			   \@local_domains_acl, $local_domains_re)
		) { # append address extensions to mailbox names if desired,
		    # but only to those that match local_domains* lookups
		    my($localpart,$domain) = split_address($r->recip_addr);
		    if ($replace_existing_extension) {
			# strip away existing address extensions
			$localpart =~
				s/^(.*?)\Q$recipient_delimiter\E.*$(?!\n)/$1/s;
		    }
		    do_log(5,"adding extension $recipient_delimiter".
			     "$addr_extension_virus to $localpart\@$domain");
		    $r->recip_addr_modified(
			$localpart . $recipient_delimiter . $ext . $domain);
		}
	    }
	    $which_section = "virus_or_banned quar+notif";
	    ensure_mime_entity($msginfo,$fh,$tempdir,\@virusname);
	    do_virus($conn,$msginfo);   # send notifications, quarantine it

	} else {  # perhaps some recips consider it spam?
	    # spaminess is an individual matter, we must compare spam level
	    # with each recipient setting, there is no global criterium
	    # that the mail is spam
	    $which_section = "deal_with_spam";
	    for my $r (@{$msginfo->per_recip_data}) {
		next  if $r->recip_done;  # already dealt with
		my($should_be_killed) = $r->recip_blacklisted_sender ||
		    defined $spam_level && $spam_level>=lookup($r->recip_addr,
			$spam_kill_level_sql, $spam_kill_level_ldap,
			$sa_kill_level_deflt);
		next  unless $should_be_killed;
		# message is at or above kill level, or sender is blacklisted
		$considered_spam_by_some_recips = 1;
		if ($final_spam_destiny == D_PASS ||
		    $r->recip_whitelisted_sender ||
		    lookup($r->recip_addr, $spam_lovers_sql,$spam_lovers_ldap,
			   \%spam_lovers,\@spam_lovers_acl,$spam_lovers_re) ) {
		    # do nothing, recipient wants this message, even if spam
		} else {   # change mail destiny for those not wanting spam
		    $r->recip_destiny($final_spam_destiny);
		    my($reason) = $r->recip_blacklisted_sender ?
					'sender blacklisted' : 'UBE';
		    $r->recip_smtp_response( ($final_spam_destiny == D_DISCARD
				? "250 2.7.1 Ok, discarded, $reason"
				: "550 5.7.1 Message content rejected, $reason")
			. ", id=$am_id");
		    $r->recip_done(1);
		}
		# add address extensions if enabled and passing the message
		if ($recipient_delimiter ne '' &&
		    $addr_extension_spam ne '' &&
		    $r->recip_destiny == D_PASS &&
		    lookup($r->recip_addr, $local_domains_sql,
			   $local_domains_ldap, \%local_domains,
			   \@local_domains_acl, $local_domains_re) )
		{   # append address extensions to mailbox names if desired,
		    # but only to those that match local_domains* lookups
		    my($localpart,$domain) = split_address($r->recip_addr);
		    if ($replace_existing_extension) {
			# strip away existing address extensions
			$localpart =~
				s/^(.*?)\Q$recipient_delimiter\E.*$(?!\n)/$1/s;
		    }
		    do_log(5,"adding extension $recipient_delimiter".
			     "$addr_extension_spam to $localpart\@$domain");
		    $r->recip_addr_modified($localpart.
			    $recipient_delimiter.$addr_extension_spam.$domain);
		}
	    }
	    if ($considered_spam_by_some_recips) {
		$which_section = "spam quar+notif";
		ensure_mime_entity($msginfo,$fh,$tempdir,\@virusname);
		do_spam($conn,$msginfo);
	    }
	}

	if (@bad_headers) {  # invalid mail headers
	    $which_section = "deal_with_bad_headers";
	    ensure_mime_entity($msginfo,$fh,$tempdir,\@virusname);
	    my($is_bulk) = $msginfo->mime_entity->head->get("precedence");
	    chomp($is_bulk);
	    do_log(0, sprintf("BAD HEADER from %s<%s>: %s",
			      $is_bulk eq '' ? '' : "($is_bulk) ",
			      $msginfo->sender, $bad_headers[0] ));
	    $is_bulk =~ /(bulk|list)/i ? $1 : undef;
	    if (defined $is_bulk || $msginfo->sender eq '') {
		# have mercy on mailing lists and DSN
	    } else {
		for my $r (@{$msginfo->per_recip_data}) {
		    next  if $r->recip_done;  # already dealt with
		    if ($final_bad_header_destiny == D_PASS ||
			lookup($r->recip_addr,
			       $bad_header_lovers_sql, $bad_header_lovers_ldap,
			       \%bad_header_lovers, \@bad_header_lovers_acl,
			       $bad_header_lovers_re) ) {
			# recipient wants this message, broken or not
		    } else {  # change mail destiny for those not wanting it
			$r->recip_destiny($final_bad_header_destiny);
			my($reason) = (split("\n",$bad_headers[0]))[0];
			$r->recip_smtp_response(
			    ($final_bad_header_destiny == D_DISCARD
			      ? "250 2.6.0 Ok, message with invalid header discarded"
			      : "550 5.6.0 Message with invalid header rejected")
			    . ", id=$am_id - $reason");
			$r->recip_done(1);
		    }
		}
	    }
	}

#	$which_section = "special_quarantine";
#	do_quarantine($conn, $msginfo, Amavis::Out::EditHeader->new,
#		      ['user-quarantine'], 'local:user-%i-%n'
#	    )  if lookup($msginfo->sender, ['user1@domain','user2@domain']);

	# 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";
	    ensure_mime_entity($msginfo,$fh,$tempdir,\@virusname); #need header
	    # will forward only to those recipients not yet marked
	    # as 'done' by the above content filtering sections
	    for (;;) {
		my($hdr_edits) = Amavis::Out::EditHeader->new;
		$hdr_edits = add_forwarding_header_edits_common(
		    $conn,$msginfo,$hdr_edits,$hold,
		    $virus_presence_checked,$spam_presence_checked);
		my($done_all);
		my($recip_cl);  # ref to a list of similar recip objects
		($hdr_edits,$recip_cl,$done_all) =
		    add_forwarding_header_edits_per_recip(
					     $conn,$msginfo,$hdr_edits,$hold);
		last  if !@$recip_cl;
		$msginfo->header_edits($hdr_edits);
		mail_dispatch($forward_method,$conn,$msginfo,0,
			      sub {my($r)=@_; grep {$_ eq $r} @$recip_cl} );
		last  if $done_all;
	    }
	}
	prolong_timer($which_section);

	$which_section = "delivery-notification";
	my($dsn_needed);
	($smtp_resp, $exit_code, $dsn_needed) =
	    one_response_for_all($msginfo,$dsn_per_recip_capable);
	my($warnsender_with_pass) = $smtp_resp =~ /^2/ && !$dsn_needed &&
	    (   $warnvirussender  && @virusname
	     || $warnbannedsender && @banned_filename
	     || $warnbadhsender   && @bad_headers
	     || $warnspamsender   && $considered_spam_by_some_recips );
	do_log(5, "warnsender_with_pass=$warnsender_with_pass, dsn_needed=$dsn_needed, exit=$exit_code, $smtp_resp");
	if ($dsn_needed || $warnsender_with_pass) {
	    ensure_mime_entity($msginfo,$fh,$tempdir,\@virusname);# need header
	    my($notification);
	    if ($msginfo->sender eq '') {  # don't respond to null reverse path
		do_log(4, "Not sending DSN to empty return path");
	    } elsif ($msginfo->sender_contact eq '') {
		do_log(4, "Not sending DSN to believed-to-be-faked return path");
		$msginfo->dsn_sent(2);  # pretend the message was bounced
	    } elsif ((@virusname || @banned_filename ||
		 $considered_spam_by_some_recips) &&
		$msginfo->mime_entity->head->get("precedence")
		   =~ /bulk|list|junk/i ) {
		do_log(4, "Not sending DSN in response to bulk mail");
		$msginfo->dsn_sent(2);  # pretend the message was bounced
	    } else {
		# generate delivery status notification according to rfc1892
		# and rfc1894, but only if necessary
		$notification = delivery_status_notification(
		    $conn, $msginfo, $warnsender_with_pass, \%builtins,
		    @virusname+@banned_filename ? \$notify_virus_sender_templ
			: $considered_spam_by_some_recips ? \$notify_spam_sender_templ
			: \$notify_sender_templ);
	    }
	    if (defined $notification) {    # dsn needed
		# send delivery notification
		mail_dispatch($notify_method,$conn,$notification,1);
		my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
		    one_response_for_all($notification,0);     # check status
		if (!$n_dsn_needed) {       # dsn delivery successful?
		    $msginfo->dsn_sent(1);  # mark the message as bounced
		} else {
		    do_log(0, "UNABLE TO SEND DSN: $n_smtp_resp");
	      #     # if dsn can not be sent, try to send it to postmaster
	      #     $notification->recips(['postmaster']);
	      #     # attempt double bounce
	      #     mail_dispatch($notify_method,$conn,$notification,1);
		}
		# $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);
	$$strr =~ s/[\s\n\r]+$(?!\n)//;
	do_log(0, $$strr)  if $$strr ne '';

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

# Ensure we have $msginfo->$entity defined when we expect we'll need it,
# e.g. to construct notifications. While at it, also get us some additional
# information on sender from the header.
#
sub ensure_mime_entity($$$$) {
    my($msginfo,$fh,$tempdir,$virusname_list) = @_;
    if (!defined($msginfo->mime_entity)) {
	# header may not have been parsed yet, e.g. if the result was cached
	$msginfo->mime_entity(mime_decode($fh,$tempdir));
	prolong_timer("ensure_mime_entity");
    }
    # best attempt at determining true sender of the junk - normally
    # the same as envelope sender, unless certain viruses mangle it
    if (@$virusname_list) {
	my($sender_contact,$sender_source) = best_try_originator(
	    $msginfo->sender, $msginfo->mime_entity, $virusname_list);
	$msginfo->sender_contact($sender_contact); # save it
	$msginfo->sender_source($sender_source);   # save it
    }
}

sub add_forwarding_header_edits_common($$$$) {
    my($conn, $msginfo, $hdr_edits, $hold,
       $virus_presence_checked, $spam_presence_checked) = @_;

    $hdr_edits->prepend_header('Received',
	received_line($conn,$msginfo,am_id(),1),
	1)  if $insert_received_line && $forward_method ne '';
    # 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]+$(?!\n)/) {
	    if ($remove_existing_x_scanned_headers)
		{ $hdr_edits->delete_header($X_HEADER_TAG) }
	    $hdr_edits->append_header(
		$X_HEADER_TAG,$X_HEADER_LINE)  if $virus_presence_checked;
	}
	$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);
	}
	$hdr_edits->append_header('X-Amavis-Alert',
	    "BAD HEADER ".$bad_headers[0], 1)  if @bad_headers;
    }
    if ($extra_code_antispam) {
	if ($remove_existing_spam_headers) {
	    $hdr_edits->delete_header('X-Spam-Status');
	    $hdr_edits->delete_header('X-Spam-Level');
	    $hdr_edits->delete_header('X-Spam-Flag');
	    $hdr_edits->delete_header('X-Spam-Report');
	    $hdr_edits->delete_header('X-Spam-Checker-Version');
	}
#	$hdr_edits->append_header('X-Spam-Checker-Version',
#	    sprintf("SpamAssassin %s (%s)",
#		    Mail::SpamAssassin::Version(),
#		    $Mail::SpamAssassin::SUB_VERSION));
    }
    $hdr_edits;
}

# Prepare header edits for the first not-yet-done recipient.
# Inspect remaining recipients, returning the list of recipient objects
# that are receiving the same set of header edits (so the message may be
# delivered to them in one transaction).
#
sub add_forwarding_header_edits_per_recip($$$$$) {
    my($conn, $msginfo, $hdr_edits, $hold, $filter) = @_;
    my(@recip_cluster);
    my(@per_recip_data) = grep {!$_->recip_done && (!$filter || &$filter($_))}
			       @{$msginfo->per_recip_data};
    my($per_recip_data_len) = scalar(@per_recip_data);
    if (!$extra_code_antispam)
	{ @recip_cluster = @per_recip_data; @per_recip_data = () }
    my($first) = 1;  my($cluster_key);  my($cluster_full_spam_status);
    for my $r (@per_recip_data) {
	my($recip) = $r->recip_addr;
	my($blacklisted) = $r->recip_blacklisted_sender;
	my($whitelisted) = $r->recip_whitelisted_sender;
	my($is_local) =
	    lookup($recip, $local_domains_sql,
	                   $local_domains_ldap, \%local_domains,
		           \@local_domains_acl, $local_domains_re);
	my($tag_level) =
	    lookup($recip, $spam_tag_level_sql, $spam_tag_level_ldap,
			   $sa_tag_level_deflt);
	my($tag2_level) =               # looking for kill_level compatibility
	    lookup($recip, $spam_tag2_level_sql,  $spam_kill_level_sql,
			   $spam_tag2_level_ldap, $spam_kill_level_ldap,
			   $sa_tag2_level_deflt,  $sa_kill_level_deflt);
	my($do_tag)  = $is_local && ($blacklisted || $spam_level>=$tag_level);
	my($do_tag2) = $is_local && ($blacklisted || $spam_level>=$tag2_level);
	my($do_subj) = $do_tag2 && $sa_spam_subject_tag ne '' &&
		       lookup($recip, $spam_modifies_subj_sql,
			      $spam_modifies_subj_ldap,$sa_spam_modifies_subj);
	for ($do_tag,$do_tag2,$do_subj) { $_ = $_ ? 1 : 0 }  # normalize
	my($spam_level_bar, $full_spam_status);
	if ($do_tag || $do_tag2) {
	    $spam_level_bar = '*' x min($blacklisted?64:$spam_level+0, 64);
	    $full_spam_status = sprintf(
		"%s,\n hits=%3.1f\n tagged_above=%3.1f\n required=%3.1f\n %s%s",
		( ($blacklisted || $spam_level>=$tag2_level) ? 'Yes' : 'No'),
		$spam_level, $tag_level, $tag2_level,
		join('', $blacklisted ? "BLACKLISTED\n " : (),
			 $whitelisted ? "WHITELISTED\n " : () ), $spam_status);
	}
#	$hdr_edits->append_header('X-Sender-Status',
#				  'Whitelisted')  if $whitelisted;
	my($key) = join("\000", $do_tag, $do_tag2, $do_subj,
				$spam_level_bar, $full_spam_status);
	if ($first) {
	    do_log(5, sprintf("headers CLUSTERING: NEW CLUSTER <%s>: ".
			      "hits=%3.1f, tag=%d, tag2=%d, subj=%d, local=%d, bl=%d",
		$recip, $spam_level,$do_tag,$do_tag2,$do_subj,$is_local,$blacklisted) );
	    $cluster_key = $key; $cluster_full_spam_status = $full_spam_status;
	} elsif ($key eq $cluster_key) {
	    do_log(5, "headers CLUSTERING: <$recip> joining cluster");
	} else {
	    do_log(5, "headers CLUSTERING: skipping <$recip> (tag=$do_tag, tag2=$do_tag2)" );
	    next;
	}
	if ($first && $do_tag) {
	    $hdr_edits->append_header('X-Spam-Status',$full_spam_status,1);
	    $hdr_edits->append_header('X-Spam-Level',$spam_level_bar);
	}
	if ($first && $do_subj) {
	    my($entity) = $msginfo->mime_entity;
	    if (defined $entity && $entity->head->get('Subject')) {  # edit
		$hdr_edits->edit_header('Subject',
					sub { $_[1]=~/^([ \t]?)(.*)$(?!\n)/s;
					      ' '.$sa_spam_subject_tag.$2 });
	    } else {   # no Subject header field present, insert one
		my($s) = $sa_spam_subject_tag;  $s =~ s/[ \t]+$(?!\n)//; # trim
		$hdr_edits->append_header('Subject', $s);
	    }
	}
	if ($first && $do_tag2) {
	    $hdr_edits->append_header('X-Spam-Flag', 'YES');
#	    $hdr_edits->append_header('X-Spam-Report',
#				      $spam_report,1)  if $spam_report ne '';
	}
	push(@recip_cluster, $r);  $first = 0;
    }
    my($done_all);
    if (@recip_cluster == $per_recip_data_len) {
	do_log(3, "headers CLUSTERING: ".
		  "done all $per_recip_data_len recips in one go");
	$done_all = 1;
    } else {
	do_log(3, sprintf("headers CLUSTERING: got %d recips out of %d: %s",
		    scalar(@recip_cluster), $per_recip_data_len,
		    join(", ", map {"<".$_->recip_addr.">"} @recip_cluster) ));
    }
    if (defined($cluster_full_spam_status) && @recip_cluster) {
	my($s) = $cluster_full_spam_status;  $s =~ s/\n / /g;
	do_log(2, sprintf("SPAM-TAG, <%s> -> %s, %s", $msginfo->sender_source,
		join(", ", map {"<".$_->recip_addr.">"} @recip_cluster), $s));
    }
    ($hdr_edits, \@recip_cluster, $done_all);
}

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

    # 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($quarantine_method =~ /^bsmtp:/i
		      ? $msginfo->recips  # original message recipients, bsmtp:
		      : $recips_ref);     # e.g. per-recip domain quarantine
    $quar_msg->header_edits($hdr_edits);
    $quar_msg->mail_text($msginfo->mail_text);

    # fudge to get to the body_digest of $msginfo, not of $quar_msg
    $quarantine_method =~ s/%b/$msginfo->body_digest/eg;
    mail_dispatch($quarantine_method,$conn,$quar_msg,1);

    my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
	one_response_for_all($quar_msg,0);  # check status
    if ($n_smtp_resp !~ /^2/ || $n_dsn_needed) {
	# abort if quarantining not successful
	die "Can not quarantine: '$n_smtp_resp'";
    }
    my(@qa);  # list of quarantine mailboxes or addresses
    for my $r (@{$quar_msg->per_recip_data}) {
	my($addr) = $r->recip_final_addr;
	push(@qa, $addr=~/\@/ ? $addr : $r->recip_mbxname);
    }
    $msginfo->quarantined_to(\@qa);
    do_log(5, "DO_QUARANTINE done");
}

# 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
    my($taint) = substr($virus_quarantine_method,0,0);
    $VIRUSFILE = $virus_quarantine_method =~ /^(?:local|bsmtp):(.*)$(?!\n)/si
			? $1.$taint : "virus-%i-%n";
    $VIRUSFILE =~ s/%b/$msginfo->body_digest/eg;
    $VIRUSFILE =~ s/%i/strftime("%Y%m%d-%H%M%S",localtime)/eg;
    $VIRUSFILE =~ s/%n/am_id()/eg;
    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,
		  $virus_quarantine_method)  if @q_addr;

    do_log(5, "DO_VIRUS - NOTIFICATIONS, sender: ".$msginfo->sender);
    $hdr_edits = Amavis::Out::EditHeader->new;

#   my($notify_virus_admin_only_if_sender_is_local) = 0;

    # 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");
#   } elsif ($notify_virus_admin_only_if_sender_is_local &&
#	     lookup($msginfo->sender, $local_domains_sql, $local_domains_ldap,
#		    \%local_domains, \@local_domains_acl, $local_domains_re)) {
#	do_log(2, "Skip virus_admin notification for <".$msginfo->sender.
#		  ">, non-local sender");
    } 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'} = $hdrfrom_notify_admin;
	$notification->mail_text(string_to_mime_entity(
	    expand(\$notify_virus_admin_templ,\%mybuiltins) ));
	$notification->header_edits($hdr_edits);
	mail_dispatch($notify_method,$conn,$notification,1);
	my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
	    one_response_for_all($notification,0);      # 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 && @virusname ||
	   $warnbannedrecip && @banned_filename) ) {
	# warn_recip() normally disabled - it is usually counterproductive
	# Enable only if you know what you are doing!
#   } elsif (! defined($msginfo->sender_contact) ) {
#	do_log(5,"do_virus: skip recipient notifications for unknown senders");
    } else {
	my(@locals) = grep { $warn_offsite ||
			     lookup($_, $local_domains_sql,
			                $local_domains_ldap, \%local_domains,
					\@local_domains_acl, $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'} = $hdrfrom_notify_admin;
	    $notification->mail_text(string_to_mime_entity(
		expand(\$notify_virus_recips_templ,\%mybuiltins) ));
	    $notification->header_edits($hdr_edits);
	    mail_dispatch($notify_method,$conn,$notification,1);
	    my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
		one_response_for_all($notification,0);      # check status
	    if ($n_smtp_resp !~ /^2/ || $n_dsn_needed)
		{ do_log(0, "FAILED to notify virus recipients: $n_smtp_resp")}
	    # $notification->purge;
	}
    }
    do_log(5, "DO_VIRUS - DONE");
}

#
# 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
    my($taint) = substr($spam_quarantine_method,0,0);
    $VIRUSFILE = $spam_quarantine_method =~ /^(?:local|bsmtp):(.*)$(?!\n)/si
			? $1.$taint : "spam-%b-%i-%n";
    $VIRUSFILE =~ s/%b/$msginfo->body_digest/eg;
    $VIRUSFILE =~ s/%i/strftime("%Y%m%d-%H%M%S",localtime)/eg;
    $VIRUSFILE =~ s/%n/am_id()/eg;
    # use the smallest value as the level reported in quarantined headers!
    my($tag_level) =
	min(map {lookup($_, $spam_tag_level_sql, $spam_tag_level_ldap,
			    $sa_tag_level_deflt)} @{$msginfo->recips});
    my($tag2_level) =                   # looking for kiil_level compatibility
	min(map {lookup($_, $spam_tag2_level_sql,  $spam_kill_level_sql,
			    $spam_tag2_level_ldap, $spam_kill_level_ldap,
			    $sa_tag2_level_deflt, $sa_kill_level_deflt)}
		@{$msginfo->recips});
    my($kill_level) =
	min(map {lookup($_, $spam_kill_level_sql, $spam_kill_level_ldap,
			    $sa_kill_level_deflt)} @{$msginfo->recips});
    my($full_spam_status) = sprintf(
	"%s,\n hits=%3.1f\n tag1=%3.1f\n tag2=%3.1f\n kill=%3.1f\n %s",
	($spam_level >= $tag2_level ? 'Yes' : 'No'),
	$spam_level, $tag_level, $tag2_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 a quarantine address");
    my(@q_addr);   # quarantine address(es)
    if ($spam_quarantine_bysender_to) {         # by-sender quarantine
	my($a) = lookup($msginfo->sender, $spam_quarantine_bysender_to);
	push(@q_addr, $a)  if $a ne '';
    }
    for my $r (@{$msginfo->per_recip_data}) {   # per-recipient quarantine
	my($a) = lookup($r->recip_addr, $spam_quarantine_to_sql,
			$spam_quarantine_to_ldap, $spam_quarantine_to);
	push(@q_addr, $a)  if $a ne '' && !grep {$_ eq $a} @q_addr;
    }
    if (@q_addr) {  # 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($spam_level+0,64));
	do_quarantine($conn, $msginfo, $hdr_edits, \@q_addr,
		      $spam_quarantine_method);
    }
    do_log(1, sprintf("SPAM, <%s> -> %s, %s%s", $msginfo->sender_source,
		      join(',', map{"<$_>"} @{$msginfo->recips}), $s,
		      !@q_addr ? '' : sprintf(", quarantine %s (%s)",
					      $VIRUSFILE, join(',',@q_addr))));
    # 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
	do_log(5, "DO_SPAM - NOTIFICATIONS, sender: ".$msginfo->sender);
	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'} = $hdrfrom_notify_spamadmin;
	$notification->mail_text(string_to_mime_entity(
	    expand(\$notify_spam_admin_templ,\%mybuiltins) ));
	my($hdr_edits) = Amavis::Out::EditHeader->new;
	$notification->header_edits($hdr_edits);
	mail_dispatch($notify_method,$conn,$notification,1);
	my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
	    one_response_for_all($notification,0);      # check status
	if ($n_smtp_resp !~ /^2/ || $n_dsn_needed)
	    { do_log(0, "FAILED to notify spam admin: $n_smtp_resp") }
	# $notification->purge;
    }
    do_log(5, "DO_SPAM DONE");
}

# 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 $eol;
	$header_size += length($_);  push(@orig_header,$_); # with trailing EOL
    }
    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} )? ) $(?!\n)/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(3, "body hash: $signature");
    $signature;
}

sub find_program_path($$$) {
    my($fv_list, $path_list_ref, $may_log) = @_;
    $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
	    my($errn) = stat($fv_cmd[0]) ? 0 : 0+$!;
	    if ($errn == ENOENT) {}
	    elsif ($errn) { do_log(0, "find_program_path: ".
				"$fv_cmd[0] inaccessible: $!")  if $may_log }
	    elsif (-x _ && !-d _) { $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) {
		my($errn) = stat("$p/$fv_cmd[0]") ? 0 : 0+$!;
		if ($errn == ENOENT) {}
		elsif ($errn) { do_log(0, "find_program_path: ".
			       "$p/$fv_cmd[0] inaccessible: $!")  if $may_log }
		elsif (-x _ && !-d _) {
		    $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 $lzop $lha $unarj
		  $uncompress $unfreeze $unrar $zoo $cpio)) {
	my($g) = $f;  $g =~ s/\$/Amavis::Conf::/;
	my($fv_list) = eval('$'.$g);
	my($found) = find_program_path($fv_list,$path_list_ref,1);
	{ 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));
	}
    }
    # map program name hints to full paths
    my($tier) = 'primary';  # primary, secondary, ...   av scanners
    for my $f (@av_scanners, "\000", @av_scanners_backup) {
	if ($f eq "\000") {
	  $tier = 'secondary';
	} elsif (!defined $f || !ref $f) {  # empty, skip
	} elsif (ref($f->[1]) eq 'CODE') {
	    do_log(0, "Using internal av scanner code for ($tier) ".$f->[0]);
	} else {
	    my($found) = $f->[1] = find_program_path($f->[1],$path_list_ref,1);
	    if (!defined $found) {
		do_log(3, "No $tier av scanner: ".$f->[0]);
		$f = undef;  # release its storage
	    } else {
		do_log(0, sprintf("Found $tier av scanner %-11s at %s%s",
		    $f->[0],
		    $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) "
					     : '',
		    $found));
	    }
	}
    }
}

# Fetch all remaining modules.
sub fetch_modules_extra() {
    my(@modules);
    push(@modules, 'DBI')        if $extra_code_sql;
    push(@modules, 'Net::LDAP')  if $extra_code_ldap;
    push(@modules, qw(Compress::Zlib Convert::TNEF Convert::UUlib
		      Archive::Zip Archive::Tar))  unless $bypass_decode_parts;
    if ($extra_code_antispam) {
	push(@modules, qw(Mail::SpamAssassin Mail::SpamAssassin::NoMailAudit));
	push(@modules, qw(Mail::SpamAssassin::DBBasedAddrList)
	    )  if $sa_auto_whitelist;
    }
    Amavis::Boot::fetch_modules('REQUIRED ADDITIONAL MODULES', 1, @modules);
    if ($extra_code_antispam) {  # must be loaded before chroot takes place
	Amavis::Boot::fetch_modules('PRE-COMPILE OPTIONAL MODULES', 0, qw(
	    Mail::SpamAssassin::UnixLocker Mail::SpamAssassin::PerMsgLearner
	    Net::DNS::RR::SOA Net::DNS::RR::NS Net::DNS::RR::MX Net::DNS::RR::A
	    Net::DNS::RR::PTR Net::DNS::RR::CNAME Net::DNS::RR::TXT));
    }
    # load optional module SAVI if available and desired
    if ($extra_code_antivirus) {
	my($savi_module_ok,$savi); my($first) = 1;
	for (grep {ref($_) eq 'ARRAY' && $_->[0] eq 'Sophos SAVI'}
		  (@av_scanners, @av_scanners_backup)
	) {
	    if ($first) {
		$savi_module_ok = eval {require SAVI};

# comment out the following line in order to make SAVI-Perl initialize
# every time a child processs is born (instead of only once at startup time):
		$savi = Amavis::AV::sophos_savi_init(@$_)  if $savi_module_ok;

	    }
	    $_->[1] = undef  if !$savi_module_ok;
	    $_->[2] = $savi  if defined $savi;
	    $first = 0;
	}
    }
}

#
# Main program starts here
#

# Read dynamic source code, and logging and notification message templates
# at the end of the Amavis package
#
if ($unicode_aware) {
    # binmode(\*Amavis::DATA, ":utf8") or die "Can't set \*DATA to utf8: $!";
    # or use:                 ":encoding(iso-8859-1)"
}
do{ local($/) = "__DATA__$eol";   # set line terminator to this string
    map { chomp($_ = <Amavis::DATA>) }
	($extra_code_sql, $extra_code_ldap,
	 $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/^\r?\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 =~ /^(.*?)[\r\n]+$(?!\n)/s; # 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)], 0);
$amavisd_path = $1 if $amavisd_path=~m{^([A-Za-z0-9/._=+-]+)$(?!\n)}; # 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/._=+-]+)$(?!\n)};# untaint
}
# Read config file, which may override default settings
Amavis::Conf::read_config($config_file);

# Master configuration
my(@modules_basic) = keys %INC;

if (!@lookup_sql_dsn) { $extra_code_sql = undef }
else {
    eval $extra_code_sql or die "Problem in the Lookup::SQL code: $@";
    $extra_code_sql = 1;   # release memory occupied by the source code
}
if (!$enable_ldap) { $extra_code_ldap = undef }
else {
    eval $extra_code_ldap or die "Problem in the Lookup::LDAP code: $@";
    $extra_code_ldap = 1;   # release memory occupied by the source code
}

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 '' || ref $inet_socket_port && !@$inet_socket_port) {
    $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 && !@av_scanners_backup) {
    $extra_code_antivirus = undef;
} elsif (!%bypass_virus_checks &&
	 @bypass_virus_checks_acl==1 && @bypass_virus_checks_acl[0] eq '.') {
    # do a simple-minded test to make it easy to turn off virus checks
    $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 (!%bypass_spam_checks &&
    @bypass_spam_checks_acl==1 && @bypass_spam_checks_acl[0] eq '.') {
    # do a simple-minded test to make it easy to turn off spam checks
    $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|debug-sa|foreground)?$/) {
    $DEBUG=1      if $cmd eq 'debug';
    $daemonize=0  if $cmd eq 'foreground';
    $daemonize=0, $sa_debug=1  if $cmd eq 'debug-sa';
} elsif ($cmd !~ /^reload|stop$/) {
    die "Unknown argument.  Usage:\n  $0 [ -c config-file ] ( [ start ] | stop | reload | debug | debug-sa | foreground )\n";
} else {
    if ($pid_file eq '')
	{ die "pid_file config parameter not defined, can't $cmd\n" }
    my($errn) = stat($pid_file) ? 0 : 0+$!;
    if ($errn == ENOENT)
	{ die "No pid_file $pid_file, can't $cmd the process\n" }
    elsif ($errn)
	{ die "pid_file $pid_file inaccessible: $!, can't $cmd the process\n" }
    my($amavisd_pid);
    open(PID_FILE, "< $pid_file\0") 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';

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

# $SIG{USR2} = sub {
#    my($msg) = Carp::longmess("SIG$_[0] received, backtrace:");
#    print STDERR "\n",$msg,"\n";  do_log(0,$msg);
# };

fetch_modules_extra();  # bring additional modules into memory and compile them

# my(@modules_extra);
# for my $m (keys %INC)
#     { push(@modules_extra, $m)  if !grep {$_ eq $m} @modules_basic }
# do_log(0, "modules loaded: "      .join(", ", sort @modules_basic));
# do_log(0, "extra modules loaded: ".join(", ", sort @modules_extra));

for my $m ('Amavis::Conf',
	   sort map { s/\.pm$//; s[/][::]g; $_ } grep { /\.pm$/ } keys %INC) {
    next if !grep { $_ eq $m } qw( Amavis::Conf
	Archive::Tar Archive::Zip Compress::Zlib Convert::TNEF Convert::UUlib
	MIME::Entity MIME::Parser MIME::Tools Mail::Header Mail::Internet
	Mail::SpamAssassin Net::DNS Net::Server SAVI Unix::Syslog );
    do_log(0, sprintf("Module %-19s %s", $m, $m->VERSION || '?'));
}

if ($forward_method eq '' && $extra_code_in_smtp) {
    do_log(1, "forward_method is null (probably milter setup), ".
	      "DISABLING SMTP-in AS A PRECAUTION");
    $extra_code_in_smtp = undef;
}
do_log(1, "Found myself: $amavisd_path -c $config_file");
do_log(1, "Lookup::SQL code      ".($extra_code_sql    ?'':" NOT")." loaded");
do_log(1, "Lookup::LDAP code     ".($extra_code_ldap   ?'':" NOT")." loaded");
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");

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

# 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_sql,
				       $local_domains_ldap, \%local_domains,
				       \@local_domains_acl, $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 { local($_) = $MSGINFO->mime_entity;   # Message-ID of the message
	       if (defined) { $_ = $_->head->get("Message-ID"); chomp; $_ } },
    j => sub { local($_) = $MSGINFO->mime_entity;   # Subject of the message
	       if (defined) { $_ = $_->head->get("Subject"); chomp; $_ } },
    b => sub {$MSGINFO->body_digest},     # original message body digest
    n => \&am_id,		# amavis internal message id (for log entries)
    i => sub {$VIRUSFILE},	# some quarantine id, e.g. quarantine filename
    q => sub {$MSGINFO->quarantined_to},  # list of quarantine mailboxes
#   q => sub {map {my($q)=$_; $q=~s[^.*/([^/]+)$][$1]; $q}  # basename
#	      $MSGINFO->quarantined_to},  # list of quarantine mailboxes
    v => sub {[split(/[ \t]*\r?\n/,$av_output)]}, # anti-virus scanner output
    V => sub {\@virusname},	     # list of virus names
    F => sub {\@banned_filename},    # list of banned file names
    X => sub {\@bad_headers},        # list of header syntax violations
    W => sub {\@detecting_scanners}, # list of av scanners detecting a virus
    H => sub {[map {my $h=$_; chomp($h); $h} @{$MSGINFO->orig_header}]},# orig hdr
    A => sub {[split(/\r?\n/, $spam_report)]}, # SpamAssassin report lines
    c => sub {!defined $spam_level?'-':$spam_level},  # SpamAssassin hits/score
  # 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) },     # normal
  'spam-quarantine'  => sub { ($QUARANTINEDIR, "$VIRUSFILE.gz") }, # gzipped
  '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), $$) )
	    },
  'ham-quarantine' =>				# another example
	sub { ("$QUARANTINEDIR/ham.mbox", undef) },
  '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
		  map { "$_/tcp" }            # accept SMTP on this port(s)
		      (ref $inet_socket_port ? @$inet_socket_port :
		       $inet_socket_port ne '' ? $inet_socket_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,  # serialization lockfile
      # serialize  => 'flock',     # flock, semaphore, pipe
	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::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,$implied_args) = @_;
    # fieldtype: B=boolean, N=numeric, S=string,
    #            N-: numeric, nonexistent field returns undef without complaint
    #            S-: string,  nonexistent field returns undef without complaint
    #            B-: boolean, nonexistent field returns undef without complaint
    #            B0: boolean, nonexistent field treated as false
    #            B1: boolean, nonexistent field treated as true
    return undef  if !defined($sql_query);
    my($self) = bless {}, $class;
    $self->{sql_query} = $sql_query;
    $self->{fieldname} = lc($fieldname);
    $self->{fieldtype} = uc($fieldtype);
    $self->{args} = ref($implied_args) eq 'ARRAY' ? [@$implied_args]  # copy
			: [$implied_args]  if defined $implied_args;
    $self;
}

sub lookup_sql_field($$) {
    my($self,$addr) = @_;
    my($match);
    if (!defined($self)) {
	do_log(5, "lookup_sql_field - undefined, \"$addr\" no match");
    } else {
	my($field) = $self->{fieldname};
	if (!defined($self->{sql_query})) {
	    do_log(5, "lookup_sql_field($field) - null query, \"$addr\" no match");
	} else {
	    my($h_ref) = !exists($self->{args}) ?
			   $self->{sql_query}->lookup_sql($addr)
			 : $self->{sql_query}->lookup_sql($addr,$self->{args});
	    if (!defined($h_ref)) {
		do_log(5, "lookup_sql_field($field), \"$addr\" no match");
	    } elsif (!exists($h_ref->{$field})) {
		# record found, but no field with that name in the table
		if ($self->{fieldtype} eq 'B0') {  # boolean, defaults to false
		    $match = 0;  # nonexistent field treated as 0
		    do_log(5, "lookup_sql_field($field), no field, \"$addr\" result=$match");
		} elsif ($self->{fieldtype} eq 'B1') {  # defaults to true
		    $match = 1;  # nonexistent field treated as 1
		    do_log(5, "lookup_sql_field($field), no field, \"$addr\" result=$match");
		} elsif ($self->{fieldtype}=~/^.-$/) {  # expected to not exist
		    do_log(5, "lookup_sql_field($field), no field, \"$addr\" result=undef");
		} else {         # treated as 'no match', issue a warning
		    do_log(1, "lookup_sql_field($field) ".
			  "(WARNING: no such field in the SQL table), ".
			  "\"$addr\" matches, result=undef");
		}
	    } else {
		# fieldtype: B=boolean, N=numeric, S=string,
		#            B0: boolean, nonexistent field treated as false,
		#            B1: boolean, nonexistent field treated as true
		$match = $h_ref->{$field};  my($found) = defined $match;
		if (!defined($match)) {   # keep undef for NULL field values
		} elsif ($self->{fieldtype} =~ /^B/) {  # boolean
		    # convert values 'N', 'F', '0', ' ' and "\000" to 0
		    # to allow value to be used directly as a Perl boolean
		    $match = 0  if $match =~ /^[NnFf0 \000][ ]*$(?!\n)/;
		} elsif ($self->{fieldtype} =~ /^N/) {   # numeric
		    $match = $match + 0;  # unify different numeric forms
		} elsif ($self->{fieldtype} =~ /^S/) {   # string
		    $match =~ s/ +$(?!\n)//;    # trim trailing spaces
		}
		do_log(5, "lookup_sql_field($field) \"$addr\"" .
			(!$found ? ", no match" : " matches, result=$match") );
	    }
	}
    }
    $match;
}

1;

#
package Amavis::Lookup::SQL;
use strict;
BEGIN {
    use Exporter ();
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
    $VERSION = '1.15';
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(&connect_to_sql);
}
use subs @EXPORT_OK;

use DBI;

BEGIN {
    import Amavis::Util qw(do_log);
    import Amavis::Conf qw(:platform :confvars);
    import Amavis::Timing qw(section_time);
    import Amavis::rfc2821_2822_Tools qw(split_address split_localpart);
}

# 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': " .
		  $DBI::errstr);
    }
    do_log(0, "connect_to_sql: unable to connect to any DSN at all!"
	  )  if !$dbh && @dsns>1;
    $dbh;
}

# return a Lookup::SQL object containing a DBI handle and prepared selects
sub new($$$$$$) {
    my($class, $dbh, $select_clause) = @_;
    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) = $select_clause;  $sel =~ s/%k/join(',',('?')x$n)/ge;
	do_log(5,"SQL prepare: ".$sel);
	$self->{"sth$n"} = $dbh->prepare($sel);
    }
    $self;
}

sub clear_cache {
    my($self) = @_;
    delete $self->{cache};
}

# 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
# the order is unspecified, which is only useful if just specific entries
# exist in a database (full address, not domain part or mailbox part only).
#
# The following order is recommended, going from specific to more general:
#  - lookup for user+foo@example.com
#  - lookup for user@example.com (only if $recipient_delimiter nonempty)
#  - lookup for user+foo ('naked lookup': only if local)
#  - lookup for user  ('naked lookup': local and $recipient_delimiter nonempty)
#  - lookup for @example.com
#  - lookup for @.       (catchall)
# NOTE:
#  this is different from hash and ACL lookups in three important aspects:
#    - subdomains are not looked at, only full domain names are matched;
#    - naked key (without '@') implies mailbox (=user) name, not domain name;
#    - the naked mailbox name lookups are only performed when the e-mail
#      address (usually its domain part) matches the local_domains* lookups.
#
# 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,$extra_args) = @_;
    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($taint) = substr($addr,0,0);
    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.$taint  if $domain =~ /^\@?(.*?)\.*$(?!\n)/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_acl,$local_domains_re)) {
	# NOTE: $local_domains_sql is not looked up to avoid recursion,
	#       only static local_domain* lookup tables are used !
	push(@keys, $localpart.$recipient_delimiter.$extension)
	    if $extension ne '';          # user+foo
	push(@keys, $localpart);          # user
    }
    push(@keys, '@'.$domain);             # @example.com
    push(@keys, '@.');                    # @.  (catchall)
    my($n) = sprintf("%d",scalar(@keys));
    my($sth) = $self->{"sth$n"};
    unshift(@keys,@$extra_args)  if ref $extra_args;  # prepend extra arguments
    for (@keys) { $_=$1 if /^(.*)$(?!\n)/s }     # untaint keys
    do_log(5, "lookup_sql \"$addr\", query keys: " .
	      join(', ', map{"\"$_\""}@keys) );
    $sth->execute(@keys);  # do the query
    my($a_ref,$found,$match); $match = {};
    while ( defined($a_ref=$sth->fetchrow_arrayref) ) {  # fetch query results
	my(@names) = @{$sth->{NAME_lc}};
	$found = 1; $match = {}; @$match{@names} = @$a_ref;
	do_log(5, "lookup_sql: \"$addr\" matches, result=(".
		join(", ", map {$_.'=>"'.$match->{$_}.'"'} @names) .")" );
	last if $found; # first match wins, the loop is for possible future use
    }
    $sth->finish();
    if (!$found) {
	$match = undef;
	do_log(5, "lookup_sql, \"$addr\" no match");
    }
    # save for future use, but only within processing of this message
    $self->{cache}->{$addr} = $match;
    section_time('lookup_sql');
    $match;
}

1;

__DATA__
#^L
package Amavis::Lookup::LDAP;
# by Jacques Supcik, PhD
# IP-Plus Internet Services - Swisscom Enterprise Solutions Ltd
# Genfergasse 14, 3050 Bern, Switzerland (http://www.ip-plus.net/)
# March 2003

use strict;
BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION
              $ldap_sys_default %ldap_cache);
  @ISA = qw(Exporter);
  $VERSION = '1.15';

  import Amavis::Util qw(do_log);
  import Amavis::Conf qw(:platform :confvars);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools qw(split_address split_localpart);

  $ldap_sys_default = {
    hostname => 'localhost', port => 389, timeout => 120, tls => 0,
    base => undef, scope => 'sub',
    query_filter => '(&(objectClass=amavisAccount)(mail=%m))',
    res_attr => undef, res_filter => '%r',
    bind_dn => undef, bind_password => undef
  };
  %ldap_cache = ();
}

sub trim {
  my $str = shift;
  $str =~ s/\s+$(?!\n)//; $str =~ s/^\s+//;
  $str;
}

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;
  my ($default, $query) = @_;
  my ($self) = bless {}, $class;
  my $llog = sub {
    my $level = shift;
    my $template = shift;
    my $prefix = __PACKAGE__."::new (res_attr->".$query->{res_attr}.")";
    do_log($level, sprintf("$prefix - $template", @_));
  };
  # Replace undefined attributes by defaults
  foreach (qw(hostname port timeout tls base scope query_filter
    res_attr res_filter bind_dn bind_password)) {
    $query->{$_} = $default->{$_} unless (defined $query->{$_});
    $query->{$_} = $ldap_sys_default->{$_} unless (defined $query->{$_});
  }
  my $ldap;
  my $hostList = (ref $query->{hostname} eq 'ARRAY') ?
   join ", ", @{$query->{hostname}} : $query->{hostname};
  my $cache_key = join "\036", ($hostList, $query->{port},
    $query->{timeout}, $query->{tls},
    $query->{bind_dn}, $query->{bind_password});
  if (exists $ldap_cache{$cache_key}) {
    $llog->(5, "Fetching ldap connection from cache");
    $ldap = $ldap_cache{$cache_key};
  } else {
    $llog->(5, "trying to connect to '%s'", $hostList);
    $ldap = Net::LDAP->new($query->{hostname}, port=>$query->{port},
      timeout=>$query->{timeout}, onerror=>'undef');
    if ($ldap) {
      $llog->(5, "connection to '%s' succeeded", $hostList);
    } else {
      $llog->(0, "unable to connect to host '%s'. LDAP lookups disabled.",
        $hostList);
      return undef;
    }
    if ($query->{tls}) { # TLS required
      my $tlsVer = $ldap->start_tls(verify=>'none');
      $llog->(5, "TLS version %s enabled", $tlsVer);
    }
    if ($query->{bind_dn}) { # Binding required
      if ($ldap->bind ($query->{bind_dn}, password => $query->{bind_password})) {
        $llog->(5, "bind '%s' succeeded", $query->{bind_dn});
      } else {
        $llog->(1, "unable to bind '%s'",$query->{bind_dn});
        return undef;
      }
    }
    $ldap_cache{$cache_key} = $ldap;
  }
  $self->{ldap} = $ldap;
  foreach (qw(base scope query_filter res_attr res_filter)) {
    $self->{$_} = $query->{$_};
  }
  if ($query->{res_attr} eq "dn") {
    $self->{type} = "S" # String
  } else {
    my $schema = $ldap->schema(); # Lookup schema
    if ($schema) {
      my $sa = $schema->attribute($query->{res_attr});
      if ($sa and $sa->{equality} eq 'booleanMatch' and $sa->{'single-value'}) {
        $self->{type} = "B" # Boolean
      } elsif ($sa and $sa->{equality} eq 'integerMatch' and
        $sa->{'single-value'}) {
        $self->{type} = "N" # Number
      } elsif ($sa and not $sa->{'single-value'}) {
        $self->{type} = "L" # List
      } elsif ($sa) {
        $self->{type} = "S" # String
      } else {
        $llog->(1, "attribute not defined in schema");
        $self->{type} = "S" # attribute not defined, default String
      }
    } else {
      $llog->(1, "unable to read LDAP schema");
      $self->{type} = "S" # If no schema is defined, default String
    }
  }
  $llog->(5, "type='%s'",$self->{type});
  return $self;
}

sub lookup_ldap_exact {
  my $self = shift;
  my ($addr) = @_;
  my $llog = sub {
    my $level = shift;
    my $template = shift;
    my $prefix = __PACKAGE__."::lookup_ldap_exact ($addr)";
    do_log($level, sprintf("$prefix - $template", @_));
  };
  unless (defined $self) {
    $llog->(5, "object undefined, no match");
    return undef;
  }
  unless (defined $self->{ldap}) {
    $llog->(5, "null ldap object, no match");
    return undef;
  }
  my $filter = $self->{query_filter};
  $filter =~ s/%m/$addr/g;
  my $attribute = $self->{res_attr};
  $llog->(5, "searching attribute=%s, filter=%s, base=\"%s\", scope=\"%s\"",
    $self->{res_attr}, $filter, $self->{base}, $self->{scope});
  my $res = $self->{ldap}->search (
    base => $self->{base}, scope => $self->{scope}, filter => $filter
  );
  unless (defined $res) {
    $llog->(5, "result undefined, no match");
    return undef;
  }
  $llog->(5, "result:%s", $res->code);
  if (my $entry = $res->pop_entry) {
    if ($self->{res_attr} eq "dn") {
      my $x = trim($entry->dn);
      my $f = $self->{res_filter}; $f =~ s/%r/$x/g;
      $llog->(5, "dn match: %s (%s)", $x, $f);
      return $f;
    } elsif ($entry->exists($self->{res_attr})) {
      if ($self->{type} eq "B") {
	my $x = (uc($entry->get_value($self->{res_attr})) eq "TRUE") ? 1 : 0;
  	my $f = $self->{res_filter}; $f =~ s/%r/$x/g;
        $llog->(5, "boolean match: %s (%s)", $x, $f);
	return $f;
      } elsif ($self->{type} eq "N") {
	my $x = 0 + scalar $entry->get_value($self->{res_attr});
  	my $f = $self->{res_filter}; $f =~ s/%r/$x/g;
        $llog->(5, "numeric match: %s (%s)", $x, $f);
	return $f;
      } elsif ($self->{type} eq "S") {
	my $x = trim(scalar $entry->get_value($self->{res_attr}));
  	my $f = $self->{res_filter}; $f =~ s/%r/$x/g;
        $llog->(5, "string match: %s (%s)", $x, $f);
	return $f;
      } else {
	my @x = map { trim($_) } $entry->get_value($self->{res_attr});
	my @f = map { my $f = $self->{res_filter}; $f =~ s/%r/$_/g; $f } @x;
        $llog->(5, "list match: %s (%s)", join (", ", @x), join (", ", @f));
	return wantarray ? @f : \@f;
      }
    } else {
      $llog->(5, "attribute does not exists, no match");
    }
  } else {
    $llog->(5, "address not found, no match");
  }
  return undef
}

sub lookup_ldap {
  my $self = shift;
  my ($addr) = @_;
  my $llog = sub {
    my $level = shift;
    my $template = shift;
    my $prefix = __PACKAGE__."::lookup_ldap ($addr)";
    do_log($level, sprintf("$prefix - $template", @_));
  };
  my $log_prefix = __PACKAGE__ . "::lookup_ldap($addr) -";
  my ($taint) = substr($addr,0,0);
  my ($localpart, $domain) = split_address($addr);
  my $res;
  $domain = lc($domain);
  $localpart = lc($localpart) unless $localpart_is_case_sensitive;
  # chop off leading @, and trailing dots
  if ($domain =~ /^\@?(.*?)\.*$(?!\n)/s) { $domain = $1.$taint }
  my $extension;
  if ($recipient_delimiter ne '') {
    ($localpart, $extension) =
      split_localpart($localpart, $recipient_delimiter);
  }
  if ($extension ne '') { # user+foo@example.com
    $res = $self->lookup_ldap_exact ($localpart.$recipient_delimiter.
      $extension.'@'.$domain);
    if (defined $res) { return $res }
  }
  $res = $self->lookup_ldap_exact($localpart.'@'.$domain);  # user@example.com
  if (defined $res) { return $res }
  if (Amavis::Lookup::lookup($addr, \%local_domains,
				    \@local_domains_acl, $local_domains_re)) {
    if ($extension ne '') { # user+foo
      $res = $self->lookup_ldap_exact($localpart.$recipient_delimiter.
	$extension);
      if (defined $res) { return $res }
    }
    $res = $self->lookup_ldap_exact ($localpart); # user
    if (defined $res) { return $res }
  }
  $res = $self->lookup_ldap_exact ('@'.$domain); # @example.com
  if (defined $res) { return $res }
  $res = $self->lookup_ldap_exact ('@.'); # @. (catchall)
  return $res
}

1;

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

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

use subs @EXPORT;
use Errno qw(ENOENT);
use IO::File;

BEGIN {
    import Amavis::Conf qw(:platform :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 | \Q$MYHOME\E )
		       \/ (?! .* \.{2,} .*) [A-Za-z0-9_.-]+ ) $(?!\n)/xso
	    or die "Invalid temporary directory '$inbuff'";
	$tempdir = $1;  # untaint the directory name
	# set new amavis message id
	am_id( ($tempdir =~ /amavis-(milter-)?(.+?)$(?!\n)/s ? $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", 'r')
	    or die "Can't open file $tempdir/email.txt: $!";
	binmode($fh,":bytes")
	    or die "Can't cancel :utf8 mode: $!"  if $unicode_aware;
	$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);
	my($errn) = $tempdir eq '' ? ENOENT : (stat($tempdir) ? 0 : 0+$!);
	if ($tempdir eq '' || $errn == ENOENT) {
	    # 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_OK) { # e.g. milter
	    # when forwarding is left for MTA on the input side to do,
	    # warn if there is anything that should be done, but MTA is not
	    # capable of doing (or a helper program can not pass the request)
	    my($any_deletes);
	    for my $r (@{$msginfo->per_recip_data}) {
		my($addr,$newaddr) = ($r->recip_addr, $r->recip_final_addr);
		if ($r->recip_done) {
		    do_log(0, "WARN: recip addr <$addr> should be removed, but MTA can't do it");
		    $any_deletes++;
		} elsif ($newaddr ne $addr) {
		    do_log(0, "WARN: recip addr <$addr> should be replaced with <$newaddr>, but MTA can't do it");
		}
	    }
	    if ($any_deletes) {
		do_log(0, "WARN: REJECT THE WHOLE MESSAGE, MTA-in can't do the recips deletion");
		$exit_code = EX_UNAVAILABLE;
	    }
	}
    }
    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.15';
    @ISA = qw(Exporter);
}
use POSIX qw(strftime);
use Errno qw(ENOENT);
use Time::HiRes qw(time);

BEGIN {
    import Amavis::Conf qw(:platform :confvars);
    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};
    my($errn) = $self->{tempdir_pers} eq '' ? ENOENT
		    : (stat($self->{tempdir_pers}) ? 0 : 0+$!);
    if (defined $self->{tempdir_pers} && $errn != ENOENT) {
	# 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, $$);
    }
    my($errn) = stat($self->{tempdir_pers}) ? 0 : 0+$!;
    if ($errn == ENOENT || ! -d _) {
	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";
    my($errn) = stat($fname) ? 0 : 0+$!;
    if ($self->{fh_pers} && !$errn && -f _) {
	$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: $!";
    } else {
	$self->{fh_pers} = IO::File->new($fname, 'w+', 0640)
	    or die "Can't create file $fname: $!";
	section_time('create email.txt');
    }
}

# 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

    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,$aborting,$eof,$voluntary_exit); 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) = $_; my($taint) = substr($cmd,0,0); #tainted empty string
	    do_log(4, $self->{proto} . "< $cmd");
	    !/^ \s* ([A-Za-z]+) (?: \s+ (.*?) )? \s* \015\012 $(?!\n)/xs && do {
		$self->smtp_resp(1,"500 5.5.2 Error: bad syntax", 1, $cmd); last;
	    };
	    $_ = uc($1).$taint; my($args) = $2.$taint;
	    /^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);
		    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+ ([^<>]+) )? $(?!\n)/isx ) {
		    $self->smtp_resp(0,"501 5.5.2 Syntax: MAIL FROM: <address>", 1, $cmd);
		    last;
		}
		my($addr,$opt) = ($1.$taint, $2.$taint);  my($bad);
		for (split(' ',$opt)) {
		    if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]*  ) =
			    ( [\041-\074\076-\176]+ ) $(?!\n)/x) {#printable, no =,SP
			$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).$taint, $2.$taint);
			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.$taint : $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} . "< $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+ ([^<>]+) )? $(?!\n)/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);
		} elsif ($got_rcpt > $smtpd_recipient_limit) {
		    $self->smtp_resp(0,"452 4.5.3 Too many recipients");
		} else {
		    my($addr,$opt) = ($1.$taint, $2.$taint);
		    $addr = ($addr =~ /^<(.*)>$/s) ? $1.$taint : $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 {
		# set timer to the initial value, MTA timer starts here
		prolong_timer('DATA received - timer reset', $child_timeout);
		my($within_data_transfer,$complete);
		eval {
		    $msginfo->sender($sender); $msginfo->recips(\@recips);
		    do_log(1, sprintf("%s:%s:%s %s: <%s> -> %s Received: %s",
			      $conn->smtp_proto,
			      $conn->socket_ip eq $inet_socket_bind ? ''
				: '['.$conn->socket_ip.']',
			      $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>");
		    $within_data_transfer = 1;
		    section_time('SMTP pre-DATA-flush') if $self->{pipelining};
		    $self->{tempdir_empty} = 0;
		    do{ local($/) = "\015\012"; #set in.line terminator to CRLF
			while(<$sock>) {    # use native I/O for speed
			  # do_log(5, $self->{proto} . "< $_");
			    if (/^\./) {
				if ($_ eq ".\015\012") {
				    $complete = 1; $within_data_transfer = 0;
				    last;
				}
				# rfc 2821 by the letter
				s/^\.(.+\015\012)$(?!\n)/$1/s;
			    }
			    chomp; # remove \015\012 (=$/), faster than s///
			    print {$self->{fh_pers}} $_,$eol
				or die "Can't write to mail file: $!";
			}
			$eof = 1  if !$complete;
		    }; # restores line terminator
		    # normal data termination, or eof on socket, or fatal error
		    do_log(4, $self->{proto} . "< .\015\012")  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($@);
		    # either send: '421 Shutting down', or alternatively:
		    #   '451 Aborted, error in processing' and NOT shut down!
		    if (!$within_data_transfer) {
			my($msg) = "Error in processing: " .
				   !$complete && $@ eq '' ? 'incomplete' : $@;
			do_log(0, $self->{proto}." TROUBLE: 451 4.5.0 $msg");
			$self->smtp_resp(1, "451 4.5.0 $msg");
		    ### $aborting = $msg;
		    } else {
			$aborting = "client broke the connection ".
				    "during data transfer"  if $eof;
			$aborting .= ', '  if $aborting ne '' && $@ ne '';
			$aborting .= $@;
			$aborting = '???'  if $aborting eq '';
			do_log($@ ne '' ? 0 : 3,
			       $self->{proto}." TROUBLE, ABORTING: $aborting");
		    }
		} 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 ($smtp_resp !~ /^4/ &&
			grep { !$_->recip_done } @{$msginfo->per_recip_data}) {
			    die "TROUBLE/MISCONFIG: not all recipients done, ".
				     "\$forward_method is \"$forward_method\"";
		    }
		    if (!$lmtp) {
			do_log(4, "sending SMTP response: \"$smtp_resp\"");
			$self->smtp_resp(0, $smtp_resp);
		    } else {
			my($bounced) = $msginfo->dsn_sent;
			for my $r (@{$msginfo->per_recip_data}) {
			    my($resp) = $r->recip_smtp_response;
			    if ($bounced && $smtp_resp=~/^2/ && $resp!~/^2/) {
				# as the message was already bounced by us,
				# MTA must not bounce it again; failure status
				# needs to be converted into success!
				$resp = sprintf("250 2.5.0 Ok, DSN %s (%s)",
					    $bounced==1?'sent':'muted', $resp);
			    }
			    do_log(4, sprintf(
				"sending LMTP response for <%s>: \"%s\"",
				$r->recip_addr, $resp));
			    $self->smtp_resp(0, $resp);
			}
		    }
		};
		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;  # implicit RSET
		$msginfo = undef;  # forget previous

		$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);
	};
	$voluntary_exit = 1;
	last  if $terminating || defined $aborting;  # 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;
    }
    $eof = 1  if !$voluntary_exit;
    # we come here when: QUIT is received, eof on socket, or we need to abort
    $self->smtp_resp_flush; # just in case, the session might have been disconnected
    my($msg) =
	defined $aborting && !$eof? "ABORTING the session: $aborting" :
	defined $aborting ? $aborting :
	!$terminating     ? "client broke the connection without a QUIT" : '';
    do_log(0, $self->{proto}.': NOTICE: '.$msg)  if $msg ne '';
    if (defined $aborting && !$eof)
	{ $self->smtp_resp(1,"421 4.3.2 Service shutting down, ".$aborting) }
    $self->{session_closed_normally} = 1;
    # 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: $line");
	sleep 5;
	section_time('SMTP penalty wait');
    }
    my($taint) = substr($resp,0,0);
    $resp = sanitize_str($resp,1);
    if ($resp !~ /^ ([1-5]\d\d) (\ |-|$(?!\n))
		    ([245] \. \d{1,3} \. \d{1,3} (?: \ |$(?!\n)) )?
		    (.*) $(?!\n)/xs)
	{ die "Internal error(2): bad SMTP response code: '$resp'" }
    my($resp_code,$continuation,$enhanced,$tail) = ($1,$2,$3, $4.$taint);
    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.$taint }
	$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} . "> $resp");
	};
	print map($_."\015\012", @{$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.15';
    @ISA = qw(Exporter);
    @EXPORT_OK = qw(&sophos_savi_init);
}

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

use subs @EXPORT_OK;
use vars @EXPORT;

BEGIN {
  import Amavis::Conf qw(:platform :confvars);
  import Amavis::Util qw(do_log am_id retcode min max run_command);
  import Amavis::Timing qw(section_time);
}

use vars qw(%st_socket_created %st_sock); # keep persistent state (per-socket)
use vars qw($savi);

sub sophos_savi_init {
    my($av_name, $command) = @_;
    my(@savi_bool_options) = qw(
	FullSweep DynamicDecompression FullMacroSweep OLE2Handling
	IgnoreTemplateBit VBA3Handling VBA5Handling OF95DecryptHandling
	HelpHandling DecompressVBA5 Emulation PEHandling ExcelFormulaHandling
	PowerPointMacroHandling PowerPointEmbeddedHandling ProjectHandling
	ZipDecompression ArjDecompression RarDecompression UueDecompression
	GZipDecompression TarDecompression CmzDecompression HqxDecompression
	MbinDecompression !LoopBackEnabled
	Lha SfxArchives MSCabinet TnefAttachmentHandling MSCompress
	!DeleteAllMacros Vbe !ExecFileDisinfection VisioFileHandling
	Mime ActiveMimeHandling !DelVBA5Project
	ScrapObjectHandling SrpStreamHandling Office2001Handling
	Upx PalmPilotHandling HqxDecompression
	Pdf Rtf Html Elf WordB OutlookExpress
    );
    # starting with SAVI V3: Mac and SafeMacDfHandling options were removed;
    # new option GrpArchiveUnpack makes individual settings unnecessary;
    # option 'Mime' may cause a CPU loop when checking broken mail with older
    # versions of Sophos library
    my($savi) = SAVI->new;
    ref $savi or die "$av_name: Can't create a SAVI object, err=$savi";
    my($version) = $savi->version;
    ref $version or die "$av_name: Can't get SAVI version, err=$version";
    do_log(2, sprintf("$av_name init: Version %s (engine %d.%d) recognizing %d viruses\n",
	$version->string, $version->major, $version->minor, $version->count));
#   for ($version->ide_list)
#	{ do_log(2, sprintf("$av_name: IDE %s released %s", $_->name, $_->date)) }
    my($error) = $savi->set('MaxRecursionDepth', 16, 1);
    !defined $error or die "$av_name: error setting MaxRecursionDepth: err=$error";
    my($error) = $savi->set('NamespaceSupport', 3);  # new with Sophos 3.67
    !defined $error or do_log(0,"$av_name: error setting NamespaceSupport: err=$error");
    for (@savi_bool_options) {
	my($value) = /^!/ ? 0 : 1;  s/^!+//;
	$error = $savi->set($_, $value);
	!defined $error or die "$av_name: Error setting $_: err=$error";
    }
    section_time('sophos_savi_init');
    $savi;
}

# same args and returns as run_av() below
#
sub sophos_savi {
    my($tempdir, $av_name, $command, $savi_of_parent) = @_;
    if (defined $savi_of_parent) { $savi = $savi_of_parent }
    else { $savi = sophos_savi_init($av_name,$command)  if !defined $savi }
    my($scan_status,@virusname); my($output) = '';
    local(*DIR); my($f); my($cnt) = 0;
    opendir(DIR, "$tempdir/parts")
	or die "Can't open directory $tempdir/parts: $!";
    while (defined($f = readdir(DIR))) {
	my($fname) = "$tempdir/parts/$f";
	my($errn) = stat($fname) ? 0 : 0+$!;
	next  if $errn == ENOENT;
	if ($errn) { die "sophos_savi: $fname inaccessible: $!" }
	if (!-r _) { die "sophos_savi: $fname not readable" }
	next  if -d _ && ($f eq '.' || $f eq '..');  # this or parent directory
	next  if -z _;   # empty file
	$cnt++; do_log(5, "$av_name: checking $fname");
	my($result) = $savi->scan($fname);
	if (!ref($result)) {  # error
	    my($msg) = "$av_name: error scanning file $fname, " .
			$savi->error_string($result) . " ($result) $!";
	    if (! grep {$result == $_} (514,527,530,538,549) ) {
		die $msg;
	    } else { # don't panic on non-fatal (encrypted, corrupted, partial)
		do_log(0,$msg);
		$scan_status = 0  if !$scan_status;  # no viruses, no errors
	    }
	} elsif ($result->infected) {
	    $scan_status = 1;   # virus(es) found, no errors
	    my($msg) = "INFECTED $fname: " . join(", ",$result->viruses);
	    $output .= $msg.$eol;  do_log(2,"$av_name result: $msg");
	    push(@virusname, $result->viruses);
	} else {
	    $scan_status = 0  if !$scan_status;  # no viruses, no errors
	}
    }
    closedir(DIR) or die "Can't close directory: $!";
    if (!$cnt) { $scan_status = 0 }   # no errors, no viruses
    do_log(3,"$av_name result: clean")  if !$scan_status;
    ($scan_status,$output,\@virusname);
}

# same args and returns as run_av() below,
# but prepended by a $query, which is the string to be sent to the daemon.
# Handles both UNIX and INET domain sockets.
# More than one socket may be specified for redundancy, they will be tried
# one after the other until one succeeds.
#
sub ask_daemon_internal {
    my( $query, $tempdir,
	$av_name, $command, $args,
	$sts_clean, $sts_infected, $how_to_get_names, # regexps
      ) = @_;
    my($query_template,$sockets) = @$args;
    my($scan_status,$output,@virusname); my($socketname,$is_inet);
    if (!ref($sockets)) { $sockets = [ $sockets ] }
    my($max_retries) = 3 * @$sockets;  my($retries) = 0;
    $SIG{PIPE} = 'IGNORE';  # 'send' to broken pipe throws a signal
    for (;;) {  # gracefully handle cases when av child times out or restarts
	@$sockets >= 1 or die "no sockets specified!?";  # sanity
	$socketname = $sockets->[0];  # try the first one in the current list
	$is_inet = $socketname =~ m{^/} ? 0 : 1;
	eval {
	    if (!$st_socket_created{$socketname}) {
		do_log(3, "$av_name: Connecting to socket " .
			  join(' ',$daemon_chroot_dir,$socketname) .
			  (!$retries ? '' : ", retry #$retries") );
		if ($is_inet) {   # inet socket
		    $st_sock{$socketname} = IO::Socket::INET->new($socketname)
			or die "Can't connect to INET socket $socketname: $!\n";
		    $st_socket_created{$socketname} = 1;
		} else {          # unix socket
		    $st_sock{$socketname} = IO::Socket::UNIX->new(
			Type => SOCK_STREAM)
			or die "Can't create UNIX socket: $!\n";
		    $st_socket_created{$socketname} = 1;
		    $st_sock{$socketname}->connect(
			pack_sockaddr_un($socketname) )
			or die "Can't connect to UNIX socket $socketname: $!\n";
		}
	    }
	    do_log(3, sprintf("$av_name: Sending %s to %s socket $socketname",
			      $query, $is_inet ? "INET" : "UNIX"));
	    # 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}, $query, 0)
		or die "Can't send to socket $socketname: $!\n";
	    if ($av_name =~ /^(Sophie|Trophie)/i) {
		# Sophie and Trophie can accept multiple requests per session
		# and return a single line response each time
		defined $st_sock{$socketname}->recv($output, 1024)
		    or die "Can't receive from socket $socketname: $!\n";
	    } else {
		$output = join('', $st_sock{$socketname}->getlines);
		$st_sock{$socketname}->close
		    or die "Can't close socket $socketname: $!\n";
		$st_sock{$socketname}=undef; $st_socket_created{$socketname}=0;
	    }
	    $! = 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 <= $max_retries
	    or die "Too many retries to talk to $socketname ($@)";
	# is ECONNREFUSED for INET sockets common enough too?
	if ($retries <= 1 && $errn == EPIPE) {  # common, don't cause concern
	    do_log(2,"$av_name broken pipe (don't worry), retrying ($retries)");
	} else {
	    do_log( ($retries>1?0:1), "$av_name: $@, retrying ($retries)");
	    if ($retries % @$sockets == 0) { # every time the list is exhausted
		my($dly) = min(20, 1 + 5 * ($retries/@$sockets - 1));
		do_log(3,"$av_name: sleeping for $dly s");
		sleep($dly);   # 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;
	}
	# leave working socket as the first entry in the list
	# so that it will be tried first when needed again
	push(@$sockets, shift @$sockets)  if @$sockets>1; # circular shift left
    }
    do_log(3,"$av_name result: $output");
    if ($output =~ /$sts_infected/m) {
	@virusname = ref($how_to_get_names) eq 'CODE'
				? &$how_to_get_names($output)
				: $output =~ /$how_to_get_names/gm;
	$scan_status = 1;      # no errors, virus(es)
    } elsif ($output =~ /$sts_clean/m) {
	$scan_status = 0;      # no errors, no viruses
    } else {
	do_log(0,"$av_name FAILED - unknown status: $output");
    }
    ($scan_status,$output,\@virusname);
}

# same args and returns as run_av() below
sub ask_daemon {
    my($tempdir,$av_name,$command,$args) = @_;
    ref $args eq 'ARRAY'
	or die "The field#3 in the \@av_scanners entry is not an array ref";
    my($query_template) = $args->[0];
    $query_template =~ s[{}][$tempdir/parts]g;  # replace {} with dir name
    if ($query_template !~ /\*/) {  # scanner can be given a directory name
	return ask_daemon_internal($query_template, @_);
    } else {                        # must check each file individually
	my($scan_status,@virusname); my($output) = '';
	local(*DIR); my($f); my($cnt) = 0;
	opendir(DIR, "$tempdir/parts")
	    or die "Can't open directory $tempdir/parts: $!";
	while (defined($f = readdir(DIR))) {
	    my($fname) = "$tempdir/parts/$f";
	    my($errn) = stat($fname) ? 0 : 0+$!;
	    next  if $errn == ENOENT;
	    if ($errn) { die "ask_daemon: $fname inaccessible: $!" }
	    if (!-r _) { die "ask_daemon: $fname not readable" }
	    next  if -d _ && ($f eq '.' || $f eq '..');  # this or parent dir
	    next  if -z _;   # empty file
	    $cnt++; do_log(5, "$av_name: checking $fname");
	    my($query_template_exp) = $query_template;
	    $query_template_exp =~ s[\*][$f]g;  # replace * with bare file name
	    my($t_scan_status,$t_output,$t_virusnames) =
		ask_daemon_internal($query_template_exp, @_);
	    if ($t_scan_status) {  # virus(es) found in one part
		$scan_status = $t_scan_status;  # virus(es) found, no errors
		do_log(3,"$av_name result: $t_output");
		$output .= $t_output . $eol;
		push(@virusname, @$t_virusnames);
	    } elsif (!defined $t_scan_status) {
		last;  # error, bail out
	    } else {
		$scan_status = 0  if !$scan_status;  # no viruses, no errors
	    }
	}
	closedir(DIR) or die "$av_name: Can't close directory: $!";
	if (!$cnt) { $scan_status = 0 }   # no errors, no viruses
	do_log(3,"$av_name result: clean")  if !$scan_status;
	($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
      ) = @_;
    my($scan_status,$virusnames); my($output) = '';
    &$pre_code(@_)  if defined $pre_code;
    if (ref($command) eq 'CODE') {
	do_log(3,"Using $av_name: (built-in interface)");
	($scan_status,$output,$virusnames) = &$command(@_);
    } else {
	my(@args) = split(' ',$args);
	if (grep { m{^({}/)?\*$(?!\n)} } @args) { # list each file individually
	    local(*DIR); my($f); my(@bare_fnames);
	    opendir(DIR, "$tempdir/parts")
		or die "Can't open directory $tempdir/parts: $!";
	    while (defined($f = readdir(DIR))) {
		my($fname) = "$tempdir/parts/$f";
		my($errn) = stat($fname) ? 0 : 0+$!;
		next  if $errn == ENOENT;
		if ($errn) { die "run_av: $fname inaccessible: $!" }
		if (!-r _) { die "run_av: $fname not readable" }
		next  if -d _ && ($f eq '.' || $f eq '..'); #this or parent dir
		next  if -z _;   # empty file
		if ($f =~ /^([A-Za-z0-9_.-]+)$(?!\n)/s) { push(@bare_fnames,$1) }
		else { do_log(0, "run_av: WARN: refused to untaint: $f") }
	    }
	    closedir(DIR) or die "$av_name: Can't close directory: $!";
	    # replace * with bare file name
	    for my $a (@args) {
		$a =~ s[^({}/)?\*$(?!\n)][join(' ',map {$1.$_} @bare_fnames)]e;
	    }
	}
	for (@args) { s[{}][$tempdir/parts]g } # replace {} with directory name
	# NOTE: RAV does not like '</dev/null' in its command!
	do_log(3, "Using $av_name: " . join(' ',$command,@args));
	my($proc_fh) = run_command(undef, "&1", $command, @args);
	while( defined($_ = $proc_fh->getline) ) { $output .= $_ }
	my($err); $proc_fh->close or $err=$!; my($retval) = retcode($?);
	chomp($output); my($output_trimmed) = $output;
	$output_trimmed =~ s/([ \t\n\r])[ \t\n\r]{4,}/$1.../gs;
	$output_trimmed = "..." . substr($output_trimmed,-900)
			  if length($output_trimmed) > 900;
	do_log(3, "run_av: $command status=$retval ($? $err),$output_trimmed");
	# test for infected first, in case both expressions match
	if (ref($sts_infected) eq 'ARRAY' ? (grep {$_==$retval} @$sts_infected)
			: $output =~ /$sts_infected/m) {  # is infected
	    $virusnames = []; # get a list of virus names by parsing output
	    @$virusnames = ref($how_to_get_names) eq 'CODE'
				? &$how_to_get_names($output)
				: $output =~ /$how_to_get_names/gm;
	    @$virusnames = map {defined $_ ? $_ : ()} @$virusnames;
	    $scan_status = 1; # 'true' indicates virus found
	    do_log(5,"run_av: INFECTED: ".join(", ",@$virusnames));
	} elsif (ref($sts_clean) eq 'ARRAY' ? (grep {$_==$retval} @$sts_clean)
			: $output =~ /$sts_clean/m) {     # is clean
	    $scan_status = 0; # 'false' (but defined) indicates no viruses
	    do_log(5,"run_av: clean");
	} else {
	    do_log(0,"Virus scanner failure: $command (exit status: $retval)");
	}
	$output = $output_trimmed  if length($output) > 900;
    }
    &$post_code(@_)  if defined $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,@virusname,@detecting_scanners);
    my($anyone_done); my($anyone_tried);
    my(@errors); my($j); my($tier) = 'primary';
    for my $av (@av_scanners, "\000", @av_scanners_backup) {
	if ($av eq "\000") {  # 'magic' separator between lists
    	    last  if $anyone_done;
	    do_log(0,"WARN: all $tier virus scanners failed, trying backups");
	    $tier = 'secondary';  next;
	}
	next  if !defined $av || !ref $av || !defined $av->[1];
	$anyone_tried++;
	my($this_status,$this_output,$this_vn);
	eval { ($this_status,$this_output,$this_vn) = run_av($tempdir,@$av) };
	if ($@ ne '') {
	    my($err) = $@; chomp($err);
	    $err = "$av->[0] av-scanner FAILED: $err";
	    do_log(0,$err); push(@errors,$err);
	    $this_status = undef;
	};
	$anyone_done++  if defined $this_status;
	$scan_status = $this_status  if !defined $scan_status || $this_status;
	$output = $this_output  if !defined $output;
	$j++; section_time("AV-scan-$j");
	if ($this_status) {  # virus detected
	    push(@detecting_scanners, $av->[0]);
	    if (!@virusname)  # store results of the first scanner detecting
		{ @virusname = @$this_vn; $output = $this_output }
	    ### last;   # Want to stop if we found a virus? Naah!
	}
    }
    if (!$anyone_tried) { die "NO VIRUS SCANNERS AVAILABLE\n" }
    elsif (!$anyone_done)
	{ die ("ALL VIRUS SCANNERS FAILED: ".join("; ",@errors)."\n") }
    ($scan_status, $output, \@virusname, \@detecting_scanners); # return a quad
}

1;

__DATA__
package Amavis::SpamControl;
use strict;

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

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

use subs @EXPORT_OK;

use vars qw($spamassasin_obj);

# called at startup, before the main fork
sub init() {
    do_log(1, "SpamControl: initializing Mail::SpamAssassin");
    my($saved_umask) = umask;
    $spamassasin_obj = Mail::SpamAssassin->new({
	debug => $sa_debug,
	save_pattern_hits => $sa_debug,
	dont_copy_prefs   => 1,
	local_tests_only  => $sa_local_tests_only,
	home_dir_for_helpers => $helpers_home,
	stop_at_threshold => 0,
#	DEF_RULES_DIR     => '/usr/local/share/spamassassin',
#	LOCAL_RULES_DIR   => '/etc/mail/spamassassin',
    });
    if ($sa_auto_whitelist) {  # setup SpamAssassin auto-whitelisting
	do_log(1, "SpamControl: turning on SA auto-whitelisting (AWL)");
	# create a factory for the persistent address list
	my($addrlstfactory) = Mail::SpamAssassin::DBBasedAddrList->new;
	$spamassasin_obj->set_persistent_address_list_factory($addrlstfactory);
    }
    $spamassasin_obj->compile_now;	# ensure all modules etc. are preloaded
    alarm(0);              # seems like SA forgets to clear alarm in some cases
    umask($saved_umask);   # restore our umask
    do_log(1, "SpamControl: done");
}

# check envelope sender if white or blacklisted by each recipient;
# Saves the result in recip_blacklisted_sender and recip_whitelisted_sender
# properties of each recipient object.
#
sub white_black_list($$$$) {
    my($conn,$msginfo,$sql_wblist,$user_id_sql) = @_;
    my($any_w)=0; my($any_b)=0; my($all)=1; my($wr,$br);
    my($sender) = $msginfo->sender;
    do_log(4, "white_black_list: checking sender <$sender>");
    for my $r (@{$msginfo->per_recip_data}) {
	next if $r->recip_done;  # already dealt with
	my($wb,$user_id);  my($recip) = $r->recip_addr;
	if (defined($sql_wblist) &&
	    defined($user_id=lookup($recip,$user_id_sql)) )
	{
	    $wb = lookup($sender, Amavis::Lookup::SQLfield->new(
					     $sql_wblist,'wb','S',$user_id) );
	    if (!defined($wb) || $wb =~ /^[ \000]*$(?!\n)/) { # not specified (space)
		$wb = undef;
	    } elsif ($wb =~ /^[BbNnFf0][ ]*$(?!\n)/) {  # blacklisted (B or N)
		$wb=-1; $any_b++; $br=$recip; $r->recip_blacklisted_sender(1);
		do_log(5,"white_black_list: (SQL) recip <$recip> blacklisted sender <$sender>");
	    } else {                                    # whitelisted (W or Y)
		$wb=+1; $any_w++; $wr=$recip; $r->recip_whitelisted_sender(1);
		do_log(5,"white_black_list: (SQL) recip <$recip> whitelisted sender <$sender>");
	    }
	}
	if (!defined($wb)) {
	    # sender can be both white- and blacklisted at the same time
	    if (lookup($sender,
		       lookup($recip,$per_recip_blacklist_sender_lookup_tables),
		       \%blacklist_sender, \@blacklist_sender_acl,
		       $blacklist_sender_re)) {
		$wb=-1; $any_b++; $br=$recip; $r->recip_blacklisted_sender(1);
		do_log(5,"white_black_list: recip <$recip> blacklisted sender <$sender>");
	    }
	    if (lookup($sender,
		       lookup($recip,$per_recip_whitelist_sender_lookup_tables),
		       \%whitelist_sender, \@whitelist_sender_acl,
		       $whitelist_sender_re)) {
		$wb=+1; $any_w++; $wr=$recip; $r->recip_whitelisted_sender(1);
		do_log(5,"white_black_list: recip <$recip> whitelisted sender <$sender>");
	    }
	}
	$all = 0  if !$wb;
    }
    my($msg) = '';
    if    ($all && $any_w && !$any_b) { $msg = "whitelisted" }
    elsif ($all && $any_b && !$any_w) { $msg = "blacklisted" }
    elsif ($all) { $msg = "black or whitelisted by all recips" }
    elsif ($any_b || $any_w) {
	$msg.="whitelisted by ".($any_w>1?"$any_w recips, ":"$wr, ") if $any_w;
	$msg.="blacklisted by ".($any_b>1?"$any_b recips, ":"$br, ") if $any_b;
	$msg.="but not by all,";
    }
    do_log(2,"white_black_list: $msg sender <$sender>")  if $msg ne '';
    ($any_w+$any_b, $all);
}

# - 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) = @_;
    my($spam_level, $spam_status, $spam_report);
    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: ".
		  $msginfo->orig_body_size);
    } else {
	my($fh) = $msginfo->mail_text;
	$fh->seek(0,0) or die "Can't rewind mail file: $!";
	my(@lines); my($body_lines) = 0;
	push(@lines, sprintf('X-Envelope-From: %s'.$eol,
		     qquote_rfc2821_local($msginfo->sender)));
	push(@lines, sprintf('X-Envelope-To: %s'.$eol,
		     join(",\n ",qquote_rfc2821_local(@{$msginfo->recips}))));
	# read mail into memory in preparation for SpamAssasin
	while (<$fh>) { push(@lines,$_); last if $_ eq $eol }  # header
	while (<$fh>) { push(@lines,$_); $body_lines++ }       # body
	section_time('SA msg read');

	my($sa_required, $sa_tests);
	my($saved_umask) = umask;
	my($remaining_time) = alarm(0);  # check how much time is left
	eval {
	    # NOTE ON TIMEOUTS: SpamAssassin may use timer for its own purpose,
	    # disabling it before returning. It seems it only uses timer when
	    # external tests are enabled, so in order for our timeout to be
	    # useful, $sa_local_tests_only needs to be true (e.g. 1).
	    local $SIG{ALRM} = sub {
		my($s) = Carp::longmess("SA TIMED OUT, backtrace:");
		# crop at some arbitrary limit
		if (length($s) > 900) { $s = substr($s,0,900-3) . "..." }
		do_log(0,$s);
	    };
	    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);
	    { local($1,$2,$3,$4);  # avoid Perl 5.8.0 bug, $1 gets tainted
	      $per_msg_status = $spamassasin_obj->check($mail_obj);
	    }
	    my($rem_t) = alarm(0);
	    do_log(5, "RETURNED FROM NoMailAudit::check, time left: $rem_t s");

	    $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');
	umask($saved_umask);  # SA changes umask to 0077
	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;
    }
    my($msg) = "spam_scan: hits=$spam_level $spam_status";
    $msg =~ s/,\n /,/g;  do_log(2, $msg);
    ($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 both infected and noninfected messages (default):
[? %#V |[? %#F |[?%#D|Not-Delivered|Passed]|BANNED name/type (%F)]|INFECTED (%V)], #
<%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.
# Note that only valid header fields are allowed; non-standard header
# field heads must begin with "X-" .
#
Subject: Undeliverable mail[?%#X|#|, invalid characters in header]

Message-ID: <DSN%n@%h>

[? %#X |#|INVALID CHARACTERS IN HEADER

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

[? %#X ||
WHAT IS AN INVALID CHARACTER IN MAIL HEADER?

  The RFC 2822 standard specifies rules for forming internet messages.
  It does not allow the use of characters with codes above 127 to be used
  directly (non-encoded) in mail header (it also prohibits NUL and bare CR).

  If characters (e.g. with diacritics) from ISO Latin or other alphabets
  need to be included in the header, these characters need to be properly
  encoded according to RFC 2047. This encoding is often done transparently
  by mail reader (MUA), but if automatic encoding is not available (e.g.
  by some older MUA) it is the user's responsibility to avoid the use
  of such characters in mail header, or to encode them manually. Typically
  the offending header fields in this category are 'Subject', 'Organization',
  and comment fields in e-mail addresses of the 'From', 'To' and 'Cc'.

  Sometimes such invalid header fields are inserted automatically
  by some MUA, MTA, content checker, or other mail handling service.
  If this is the case, that service needs to be fixed or properly configured.
  Typically the offending header fields in this category are 'Date',
  'Received', 'X-Mailer', 'X-Priority', 'X-Scanned', etc.

  If you don't know how to fix or avoid the problem, please report it
  to _your_ postmaster or system manager.
]

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.
# Note that only valid header fields are allowed; non-standard header
# field heads must begin with "X-" .
#
Subject: [? %#V |[? %#F |[? %#X ||INVALID HEADER]|BANNED FILENAME (%F)]|VIRUS (%V)] IN MAIL FROM YOU
[? %m  |#|In-Reply-To: %m]
Message-ID: <VS%n@%h>

[? %#V |[? %#F |[? %#X ||INVALID CHARACTERS IN HEADER]|BANNED FILENAME ALERT]|VIRUS ALERT]

Our content checker found
[? %#V |#|    [? %#V |viruses|virus|viruses]: %V]
[? %#F |#|    banned [? %#F |names|name|names]: %F]
[? %#X |#|\n[%X\n]]
in your email to the following [? %#R |recipients|recipient|recipients]:[
-> %R]

Please check your system[?%#V|| for viruses],
or ask your system administrator to do so.

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

]#

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.
# Note that only valid header fields are allowed; non-standard header
# field heads must begin with "X-" .
#
Date: %d
From: %f
Subject: [? %#V |[? %#F |[? %#X ||INVALID HEADER]|BANNED NAME (%F)]|VIRUS (%V)]#
 FROM[?%l|| LOCAL] [?%o|(?)|<%o>]
To: [? %#T |undisclosed-recipients: ;|[<%T>|, ]]
[? %#C |#|Cc: [<%C>|, ]]
Message-ID: <VA%n@%h>

[? %#X |#|[%X\n]]
[? %#V |No viruses were found.
|A virus (%V) was found.
|Two viruses (%V) were found.
|%#V viruses were found.
]
[? %#F
|#|A banned name (%F) was found.
|Two banned names (%F) were found.
|%#F banned names were found.
]
[? %#W |#
|Scanner detecting a virus: %W
|Scanners detecting a virus: %W
]
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 WILL BE delivered to:[
%D]
]
[? %#N |#|The message WAS NOT delivered to:[
%N]
]
[? %#V |#|[? %#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.
# Note that only valid header fields are allowed; non-standard header
# field heads must begin with "X-" .
#
Date: %d
From: %f
Subject: [? %#V |[? %#F ||BANNED NAME]|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 NAME ALERT]|VIRUS ALERT]

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

   %o]

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

Please contact your system administrator for details.
__DATA__
#
# =============================================================================
# This is a template for SPAM SENDER NOTIFICATIONS.
# For syntax and customization instructions see README.customize.
# Note that only valid header fields are allowed; non-standard header
# field heads must begin with "X-" .
#
Subject: Considered UNSOLICITED BULK EMAIL from you
[? %m  |#|In-Reply-To: %m]
Message-ID: <SS%n@%h>

Your message to:[
-> %R]

was considered unsolicited bulk e-mail (UBE).
Subject: %j

[? %#D |Delivery of the email was stopped!
]#
#
# SpamAssassin report:
# [%A
# ]\
__DATA__
#
# =============================================================================
# This is a template for SPAM ADMINISTRATOR NOTIFICATIONS.
# For syntax and customization instructions see README.customize.
# Note that only valid header fields are allowed; non-standard header
# field heads must begin with "X-" .
#
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]
Subject: %j

[? %t |#|According to the 'Received:' trace, the message originated at:
   %t
]
[? %#D ||The message WILL BE 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 ------------------------------
