#!/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,2003,2004  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 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::Part
#  Amavis::Unpackers::OurFiler
#  Amavis::Unpackers::Validity
#  Amavis::Unpackers::MIME
#  Amavis::Notify
#  Amavis::Cache
#  Amavis
#optionally compiled-in packages: ---------------------------------------------
#  Amavis::Lookup::SQLfield
#  Amavis::Lookup::SQL
#  Amavis::Lookup::LDAP
#  Amavis::In::AMCL
#  Amavis::In::SMTP
#  Amavis::AV
#  Amavis::SpamControl
#  Amavis::Unpackers
#------------------------------------------------------------------------------

#
package Amavis::Boot;
use strict;
use re 'taint';

# 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::Handle IO::File IO::Socket IO::Socket::UNIX IO::Socket::INET
    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
  ));
  # with earlier versions of Perl one may need to add additional modules
  # to the list, such as: auto::POSIX::setgid auto::POSIX::setuid ...
  fetch_modules('OPTIONAL BASIC MODULES', 0, qw(
    Carp::Heavy auto::POSIX::setgid auto::POSIX::setuid
  ));
}

1;

#
package Amavis::Conf;
use strict;
use re 'taint';

# 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 = '2.01';
  @ISA = qw(Exporter);
  @EXPORT = ();
  @EXPORT_OK = ();
  %EXPORT_TAGS = (
    'confvars' => [qw(
      $myversion $mydomain
      $MYHOME $TEMPBASE $QUARANTINEDIR $db_home
      $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 $warnbadhrecip
      $log_templ
      $unix_socketname $inet_socket_port $inet_socket_bind @inet_acl
      $myhostname $localhost_name
      $amavis_auth_user $amavis_auth_pass
      $smtpd_greeting_banner $smtpd_quit_banner
      $insert_received_line $gets_addr_in_quoted_form
      $forward_method $relayhost_is_client
      $X_HEADER_TAG $X_HEADER_LINE $undecipherable_subject_tag
      $remove_existing_x_scanned_headers $remove_existing_spam_headers
      %local_delivery_aliases
      $hdr_encoding $bdy_encoding $hdr_encoding_qb
      $final_virus_destiny $final_spam_destiny
      $final_banned_destiny $final_bad_header_destiny
      $recipient_delimiter $replace_existing_extension
      $localpart_is_case_sensitive
      $addr_extension_virus $addr_extension_spam
      $addr_extension_banned $addr_extension_bad_header
      $smtpd_recipient_limit
      $MAXLEVELS $MAXFILES
      $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR
      $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR
      $per_recip_whitelist_sender_lookup_tables
      $per_recip_blacklist_sender_lookup_tables
      @lookup_sql_dsn $sql_key_fieldname
      $sql_select_policy $sql_select_white_black_list
      $bypass_decode_parts $banned_namepath_re
      $virus_check_negative_ttl $virus_check_positive_ttl
      $spam_check_negative_ttl $spam_check_positive_ttl

      $enable_ldap $default_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
      $spam_quarantine_to_ldap

      @local_domains_maps
      @bypass_virus_checks_maps @bypass_spam_checks_maps
      @bypass_banned_checks_maps @bypass_header_checks_maps
      @virus_lovers_maps @spam_lovers_maps
      @banned_files_lovers_maps @bad_header_lovers_maps
      @virus_admin_maps @spam_admin_maps
      @virus_quarantine_to_maps
      @banned_quarantine_to_maps @bad_header_quarantine_to_maps
      @spam_quarantine_to_maps @spam_quarantine_bysender_to_maps
      @keep_decoded_original_maps @map_full_type_to_short_type_maps
      @banned_filename_maps @viruses_that_fake_sender_maps
      @spam_tag_level_maps @spam_tag2_level_maps @spam_kill_level_maps
      @spam_modifies_subj_maps
      @whitelist_sender_maps @blacklist_sender_maps
    )],
    'notifyconf' => [qw(
      $notify_method
      $notify_xmailer_header
      $virus_quarantine_method
      $spam_quarantine_method
      $banned_files_quarantine_method
      $bad_header_quarantine_method
      $mailfrom_notify_sender
      $mailfrom_notify_recip
      $mailfrom_notify_admin
      $mailfrom_notify_spamadmin
      $mailfrom_to_quarantine
      $hdrfrom_notify_sender
      $hdrfrom_notify_recip
      $hdrfrom_notify_admin
      $hdrfrom_notify_spamadmin
      $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
    )],
    'unpack' => [qw(
      $file $arc $gzip $bzip2 $lzop $lha $unarj $uncompress $unfreeze
      $unrar $zoo $cpio $rpm2cpio $cabextract
    )],
    'sa' => [qw(
      $helpers_home $dspam
      $sa_tag_level_deflt $sa_tag2_level_deflt
      $sa_kill_level_deflt $sa_dsn_cutoff_level
      $sa_spam_subject_tag1 $sa_spam_subject_tag $sa_spam_modifies_subj
      $sa_spam_level_char $sa_spam_report_header
      $sa_local_tests_only $sa_debug $sa_mail_body_size_limit
      $sa_auto_whitelist $sa_timeout
    )],
    '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;

# private legacy variables, predeclared for compatibility use in amavisd.conf
# The rest of the program does not use them directly and they should not be
# visible in other modules, but may be referenced throgh @*_maps variables.
use vars qw(
  %local_domains @local_domains_acl $local_domains_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
  %virus_admin %spam_admin $virus_admin $spam_admin
  $virus_quarantine_to $banned_quarantine_to $bad_header_quarantine_to
  $spam_quarantine_to $spam_quarantine_bysender_to
  $keep_decoded_original_re $map_full_type_to_short_type_re
  $banned_filename_re $viruses_that_fake_sender_re
  %whitelist_sender @whitelist_sender_acl $whitelist_sender_re
  %blacklist_sender @blacklist_sender_acl $blacklist_sender_re
);

$myversion = 'amavisd-new-20040415';

$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';#intentionally bad default

# Create debugging output - true: log to stderr; false: 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 by 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;

# expiration time of cached results: time to live in seconds
# (how long the result of a virus/spam test remains valid)
$virus_check_negative_ttl=  3*60; # time to remember that mail was not infected
$virus_check_positive_ttl= 30*60; # time to remember that mail was infected
$spam_check_negative_ttl = 30*60; # time to remember that mail was not spam
$spam_check_positive_ttl = 30*60; # time to remember that mail was spam
#
# NOTE:
#   Cache size will be determined by the largest of the $*_ttl values.
#   Depending on the mail rate, the cache database may grow quite large.
#   Reasonable compromise for the max value is 15 minutes to 2 hours.

# Customizable notification messages, logging

$SYSLOG_LEVEL = "mail.info";

# 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'};
#
# $spam_quarantine_to_ldap = {res_attr => 'amavisSpamQuarantineTo'};
#
# $local_domains_ldap = {
#   query_filter => '(&(objectClass=mailDomain)(dc=%m))
#   res_filter => 'OK'};

# 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 (wblist.rid=?) AND (wblist.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 ::1 );  # allow SMTP access only from localhost

$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';
$banned_files_quarantine_method = 'local:banned-%i-%n';
$bad_header_quarantine_method   = 'local:badh-%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

# encoding (encoding in MIME context terminology)
$hdr_encoding_qb = 'Q';        # quoted-printable (default)
#$hdr_encoding_qb = 'B';  # base64           (usual for far east charsets)

$smtpd_recipient_limit = 1100;  # 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];

$smtpd_greeting_banner = '${helo-name} ${protocol} amavisd-new service ready';
$smtpd_quit_banner = '${helo-name} (amavisd-new) closing transmission channel';

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

# SMTP AUTH username and password for notification submissions
$amavis_auth_user = undef;  # or perhaps: 'amavisd'
$amavis_auth_pass = undef;

# 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 malware
#   Specify undef to disable, or 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  = 'virus-quarantine';   # %local_delivery_aliases mapped
$banned_quarantine_to = 'banned-quarantine';  # %local_delivery_aliases mapped
$bad_header_quarantine_to = 'bad-header-quarantine'; # %local_delivery_aliases
$spam_quarantine_to   = 'spam-quarantine';    # %local_delivery_aliases mapped

# similar to $spam_quarantine_to, but the lookup key is the sender address
$spam_quarantine_bysender_to = undef;  # dflt: no by-sender spam quarantine

# 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_tag1  = undef;  # example: '***possible SPAM*** '
$sa_spam_subject_tag   = undef;  # example: '***SPAM*** '
$sa_spam_modifies_subj = 1;      # true for compatibility; can be a
                                 # lookup table indicating per-recip settings
$undecipherable_subject_tag = '***UNCHECKED*** ';

$sa_spam_level_char = '*';  # character to be used in X-Spam-Level bar;
                            # empty or undef disables adding this header field
$sa_spam_report_header = 0; # insert X-Spam-Report header field?
$sa_local_tests_only = 0;
$sa_debug = 0;
$sa_timeout = 30;           # timeout in seconds for a call to SpamAssassin

# 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 amavisd-new, or by MTA. 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 and dual-sendmail setup 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 contents;
#
# D_DISCARD  mail will not be delivered to its recipients, sender will NOT be
#            notified. Effectively we lose mail (but it 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_maps, 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 lists in @local_domains_maps are not affected (i.e.
# non-local recipients).
#
# 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 local delivery agent (LDA).

$addr_extension_virus  = undef;      # or set to: 'virus'  for example
$addr_extension_spam   = undef;      # or set to: 'spam'   for example
$addr_extension_banned = undef;      # or set to: 'banned' for example
$addr_extension_bad_header = undef;  # or set to: 'badh'   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;

# first match wins, more specific entries should precede general ones!
$map_full_type_to_short_type_re = Amavis::Lookup::RE->new(
  [qr/^empty\z/                       => 'empty'],
  [qr/^directory\z/                   => 'dir'],
  [qr/^can't (stat|read)\b/           => 'dat'],  # file(1) diagnostics
  [qr/^cannot open\b/                 => 'dat'],  # file(1) diagnostics
  [qr/^ERROR: Corrupted\b/            => 'dat'],  # file(1) diagnostics
  [qr/can't read magic file|couldn't find any magic files/ => 'dat'],
  [qr/^data\z/                        => 'dat'],

  [qr/^ISO-8859.*\btext\b/            => 'txt'],
  [qr/^Non-ISO.*ASCII\b.*\btext\b/    => 'txt'],
  [qr/^Unicode\b.*\btext\b/i          => 'txt'],
  [qr/^'diff' output text\b/          => 'txt'],
  [qr/^HTML document text\b/          => 'html'],
  [qr/^GNU message catalog\b/         => 'mo'],
  [qr/^PGP encrypted data\b/          => 'pgp'],
  [qr/^PGP armored data( signed)? message\b/ => 'pgp.asc'],
  [qr/^PGP armored\b/                 => 'pgp.asc'],

### 'file' is a bit too trigger happy to claim something is 'mail text'
# [qr/^RFC 822 mail text\b/           => 'mail'],
  [qr/^(ASCII|smtp|RFC 822) mail text\b/ => 'txt'],

  [qr/^JPEG image data\b/             => 'jpg'],
  [qr/^GIF image data\b/              => 'gif'],
  [qr/^PNG image data\b/              => 'png'],
  [qr/^TIFF image data\b/             => 'tif'],
  [qr/^PC bitmap data\b/              => 'bmp'],
  [qr/^PCX\b.*\bimage data\b/         => 'pcx'],
  [qr/^MP3\b/                         => 'mp3'],
  [qr/^MPEG\b.*\bstream data\b/       => 'mpeg'],
  [qr/^RIFF\b.*\bAVI\b/               => 'avi'],
  [qr/^RIFF\b.*\bWAVE audio\b/        => 'wav'],
  [qr/^Macromedia Flash data\b/       => 'swf'],

  [qr/^PostScript document text\b/    => 'ps'],
  [qr/^PDF document\b/                => 'pdf'],
  [qr/^Rich Text Format data\b/       => 'rtf'],
  [qr/^Microsoft Office Document\b/   => 'doc'],
  [qr/^LaTeX\b.*\bdocument text\b/    => 'lat'],
  [qr/^TeX DVI file\b/                => 'dvi'],
  [qr/^XML document text\b/           => 'xml'],
  [qr/^exported SGML document text\b/ => 'sgml'],
  [qr/^compiled Java class data\b/    => 'java'],
  [qr/^MS Windows 95 Internet shortcut text\b/ => 'url'],

  [qr/^frozen\b/                      => 'F'],
  [qr/^gzip compressed\b/             => 'gz'],
  [qr/^bzip2? compressed\b/           => 'bz2'],
  [qr/^lzop compressed\b/             => 'lzo'],
  [qr/^compress'd/                    => 'Z'],
  [qr/^Zip archive\b/i                => 'zip'],
  [qr/^RAR archive\b/i                => 'rar'],
  [qr/^LHa.*\barchive\b/i             => 'lha'],  # or .lzh
  [qr/^ARC archive\b/i                => 'arc'],
  [qr/^ARJ archive\b/i                => 'arj'],
  [qr/^Zoo archive\b/i                => 'zoo'],
  [qr/^(?:GNU |POSIX )?tar archive\b/i=> 'tar'],
  [qr/^(?:ASCII )?cpio archive\b/i    => 'cpio'],
  [qr/^RPM\b/ => 'rpm'],
  [qr/^(Transport Neutral Encapsulation Format|TNEF)\b/i => 'tnef'],
  [qr/^Microsoft cabinet file\b/      => 'cab'],

  [qr/^(uuencoded|xxencoded)\b/i      => 'uue'],
  [qr/^binhex\b/i                     => 'hqx'],
  [qr/^(ASCII|text)\b/i               => 'asc'],
  [qr/^Emacs.*byte-compiled Lisp data/i => 'asc'],  # BinHex with an empty line
  [qr/\bscript text executable\b/     => 'txt'],

  [qr/^MS-DOS\b.*\bexecutable\b/      => 'exe-ms'],
  [qr/^MS Windows\b.*\bexecutable\b/  => 'exe-ms'],
  [qr/^PA-RISC.*\bexecutable\b/       => 'exe-unix'],
  [qr/^ELF .*\bexecutable\b/          => 'exe-unix'],
  [qr/^COFF format .*\bexecutable\b/  => 'exe-unix'],
  [qr/^executable \(RISC System\b/    => 'exe-unix'],

  [qr/\bexecutable\b/i                => 'exe'],
  [qr/\btext\b/i                      => 'asc'],
);

# MS Windows PE 32-bit Intel 80386 GUI executable not relocatable
# MS-DOS executable (EXE), OS/2 or MS Windows
# PA-RISC1.1 executable dynamically linked
# PA-RISC1.1 shared executable dynamically linked
# ELF 64-bit LSB executable, Alpha (unofficial), version 1 (FreeBSD), for FreeBSD 5.0.1, dynamically linked (uses shared libs), stripped
# ELF 64-bit LSB executable, Alpha (unofficial), version 1 (SYSV), for GNU/Linux 2.2.5, dynamically linked (uses shared libs), stripped
# ELF 64-bit MSB executable, SPARC V9, version 1 (FreeBSD), for FreeBSD 5.0, dynamically linked (uses shared libs), stripped
# ELF 64-bit MSB shared object, SPARC V9, version 1 (FreeBSD), stripped
# ELF 32-bit LSB executable, Intel 80386, version 1, dynamically`
# ELF 32-bit MSB executable, SPARC, version 1, dynamically linke`
# COFF format alpha executable paged stripped - version 3.11-10
# COFF format alpha executable paged dynamically linked stripped`
# COFF format alpha demand paged executable or object module stripped - version 3.11-10
# COFF format alpha paged dynamically linked not stripped shared`
# executable (RISC System/6000 V3.1) or obj module

# 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(@_) }

sub build_default_maps() {
  @local_domains_maps = (
    \%local_domains, \@local_domains_acl, \$local_domains_re);
  @bypass_virus_checks_maps = (
    \%bypass_virus_checks, \@bypass_virus_checks_acl, \$bypass_virus_checks_re);
  @bypass_spam_checks_maps = (
    \%bypass_spam_checks, \@bypass_spam_checks_acl, \$bypass_spam_checks_re);
  @bypass_banned_checks_maps = (
    \%bypass_banned_checks, \@bypass_banned_checks_acl, \$bypass_banned_checks_re);
  @bypass_header_checks_maps = (
    \%bypass_header_checks, \@bypass_header_checks_acl, \$bypass_header_checks_re);
  @virus_lovers_maps = (
    \%virus_lovers, \@virus_lovers_acl, \$virus_lovers_re);
  @spam_lovers_maps = (
    \%spam_lovers, \@spam_lovers_acl, \$spam_lovers_re);
  @banned_files_lovers_maps = (
    \%banned_files_lovers, \@banned_files_lovers_acl, \$banned_files_lovers_re);
  @bad_header_lovers_maps = (
    \%bad_header_lovers, \@bad_header_lovers_acl, \$bad_header_lovers_re);
  @virus_admin_maps = (\%virus_admin, \$virus_admin);
  @spam_admin_maps  = (\%spam_admin,  \$spam_admin);
  @virus_quarantine_to_maps = (\$virus_quarantine_to);
  @banned_quarantine_to_maps = (\$banned_quarantine_to);
  @bad_header_quarantine_to_maps = (\$bad_header_quarantine_to);
  @spam_quarantine_to_maps = (\$spam_quarantine_to);
  @spam_quarantine_bysender_to_maps = (\$spam_quarantine_bysender_to);
  @keep_decoded_original_maps = (\$keep_decoded_original_re);
  @map_full_type_to_short_type_maps = (\$map_full_type_to_short_type_re);
  @banned_filename_maps = (\$banned_filename_re);
  @viruses_that_fake_sender_maps = (\$viruses_that_fake_sender_re);
  @spam_tag_level_maps  = (\$sa_tag_level_deflt);
  @spam_tag2_level_maps = (\$sa_tag2_level_deflt);
  @spam_kill_level_maps = (\$sa_kill_level_deflt);
  @spam_modifies_subj_maps = (\$sa_spam_modifies_subj);
  @whitelist_sender_maps = (
    \%whitelist_sender, \@whitelist_sender_acl, \$whitelist_sender_re);
  @blacklist_sender_maps = (
    \%blacklist_sender, \@blacklist_sender_acl, \$blacklist_sender_re);
}

# 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: $@" }
  # some sensible defaults for essential settings
  $TEMPBASE     = $MYHOME                if !defined $TEMPBASE;
  $helpers_home = $MYHOME                if !defined $helpers_home;
  $db_home      = "$MYHOME/db"           if !defined $db_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_recip = "amavisd-new <postmaster\@$myhostname>"
    if !defined $hdrfrom_notify_recip;
  $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 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;
use re 'taint';

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

use Time::HiRes qw(time);

use vars qw(@timing @counter_names);

# clear array @timing and enter start time
sub init() {
  @timing = (); @counter_names = ();
  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));
}

sub snmp_count(@) { push(@counter_names, @_) }
sub get_snmp_counters() { \@counter_names }

use vars qw($t_was_busy $t_busy_cum $t_idle_cum $t0);

sub idle_proc(@) {
  my($t1) = time;
  if (defined $t0) {
    ($t_was_busy ? $t_busy_cum : $t_idle_cum) += $t1 - $t0;
    Amavis::Util::do_log(5,
      sprintf("HERE @_: was %s, %.1f ms, total idle %.3f s, busy %.3f s",
        $t_was_busy ? "busy" : "idle", 1000 * ($t1 - $t0),
        $t_idle_cum, $t_busy_cum));
  }
  $t0 = $t1;
}

sub go_idle(@) {
  if ($t_was_busy) { idle_proc(@_); $t_was_busy = 0 }
}

sub go_busy(@) {
  if (!$t_was_busy) { idle_proc(@_); $t_was_busy = 1 }
}

sub report_load() {
  return if $t_busy_cum + $t_idle_cum <= 0;
  Amavis::Util::do_log(3, sprintf(
     "load: %.0f %%, total idle %.3f s, busy %.3f s",
     100*$t_busy_cum / ($t_busy_cum + $t_idle_cum), $t_idle_cum, $t_busy_cum));
}

1;

#
package Amavis::Lock;
use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @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: $!";
}

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

1;

#
package Amavis::Log;
use strict;
use re 'taint';

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

  if ($syslog_level =~ /^\s*([a-z0-9]+)\.([a-z0-9]+)\s*\z/i) {
    $syslog_facility = eval("LOG_\U$1");
    $syslog_priority = eval("LOG_\U$2");
  }
  $syslog_facility = LOG_DAEMON  if $syslog_facility !~ /^\d+\z/;
  $syslog_priority = LOG_WARNING if $syslog_priority !~ /^\d+\z/;
  if ($do_syslog) {
    openlog($ident, LOG_PID, $syslog_facility);
  } else {
    $loghandle = IO::File->new($logfile,'>>')
      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{LC_TYPE}"   if $ENV{LC_TYPE} ne '';
  $msg .= ", LC_CTYPE=$ENV{LC_CTYPE}" if $ENV{LC_CTYPE} 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);
    seek($loghandle,0,2) or die "Can't position log file to its tail: $!";
    print $loghandle $prefix, $am_id, $errmsg, $eol;
    unlock($loghandle);
  }
}

1;

#
package Amavis::Util;
use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = ();
  @EXPORT = ();
  @EXPORT_OK = qw(&untaint &min &max
                  &safe_encode &am_id &new_am_id &do_log &debug_oneshot
                  &retcode &exit_status_str &prolong_timer &sanitize_str
                  &strip_tempdir &rmdir_recursively &rmdir_flat
                  &read_text &read_l10n_templates &read_hash &run_command);
}
use subs @EXPORT_OK;
use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);
use Errno qw(ENOENT);
use Digest::MD5;
# use Encode;  # Perl 5.8  UTF-8 support
# use Encode::CN;  # example: explicitly load Chinese module

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

# Return untainted copy of the argument (which can be a string or a string ref)
sub untaint($) {
  no re 'taint';
  my($str) = @_;
  local($1);  # avoid Perl taint bug: tainted global $1 propagates taintedness
  $str = $1  if (ref($str) ? $$str : $str) =~ /^(.*)\z/s;
  $str;
}

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

# 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 = untaint(\$str);
    $taint . Encode::encode($encoding, $str, $check);  # reattach 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
}

sub new_am_id($;$$) {
  my($str, $cnt, $seq) = @_;
  my($id);
# my($ctx) = Digest::MD5->new; # 128 bits (32 hex digits)
# $ctx->add($str.$$);
# $id = substr($ctx->hexdigest, 0, 6);
  $id = defined $str ? $str : sprintf("%05d", $$);
  $id .= sprintf("-%02d", $cnt) if defined $cnt;
  $id .= "-$seq" if $seq > 1;
  am_id($id);
}

# 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 exit_status_str($;$) {
  my($stat,$err) = @_; my($str);
  if (WIFEXITED($stat)) {
    $str = sprintf("exit %d", WEXITSTATUS($stat));
  } elsif (WIFSTOPPED($stat)) {
    $str = sprintf("stopped, signal %d", WSTOPSIG($stat));
  } else {
    $str = sprintf("DIED on signal %d", WTERMSIG($stat));
  }
  $str .= ', '.$err  if $err ne '';
  $str;
}

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

# Mostly for debugging and reporting purposes:
# Convert nonprintable characters in the argument
# to \[rnftbe], or \octal code, and '\' to '\\',
# 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, file email.txt, and 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;
  do_log(4, "strip_tempdir: $dir");
  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($;$);  # prototype
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))) {
    my($msg);
    my($errn) = lstat("$dir/$f") ? 0 : 0+$!;
    if    ($errn == ENOENT) { $msg = "does not exist" }
    elsif ($errn)           { $msg = "inaccessible: $!" }
    if (defined $msg) { die "rmdir_recursively: \"$dir/$f\" $msg" }
    next  if ($f eq '.' || $f eq '..') && -d _;
    $f = untaint(\$f);
    if (-d _) {
      rmdir_recursively("$dir/$f", 0);
    } 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))) {
    my($msg);
    my($errn) = lstat("$dir/$f") ? 0 : 0+$!;
    if    ($errn == ENOENT) { $msg = "does not exist" }
    elsif ($errn)           { $msg = "inaccessible: $!" }
    if (defined $msg) { die "rmdir_flat: \"$dir/$f\" $msg" }
    next  if ($f eq '.' || $f eq '..') && -d _;
    $f = untaint(\$f);
    if (-d _) {
      die "Refused to unlink a subdirectory $dir/$f";
    } else {
      unlink("$dir/$f") or die "Can't remove file $dir/$f: $!";
    }
  }
  closedir(DIR) or die "Can't close directory $dir: $!";
  rmdir($dir)   or die "Can't remove directory $dir: $!";
  1;
}

# 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,'<') 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 $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. Used by the Debian distribution.
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");
  if ($file_chset =~ m{^(?:#[^\n]*\n)*([^./\n\s]+)(\s*[#\n].*)?$}s) {
    $file_chset = $1;
  } 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);
}

#use CDB_File;
#sub tie_hash($$) {
# my($hashref, $filename) = @_;
# CDB_File::create(%$hashref, $filename, "$filename.tmp$$")
#   or die "Can't create cdb $filename: $!";
# my($cdb) = tie(%$hashref,'CDB_File',$filename)
#   or die "Tie to $filename failed: $!";
# $hashref;
#}

# read a lookup hash from file - may be called from amavisd.conf .
#
# Format: one key per line, anything from '#' to the end of line
# is considered 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 part of the string).
# Lines may contain a pair: key value, separated by whitespace, or key only,
# in which case a value 1 is implied. Trailing whitespace is discarded,
# empty lines (containing only whitespace and comment) are ignored.
# Addresses (lefthand-side) are converted from rfc2821-quoted form
# into internal (raw) form and inserted as keys into a given hash.
# NOTE: the format is partly compatible with Postfix maps (not aliases):
#   no continuation lines are honoured, Postfix maps do not allow
#   rfc2821-quoted addresses containing whitespace, Postfix only allow
#   comments starting at the beginning of the line.
#
# The $hashref argument is returned for convenience, so that one can do
# 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') }
# or even simpler:
#   $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,'<') or die "Can't open file $filename for reading: $!";
  while (<$inp>) {  # carefully handle comments, '#' within "" does not count
    chomp;
    my($lhs) = ''; my($rhs) = ''; my($at_rhs) = 0;
    for my $t ( /\G ( " (?: \\. | [^"\\] )* " |
                      [^#" \t]+ | [ \t]+ | . )/gcsx) {
      last  if $t eq '#';
      if (!$at_rhs && $t =~ /^[ \t]+\z/) { $at_rhs = 1 }
      else { ($at_rhs ? $rhs : $lhs) .= $t }
    }
    $rhs =~ s/[ \t]+\z//;  # trim trailing whitespace
    next  if $lhs eq '' && $rhs eq '';
    my($addr) = Amavis::rfc2821_2822_Tools::unquote_rfc2821_local($lhs);
    my($localpart,$domain) = Amavis::rfc2821_2822_Tools::split_address($addr);
    $localpart = lc($localpart)  if !$localpart_is_case_sensitive;
    $addr = $localpart . lc($domain);
    $hashref->{$addr} = $rhs eq '' ? 1 : $rhs;
    # do_log(5, "read_hash: address: <$addr>: ".$hashref->{$addr});
  }
  $inp->close or die "Can't close $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. Use 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, catching errors
  if ($@ ne '') { chomp($@); die "run_command (open pipe): $@" }
  defined($pid) or die "run_command: can't fork: $!";
  if (!$pid) {                           # child
    eval {  # must not use die in child process, or we end up with
            # two running daemons! Close all unneeded files.
#     use Devel::Symdump ();
#     my($dumpobj) = Devel::Symdump->rnew;
#     for my $k ($dumpobj->ios) {
#       no strict 'refs';
#       my($fn) = fileno($k);
#       if ($fn == 1 || $fn == 2) {
#         do_log(2,sprintf("KEEPING %s, fileno=%s", $k, $fn));
#       } else {
#         $! = undef; close(*{$k}{IO}) and do_log(0, "DID CLOSE $k (fileno=$fn)");
#       }
#     }
      close(STDIN)       or die "Can't close STDIN: $!";
      close(main::stdin) or die "Can't close main::stdin: $!";
      open(STDIN, "<$stdin_from")
        or die "Can't reopen STDIN on $stdin_from: $!";
      fileno(STDIN) == 0 or die "run_command: STDIN not fd0";
      if ($stderr_to ne '') {
        close(STDERR) or die "Can't close STDERR: $!";
        open(STDERR, ">$stderr_to")
          or die "Can't open STDERR to $stderr_to: $!";
        fileno(STDERR) == 2 or die "run_command: STDERR not fd2";
      }
      # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
      { no warnings;
        exec {$cmd} ($cmd,@args)
          or do_log(0,"Can't exec program $cmd: $!");
        exec('/usr/bin/false');  # must not exit, we have to avoid DESTROY handlers
        exec('/bin/false'); exec('false'); exec('true');  # still kicking? die!
        exit 1;                # better safe than sorry
                               # NOTREACHED
      }
    };
    chomp($@);
    do_log(0,"run_command: child process [$$] failed to exec $cmd_text: $@");
    { no warnings;
      exec('/usr/bin/false');  # must not exit, we have to avoid DESTROY handlers
      exec('/bin/false'); exec('false'); exec('true');  # still kicking? die!
      do_log(0,"run_command: TROUBLE - Panic, can't die");
      exit 1;                  # better safe than sorry
                               # NOTREACHED
    }
  }
  # parent
  do_log(5,"run_command: [$pid] $msg");
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  $proc_fh;  # return subprocess file handle
}

1;

#
package Amavis::rfc2821_2822_Tools;
use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = ();
  @EXPORT = qw(
    &rfc2822_timestamp &received_line &parse_received
    &fish_out_ip_from_received &split_address &split_localpart &make_query_keys
    &quote_rfc2821_local &qquote_rfc2821_local &unquote_rfc2821_local
    &one_response_for_all
    &EX_OK &EX_NOUSER &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_NOUSER()      {67} } unless defined(&EX_NOUSER);
  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
                         $recipient_delimiter $localpart_is_case_sensitive);
  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*\z/;
  setlocale(LC_CTYPE, $old_locale);
  $s;
}

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

sub parse_received($) {
  my($received) = @_;
  local($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11);
  $received =~ s/\n([ \t])/$1/g;  # unfold
  $received =~ s/[\n\r]//g;       # delete remaining newlines if any
  my(%fields);
  while ($received =~ m{\G\s*
            ( \b(from|by) \s+ ( (?: \[ (?: \\. | [^\]\\] )* \] | [^;\s\[] )+ )
              (?: \s* \( (?: ( [^\s\[]+ ) \s+ )?
                         \[ ( (?: \\. | [^\]\\] )* ) \] \s*
                      \) )?
              (?: .*? ) (?= \(|;|\z|\b(?:from|by|via|with|id|for)\b )  # junk
            | \b(via|with|id|for) \s+
              ( (?:  "  (?: \\. | [^"\\]  )* "
                  |  \[ (?: \\. | [^\]\\] )* \]
                  |  \\. | .
                )+? (?= \(|;|\z|\b(?:from|by|via|with|id|for)\b ) )
            | (;) \s* ( .*? ) \s* \z                                   # time
            | (.*?) (?= \(|;|\z|\b(?:from|by|via|with|id|for)\b )      # junk
            ) ( (?: \s+ | (?: \( (?: \\. | [^)\\] )* \) ) )* ) }xgcsi)
  {
    my($v1, $v2, $v3, $comment) = ('') x 4;
    my($item, $field) = ($1, lc($2 || $6 || $8));
    if ($field eq 'from' || $field eq 'by') {
      ($v1, $v2, $v3, $comment) = ($3, $4, $5, $11);
    } elsif ($field eq ';') {  # time
      ($v1, $comment) = ($9, $11);
    } elsif ($10 eq '') {      # via|with|id|for
      ($v1, $comment) = ($7, $11);
    } else {                   # junk
      ($v1, $comment) = ($10, $11);
    }
    $comment =~ s/^\s+//;
    $comment =~ s/\s+\z//;
    $item    =~ s/^\Q$field\E\s*//i;
    if (!exists $fields{$field}) {
      $fields{$field} = [$item, $v1, $v2, $v3, $comment];
      do_log(5, "parse_received: $field = $item/$v1/$v2/$v3")  if $field ne '';
    }
  }
  \%fields;
}

sub fish_out_ip_from_received($) {
  my($received) = @_;
  my($ip);
  my($fields_ref) = parse_received($received);
  if (defined $fields_ref && exists $fields_ref->{'from'}) {
    my($item, $v1, $v2, $v3, $comment) = @{$fields_ref->{'from'}};
    for ($v3, $v2, $v1, $comment, $item) {
      if (/   \[ (\d{1,3} (?: \. \d{1,3}){3}) \] /x) {
        $ip = $1;  last;
      } elsif (/ (\d{1,3} (?: \. \d{1,3}){3}) (?!\d) /x) {
        $ip = $1;  last;
      } elsif (/ \[ (IPv6:)? ( ([0-9a-zA-Z]* : ){2,} [0-9a-zA-Z:.]* ) \] /xi) {
        $ip = $2;  last;
      }
    }
    do_log(5, "fish_out_ip_from_received: $ip, $item");
  }
  !defined($ip) ? undef : $ip;  # undef need not be tainted
}

# 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.
# Does not handle explicit route paths.
#
sub split_address($) {
  my($mailbox) = @_;
  $mailbox =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\]\\] )*  \]
                                 |  [^@"<>\[\]\\\s] )*
                       ) \z/xs ? ($1, $2) : ($mailbox, '');
}

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

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

# For a given email address (e.g. for User+Foo@sub.exAMPLE.COM)
# prepare and return a list of lookup keys in the following sequence:
#   User+Foo@sub.exAMPLE.COM   (as-is, no lowercasing)
#   user+foo@sub.example.com
#   user@sub.example.com (only if $recipient_delimiter nonempty)
#   user+foo(@) (only if $include_bare_user)
#   user(@)     (only if $include_bare_user and $recipient_delimiter nonempty)
#   (@)sub.example.com
#   (@).sub.example.com
#   (@).example.com
#   (@).com
#   (@).
# Note about (@): if $at_with_user is true the user-only keys (without domain)
# get an '@' character appended (e.g. 'user+foo@'). Usual for lookup_hash.
# If $at_with_user is false the domain-only (no user localpart) keys
# get a '@' prepended (e.g. '@.example.com'). Usual for lookup_sql.
#
# The domain part is always matched case-insensitively,
# the localpart is lowercased iff $localpart_is_case_sensitive is true.
#
sub make_query_keys($$$) {
  my($addr,$at_with_user,$include_bare_user) = @_;
  my($localpart,$domain) = split_address($addr); $domain = lc($domain);
  my($saved_full_localpart) = $localpart;
  $localpart = lc($localpart)  if !$localpart_is_case_sensitive;
  # chop off leading @, and trailing dots
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  my($extension);
  if ($recipient_delimiter ne '') {
    ($localpart,$extension) = split_localpart($localpart,$recipient_delimiter);
    $extension = lc($extension)  if !$localpart_is_case_sensitive;
  }
  my($append_to_user,$prepend_to_domain) = $at_with_user ? ('@','') : ('','@');
  my(@keys);  # a list of query keys
  push(@keys, $addr);                        # as is
  push(@keys, $localpart.$recipient_delimiter.$extension.'@'.$domain)
    if $extension ne '';                     # user+foo@example.com
  push(@keys, $localpart.'@'.$domain);       # user@example.com
  if ($include_bare_user) {  # typically enabled for local users only
    push(@keys, $localpart.$recipient_delimiter.$extension.$append_to_user)
      if $extension ne '';                   # user+foo(@)
    push(@keys, $localpart.$append_to_user); # user(@)
  }
  push(@keys, $prepend_to_domain.$domain);   # (@)sub.example.com
  if ($domain !~ /\[/) {     # don't split address literals
    my(@dkeys); my($d) = $domain;
    for (;;) {               # (@).sub.example.com (@).example.com (@).com (@).
      push(@dkeys, $prepend_to_domain.'.'.$d);
      last  if $d eq '';
      $d = ($d =~ /^([^.]*)\.(.*)\z/s) ? $2 : '';
    }
    if (@dkeys > 10) { @dkeys = @dkeys[$#dkeys-9 .. $#dkeys] }  # sanity limit
    push(@keys,@dkeys);
  }
  my($keys_ref) = [];   # remove duplicates
  for my $k (@keys) { push(@$keys_ref,$k)  if !grep {$k eq $_} @$keys_ref }
  do_log(4,"query_keys: ".join(', ',@$keys_ref));
  # the rhs replacement strings are similar to what would be obtained
  # by lookup_re() given the following regular expression:
  # /^( ( ( [^@]*? ) ( \Q$recipient_delimiter\E [^@]* )? ) (?: \@ (.*) ) )$/xs
  my($rhs) = [   # a list of right-hand side replacement strings
    $addr,                            # $1 = User+Foo@Sub.Example.COM
    $saved_full_localpart,            # $2 = User+Foo
    $localpart,                       # $3 = user
    $recipient_delimiter.$extension,  # $4 = +foo
    $domain,                          # $5 = sub.example.com
  ];
  ($keys_ref, $rhs);
}

# 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 amavisd-new 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 in 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]+)*\z/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 amavisd-new and other mail sw,
# external (quoted) form is used in SMTP commands and message headers.
#
sub unquote_rfc2821_local($) {
  my($mailbox) = @_;
  # the angle-bracket stripping is not really a duty of this subroutine,
  # as it should have been already done elsewhere, but for the time being
  # we do it here:
  $mailbox = $1  if $mailbox =~ /^ \s* < ( .* ) > \s* \z/xs;
  my($localpart,$domain) = split_address($mailbox);
  $localpart =~ s/ " | \\ (.) | \\ \z /$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 triple: (smtp response, exit status,
# an indication whether DSN is needed).
#
sub one_response_for_all($$$) {
  my($msginfo, $dsn_per_recip_capable, $am_id) = @_;
  my($smtp_resp, $exit_code, $dsn_needed);

  my($delivery_method) = $msginfo->delivery_method;
  my($sender)          = $msginfo->sender;
  my($per_recip_data)  = $msginfo->per_recip_data;
  my($any_not_done)    = scalar(grep { !$_->recip_done } @$per_recip_data);
  if ($delivery_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, id=$am_id"; $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) {
      # helper program will interpret 99 as discard
      $exit_code = $delivery_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
        # declare success, we'll handle bounce
      $smtp_resp = "250 2.5.0 Ok, id=$am_id";
      if ($any_not_done) { $smtp_resp .= ", continue delivery" }
      elsif ($delivery_method eq '') { $exit_code = 99 }  # milter DISCARD
    }
    if ($rej_cnt + $bounce_cnt + $drop_cnt > 0) {
      $smtp_resp .= ", ";
      $smtp_resp .= "but "  if $rej_cnt+$bounce_cnt+$drop_cnt<@$per_recip_data;
      $smtp_resp .= join ", and ",
        map { my($cnt, $nm) = @$_;
              !$cnt ? () : $cnt == @$per_recip_data ? $nm : "$cnt $nm"
        } ([$rej_cnt,'REJECT'], [$bounce_cnt,'BOUNCE'], [$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;
use re 'taint';

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 distinguishable 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. The regexp is powerful enough
# that this is unnecessary. The routine is 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 implicit 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 @ and $ .
#
# 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
# decimal 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($found, $matchingkey, $result);
  local($1,$2,$3,$4);
  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(@rhs) = $addr =~ /$key/;
    if (@rhs) {
      $found++; $matchingkey = $key;
      # do the righ-hand side replacements if any $n, ${n} or $(n) is specified
      my($any) = $result =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                             { my($j)=$2+$3+$4; $j<1 ? '' : $rhs[$j-1] }gxse;
      # bring taintedness of input to the result
      $result .= substr($addr,0,0)  if $any;
      last;
    }
  }
  $matchingkey = $result = undef  if !$found;
  my(%esc) = (r => "\r", n => "\n", f => "\f", b => "\b",
              e => "\e", a => "\a", t => "\t");
  my($mk) = $matchingkey;  # pretty-print
  $mk =~ s{ \\(.) }{ exists($esc{$1}) ? $esc{$1} : $1 }egsx;
  do_log(4, "lookup_re($addr)".
    (!$found ? ", no match" : " matches key \"$mk\", result=$result"));
  !wantarray ? $result : ($result, $matchingkey);
}

1;

#
package Amavis::Lookup;
use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @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);
  import Amavis::Timing qw(section_time snmp_count);
  import Amavis::rfc2821_2822_Tools qw(split_address make_query_keys);
}

# lookup_hash() performs a lookup for an e-mail address against a hash map.
# If a match is found (a hash key exists in the Perl hash) the function returns
# whatever the map returns, otherwise undef is returned. First match wins,
# aborting further search sequence.
#
sub lookup_hash($$) {
  my($addr, $hash_ref) = @_;
  (ref($hash_ref) eq 'HASH') or die "lookup_hash: arg2 must be a hash ref";
  local($1,$2,$3,$4);
  my($found, $matchingkey, $result);
  my($keys_ref,$rhs_ref) = make_query_keys($addr,1,1);
  for my $key (@$keys_ref) {   # do the search
    if (exists $$hash_ref{$key})
      { $found++; $matchingkey = $key; $result = $$hash_ref{$key} }
    last  if $found;
  }
  # do the right-hand side replacements of $1, $2, $3, $4 if needed
  if ($found && !ref($result) && $result=~/\$/) {
    my($any) = $result=~s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                         { my($j)=$2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }gxse;
    # bring taintedness of input to the result
    $result .= substr($addr,0,0)  if $any;
  }
  do_log(4, "lookup_hash($addr)".
    (!$found?", no match":" matches key \"$matchingkey\", result=$result"));
  !wantarray ? $result : ($result, $matchingkey);
}

# 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. The ".uk" is redundant
#
# 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";
  return undef  if !@$acl_ref;  # empty list can't match anything
  my($localpart,$domain) = split_address($addr); $domain = lc($domain);
  $localpart = lc($localpart)  if !$localpart_is_case_sensitive;
  # chop off leading @ and trailing dots
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  my($lcaddr) = $localpart . '@' . $domain;
  my($found, $matchingkey, $result);
  for my $e (@$acl_ref) {
    $result = 1; $matchingkey = $e; my($key) = $e;
    if ($key =~ /^(!+)(.*)\z/s) {  # starts with an exclamation mark(s)
      $key = $2;
      $result = 1-$result  if (length($1) & 1);  # negate if odd
    }
    if ($key =~ /^(.*?)\@(.*)\z/s) {   # contains '@', check full address
      if ($localpart_is_case_sensitive) {
        $found++  if $localpart eq $1     && $domain eq lc($2);
      } else {
        $found++  if $localpart eq lc($1) && $domain eq lc($2);
      }
    } elsif ($key =~ /^\.(.*)\z/s) {   # leading dot: domain or subdomain
      $found++  if $domain eq lc($1) || $domain =~ /\Q$key\E\z/si;
    } else {                           # match domain (but not its subdomains)
      $found++  if $domain eq lc($key);
    }
    last  if $found;
  }
  $matchingkey = $result = undef  if !$found;
  do_log(4, "lookup_acl($addr)".
    (!$found?", no match":" matches key \"$matchingkey\", result=$result"));
  !wantarray ? $result : ($result, $matchingkey);
}

# Perform a lookup for an e-mail address against any number of supplied maps:
# - SQL map,
# - LDAP map,
# - hash map,
# - 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($result,$matchingkey);
  for my $tb (@tables) {
    my($t) = ref($tb) eq 'REF' ? $$tb : $tb;  # allow one level of redirection
    if (!ref($t) || ref($t) eq 'SCALAR') {    # a scalar always matches
      $result = ref($t) ? $$t : $t;  # allow direct or indirect reference
      $matchingkey = $addr;
      do_log(5,"lookup: (scalar) matches, result=\"$result\"")
        if defined $result;
    } elsif (ref($t) eq 'HASH') {
      ($result,$matchingkey) = lookup_hash($addr, $t);
    } elsif (ref($t) eq 'ARRAY') {
      ($result,$matchingkey) = lookup_acl($addr, $t);
    } elsif ($t->isa('Amavis::Lookup::RE')) {
      ($result,$matchingkey) = $t->lookup_re($addr);
    } elsif ($t->isa('Amavis::Lookup::SQL')) {
      ($result,$matchingkey) = $t->lookup_sql($addr);
    } elsif ($t->isa('Amavis::Lookup::LDAP')) {
      ($result,$matchingkey) = $t->lookup_ldap($addr);
    } elsif ($t->isa('Amavis::Lookup::SQLfield')) {
      ($result,$matchingkey) = $t->lookup_sql_field($addr);
    } else {
      die "TROUBLE: lookup argument is an unknown object: " . ref($t);
    }
    last  if defined $result;
  }
  if (!defined($result)) { do_log(4,"lookup: undef, \"$addr\" no match") }
  else {
    do_log(4,sprintf('lookup: %-6s "%s" matches, result="%s", matching_key="%s"',
                     $result?'true,':'false,', $addr, $result, $matchingkey));
  }
  !wantarray ? $result : ($result, $matchingkey);
}

# ip_to_vec() takes IPv6 or IPv4 IP address with optional prefix length
# (or IPv4 mask), parses and validates it, and returns it as a 128-bit
# vector string that can be used as operand to Perl bitwise string operators.
# Syntax and other errors in the argument throw exception (die).
# If the second argument $allow_mask is 0, the prefix length or mask
# specification is not allowed as part of the IP address.
#
# The IPv6 syntax parsing and validation adheres to rfc3513.
# All the following IPv6 address forms are supported:
#   x:x:x:x:x:x:x:x        preferred form
#   x:x:x:x:x:x:d.d.d.d    alternative form
#   ...::...               zero-compressed form
#   addr/prefix-length     prefix length may be specified (defaults to 128)
# Optionally an "IPv6:" prefix may be prepended to the IPv6 address
# as specified by rfc2821. No brackets are allowed enclosing the address.
#
# The following IPv4 forms are allowed:
#   d.d.d.d
#   d.d.d.d/prefix-length  CIDR mask length is allowed (defaults to 32)
#   d.d.d.d/m.m.m.m        network mask (gets converted to prefix-length)
# If prefix-length or a mask is specified with an IPv4 address, the address
# may be shortened to d.d.d/n or d.d/n or d/n. Such truncation is allowed
# for compatibility with earlier version, but is deprecated and is not
# allowed for IPv6 addresses.
#
# IPv4 addresses and masks are converted to IPv4-mapped IPv6 addresses
# of the form ::FFFF:d.d.d.d,  The CIDR mask length (0..32) is converted
# to IPv6 prefix-length (96..128). The returned vector strings resulting
# from IPv4 and IPv6 forms are indistinguishable.
#
# NOTE:
#   d.d.d.d is equivalent to ::FFFF:d.d.d.d (IPv4-mapped IPv6 address)
#   which is not the same as ::d.d.d.d      (IPv4-compatible IPv6 address)
#
# A triple is returned:
#  - IP address represented as a 128-bit vector (a string)
#  - network mask derived from prefix length, a 128-bit vector (string)
#  - prefix length as an integer (0..128)
#
sub ip_to_vec($;$) {
  my($ip,$allow_mask) = @_;
  my($ip_len); my(@ip_fields);
  local($1,$2,$3,$4,$5,$6);
  $ip =~ s/^[ \t]+//; $ip =~ s/[ \t\n]+\z//s;  # trim
  my($ipa) = $ip;
  ($ipa,$ip_len) = ($1,$2)  if $allow_mask && $ip =~ m{^([^/]*)/(.*)\z}s;
  if ($ipa =~ m{^(IPv6:)?(.*:)(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z}si){
    # IPv6 alternative form x:x:x:x:x:x:d.d.d.d
    !grep {$_ > 255} ($3,$4,$5,$6)
      or die "Invalid decimal field value in IPv6 address: $ip";
    $ipa = $2 . sprintf("%02X%02X:%02X%02X", $3,$4,$5,$6);
  } elsif ($ipa =~ m{^\d{1,3}(?:\.\d{1,3}){0,3}\z}) {  # IPv4 form
    my(@d) = split(/\./,$ipa,-1);
    !grep {$_ > 255} @d  or die "Invalid field value in IPv4 address: $ip";
    defined($ip_len) || @d==4
      or die "IPv4 address $ip contains fewer than 4 fields";
    $ipa = '::FFFF:' . sprintf("%02X%02X:%02X%02X", @d);  # IPv4-mapped IPv6
    if (!defined($ip_len)) { $ip_len = 32;   # no length, defaults to /32
    } elsif ($ip_len =~ /^\d{1,9}\z/) {      # /n, IPv4 CIDR notation
    } elsif ($ip_len =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/) {
      !grep {$_ > 255} ($1,$2,$3,$4)
        or die "Illegal field value in IPv4 mask: $ip";
      my($mask1) = pack('C4',$1,$2,$3,$4);   # /m.m.m.m
      my($len) = unpack("%b*",$mask1);       # count ones
      my($mask2) = pack('B32', '1' x $len);  # reconstruct mask from count
      $mask1 eq $mask2
        or die "IPv4 mask not representing valid CIDR mask: $ip";
      $ip_len = $len;
    } else {
      die "Invalid IPv4 network mask or CIDR prefix length: $ip";
    }
    $ip_len<=32 or die "IPv4 network prefix length greater than 32: $ip";
    $ip_len += 128-32;  # convert IPv4 net mask length to IPv6 prefix length
  }
  $ip_len = 128  if !defined($ip_len);
  $ip_len<=128 or die "IPv6 network prefix length greater than 128: $ip";
  $ipa =~ s/^IPv6://i;
  # now we presumably have an IPv6 preferred form x:x:x:x:x:x:x:x
  if ($ipa !~ /^(.*?)::(.*)\z/s) {  # zero-compressing form used?
    @ip_fields = split(/:/,$ipa,-1);  # no
  } else {                         # expand zero-compressing form
    my(@a) = split(/:/,$1,-1); my(@b) = split(/:/,$2,-1);
    my($missing_cnt) = 8-(@a+@b);  $missing_cnt = 1  if $missing_cnt<1;
    @ip_fields = (@a, (0) x $missing_cnt, @b);
  }
  !grep { !/^[0-9a-zA-Z]{1,4}\z/ } @ip_fields
    or die "Invalid syntax of IPv6 address: $ip";
  @ip_fields<8 and die "IPv6 address $ip contains fewer than 8 fields";
  @ip_fields>8 and die "IPv6 address $ip contains more than 8 fields";
  my($vec) = pack("n8", map {hex} @ip_fields);
  $ip_len=~/^\d{1,3}\z/
    or die "Invalid prefix length syntax in IP address: $ip";
  $ip_len<=128 or die "Invalid prefix length in IPv6 address: $ip";
  my($mask) = pack('B128', '1' x $ip_len);
# do_log(5,sprintf("ip_to_vec: %s => %s/%d\n", $ip,unpack("B*",$vec),$ip_len));
  ($vec,$mask,$ip_len);
}

# lookup_ip_acl() performs a lookup for an IPv4 or IPv6 address
# against access control list of network or host addresses.
#
# IP address is compared to 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.
#
# For IPv4 a network address 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. For IPv6 addresses all rfc3513 forms are allowed.
# See also comments at ip_to_vec().
#
# Although not a special case, it is good to remember that '::/0'
# always matches any IPv4 or IPv6 address.
#
# The '0/0' is equivalent to '::FFFF:0:0/0' and matches any IPv4 address
# (including IPv4-mapped IPv6 addresses), but not other IPv6 addresses!
#
# Example
#   given: @acl = qw( !192.168.1.12 172.16.3.3 !172.16.3.0/255.255.255.0
#                     10.0.0.0/8 172.16.0.0/12 192.168.0.0/16
#                     !0.0.0.0/8 !:: 127.0.0.0/8 ::1 );
# 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).
# In addition the 'unspecified' (null) IPv4 and IPv6 addresses return false,
# and IPv4 and IPv6 loopback addresses match and return true.
#
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($ip_vec,$ip_mask) = ip_to_vec($ip,0);
  my($found, $fullkey, $result);
  for my $net (@$nets_ref) {
    $fullkey = $net; my($key) = $fullkey; $result = 1;
    if ($key =~ /^(!+)(.*)\z/s) {  # starts with exclamation mark(s)
      $key = $2;
      $result = 1 - $result  if (length($1) & 1);  # negate if odd
    }
    my($acl_ip_vec, $acl_mask) = ip_to_vec($key,1);
    $found++  if ($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask);
    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;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @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 and are treated as plain characters,
# loosing any special meaning they might have. 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. The result 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 (/^%(%)\z/)       { $_ = $1 }                #  %% -> %
    elsif (/^(%#?.)\z/s)    { $_ = \$1 }               # unknown builtins
    elsif (/^\\([0-7]{1,3})\z/) { $_ = chr(oct($1)) }  # \nnn
    elsif (/^\\(.)\z/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*\z/)         { $sel = 0 }
        elsif ($sel =~ /^\s*(\d+)\s*\z/) { $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 && $$_ =~ /^%(.)\z/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\z/;
          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 =~ /^%\#(.)\z/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*\z/);
        }
      } elsif ($$t =~ /^%(.)\z/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);
    }
  }
  \$output_str;
}

1;

#
package Amavis::In::Connection;

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

use strict;
use re 'taint';

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

sub new
  { my($class) = @_; bless {}, $class }
sub client_ip       # client IP address (immediate SMTP client, i.e. our MTA)
  { 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;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @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 a 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;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @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 client_addr     # original client IP addr, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_ip} : ($self->{cli_ip}=shift) }
sub client_name     # orig. client DNS name, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_name} : ($self->{cli_name}=shift) }
sub client_proto     # orig. client protocol, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_proto} : ($self->{cli_proto}=shift) }
sub client_helo     # orig. client EHLO name, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_helo} : ($self->{cli_helo}=shift) }
sub msg_size        # ESMTP SIZE parameter value
  { my($self)=shift; !@_ ? $self->{msg_size}   : ($self->{msg_size}=shift) }
sub auth_user       # ESMTP AUTH username
  { my($self)=shift; !@_ ? $self->{auth_user}  : ($self->{auth_user}=shift) }
sub auth_pass       # ESMTP AUTH password
  { my($self)=shift; !@_ ? $self->{auth_pass}  : ($self->{auth_pass}=shift) }
sub auth_submitter  # ESMTP MAIL command AUTH option value
  { my($self)=shift; !@_ ? $self->{auth_subm}  : ($self->{auth_subm}=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 (e.g. believed faked)
  { 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 parts_root      # Amavis::Unpackers::Part root object
  { my($self)=shift; !@_ ? $self->{parts_root}:  ($self->{parts_root}=shift)}
sub mail_text       # rfc2822 msg: (open) file handle, or MIME::Entity object
  { my($self)=shift; !@_ ? $self->{mail_text}  : ($self->{mail_text}=shift) }
sub mail_tempdir    # work directory, either $TEMPBASE or supplied by client
  { my($self)=shift; !@_ ? $self->{mail_tempdir} : ($self->{mail_tempdir}=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) }
sub delivery_method # delivery method, or empty for implicit delivery (milter)
  { my($self)=shift; !@_ ? $self->{delivery_method} : ($self->{delivery_method}=shift) }
sub client_delete   # don't delete the tempdir, it is a client's reponsibility
  { my($self)=shift; !@_ ? $self->{client_delete} : ($self->{client_delete}=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 of '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;
use re 'taint';

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

BEGIN {
  import Amavis::Conf qw(:platform $hdr_encoding $hdr_encoding_qb);
  import Amavis::Timing qw(section_time snmp_count);
  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)\z/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,
                                               $hdr_encoding_qb,$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*\z/ && $s_l + length($_) > 78) {
        $str .= "\n"  if $str ne '';
        $str .= $s; $s = ''; $s_l = 0;
      }
      $s .= $_; $s_l += length($_);
    }
    if ($s !~ /^\s*\z/) {
      $str .= "\n"  if $str ne '';
      $str .= $s;
    }
  } elsif (length($str) > 999) {
    # truncate the damn thing (to be done better)
    $str = substr($str,0,997);
  }
  $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, and append
# an empty line (end-of-header). Returns number of original 'Received:'
# header fields 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?\z/ ? ()   # remove empty lines, ensure NL
                                 : (/\n\z/ ? $_ : $_ . "\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 {  # header edits are required
    my($curr_head, $next_head);
    push(@header, $eol)  if $is_mime;  # append empty line as end-of-header
    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 field
        } elsif ($curr_head !~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s) {
          # invalid header, but we don't care
          $out_fh->print($curr_head) or die "sending mail header4: $!";
        } else {                     # count, edit, or delete
            # obsolete rfc822 syntax allowed whitespace before colon
          my($field_name, $field_body) = ($1, $2);
          my($field_name_lc) = lc($field_name);
          $received_cnt++  if $field_name_lc eq 'received';
          if (!exists($self->{edit}{$field_name_lc})) { # unchanged
            $out_fh->print($curr_head) or die "sending mail header5: $!";
          } else {
            my($edit) = $self->{edit}{$field_name_lc};
            if (defined($edit)) {                       # edit, not delete
              chomp($field_body);
              ### $field_body =~ s/\n([ \t])/$1/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;
use re 'taint';

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

use Errno qw(ENOENT);
use POSIX qw(strftime);
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 exit_status_str);
  import Amavis::Timing qw(section_time snmp_count);
  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) = @_;
  $via =~ /^local:(.*)\z/si or die "Bad local method: $via";
  my($via_arg) = $1;
  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 file handle or a MIME::Entity object
  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 such 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{%(.)}
          {  $1 eq 'b' ? $msginfo->body_digest
           : $1 eq 'i' ? strftime("%Y%m%d-%H%M%S",localtime)
           : $1 eq 'n' ? am_id()
           : $1 eq '%' ? '%' : '%'.$1 }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 would throw 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\z/) {
            # uses shell!
            open(MP, "|$gzip >$mbxname") 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);
          seek(MP,0,2) or die "Can't position mailbox file to its tail: $!";
          $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;
        if (!$hdr_edits) {
          $hdr_edits = Amavis::Out::EditHeader->new;
          $msginfo->header_edits($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 $eol;
          }
        }
        # 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;
      if (!$pipe) {
        close(MP) or die "Can't close $mbxname: $!";
      } else {
        my($err); close(MP) or $err = $!;
        $?==0 or die ("Can't close pipe $mbxname: ".exit_status_str($?,$err) );
      }
      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;
use re 'taint';

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

use IO::File;
use IO::Wrap;
use Net::Cmd;
use Net::SMTP 2.24;
use Authen::SASL;
use POSIX qw(strftime);

BEGIN {
  import Amavis::Conf qw(:platform $DEBUG $localhost_name
                         $notify_method $relayhost_is_client);
  import Amavis::Util qw(untaint min max do_log debug_oneshot am_id
                         retcode exit_status_str prolong_timer);
  import Amavis::Timing qw(section_time snmp_count);
  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($conn) = shift;  my($msginfo,$initial_submission,$filter) = @_;
  my($via) = $msginfo->delivery_method;
  if ($via =~ /^smtp:/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) {
    # 'local:' is used by the quarantine code to relieve it
    # of the need to know which delivery method needs to be used.
    # 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, "TROUBLE: Number of recipients ($num_recips_undone_after) "
                . "not reduced in SMTP transaction, abandon the effort");
      last;
    }
    if ($num_recips_undone_after > 0) {
      do_log(1, 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';
  snmp_count('OutMsgs');
  local($1,$2,$3);  # avoid Perl taint bug, still in 5.8.3
  $via =~ /^smtp: (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) /six
    or die "Bad fwd method syntax: $via";
  my($relayhost, $relayhost_port) = ($1.$2, $3);
  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 file handle or a MIME::Entity object
  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, Port => $relayhost_port,
      Hello => $localhost_name, ExactAddresses => 1,
      Timeout => max(60, min(5 * 60, $remaining_time)),  # for each operation
#     Timeout => 0,  # no timeouts, disable nonblocking mode on socket
    # Debug => debug_oneshot(),
    # LocalAddr => 10.11.12.13,   # (bind to) source IP address
    );
    defined($smtp_handle)
      or die "Can't connect to $relayhost port $relayhost_port, $!";
    do_log(5, "Remote host introduces itself as: " . $smtp_handle->domain);

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

    $which_section = 'fwd-xforward';
    if ($msginfo->client_addr ne '' && $smtp_handle->supports('XFORWARD')) {
      # char between "!" (33) and "~" (126) inclusive, except for "+" and "="
      my($cmd) = join(' ', 'XFORWARD', map
        { my($n,$v) = @$_;  # encode parameter value as xtext: rfc3461
          $v =~ s/[^\041-\052\054-\074\076-\176]/sprintf("+%02X",ord($&))/eg;
          $v eq '' ? () : ("$n=$v") }
        ( ['ADDR', $msginfo->client_addr],  ['NAME',$msginfo->client_name],
          ['PROTO',$msginfo->client_proto], ['HELO',$msginfo->client_helo] ));
      do_log(5, "sending $cmd");
      $smtp_handle->command($cmd);
      $smtp_handle->response()==2 or die "sending $cmd\n";
      section_time($which_section); prolong_timer($which_section);
    }

    $which_section = 'fwd-auth';
    my($auth_user) = $msginfo->auth_user;
    my($mechanisms) = $smtp_handle->supports('AUTH');
    if ($mechanisms eq '' && !defined $auth_user) {
      # no authentication
    } elsif ($mechanisms eq '' && defined $auth_user) {
      do_log(2,"INFO: AUTH data available, but server does not support authentication");
    } elsif ($mechanisms ne '' && !defined $auth_user) {
      do_log(2,"INFO: AUTH data not available, server supports AUTH $mechanisms");
    } elsif ($msginfo->auth_submitter eq '<>') {
      do_log(2,"INFO: unknown submitter, not authenticating");
    } else {
      do_log(2,"INFO: authenticating $auth_user, server supports AUTH $mechanisms");
      my($sasl) = Authen::SASL->new(
        'callback' => { 'user' => $auth_user, 'authname' => $auth_user,
                        'pass' => $msginfo->auth_pass });
      $smtp_handle->auth($sasl) or die "sending AUTH, user=$auth_user\n";
      section_time($which_section); prolong_timer($which_section);
    }

    $which_section = 'fwd-mail-from';
    # how to pass the $msginfo->auth_submitter ???!!!
    $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(3, "response to RCPT TO: \"$smtp_resp\"");
        $r->recip_remote_mta($relayhost);
        $r->recip_remote_mta_smtp_response($smtp_resp);
        if ($smtp_resp =~ /^ (\d{3}) \s+ ([245] \. \d{1,3} \. \d{1,3})?
                             \s* (.*) \z/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++;
          $smtp_response = $smtp_resp  if !defined($smtp_response);
        }
        $smtp_response = $smtp_resp
          if $smtp_resp =~ /^5/ && $smtp_response !~ /^5/;  # keep first 5x
        $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 to a QUIT
    $smtp_handle->quit;         # send a QUIT regardless of success so far
    if ($err eq '' && $smtp_handle->status != CMD_OK) {
      do_log(0,"WARN: 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\z/) {
    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\z/ ? "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\z/ ? "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);
      }
    }
  }
  if (   $smtp_response =~ /^2/) { snmp_count('OutMsgsDelivers') }
  elsif ($smtp_response =~ /^4/) { snmp_count('OutAttemptFails') }
  elsif ($smtp_response =~ /^5/) { snmp_count('OutMsgsRejects')  }
  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) = @_;
  snmp_count('OutMsgs');
  $via =~ /^pipe:(.*)\z/si or die "Bad fwd method syntax: $via";
  my($pipe_args) = $1;
  $pipe_args =~ s/^flags=\S*\s*//i;  # flags are currently ignored, q implied
  $pipe_args =~ s/^argv=//i;
  my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) }
                             @{$msginfo->per_recip_data};
  my($logmsg) = sprintf("%s via PIPE: <%s>",
                     ($initial_submission ? 'SEND' : 'FWD'), $msginfo->sender);
  if (!@per_recip_data) { do_log(5, "$logmsg, nothing to do"); return 1 }
  do_log(1, $logmsg . " -> "
        . join(",", map { "<" . $_->recip_final_addr . ">" } @per_recip_data));
  my($msg) = $msginfo->mail_text;  # a file handle or a MIME::Entity object
  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\}\z/i) {
      push(@command,
           map { $_ eq '' ? '<>' : untaint(quote_rfc2821_local($_)) }
               $msginfo->sender);
    } elsif (/^\$\{recipient\}\z/i) {
      push(@command,
           map { $_ eq '' ? '<>' : untaint(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 would throw 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
    no warnings;
    exec {$command[0]} (@command)
      or do_log(0,"TROUBLE: Can't exec program $command[0]: $!");
    exec('/usr/bin/false');  # must not exit, we have to avoid DESTROY handlers
    exec('/bin/false'); exec('false'); exec('true');  # still kicking? die!
    exit EX_TEMPFAIL;        # better safe than sorry
                             # NOTREACHED
  }
  # parent
  binmode(MP) or die "Can't set pipe to binmode: $!";  # dflt since Perl 5.8.1
  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_NOUSER, EX_UNAVAILABLE
    if ($status == EX_OK) {
      $smtp_response = "250 2.6.0 Ok";  # submitted to MTA
      snmp_count('OutMsgsDelivers');
    } elsif ($status == EX_TEMPFAIL) {
      $smtp_response = "450 4.5.0 Temporary failure submitting message";
      snmp_count('OutAttemptFails');
    } elsif ($status == EX_NOUSER) {
      $smtp_response = "550 5.1.1 Recipient unknown";
      snmp_count('OutMsgsRejects');
    } elsif ($status == EX_UNAVAILABLE) {
      $smtp_response = "550 5.5.0 Mail submission service unavailable";
      snmp_count('OutMsgsRejects');
    } else {
      $smtp_response = "451 4.5.0 Unknown failure submitting message, " .
                       exit_status_str($?,$err);
      snmp_count('OutAttemptFails');
    }
  }
  $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) = @_;
  snmp_count('OutMsgs');
  $via =~ /^bsmtp:(.*)\z/si or die "Bad fwd method: $via";
  my($bsmtp_file_final) = $1;
  $bsmtp_file_final =~ s{%(.)}
    {  $1 eq 'b' ? $msginfo->body_digest
     : $1 eq 'i' ? strftime("%Y%m%d-%H%M%S",localtime)
     : $1 eq 'n' ? am_id()
     : $1 eq '%' ? '%' : '%'.$1 }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%s",  # avoid conversion to 7bit
               qquote_rfc2821_local($msginfo->sender), $eol)
      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";
    snmp_count('OutMsgsDelivers');
  } 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";
      snmp_count('OutMsgsRejects');
    } else {
      $smtp_response = "451 4.5.0 Writing $bsmtp_file_tmp failed: $err";
      snmp_count('OutAttemptFails');
    }
  }
  $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;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @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_maps);
  import Amavis::Util qw(do_log);
  import Amavis::rfc2821_2822_Tools qw(
                   split_address parse_received fish_out_ip_from_received);
  import Amavis::Lookup qw(lookup lookup_ip_acl);
}
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 & 5.8.2 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
                   ) \z/xi )
    { # discard recipient's address used as a fake 'MAIL FROM:'
      $best_try_originator = undef;
    } else {
      $best_try_originator = $1 if $from=~/^_(.+)\z/s && lc($sender) ne lc($1);
    }
  }
  for my $vn (@$virusname_list) {
    my($result,$matching_key) = lookup($vn,@viruses_that_fake_sender_maps);
    if ($result) {
      do_log(2, "Virus $vn matches $matching_key, 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]+\z/) {
      my(@raddr) = gethostbyname($name);           # name -> IP
      my($rname, $raliases, $raddrtype, $rlength, @raddrs) = @raddr;
      for my $ra (@raddrs) { return $name if lc($ra) eq lc($binaddr) }
    }
  }
  '[' . $addr . ']';  # return IP address in brackets if nothing matches
}

# Obtain and parse the first entry (chronologically) in the 'Received:' header
# path trace - to be used as the value of the macro %t in customized messages
#
sub first_received_from($) {
  my($entity) = shift;
  my($first_received);
  if (defined($entity)) {
    my($fields) = parse_received($entity->head->get('received', -1));
    if (exists $fields->{'from'}) {
      my($item, $v1, $v2, $v3, $comment) = @{$fields->{'from'}};
      $first_received = join(' ', $item, $comment);
    }
    do_log(5, "first_received_from: $first_received");
  }
  $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 invalid 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_from_ip);
  my(@received) = reverse $entity->head->get('received');
  $#received = 3  if $#received > 3;  # first four, chronologically
  my(@publicnetworks) = qw(
    !0.0.0.0/8 !127.0.0.0/8 !:: !::1
    !172.16.0.0/12 !192.168.0.0/16 !10.0.0.0/8
    !169.254.0.0/16 !192.0.2.0/24 !192.88.99.0/24 !224.0.0.0/4
    ::/0 );  # rfc3330
  for my $r (@received) {
    $first_received_from_ip = fish_out_ip_from_received($r);
    last  if $first_received_from_ip ne '' &&
             eval { lookup_ip_acl($first_received_from_ip,\@publicnetworks) };
  }
  $originator = '?@' . ip_addr_to_name($first_received_from_ip)
    if $first_received_from_ip ne '';
  (undef, $originator);
}

1;

#
package Amavis::Unpackers::NewFilename;
use strict;
use re 'taint';

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

BEGIN {
  import Amavis::Conf qw(:confvars);
  import Amavis::Util qw(do_log min max);
}

use vars qw($avail_quota);  # available bytes quota for unpacked mail
use vars qw($rem_quota);    # remaining bytes quota for unpacked mail

sub new($;$$) {  # create a file name generator object
  my($class, $maxfiles,$mail_size) = @_;
  # calculate and initialize quota
  $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");
  # create object
  bless {
    num_of_issued_names => 0,  first_issued_ind => 1,  last_issued_ind => 0,
    maxfiles => $maxfiles,  # undef disables limit
    objlist => [],
  }, $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;
  $self->{objlist} = [];
}

sub parts_list($) {  # returns a ref to a list of recently issued names
  my($self) = shift;
  $self->{objlist};
}

sub parts_list_add($$) {  # add a parts object to the list of parts
  my($self, $part) = @_;
  push(@{$self->{objlist}}, $part);
}

sub generate_new_num($) {  # make-up a new number for a file and return it
  my($self) = @_;
  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}++;
  $self->{last_issued_ind};
}

sub consumed_bytes($$;$) {
  my($bytes, $bywhom, $tentatively) = @_;
  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  unless $tentatively;
  $rem_quota;  # return remaining quota
}

1;

#
package Amavis::Unpackers::Part;
use strict;
use re 'taint';

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

BEGIN {
  import Amavis::Util qw(do_log);
}

use vars qw($file_generator_object);
sub init($) { $file_generator_object = shift }

sub new($;$$) {  # create a part descriptor object
  my($class, $dir_name,$parent) = @_;
  my($self) = bless {}, $class;
  if (!defined($dir_name) && !defined($parent)) {
    # just make an empty object, presumably used as a new root
  } else {
    $self->number($file_generator_object->generate_new_num);
    $self->dir_name($dir_name);
    if (defined $parent) {
      $self->parent($parent);
      my($ch_ref) = $parent->children;
      push(@$ch_ref,$self); $parent->children($ch_ref);
    }
    $file_generator_object->parts_list_add($self);  # save it
    do_log(4, "Issued a new file name: " . $self->base_name);
  }
  $self;
}

sub number
  { my($self)=shift; !@_ ? $self->{number}   : ($self->{number}=shift) };
sub dir_name
  { my($self)=shift; !@_ ? $self->{dir_name} : ($self->{dir_name}=shift) };
sub parent
  { my($self)=shift; !@_ ? $self->{parent}   : ($self->{parent}=shift) };
sub children
  { my($self)=shift; !@_ ? $self->{children}||[] : ($self->{children}=shift) };
sub type_short
  { my($self)=shift; !@_ ? $self->{ty_short} : ($self->{ty_short}=shift) };
sub type_long
  { my($self)=shift; !@_ ? $self->{ty_long}  : ($self->{ty_long}=shift) };
sub type_declared
  { my($self)=shift; !@_ ? $self->{ty_decl}  : ($self->{ty_decl}=shift) };
sub name_declared
  { my($self)=shift; !@_ ? $self->{nm_decl}  : ($self->{nm_decl}=shift) };
sub size
  { my($self)=shift; !@_ ? $self->{size}     : ($self->{size}=shift) };
sub exists
  { my($self)=shift; !@_ ? $self->{exists}   : ($self->{exists}=shift) };
sub attributes   # listref of characters representing attributes
  { my($self)=shift; !@_ ? $self->{attr}     : ($self->{attr}=shift) };
sub attributes_add {  # U=undecodable, C=crypted, D=directory
  my($self)=shift; my($a) = $self->{attr} || [];
  for my $arg (@_) { push(@$a,$arg)  if $arg ne '' && !grep {$_ eq $arg} @$a }
  $self->{attr} = $a;
};
sub base_name { my($self)=shift; sprintf("p%03d",$self->number) }
sub full_name { my($self)=shift; $self->dir_name.'/'.$self->base_name }

# returns a ref to a list of part ancestors, starting with the root object,
# and including the part object itself
sub path {
  my($self)=shift;
  my(@path);
  for (my($p)=$self; defined($p); $p=$p->parent) { unshift(@path,$p) }
  \@path;
};

1;

#
package Amavis::Unpackers::OurFiler;
use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @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, $parent_obj) = @_;
  $dir =~ s{/+\z}{};  # chop off trailing slashes from directory name
  bless {parent => $parent_obj, directory => $dir}, $class;
}

# provide a generated file name
sub output_path($@) {
  my($self, $head) = @_;
  my($newpart_obj) =
    Amavis::Unpackers::Part->new($self->{directory}, $self->{parent});
  get_amavisd_part($head, $newpart_obj);  # store object into head
  $newpart_obj->full_name;
}

sub get_amavisd_part($;$) {
  my($head) = shift;
  !@_ ? $head->{amavisd_parts_obj} : ($head->{amavisd_parts_obj} = shift);
}

1;

#
package Amavis::Unpackers::Validity;
use strict;
use re 'taint';

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

BEGIN {
  import Amavis::Util qw(do_log sanitize_str);
  import Amavis::Conf qw(:platform :confvars);
  import Amavis::Lookup qw(lookup);
}

use subs @EXPORT_OK;

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 {
        # obsolete rfc822 syntax allowed whitespace before colon
        my($field_name, $field_body) =
          $curr_head =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s
            ? ($1, $2) : (undef, $curr_head);
        my($msg1,$msg2);
        if (!defined($field_name) && $curr_head=~/^()()(.*)\z/s) {
          $msg1 = "Invalid header field head";
        } elsif ($curr_head =~ /^(.*?)([\000\015])(.*)\z/s) {
          $msg1 = "Improper use of control character";
        } elsif ($curr_head =~ /^(.*?)([\200-\377])(.*)\z/s) {
          $msg1 = "Non-encoded 8-bit data";
        } elsif ($curr_head =~ /^(.*?)([^\000-\377])(.*)\z/s) {
          $msg1 = "Non-encoded Unicode character";
        } elsif ($curr_head =~ /^()()([ \t]+)$/m) {
          $msg1 ="Improper folded header field made up entirely of whitespace";
        }
        if (defined $msg1) {
          my($pre, $ch, $post) = ($1, $2, $3);
          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)", ord($ch))  if length($ch)==1;
          $msg1 .= " in message header $field_name"       if $field_name ne '';
          $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) . '^');
          push(@bad, "$msg1: $msg2");
        }
      }
      last  if $next_head eq $eol;  # end-of-header reached
      $curr_head = $next_head;
    }
  }
  @bad;
}

sub check_for_banned_names($) {
  my($parts_root) = @_;
  do_log(3, "Checking for banned types and filenames");
  my(@banned); my($part);
  for (my(@unvisited)=($parts_root);
       @unvisited and $part=shift(@unvisited);
       push(@unvisited,@{$part->children}))
  { # traverse decomposed parts tree breadth-first
    my(@path) = @{$part->path};
    next  if @path <= 1;
    shift(@path);  # ignore place-holder root node
    next  if @{$part->children};  # ignore non-leaf nodes
    my(@descr); my($found,$key_val,$key_what,$result,$matchingkey);
    for my $part (@path) {
      my(@k,$n);
      $n = $part->base_name;
      if ($n ne '') { $n=~s/[\t\n]/ /g; push(@k,"P=$n") }
      $n = $part->type_declared;
      $n = [$n]  if !ref($n);
      for (@$n) {if ($_ ne '') {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"M=$m")} }
      $n = $part->type_short;
      $n = [$n]  if !ref($n);
      for (@$n) {if ($_ ne '') {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"T=$m")} }
      $n = $part->name_declared;
      $n = [$n]  if !ref($n);
      for (@$n) {if ($_ ne '') {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"N=$m")} }
      $n = $part->attributes;
      $n = [$n]  if !ref($n);
      for (@$n) {if ($_ ne '') {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"A=$m")} }
      push(@descr, join("\t",@k));
      if (!$found && @banned_filename_maps) {  # still searching?  (old style)
        for my $k (@k) {
          $k =~ /^([a-zA-Z0-9])=(.*)\z/s;
          ($key_what,$key_val) = ($1,$2);
          next  unless $key_what =~ /^[TMNA]\z/;
          if ($key_what eq 'T') {
            $key_val = '.' . $key_val;  # prepend a dot for compatibility
          } elsif ($key_what eq 'A') {
            if ($key_val eq 'U') { $key_val = 'UNDECIPHERABLE' } else { next }
          }
          do_log(4, sprintf("check_for_banned (%s) %s=%s",
                            $part->base_name, $key_what, $key_val));
          ($result,$matchingkey) = lookup($key_val,@banned_filename_maps);
          $found++  if defined $result;
          last  if $found;
        }
      }
    }
    my($key_val_str) = join(' | ',@descr);  $key_val_str =~ s/\t/,/g;
    if (!$found) {  # try new style
      ($result,$matchingkey) = lookup(join("\n",@descr), $banned_namepath_re);
      $found++  if defined $result;
    }
    my(%esc) = (r => "\r", n => "\n", f => "\f", b => "\b",
                e => "\e", a => "\a", t => "\t");
    my($mk) = $matchingkey;  # pretty-print
    $mk =~ s{ \\(.) }{ exists($esc{$1}) ? $esc{$1} : $1 }egsx;
    do_log($result?0:3, sprintf('p.path%s: "%s"%s',
                   !$result?'':' BANNED', $key_val_str,
                   !defined $result ? '' : ", matching_key=\"$mk\""));
    push(@banned,$key_val_str)  if $result;
  }
# for (@banned) { $_ = sanitize_str($_); $_ = '"' . $_ . '"' if / / }
  \@banned;  # return a listref of violations, possibly empty
}

1;

#
package Amavis::Unpackers::MIME;
use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = ();
  @EXPORT = ();
  @EXPORT_OK = qw(&mime_decode);
}
use MIME::Parser;
use MIME::Words;

BEGIN {
  import Amavis::Util qw(do_log);
  import Amavis::Timing qw(section_time snmp_count);
  import Amavis::Conf qw(:platform :confvars);
  import Amavis::Unpackers::NewFilename qw(consumed_bytes);
}

use subs @EXPORT_OK;

# save MIME preamble and epilogue (if nontrivial) as extra (pseudo)parts
sub mime_decode_pre_epi($$$$) {
  my($pe_name, $pe_lines, $tempdir, $parent_obj) = @_;
  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_-]*\z}s) {
      my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",
                                                      $parent_obj);
      $newpart_obj->name_declared($pe_name);
      my($newpart) = $newpart_obj->full_name;
      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: $!";
      $newpart_obj->size($len);
      consumed_bytes($len, "mime_decode_$pe_name");
    }
  }
}

# Break up mime parts, return MIME::Entity object
sub mime_decode($$$) {
  my($fileh, $tempdir, $parent_obj) = @_;
  # $fileh may be an open file handle, or a file name

  my($parser) = MIME::Parser->new;
  $parser->filer(Amavis::Unpackers::OurFiler->new("$tempdir/parts",
                                                  $parent_obj));
  $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);
  snmp_count('OpsDecByMimeParser');
  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 & 5.8.2 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 & 5.8.2 bug, $1 gets tainted !
    $entity = $parser->parse_open("$tempdir/parts/$fileh");
  }
# my($mime_err) = $parser->last_error;  # deprecated
  my($mime_err) = $parser->results->errors;
  $mime_err=~s/\s+\z//; $mime_err=~s/[ \t\r]*\n+/; /g; $mime_err=~s/\s+/ /g;
  $mime_err = substr($mime_err,0,250) . '...'  if length($mime_err) > 250;
  do_log(1, "WARN: MIME::Parser $mime_err")  if $mime_err ne '';
  my($ent);
  for (my(@unvisited)=($entity);
       @unvisited and $ent=shift(@unvisited);
       push(@unvisited,$ent->parts))
  { # traverse MIME::Entity object breadth-first,
    # extracting preambles and epilogues as extra (pseudo)parts
    mime_decode_pre_epi('preamble', $ent->preamble, $tempdir, $parent_obj);
    my($mt, $et) = ($ent->mime_type, $ent->effective_type);
    my($body) = $ent->bodyhandle;
    do_log(4,"mime_decode: Content-type: $mt"
             .(!$body ? "" : (", name: " . $ent->head->recommended_filename)));
    if (defined $body) {
      my(@rn);  # recommended file names, both raw and RFC 2047 decoded
      my($head) = $ent->head; my($fn) = $body->path;
      # retrieve Parts object (if any), stashed into head object
      my($part) = Amavis::Unpackers::OurFiler::get_amavisd_part($head);
      my($size) = defined $fn ? -s $fn : length($body->as_string);
      consumed_bytes($size, 'mime_decode');
      if (defined $part) {
        $part->size($size);
        $part->type_declared($mt eq $et ? $mt : [$mt, $et]);
      }
      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 '') {
        $val_decoded = MIME::Words::decode_mimewords($val);
        push(@rn, $val_decoded)  if !grep { $_ eq $val_decoded } @rn;
        push(@rn, $val)          if !grep { $_ eq $val         } @rn;
      }
      $part->name_declared(@rn==1 ? $rn[0] : \@rn)  if @rn && defined $part;
    }
    mime_decode_pre_epi('epilogue', $ent->epilogue, $tempdir, $parent_obj);
  }
  section_time('mime_decode');
  ($entity, $mime_err);
}

1;

#
package Amavis::Notify;
use strict;
use re 'taint';

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

BEGIN {
  import Amavis::Util qw(do_log safe_encode am_id);
  import Amavis::Timing qw(section_time snmp_count);
  import Amavis::Conf qw(:platform :notifyconf $myhostname $forward_method
                         $hdr_encoding $bdy_encoding $hdr_encoding_qb
                         $amavis_auth_user $amavis_auth_pass);
  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) = @_;
  local($1,$2,$3); my($entity); my($m_hdr,$m_body);
  ($m_hdr, $m_body) = ($1, $3)
    if $$mail_as_string_ref =~ /^(.*?\r?\n)(\r?\n|\z)(.*)\z/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*(.*)\z/s) {
      my($fhead, $fbody) = ($1, $2);
      # encode according to RFC 2047 if necessary
      if ($fhead =~ /^(X-.*|Subject|Comments)\z/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, $hdr_encoding_qb,
                                              $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
      if (!eval { $head->replace($fhead, $fbody); 1 }) {
        chomp($@);
        die sprintf("%s header field '%s: %s'",
                    ($@ eq '' ? "invalid" : "$@, "), $fhead, $fbody);
      }
    }
  }
  $entity;  # return the built MIME::Entity
}

# Generate delivery status notification according to
# rfc1892 (now rfc3462) and rfc1894 (now rfc3464).
# 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 rfc3464
    $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 ($msginfo->delivery_method eq '') {  # e.g. milter
          # as far as we are concerned all is ok, delivery will be performed
          # by a helper program or MTA
          $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* (.*) \z/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])\z/) {
        $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;

    # rfc3464: 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->rx_time($msginfo->rx_time);
    $notification->delivery_method($notify_method);
    $notification->sender($mailfrom_notify_sender);  # should be empty!
    $notification->auth_submitter('<>');
    $notification->auth_user($amavis_auth_user);
    $notification->auth_pass($amavis_auth_pass);
    $notification->recips([$msginfo->sender_contact]);
    $notification->mail_text($dsn_entity);
  }
  $notification;
}

# Return a pair of arrayrefs of quoted recipient addresses (the first lists
# recipients with successful delivery status, the second all the rest),
# plus a list of short per-recipient delivery reports for failed deliveries,
# that can be used in the first MIME part (the free text format) of delivery
# status notifications.
#
sub delivery_short_report($) {
  my($msginfo) = @_;
  my(@succ_recips, @failed_recips, @failed_recips_full);
  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_recips,   $qrecip_addr);
    } else {
      push(@failed_recips, $qrecip_addr);
      push(@failed_recips_full,
           sprintf("%s:%s\n   %s", $qrecip_addr,
                   ($remote_mta eq ''?'':" $remote_mta said:"), $smtp_resp));
    }
  }
  (\@succ_recips, \@failed_recips, \@failed_recips_full);
}

# Build a new MIME::Entity object based on the original mail, but hopefully
# safer to mail readers: conventional mail header fields are retained,
# Resent-{From,Date,Message-ID} are added, and original mail becomes
# an attachment of type 'message/rfc822'. Text in $first_part becomes
# the first MIME part of type 'text/plain'.
#
sub defanged_mime_entity($$$) {
  my($conn,$msginfo,$first_part) = @_;
  my($new_entity); my($resent_time) = time;
  $first_part = safe_encode($bdy_encoding, $first_part);
  # make sure _our_ source line number is reported in case of failure
  eval {$new_entity = MIME::Entity->build(
    Type => 'multipart/mixed',
    (defined $notify_xmailer_header && $notify_xmailer_header eq ''
      ? ()  # leave the MIME::Entity default
      : ('X-Mailer' => $notify_xmailer_header) ),  # X-Mailer hdr or undef
    ); 1}  or do {chomp($@); die $@};
  my($head) = $new_entity->head;
  my($orig_head) = $msginfo->mime_entity->head;
  for my $field_head (   # copy some of the original header fields - part 1
      qw( Received From Sender To Cc Reply-To Date Message-ID ) ) {
    for my $value ($orig_head->get_all($field_head)) {
      do_log(4, "copying-over(1) the header field: $field_head");
      eval { $head->add($field_head, $value); 1 } or do {chomp($@); die $@};
    }
  }
  for my $field_pair (   # prepend Resent-* header fields
      ['Resent-From', $hdrfrom_notify_recip],
      ['Resent-Date', rfc2822_timestamp($resent_time)],
      ['Resent-Message-ID', sprintf('<RE%s@%s>',am_id(),$myhostname)] ) {
    eval { $head->add(@$field_pair); 1 } or do {chomp($@); die $@};
  }
  for my $field_head (   # copy some of the original header fields - part 2
      qw(Resent-From Resent-Sender Resent-To Resent-Cc
         Resent-Date Resent-Message-ID
         In-Reply-To References Subject
         Comments Keywords Organization X-Mailer)) {
    for my $value ($orig_head->get_all($field_head)) {
      do_log(4, "copying-over(2) the header field: $field_head");
      eval { $head->add($field_head, $value); 1 } or do {chomp($@); die $@};
    }
  }
  $head = undef;  # ref not needed any longer
  eval {$new_entity->attach(
    Type => 'text/plain', Encoding => '-SUGGEST', Charset => $bdy_encoding,
    Data => $first_part); 1}  or do {chomp($@); die $@};
  eval {$new_entity->attach(
    Type => 'message/rfc822', Encoding => '8bit',  # rfc2046
    Path => $msginfo->mail_tempdir.'/email.txt',
    Description => 'Original message',
    Filename => 'message.txt', Disposition => 'attachment'); 1}
    or do {chomp($@); die $@};
  $new_entity;
}

1;

#
package Amavis::Cache;
# offer an 'IPC::Cache'-compatible interface to the local Perl hash
use strict;
use re 'taint';

#trivial variant of public interface routines:
# sub new { my($class) = @_; bless {}, $class }
# sub get { my($self,$key) = @_; thaw($self->{$key}) }
# sub set { my($self,$key,$obj) = @_; $self->{$key} = freeze($obj) }
# sub update_counters {}

BEGIN {
  import Amavis::Conf qw($db_home);
  import Amavis::Util qw(do_log);
  import Amavis::Timing qw(section_time snmp_count get_snmp_counters);
}

use POSIX qw(strftime);
use BerkeleyDB;

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

sub new {
  my($class) = @_;
  my($env) = BerkeleyDB::Env->new(
    -Home=>$db_home, -Mode=>0640,
    -Flags=> DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL);
  defined $env or die "BDB bad db env. at $db_home: $BerkeleyDB::Error, $!.";
  do_log(4, sprintf("BerkeleyDB %s, db version %s",
                    BerkeleyDB->VERSION, $BerkeleyDB::db_version));
  my($dbc) = BerkeleyDB::Hash->new(
    -Filename=>'cache.db', -Flags=>DB_CREATE, -Env=>$env );
  defined $dbc or die "BDB no dbC: $BerkeleyDB::Error, $!.";
  my($dbq) = BerkeleyDB::Queue->new(
    -Filename=>'cache-expiry.db', -Flags=>DB_CREATE, -Env=>$env,
    -Len=>15+1+32 );  # '-ExtentSize' needs DB 3.2.x, e.g. -ExtentSize=>2
  defined $dbq or die "BDB no dbQ: $BerkeleyDB::Error, $!.";
  my($dbs) = BerkeleyDB::Hash->new(
    -Filename=>'snmp.db', -Flags=>DB_CREATE, -Env=>$env );
  defined $dbs or die "BDB no dbS: $BerkeleyDB::Error, $!.";
  bless {'db_cache'=>$dbc, 'db_queue'=>$dbq, 'db_snmp'=>$dbs}, $class;
}

# purge expired entries from the queue head and enqueue new entry at the tail
sub enqueue {
  my($self,$str,$now_utc_iso8601,$expires_utc_iso8601) = @_;
  my($db) = $self->{'db_cache'};  my($dbq) = $self->{'db_queue'};
  my($stat,$key,$val); $key = '';
  my($qcursor) = $dbq->db_cursor(DB_WRITECURSOR);
  defined $qcursor or die "BDB Q db_cursor: $BerkeleyDB::Error, $!.";
  while ( ($stat=$qcursor->c_get($key,$val,DB_NEXT)) == 0 ) {
    if ($val !~ /^([^ ]+) (.*)\z/s) {
      do_log(0,"WARN: queue head invalid, deleting: $val");
    } else {
      my($t,$digest) = ($1,$2);
      last  if $t ge $now_utc_iso8601;
      my($cursor) = $db->db_cursor(DB_WRITECURSOR);
      defined $cursor or die "BDB db_cursor: $BerkeleyDB::Error, $!.";
      my($v); my($st1) = $cursor->c_get($digest,$v,DB_SET);
      $st1==0 || $st1==DB_NOTFOUND or die "BDB c_get: $BerkeleyDB::Error, $!.";
      if ($st1==0 && $v=~/^([^ ]+) /s) {  # record exists and appears valid
         if ($1 ne $t) {
           do_log(5,"not deleting: $digest, has been refreshed since");
         } else {  # its expiration time correspond to timestamp in the queue
           do_log(5,"deleting: $digest");
           my($st2) = $cursor->c_del;     # delete expired entry from the cache
           $st2==0 || $st2==DB_KEYEMPTY
             or die "BDB c_del: $BerkeleyDB::Error, $!.";
         }
      }
      $cursor->c_close==0 or die "BDB c_close: $BerkeleyDB::Error, $!.";
    }
    my($st3) = $qcursor->c_del;
    $st3==0 || $st3==DB_KEYEMPTY or die "BDB Q c_del: $BerkeleyDB::Error, $!.";
  }
  $stat==0 || $stat==DB_NOTFOUND or die "BDB Q c_get: $BerkeleyDB::Error, $!.";
  $qcursor->c_close==0 or die "BDB Q c_close: $BerkeleyDB::Error, $!.";
  # insert new expiration request in the queue
  $dbq->db_put($key, "$expires_utc_iso8601 $str", DB_APPEND) == 0
    or die "BDB Q db_put: $BerkeleyDB::Error, $!.";
  $stat = $dbq->db_sync();
  $stat==0 or warn "BDB Q db_sync, status $stat: $BerkeleyDB::Error, $!.";
  $stat = $db->db_sync();
  $stat==0 or warn "BDB C db_sync, status $stat: $BerkeleyDB::Error, $!.";
}

sub get {
  my($self,$key) = @_;
  my($val,$obj); my($db) = $self->{'db_cache'};
  my($stat) = $db->db_get($key,$val);
  $stat==0 || $stat==DB_NOTFOUND  or die "BDB c_get: $BerkeleyDB::Error, $!.";
  $obj = thaw($2)  if $stat==0 && $val=~/^([^ ]+) (.*)/s;   # if valid record
  $obj;
}

sub set {
  my($self,$key,$obj,$now_utc_iso8601,$expires_utc_iso8601) = @_;
  my($db) = $self->{'db_cache'};
  my($cursor) = $db->db_cursor(DB_WRITECURSOR);
  defined $cursor or die "BDB db_cursor: $BerkeleyDB::Error, $!.";
  my($val); my($stat) = $cursor->c_get($key,$val,DB_SET);
  $stat==0 || $stat==DB_NOTFOUND  or die "BDB c_get: $BerkeleyDB::Error, $!.";
  $cursor->c_put($key, $expires_utc_iso8601.' '.freeze($obj),
                 $stat==0 ? DB_CURRENT : DB_KEYLAST ) == 0
    or die "BDB c_put: $BerkeleyDB::Error, $!.";
  $cursor->c_close==0 or die "BDB c_close: $BerkeleyDB::Error, $!.";
  $stat = $db->db_sync();
  $stat==0 or warn "BDB db_sync, status $stat: $BerkeleyDB::Error, $!.";
  $self->enqueue($key,$now_utc_iso8601,$expires_utc_iso8601);
  $obj;
}

sub update_counters {
  my($self) = @_;
  my($list) = get_snmp_counters();
  if (defined $list && @$list) {
    my($db) = $self->{'db_snmp'};
    my($cursor) = $db->db_cursor(DB_WRITECURSOR);
    defined $cursor or die "BDB S db_cursor: $BerkeleyDB::Error, $!.";
    for my $key (@$list) {
      my($val,$flags);
      my($stat) = $cursor->c_get($key,$val,DB_SET);
      if ($stat==0) {  # exists, update it
        if ($val !~ /^\d+\z/)
          { do_log(0,"WARN: counter not numeric: $val, clearing"); $val = 0 }
        $flags = DB_CURRENT; $val = $val+1;
      } else {  # create new entry
        $stat==DB_NOTFOUND  or die "BDB S c_get: $BerkeleyDB::Error, $!.";
        $flags = DB_KEYLAST; $val = 1;
      }
      $cursor->c_put($key, sprintf("%010d",$val), $flags) == 0
        or die "BDB S c_put: $BerkeleyDB::Error, $!.";
    }
    $cursor->c_close==0 or die "BDB S c_close: $BerkeleyDB::Error, $!.";
    my($stat); $stat = $db->db_sync();
    $stat==0 or warn "BDB S db_sync, status $stat: $BerkeleyDB::Error, $!.";
  }
  delete $self->{'cnt'};
}

sub DESTROY {
  my($self) = shift;
  for my $db ($self->{'db_cache'}, $self->{'db_queue'}, $self->{'db_snmp'}) {
    if (defined $db) {
      $db->db_close==0 or die "BDB DESTROY db_close: $BerkeleyDB::Error, $!.";
    }
  }
}

# protect % and ~, as well as NUL and \200 for good measure
sub encode($) {
  my($str) = @_; $str =~ s/[%~\000\200]/sprintf("%%%02X",ord($&))/egs; $str;
}

# simple Storable::freeze lookalike
sub freeze($);  # prototype
sub freeze($) {
  my($obj) = @_; my($ty) = ref($obj);
  if (!defined($obj))     { 'U' }
  elsif (!$ty)            { join('~', '',  encode($obj))  }  # string
  elsif ($ty eq 'SCALAR') { join('~', 'S', encode(freeze($$obj))) }
  elsif ($ty eq 'REF')    { join('~', 'R', encode(freeze($$obj))) }
  elsif ($ty eq 'ARRAY')  { join('~', 'A', map {encode(freeze($_))} @$obj) }
  elsif ($ty eq 'HASH') {
    join('~','H',map {(encode($_),encode(freeze($obj->{$_})))} sort keys %$obj)
  } else { die "Can't freeze object type $ty" }
}

# simple Storable::thaw lookalike
sub thaw($);  # prototype
sub thaw($) {
  my($str) = @_;
  return undef  if !defined $str;
  my($ty,@val) = split(/~/,$str,-1);
  for (@val) { s/%([0-9a-fA-F]{2})/pack("C",hex($1))/eg }
  if    ($ty eq 'U') { undef }
  elsif ($ty eq '')  { $val[0] }
  elsif ($ty eq 'S') { my($obj)=thaw($val[0]); \$obj }
  elsif ($ty eq 'R') { my($obj)=thaw($val[0]); \$obj }
  elsif ($ty eq 'A') { [map {thaw($_)} @val] }
  elsif ($ty eq 'H') {
    my($hr) = {}; 
    while (@val) { my($k) = shift @val; $hr->{$k} = thaw(shift @val) }
    $hr;
  } else { die "Can't thaw object type $ty" }
}

1;

#
package Amavis;
require 5.005;  # need qr operator and \z in regexps
use strict;
use re 'taint';

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(untaint min max do_log debug_oneshot am_id
                         prolong_timer rmdir_flat);
  import Amavis::Timing qw(section_time snmp_count);
  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::Validity qw(
                           check_header_validity check_for_banned_names);
  import Amavis::Unpackers::MIME qw(mime_decode);
  import Amavis::Expand qw(expand);
  import Amavis::Notify qw(delivery_status_notification delivery_short_report
                           string_to_mime_entity defanged_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 $extra_code_unpackers);
use vars qw($spam_level $spam_status $spam_report);
use vars qw($user_id_sql $wb_listed_sql);
use vars qw($body_digest $body_digest_cache);
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 or LMTP 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';
  eval {
    # 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 directory is not writable: $name" }
    if ($db_home ne '') {
      my($name) = $db_home;
      $name = "$daemon_chroot_dir $name"  if $daemon_chroot_dir ne '';
      $errn = stat($db_home) ? 0 : 0+$!;
      if ($errn == ENOENT) { }
      elsif ($errn) { die "db_home inaccessible, $!: $name" }
      elsif (!-d _) { die "db_home is not a directory : $name" }
      elsif (!-w _) { die "db_home directory is not writable: $name" }
      else { rmdir_flat($db_home) }
      mkdir($db_home,0750) or die "Can't create directory $db_home: $!";
    }
    if ($QUARANTINEDIR ne '') {
      my($name) = $QUARANTINEDIR;
      $name = "$daemon_chroot_dir $name"  if $daemon_chroot_dir ne '';
      $errn = stat($QUARANTINEDIR) ? 0 : 0+$!;
      if    ($errn == ENOENT) { }  # ok
      elsif ($errn)         { die "QUARANTINEDIR inaccessible, $!: $name" }
      elsif (-d _ && !-w _) { die "QUARANTINEDIR directory not writable: $name" }
    }
    Amavis::SpamControl::init()  if $extra_code_antispam;
  };
  if ($@ ne '') {
    chomp($@); my($msg) = "TROUBLE in pre_loop_hook: $@"; do_log(0,$msg);
    die ("Suicide (" . am_id() . ") " . $msg . "\n"); # kills child, not parent
  }
  1;
}

### 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)';
  Amavis::Timing::go_idle('vir');
}

### user customizable Net::Server hook
sub post_accept_hook {
  my($self) = shift;
  local $SIG{CHLD} = 'DEFAULT';
  $child_invocation_count++;
  $0 = sprintf("amavisd (ch%d-accept)", $child_invocation_count);
  Amavis::Timing::go_busy('hi ');
  Amavis::Timing::init();  # establish initial time right after 'accept'
}

### 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';
  local($1,$2,$3,$4);  # Perl bug: $1 and $2 come tainted from Net::Server !

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

# use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC);
# sub cloexec_on($;$) {
#   my($fd,$name) = @_; my($flags);
#   $flags = fcntl($fd, F_GETFD, 0)
#     or die "Can't get flags from the file descriptor: $!";
#   if ($flags & FD_CLOEXEC == 0) {
#     do_log(4,"Turning on FD_CLOEXEC flag on $name");
#     fcntl($fd, F_SETFD, $flags | FD_CLOEXEC)
#       or die "Can't set FD_CLOEXEC on file descriptor $name: $!";
#   }
# }

### 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';
  local($1,$2,$3,$4);  # Perl bug: $1 and $2 come tainted from Net::Server !
  # Net::Server assigns STDIN and STDOUT to the socket
  binmode(STDIN)  or die "Can't set STDIN to binmode: $!";
  binmode(STDOUT) or die "Can't set STDOUT to binmode: $!";
  binmode($sock)  or die "Can't set socket to binmode: $!";
  $| = 1;
  local $SIG{ALRM} = sub { die "timed out\n" };  # do not modify the sig text!
  eval {
    if ($] < 5.006) { # Perl older than 5.6.0 did not set FD_CLOEXEC on sockets
###   for my $mysock (@{$prop->{sock}}) { cloexec_on($mysock, $mysock) }
    }
    $body_digest_cache = Amavis::Cache->new  if !defined($body_digest_cache);
    prolong_timer('new request - timer reset', $child_timeout);  # timer init
    if ($extra_code_ldap && $child_invocation_count == 1) {
      # $ldap_wblist : TODO
      my $lf = sub { Amavis::Lookup::LDAP->new($default_ldap, @_) if $_[0] };
      unshift(@virus_lovers_maps,        $lf->($virus_lovers_ldap));
      unshift(@spam_lovers_maps,         $lf->($spam_lovers_ldap));
      unshift(@banned_files_lovers_maps, $lf->($banned_files_lovers_ldap));
      unshift(@bad_header_lovers_maps,   $lf->($bad_header_lovers_ldap));
      unshift(@bypass_virus_checks_maps, $lf->($bypass_virus_checks_ldap));
      unshift(@bypass_spam_checks_maps,  $lf->($bypass_spam_checks_ldap));
      unshift(@bypass_banned_checks_maps,$lf->($bypass_banned_checks_ldap));
      unshift(@bypass_header_checks_maps,$lf->($bypass_header_checks_ldap));
      unshift(@spam_tag_level_maps,      $lf->($spam_tag_level_ldap));
      unshift(@spam_tag2_level_maps,     $lf->($spam_tag2_level_ldap));
      unshift(@spam_kill_level_maps,     $lf->($spam_kill_level_ldap));
      unshift(@spam_modifies_subj_maps,  $lf->($spam_modifies_subj_ldap));
      unshift(@spam_quarantine_to_maps,  $lf->($spam_quarantine_to_ldap));
      unshift(@local_domains_maps,       $lf->($local_domains_ldap));
    }
    if ($extra_code_sql && @lookup_sql_dsn) {
      if (!defined $sql_wblist && defined $sql_select_white_black_list) {
        $sql_wblist = Amavis::Lookup::SQL->new;
      }
      if (!defined $sql_policy && defined $sql_select_policy) {
        # make SQL lookup object which will carry SELECT and DBI handle
        $sql_policy = Amavis::Lookup::SQL->new;
      }
    }
    if (defined $sql_policy) {
      # make SQL field 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',                  'S');
      unshift(@virus_lovers_maps,        $nf->('virus_lover',         'B0'));
      unshift(@spam_lovers_maps,         $nf->('spam_lover',          'B-'));
      unshift(@banned_files_lovers_maps, $nf->('banned_files_lover',  'B-'));
      unshift(@bad_header_lovers_maps,   $nf->('bad_header_lover',    'B-'));
      unshift(@bypass_virus_checks_maps, $nf->('bypass_virus_checks', 'B0'));
      unshift(@bypass_spam_checks_maps,  $nf->('bypass_spam_checks',  'B0'));
      unshift(@bypass_banned_checks_maps,$nf->('bypass_banned_checks','B-'));
      unshift(@bypass_header_checks_maps,$nf->('bypass_header_checks','B-'));
      unshift(@spam_tag_level_maps,      $nf->('spam_tag_level',      'N'));
      unshift(@spam_tag2_level_maps,     $nf->('spam_tag2_level',     'N'));
      unshift(@spam_kill_level_maps,     $nf->('spam_kill_level',     'N'));
      unshift(@spam_modifies_subj_maps,  $nf->('spam_modifies_subj',  'B-'));
      unshift(@spam_quarantine_to_maps,  $nf->('spam_quarantine_to',  'S-'));
      unshift(@local_domains_maps,       $nf->('local',               'B1'));
      section_time('sql-prepare');
    }
    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 helper program
      $amcl_in_obj = Amavis::In::AMCL->new  if !$amcl_in_obj;
      $amcl_in_obj->process_policy_request($sock, $conn, \&check_mail, 1);
    } elsif ($sock->NS_proto eq 'TCP') {  # assume SMTP or LMTP
      $conn->socket_ip($prop->{sockaddr});
      $conn->socket_port($prop->{sockport});
      $conn->client_ip($prop->{peeraddr});
      if ($prop->{sockport} == 3330) {
        process_tcp_lookup_request($sock, $conn);
        do_log(2, Amavis::Timing::report());  # report elapsed times
      } elsif ($prop->{sockport} == 9998) {   # AM.PDP
        $amcl_in_obj = Amavis::In::AMCL->new  if !$amcl_in_obj;
        $amcl_in_obj->process_policy_request($sock, $conn, \&check_mail, 0);
      } elsif (!$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);
    }
  };  # eval
  alarm(0);          # stop the timer
  if ($@ ne '') {
    chomp($@);
    my($msg) = $@ eq "timed out"
      ? "Child task exceeded $child_timeout seconds, abort"
      : "TROUBLE in process_request: $@";
    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 ("Suicide (" . 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 = sprintf("amavisd (ch%d-avail)", $child_invocation_count);
  Amavis::Timing::go_idle('bye'); Amavis::Timing::report_load();
}

### Child is about to be terminated
### user customizable Net::Server hook
sub child_finish_hook {
  my($self) = shift;
  local $SIG{CHLD} = 'DEFAULT';
  $0 = sprintf("amavisd (ch%d-finish)", $child_invocation_count);
# 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)
  $body_digest_cache = undef;  # calls Amavis::Cache::DESTROY
}

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)
  $body_digest_cache = undef;  # calls Amavis::Cache::DESTROY
}

# implements Postfix TCP lookup server, see tcp_table(5) man page
sub process_tcp_lookup_request($$) {
  my($sock, $conn) = @_;
  local($/) = "\012";   # set line terminator to LF
  my($req_cnt);
  while (<$sock>) {
    $req_cnt++; my($level) = 0;
    my($resp_code, $resp_msg) = (400, 'INTERNAL ERROR');
    if (/^get (.*?)\015?\012\z/si) {
      my($key) = tcp_lookup_decode($1);
      my($sl); $sl = lookup($key,@spam_lovers_maps);
      $resp_code = 200; $level = 2;
      $resp_msg = $sl ? "OK Recipient <$key> IS spam lover"
                      : "DUNNO Recipient <$key> is NOT spam lover";
    } elsif (/^put ([^ ]*) (.*?)\015?\012\z/si) {
      $resp_code = 500; $resp_msg = 'request not implemented: ' . $_;
    } else {
      $resp_code = 500; $resp_msg = 'illegal request: ' . $_;
    }
    do_log($level, "tcp_lookup($req_cnt): $resp_code $resp_msg");
    $sock->printf("%03d %s\012", $resp_code, tcp_lookup_encode($resp_msg))
      or die "Can't write to tcp_lookup socket: $!";
  }
  do_log(0, "tcp_lookup: RUNDOWN after $req_cnt requests");
}

sub tcp_lookup_encode($) {
  my($str) = @_;
  $str =~ s/[^\041-\044\046-\176]/sprintf("%%%02x",ord($&))/eg;
  $str;
}

sub tcp_lookup_decode($) {
  my($str) = @_;
  $str =~ s/%([0-9a-fA-F]{2})/pack("C",hex($1))/eg;
  $str;
}

# 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; @detecting_scanners = ();
  @virusname = (); @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) =   # maxfiles 0 disables the $MAXFILES limit
    Amavis::Unpackers::NewFilename->new($MAXFILES?$MAXFILES:undef, $mail_size);
  Amavis::Unpackers::Part::init($file_generator_object); # fudge: keep in variable
  my($parts_root) = Amavis::Unpackers::Part->new;
  $msginfo->parts_root($parts_root);
  my($smtp_resp, $exit_code, $preserve_evidence);
  my($banned_filename_checked,$virus_presence_checked,$spam_presence_checked);

  # is any mail component password protected or otherwise non-decodable?
  my($any_undecipherable) = 0;

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

  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 {
    snmp_count('InMsgs');
    snmp_count('InMsgsNullRPath')  if $msginfo->sender eq '';

    $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?
    $which_section = "cached";
    snmp_count('CacheAttempts');
    my($cache_entry); my($now) = time;
    my($cache_entry_ttl) =
      max($virus_check_negative_ttl, $virus_check_positive_ttl,
          $spam_check_negative_ttl,  $spam_check_positive_ttl);
    my($now_utc_iso8601)     = strftime("%Y%m%dT%H%M%S",gmtime($now));
    my($expires_utc_iso8601) = strftime("%Y%m%dT%H%M%S",
                                        gmtime($now+$cache_entry_ttl));
    $cache_entry = $body_digest_cache->get($body_digest)
      if $body_digest_cache && defined $body_digest;
    if (!defined $cache_entry) {
      snmp_count('CacheMisses');
      $cache_entry->{'ctime'} = $now_utc_iso8601;  # create a new cache record
    } else {
      snmp_count('CacheHits');
      $banned_filename_checked = defined $cache_entry->{'FB'} ? 1 : 0;
      $virus_presence_checked  = defined $cache_entry->{'VN'} ? 1 : 0;

      # spam level and spam report may be influenced by mail header, not only
      # by mail body, so caching based on body is only a close approximation;
      # ignore spam cache if body is too small
      $spam_presence_checked = defined $cache_entry->{'SL'} ? 1 : 0;
      if ($msginfo->orig_body_size < 200) { $spam_presence_checked = 0 }

      if ($virus_presence_checked && defined $cache_entry->{'Vt'}) {
        # check for expiration of cached virus test results
        my($ttl) = !@{$cache_entry->{'VN'}} ? $virus_check_negative_ttl
                                            : $virus_check_positive_ttl;
        if ($now > $cache_entry->{'Vt'} + $ttl) {
          do_log(2,"Cached virus check expired, TTL = $ttl s");
          $virus_presence_checked  = 0;
        }
      }
      if ($spam_presence_checked && defined $cache_entry->{'St'}) {
        # check for expiration of cached spam test results
        my($ttl) = $cache_entry->{'SL'} < 6  ? $spam_check_negative_ttl
                                             : $spam_check_positive_ttl;
        if ($now > $cache_entry->{'St'} + $ttl) {
          do_log(2,"Cached spam check expired, TTL = $ttl s");
          $spam_presence_checked  = 0;
        }
      }
      if ($virus_presence_checked) {
        $av_output = $cache_entry->{'VO'};
        @virusname = @{$cache_entry->{'VN'}};
        @detecting_scanners = @{$cache_entry->{'VD'}};
      }
      @banned_filename = @{$cache_entry->{'FB'}}
        if $banned_filename_checked;
      ($spam_level, $spam_status, $spam_report) = @$cache_entry{'SL','SS','SR'}
        if $spam_presence_checked;
      do_log(1,sprintf("cached %s from <%s> (%s,%s,%s)",
                       $body_digest, $msginfo->sender,
                       $banned_filename_checked, $virus_presence_checked,
                       $spam_presence_checked));
      snmp_count('CacheHitsVirusCheck')   if $virus_presence_checked;
      snmp_count('CacheHitsVirusMsgs')    if @virusname;
      snmp_count('CacheHitsSpamCheck')    if $spam_presence_checked;
      snmp_count('CacheHitsSpamMsgs')     if $spam_level >= 6;
#     snmp_count('CacheHitsBannedCheck')  if $banned_filename_checked;
#     snmp_count('CacheHitsBannedMsgs')   if @banned_filename;
      do_log(5,sprintf("cache entry age: %s c=%s a=%s",
                  (@virusname ? 'V' : $spam_level > 5 ? 'S' : '.'),
                  $cache_entry->{'ctime'}, $cache_entry->{'atime'} ));
    }

    my($will_do_virus_scanning) =   # virus scanning will be needed?
       !$virus_presence_checked && $extra_code_antivirus &&
       grep {!lookup($_,@bypass_virus_checks_maps)} @recips;

    my($will_do_banned_checking) =  # banned name checking will be needed?
       !$banned_filename_checked &&
       (@banned_filename_maps || $banned_namepath_re) &&
       grep {!lookup($_,@bypass_banned_checks_maps)} @recips;

    # will do decoding parts as deeply as possible?  only if needed
    my($will_do_parts_decoding) =
       !$bypass_decode_parts &&
       ($will_do_virus_scanning || $will_do_banned_checking);

    $which_section = "mime_decode-1";
    my($ent,$mime_err) = mime_decode($fh, $tempdir, $parts_root);
    $msginfo->mime_entity($ent);
    push(@bad_headers, "MIME error: ".$mime_err)  if $mime_err ne '';
    prolong_timer($which_section);

    if ($will_do_parts_decoding) {
      # decoding parts can take a lot of time!
      snmp_count('OpsDec');
      ($hold,$any_undecipherable) =
        Amavis::Unpackers::decompose_mail($tempdir,$file_generator_object);
    }
    if (grep {!lookup($_,@bypass_header_checks_maps)} @recips) {
      push(@bad_headers, check_header_validity($conn,$msginfo));
    }
    if ($will_do_banned_checking) {      # check for banned file contents
      $which_section = "check-banned";
      my($banned_filenames_ref) = check_for_banned_names($parts_root);
      push(@banned_filename, @$banned_filenames_ref);
    }
    $cache_entry->{'FB'} = \@banned_filename;

    if ($virus_presence_checked) {
      do_log(5, "virus_presence cached, skipping virus_scan");
    } elsif (!$extra_code_antivirus) {
      do_log(5, "No anti-virus code loaded, skipping virus_scan");
    } elsif (!grep {!lookup($_,@bypass_virus_checks_maps)} @recips) {
      do_log(5, "bypassing of virus checks requested");
    } elsif ($will_do_virus_scanning && $hold ne '') {
      # protect virus scanner from mail bombs
      do_log(0, "NOTICE: Virus scanning skipped: $hold");
      $will_do_virus_scanning = 0;
    } elsif (!$will_do_virus_scanning) {
      do_log(0, "NOTICE: will_do_virus_scanning is false???");
    } else {
      if (!defined($msginfo->mime_entity)) {
        $which_section = "mime_decode-3";
        $msginfo->mime_entity(mime_decode($fh, $tempdir, $parts_root));
        prolong_timer($which_section);
      }
      # special case to preserve complete mail file for inspection
      if (lookup('MAIL',@keep_decoded_original_maps) ||
          $any_undecipherable && lookup('MAIL-UNDECIPHERABLE',
                                        @keep_decoded_original_maps)) {
        # keep the original email.txt by making a hard link to it in ./parts/
        $which_section = "linking-to-MAIL";
        my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",
                                                        $parts_root);
        my($newpart) = $newpart_obj->full_name;
        do_log(4, "providing full original message to scanners as $newpart".
           (!$any_undecipherable ?'' :", $any_undecipherable undecipherable"));
        link("$tempdir/email.txt", $newpart)
          or die "Can't create hard link $newpart to $tempdir/email.txt: $!";
        $newpart_obj->type_short('MAIL');
        $newpart_obj->type_declared('message/rfc822');
        # we don't want this pseudo part to be decoded twice
        # $file_generator_object->parts_list_reset;  # (not needed any longer)
      }
      $which_section = "virus_scan";
      my($virus_scan_time) = time;     # current timestamp
      # some virus scanners behave badly if interrupted,
      # so for now just turn off the timer
      my($remaining_time) = alarm(0);  # check time 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($@);
        if ($@ eq "timed out") {
          @virusname = (); $av_ret = 0;  # assume not a virus!
          do_log(0, "virus_scan TIMED OUT, ASSUME NOT A VIRUS !!!");
        } else {
          $hold = "virus_scan: $@";  # request HOLD
          $av_ret = 0;               # pretend it was ok (msg should be held)
          die "$hold\n";             # die, TEMPFAIL is preferred to HOLD
        }
      }
      snmp_count('OpsVirusCheck');
      defined($av_ret) or die "All virus scanners failed!";
      @$cache_entry{'Vt','VO','VN','VD'} =
        ($virus_scan_time, $av_output, \@virusname, \@detecting_scanners);
      $virus_presence_checked = 1;
    }

    my($sender_contact,$sender_source);
    if (!@virusname) { $sender_contact = $sender_source = $msginfo->sender }
    else {
      ($sender_contact,$sender_source) = best_try_originator(
                        $msginfo->sender, $msginfo->mime_entity, \@virusname);
      section_time('best_try_originator');
    }
    $msginfo->sender_contact($sender_contact);  # save it
    $msginfo->sender_source($sender_source);    # save it

    # 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;
    section_time('wb-list');
    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_maps)} @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);
      snmp_count('OpsSpamCheck');
      @$cache_entry{'St','SL','SS','SR'} =
        (time, $spam_level, $spam_status, $spam_report);
      $spam_presence_checked = 1;
    }

    # store to cache
    $cache_entry->{'atime'} = $now_utc_iso8601;     # update accessed timestamp
    $body_digest_cache->set($body_digest,$cache_entry,
                            $now_utc_iso8601,$expires_utc_iso8601)
      if $body_digest_cache && defined $body_digest;
    $cache_entry = undef;  # discard the object, it is no longer needed
    section_time('update_cache');

    for (@virusname) { snmp_count("virus.byname.$_") }

    # 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
      # bad_headers do not enter this section, although code is ready for them
      $which_section = "deal_with_virus_or_banned";
      my($final_destiny) = @virusname       ? $final_virus_destiny
                         : @banned_filename ? $final_banned_destiny
                         : @bad_headers     ? $final_bad_header_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_maps)) &&
                 (!@banned_filename ||     # not banned or we want it
                  lookup($r->recip_addr, @banned_files_lovers_maps)) &&
                 (!@bad_headers ||         # not bad header or we want it
                  lookup($r->recip_addr, @bad_header_lovers_maps)) )
        {
          # 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) }
          elsif (@bad_headers)
            { $reason = "BAD_HEADER: " . join(", ", @bad_headers) }
          $reason = substr($reason,0,100)."..."  if length($reason) > 100+3;
          $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);
        }
      }
      $which_section = "virus_or_banned quar+notif";
      ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
      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_whitelisted_sender &&
          ($r->recip_blacklisted_sender ||
           defined $spam_level && $spam_level>=lookup($r->recip_addr,
                                                      @spam_kill_level_maps));
        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 ||
            lookup($r->recip_addr, @spam_lovers_maps)) {
          # 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);
        }
      }
      if ($considered_spam_by_some_recips) {
        $which_section = "spam quar+notif";
        ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
        do_spam($conn, $msginfo);
        section_time('post-do_spam');
      }
    }

    if (@bad_headers) {  # invalid mail headers
      $which_section = "deal_with_bad_headers";
      ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
      my($is_bulk) = $msginfo->mime_entity->head->get('precedence', 0);
      chomp($is_bulk);
      do_log(1,sprintf("BAD HEADER from %s<%s>: %s",
                       $is_bulk eq '' ? '' : "($is_bulk) ", $msginfo->sender,
                       $bad_headers[0]));
      $is_bulk = $is_bulk=~/(bulk|list|junk)/i ? $1 : undef;
      if (defined $is_bulk || $msginfo->sender eq '') {
        # have mercy on mailing lists and DSN
      } else {
        my($any_badh);
        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_maps))
          {
            # 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"
                        : "554 5.6.0 Message with invalid header rejected"
                      ) . ", id=$am_id - $reason");
            $r->recip_done(1);
            $any_badh++;
          }
        }
        if ($any_badh) {  # we use the same code as for viruses or banned
                          # but only if it wasn't already handled as spam
          do_virus($conn, $msginfo);  # send notifications, quarantine it
        }
      }
      section_time($which_section);
    }

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

#   $which_section = "checking_sender_ip";
#   my(@recips) = @{$msginfo->recips};
#   if ($considered_spam_by_some_recips && @recips==1 &&
#       $recips[0] eq $msginfo->sender &&
#       lookup($msginfo->sender, @local_domains_maps))
#   {
#     my(@mynetworks) = qw(127/8 10/8 172.16/12 192.168/16);  # adjust to will
#     ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
#     my($ip) = fish_out_ip_from_received(
#                              $msginfo->mime_entity->head->get('received',0));
#     my($our_ip) = eval { lookup_ip_acl($ip,\@mynetworks) };
#     if (defined($ip) && ($@ ne '') && !$our_ip) {
#       do_log(0, "FAKE SENDER, SPAM: $ip, " . $msginfo->sender);
#       $msginfo->sender_contact(undef);  # believed to be faked
#     }
#   }

    if ($hold ne '') { do_log(0, "NOTICE: HOLD reason: $hold") }

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

    my($which_content_counter) = @virusname ? 'ContentVirusMsgs'
      : @banned_filename ? 'ContentBannedMsgs'
      : $considered_spam_by_some_recips ? 'ContentSpamMsgs'
      : @bad_headers ? 'ContentBadHdrMsgs' : 'ContentCleanMsgs';
    snmp_count($which_content_counter);

    if ($msginfo->delivery_method eq '') {   # AM.PDP / milter
      $which_section = "AM.PDP headers";
      ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
      my($hdr_edits) = Amavis::Out::EditHeader->new;
      $hdr_edits = add_forwarding_header_edits_common(
        $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
        $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, $any_undecipherable,
          $virus_presence_checked, $spam_presence_checked, undef);
      $msginfo->header_edits($hdr_edits);  # store edits
      if (@$recip_cl && !$done_all) {
        do_log(0, "AM.PDP: CLIENTS REQUIRE DIFFERENT HEADERS");
      };
    } elsif (grep { !$_->recip_done } @{$msginfo->per_recip_data}) {
      # to be delivered explicitly, and there are recipients still to be done
      $which_section = "forwarding";
      ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
      # will forward only to those recipients not yet marked
      # as 'done' by the above content filtering sections
      if ($hold ne '' || @virusname || @banned_filename
###       || $considered_spam_by_some_recips     # or spam
      ) {  # malware
        # a quick-fix solution to defang dangerous contents
        my($explanantion) =
            $hold ne ''      ? "WARNING, possible mail bomb, NOT CHECKED FOR VIRUSES:\n  $hold"
          : @virusname       ? 'WARNING: contains virus '.join(' ',@virusname)
          : @banned_filename ? "WARNING: contains banned part"
          : $considered_spam_by_some_recips ? $spam_report
          : @bad_headers     ? "WARNING: bad headers" : '';
        $explanantion .= "\n"  if $explanantion !~ /\n\z/;
        my($s) = $explanantion; $s=~s/[ \t\n]+\z//;
        if (length($s) > 100) { $s = substr($s,0,100-3) . "..." }
        do_log(0, "DEFANGING MAIL: $s");
        my($d) = defanged_mime_entity($conn,$msginfo,$explanantion);
        $msginfo->mail_text($d);  # substitute mail with rewritten version
        section_time('defang');
      }
      for (;;) {  # do the delivery
        my($hdr_edits) = Amavis::Out::EditHeader->new;
        $hdr_edits = add_forwarding_header_edits_common(
          $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
          $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, $any_undecipherable,
            $virus_presence_checked, $spam_presence_checked, undef);
        last  if !@$recip_cl;
        $msginfo->header_edits($hdr_edits);  # store edits
        mail_dispatch($conn, $msginfo, 0,
                      sub { my($r) = @_; grep { $_ eq $r } @$recip_cl });
        snmp_count('OutForwMsgs');
        snmp_count('OutForwHoldMsgs')  if $hold ne '';
        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, $am_id);
    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(4, sprintf(
      "warnsender_with_pass=%s (%s,%s,%s,%s), dsn_needed=%s, exit=%s, %s",
      $warnsender_with_pass,$warnvirussender,$warnbannedsender,
      $warnbadhsender,$warnspamsender, $dsn_needed,$exit_code,$smtp_resp));
    if ($dsn_needed || $warnsender_with_pass) {
      ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
      my($what_bad_content) = join(' & ',
        !@virusname                      ? () : 'VIRUS',
        !@banned_filename                ? () : 'BANNED',
        !@bad_headers                    ? () : 'BAD HEADER',
        !$considered_spam_by_some_recips ? () : 'SPAM');
      my($notification);
      if ($msginfo->sender eq '') {  # don't respond to null reverse path
        my($msg) = "DSN contains $what_bad_content; bounce is not bouncable";
        if (!$dsn_needed) { do_log(4, $msg) }
        else { do_log(0, "NOTICE: $msg, mail intentionally dropped") }
        $msginfo->dsn_sent(2);       # pretend the message was bounced
      } elsif ($msginfo->sender_contact eq '') {
        my($msg) = sprintf("Not sending DSN to believed-to-be-faked "
                           . "sender <%s>, mail containing %s",
                           $msginfo->sender, $what_bad_content);
        if (!$dsn_needed) { do_log(4, $msg) }
        else { do_log(2, "NOTICE: $msg intentionally dropped") }
        $msginfo->dsn_sent(2);       # pretend the message was bounced
      } elsif (defined $spam_level && defined $sa_dsn_cutoff_level &&
               $spam_level >= $sa_dsn_cutoff_level) {
        my($msg) = "Not sending DSN, spam level $spam_level exceeds DSN cutoff level";
        if (!$dsn_needed) { do_log(4, $msg) }
        else { do_log(0, "NOTICE: $msg, mail intentionally dropped") }
        $msginfo->dsn_sent(2);  # pretend the message was bounced
      } elsif ((@virusname || @banned_filename || @bad_headers ||
                $considered_spam_by_some_recips) &&
          $msginfo->mime_entity->head->get('precedence',0)=~/bulk|list|junk/i)
      {
        my($msg) = sprintf("Not sending DSN in response to bulk mail "
                           . "from <%s> containing %s",
                           $msginfo->sender, $what_bad_content);
        if (!$dsn_needed) { do_log(4, $msg) }
        else { do_log(0, "NOTICE: $msg, mail intentionally dropped") }
        $msginfo->dsn_sent(2);       # pretend the message was bounced
      } else {
        my($which_dsn_counter,$dsnmsgref);
        ### TODO: better selection of DSN reason is needed!
        for my $r (@{$msginfo->per_recip_data}) {
          next  if !$r->recip_done;
          local($_) = $r->recip_smtp_response;
          ($which_dsn_counter,$dsnmsgref) =
              /^5.*\bVIRUS\b/ ?('OutDsnVirusMsgs', \$notify_virus_sender_templ)
            : /^5.*\bBANNED\b/?('OutDsnBannedMsgs',\$notify_virus_sender_templ)
            : /^5.*\bheader\b/?('OutDsnBadHdrMsgs',\$notify_sender_templ)
            : /^5.*\b(?:UBE|blacklisted)\b/ ?
              ('OutDsnSpamMsgs', \$notify_spam_sender_templ)
            : ('OutDsnOtherMsgs',\$notify_sender_templ);
        }
        # generate delivery status notification according to rfc3462
        # and rfc3464, but only if necessary
        $notification = delivery_status_notification($conn, $msginfo,
          $warnsender_with_pass, \%builtins, $dsnmsgref)  if $dsnmsgref;
        snmp_count($which_dsn_counter)  if defined $notification;
      }
      if (defined $notification) {  # dsn needed, send delivery notification
        mail_dispatch($conn, $notification, 1);
        snmp_count('OutDsnMsgs');
        my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
          one_response_for_all($notification, 0, $am_id);  # check status
        if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) {      # dsn successful?
          $msginfo->dsn_sent(1);  # mark the message as bounced
        } elsif ($n_smtp_resp =~ /^4/) {
          snmp_count('OutDsnTempFails');
          die sprintf("temporarily unable to send DSN to <%s>: %s",
                      $msginfo->sender, $n_smtp_resp);
        } else {
          snmp_count('OutDsnRejects');
          do_log(0,sprintf("NOTICE: UNABLE TO SEND DSN to <%s>: %s",
                           $msginfo->sender, $n_smtp_resp));
#         # if dsn can not be sent, try to send it to postmaster
#         $notification->recips(['postmaster']);
#         # attempt double bounce
#         mail_dispatch($conn, $notification, 1);
        }
      # $notification->purge;
      }
    }
    prolong_timer($which_section);

    $which_section = "finishing";
    # generate customized log report at log level 0 - this is usually
    # the only log entry interesting to administrators during normal operation
    my($strr) = expand(\$log_templ, \%builtins);
    for my $logline (split(/[ \t]*\n/, $$strr)) {
      do_log(0, $logline)  if $logline ne '';
    }
    section_time('main_log_entry');

    $body_digest_cache->update_counters;
    section_time('update_snmp');

  };  # 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 '') {
    do_log(0, "NOTICE: Evidence is to be preserved: $hold");
    $preserve_evidence = 1;
  }
  if (!$preserve_evidence && debug_oneshot()) {
    do_log(0, "DEBUG_ONESHOT CAUSES EVIDENCE TO BE PRESERVED");
    $preserve_evidence = 1;
  }

  my($which_counter) = 'InUnknown';
  if    ($smtp_resp =~ /^4/) { $which_counter = 'InTempFails' }
  elsif ($smtp_resp =~ /^5/) { $which_counter = 'InRejects' }
  elsif ($smtp_resp =~ /^2/) {
    my($dsn_sent) = $msginfo->dsn_sent;
    if (!$dsn_sent) { $which_counter = $msginfo->delivery_method ne ''
                                       ? 'InAccepts' : 'InContinues' }
    elsif ($dsn_sent==1) { $which_counter = 'InBounces' }
    elsif ($dsn_sent==2) { $which_counter = 'InDiscards' }
  }
  snmp_count($which_counter);

  $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, $parts_root) = @_;
  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, $parts_root));
    prolong_timer("ensure_mime_entity");
  }
}

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

  $hdr_edits->prepend_header('Received',
    received_line($conn,$msginfo,am_id(),1), 1)
    if $insert_received_line && $msginfo->delivery_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, "Inserting header field: X-Amavis-Hold: $hold");
  }
  if ($extra_code_antivirus) {
    $hdr_edits->delete_header('X-Amavis-Alert');
    $hdr_edits->delete_header($X_HEADER_TAG)
      if $remove_existing_x_scanned_headers &&
         ($X_HEADER_LINE && $X_HEADER_TAG =~ /^[!-9;-\176]+\z/);
  }
  if ($extra_code_antispam) {
    if ($remove_existing_spam_headers) {
      for my $h (qw(
          X-Spam-Status X-Spam-Level X-Spam-Flag X-Spam-Score X-Spam-Report
          X-Spam-Checker-Version X-Spam-Tests X-Scanned-By
          X-DSPAM-Result X-DSPAM-Signature X-DSPAM-Probability X-DSPAM-User)) {
        $hdr_edits->delete_header($h);
      }
    }
  # $hdr_edits->append_header('X-Spam-Checker-Version',
  # sprintf("SpamAssassin %s (%s) on %s", Mail::SpamAssassin::Version(),
  #         $Mail::SpamAssassin::SUB_VERSION, $myhostname));
  }
  $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, $any_undecipherable,
     $virus_presence_checked, $spam_presence_checked, $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);
  my($first) = 1; my($cluster_key); my($cluster_full_spam_status);
  for my $r (@per_recip_data) {
    my($recip) = $r->recip_addr;
    my($is_local,$blacklisted,$whitelisted,$tag_level,$tag2_level,
       $do_tag_virus_checked,$do_tag_virus,$do_tag_banned,$do_tag_badh,
       $do_tag,$do_tag2,$do_subj,$do_subj_u);
    $is_local    = lookup($recip, @local_domains_maps);
    $do_tag_badh = @bad_headers && !lookup($recip,@bypass_header_checks_maps);
    $do_tag_banned = @banned_filename &&
                     !lookup($recip,@bypass_banned_checks_maps);
    $do_tag_virus = @virusname && !lookup($recip,@bypass_virus_checks_maps);
    $do_tag_virus_checked =
      ($X_HEADER_LINE && $X_HEADER_TAG =~ /^[!-9;-\176]+\z/) &&
      $virus_presence_checked && !lookup($recip,@bypass_virus_checks_maps);
    if ($extra_code_antispam) {
      my($bypassed);
      $blacklisted = $r->recip_blacklisted_sender;
      $whitelisted = $r->recip_whitelisted_sender;
      $bypassed    = lookup($recip, @bypass_spam_checks_maps);
      $tag_level   = lookup($recip, @spam_tag_level_maps);
      $tag2_level  = lookup($recip, @spam_tag2_level_maps);
      # spam-related headers should _not_ be inserted for:
      #  - nonlocal recipients (outgoing mail), as a matter of courtesy
      #    to our users;
      #  - recipients matching bypass_spam_checks: even though spam checking
      #    may have been done for other reasons, these recipients do not
      #    expect such headers, so let's pretend the check has not been done
      #    and not insert spam-related headers for them
      $do_tag  = $is_local && !$bypassed &&
        ($blacklisted ||
         defined $spam_level ? $spam_level >= $tag_level
         : $whitelisted      ?         -10 >= $tag_level : 0);
      $do_tag2 = $is_local && !$bypassed && !$whitelisted &&
        ($blacklisted || defined $spam_level && $spam_level >= $tag2_level);
      $do_subj = ( $do_tag2 && $sa_spam_subject_tag ne '' ||
                   ($do_tag || $do_tag2) && $sa_spam_subject_tag1 ne ''
                 ) && lookup($recip, @spam_modifies_subj_maps);
    }
    if ($hold ne '' || $any_undecipherable) { # adding *UNCHECKED* subject tag?
       $do_subj_u = $undecipherable_subject_tag ne '' &&
                    $is_local && !@virusname &&
                    !lookup($recip, @bypass_virus_checks_maps);
    }
    for ($do_tag_virus_checked, $do_tag_virus, $do_tag_banned, $do_tag_badh,
         $do_tag, $do_tag2, $do_subj, $do_subj_u) { $_ = $_?1:0 }  # normalize
    my($spam_level_bar, $full_spam_status);
    if ($do_tag || $do_tag2) {
      $spam_level_bar =
        $sa_spam_level_char x min($blacklisted ? 64 : $spam_level+0, 64)
        if $sa_spam_level_char ne '';
      $full_spam_status = sprintf(
        "%s,\n hits=%s\n tagged_above=%3.1f\n required=%3.1f\n %s%s",
        $do_tag2 ? 'Yes' : 'No',
        !defined $spam_level ? '-' : sprintf("%3.1f", $spam_level),
        $tag_level, $tag2_level,
        join('', $blacklisted ? "BLACKLISTED\n " : (),
                 $whitelisted ? "WHITELISTED\n " : ()),
        $spam_status);
    }
    my($key) = join("\000",
      $do_tag_virus_checked, $do_tag_virus, $do_tag_banned, $do_tag_badh,
      $do_tag, $do_tag2, $do_subj, $do_subj_u, $spam_level_bar,
      $full_spam_status);
    if ($first) {
      do_log(5,sprintf(
        "headers CLUSTERING: NEW CLUSTER <%s>: ".
        "hits=%s, tag=%d, tag2=%d, subj=%d, subj_u=%d, local=%d, bl=%d",
        $recip,
        !defined $spam_level ?'-' :sprintf("%3.1f",$spam_level),
        $do_tag, $do_tag2, $do_subj, $do_subj_u, $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;  # this recipient will be handled in some later pass
    }

    if ($first) {  # insert headers required for the new cluster
      if ($do_tag_virus_checked) {
        $hdr_edits->append_header($X_HEADER_TAG, $X_HEADER_LINE);
      }
      if ($do_tag_virus) {
        $hdr_edits->append_header('X-Amavis-Alert',
          "INFECTED, message contains virus:\n " . join(",\n ",@virusname), 1);
      }
      if ($do_tag_banned) {
        my(@b) = @banned_filename>3 ? @banned_filename[0..2] :@banned_filename;
        my($msg) = "BANNED, message contains "
          . (@banned_filename==1 ? 'part' : 'parts') . ":\n "
          . join(",\n ", @b) . (@banned_filename > @b ? ", ..." : "");
        $hdr_edits->append_header('X-Amavis-Alert', $msg, 1);
      }
      if ($do_tag_badh) {
        $hdr_edits->append_header('X-Amavis-Alert',
                                  'BAD HEADER '.$bad_headers[0], 1);
      }
      if ($do_tag) {
        $hdr_edits->append_header('X-Spam-Status', $full_spam_status, 1);
#       $hdr_edits->append_header('X-Spam-Score',
#         !defined $spam_level ? '-' : sprintf("%3.1f",$spam_level) );
        $hdr_edits->append_header('X-Spam-Level',
                                  $spam_level_bar)  if defined $spam_level_bar;
      }
      if ($do_tag2) {
        $hdr_edits->append_header('X-Spam-Flag', 'YES');
        $hdr_edits->append_header('X-Spam-Report', $spam_report,1)
          if $sa_spam_report_header && $spam_report ne '';
      }
      if ($do_subj || $do_subj_u) {
        my($s) = '';
        if ($do_subj_u) {
          $s = $undecipherable_subject_tag;
          do_log(3,"adding $undecipherable_subject_tag, $any_undecipherable, $hold");
        }
        if ($do_subj) {
          $s .= $do_tag2 && $sa_spam_subject_tag ne '' ? $sa_spam_subject_tag
                                                       : $sa_spam_subject_tag1;
        }
        my($entity) = $msginfo->mime_entity;
        if (defined $entity && defined $entity->head->get('Subject',0)) {
          $hdr_edits->edit_header('Subject',
                                 sub { $_[1]=~/^([ \t]?)(.*)\z/s; ' '.$s.$2 });
        } else {  # no Subject header field present, insert one
          $s =~ s/[ \t]+\z//;  # trim
          $hdr_edits->append_header('Subject', $s);
          if (!defined $entity) {
            do_log(0,"WARN: no MIME entity!? Inserting 'Subject'");
          } else {
            do_log(0,"INFO: no existing header field 'Subject', inserting it");
          }
        }
      }
    }
    push(@recip_cluster,$r);  $first = 0;

    # append address extensions to mailbox names if desired
    my($ext) = $do_tag_virus  ? $addr_extension_virus
             : $do_tag_banned ? $addr_extension_banned
             : $do_tag2       ? $addr_extension_spam
             : $do_tag_badh   ? $addr_extension_bad_header : '';
    if ($recipient_delimiter ne '' && $ext ne '' && $is_local) {
      my($localpart,$domain) = split_address($recip);
      if ($replace_existing_extension)  # strip existing address extensions
        { $localpart =~ s/^(.*?)\Q$recipient_delimiter\E.*\z/$1/s }
      do_log(5,"adding address extension $recipient_delimiter$ext".
               " to $localpart\@$domain");
      $r->recip_addr_modified($localpart.$recipient_delimiter.$ext.$domain);
    }
  }
  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[ \t]/ /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,$snmp_id) = @_;
  if ($quarantine_method eq '') { do_log(5, "quarantine disabled") }
  else {
    # NOTE: RFC2821 mentions possible headers X-SMTP-MAIL and X-SMTP-RCPT
    # Inserting return path may be redundant (depending on quarantine method),
    # but let's insert X-Envelope-From header unconditionally nevertheless.
    $hdr_edits->prepend_header('X-Envelope-From',
      qquote_rfc2821_local($msginfo->sender));
    # Exim uses: Envelope-To,  Sendmail uses X-Envelope-To
    $hdr_edits->prepend_header('X-Envelope-To',
      join(",\n ", qquote_rfc2821_local(@{$msginfo->recips})), 1);

    my($quar_msg) = Amavis::In::Message->new;
    $quar_msg->delivery_method($quarantine_method);
    $quar_msg->sender(defined $mailfrom_to_quarantine
                        ? $mailfrom_to_quarantine : $msginfo->sender);
    $quar_msg->auth_submitter(qquote_rfc2821_local($quar_msg->sender));
    $quar_msg->auth_user($amavis_auth_user);
    $quar_msg->auth_pass($amavis_auth_pass);
    do_log(5, "DO_QUARANTINE, sender: " . $quar_msg->sender);
    $quar_msg->recips($quarantine_method =~ /^bsmtp:/i
                        ? $msginfo->recips  # original recipients, bsmtp:
                        : $recips_ref);     # e.g. per-recip domain quarantine
    $quar_msg->header_edits($hdr_edits);
    $quar_msg->mail_text($msginfo->mail_text);  # use the same mail contents

    # fudge to get to the body_digest of $msginfo, not of $quar_msg
    $quarantine_method =~ s/%b/$msginfo->body_digest/eg;
    snmp_count('QuarMsgs');
    mail_dispatch($conn, $quar_msg, 1);
    my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
      one_response_for_all($quar_msg, 0, am_id());  # check status
    if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) {   # ok
      snmp_count($snmp_id eq '' ? 'QuarOther' : $snmp_id);
    } elsif ($n_smtp_resp =~ /^4/) {
      snmp_count('QuarAttemptTempFails');
      die "temporarily unable to quarantine: $n_smtp_resp";
    } else {  # abort if quarantining not successful
      snmp_count('QuarAttemptFails');
      die "Can not quarantine: $n_smtp_resp";
    }
    my(@qa);  # collect a 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/banned/bad-header found - quarantine it and send notifications
sub do_virus($$) {
  my($conn, $msginfo) = @_;
  my($quarantine_method, $quarantine_to_maps_ref, $bypass_checks_maps_ref) =
    @virusname ?
      ($virus_quarantine_method,
       \@virus_quarantine_to_maps,
       \@bypass_virus_checks_maps)
    : @banned_filename ?
      ($banned_files_quarantine_method,
       \@banned_quarantine_to_maps,
       \@bypass_banned_checks_maps)
    : @bad_headers ?
      ($bad_header_quarantine_method,
       \@bad_header_quarantine_to_maps,
       \@bypass_header_checks_maps)
    : (undef, undef, undef);

  # suggest a name to be used as 'X-Quarantine-id:' or file name
  $VIRUSFILE = $quarantine_method =~ /^(?:local|bsmtp):(.*)\z/si ?
                 $1 : "virus-%i-%n";
  $VIRUSFILE =~ s{%(.)}
    {  $1 eq 'b' ? $msginfo->body_digest
     : $1 eq 'i' ? strftime("%Y%m%d-%H%M%S",localtime)
     : $1 eq 'n' ? am_id()
     : $1 eq '%' ? '%' : '%'.$1 }eg;
  # prepare header edits for the quarantined message
  my($hdr_edits) = Amavis::Out::EditHeader->new;
  $hdr_edits->prepend_header('X-Quarantine-id', "<$VIRUSFILE>");

  if (@virusname) {
    $hdr_edits->append_header('X-Amavis-Alert',
      "INFECTED, message contains virus:\n " . join(",\n ", @virusname), 1);
  }
  if (@banned_filename) {
    my(@b) = @banned_filename>3 ? @banned_filename[0..2] : @banned_filename;
    my($msg) = "BANNED, message contains "
               . (@banned_filename==1 ? 'part' : 'parts') . ":\n "
               . join(",\n ", @b) . (@banned_filename > @b ? ", ..." : "");
    $hdr_edits->append_header('X-Amavis-Alert', $msg, 1);
  }
  if (@bad_headers) {
    $hdr_edits->append_header('X-Amavis-Alert',
                              'BAD HEADER '.$bad_headers[0], 1);
  }
  my(@q_addr);  # obtain per-recipient quarantine address(es)
  for my $r (@{$msginfo->per_recip_data}) {
    my($a); $a = lookup($r->recip_addr, @$quarantine_to_maps_ref);
    push(@q_addr, $a)  if $a ne '' && !grep { $_ eq $a } @q_addr;
  }
  do_quarantine($conn, $msginfo, $hdr_edits, \@q_addr, $quarantine_method,
                @virusname ? 'QuarVirusMsgs' : 'QuarBannedMsgs')  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); $admin = lookup($msginfo->sender_source, @virus_admin_maps);
  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_maps)) {
#   do_log(2, "Skip virus_admin notification for <".
#             $msginfo->sender . ">, non-local sender");
  } else {  # notify virus admin
    my($notification) = Amavis::In::Message->new;
    $notification->delivery_method($notify_method);
    $notification->sender($mailfrom_notify_admin);
    $notification->auth_submitter(qquote_rfc2821_local($mailfrom_notify_admin));
    $notification->auth_user($amavis_auth_user);
    $notification->auth_pass($amavis_auth_pass);
    $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($conn, $notification, 1);
    my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
      one_response_for_all($notification, 0, am_id());  # check status
    if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) {       # ok
    } elsif ($n_smtp_resp =~ /^4/) {
      die "temporarily unable to notify virus admin: $n_smtp_resp";
    } else {
      do_log(0, "FAILED to notify virus admin: $n_smtp_resp");
    }
    # $notification->purge;
  }

  if (! ($warnvirusrecip  && @virusname ||
         $warnbannedrecip && @banned_filename ||
         $warnbadhrecip   && @bad_headers) ) {
    # warnrecip disabled (common, enabling is usually counterproductive)
    do_log(5,"do_virus: recipient notifications disabled");
# } elsif (! defined($msginfo->sender_contact) ) {
#   do_log(5,"do_virus: skip recipient notifications for unknown senders");
  } else {  # send notification to recipients
    my(@locals) =
      grep { @virusname       && !lookup($_,@bypass_virus_checks_maps) ?
               $warnvirusrecip
           : @banned_filename && !lookup($_,@bypass_banned_checks_maps) ?
               $warnbannedrecip
           : @bad_headers     && !lookup($_,@bypass_header_checks_maps) ?
               $warnbadhrecip
           : 0 }
      grep { $warn_offsite || lookup($_,@local_domains_maps) }
      @{$msginfo->recips};
    if (!@locals) {
      do_log(5,"do_virus: recipient notifications not required");
    } else {
      my($notification) = Amavis::In::Message->new;
      $notification->delivery_method($notify_method);
      $notification->sender($mailfrom_notify_recip);
      $notification->auth_submitter(qquote_rfc2821_local($mailfrom_notify_recip));
      $notification->auth_user($amavis_auth_user);
      $notification->auth_pass($amavis_auth_pass);
      $notification->recips(\@locals);
      my(%mybuiltins) = %builtins;  # make a local copy
      $mybuiltins{'f'} = $hdrfrom_notify_admin;             # 'From:'
      $mybuiltins{'T'} = [quote_rfc2821_local($locals[0])]  # 'To:'
        if @locals==1 && $locals[0] ne '';
      $notification->mail_text(string_to_mime_entity(
                          expand(\$notify_virus_recips_templ, \%mybuiltins) ));
      $notification->header_edits($hdr_edits);
      mail_dispatch($conn, $notification, 1);
      my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
        one_response_for_all($notification, 0, am_id());  # check status
      if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) {       # ok
      } elsif ($n_smtp_resp =~ /^4/) {
        die "temporarily unable to notify recipients: $n_smtp_resp";
      } else {
        do_log(0, "FAILED to notify 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
  $VIRUSFILE = $spam_quarantine_method =~ /^(?:local|bsmtp):(.*)\z/si ?
                 $1 : "spam-%b-%i-%n";
  $VIRUSFILE =~ s{%(.)}
    {  $1 eq 'b' ? $msginfo->body_digest
     : $1 eq 'i' ? strftime("%Y%m%d-%H%M%S",localtime)
     : $1 eq 'n' ? am_id()
     : $1 eq '%' ? '%' : '%'.$1 }eg;
  # use the smallest value as the level reported in quarantined headers!
  my($tag_level) =
    min(map { scalar(lookup($_,@spam_tag_level_maps))  } @{$msginfo->recips});
  my($tag2_level) =
    min(map { scalar(lookup($_,@spam_tag2_level_maps)) } @{$msginfo->recips});
  my($kill_level) =
    min(map { scalar(lookup($_,@spam_kill_level_maps)) } @{$msginfo->recips});
  my($blacklisted) =
    scalar(grep { $_->recip_blacklisted_sender } @{$msginfo->per_recip_data});
  my($whitelisted) =
    scalar(grep { $_->recip_whitelisted_sender } @{$msginfo->per_recip_data});
  my($full_spam_status) = sprintf(
    "%s,\n hits=%s\n tag1=%3.1f\n tag2=%3.1f\n kill=%3.1f\n %s%s",
    (defined $spam_level && $spam_level >= $tag2_level ? 'Yes' : 'No'),
    !defined $spam_level ? '-' : sprintf("%3.1f",$spam_level),
    $tag_level, $tag2_level, $kill_level,
    join('', $blacklisted ? "BLACKLISTED\n " : (),
             $whitelisted ? "WHITELISTED\n " : ()),
    $spam_status);
# my($s) = $spam_status;      $s =~ s/\n[ \t]//g;
  my($s) = $full_spam_status; $s =~ s/\n[ \t]/ /g;

  do_log(5, "do_spam: looking for a quarantine address");
  my(@q_addr);  # quarantine address(es)
  if (@spam_quarantine_bysender_to_maps) {   # by-sender quarantine
    my($a); $a = lookup($msginfo->sender, @spam_quarantine_bysender_to_maps);
    push(@q_addr, $a)  if $a ne '';
  }
  for my $r (@{$msginfo->per_recip_data}) {  # per-recipient quarantine
    my($a); $a = lookup($r->recip_addr, @spam_quarantine_to_maps);
    push(@q_addr, $a)  if $a ne '' && !grep { $_ eq $a } @q_addr;
  }
  if (@q_addr || $spam_quarantine_method!~/^local:/i) {  # 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-Score',
#     !defined $spam_level ? '-' : sprintf("%3.1f",$spam_level) );
    $hdr_edits->append_header('X-Spam-Level',
                              $sa_spam_level_char x min(0+$spam_level,64))
                              if $sa_spam_level_char ne '';
    $hdr_edits->append_header('X-Spam-Report', $spam_report,1)
      if $sa_spam_report_header && $spam_report ne '';
    do_quarantine($conn, $msginfo, $hdr_edits, \@q_addr,
                  $spam_quarantine_method, 'QuarSpamMsgs');
  }
  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); $admin = lookup($msginfo->sender, @spam_admin_maps);
  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->delivery_method($notify_method);
    $notification->sender($mailfrom_notify_spamadmin);
    $notification->auth_submitter(qquote_rfc2821_local($mailfrom_notify_spamadmin));
    $notification->auth_user($amavis_auth_user);
    $notification->auth_pass($amavis_auth_pass);
    $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($conn, $notification, 1);
    my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
      one_response_for_all($notification, 0, am_id());  # check status
    if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) {       # ok
    } elsif ($n_smtp_resp =~ /^4/) {
      die "temporarily unable to notify spam admin: $n_smtp_resp";
    } else {
      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;
  $signature = untaint(\$signature)  # checked (either 32 or 40 char)
    if $signature =~ /^ [0-9a-fA-F]{32} (?: [0-9a-fA-F]{8} )? \z/x;
  # 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 $rpm2cpio $cabextract $dspam))
  {
    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") {   # next tier
      $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);
  if ($extra_code_sql) {
    push(@modules, 'DBI');
    for (@lookup_sql_dsn) {
      my(@dsn) = split(/:/,$_->[0],-1);
      push(@modules, 'DBD::'.$dsn[1])  if uc($dsn[0]) eq 'DBI';
    }
  }
  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;
  push(@modules, qw(Mail::SpamAssassin))  if $extra_code_antispam;
  Amavis::Boot::fetch_modules('REQUIRED ADDITIONAL MODULES', 1, @modules);
  @modules = ();  # now start collecting optional modules
  push(@modules, 'Authen::SASL')  if $extra_code_in_smtp;
  if ($extra_code_antispam) {  # must be loaded before chroot takes place
    push(@modules, qw(
      Mail::SpamAssassin::UnixLocker Mail::SpamAssassin::PerMsgLearner
      Mail::SpamAssassin::BayesStoreDBM Mail::SpamAssassin::BayesStore::DBM
      Mail::SpamAssassin::DBBasedAddrList Mail::SpamAssassin::Plugin::URIDNSBL
      Mail::SPF::Query Net::CIDR::Lite
      Net::DNS::RR::SOA Net::DNS::RR::NS Net::DNS::RR::MX
      Net::DNS::RR::A Net::DNS::RR::AAAA Net::DNS::RR::PTR
      Net::DNS::RR::CNAME Net::DNS::RR::TXT Net::Ping bytes));
  }
  Amavis::Boot::fetch_modules('PRE-COMPILE OPTIONAL MODULES', 0,
                              @modules)  if @modules;
  # 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
# from the end of this file (pseudo file handle DATA)
#
$notify_spam_admin_templ = $notify_spam_recips_templ = '';  # not used
do{ local($/) = "__DATA__\n";   # 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,
    $extra_code_unpackers, $log_templ, $notify_sender_templ );
  if ($unicode_aware) {
#   binmode(\*Amavis::DATA, ":encoding(utf8)")    #  :encoding(iso-8859-1)
#     or die "Can't set \*DATA encoding: $!";
  }
  map { chomp($_ = <Amavis::DATA>) } (
    $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 die "Can't close *Amavis::DATA: $!";
# close(STDIN)        or die "Can't close STDIN: $!";

# discarding leading NL just in case (old 'configure' relicts)
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]+\z/s;  # discard trailing NL

umask(0027);

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

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 = untaint($config_file)
    if $config_file =~ m{^[A-Za-z0-9/._=+-]+\z};
}
# Read config file, which may override default settings
Amavis::Conf::read_config($config_file);

# chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";

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

# compile optional modules if needed
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_maps &&
         !ref($bypass_virus_checks_maps[0]) && $bypass_virus_checks_maps[0]) {
  # 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_maps &&
    !ref($bypass_spam_checks_maps[0]) && $bypass_spam_checks_maps[0]) {
  # 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
}

if ($bypass_decode_parts) {
  $extra_code_unpackers = undef;
} else {
  eval $extra_code_unpackers or die "Problem in the Amavis::Unpackers code: $@";
  $extra_code_unpackers = 1;  # release memory occupied by the source code
}

my($cmd) = lc($ARGV[0]);
if ($cmd =~ /^(start|debug|debug-sa|foreground)?\z/) {
  $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\z/) {
  die "$myversion: 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 = $_ if /^\d+\z/ }
  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";
  $amavisd_pid = untaint($amavisd_pid);
  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'; $ENV{COLUMNS} = '80'; $ENV{LINES} = '100';

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

# report versions of Perl and modules
do_log(0, "Perl version               $]");
for my $m ('Amavis::Conf',
           sort map { s/\.pm\z//; s[/][::]g; $_ } grep { /\.pm\z/ } 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::SMTP Net::Cmd Net::Server Net::LDAP
    DBI BerkeleyDB DB_File SAVI Unix::Syslog Time::HiRes);
  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");
do_log(1,"Unpackers  code       ".($extra_code_unpackers?'':" NOT")." loaded");

# release storage
if (!$extra_code_antivirus) { @av_scanners = @av_scanners_backup = () }
undef @modules_basic;   # @modules_extra

# 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_source,@local_domains_maps) ? 1 : undef}, # sender 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,$f)=delivery_short_report($MSGINFO); $y}, # succ.delivered
  O => sub {my($y,$n,$f)=delivery_short_report($MSGINFO); $n}, # failed recips
  N => sub {my($y,$n,$f)=delivery_short_report($MSGINFO); $f}, # short dsn
  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',0); chomp; $_ }},
  r => sub { local($_) = $MSGINFO->mime_entity;   # first Resent-Message-ID
             if (defined) { $_ = $_->head->get('Resent-Message-ID',0); chomp; $_ }},
  j => sub { local($_) = $MSGINFO->mime_entity;   # Subject of the message
             if (defined) { $_ = $_->head->get('Subject',0); 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<=1 ? \@banned_filename
              : [$banned_filename[0], '...'] },   # 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},  # SA hits/score
  z => sub {$MSGINFO->orig_body_size+1+$MSGINFO->orig_header_size}, # mail size
  a => sub {$MSGINFO->client_addr}, # original SMTP session client IP address
  g => sub {$MSGINFO->client_name}, # original SMTP session client DNS name
  k => sub { scalar(grep  # any recipient declared the message be killed ?
               { !$_->recip_whitelisted_sender &&
                 ($_->recip_blacklisted_sender ||
                  defined $spam_level &&
                  $spam_level >= lookup($_->recip_addr,@spam_kill_level_maps))
               } @{$MSGINFO->per_recip_data}) },
  '1'=> sub { scalar(grep  # above tag level for any recipient?
               { !$_->recip_whitelisted_sender &&
                 ($_->recip_blacklisted_sender ||
                  defined $spam_level &&
                  $spam_level >= lookup($_->recip_addr,@spam_tag_level_maps))
               } @{$MSGINFO->per_recip_data}) },
  '2'=> sub { scalar(grep  # above tag2 level for any recipient?
               { !$_->recip_whitelisted_sender &&
                 ($_->recip_blacklisted_sender ||
                  defined $spam_level &&
                  $spam_level >= lookup($_->recip_addr,@spam_tag2_level_maps))
               } @{$MSGINFO->per_recip_data}) },
  # macros f, T, C, B will be defined by each warn_* as appropriate
  # (representing From:, To:, Cc:, and Bcc: respectively)
  # remaining free letters: epuwxyEGIJKLMPQUYZ
);

# 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) },
  'banned-quarantine'   => sub { ($QUARANTINEDIR,  $VIRUSFILE) },
  'bad-header-quarantine'=>sub { ($QUARANTINEDIR,  $VIRUSFILE) },
# 'spam-quarantine'     => sub { ($QUARANTINEDIR,  $VIRUSFILE) },     # normal
  'spam-quarantine'     => sub { ($QUARANTINEDIR, "$VIRUSFILE.gz") }, # gzipped

  # some more examples:
  'sender-quarantine' =>
    sub { no re 'taint';
          my($s) = $MSGINFO->sender;
          $s =~ s/[^a-zA-Z0-9._@]/=/g; $s =~ s/\@/%/g;
          local $1; $s = $1  if $s =~ /^([a-zA-Z0-9._=%]+)\z/;  # untaint
          $s =~ s/%/%%/g;  # protect %
          ( $QUARANTINEDIR, "sender-$s-%i-%n.gz" );   # suggested file name
        },
  'recip-quarantine' =>
    sub { ("$QUARANTINEDIR/recip-archive.mbox", undef) },
  'ham-quarantine' =>
    sub { ("$QUARANTINEDIR/ham.mbox", undef) },
  'outgoing-quarantine' =>
    sub { ("$QUARANTINEDIR/outgoing.mbox", undef) },
  'incoming-quarantine' =>
    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"), # helper
#             "3330/tcp",                 # Postfix tcp_lookup
#             "9998/tcp",                 # Postfix or AM.PDP policy server 
              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 (especially notification templates) from DATA sections
# to avoid any interpretations of special characters (e.g. \ or ') by Perl
#

__DATA__
#
package Amavis::Lookup::SQLfield;
use strict;
use re 'taint';

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,$matchingkey);
  if (!defined($self)) {
    do_log(5, "lookup_sql_field - undefined, \"$addr\" no match");
  } elsif (!defined($self->{sql_query})) {
    do_log(5, sprintf("lookup_sql_field(%s) - null query, \"%s\" no match",
                      $self->{fieldname}, $addr));
  } else {
    my($h_ref); my($field) = $self->{fieldname};
    ($h_ref, $matchingkey) = $self->{sql_query}->lookup_sql($addr,
                                  !exists($self->{args}) ? () : $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
      # fieldtype: B0: boolean, nonexistent field treated as false,
      #            B1: boolean, nonexistent field treated as true
      if (     $self->{fieldtype} =~ /^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} =~ /^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}=~/^.-/s) {   # 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) ".
                 "(WARN: no such field in the SQL table), ".
                 "\"$addr\" matches, result=undef");
      }
    } else {
      # fieldtype: B=boolean, N=numeric, S=string
      $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 =~ /^([NnFf ]|0+|\000+)[ ]*\z/;
      } elsif ($self->{fieldtype} =~ /^N/) {   # numeric
        $match = $match + 0;  # unify different numeric forms
      } elsif ($self->{fieldtype} =~ /^S/) {   # string
        $match =~ s/ +\z//;   # trim trailing spaces
      }
      do_log(5, "lookup_sql_field($field) \"$addr\"" .
             (!$found ? ", no match" : " matches, result=$match") );
    }
  }
  !wantarray ? $match : ($match, $matchingkey);
}

1;

#
package Amavis::Lookup::SQL;
use strict;
use re 'taint';

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

use DBI;

BEGIN {
  import Amavis::Util qw(untaint do_log);
  import Amavis::Conf qw(:platform :confvars);
  import Amavis::Timing qw(section_time snmp_count);
  import Amavis::rfc2821_2822_Tools qw(make_query_keys);
}

use vars qw($sql_connected);

# 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);
  do_log(3,"Connecting to SQL database server");
  for my $tmpdsn (@dsns) {
    my($dsn, $username, $password) = @$tmpdsn;
    do_log(4, "connect_to_sql: trying '$dsn'");
    $dbh = DBI->connect($dsn, $username, $password,
                        {PrintError => 0, RaiseError => 0, Taint => 1} );
    if ($dbh) { do_log(3,"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;
  $sql_connected = 1  if $dbh;
  $dbh;
}

# return a new Lookup::SQL object to contain DBI handle and prepared selects
sub new {
  my($class) = @_;  bless {}, $class;
}

# store DBI handle and prepared selects into existing Lookup::SQL obj
sub store_dbh($$$) {
  my($self, $dbh, $select_clause) = @_;
  $self->{dbh} = $dbh;  # save DBI handle
  $self->{select_clause} = $select_clause;
  $self->clear_cache;   # let's start afresh just in case
  $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 only specific entries
# exist in a database (e.g. only full addresses, not domains).
#
# 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 @sub.example.com
#  - lookup for @.sub.example.com
#  - lookup for @.example.com
#  - lookup for @.com
#  - lookup for @.       (catchall)
# NOTE:
#  this is different from hash and ACL lookups in two important aspects:
#    - naked key without '@' implies mailbox (=user) name, not domain name;
#    - the naked mailbox name lookups are only performed when the e-mail addr
#      (usually its domain part) matches the static local_domains* lookups.
#
# The domain part is always lowercased when constructing a key,
# the localpart is lowercased unless $localpart_is_case_sensitive is true.
#
sub lookup_sql($$;$) {
  my($self,$addr,$extra_args) = @_;
  my($match,$matchingkey);
  if (!defined $extra_args &&
      exists $self->{cache} && exists $self->{cache}->{$addr})
  { # cached ?
    $match = $self->{cache}->{$addr};
    $matchingkey = '/cached/';  # it will do for now, improve some day ...
    if (!defined($match)) {
      do_log(5,"lookup_sql (cached): \"$addr\" no match");
    } else {
      do_log(5, sprintf("lookup_sql (cached): \"%s\" matches, result=(%s)",
        $addr, join(", ", map { sprintf("%s=>%s", $_,
                                !defined($match->{$_})?'-':'"'.$match->{$_}.'"'
                                       ) } sort keys(%$match) ) ));
    }
    return  !wantarray ? $match : ($match, $matchingkey);
  }
  if (!$sql_connected) {
    my($sql_dbh) = connect_to_sql(@lookup_sql_dsn);
    section_time('sql-connect');
    defined($sql_dbh) or die "SQL server(s) not reachable";
    $sql_dbh->{'RaiseError'} = 1;
    $Amavis::sql_policy->store_dbh($sql_dbh, $sql_select_policy)
      if defined $sql_select_policy;
    $Amavis::sql_wblist->store_dbh($sql_dbh, $sql_select_white_black_list)
      if defined $sql_select_white_black_list;
  }
  my($is_local);  # $local_domains_sql is not looked up to avoid recursion!
  $is_local = Amavis::Lookup::lookup($addr,
                 grep {ref ne 'Amavis::Lookup::SQL' &&
                       ref ne 'Amavis::Lookup::SQLfield'} @local_domains_maps);
  my($keys_ref,$rhs_ref) = make_query_keys($addr,0,$is_local);
  my(@keys) = @$keys_ref;
  my($n) = sprintf("%d",scalar(@keys));  # number of keys
  if (!exists $self->{"sth$n"}) {
    # 'prepare' appropriate query only when needed and save it for reuse
    my($sel) = $self->{select_clause};  $sel =~ s/%k/join(',',('?')x$n)/ge;
    do_log(4,"SQL prepare($n): $sel");
    $self->{"sth$n"} = $self->{dbh}->prepare($sel);
  }
  my($sth) = $self->{"sth$n"};
  unshift(@keys,@$extra_args)  if ref $extra_args;  # prepend extra arguments
  for (@keys) { $_ = untaint($_) }  # untaint keys
  do_log(5,"lookup_sql \"$addr\", query keys: ".join(', ',map{"\"$_\""}@keys));
  my($a_ref,$found); $match = {};
  eval {
    $sth->execute(@keys);  # do the query
    while ( defined($a_ref=$sth->fetchrow_arrayref) ) {  # fetch query results
      my(@names) = @{$sth->{NAME_lc}};
      $found = 1; $match = {}; @$match{@names} = @$a_ref;
      if (!exists $match->{'local'} && $match->{'email'} eq '@.') {
        # UGLY HACK to let a catchall (@.) imply that field 'local' has
        # a value undef (NULL) when that field is not present in the
        # database. This overrides B1 fieldtype default by an explicit
        # undef for '@.', causing a fallback to static lookup tables.
        # The purpose is to provide a useful default for local_domains
        # lookup if the field 'local' is not present in the SQL table.
        # NOTE: field names 'local' and 'email' are hardwired here!!!
        push(@names,'local'); $match->{'local'} = undef;
        do_log(5, "lookup_sql: \"$addr\" matches catchall, local=>undef");
      }
      $matchingkey = join(", ", map { sprintf("%s=>%s", $_,
                                !defined($match->{$_})?'-':'"'.$match->{$_}.'"'
                                ) } @names);
      do_log(5, "lookup_sql($addr) matches, result=($matchingkey)");
      last  if $found;  # first match wins, loop is for possible future use
    }
    $sth->finish();
  };  # eval
  if ($@ ne '') {
    my($err) = $@;
    do_log(0, "lookup_sql: $DBI::err, $DBI::errstr");
    if ($sth && ($sth->err eq '2006' ||        # MySQL server has gone away
                 $sth->errstr =~ /\bserver has gone away\b/)) {
      do_log(0,"NOTICE: Disconnected from SQL server");
      $sql_connected = 0;  $self->{dbh}->disconnect;
    }
    die $err;
  }
  if (!$found) {
    $match = $matchingkey = 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');
  !wantarray ? $match : ($match, $matchingkey);
}

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;
use re 'taint';

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

  import Amavis::Util qw(do_log);
  import Amavis::Conf qw(:platform :confvars);
  import Amavis::Timing qw(section_time snmp_count);
  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+\z//; $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
  for (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;
  for (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});
  $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");
  }
  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($localpart,$domain) = split_address($addr);
  my $res;
  $domain = lc($domain);
  $localpart = lc($localpart)  if !$localpart_is_case_sensitive;
  # chop off leading @, and trailing dots
  if ($domain =~ /^\@?(.*?)\.*\z/s) { $domain = $1 }
  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 }
  # $local_domains_ldap is not looked up to avoid recursion!
  if (Amavis::Lookup::lookup($addr,
                   grep {ref ne 'Amavis::Lookup::LDAP'} @local_domains_maps)) {
    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)
  $res;
}

1;

__DATA__
#
package Amavis::In::AMCL;
use strict;
use re 'taint';

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

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

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

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

# (used with sendmail milter and traditional (non-SMTP) MTA interface)
#
sub process_policy_request($$$$) {
  my($self, $sock, $conn, $check_mail, $old_amcl) = @_;
  # $sock:       connected socket from Net::Server
  # $conn:       information about client connection
  # $check_mail: subroutine ref to be called with file handle

  my(%attr);
  $0 = sprintf("amavisd (ch%d-P-idle)", $Amavis::child_invocation_count);
  if ($old_amcl) {
    # Accept a single request from traditional amavis helper program.
    # Receive TEMPDIR/SENDER/RCPTS/LDA/LDAARGS from client
    # Simple "protocol": \2 means LDA; \3 means EOT (end of transmission)
    my($state) = 0; $attr{'request'} = 'AM.CL'; my($response) = "\001";
    my($rv,$inbuf,@recips,@ldaargs,$inbuff);
    my(@attr_names) = qw(tempdir sender recipient ldaargs);
    while (defined($rv = recv($sock, $inbuff, 8192, 0))) {
      $0 = sprintf("amavisd (ch%d-P)", $Amavis::child_invocation_count);
      if ($state < 2) {
        $attr{$attr_names[$state]} = $inbuff; $state++;
      } elsif ($state == 2 && $inbuff eq "\002") {
        $state++;
      } elsif ($state >= 2 && $inbuff eq "\003") {
        section_time('got data');
        $attr{'recipient'} = \@recips; $attr{'ldaargs'} = \@ldaargs;
        eval {
          my($msginfo) = preprocess_policy_query(\%attr);
          $response = (map { /^exit_code=(\d+)\z/ ? $1 : () }
                           check_amcl_policy($conn,$msginfo,$check_mail,1))[0];
        };
        if ($@ ne '') {
          chomp($@); do_log(0,"policy_server FAILED: $@");
          $response = EX_TEMPFAIL;
        }
        $state = 4;
      } elsif ($state == 2) {
        push(@recips, $inbuff);
      } else {
        push(@ldaargs, $inbuff);
      }
      defined(send($sock,$response,0))
        or die "send failed in state $state: $!";
      last  if $state >= 4;
      $0 = sprintf("amavisd (ch%d-P-idle)", $Amavis::child_invocation_count);
    }
    if ($state==4 && defined($rv)) {
      # normal termination
    } elsif (!defined($rv) && $! != 0) {
      die "recv failed in state $state: $!";
    } else {  # eof or runaway state
      die "helper client session terminated unexpectedly, state: $state";
    }
    do_log(2, Amavis::Timing::report());  # report elapsed times

  } else {  # Postfix policy server or new amavis helper protocol AM.PDP
    # for Postfix policy server see Postfix docs SMTPD_POLICY_README
    my(@response);
    local($/) = "\012";  # set line terminator to LF (Postfix idiosyncrasy)
    while(<$sock>) {     # can accept multiple tasks
      $0 = sprintf("amavisd (ch%d-P)", $Amavis::child_invocation_count);
      Amavis::Timing::init();
      # must not use \r and \n, may not be \015 and \012 on certain platforms
      if (/^\015?\012\z/) {  # end of request
        section_time('got data');
        eval {
          my($msginfo) = preprocess_policy_query(\%attr);
          @response = $attr{'request'} eq 'smtpd_access_policy'
                        ? postfix_policy($conn,$msginfo,\%attr)
                        : check_amcl_policy($conn,$msginfo,$check_mail,0);
        };
        if ($@ ne '') {
          chomp($@); do_log(0, "policy_server FAILED: $@");
          @response = (proto_encode('setreply','450','4.5.0',"Failure: $@"),
                       proto_encode('return_value','tempfail'),
                       proto_encode('exit_code',sprintf("%d",EX_TEMPFAIL)));
        # last;
        }
        $sock->print( map { $_."\012" } (@response,'') )
          or die "Can't write response to socket: $!";
        %attr = (); @response = ();
        do_log(2, Amavis::Timing::report());
      } elsif (/^ ([^=\000\012]*?) (=|:[ \t]*)
                  ([^\012]*?) \015?\012 \z/xsi) {
        my($attr_name) = Amavis::tcp_lookup_decode($1);
        my($attr_val)  = Amavis::tcp_lookup_decode($3);
        if (!exists $attr{$attr_name}) {
          $attr{$attr_name} = $attr_val;
        } else {
          if (!ref($attr{$attr_name}))
            { $attr{$attr_name} = [ $attr{$attr_name} ] }
          push(@{$attr{$attr_name}}, $attr_val);
        }
        my($known_attr) = scalar(grep {$_ eq $attr_name} qw(
          request helo_name protocol_state protocol_name queue_id
          client_name client_address sender recipient) );
        do_log(!$known_attr?0:1, "postfix_policy: $attr_name=$attr_val");
      } else {
        do_log(0, "postfix_policy: INVALID ATTRIBUTE LINE: $_");
      }
      $0 = sprintf("amavisd (ch%d-P-idle)", $Amavis::child_invocation_count);
    }
    if (!defined($_) && $! != 0) { die "read from client socket FAILED: $!" }
  };
  $0 = sprintf("amavisd (ch%d-P)", $Amavis::child_invocation_count);
}

# Return a new Amavis::In::Message object
# based on given policy query attributes
#
sub preprocess_policy_query($) {
  my($attr_ref) = @_;

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

  # amavisd -> amavis-helper protocol query consists of any number of
  # the following lines, the response is terminated by an empty line.
  # The 'request=AM.PDP' is a required first field, the order of
  # remaining fields is arbitrary.
  # Required fields are: request, tempdir, sender, recipient (one or more)
  #   request=AM.PDP
  #   tempdir=/var/amavis/amavis-milter-MWZmu9Di
  #   tempdir_removed_by=client    (tempdir_removed_by=server is a default)
  #   sender=<foo@example.com>
  #   recipient=<bar1@example.net>
  #   recipient=<bar2@example.net>
  #   recipient=<bar3@example.net>
  #   delivery_care_of=server      (client or server, client is a default)
  #   protocol_name=ESMTP
  #   helo_name=b.example.com
  #   client_address=10.2.3.4

  my($sender,@recips,$tempdir);
  $msginfo->delivery_method(
    lc($attr_ref->{'delivery_care_of'}) eq 'server' ? $forward_method : '');
  $msginfo->client_delete(lc($attr_ref->{'tempdir_removed_by'}) eq 'client'
                          ? 1 : 0);
  $msginfo->client_addr($attr_ref->{'client_address'})
    if exists $attr_ref->{'client_address'};
  $msginfo->client_name($attr_ref->{'client_name'})
    if exists $attr_ref->{'client_name'};
  $msginfo->client_proto($attr_ref->{'protocol_name'})
    if exists $attr_ref->{'protocol_name'};
  $msginfo->client_helo($attr_ref->{'helo_name'})
    if exists $attr_ref->{'helo_name'};
  if (exists $attr_ref->{'sender'}) {
    $sender = $attr_ref->{'sender'};
    $sender = unquote_rfc2821_local($sender);
    debug_oneshot(1)  if lookup($sender,\@debug_sender_acl);
    $msginfo->sender($sender);
  }
  if (exists $attr_ref->{'recipient'}) {
    my($r) = $attr_ref->{'recipient'};
    @recips = !ref($r) ? $r : @$r;
    map { $_=unquote_rfc2821_local($_) } @recips;
    $msginfo->recips(\@recips);
  }
  if (!exists $attr_ref->{'tempdir'}) {
    $tempdir = $TEMPBASE; $msginfo->mail_tempdir($tempdir);
  } else {
    local($1,$2); $tempdir = $attr_ref->{tempdir};
    $tempdir =~ /^ (?: \Q$TEMPBASE\E | \Q$MYHOME\E )
                   \/ (?! .*? \.{2,}) [A-Za-z0-9_.-]+ \z/xso
      or die "Invalid temporary directory '$tempdir'";
    $tempdir = untaint(\$tempdir);  # untaint the directory name
    # set new amavis message id
    new_am_id( ($tempdir =~ /amavis-(milter-)?(.+?)\z/s ? $2 : undef) );
    # file created by amavis client, just open it
    my($fh) = IO::File->new;
    $fh->open("$tempdir/email.txt",'<')
      or die "Can't open file $tempdir/email.txt: $!";
    binmode($fh,":bytes") or die "Can't cancel :utf8 mode: $!"
      if $unicode_aware;
    $msginfo->mail_tempdir($tempdir);
    $msginfo->mail_text($fh);  # save file handle to object
  }
  if ($attr_ref->{'request'} =~ /^AM\.(CL|PDP)\z/) {
    do_log(1, sprintf("%s %s: <%s> -> %s", $attr_ref->{'request'}, $tempdir,
                      $sender, join(',', map{"<$_>"}@recips) ));
  } else {
    do_log(1, sprintf("%s(%s): %s %s: %s[%s] <%s> -> <%s>",
                    @$attr_ref{qw(request protocol_state protocol_name queue_id
                    client_name client_address sender recipient)}));
  }
  $msginfo;
}

sub check_amcl_policy($$$$) {
  my($conn,$msginfo,$check_mail,$old_amcl) = @_;

  my($smtp_resp, $exit_code, $preserve_evidence);
  # do some sanity checks before deciding to call check_mail()
  if (!ref($msginfo->per_recip_data) || !defined($msginfo->mail_text)) {
    $smtp_resp = '450 4.5.0 Incomplete request'; $exit_code = EX_TEMPFAIL;
  } else {
    # check_mail() expects open file on $fh, need not be rewound
    my($fh) = $msginfo->mail_text;  my($tempdir) = $msginfo->mail_tempdir;
    ($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 ($msginfo->client_delete) {
      do_log(4, "AM.PDP: deletion of $tempdir is client's responsibilility");
    } elsif ($preserve_evidence) {
      do_log(0, "AM.PDP: tempdir is to be PRESERVED: $tempdir");
    } else {
      do_log(4, "AM.PDP: tempdir being removed: $tempdir");
      rmdir_recursively($tempdir);
    }
  }
  # amavisd -> amavis-helper protocol response consists of any number of
  # the following lines, the response is terminated by an empty line
  #   addrcpt=recipient
  #   delrcpt=recipient
  #   addheader=hdr_head hdr_body
  #   chgheader=index hdr_head hdr_body
  #   replacebody=new_body  (not implemented)
  #   return_value=continue|reject|discard|accept|tempfail
  #   setreply=rcode xcode message
  #   exit_code=n           (old amavis helper, not applicable to milter)

  my(@response); my($rcpt_deletes,$rcpt_count)=(0,0);
  if (ref($msginfo->per_recip_data)) {
    for my $r (@{$msginfo->per_recip_data})
      { $rcpt_count++;  if ($r->recip_done) { $rcpt_deletes++ } }
  }
  if ($smtp_resp=~/^([1-5]\d\d) ([245]\.\d{1,3}\.\d{1,3})(?: |\z)(.*)\z/s)
    { push(@response, proto_encode('setreply', $1,$2,$3)) }
  if ($exit_code == EX_TEMPFAIL) {
    push(@response, proto_encode('return_value','tempfail'));
  } elsif ($exit_code == EX_NOUSER) {        # reject the whole message
    push(@response, proto_encode('return_value','reject'));
  } elsif ($exit_code == EX_UNAVAILABLE) {   # reject the whole message
    push(@response, proto_encode('return_value','reject'));
  } elsif ($exit_code == 99) {               # discard the whole message
    push(@response, proto_encode('return_value','discard'));
  } elsif ($rcpt_count-$rcpt_deletes < 1) {  # none left, should be discarded
    # why was discarding not requested?
    do_log(0, "WARN: no recips left, $smtp_resp");
    $exit_code = 99;
    push(@response, proto_encode('return_value','discard'));
  } elsif ($msginfo->delivery_method ne '') {
    # tell MTA to discard the message, amavisd will do the forwarding
    $exit_code = 99;   # *** 99 or EX_OK; ???
    push(@response, proto_encode('return_value','discard'));
  } else {  # EX_OK
    for my $r (@{$msginfo->per_recip_data}) {  # modified recipient addresses?
      my($addr,$newaddr) = ($r->recip_addr, $r->recip_final_addr);
      if ($r->recip_done) {          # delete
        push(@response, proto_encode('delrcpt',
                                     quote_rfc2821_local($addr)));
      } elsif ($newaddr ne $addr) {  # modify, e.g. adding extension
        push(@response, proto_encode('delrcpt',
                                     quote_rfc2821_local($addr)));
        push(@response, proto_encode('addrcpt',
                                     quote_rfc2821_local($newaddr)));
      }
    }
    my($hdr_edits) = $msginfo->header_edits;
    if ($hdr_edits) {  # any added or modified header fields?
      # Inserting. Not posible to specify placement of header fields in milter!
      for my $hf (@{$hdr_edits->{prepend}}, @{$hdr_edits->{append}}) {
        if ($hf =~ /^([^:]+):[ \t]*(.*?)$/s)
          { push(@response, proto_encode('addheader',$1,$2)) }
      }
      my($field_name,$edit,$field_body);
      while ( ($field_name,$edit) = each %{$hdr_edits->{edit}} ) {
        $field_body = $msginfo->mime_entity->head->get($field_name,0);
        if (!defined($field_body)) {
          # such header field does not exist, do nothing
        } elsif (!defined($edit)) {  # delete existing header field
          push(@response, proto_encode('delheader',"1",$field_name));
        } else {                     # edit the first occurrence
          chomp($field_body);
          $field_body = hdr($field_name, &$edit($field_name,$field_body));
          $field_body = $1  if $field_body =~ /^[^:]+:[ \t]*(.*?)$/s;
          push(@response, proto_encode('chgheader', "1",
                                       $field_name, $field_body));
        }
      }
    }
    if ($old_amcl) {   # milter via old amavis helper program
      # warn if there is anything that should be done but MTA is not capable of
      # (or a helper program can not pass the request)
      for (grep { /(delrcpt|addrcpt)=/ } @response)
        { do_log(0, "WARN: MTA can't do: $_") }
      if ($rcpt_deletes) {
        do_log(0, "WARN: ACCEPT THE WHOLE MESSAGE, ".
                  "MTA-in can't do selective recips deletion");
      }
    }
    push(@response, proto_encode('return_value','continue'));
  }
# if ($mta_in_type eq 'qmail' && $exit_code == EX_TEMPFAIL) {
#   $exit_code = 81;  # qmail is different?!
# }
  push(@response, proto_encode('exit_code',"$exit_code"));
  do_log(2, "mail checking ended: ".join("\n",@response));
  @response;
}

sub postfix_policy($$$) {
  my($conn,$msginfo,$attr_ref) = @_;
  my(@response);
  if (!exists($attr_ref->{'request'})) {
    die "no 'request' attribute";
  } elsif ($attr_ref->{'request'} ne 'smtpd_access_policy') {
    die ("unknown 'request' value: " . $attr_ref->{'request'});
  } else {
    @response = 'action=DUNNO';
  }
  @response;
}

sub proto_encode($@) {
  my($attribute_name,@strings) = @_;
  $attribute_name =~    # encode all but alfanumerics, '_' and '-'
    s/[^0-9a-zA-Z_-]/sprintf("%%%02x",ord($&))/eg;
  for (@strings) {      # encode % and nonprintables
    s/[^\041-\044\046-\176]/sprintf("%%%02x",ord($&))/eg;
  }
  ## encode % and nonprintables, but leave SP and TAB as-is
  # $str =~ s/[^\011\040-\044\046-\176]/sprintf("%%%02x",ord($&))/eg;
  $attribute_name . '=' . join(' ',@strings);
}

1;

__DATA__
#
package Amavis::In::SMTP;
use strict;
use re 'taint';

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

BEGIN {
  import Amavis::Conf qw(:platform :confvars);
  import Amavis::Util qw(do_log am_id new_am_id prolong_timer debug_oneshot
                         sanitize_str strip_tempdir rmdir_recursively);
  import Amavis::Lookup qw(lookup);
  import Amavis::Timing qw(section_time snmp_count);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::In::Message;
  import Amavis::In::Connection;
}

sub new($) {
  my($class) = @_;
  my($self) = bless {}, $class;
  $self->{sock} = undef;              # SMTP socket
  $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 _) {
    do_log(4,"prepare_tempdir: creating directory ".$self->{tempdir_pers});
    mkdir($self->{tempdir_pers}, 0750)
      or die "Can't create directory $self->{tempdir_pers}: $!";
    $self->{tempdir_empty} = 1;
    section_time('mkdir tempdir');
  }
  # prepare temporary file for writing (and reading later)
  my($fname) = $self->{tempdir_pers} . "/email.txt";
  $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 {
    do_log(4,"prepare_tempdir: creating file $fname");
    $self->{fh_pers} = IO::File->new($fname,'+>',0640)
      or die "Can't create file $fname: $!";
    section_time('create email.txt');
  }
}

sub authenticate($$$) {
  my($state,$auth_mech,$auth_resp) = @_;
  my($result,$newchallenge);
  if ($auth_mech eq 'ANONYMOUS') {   # rfc2245
    $result = [$auth_resp,undef];
  } elsif ($auth_mech eq 'PLAIN') {  # rfc2595, "user\0authname\0pass"
    if (!defined($auth_resp)) { $newchallenge = '' }
    else { $result = [ (split(/\000/,$auth_resp,-1))[0,2] ] }
  } elsif ($auth_mech eq 'LOGIN' && !defined $state) {
    $newchallenge = 'Username:'; $state = [];
  } elsif ($auth_mech eq 'LOGIN' && @$state==0) {
    push(@$state, $auth_resp); $newchallenge = 'Password:';
  } elsif ($auth_mech eq 'LOGIN' && @$state==1) {
    push(@$state, $auth_resp); $result = $state;
  } # CRAM-MD5:rfc2195,  DIGEST-MD5:rfc2831
    ($state,$result,$newchallenge);
}

# 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 protocol instead of (E)SMTP
  # $conn:       information about client connection
  # $check_mail: subroutine ref to be called with file handle

  my($msginfo,$authenticated,$auth_user,$auth_pass);
  $self->{sock} = $sock;
  $self->{pipelining} = 0;    # may we buffer responses?
  $self->{smtp_outbuf} = [];  # SMTP responses buffer for PIPELINING
  my($auth_required) = 0;
  my(@auth_mech_avail) = ('PLAIN','LOGIN');   # empty list disables AUTH

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

  new_am_id(undef, $Amavis::child_invocation_count, undef);
  my($initial_am_id) = 1; my($sender,@recips); my($got_rcpt);
  my($terminating,$aborting,$eof,$voluntary_exit); my($seq) = 0;
  my(%xforward_args);
  $conn->smtp_proto($self->{proto} = $lmtp ? 'LMTP' : 'SMTP');

  my($smtpd_greeting_banner_tmp) = $smtpd_greeting_banner;
  $smtpd_greeting_banner_tmp =~
    s{ \$ (?: \{ ([^\}]*) \} | ([a-zA-Z0-9_-]+) ) }
     { { 'helo-name' => $myheloname,
         'version'   => $myversion,
         'protocol'  => $lmtp?'LMTP':'ESMTP' }->{lc($1.$2)}
     }egx;
  $self->smtp_resp(1, "220 $smtpd_greeting_banner_tmp");

  $0 = sprintf("amavisd (ch%d-idle)", $Amavis::child_invocation_count);
  Amavis::Timing::go_idle(4);
  undef $!;
  while(<$sock>) {
    $0 = sprintf("amavisd (ch%d-%s)",
                 $Amavis::child_invocation_count, am_id());
    Amavis::Timing::go_busy(5);
    prolong_timer('reading SMTP command');
    { # a block is used as a 'switch' statement - 'last' will exit from it
      my($cmd) = $_;
      do_log(4, $self->{proto} . "< $cmd");
      !/^ \s* ([A-Za-z]+) (?: \s+ (.*?) )? \s* \015\012 \z/xs && do {
        $self->smtp_resp(1,"500 5.5.2 Error: bad syntax", 1, $cmd); last;
      };
      $_ = uc($1); my($args) = $2;
      /^RSET|DATA|QUIT\z/ && $args ne '' && do {
        $self->smtp_resp(1,"501 5.5.4 Error: $_ does not accept arguments",
                         1,$cmd);
        last;
      };
      /^RSET\z/ && do { $sender = undef; @recips = (); $got_rcpt = 0;
                        $msginfo = undef;  # forget previous
                        $self->smtp_resp(0,"250 2.0.0 Ok $_"); last };
      /^NOOP\z/ && do { $self->smtp_resp(1,"250 2.0.0 Ok $_"); last };
      /^QUIT\z/ && do {
        my($smtpd_quit_banner_tmp) = $smtpd_quit_banner;
        $smtpd_quit_banner_tmp =~
          s{ \$ (?: \{ ([^\}]*) \} | ([a-zA-Z0-9_-]+) ) }
           { { 'helo-name' => $myheloname,
               'version'   => $myversion,
               'protocol'  => $lmtp?'LMTP':'ESMTP' }->{lc($1.$2)}
           }egx;
        $self->smtp_resp(1,"221 2.0.0 $smtpd_quit_banner_tmp");
        $terminating=1; last;
      };
###   !$lmtp && /^HELO\z/ && do {  # strict
      /^HELO\z/ && 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\z/ || $lmtp && /^LHLO\z/) && do {  # strict
      (/^EHLO\z/ || /^LHLO\z/) && do {
        $sender = undef; @recips = (); $got_rcpt = 0;  # implies RSET
        $msginfo = undef;  # forget previous
        $lmtp = /^LHLO\z/ ? 1 : 0;
        $conn->smtp_proto($self->{proto} = $lmtp ? 'LMTP' : 'ESMTP');
        $self->{pipelining} = 1;
        $self->smtp_resp(0,"250 $myheloname\n" . join("\n",
          'PIPELINING', 'SIZE', '8BITMIME', 'ENHANCEDSTATUSCODES',
          !@auth_mech_avail ? () : join(' ','AUTH',@auth_mech_avail),
          'XFORWARD NAME ADDR PROTO HELO' ));
        $conn->smtp_helo($args); section_time("SMTP $_");
        last;
      };
      /^XFORWARD\z/ && do {  # Postfix extension
        if (defined($sender)) {
          $self->smtp_resp(0,"503 5.5.1 Error: XFORWARD not allowed within transaction", 1, $cmd);
          last;
        }
        my($bad);
        for (split(' ',$args)) {
          if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]*  ) =
                  ( [\041-\074\076-\176]+ ) \z/xs) { # printable, not '=' or SP
            $self->smtp_resp(0,"501 5.5.4 Syntax error in XFORWARD parameters",
                             1, $cmd);
            $bad = 1; last;
          } else {
            my($name,$val) = (uc($1), $2);
            if ($name =~ /^(?:NAME|ADDR|PROTO|HELO)\z/) {
              # value encoded as xtext: rfc3461
              $val =~ s/\+([0-9a-fA-F]{2})/pack("C",hex($1))/eg;
              $xforward_args{$name} = $val;
            } else {
              $self->smtp_resp(0,"501 5.5.4 XFORWARD command parameter error: $name=$val",1,$cmd);
              $bad = 1; last;
            }
          }
        }
        $self->smtp_resp(1,"250 2.5.0 Ok")  if !$bad;
        last;
      };
      /^HELP\z/ && do {
        $self->smtp_resp(1,"214 2.0.0 See amavisd-new home page at:\n".
                           "http://www.ijs.si/software/amavisd/");
        last;
      };
      /^AUTH\z/ && @auth_mech_avail && do {  # rfc2554
        if ($args !~ /^([^ ]+)(?: ([^ ]*))?\z/is) {
          $self->smtp_resp(0,"501 5.5.2 Syntax: AUTH mech [initresp]",1,$cmd);
          last;
        }
        my($auth_mech,$auth_resp) = (uc($1), $2);
        if ($authenticated) {
          $self->smtp_resp(0,"503 5.5.1 Error: session already authenticated", 1, $cmd);
        } elsif (defined($sender)) {
          $self->smtp_resp(0,"503 5.5.1 Error: AUTH not allowed within transaction", 1, $cmd);
        } elsif (!grep {uc($_) eq $auth_mech} @auth_mech_avail) {
          $self->smtp_resp(0,"504 5.7.6 Error: requested authentication mechanism not supported", 1, $cmd);
        } else {
          my($state,$result,$challenge);
          if   ($auth_resp eq '=') { $auth_resp = '' }  # zero length
          elsif ($auth_resp eq '') { $auth_resp = undef }
          for (;;) {
            if ($auth_resp !~ m{^[A-Za-z0-9+/=]*\z}) {
              $self->smtp_resp(0,"501 5.5.4 Authentication failed: malformed authentication response", 1, $cmd);
              last;
            } else {
              $auth_resp = decode_base64($auth_resp)  if $auth_resp ne '';
              ($state,$result,$challenge) =
                authenticate($state, $auth_mech, $auth_resp);
              if (ref($result) eq 'ARRAY') {
                $self->smtp_resp(0,"235 2.7.1 Authentication successful");
                $authenticated = 1; ($auth_user,$auth_pass) = @$result;
                do_log(2,"AUTH $auth_mech, user=$auth_user, pass=$auth_resp");
                last;
              } elsif (defined $result && !$result) {
                $self->smtp_resp(0,"535 5.7.1 Authentication failed", 1, $cmd);
                last;
              }
            }
            # server challenge or ready prompt
            $self->smtp_resp(1,"334 ".encode_base64($challenge,''));
            $auth_resp = <$sock>;
            do_log(5, $self->{proto} . "< $auth_resp");
            $auth_resp =~ s/\015?\012\z//;
            if ($auth_resp eq '*') {
              $self->smtp_resp(0,"501 5.7.1 Authentication aborted");
              last;
            }
          }
        }
        last;
      };
      /^VRFY\z/ && 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", 0, $cmd);
      # }
        last;
      };
      /^MAIL\z/ && do {  # begin new transaction
        if (defined($sender)) {
          $self->smtp_resp(0,"503 5.5.1 Error: nested MAIL command", 1, $cmd);
          last;
        }
        if (!$authenticated && @auth_mech_avail && $auth_required) {
          $self->smtp_resp(0,"530 5.7.1 Authentication required", 1, $cmd);
          last;
        }
        # begin SMTP transaction
        prolong_timer('MAIL FROM received - timer reset', $child_timeout);
        if (!$seq) {# the first connect
          section_time('SMTP pre-MAIL');
        } else {    # establish new time reference for each transaction
          Amavis::Timing::init();
        }
        $seq++;
        new_am_id(undef,$Amavis::child_invocation_count,$seq) if !$initial_am_id;
        $initial_am_id = 0; $self->prepare_tempdir;
        $msginfo = Amavis::In::Message->new;
        $msginfo->rx_time(time);
        $msginfo->delivery_method($forward_method);
        if ($authenticated) {
          $msginfo->auth_user($auth_user); $msginfo->auth_pass($auth_pass);
        }
        $msginfo->client_addr($xforward_args{'ADDR'});
        $msginfo->client_name($xforward_args{'NAME'});
        $msginfo->client_proto($xforward_args{'PROTO'});
        $msginfo->client_helo($xforward_args{'HELO'});
        %xforward_args = ();  # reset values for the next transation
        # permit some sloppy syntax without angle brackets
        if ($args !~ /^FROM: \s*
                      ( < (?: " (?: \\. | [^\\"] )* " | [^"@] )*
                          (?: @ (?: \[ (?: \\. | [^\]\\] )* \] |
                                    [^\[\]\\>] )* )?
                        > |
                        [^<\s] (?: " (?: \\. | [^\\"] )* " | [^"\s] )*
                      ) (?: \s+ ([\040-\176]+) )? \z/isx ) {
            $self->smtp_resp(0,"501 5.5.2 Syntax: MAIL FROM: <address>",1,$cmd);
            last;
        }
        my($addr,$opt) = ($1,$2);  my($bad,$submitter);
        for (split(' ',$opt)) {
          if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]*  ) =
                  ( [\041-\074\076-\176]+ ) \z/xs) { # printable, not '=' or 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),$2);
            if ($name eq 'SIZE' && $val=~/^\d{1,20}\z/) {
              $msginfo->msg_size($val+0);
            } elsif ($name eq 'BODY' && $val=~/^7BIT|8BITMIME\z/i){
              $msginfo->body_type(uc($val));
            } elsif ($name eq 'AUTH' && @auth_mech_avail && !defined($submitter)){
              # rfc2554
              $submitter = $val;  # encoded as xtext: rfc3461
              $submitter =~ s/\+([0-9a-fA-F]{2})/pack("C",hex($1))/eg;
            } else {
              my($msg);
              if ($name eq 'AUTH' && !@auth_mech_avail) {
                $msg = "503 5.7.4 Error: authentication disabled";
              } else {
                $msg = "504 5.5.4 MAIL command parameter error: $name=$val";
              }
              $self->smtp_resp(0,$msg,1,$cmd);
              $bad = 1; last;
            }
          }
        }
        if (!$bad) {
          $addr = ($addr =~ /^<(.*)>\z/s) ? $1 : $addr;
          $self->smtp_resp(0,"250 2.1.0 Sender $addr OK");
          $sender = unquote_rfc2821_local($addr);
          debug_oneshot(lookup($sender,\@debug_sender_acl) ? 1 : 0,
                        $self->{proto} . "< $cmd");
        # $submitter = "<$addr>" if !defined($submitter);  # rfc2554: MAY
          $submitter = '<>'      if !$authenticated;
          $msginfo->auth_submitter($submitter);
        };
        last;
      };
      /^RCPT\z/ && 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+ ([\040-\176]+) )? \z/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, $2);
          $addr = ($addr =~ /^<(.*)>\z/s) ? $1 : $addr;
          $self->smtp_resp(0,"250 2.1.5 Recipient $addr OK");
          push(@recips, unquote_rfc2821_local($addr));
        };
        last;
      };
      /^DATA\z/ && !@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\z/ && 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 input 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)\z/$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});
          $msginfo->mail_tempdir($self->{tempdir_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: " . $msginfo->delivery_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);
            }
          }
        };
        alarm(0); do_log(5,"timer stopped after DATA end");
        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);
    };  # end of 'switch' block
    if ($terminating || defined $aborting) {   # exit SMTP-session loop
      $voluntary_exit = 1; last;
    }
    # 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;
    $0 = sprintf("amavisd (ch%d-%s-idle)",
                 $Amavis::child_invocation_count, am_id());
    Amavis::Timing::go_idle(6);
    undef $!;
  } # end of while
  my($errn,$errs);
  if (!$voluntary_exit) {
    $eof = 1;
    if (!defined($_)) { $errn = 0+$!; $errs = "$!" }
  }
  $0 = sprintf("amavisd (ch%d)", $Amavis::child_invocation_count);
  Amavis::Timing::go_busy(7);
  # come here when: QUIT is received, eof or err 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 ($errs)" : '';
  do_log($aborting?0:2, $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');
  }
  $resp = sanitize_str($resp,1);
  local($1,$2,$3,$4);
  if ($resp !~ /^ ([1-5]\d\d) (\ |-|\z)
                ([245] \. \d{1,3} \. \d{1,3} (?: \ |\z) )?
                (.*) \z/xs)
    { die "Internal error(2): bad SMTP response code: '$resp'" }
  my($resp_code,$continuation,$enhanced,$tail) = ($1,$2,$3, $4);
  my($lead_len) = length($resp_code) + 1 + length($enhanced);
  while (length($tail) > 512-2-$lead_len || $tail =~ /\n/) {
    # rfc2821: The maximum total length of a reply line including the
    # reply code and the <CRLF> is 512 characters.  More information
    # may be conveyed through multiple-line replies.
    my($head) = substr($tail,0,512-2-$lead_len);
    if ($head =~ /^([^\n]*\n)/) { $head = $1 }
    $tail = substr($tail,length($head)); chomp($head);
    push(@{$self->{smtp_outbuf}}, $resp_code.'-'.$enhanced.$head);
  }
  push(@{$self->{smtp_outbuf}},$resp_code.$continuation.$enhanced.$tail);
  $self->smtp_resp_flush   if $flush || !$self->{pipelining} ||
                              @{$self->{smtp_outbuf}} > 200;
}

sub smtp_resp_flush($) {
  my($self) = shift;
  if (@{$self->{smtp_outbuf}}) {
    for my $resp (@{$self->{smtp_outbuf}}) {
      do_log(4, $self->{proto} . "> $resp");
    };
    $self->{sock}->print(map($_."\015\012", @{$self->{smtp_outbuf}}))
      or die "Error writing a SMTP response to the socket: $!";
    @{$self->{smtp_outbuf}} = ();
  }
}

1;

__DATA__
#
package Amavis::AV;
use strict;
use re 'taint';

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

use POSIX qw(WIFEXITED WEXITSTATUS);
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(untaint min max do_log am_id
                         exit_status_str run_command);
  import Amavis::Timing qw(section_time snmp_count);
}

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
    ActiveMimeHandling !DelVBA5Project
    ScrapObjectHandling SrpStreamHandling Office2001Handling
    Upx PalmPilotHandling HqxDecompression
    Pdf Rtf Html Elf WordB OutlookExpress
  );
#   Mime
  # 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 some
  # versions of Sophos library (even with more recent ones!)
  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";
  $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) = lstat($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
    if (-l _) {  # symbolic link
      do_log(0, "WARN: $av_name: skipping unexpected symbolic link $fname");
      next;
    }
    $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) = "$f INFECTED: ".join(", ",$result->viruses);
      $output .= $msg.$eol;  do_log(2,"$av_name: $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) = 2 * @$sockets;  my($retries) = 0;
  $SIG{PIPE} = 'IGNORE';  # 'send' to broken pipe would throw 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 %s",
                        $query, $is_inet?"INET":"UNIX", $socketname));
      # 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 good 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)
    do_log(2,"$av_name: INFECTED: ".join(", ",@virusname));
  } 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) = lstat($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
      if (-l _) {     # symbolic link
        do_log(0, "WARN: $av_name: skipping unexpected symbolic link $fname");
        next;
      }
      $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 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 provided 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,$error_str); 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($any_files_to_check) = 1;
    my(@args) = split(' ',$args);
    if (grep { m{^({}/)?\*\z} } @args) {  #  {}/* or *, list each file
      local($1); 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) = lstat($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 directory
        next  if -z _;  # empty file
        if (-l _) {     # symbolic link
          do_log(0, "WARN: run_av: skipping unexpected symbolic link $fname");
          next;
        }
        if ($f !~ /^[A-Za-z0-9_.-]+\z/s)
          { do_log(0, "run_av: WARN: unexpected/suspicious file name: $f") }
        push(@bare_fnames, untaint(\$f));
      }
      closedir(DIR) or die "run_av $av_name: Can't close directory: $!";
      $any_files_to_check = scalar(@bare_fnames);
      # replace * with bare file name if alone or in {}/*
      @args = map { !m{^({}/)?\*\z} ? $_ : map {$1.$_} @bare_fnames } @args;
    }
    for (@args) { s[{}][$tempdir/parts]g }  # replace {} with directory name
    if (!$any_files_to_check) {
      do_log(3, "Not calling $av_name, no files to scan");
      $scan_status = 0;  # 'false' (but defined) indicates no viruses
    } else {
      # 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($child_stat) = $?;
      $error_str = exit_status_str($child_stat,$err);
      my($retval) = WEXITSTATUS($child_stat);
      local($1); chomp($output); my($output_trimmed) = $output;
      $output_trimmed =~ s/([ \t\n\r])[ \t\n\r]{4,}/$1.../gs;
      $output_trimmed = "..." . substr($output_trimmed,-800)
        if length($output_trimmed) > 800;
      do_log(3, "run_av: $command $error_str, $output_trimmed");
      if (!WIFEXITED($child_stat)) {
      } elsif (ref($sts_infected) eq 'ARRAY'
                    ? (grep {$_==$retval} @$sts_infected)
                    : $output =~ /$sts_infected/m) {  # is infected
        # test for infected first, in case both expressions match
        $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(2,"run_av ($av_name): 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 ($av_name): clean");
      } else {
        $error_str = 'unexpected ' . $error_str;
      }
      $output = $output_trimmed  if length($output) > 900;
    }
  }
  &$post_code(@_)  if defined $post_code;
  $virusnames = []        if !defined $virusnames;
  @$virusnames = (undef)  if $scan_status && !@$virusnames;  # nonnil
  if (!defined($scan_status) && defined($error_str)) {
    die "$command $error_str";      # die is more informative than return value
  }
  ($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) {
    next  if !defined $av;
    if ($av eq "\000") {  # 'magic' separator between lists
      last  if $anyone_done;
      do_log(0,"WARN: all $tier virus scanners failed, considering backups");
      $tier = 'secondary';  next;
    }
    next  if !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 (@virusname && @detecting_scanners) {
    my(@ds) = @detecting_scanners;  for (@ds) { s/,/;/ }  # facilitates parsing
    do_log(2, sprintf("virus_scan: (%s), detected by %d scanners: %s",
                      join(', ',@virusname), scalar(@ds), join(', ',@ds)));
  }
  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;
use re 'taint';

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

BEGIN {
  import Amavis::Conf qw(:platform :sa $log_level
    @whitelist_sender_maps @blacklist_sender_maps
    $per_recip_whitelist_sender_lookup_tables
    $per_recip_blacklist_sender_lookup_tables);
  import Amavis::Util qw(do_log retcode exit_status_str run_command
                         prolong_timer);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Timing qw(section_time snmp_count);
  import Amavis::Lookup qw(lookup);
}

use subs @EXPORT_OK;

use vars qw($spamassassin_obj);

# called at startup, before the main fork
sub init() {
  do_log(1, "SpamControl: initializing Mail::SpamAssassin");
  my($saved_umask) = umask;
  $spamassassin_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',
#see man Mail::SpamAssassin for other options
  });
  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;
    $spamassassin_obj->set_persistent_address_list_factory($addrlstfactory);
  }
  $spamassassin_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, SA clobbered it
  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;

#   # whitelist genuine bounces from our own mailer
#   if ($msginfo->sender eq '' && defined $msginfo->mime_entity) {
#     my(@received) = $msginfo->mime_entity->head->get('received');
#     if (!@received) {  # no 'Received:' header fields, first-hand bounce
#       $wb=+1; $any_w++; $wr=$recip; $r->recip_whitelisted_sender(1);
#       do_log(0,"white_black_list: whitelisted bounce from our MTA");
#     }
#   }
    if (!defined($wb) && 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)) {  # NULL field or no match: remains undefined
      } elsif ($wb =~ /^[ \000]*\z/) {       # neutral, stops the search
        $wb = 0;
        do_log(5,"white_black_list: (SQL) recip <$recip> is neutral to sender <$sender>");
      } elsif ($wb =~ /^([BbNnFf]|0+)[ ]*\z/) {  # blacklisted (B, N, F or 0)
        $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, Y, T or 1)
        $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)) {  # fall back to static lookups if no match
      # sender can be both white- and blacklisted at the same time
      if (lookup($sender,
           scalar(lookup($recip,$per_recip_blacklist_sender_lookup_tables)),
           @blacklist_sender_maps)) {
        $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,
           scalar(lookup($recip,$per_recip_whitelist_sender_lookup_tables)),
           @whitelist_sender_maps)) {
        $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); my(@lines);
  my($dspam_signature,$dspam_result,$dspam_fname);
  push(@lines, sprintf("Return-Path: %s\n",      # fake a local delivery agent
    qquote_rfc2821_local($msginfo->sender)));
  push(@lines, sprintf("X-Envelope-To: %s\n",
                    join(",\n ",qquote_rfc2821_local(@{$msginfo->recips}))));
  my($fh) = $msginfo->mail_text;
  if ( defined $sa_mail_body_size_limit &&
       ($msginfo->orig_body_size > $sa_mail_body_size_limit ||
        $msginfo->orig_header_size + 1 + $msginfo->orig_body_size
          > 5*1024 + $sa_mail_body_size_limit)
     ) {
    do_log(1, "spam_scan: not wasting time on SA, message ".
              "longer than $sa_mail_body_size_limit bytes: ".
              $msginfo->orig_header_size .'+'. $msginfo->orig_body_size);
  } else {
    if ($dspam eq '') {
      do_log(5, "spam_scan: DSPAM not available, skipping it");
    } else {
      # pass the mail to DSPAM, extract its result headers and feed them to SA
      $dspam_fname = $msginfo->mail_tempdir . '/dspam.msg';
      my($dspam_fh) = IO::File->new;
      $dspam_fh->open($dspam_fname,'>',0640)
        or die "Can't create file $dspam_fname: $!";
      $fh->seek(0,0) or die "Can't rewind mail file: $!";
      my($proc_fh) = run_command('&'.fileno($fh), "&1", $dspam,
                                 qw(--stdout --deliver-spam) );
      # keep X-DSPAM-*, ignore other changes e.g. Content-Transfer-Encoding
      while (defined($_ = $proc_fh->getline)) {  # scan mail header from DSPAM
        $dspam_fh->print($_) or die "Can't write to $dspam_fname: $!";
        last  if $_ eq $eol;
        if (/^X-DSPAM/) { do_log(3,$_); push(@lines,$_) }
        $dspam_signature = $1  if /^X-DSPAM-Signature:[ \t]*(.*)$/i;
        $dspam_result    = $1  if /^X-DSPAM-Result:[ \t]*(.*)$/i;
      }
      while ($proc_fh->read($_,16384) > 0) {     # copy mail body from DSPAM
        $dspam_fh->print($_) or die "Can't write to $dspam_fname: $!";
      }
      my($err); $proc_fh->close or $err = $!; my($retval) = retcode($?);
      do_log(0, 'DSPAM '.exit_status_str($?,$err))  if $retval;
      $dspam_fh->close or die "Can't close $dspam_fname: $!";
      my($hdr_edits) = $msginfo->header_edits;
      if (!$hdr_edits) {
        $hdr_edits = Amavis::Out::EditHeader->new;
        $msginfo->header_edits($hdr_edits);
      }
      $hdr_edits->append_header('X-DSPAM-Signature',
                                $dspam_signature)  if $dspam_signature ne '';
      section_time('DSPAM');
    }
    # read mail into memory in preparation for SpamAssasin
    my($body_lines) = 0;
    $fh->seek(0,0) or die "Can't rewind mail file: $!";
    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 rather arbitrary limit
        if (length($s) > 900) { $s = substr($s,0,900-3) . "..." }
        do_log(0,$s);
      };
      # prepared to wait no more than n seconds
      alarm($sa_timeout)  if $sa_timeout > 0;
      my($mail_obj); my($sa_version) = Mail::SpamAssassin::Version();
      do_log(5, "calling SA parse, SA version $sa_version");
      if ($sa_version >= 3) {
        $mail_obj = $spamassassin_obj->parse(\@lines);
      } elsif ($sa_version >= 2.70) {
        $mail_obj = Mail::SpamAssassin::MsgParser->parse(\@lines);
      } else {
        $mail_obj = Mail::SpamAssassin::NoMailAudit->new(data => \@lines,
                                                         add_From_line => 0);
      }
      section_time('SA parse');
      do_log(5, "CALLING SA check");
      my($per_msg_status);
      { local($1,$2,$3,$4,$5,$6);  # avoid Perl 5.8.0 bug, $1 gets tainted
        $per_msg_status = $spamassassin_obj->check($mail_obj);
      }
      my($rem_t) = alarm(0);
      do_log(5, "RETURNED FROM SA check, time left: $rem_t s");

      { local($1,$2,$3,$4);  # avoid Perl 5.8.0 & 5.8.2 taint bug
        $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;  # taints $1 and $2 !

      # example of how to gather aditional information from SA:
      # my($untrusted) = $per_msg_status->_get_tag('RELAYSUNTRUSTED');

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

    if ($dspam ne '' && defined $spam_level) {  # DSPAM auto-learn
      my($eat,@options);
      if (   $spam_level >  5.0 && $dspam_result eq 'Innocent')
        { $eat = 'SPAM'; @options = qw(--stdout --addspam) }
      elsif ($spam_level <  1.0 && $dspam_result eq 'Spam')
        { $eat = 'HAM';  @options = qw(--stdout --falsepositive) }
      if (defined $eat && $dspam_signature ne '') {
        do_log(2, "DSPAM learn $eat ($spam_level), $dspam_signature");
        my($proc_fh) = run_command($dspam_fname, "&1", $dspam, @options);
        while (defined($_ = $proc_fh->getline)) {}  # consume possible output
#       my($output) = join('', $proc_fh->getlines); # consume possible output
        my($err); $proc_fh->close or $err = $!; my($retval) = retcode($?);
#       do_log(0, "DSPAM learn $eat response:".$output)  if $output ne '';
        $retval==0 or die ("DSPAM learn $eat FAILED: ".exit_status_str($?,$err));
        section_time('DSPAM loarn');
      }
    }
  }
  if (defined $dspam_fname) {
    if (($spam_level > 5.0 ? 1 : 0) != ($dspam_result eq 'Spam' ? 1 : 0))
      { do_log(2, "DSPAM: different opinions: $dspam_result, $spam_level") }
    if ($dspam_result eq 'Spam' &&
        $spam_level-1.0 < 6.31 && $spam_level >= 6.31)
      { do_log(2, "DSPAM: saved the day: $dspam_result, $spam_level") }
    unlink($dspam_fname) or die "Can't delete file $dspam_fname: $!";
  }
  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::MsgContainer 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__
#
package Amavis::Unpackers;
use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.01';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = ();
  @EXPORT = ();
  @EXPORT_OK = qw(&init &decompose_part &determine_file_types);
}
use Errno qw(ENOENT);
use File::Basename qw(basename);
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(untaint min max do_log retcode exit_status_str
                         prolong_timer sanitize_str
                         rmdir_flat rmdir_recursively run_command);
  import Amavis::Conf qw(:platform :confvars :unpack);
  import Amavis::Timing qw(section_time snmp_count);
  import Amavis::Lookup qw(lookup);
  import Amavis::Unpackers::MIME qw(mime_decode);
  import Amavis::Unpackers::NewFilename qw(consumed_bytes);
}

use subs @EXPORT_OK;

# 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($$$);  # prototype
sub flatten_and_tidy_dir($$$) {
  my($dir, $outdir, $parent_obj) = @_;
  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);
  chmod(0750, $dir) or die "Can't change protection of \"$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: $!" }
    if (defined $msg) { die "flatten_and_tidy_dir: \"$dir/$f\" $msg" }
    next  if ($f eq '.' || $f eq '..') && -d _;
    $f = untaint(\$f);
    my($newpart_obj) = Amavis::Unpackers::Part->new($outdir,$parent_obj);
    $newpart_obj->name_declared($f);
    if (-d _) {
      $newpart_obj->attributes_add('D');
      $consumed_bytes += flatten_and_tidy_dir("$dir/$f", $outdir, $parent_obj);
    } elsif (-l _) {
      $cnt_u++; $newpart_obj->attributes_add('L');
      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++; $newpart_obj->attributes_add('S');
      unlink("$dir/$f") or die "Can't remove nonregular file \"$dir/$f\": $!";
    } elsif (-z _) {
      $cnt_u++;
      unlink("$dir/$f") or die "Can't remove empty file \"$dir/$f\": $!";
    } else {
      chmod(0750, "$dir/$f")
        or die "Can't change protection of file \"$dir/$f\": $!";
      my($size) = 0 + (-s _);
      $newpart_obj->size($size);
      $consumed_bytes += $size;
      my($newpart) = $newpart_obj->full_name;
      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\": $!";
  rmdir($dir)   or die "Can't remove directory \"$dir\": $!";
  section_time("ren${cnt_r}-unl${cnt_u}-files");
  $consumed_bytes;
}

# call 'file(1)' utility for each part,
# and associate (save) full and short types with each part
#
sub determine_file_types($$) {
  my($tempdir, $partslist_ref) = @_;
  $file ne '' or die "Unix utility file(1) not available, but is needed";
  my($cwd) = "$tempdir/parts";
  my(@part_list) = grep { $_->exists } @$partslist_ref;
  if (!@part_list) { do_log(5, "no parts, file(1) not called") }
  else {
    local($1,$2); # avoid Perl taint bug (5.8.3), $cwd and $arg are not tainted
                  # but $arg becomes tainted because $1 is tainted from before
    my(@file_list);
    for my $part (@part_list) {
      my($arg) = $part->full_name;
      $arg =~ s{^\Q$cwd\E/(.*)\z}{$1}s;    # remove cwd if possible
      push(@file_list, $arg);
    }
    chdir($cwd) or die "Can't chdir to $cwd: $!";
    my($proc_fh) = run_command(undef, undef, $file, @file_list);
    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
    local($_); my($index) = 0;
    while (defined($_ = $proc_fh->getline)) {
      chomp;
      do_log(5, "result line from file(1): ".$_);
      if ($index > $#file_list) {
        do_log(0, "NOTICE: Skipping extra output from file(1): $_");
      } else {
        my($part)   = $part_list[$index];  # walk through @part_list in sync
        my($expect) = $file_list[$index];  # walk through @file_list in sync
        if (!/^(\Q$expect\E):[ \t]*(.*)\z/s) {    # split file name from type
          do_log(0,"NOTICE: Skipping bad output from file(1) ".
                   "at [$index, $expect], got: $_");
        } else {
          my($type_short); my($actual_name) = $1; my($type_long) = $2;
          $type_short = lookup($type_long,@map_full_type_to_short_type_maps);
          do_log(4, sprintf("File-type of %s: %s%s",
                            $part->base_name, $type_long,
                            (defined $type_short ? "; ($type_short)" : '') ));
          $part->type_long($type_long); $part->type_short($type_short);
          $part->attributes_add('C')  if $type_short eq 'pgp';  # encrypted?
          $index++;
        }
      }
    }
    if ($index < @part_list) {
      die sprintf("parsing file(1) results - missing last %d results",
                  @part_list - $index);
    }
    my($err); $proc_fh->close or $err = $!;
    $?==0 or die ("'file' utility ($file) failed, ".exit_status_str($?,$err));
    section_time(sprintf('get-file-type%d', scalar(@part_list)));
  }
}

sub decompose_mail($$) {
  my($tempdir,$file_generator_object) = @_;

  my($hold); my(@parts); my($depth) = 1; my($any_undecipherable) = 0;
  my($which_section) = "parts_decode";
  # fetch all not-yet-visited part names, and start a new cycle
TIER:
  while (@parts = @{$file_generator_object->parts_list}) {
    if ($MAXLEVELS && $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(', ', (map { $_->base_name } @chopped_parts),
                     (@chopped_parts >= @parts ? () : "...")) ));
    for my $part (@parts) {
      my($errn) = stat($part->full_name) ? 0 : 0+$!;
      $any_undecipherable++  if grep {$_ eq 'U'} @{ $part->attributes || [] };
      if ($errn == ENOENT) {
        $part->exists(0);
      } elsif (-z _) {
        my($f) = $part->full_name; unlink($f) or die "Can't remove \"$f\": $!";
        $part->exists(0);
      } else {
        $part->exists(1);
      }
    }
    determine_file_types($tempdir, \@parts);
    for my $part (@parts) {
      if ($part->exists) {
        $hold = decompose_part($part, $tempdir);
        last TIER  if defined $hold;
      }
    }
    $depth++;
  }
  section_time($which_section); prolong_timer($which_section);
  ($hold, $any_undecipherable);
}

# Decompose the part
sub decompose_part($$) {
  my($part, $tempdir) = @_;
  my($hold);
  my($none_called);
  # 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 {
    local($_) = $part->type_short;
    return 0  if !defined($_);  # consider atomic if unknown
    snmp_count("OpsDecType\u$_");
    /^mail\z/ && return do {mime_decode($part,$tempdir,$part); 2};
    /^(asc|uue|hqx|ync)\z/ && return do_ascii($part,$tempdir);
    /^F\z/    && defined $unfreeze
              && return do_uncompress($part,$tempdir,$unfreeze);
    /^Z\z/    && defined $uncompress
              && return do_uncompress($part,$tempdir,$uncompress);
    /^bz2\z/  && defined $bzip2
              && return do_uncompress($part,$tempdir,"$bzip2 -d");
    /^gz\z/   && defined $gzip
              && return do_uncompress($part,$tempdir,"$gzip -d");
    /^gz\z/   && return do_gunzip($part,$tempdir);  # fallback
    /^lzo\z/  && defined $lzop
              && return do_uncompress($part,$tempdir,"$lzop -d");
    /^rpm\z/  && defined $rpm2cpio
              && return do_uncompress($part,$tempdir,$rpm2cpio);
    /^cpio\z/ && defined $cpio
              && return do_cpio($part,$tempdir);
    /^tar\z/  && defined $cpio
              && return do_cpio($part,$tempdir);
    /^tar\z/  && return do_tar($part,$tempdir);  # fallback
    /^zip\z/  && return do_unzip($part,$tempdir);
    /^rar\z/  && defined $unrar
              && return do_unrar($part,$tempdir);
    /^(lha|lzh)\z/ && defined $lha
              && return do_lha($part,$tempdir);
    /^arc\z/  && defined $arc
              && return do_arc($part,$tempdir);
    /^arj\z/  && defined $unarj
              && return do_unarj($part,$tempdir);
    /^zoo\z/  && defined $zoo
              && return do_zoo($part,$tempdir);
    /^cab\z/  && defined $cabextract
              && return do_cabextract($part,$tempdir);
    /^tnef\z/ && return do_tnef($part,$tempdir);
    /^exe.*\z/ && return do_executable($part,$tempdir);

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

#
# Uncompression/unarchiving routines
# Possible return codes:
# 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)

# if ASCII text, try multiple decoding methods as provided by UUlib
# (uuencoded, xxencoded, BinHex, yEnc, Base64, Quoted-Printable)
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 '';

  snmp_count('OpsDecByUUlibAttempt');
  $sts = Convert::UUlib::Initialize();
  $sts==RET_OK or die "Convert::UUlib::Initialize failed: "
                        . Convert::UUlib::strerror($sts);
  my($uulib_version) = Convert::UUlib::GetOption(OPT_VERSION);
  !Convert::UUlib::SetOption(OPT_IGNMODE,1)  or die "do_ascii: bad uulib opt1";
# !Convert::UUlib::SetOption(OPT_DESPERATE,1)or die "do_ascii: bad uulib opt2";
  ($sts, $count) = Convert::UUlib::LoadFile($part->full_name);
  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 (uulib V$uulib_version) failed: $errmsg";
  }
  do_log(4,sprintf("do_ascii: Decoding part %s (%d items), uulib V%s",
                   $part->base_name, $count, $uulib_version));
  my($uu);
  my($any_errors, $any_decoded);
  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 decodable, ".$uu->state);
    } else {
      my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
      $newpart_obj->name_declared($uu->filename);
      my($newpart) = $newpart_obj->full_name;
      $! = undef;
      $sts = $uu->decode($newpart);  # decode to file $newpart
      my($err_decode) = "$!";
      chmod(0750, $newpart) or $! == ENOENT  # chmod, don't panic if no file
        or die "Can't change protection of \"$newpart\": $!";
      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 = "; result file status: $newpart $statmsg" }

      my($size) = 0 + (-s _);
      $newpart_obj->size($size);
      consumed_bytes($size, '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();
  snmp_count('OpsDecByUUlib')  if $any_decoded;
  ($any_decoded && !$any_errors) ? 1 : $any_errors ? 2 : 0;
}

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

  do_log(4, "Unzipping " . $part->base_name);
  snmp_count('OpsDecByArZipAttempt');
  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($part->full_name);
  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);
  my($encryptedcount,$extractedcount) = (0,0);
  for my $mem ($zip->members()) {
    my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
    $newpart_obj->name_declared($mem->fileName);
    my($compmeth) = $mem->compressionMethod;
    if ($compmeth != COMPRESSION_DEFLATED && $compmeth != COMPRESSION_STORED) {
      $any_unsupp_compmeth = $compmeth;
      $newpart_obj->attributes_add('U');
    } elsif ($mem->isEncrypted) {
      $encryptedcount++;
      $newpart_obj->attributes_add('U','C');
    } elsif ($mem->isDirectory) {
      $newpart_obj->attributes_add('D');
    } else {
      my($oldc) = $mem->desiredCompressionMethod(COMPRESSION_STORED);
      $sts = $mem->rewindData();
      $sts == AZ_OK or die sprintf("%s: error rew. member data: %s (%s)",
                                   $part->base_name, $err_nm[$sts], $sts);
      my($newpart) = $newpart_obj->full_name;
      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 sprintf("%s: error reading member: %s (%s)",
                         $part->base_name, $err_nm[$sts], $sts);
        print OUTPART ($$buf_ref) or die "Can't write to $newpart: $!";
        $newpart_obj->size(length($$buf_ref));
        consumed_bytes(length($$buf_ref), 'do_unzip');
      }
      close(OUTPART) or die "Can't close $newpart: $!";
      $mem->desiredCompressionMethod($oldc);
      $mem->endRead();
      $extractedcount++;
    }
  }
  snmp_count('OpsDecByArZip');
  if ($any_unsupp_compmeth) {
    do_log(0, sprintf("do_unzip: %s, unsupported compr. method: %s",
                      $part->base_name, $any_unsupp_compmeth));
    return 2;
  }
  if ($encryptedcount) {
    do_log(1, sprintf(
      "do_unzip: %s, %d members are encrypted, %s extracted, archive retained",
                      $part->base_name, $encryptedcount,
                      !$extractedcount ? 'none' : $extractedcount));
    return 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) = @_;
  do_log(4,sprintf("do_uncompress %s by %s", $part->base_name, $decompressor));
  my($decompressor_name) = basename((split(' ',$decompressor))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
  my($newpart) = $newpart_obj->full_name;
  my($name) = $part->name_declared;
  if ($name ne '') {
    local($_) = $part->type_short;
    /^F\z/   and $name=~s/\.F\z//;
    /^Z\z/   and $name=~s/\.Z\z//    || $name=~s/\.tgz\z/.tar/;
    /^gz\z/  and $name=~s/\.gz\z//   || $name=~s/\.tgz\z/.tar/;
    /^bz2\z/ and $name=~s/\.bz2?\z// || $name=~s/\.tbz\z/.tar/;
    /^lzo\z/ and $name=~s/\.lzo\z//;
    /^rpm\z/ and $name=~s/\.rpm\z/.cpio/;
    $newpart_obj->name_declared($name);
  }
  my($rv) = run_command_copy($newpart,
              run_command($part->full_name, undef, split(' ',$decompressor)));
  if ($rv) {
    unlink($newpart) or die "Can't unlink $newpart: $!";
    die sprintf('Error running decompressor %s on %s, %s',
                $decompressor, $part->base_name, exit_status_str($rv));
  }
  1;
}

# use Zlib to inflate
sub do_gunzip($$) {
  my($part, $tempdir) = @_;
  do_log(4, "Inflating gzip archive " . $part->base_name);
  snmp_count('OpsDecByZlib');
  local *OUTPART;
  my($gz) = gzopen($part->full_name, "rb")
    or die sprintf("do_gunzip: Error opening %s: %s",
                   $part->full_name, $gzerrno);
  my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
  my($newpart) = $newpart_obj->full_name;
  open(OUTPART, ">$newpart") or die "Can't create $newpart: $!";
  binmode(OUTPART) or die "Can't set $newpart to binmode: $!";
  my($buffer); my($size) = 0;
  while ($gz->gzread($buffer) > 0) {
    print OUTPART $buffer or die "Can't write to $newpart: $!";
    $size += length($buffer);
    consumed_bytes(length($buffer), 'do_gunzip');
  }
  $newpart_obj->size($size);
  close(OUTPART) or die "Can't close $newpart: $!";
  if ($gzerrno != Z_STREAM_END) {
    do_log(0,sprintf("do_gunzip: Error reading %s: %s",
                     $part->full_name, $gzerrno));
    unlink($newpart) or die "Can't unlink $newpart: $!";
    $newpart_obj->size(undef);
    $gz->gzclose();
    return 0;
  }
  $gz->gzclose();
  1;
}

# untar any tar archives with Archive-Tar, extract each file individually
sub do_tar($$) {
  my($part, $tempdir) = @_;
  snmp_count('OpsDecByArTar');
  # Work around bug in Archive-Tar
  my $tar = eval { Archive::Tar->new($part->full_name) };
  if (!defined($tar)) {
    chomp($@);
    do_log(4, sprintf("Faulty archive %s: %s", $part->full_name, $@));
    return 0;
  }
  local *OUTPART;
  do_log(4,"Untarring ".$part->base_name);
  my @list = $tar->list_files();
  for (@list) {
    next  if /\/\z/;  # ignore directories
                      # this is bad (reads whole file into scalar)
                      # need some error handling, too
    my $data = $tar->get_content($_);
    my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
    my($newpart) = $newpart_obj->full_name;
    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: $!";
    $newpart_obj->size(length($data));
    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, $tempdir) = @_;
  do_log(4, "Attempting to expand RAR archive " . $part->base_name);
  my($decompressor_name) = basename((split(' ',$unrar))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}Attempt");
  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, '--', $part->full_name);
  $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, '--',
                  $part->full_name);
    $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' %s, command: %s",
                     exit_status_str($rv1,$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->base_name);

  my(@list); my($hypcount) = 0; my($encryptedcount) = 0;
  my($lcnt) = 0; my($member_name); my($bytes) = 0; my($last_line);
  my($proc_fh) = run_command(undef, undef, $unrar, 'v', @common_rar_switches,
                             '--', $part->full_name);
  while (defined($_ = $proc_fh->getline)) {
    $last_line = $_  if !/^\s*$/;  # last nonempty line
    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 (/^(.)(.*)\z/s) {
        $member_name = $2; # all but the first character (space or an asterisk)
        if ($1 eq '*') {   # member is encrypted
          $encryptedcount++;
          # make a phantom entry - carrying only name and attributes
          my($newpart_obj)=Amavis::Unpackers::Part->new("$tempdir/parts",$part);
          $newpart_obj->name_declared($member_name);
          $newpart_obj->attributes_add('U','C');
          $member_name = undef;  # makes no sense extracting encrypted files
        }
      }
    }
  }
  # consume all remaining output to avoid broken pipe
  while (defined($_ = $proc_fh->getline)) { $last_line = $_  if !/^\s*$/ }
  $err = undef; $proc_fh->close or $err = $!; $retval = retcode($?);

  if ($last_line !~ /^\s*(\d+)\s+(\d+)/s) {
    do_log(4,"do_unrar: WARN: unable to obtain orig total size: $last_line");
  } else {
    do_log(4,"do_unrar: summary size: $2, sum of sizes: $bytes")
      if abs($bytes - $2) > 100;
    $bytes = $2  if $2 > $bytes;
  }
  consumed_bytes($bytes, 'do_unrar-pre', 1);  # pre-check on estimated size
  if (!grep { $_ == $retval } (0,1)) {  # not one of: SUCCESS, WARNING
    die ("unrar: can't get a list of archive members: " .
         exit_status_str($?,$err));
  }
  snmp_count("OpsDecBy\u${decompressor_name}");
  if (!@list) {
    do_log(4, "do_unrar: no archive members, or not an archive altogether");
#*** return 0  if $exec;
  } else {
  # my $rv = store_mgr($tempdir, $part, \@list, $unrar,
  #                    qw(p -inul -kb), @common_rar_switches, '--',
  #                    $part->full_name);
    my($proc_fh) =
      run_command(undef, "&1", $unrar, qw(x -inul -ver -o- -kb),
                  @common_rar_switches, '--',
                  $part->full_name, "$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 '.exit_status_str($?,$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",$part);
      consumed_bytes($b, 'do_unrar');
    }
  }
  if ($encryptedcount) {
    do_log(1, sprintf(
      "do_unrar: %s, %d members are encrypted, %s extracted, archive retained",
      $part->base_name, $encryptedcount, !@list ? 'none' : 0+@list ));
    return 2;
  }
  1;
}

# use external program to expand LHA archives
sub do_lha($$) {
  my($part, $tempdir) = @_;
  my($decompressor_name) = basename((split(' ',$lha))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}Attempt");
  # lha needs extension .exe to understand SFX!
  symlink($part->full_name, $part->full_name.".exe")
    or die sprintf("Can't symlink %s %s.exe: %s",
                   $part->full_name, $part->full_name, $!);
  # Check whether we can really lha it
  my($checkerr); my($retval) = 1;
  my($proc_fh) = run_command(undef, "&1", $lha, 'lq', $part->full_name.".exe");
  while (defined($_ = $proc_fh->getline)) {
    $checkerr = 1  if /Checksum error/i;
  }
  my($err); $proc_fh->close or $err = $!;
  $?==0 or do_log(0, 'do_lha: '.exit_status_str($?,$err));
  if ($? || $checkerr) {
    $retval = 0;  # consider atomic
  } else {
    do_log(4, "Expanding LHA archive " . $part->base_name . ".exe");
    snmp_count("OpsDecBy\u${decompressor_name}");
    $proc_fh = run_command(undef, undef, $lha, 'lq', $part->full_name.".exe");
    my(@list);
    while (defined($_ = $proc_fh->getline)) {
      chomp;
      next  if /\/\z/;  # ignore directories
      push(@list, (split(/\s+/))[-1]);  #***??? split on whitespace ???
    }
    $err=undef; $proc_fh->close or $err = $!;
    $?==0 or do_log(0, 'do_lha: '.exit_status_str($?,$err));
    if (!@list) {
      do_log(4, "do_lha: no archive members, or not an archive altogether");
#***  $retval = 0  if $exec;
    } else {
      my $rv = store_mgr($tempdir, $part, \@list, $lha, 'pq',
                         $part->full_name.".exe");
      do_log(0, 'do_lha '.exit_status_str($rv))  if $rv;
      $retval = 1;  # consider decoded
    }
  }
  unlink($part->full_name.".exe")
    or die "Can't unlink " . $part->full_name . ".exe: $!";
  $retval;
}

# 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) = @_;
  my($decompressor_name) = basename((split(' ',$arc))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  my($is_nomarch) = $arc =~ /nomarch/i;
  do_log(4,sprintf("Unarcing %s, using %s",
                   $part->base_name, ($is_nomarch ? "nomarch" : "arc") ));
  my($cmdargs) = ($is_nomarch ? "-l -U" : "ln") . " " . $part->full_name;
  my($proc_fh) = run_command(undef, '/dev/null', $arc, split(' ',$cmdargs));
  my(@list) = $proc_fh->getlines;
  my($err); $proc_fh->close or $err = $!;
  $?==0 or do_log(0, 'do_arc: '.exit_status_str($?,$err));

  #*** no spaces in filenames allowed???
  map { s/^([^ \t\r\n]*).*\z/$1/s } @list;  # keep only filenames
  if (@list) {
    my $rv = store_mgr($tempdir, $part, \@list, $arc,
                       ($is_nomarch ? ('-p', '-U') : 'p'), $part->full_name);
    do_log(0, 'arc '.exit_status_str($rv))  if $rv;
  }
  1;
}

# use external program to expand ZOO archives
sub do_zoo($$) {
  my($part, $tempdir) = @_;
  do_log(4, "Expanding ZOO archive " . $part->full_name);
  my($decompressor_name) = basename((split(' ',$zoo))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  # Zoo needs extension of .zoo!
  symlink($part->full_name, $part->full_name.".zoo")
    or die sprintf("Can't symlink %s %s.zoo: %s",
                   $part->full_name, $part->full_name, $!);
  my($proc_fh) =
    run_command(undef, undef, $zoo, 'lf1q', $part->full_name.".zoo");
  my(@list) = $proc_fh->getlines;
  my($err); $proc_fh->close or $err = $!;
  $?==0 or do_log(0, 'do_zoo: '.exit_status_str($?,$err));
  if (@list) {
    chomp(@list);
    my $rv = store_mgr($tempdir, $part, \@list, $zoo, 'xpqqq:',
                       $part->full_name . ".zoo");
    do_log(0, 'zoo '.exit_status_str($rv))  if $rv;
  }
  unlink($part->full_name.".zoo")
    or die "Can't unlink " . $part->full_name . ".zoo: $!";
  1;
}

# use external program to expand ARJ archives
sub do_unarj($$) {
  my($part, $tempdir) = @_;
  do_log(4, "Expanding ARJ archive " . $part->base_name);
  my($decompressor_name) = basename((split(' ',$unrar))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  # options to arj, ignored by unarj
  # provide some password in -g to turn fatal error into 'bad password' error
  $ENV{ARJ_SW} = "-i -jo -b5 -2h -jyc -ja1 -gsecret -w$TEMPBASE";
  # unarj needs extension of .arj!
  symlink($part->full_name, $part->full_name.".arj")
    or die sprintf("Can't symlink %s %s.arj: %s",
                   $part->full_name, $part->full_name, $!);
  # obtain total original size of archive members from the index/listing
  my($proc_fh) = run_command(undef,'/dev/null', $unarj, 'l',
                             $part->full_name.".arj");
  my($last_line);
  while (defined($_ = $proc_fh->getline)) { $last_line = $_  if !/^\s*$/ }
  my($err); $proc_fh->close or $err = $!; my($retval) = retcode($?);
  if (!grep { $_ == $retval } (0,1,3)) {   # not one of: success, warn, CRC err
    die ("unarj: can't get a list of archive members: ".
         exit_status_str($?,$err));
  }
  if ($last_line !~ /^\s*(\d+)\s*files\s*(\d+)/s) {
    do_log(0,"do_unarj: WARN: unable to obtain orig size of files: $last_line");
  } else {
    consumed_bytes($2, 'do_unarj-pre', 1); # pre-check on estimated size
  }
  # unarj has very limited extraction options, arj is much better!
  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: $!";
  $proc_fh = run_command(undef, "&1", $unarj, 'e', $part->full_name.".arj");
  my($encryptedcount,$skippedcount) = (0,0);
  while (defined($_ = $proc_fh->getline)) {
    $encryptedcount++ 
      if /^(Extracting.*\bBad file data or bad password|File is password encrypted, Skipped)\b/s;
    $skippedcount++
      if /(\bexists|^File is password encrypted|^Unsupported .*), Skipped\b/s;
  }
  $err = undef; $proc_fh->close or $err = $!; $retval = retcode($?);
  chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
  # add attributes to the parent object, because we didn't remember names
  # of its scrambled members
  $part->attributes_add('U')  if $skippedcount;
  $part->attributes_add('C')  if $encryptedcount;
  my($errn) = stat("$tempdir/parts/arj") ? 0 : 0+$!;
  if ($errn != ENOENT) {
    my($b) = flatten_and_tidy_dir("$tempdir/parts/arj","$tempdir/parts",$part);
    consumed_bytes($b, 'do_unarj');
    snmp_count("OpsDecBy\u${decompressor_name}");
  }
  unlink($part->full_name.".arj")
    or die "Can't unlink " . $part->full_name . ".arj: $!";
  if (!grep { $_ == $retval } (0,1,3)) {  # not one of: success, warn, CRC err
    die ("unarj: can't extract archive members: ".exit_status_str($?,$err));
  }
  if ($encryptedcount || $skippedcount) {
    do_log(1, sprintf(
      "do_unarj: %s, %d members are encrypted, %d skipped, archive retained",
      $part->base_name, $encryptedcount, $skippedcount));
    return 2;
  }
  1;
}

# use Convert-TNEF
sub do_tnef($$) {
  my($part, $tempdir) = @_;
  do_log(4, "Extracting TNEF attachment " . $part->base_name);
  snmp_count('OpsDecByTnef');
  chdir("$tempdir/parts") or die "Can't chdir to $tempdir/parts: $!";
  my $tnef =
    Convert::TNEF->read_in($part->full_name, {ignore_checksum => "true"});
  if (!$tnef) {
    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
    return 0;  # Not TNEF - treat as atomic
  }
  local *OUTPART;
  for my $a ($tnef->message, $tnef->attachments) {
    if (my $dh = $a->datahandle) {
      my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
      $newpart_obj->name_declared([$a->name, $a->longname]);
      $newpart_obj->size($a->size);
      consumed_bytes($a->size, 'do_tnef');
      my($newpart) = $newpart_obj->full_name;
      open(OUTPART, ">$newpart") or die "Can't create $newpart: $!";
      binmode(OUTPART) or die "Can't set $newpart to binmode: $!";
      if (defined(my $file = $dh->path)) {
        copy($file, \*OUTPART);
      } else {
        my($s) = $dh->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: $!";
    }
  }
  $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) = @_;
  do_log(4,"Expanding cpio archive ".$part->full_name);
  my($decompressor_name) = basename((split(' ',$cpio))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  my($bytes) = 0;
  my($proc_fh) = run_command($part->full_name, undef, $cpio, qw(-t -v));
                ### qw(-t -v -n --quiet) );   # use -n and --quiet if available
  while (defined($_ = $proc_fh->getline)) {
    chomp;
    next if /^\d+ blocks\z/;  # needed if --quiet is not specified
    if (!/^(?:\S+\s+){4}(\d+)\s+((?:\S+\s+){2}\S+)\s+(.*)\z/) {
      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 = $!;  ### $?;

  consumed_bytes($bytes, 'do_cpio-pre', 1);  # pre-check on estimated size
  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: $!";
  $proc_fh = run_command($part->full_name, '/dev/null', $cpio,
                qw(-i -d --no-absolute-filenames --no-preserve-owner --quiet));
  # --no-preserve-owner is not necessary if not running as root
  my($output) = ''; while (defined($_ = $proc_fh->getline)) { $output .= $_ }
  $err = undef; $proc_fh->close or $err = $!;
  $?==0 or do_log(0, 'cpio '.exit_status_str($?,$err).' '.$output);
  chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
  my($b) = flatten_and_tidy_dir("$tempdir/parts/cpio","$tempdir/parts",$part);
  consumed_bytes($b, 'do_cpio');
  1;
}

sub do_cabextract($$) {
  my($part, $tempdir) = @_;
  do_log(4, "Expanding cab archive " . $part->base_name);
  my($decompressor_name) = basename((split(' ',$cabextract))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  my($bytes) = 0;
  my($proc_fh) = run_command(undef,undef,$cabextract,'-l',$part->full_name);
  while (defined($_ = $proc_fh->getline)) {
    chomp;
    next if /^(File size|----|Viewing cabinet:|\z)/;
    if (!/^\s* (\d+) \s* \| [^|]* \| \s (.*) \z/x) {
      do_log(0, "do_cabextract: can't parse toc line: $_");
    } else {
      do_log(5, "do_cabextract: member: \"$2\", size: $1");
      $bytes += $1  if $1 > 0;
    }
  }
  # consume remaining output to avoid broken pipe (just in case)
  while (defined($proc_fh->getline)) { }
  my($err); $proc_fh->close or $err = $!;  ### $?;

  consumed_bytes($bytes, 'do_cabextract-pre', 1); # pre-check on estimated size
  mkdir("$tempdir/parts/cab", 0750) or die "Can't mkdir $tempdir/parts/cab: $!";
  $proc_fh = run_command(undef, '/dev/null', $cabextract, '-q', '-d',
                             "$tempdir/parts/cab", $part->full_name);
  my($output) = ''; while (defined($_ = $proc_fh->getline)) { $output .= $_ }
  $err = undef; $proc_fh->close or $err = $!;
  $?==0 or do_log(0, 'cabextract '.exit_status_str($?,$err).' '.$output);
  my($b) = flatten_and_tidy_dir("$tempdir/parts/cab", "$tempdir/parts", $part);
  consumed_bytes($b, 'do_cabextract');
  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->base_name." is a self-extracting archive");

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

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

  # LHA?
  return 2  if defined $lha && eval { do_lha($part, $tempdir) };
  chomp($@);
  do_log(0,"do_executable/do_lha failed, ignoring: $@")    if $@ ne '';

  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,'>') 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, $parent_obj, $list, $cmd, @args) = @_;

  local *FH;  my(@rv);
  for my $f (@$list) {
    next if $f =~ /\/\z/;  # ignore directories
    if ($f =~ m{^\.?[A-Za-z0-9_][A-Za-z0-9/._=~-]*\z}) {  # apparently safe arg
    } else {  # this is not too bad, as run_command does not use shell
      do_log(1, "store_mgr: NOTICE: untainting funny argument \"$f\"");
    }
    $f = untaint(\$f);
    my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",
                                                    $parent_obj);
    $newpart_obj->name_declared($f);
    my($newpart) = $newpart_obj->full_name;
    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,"store_mgr: extracted by $cmd, ".exit_status_str($rv));
    push(@rv, $rv);
  }
  @rv = grep { $_ != 0 } @rv;
  @rv ? $rv[0] : 0;  # just return the first
                     # nonzero status (if any), or 0
}

1;

__DATA__
#
# =============================================================================
# This text section governs how a main amavisd-new log entry is formed.
# An empty text will prevent a log entry, multi-line text will produce
# several log entries, one for each nonempty line.
# Syntax is explained in the README.customize file.
#
[?%#D||Passed #
[? %#V |[? %#F |[? %#X |[? %2 |CLEAN|SPAM]|BAD-HEADER]|BANNED (%F)]|INFECTED (%V)]#
, [?%a||\[%a\] ]<%o> -> [%D|,]#
[? %q ||, quarantine: %i]#
[? %m ||, Message-ID: %m]#
[? %r ||, Resent-Message-ID: %r]#
, Hits: %c#
]
[?%#O||Blocked #
[? %#V |[? %#F |[? %#X |[? %2 |CLEAN|SPAM]|BAD-HEADER]|BANNED (%F)]|INFECTED (%V)]#
, [?%a||\[%a\] ]<%o> -> [%O|,]#
[? %q ||, quarantine: %i]#
[? %m ||, Message-ID: %m]#
[? %r ||, Resent-Message-ID: %r]#
, Hits: %c#
]
__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 HEADER (INVALID CHARACTERS OR SPACE GAP)

[%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.
]

Return-Path: %s
Your message[?%m|| %m][?%r|| (Resent-Message-ID: %r)] could not be delivered to:[
  %N]
__DATA__
#
# =============================================================================
# This is a template for VIRUS/BANNED 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 |Unknown problem|BANNED (%F)]|VIRUS (%V)] IN MAIL FROM YOU
[? %m  |#|In-Reply-To: %m]
Message-ID: <VS%n@%h>

[? %#V |[? %#F |[? %#X ||INVALID HEADER]|BANNED CONTENTS 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 email presumably from you (%s),
to the following [? %#R |recipients|recipient|recipients]:[
-> %R]

[? %#V ||Please check your system for viruses,
or ask your system administrator to do so.
Our internal reference code for your message is %n.

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

]#
[? %#V |[? %#F ||#
The message has been blocked because it contains a component
(as a MIME part or nested within) with declared name
or MIME type or contents type violating our access policy.

To transfer contents that may be considered risky or unwanted
by site policies, or simply too large for mailing, please consider
publishing your content on the web, and only sending an URL of the
document to the recipient.

Depending on the recipient and sender site policies, with a little
effort it might still be possible to send any contents (including
viruses) using one of the following methods:

- encrypted using pgp, gpg or other encryption methods;

- wrapped in a password-protected or scrambled container or archive
  (e.g.: zip -e, arj -g, arc g, rar -p, or other methods)

Note that if the contents is not intended to be secret, the
encryption key or password may be included in the same message
for recipient's convenience.

We are sorry for inconvenience if the contents was not malicious.

The purpose of these restrictions is to cut the most common propagation
methods used by viruses and other malware. These often exploit automatic
mechanisms and security holes in certain mail readers (Microsoft mail
readers and browsers are a common and easy target). By requiring an
explicit and decisive action from the recipient to decode mail,
the dangers of automatic malware propagation is largely reduced.
#
# Details of our mail restrictions policy are available at ...

]]#

For your reference, here are headers from your email:
------------------------- BEGIN HEADERS -----------------------------
Return-Path: %s
[%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 (%F)]|VIRUS (%V)]#
 FROM[?%l|| LOCAL] [?%o|(?)|<%o>]
To: [? %#T |undisclosed-recipients: ;|[<%T>|, ]]
[? %#C |#|Cc: [<%C>|, ]]
Message-ID: <VA%n@%h>

[? %#V |No viruses were found.
|A virus (%V) was found.
|Two viruses (%V) were found.
|%#V viruses were found.
]
[? %#F |#
|A banned name was found:\n  %F
|Two banned names were found:\n  %F
|%#F banned names were found:\n  %F
]
[? %#X |#
|Bad header was found:[\n  %X]
]
[? %#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 -----------------------------
Return-Path: %s
[%H
]\
-------------------------- END HEADERS ------------------------------
__DATA__
#
# =============================================================================
# This is a template for VIRUS/BANNED/BAD-HEADER 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 |[? %#X ||INVALID HEADER]|BANNED]|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 CONTENTS 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 an email to you [? %S |from unknown sender:|from:]

   %o

Our internal reference code for your message is %n.
[? %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).
[? %#X |#|\n[%X\n]]
Subject: %j
Return-Path: %s
Our internal reference code for your message is %n.

[? %#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 [? %S |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 -----------------------------
Return-Path: %s
[%H
]\
-------------------------- END HEADERS ------------------------------
