#!/usr/bin/perl -T

#------------------------------------------------------------------------------
# This is amavisd-new.
# It is an interface between message transfer agent (MTA) and virus
# scanners and/or spam scanners, functioning as a mail content filter.
#
# 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,2005,2006  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>
#         Rainer Link <link@foo.fh-furtwangen.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::Lock
#  Amavis::Log
#  Amavis::Timing
#  Amavis::Util
#  Amavis::rfc2821_2822_Tools
#  Amavis::Lookup::RE
#  Amavis::Lookup::IP
#  Amavis::Lookup::Label
#  Amavis::Lookup
#  Amavis::Expand
#  Amavis::TempDir
#  Amavis::IO::Zlib
#  Amavis::In::Connection
#  Amavis::In::Message::PerRecip
#  Amavis::In::Message
#  Amavis::Out::EditHeader
#  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::OS_Fingerprint
#  Amavis::DB::SNMP
#  Amavis::DB
#  Amavis::Cache
#  Amavis::Lookup::SQLfield
#  Amavis::Lookup::SQL
#  Amavis::LDAP::Connection
#  Amavis::Lookup::LDAP
#  Amavis::Lookup::LDAPattr
#  Amavis::In::AMCL
#  Amavis::In::SMTP
#( Amavis::In::Courier )
#  Amavis::Out::SMTP
#  Amavis::Out::Pipe
#  Amavis::Out::BSMTP
#  Amavis::Out::Local
#  Amavis::Out::SQL::Connection
#  Amavis::Out::SQL::Log
#  Amavis::IO::SQL
#  Amavis::Out::SQL::Quarantine
#  Amavis::AV
#  Amavis::SpamControl
#  Amavis::SpamControl::SpamAssassin
#  Amavis::Unpackers
#------------------------------------------------------------------------------

no warnings 'uninitialized';

#
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'  if !/\.(pm|pl|al)\z/;
    s[::][/]g;
    eval { require $_ } or push(@missing, $m);
  }
  die "ERROR: MISSING $reason:\n" . join('', map { "  $_\n" } @missing)
    if $required && @missing;
  \@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
    Mail::Field Mail::Address Mail::Header Mail::Internet Compress::Zlib
    MIME::Base64 MIME::QuotedPrint MIME::Words
    MIME::Head MIME::Body MIME::Entity MIME::Parser MIME::Decoder
    MIME::Decoder::Base64 MIME::Decoder::Binary MIME::Decoder::QuotedPrint
    MIME::Decoder::NBit MIME::Decoder::UU MIME::Decoder::Gzip64
    Net::Cmd Net::SMTP Net::Server Net::Server::PreForkSimple
  ));
  # 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
    MIME::Decoder::BinHex
  ));
}

1;

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

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

# major contents_category constants
sub CC_CATCHALL()  { 0 }
sub CC_CLEAN ()    { 1 }
sub CC_TEMPFAIL () { 2 }
sub CC_OVERSIZED() { 3 }
sub CC_BADH  ()    { 4 }
sub CC_SPAM  ()    { 5 }
sub CC_UNCHECKED() { 6 }
sub CC_BANNED()    { 7 }
sub CC_VIRUS ()    { 8 }

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = (
    'dynamic_confvars' => [qw(
      $policy_bank_name $protocol @inet_acl
      $myhostname $syslog_ident $syslog_facility $syslog_priority
      $log_level $log_templ $log_recip_templ
      $forward_method $notify_method $os_fingerprint_method
      $propagate_dsn_if_possible $terminate_dsn_on_notify_success
      $amavis_auth_user $amavis_auth_pass $auth_reauthenticate_forwarded
      $auth_required_out $auth_required_inp $auth_required_release
      @auth_mech_avail $local_client_bind_address $smtpd_message_size_limit
      $localhost_name $smtpd_greeting_banner $smtpd_quit_banner
      $mailfrom_to_quarantine $warn_offsite $bypass_decode_parts @decoders
      @av_scanners @av_scanners_backup $first_infected_stops_scan
      $sa_spam_report_header $sa_spam_level_char $sa_mail_body_size_limit
      $undecipherable_subject_tag $localpart_is_case_sensitive
      $recipient_delimiter $replace_existing_extension
      $hdr_encoding $bdy_encoding $hdr_encoding_qb
      $insert_received_line $append_header_fields_to_bottom
      $allow_fixing_improper_header_folding
      $X_HEADER_TAG $X_HEADER_LINE $notify_xmailer_header
      $remove_existing_x_scanned_headers $remove_existing_spam_headers
      %sql_clause %local_delivery_aliases $banned_namepath_re
      $per_recip_whitelist_sender_lookup_tables
      $per_recip_blacklist_sender_lookup_tables

      @local_domains_maps @mynetworks_maps
      @newvirus_admin_maps @banned_filename_maps
      @spam_quarantine_bysender_to_maps
      @spam_tag_level_maps @spam_tag2_level_maps @spam_kill_level_maps
      @spam_dsn_cutoff_level_maps @spam_quarantine_cutoff_level_maps
      @spam_modifies_subj_maps @spam_subject_tag_maps @spam_subject_tag2_maps
      @whitelist_sender_maps @blacklist_sender_maps @score_sender_maps
      @message_size_limit_maps @debug_sender_maps
      @bypass_virus_checks_maps @bypass_spam_checks_maps
      @bypass_banned_checks_maps @bypass_header_checks_maps

      %final_destiny_by_ccat %lovers_maps_by_ccat %defang_by_ccat
      %quarantine_method_by_ccat   %quarantine_to_maps_by_ccat
      %notify_admin_templ_by_ccat  %notify_recips_templ_by_ccat
      %notify_sender_templ_by_ccat %warnsender_by_ccat
      %hdrfrom_notify_admin_by_ccat %mailfrom_notify_admin_by_ccat
      %hdrfrom_notify_recip_by_ccat %mailfrom_notify_recip_by_ccat
      %hdrfrom_notify_sender_by_ccat
      %admin_maps_by_ccat %dsn_bcc_by_ccat
      %warnrecip_maps_by_ccat %addr_extension_maps_by_ccat
    )],
    'confvars' => [qw(
      $myproduct_name $myversion_id $myversion_id_numeric $myversion_date
      $myversion
      $MYHOME $TEMPBASE $QUARANTINEDIR $quarantine_subdir_levels
      $daemonize $courierfilter_shutdown $pid_file $lock_file $db_home
      $enable_db $enable_global_cache
      $daemon_user $daemon_group $daemon_chroot_dir $path
      $DEBUG $DO_SYSLOG $LOGFILE
      $max_servers $max_requests $child_timeout $smtpd_timeout
      %current_policy_bank %policy_bank %interface_policy
      $unix_socketname $inet_socket_port $inet_socket_bind
      $relayhost_is_client $smtpd_recipient_limit
      $MAXLEVELS $MAXFILES
      $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR
      $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR
      @lookup_sql_dsn @storage_sql_dsn $timestamp_fmt_mysql
      $virus_check_negative_ttl $virus_check_positive_ttl
      $spam_check_negative_ttl $spam_check_positive_ttl
      $trim_trailing_space_in_lookup_result_fields
      $enable_ldap $default_ldap
      @keep_decoded_original_maps @map_full_type_to_short_type_maps
      @viruses_that_fake_sender_maps %banned_rules
      $file
    )],
    'sa' => [qw(
      $helpers_home $dspam
      $sa_local_tests_only $sa_auto_whitelist $sa_timeout $sa_debug
    )],
    'platform' => [qw(
      $can_truncate $unicode_aware $eol
      &D_REJECT &D_BOUNCE &D_DISCARD &D_PASS
      &CC_CATCHALL &CC_CLEAN &CC_TEMPFAIL &CC_OVERSIZED
      &CC_BADH &CC_SPAM &CC_UNCHECKED &CC_BANNED &CC_VIRUS
      %ccat_display_names
    )],
    # other variables settable by user in amavisd.conf,
    # but not directly accessible to the program
    'hidden_confvars' => [qw(
      $mydomain
    )],
    'legacy_dynamic_confvars' => [qw(
      $final_virus_destiny  $final_spam_destiny
      $final_banned_destiny $final_bad_header_destiny
      @virus_lovers_maps @spam_lovers_maps
      @banned_files_lovers_maps @bad_header_lovers_maps
      $dsn_bcc
      $mailfrom_notify_sender $mailfrom_notify_recip
      $mailfrom_notify_admin  $mailfrom_notify_spamadmin
      $hdrfrom_notify_sender  $hdrfrom_notify_recip
      $hdrfrom_notify_admin   $hdrfrom_notify_spamadmin
      $notify_virus_admin_templ  $notify_spam_admin_templ
      $notify_virus_recips_templ $notify_spam_recips_templ
      $notify_sender_templ $notify_virus_sender_templ $notify_spam_sender_templ
      $warnvirussender $warnspamsender $warnbannedsender $warnbadhsender
      $defang_virus $defang_banned $defang_spam
      $defang_bad_header $defang_undecipherable $defang_all
      $clean_quarantine_method $virus_quarantine_method $spam_quarantine_method
      $banned_files_quarantine_method $bad_header_quarantine_method
      @clean_quarantine_to_maps  @virus_quarantine_to_maps
      @banned_quarantine_to_maps @bad_header_quarantine_to_maps
      @spam_quarantine_to_maps @virus_admin_maps @banned_admin_maps
      @bad_header_admin_maps @spam_admin_maps
      @warnvirusrecip_maps @warnbannedrecip_maps @warnbadhrecip_maps
      @addr_extension_virus_maps  @addr_extension_spam_maps
      @addr_extension_banned_maps @addr_extension_bad_header_maps
    )],
    # legacy variables, predeclared for compatibility of 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 through @*_maps variables
    'legacy_confvars' => [qw(
      %local_domains @local_domains_acl $local_domains_re @mynetworks
      %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
      $newvirus_admin $virus_admin $banned_admin $bad_header_admin $spam_admin
      $warnvirusrecip $warnbannedrecip $warnbadhrecip
      $clean_quarantine_to $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
      $sa_tag_level_deflt $sa_tag2_level_deflt $sa_kill_level_deflt
      $sa_dsn_cutoff_level $sa_quarantine_cutoff_level
      $sa_spam_modifies_subj $sa_spam_subject_tag1 $sa_spam_subject_tag
      %whitelist_sender @whitelist_sender_acl $whitelist_sender_re
      %blacklist_sender @blacklist_sender_acl $blacklist_sender_re
      $addr_extension_virus $addr_extension_spam
      $addr_extension_banned $addr_extension_bad_header
      $sql_select_policy $sql_select_white_black_list
      $gets_addr_in_quoted_form @debug_sender_acl
      $arc $bzip2 $lzop $lha $unarj $gzip $uncompress $unfreeze
      $unrar $zoo $pax $cpio $ar $rpm2cpio $cabextract $ripole $tnef
      $gunzip $bunzip2 $unlzop $unstuff
      $SYSLOG_LEVEL
    )],
  );
  Exporter::export_tags qw(dynamic_confvars confvars sa platform
                      hidden_confvars legacy_dynamic_confvars legacy_confvars);
} # BEGIN

use POSIX ();
use Carp ();
use Errno qw(ENOENT EACCES);

use vars @EXPORT;

sub c($); sub cr($); sub ca($);  # prototypes
use subs qw(c cr ca);  # access subroutine to new-style config variables
BEGIN { push(@EXPORT,qw(c cr ca)) }

{ # initialize policy bank hash containing dynamic config settings
  for my $tag (@EXPORT_TAGS{'dynamic_confvars', 'legacy_dynamic_confvars'}) {
    for my $v (@$tag) {
      if ($v !~ /^([%\$\@])(.*)\z/) { die "Unsupported variable type: $v" }
      else {
        no strict 'refs'; my($type,$name) = ($1,$2);
        $current_policy_bank{$name} = $type eq '$' ? \${"Amavis::Conf::$name"}
                                    : $type eq '@' ? \@{"Amavis::Conf::$name"}
                                    : $type eq '%' ? \%{"Amavis::Conf::$name"}
                                    : undef;
      }
    }
  }
  $current_policy_bank{'policy_bank_name'} = '';  # builtin policy
  $current_policy_bank{'policy_bank_path'} = '';
  $policy_bank{''} = { %current_policy_bank };    # copy
}

# new-style access to dynamic config variables
# return a config variable value - usually a scalar;
# one level of indirection for scalars is allowed
sub c($) {
  my($name) = @_;
  if (!exists $current_policy_bank{$name}) {
    Carp::croak(sprintf('No entry "%s" in policy bank "%s"',
                        $name, $current_policy_bank{'policy_bank_name'}));
  }
  my($var) = $current_policy_bank{$name}; my($r) = ref($var);
  !$r ? $var : $r eq 'SCALAR' ? $$var
    : $r eq 'ARRAY' ? @$var : $r eq 'HASH' ? %$var : $var;
}

# return a ref to a config variable value, or undef if var is undefined
sub cr($) {
  my($name) = @_;
  if (!exists $current_policy_bank{$name}) {
    Carp::croak(sprintf('No entry "%s" in policy bank "%s"',
                        $name, $current_policy_bank{'policy_bank_name'}));
  }
  my($var) = $current_policy_bank{$name};
  !defined($var) ? undef : !ref($var) ? \$var : $var;
}

# return a ref to a config variable value (which is supposed to be an array),
# converting undef to an empty array, and a scalar to a one-element array
# if necessary
sub ca($) {
  my($name) = @_;
  if (!exists $current_policy_bank{$name}) {
    Carp::croak(sprintf('No entry "%s" in policy bank "%s"',
                        $name, $current_policy_bank{'policy_bank_name'}));
  }
  my($var) = $current_policy_bank{$name};
  !defined($var) ? [] : !ref($var) ? [$var] : $var;
}

$myproduct_name = 'amavisd-new';
$myversion_id = '2.4.0-rc8'; $myversion_date = '20060331';

$myversion = "$myproduct_name-$myversion_id ($myversion_date)";
$myversion_id_numeric =  # x.yyyzzz, allows numerical comparision, like Perl $]
  sprintf("%8.6f", $1 + ($2 + $3/1000)/1000)
  if $myversion_id =~ /^(\d+)(?:\.(\d*)(?:\.(\d*))?)?(.*)$/;

$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

# timeout for our processing:
$child_timeout = 8*60; # abort child if it does not complete a task in n sec

# timeout for waiting on client input:
$smtpd_timeout = 8*60; # disconnect session if client is idle for too long;
#  $smtpd_timeout should be higher than Postfix setting max_idle (default 100s)

# Assume STDIN is a courierfilter pipe and shutdown when it becomes readable
$courierfilter_shutdown = 0;

# 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_ident = 'amavis';
$SYSLOG_LEVEL = 'mail.debug';

$enable_db = 0;           # load optional modules Amavis::DB & Amavis::DB::SNMP
$enable_global_cache = 0; # enable use of bdb-based Amavis::Cache

# 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.
#
#@storage_sql_dsn =
#@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 LEFT JOIN policy ON users.policy_id=policy.id'.
  ' WHERE 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).
# Only the first occurrence of '?' will be replaced by users.id, subsequent
# occurrences of '?' will see empty string as an argument. There can be zero
# or more occurrences of %k, lookup keys will be multiplied accordingly.
# Up until version 2.2.0 the '?' had to be placed before the '%k';
# starting with 2.2.1 this restriction is lifted.
$sql_select_white_black_list =
  'SELECT wb FROM wblist LEFT JOIN mailaddr ON wblist.sid=mailaddr.id'.
  ' WHERE (wblist.rid=?) AND (mailaddr.email IN (%k))'.
  ' ORDER BY mailaddr.priority DESC';

%sql_clause = (
  'sel_policy' => \$sql_select_policy,
  'sel_wblist' => \$sql_select_white_black_list,
  'sel_adr' =>
    'SELECT id FROM maddr WHERE email=?',
  'ins_adr' =>
    'INSERT INTO maddr (email, domain) VALUES (?,?)',
  'ins_msg' =>
    'INSERT INTO msgs (mail_id, secret_id, am_id, time_num, time_iso, sid,'.
    ' policy, client_addr, size, host) VALUES (?,?,?,?,?,?,?,?,?,?)',
  'upd_msg' =>
    'UPDATE msgs SET content=?, quar_type=?, quar_loc=?, dsn_sent=?,'.
    ' spam_level=?, message_id=?, from_addr=?, subject=? WHERE mail_id=?',
# 'ins_rcp' =>
#   'INSERT INTO msgrcpt (mail_id, rid, time_num,'.
#   ' ds, rs, bl, wl, bspam_level, smtp_resp) VALUES (?,?,?,?,?,?,?,?,?)',
  'ins_rcp' =>
    'INSERT INTO msgrcpt (mail_id, rid,'.
    ' ds, rs, bl, wl, bspam_level, smtp_resp) VALUES (?,?,?,?,?,?,?,?)',
# 'ins_quar' =>
#   'INSERT INTO quarantine (mail_id, chunk_ind, time_num, mail_text)'.
#   ' VALUES (?,?,?,?)',
  'ins_quar' =>
    'INSERT INTO quarantine (mail_id, chunk_ind, mail_text)'.
    ' VALUES (?,?,?)',
  'sel_quar' =>
    'SELECT mail_text FROM quarantine WHERE mail_id=? ORDER BY chunk_ind',
);

#
# 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
@mynetworks = qw( 127.0.0.0/8 [::1] [FE80::]/10 [FEC0::]/10
                  10.0.0.0/8 172.16.0.0/12 192.168.0.0/16 );

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

$clean_quarantine_method = undef; # 'local:clean-%m';
$virus_quarantine_method          = 'local:virus-%m';
$spam_quarantine_method           = 'local:spam-%m.gz';
$banned_files_quarantine_method   = 'local:banned-%m';
$bad_header_quarantine_method     = 'local:badh-%m';

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

# fix improper folded header fields made up entirely of whitespace
# by removing all-whitespace lines (desirable, but may break DomainKeys
# validation of messages with illegal header)
$allow_fixing_improper_header_folding = 1;

# encoding (charset in MIME 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 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 = (POSIX::uname)[1];  # should be a FQDN !

$smtpd_greeting_banner = '${helo-name} ${protocol} ${product} service ready';
$smtpd_quit_banner = '${helo-name} ${product} 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';

$propagate_dsn_if_possible = 1; # pass on DSN if MTA announces this capability;
          # useful to be turned off globally but enabled in MYNETS policy bank
          # to hide internal mail routing from outsiders
$terminate_dsn_on_notify_success = 0;  # when true => handle DSN NOTIFY=SUCCESS
          # locally, do not let NOTIFY=SUCCESS propagate to MTA (but allow
          # other DSN options like NOTIFY=NEVER/FAILURE/DELAY, ORCPT, RET, and
          # ENVID to propagate if possible)

# @auth_mech_avail = ('PLAIN','LOGIN');   # empty list disables incoming AUTH
#$auth_required_inp = 1;    # incoming SMTP authentication required by amavisd?
#$auth_required_out = 1;    # SMTP authentication required by MTA
$auth_required_release = 1; # secret_id is required for a quarantine release

# SMTP AUTH username and password for notification submissions
# (and reauthentication of forwarded mail if requested)
#$amavis_auth_user = undef;  # perhaps: 'amavisd'
#$amavis_auth_pass = undef;
#$auth_reauthenticate_forwarded = undef;  # supply our own credentials also
                                          # for forwarded (passed) mail

# 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
$clean_quarantine_to  = 'clean-quarantine';   # %local_delivery_aliases mapped
$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

$undecipherable_subject_tag = '***UNCHECKED*** ';

# 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
$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 = undef; # insert X-Spam-Report header field?
$sa_local_tests_only = 0;
$sa_debug = undef;
$sa_timeout = 30;           # timeout in seconds for a call to SpamAssassin

$file = 'file';  # path to the file(1) utility for classifying contents

# provide names for content categories - to be used only for logging,
# SNMP counter names and display purposes
%ccat_display_names = (
  CC_CATCHALL,  'CatchAll',  # last resort, should not normally appear
  CC_CLEAN,     'Clean',
  CC_TEMPFAIL,  'TempFail',
  CC_OVERSIZED, 'Oversized',
  CC_BADH,      'BadHdr',
  CC_BADH.',1', 'BadHdrMime',
  CC_BADH.',2', 'BadHdr8bit',
  CC_BADH.',3', 'BadHdrChar',
  CC_BADH.',4', 'BadHdrSpace',
  CC_BADH.',5', 'BadHdrLong',
  CC_BADH.',6', 'BadHdrSyntax',
  CC_SPAM,      'Spam',
  CC_UNCHECKED, 'Unchecked',
  CC_BANNED,    'Banned',
  CC_VIRUS,     'Virus',
);

$MIN_EXPANSION_FACTOR =   5;  # times original mail size
$MAX_EXPANSION_FACTOR = 500;  # times original mail size

# 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, but 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.

# 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).
#
# 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), or for spam exceeding
#            spam_dsn_cutoff_level
#
# 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, and is in position to suppress DSN if considered
#            unsuitable). Best suited for Postfix and other dual-MTA setups.

$final_virus_destiny      = D_DISCARD; # 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_BOUNCE;  # 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_maps, (or @spam_lovers_maps), 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 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 do not get address extension appended).
#
# 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  = 'virus';  # for example
# $addr_extension_spam   = 'spam';
# $addr_extension_banned = 'banned';
# $addr_extension_bad_header = 'badh';

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

# Trim trailing whitespace from SQL fields, LDAP attribute values
# and hash righthand-sides as read by read_hash(); disabled by default;
# turn it on for compatibility with pre-2.4.0 versions!
$trim_trailing_space_in_lookup_result_fields = 0;

# first match wins, more specific entries should precede general ones!
# the result may be a string or a ref to a list of strings;
# see also sub decompose_part()
$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/^GNU message catalog\b/         => 'mo'],
  [qr/^PGP encrypted data\b/          => 'pgp'],
  [qr/^PGP armored data( signed)? message\b/ => ['pgp','pgp.asc'] ],
  [qr/^PGP armored\b/                 =>        ['pgp','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/             =>['image','jpg'] ],
  [qr/^GIF image data\b/              =>['image','gif'] ],
  [qr/^PNG image data\b/              =>['image','png'] ],
  [qr/^TIFF image data\b/             =>['image','tif'] ],
  [qr/^PCX\b.*\bimage data\b/         =>['image','pcx'] ],
  [qr/^PC bitmap data\b/              =>['image','bmp'] ],

  [qr/^MP2\b/                         =>['audio','mpa','mp2'] ],
  [qr/^MP3\b/                         =>['audio','mpa','mp3'] ],
  [qr/^MPEG video stream data\b/      =>['movie','mpv'] ],
  [qr/^MPEG system stream data\b/     =>['movie','mpg'] ],
  [qr/^MPEG\b/                        =>['movie','mpg'] ],
  [qr/^Microsoft ASF\b/               =>['movie','wmv'] ],
  [qr/^RIFF\b.*\bAVI\b/               =>['movie','avi'] ],
  [qr/^RIFF\b.*\bWAVE audio\b/        =>['audio','wav'] ],

  [qr/^Macromedia Flash data\b/       => 'swf'],
  [qr/^HTML document text\b/          => 'html'],
  [qr/^XML document text\b/           => 'xml'],
  [qr/^exported SGML document text\b/ => 'sgml'],
  [qr/^PostScript document text\b/    => 'ps'],
  [qr/^PDF document\b/                => 'pdf'],
  [qr/^Rich Text Format data\b/       => 'rtf'],
  [qr/^Microsoft Office Document\b/i  => 'doc'],  # OLE2: doc, ppt, xls, ...
  [qr/^ms-windows meta(file|font)\b/i => 'wmf'],
  [qr/^LaTeX\b.*\bdocument text\b/    => 'lat'],
  [qr/^TeX DVI file\b/                => 'dvi'],
  [qr/\bdocument text\b/              => 'txt'],
  [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/^bzip compressed\b/             => 'bz'],
  [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'],  # (also known as .lzh)
  [qr/^ARC archive\b/i                => 'arc'],
  [qr/^ARJ archive\b/i                => 'arj'],
  [qr/^Zoo archive\b/i                => 'zoo'],
  [qr/^(\S+\s+)?tar archive\b/i       => 'tar'],
  [qr/^(\S+\s+)?cpio archive\b/i      => 'cpio'],
  [qr/^StuffIt Archive\b/i            => 'sit'],
  [qr/^Debian binary package\b/i      => 'deb'],  # standard Unix archive (ar)
  [qr/^current ar archive\b/i         => 'a'],    # standard Unix archive (ar)
  [qr/^RPM\b/                         => 'rpm'],
  [qr/^(Transport Neutral Encapsulation Format|TNEF)\b/i => 'tnef'],
  [qr/^Microsoft Cabinet (file|archive)\b/i => 'cab'],
  [qr/^InstallShield Cabinet file\b/  => 'installshield'],

  [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','exe-ms'] ],
  [qr/^MS Windows\b.*\bexecutable\b/  => ['exe','exe-ms'] ],
  [qr/^PA-RISC.*\bexecutable\b/       => ['exe','exe-unix'] ],
  [qr/^ELF .*\bexecutable\b/          => ['exe','exe-unix'] ],
  [qr/^COFF format .*\bexecutable\b/  => ['exe','exe-unix'] ],
  [qr/^executable \(RISC System\b/    => ['exe','exe-unix'] ],
  [qr/^VMS\b.*\bexecutable\b/         => ['exe','exe-vms'] ],

  [qr/\bexecutable\b/i                => 'exe'],
  [qr/^MS Windows\b.*\bDLL\b/         => 'dll'],
  [qr/\bshared object, /i             => 'so'],
  [qr/\brelocatable, /i               => 'o'],
  [qr/\btext\b/i                      => 'asc'],
  [qr/^/                              => 'dat'],  # catchall

);

# 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
# VMS VAX executable

# prototypes
sub Amavis::Unpackers::do_mime_decode($$);
sub Amavis::Unpackers::do_ascii($$);
sub Amavis::Unpackers::do_uncompress($$$);
sub Amavis::Unpackers::do_gunzip($$);
sub Amavis::Unpackers::do_pax_cpio($$$);
sub Amavis::Unpackers::do_tar($$);
sub Amavis::Unpackers::do_ar($$$);
sub Amavis::Unpackers::do_unzip($$;$$);
sub Amavis::Unpackers::do_unrar($$$;$);
sub Amavis::Unpackers::do_unarj($$$;$);
sub Amavis::Unpackers::do_arc($$$);
sub Amavis::Unpackers::do_zoo($$$);
sub Amavis::Unpackers::do_lha($$$;$);
sub Amavis::Unpackers::do_ole($$$);
sub Amavis::Unpackers::do_cabextract($$$);
sub Amavis::Unpackers::do_tnef($$);
sub Amavis::Unpackers::do_tnef_ext($$$);
sub Amavis::Unpackers::do_unstuff($$$);
sub Amavis::Unpackers::do_executable($$@);

no warnings qw(once);
# Define alias names or shortcuts 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;
*read_array      = \&Amavis::Util::read_array;
*dump_hash       = \&Amavis::Util::dump_hash;
*dump_array      = \&Amavis::Util::dump_array;
*ask_daemon      = \&Amavis::AV::ask_daemon;
*sophos_savi     = \&Amavis::AV::ask_sophos_savi;
*ask_clamav      = \&Amavis::AV::ask_clamav;
*do_mime_decode  = \&Amavis::Unpackers::do_mime_decode;
*do_ascii        = \&Amavis::Unpackers::do_ascii;
*do_uncompress   = \&Amavis::Unpackers::do_uncompress;
*do_gunzip       = \&Amavis::Unpackers::do_gunzip;
*do_pax_cpio     = \&Amavis::Unpackers::do_pax_cpio;
*do_tar          = \&Amavis::Unpackers::do_tar;
*do_ar           = \&Amavis::Unpackers::do_ar;
*do_unzip        = \&Amavis::Unpackers::do_unzip;
*do_unrar        = \&Amavis::Unpackers::do_unrar;
*do_unarj        = \&Amavis::Unpackers::do_unarj;
*do_arc          = \&Amavis::Unpackers::do_arc;
*do_zoo          = \&Amavis::Unpackers::do_zoo;
*do_lha          = \&Amavis::Unpackers::do_lha;
*do_ole          = \&Amavis::Unpackers::do_ole;
*do_cabextract   = \&Amavis::Unpackers::do_cabextract;
*do_tnef_ext     = \&Amavis::Unpackers::do_tnef_ext;
*do_tnef         = \&Amavis::Unpackers::do_tnef;
*do_unstuff      = \&Amavis::Unpackers::do_unstuff;
*do_executable   = \&Amavis::Unpackers::do_executable;
sub new_RE { Amavis::Lookup::RE->new(@_) }

# initialize the @decoders list
sub init_decoders() {
  # A list of pairs or n-tuples: [short-type, code_ref, optional-args...].
  # Maps short types to a decoding routine, the first match wins.
  # Arguments beyond the first two can be program path string (or a listref of
  # paths to be searched) or a reference to a variable containing such a path,
  # which allows for lazy evaluation, making possible to assign values to
  # legacy configuration variables even after the assignment to @decoders.
  @decoders = (
    ['mail', \&Amavis::Unpackers::do_mime_decode],
    ['asc',  \&Amavis::Unpackers::do_ascii],
    ['uue',  \&Amavis::Unpackers::do_ascii],
    ['hqx',  \&Amavis::Unpackers::do_ascii],
    ['ync',  \&Amavis::Unpackers::do_ascii],
    ['F',    \&Amavis::Unpackers::do_uncompress, \$unfreeze],
    ['Z',    \&Amavis::Unpackers::do_uncompress, \$uncompress],
    ['gz',   \&Amavis::Unpackers::do_gunzip],
    ['gz',   \&Amavis::Unpackers::do_uncompress, \$gunzip],
    ['bz2',  \&Amavis::Unpackers::do_uncompress, \$bunzip2],
    ['lzo',  \&Amavis::Unpackers::do_uncompress, \$unlzop],
    ['rpm',  \&Amavis::Unpackers::do_uncompress, \$rpm2cpio],
    ['cpio', \&Amavis::Unpackers::do_pax_cpio,   \$pax],
    ['cpio', \&Amavis::Unpackers::do_pax_cpio,   \$cpio],
    ['tar',  \&Amavis::Unpackers::do_pax_cpio,   \$pax],
    ['tar',  \&Amavis::Unpackers::do_pax_cpio,   \$cpio],
    ['tar',  \&Amavis::Unpackers::do_tar],
    ['deb',  \&Amavis::Unpackers::do_ar, \$ar],
#   ['a',    \&Amavis::Unpackers::do_ar, \$ar], #unpacking .a seems an overkill
    ['zip',  \&Amavis::Unpackers::do_unzip],
    ['rar',  \&Amavis::Unpackers::do_unrar,      \$unrar],
    ['arj',  \&Amavis::Unpackers::do_unarj,      \$unarj],
    ['arc',  \&Amavis::Unpackers::do_arc,        \$arc],
    ['zoo',  \&Amavis::Unpackers::do_zoo,        \$zoo],
    ['lha',  \&Amavis::Unpackers::do_lha,        \$lha],
    ['doc',  \&Amavis::Unpackers::do_ole,        \$ripole],
    ['cab',  \&Amavis::Unpackers::do_cabextract, \$cabextract],
    ['tnef', \&Amavis::Unpackers::do_tnef_ext,   \$tnef],
    ['tnef', \&Amavis::Unpackers::do_tnef],
#   ['sit',  \&Amavis::Unpackers::do_unstuff,    \$unstuff],
    ['exe',  \&Amavis::Unpackers::do_executable, \$unrar,\$lha,\$unarj],
  );
}

sub build_default_maps() {
  @local_domains_maps = (
    \%local_domains, \@local_domains_acl, \$local_domains_re);
  @mynetworks_maps = (\@mynetworks);
  @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);
  @warnvirusrecip_maps  = (\$warnvirusrecip);
  @warnbannedrecip_maps = (\$warnbannedrecip);
  @warnbadhrecip_maps   = (\$warnbadhrecip);
  @newvirus_admin_maps  = (\$newvirus_admin);
  @virus_admin_maps     = (\%virus_admin, \$virus_admin);
  @banned_admin_maps    = (\$banned_admin, \%virus_admin, \$virus_admin);
  @bad_header_admin_maps= (\$bad_header_admin);
  @spam_admin_maps      = (\%spam_admin, \$spam_admin);
  @clean_quarantine_to_maps = (\$clean_quarantine_to);
  @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]} );
# @banned_filename_maps = ( {'.' => 'DEFAULT'} );#names mapped by %banned_rules
  @banned_filename_maps = ( 'DEFAULT' );  # same as previous, but shorter
  @viruses_that_fake_sender_maps = (\$viruses_that_fake_sender_re, 1);
  @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_dsn_cutoff_level_maps = (\$sa_dsn_cutoff_level);
  @spam_quarantine_cutoff_level_maps = (\$sa_quarantine_cutoff_level);
  @spam_modifies_subj_maps = (\$sa_spam_modifies_subj);
  @spam_subject_tag_maps  = (\$sa_spam_subject_tag1); # note: inconsistent name
  @spam_subject_tag2_maps = (\$sa_spam_subject_tag);  # note: inconsistent name
  @whitelist_sender_maps = (
    \%whitelist_sender, \@whitelist_sender_acl, \$whitelist_sender_re);
  @blacklist_sender_maps = (
    \%blacklist_sender, \@blacklist_sender_acl, \$blacklist_sender_re);
  @score_sender_maps = ();  # new variable, no backwards compatibility needed
  @message_size_limit_maps = ();  # new variable
  @addr_extension_virus_maps  = (\$addr_extension_virus);
  @addr_extension_spam_maps   = (\$addr_extension_spam);
  @addr_extension_banned_maps = (\$addr_extension_banned);
  @addr_extension_bad_header_maps = (\$addr_extension_bad_header);
  @debug_sender_maps = (\@debug_sender_acl);

  # build backwards-compatible settings hashes
  %final_destiny_by_ccat = (
    CC_VIRUS,      sub { c('final_virus_destiny') },
    CC_BANNED,     sub { c('final_banned_destiny') },
    CC_SPAM,       sub { c('final_spam_destiny') },
    CC_BADH,       sub { c('final_bad_header_destiny') },
    CC_OVERSIZED,  D_BOUNCE,
    CC_CATCHALL,   D_PASS,
  );
  %lovers_maps_by_ccat = (
    CC_VIRUS,      sub { ca('virus_lovers_maps') },
    CC_BANNED,     sub { ca('banned_files_lovers_maps') },
    CC_SPAM,       sub { ca('spam_lovers_maps') },
    CC_BADH,       sub { ca('bad_header_lovers_maps') },
  );
  %defang_by_ccat = (
    CC_VIRUS,      sub { c('defang_virus')          || c('defang_all') },
    CC_BANNED,     sub { c('defang_banned')         || c('defang_all') },
    CC_SPAM,       sub { c('defang_spam')           || c('defang_all') },
    CC_BADH,       sub { c('defang_bad_header')     || c('defang_all') },
    CC_UNCHECKED,  sub { c('defang_undecipherable') || c('defang_all') },
    CC_CATCHALL,   sub { c('defang_all') },
  );
  %quarantine_method_by_ccat = (
    CC_VIRUS,      sub { c('virus_quarantine_method') },
    CC_BANNED,     sub { c('banned_files_quarantine_method') },
    CC_SPAM,       sub { c('spam_quarantine_method') },
    CC_BADH,       sub { c('bad_header_quarantine_method') },
    CC_CLEAN,      sub { c('clean_quarantine_method') },
  );
  %quarantine_to_maps_by_ccat = (
    CC_VIRUS,      sub { ca('virus_quarantine_to_maps') },
    CC_BANNED,     sub { ca('banned_quarantine_to_maps') },
    CC_SPAM,       sub { ca('spam_quarantine_to_maps') },
    CC_BADH,       sub { ca('bad_header_quarantine_to_maps') },
    CC_CLEAN,      sub { ca('clean_quarantine_to_maps') },
  );
  %admin_maps_by_ccat = (
    CC_VIRUS,      sub { ca('virus_admin_maps') },
    CC_BANNED,     sub { ca('banned_admin_maps') },
    CC_SPAM,       sub { ca('spam_admin_maps') },
    CC_BADH,       sub { ca('bad_header_admin_maps') },
  );
  %dsn_bcc_by_ccat = (
    CC_CATCHALL,   sub { c('dsn_bcc') },
  );
  %mailfrom_notify_admin_by_ccat = (
    CC_SPAM,       sub { c('mailfrom_notify_spamadmin') },
    CC_CATCHALL,   sub { c('mailfrom_notify_admin') },
  );
  %hdrfrom_notify_admin_by_ccat = (
    CC_SPAM,       sub { c('hdrfrom_notify_spamadmin') },
    CC_CATCHALL,   sub { c('hdrfrom_notify_admin') },
  );
  %mailfrom_notify_recip_by_ccat = (
    CC_CATCHALL,   sub { c('mailfrom_notify_recip') },
  );
  %hdrfrom_notify_recip_by_ccat = (
    CC_CATCHALL,   sub { c('hdrfrom_notify_recip') },
  );
  %hdrfrom_notify_sender_by_ccat = (
    CC_CATCHALL,   sub { c('hdrfrom_notify_sender') },
  );
  %notify_admin_templ_by_ccat = (
    CC_SPAM,       sub { cr('notify_spam_admin_templ') },
    CC_CATCHALL,   sub { cr('notify_virus_admin_templ') },
  );
  %notify_recips_templ_by_ccat = (
    CC_SPAM,       sub { cr('notify_spam_recips_templ') },
    CC_CATCHALL,   sub { cr('notify_virus_recips_templ') },
  );
  %notify_sender_templ_by_ccat = (
    CC_VIRUS,      sub { cr('notify_virus_sender_templ') },
    CC_BANNED,     sub { cr('notify_virus_sender_templ') }, # historical reason
    CC_SPAM,       sub { cr('notify_spam_sender_templ') },
    CC_CATCHALL,   sub { cr('notify_sender_templ') },
  );
  %warnsender_by_ccat = (
    CC_VIRUS,      sub { c('warnvirussender') },
    CC_BANNED,     sub { c('warnbannedsender') },
    CC_SPAM,       sub { c('warnspamsender') },
    CC_BADH,       sub { c('warnbadhsender') },
  );
  %warnrecip_maps_by_ccat = (
    CC_VIRUS,      sub { ca('warnvirusrecip_maps') },
    CC_BANNED,     sub { ca('warnbannedrecip_maps') },
    CC_BADH,       sub { ca('warnbadhrecip_maps') },
  );
  %addr_extension_maps_by_ccat = (
    CC_VIRUS,      sub { ca('addr_extension_virus_maps') },
    CC_BANNED,     sub { ca('addr_extension_banned_maps') },
    CC_SPAM,       sub { ca('addr_extension_spam_maps') },
    CC_BADH,       sub { ca('addr_extension_bad_header_maps') },
  );
}

# prepend a lookup table label object for logging purposes
sub label_default_maps() {
  for my $varname (qw(
    @local_domains_maps @mynetworks_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
    @warnvirusrecip_maps @warnbannedrecip_maps @warnbadhrecip_maps
    @newvirus_admin_maps @virus_admin_maps
    @banned_admin_maps @bad_header_admin_maps @spam_admin_maps
    @clean_quarantine_to_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_dsn_cutoff_level_maps @spam_quarantine_cutoff_level_maps
    @spam_modifies_subj_maps @spam_subject_tag_maps @spam_subject_tag2_maps
    @whitelist_sender_maps @blacklist_sender_maps @score_sender_maps
    @message_size_limit_maps
    @addr_extension_virus_maps @addr_extension_spam_maps
    @addr_extension_banned_maps @addr_extension_bad_header_maps
    @debug_sender_maps ))
  {
    my($g) = $varname; $g =~ s{\@}{Amavis::Conf::};  # qualified variable name
    my($label) = $varname; $label=~s/^\@//; $label=~s/_maps$//;
    { no strict 'refs';
      unshift(@$g,  # NOTE: a symbolic reference
              Amavis::Lookup::Label->new($label))  if @$g;  # no label if empty
    }
  }
}

# read and evaluate configuration files (one or more)
sub read_config(@) {
  my(@config_files) = @_;
  for my $config_file (@config_files) {
    my($msg);
    my($errn) = stat($config_file) ? 0 : 0+$!;
    if    ($errn == ENOENT) { $msg = "does not exist" }
    elsif ($errn)      { $msg = "is inaccessible: $!" }
    elsif (-d _)       { $msg = "is a directory" }
    elsif (!-f _)      { $msg = "is not a regular file" }
    elsif ($> && -o _) { $msg = "is owned by EUID $>, should be owned by root"}
    elsif ($> && -w _) { $msg = "is writable by EUID $>, EGID $)" }
    if (defined $msg)  { die "Config file \"$config_file\" $msg," }
    $! = 0;
    if (defined(do $config_file)) {}
    elsif ($@ ne '') { die "Error in config file \"$config_file\": $@" }
    elsif ($! != 0)  { die "Error reading config file \"$config_file\": $!" }
  }
  $daemon_chroot_dir = ''
    if !defined $daemon_chroot_dir || $daemon_chroot_dir eq '/';
  # provide some sensible defaults for essential settings (post-defaults)
  $TEMPBASE     = $MYHOME                   if !defined $TEMPBASE;
  $helpers_home = $MYHOME                   if !defined $helpers_home;
  $db_home      = "$MYHOME/db"              if !defined $db_home;
  $lock_file    = "$MYHOME/amavisd.lock"    if !defined $lock_file;
  $pid_file     = "$MYHOME/amavisd.pid"     if !defined $pid_file;
  if ($SYSLOG_LEVEL =~ /^\s*([a-z0-9]+)\.([a-z0-9]+)\s*\z/i) {  # compatibiliy
    $syslog_facility = $1  if $syslog_facility eq '';
    $syslog_priority = $2  if $syslog_priority eq '';
  }
  $X_HEADER_TAG = 'X-Virus-Scanned'               if !defined $X_HEADER_TAG;
  $X_HEADER_LINE= "$myproduct_name at $mydomain"  if !defined $X_HEADER_LINE;

  $gunzip  = "$gzip -d"   if !defined $gunzip  && $gzip  ne '';
  $bunzip2 = "$bzip2 -d"  if !defined $bunzip2 && $bzip2 ne '';
  $unlzop  = "$lzop -d"   if !defined $unlzop  && $lzop  ne '';

  # substring ${myhostname} will be expanded later, just before use
  my($pname) = '"Content-filter at ${myhostname}"';
  $hdrfrom_notify_sender = "$pname <postmaster\@\${myhostname}>"
    if !defined $hdrfrom_notify_sender;
  $hdrfrom_notify_recip = $mailfrom_notify_recip ne ''
    ? "$pname <$mailfrom_notify_recip>"
    : $hdrfrom_notify_sender  if !defined $hdrfrom_notify_recip;
  $hdrfrom_notify_admin = $mailfrom_notify_admin ne ''
    ? "$pname <$mailfrom_notify_admin>"
    : $hdrfrom_notify_sender  if !defined $hdrfrom_notify_admin;
  $hdrfrom_notify_spamadmin = $mailfrom_notify_spamadmin ne ''
    ? "$pname <$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
      $_ = c('forward_method') eq '' ? D_REJECT : D_BOUNCE;
    }
  }
  if ($final_virus_destiny == D_DISCARD && c('warnvirussender') )
    { $final_virus_destiny = D_BOUNCE }
  if ($final_spam_destiny == D_DISCARD && c('warnspamsender') )
    { $final_spam_destiny = D_BOUNCE }
  if ($final_banned_destiny == D_DISCARD && c('warnbannedsender') )
    { $final_banned_destiny = D_BOUNCE }
  if ($final_bad_header_destiny == D_DISCARD && c('warnbadhsender') )
    { $final_bad_header_destiny = D_BOUNCE }
  if (!%banned_rules) {
    # an associative array mapping a rule name
    # to a single 'banned names/types' lookup table
    %banned_rules = ('DEFAULT'=>$banned_filename_re);  # backwards compatibile
  }
}

1;

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

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
  @EXPORT = qw(&lock &unlock);
}
use Fcntl qw(LOCK_SH LOCK_EX LOCK_UN);

use subs @EXPORT;

sub lock($) {
  my($file_handle) = @_;
  flock($file_handle, LOCK_EX) or die "Can't lock $file_handle: $!";
  # NOTE: a lock is on a file, not on a file handle
}

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

1;

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

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

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

BEGIN {
  import Amavis::Conf qw(:platform c cr ca $myversion $daemon_user);
  import Amavis::Lock;
}

use vars qw($loghandle);  # log file handle
use vars qw($myname);     # program name ($0)
use vars qw($log_to_stderr $do_syslog $logfile);
use vars qw($current_syslog_ident $current_syslog_facility);
use vars qw(%syslog_prio_name_to_num);  # maps syslog priority names to numbers

sub init($$$) {
  ($log_to_stderr, $do_syslog, $logfile) = @_;
  # initialize mapping of syslog priority names to numbers
  for my $pn qw(DEBUG INFO NOTICE WARNING ERR CRIT ALERT EMERG) {
    my($prio) = eval("LOG_$pn");
    $syslog_prio_name_to_num{$pn} = $prio =~ /^\d+\z/ ? $prio : LOG_WARNING;
  }
  open_log();
  if (!$do_syslog && $logfile eq '')
    { print STDERR "Logging to STDERR (no \$LOGFILE and no \$DO_SYSLOG)\n" }
  $myname = $0;
  my($msg) = "starting.  $myname at " . c('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(0, undef, $msg);
}

sub open_log() {
  # don't bother to skip opening the log even if $log_to_stderr (debug) is true
  if ($do_syslog) {
    my($id) = c('syslog_ident'); my($fac) = c('syslog_facility');
    my($syslog_facility_num) = eval("LOG_\U$fac");
    $syslog_facility_num = LOG_DAEMON   if $syslog_facility_num !~ /^\d+\z/;
    openlog($id, LOG_PID | LOG_NDELAY, $syslog_facility_num);
    $current_syslog_ident = $id; $current_syslog_facility = $fac;
  } elsif ($logfile ne '') {
    $loghandle = IO::File->new($logfile,'>>')
      or die "Failed to open log file $logfile: $!";
    $loghandle->autoflush(1);
    if ($> == 0) {
      my($uid) = $daemon_user=~/^(\d+)$/ ? $1 : (getpwnam($daemon_user))[2];
      if ($uid) {
        chown($uid,-1,$logfile)
          or die "Can't chown logfile $logfile to $uid: $!";
      }
    }
  }
}

sub close_log() {
  if ($do_syslog) {
    closelog();
    $current_syslog_ident = $current_syslog_facility = undef;
  } elsif (defined($loghandle) && $logfile ne '') {
    $loghandle->close or die "Error closing log file $logfile: $!";
    $loghandle = undef;
  }
}

# Log either to syslog or to a file
sub write_log($$$;@) {
  my($level,$am_id,$errmsg,@args) = @_;
  $am_id = !defined $am_id ? '' : "($am_id) ";
  # treat $errmsg as sprintf format string if additional arguments provided
  if (@args && $errmsg=~/%/) { $errmsg = sprintf($errmsg,@args) }
  $errmsg = Amavis::Util::sanitize_str($errmsg);
# my($old_locale) = POSIX::setlocale(LC_TIME,"C");  # English dates required!
# if (length($errmsg) > 2000) {  # crop at some arbitrary limit (< LINE_MAX)
#   $errmsg = substr($errmsg,0,2000) . "...";
# }
  if ($do_syslog && !$log_to_stderr) {
    # never go below this priority level
    my($prio) = $syslog_prio_name_to_num{uc(c('syslog_priority'))};
    if    ($level <= -3) { $prio = LOG_CRIT    if $prio > LOG_CRIT    }
    elsif ($level <= -2) { $prio = LOG_ERR     if $prio > LOG_ERR     }
    elsif ($level <= -1) { $prio = LOG_WARNING if $prio > LOG_WARNING }
    elsif ($level <=  0) { $prio = LOG_NOTICE  if $prio > LOG_NOTICE  }
    elsif ($level <=  2) { $prio = LOG_INFO    if $prio > LOG_INFO    }
    else                 { $prio = LOG_DEBUG   if $prio > LOG_DEBUG   }
    my($alert_mark) = $level < -1 ? '(!!) ' : $level < 0 ? '(!) ' : '';
    my($pre) = $alert_mark;
    my($logline_size) = 980;  # less than  (1023 - prefix)
    while (length($am_id)+length($pre)+length($errmsg) > $logline_size) {
      my($avail) = $logline_size - length($am_id . $pre . "...");
      syslog($prio, "%s", $am_id . $pre . substr($errmsg,0,$avail) . "...");
      $pre = $alert_mark . "...";  $errmsg = substr($errmsg, $avail);
    }
    if (c('syslog_ident') ne $current_syslog_ident ||
        c('syslog_facility') ne $current_syslog_facility) {
      close_log()  if !defined($current_syslog_ident) &&
                      !defined($current_syslog_facility);
      open_log();
    }
    syslog($prio, "%s", $am_id . $pre . $errmsg);
  } else {
    my($prefix) = sprintf("%s %s %s[%s]: ",      # prepare syslog-alike prefix
           strftime("%b %e %H:%M:%S",localtime), c('myhostname'), $myname, $$);
    if (defined $loghandle && !$log_to_stderr) {
      lock($loghandle);
      seek($loghandle,0,2) or die "Can't position log file to its tail: $!";
      $loghandle->print($prefix, $am_id, $errmsg, $eol)
        or die "Error writing to log file: $!";
      unlock($loghandle);
    } else {
      print STDERR $prefix, $am_id, $errmsg, $eol
        or die "Error writing to STDERR: $!";
    }
  }
# POSIX::setlocale(LC_TIME, $old_locale);
}

1;

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

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

use Time::HiRes 1.49 ();

use vars qw(@timing);

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

# enter current time reading into array @timing
sub section_time($) {
  push(@timing,shift,Time::HiRes::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) = $t0 <= 0 ? 0 : $timing[$#timing] - $t0;
  if ($total < 0.0000001) { $total = 0.0000001 }
  my(@sections); my($t00) = $t0;
  while (@timing) {
    my($section, $t) = (shift(@timing), shift(@timing));
    my($dt)   = $t <= $t0  ? 0 : $t-$t0;   # handle possible clock jumps
    my($dt_c) = $t <= $t00 ? 0 : $t-$t00;  # handle possible clock jumps
    my($dtp)   = $dt   >= $total ? 100 : $dt*100.0/$total;    # this event
    my($dtp_c) = $dt_c >= $total ? 100 : $dt_c*100.0/$total;  # cumulative
    push(@sections, sprintf("%s: %.0f (%.0f%%)%.0f",
                            $section, $dt*1000, $dtp, $dtp_c));
    $t0 = $t;
  }
  sprintf("TIMING [total %.0f ms] - %s", $total * 1000, join(", ",@sections));
}

# returns value in seconds of elapsed time for processing of this mail so far
sub get_time_so_far() {
  my($notneeded, $t0) = @timing;
  my($total) = $t0 <= 0 ? 0 : Time::HiRes::time - $t0;
  $total < 0 ? 0 : $total;
}

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

sub idle_proc(@) {
  my($t1) = Time::HiRes::time;
  if (defined $t0) {
    ($t_was_busy ? $t_busy_cum : $t_idle_cum) += $t1 - $t0;
    Amavis::Util::ll(5) && Amavis::Util::do_log(5,
        "idle_proc, @_: 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,
     "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::Util;
use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&untaint &min &max &safe_encode &safe_decode &q_encode
                  &xtext_encode &xtext_decode
                  &snmp_count &snmp_counters_init &snmp_counters_get
                  &am_id &new_am_id &ll &do_log &debug_oneshot
                  &add_entropy &fetch_entropy &generate_mail_id
                  &exit_status_str &proc_status_ok &kill_proc &prolong_timer
                  &sanitize_str &fmt_struct &rmdir_recursively
                  &read_text &read_l10n_templates &read_hash &read_array
                  &dump_hash &dump_array
                  &cloexec &run_command &run_command_consumer
                  &dynamic_destination);
}
use subs @EXPORT_OK;
use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);
use Errno qw(ENOENT EACCES);
use Digest::MD5 2.22;  # need 'clone' method
# use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC);  # used in cloexec, if enabled
# use Encode;  # Perl 5.8  UTF-8 support

BEGIN {
  import Amavis::Conf qw(:platform $DEBUG c cr ca
                         $trim_trailing_space_in_lookup_result_fields);
  import Amavis::Log qw(write_log open_log close_log);
  import Amavis::Timing qw(section_time);
}

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

# Returns the smallest defined 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 defined 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);
    # obtain taintedness of the string, with UTF-8 flag unconditionally off
    my($taint) = Encode::encode('ascii',substr($str,0,0));
    $taint . Encode::encode($encoding,untaint($str),$check);  # preserve taint
  }
}

sub safe_decode($$;$) {
  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
    $taint . Encode::decode($encoding,untaint($str),$check);  # preserve taint
  }
}

# Do the Q-encoding manually, the MIME::Words::encode_mimeword does not
# encode spaces and does not limit to 75 ch, which violates the RFC 2047
sub q_encode($$$) {
  my($octets,$encoding,$charset) = @_;
  my($prefix) = '=?' . $charset . '?' . $encoding . '?';
  my($suffix) = '?='; local($1,$2,$3);
  # FWS | utext (= NO-WS-CTL|rest of US-ASCII)
  $octets =~ /^ ( [\001-\011\013\014\016-\177]* [ \t] )?  (.*?)
                ( [ \t] [\001-\011\013\014\016-\177]* )? \z/sx;
  my($head,$rest,$tail) = ($1,$2,$3);
  # Q-encode $rest according to RFC 2047
  # more restricted than =?_ so that it may be used in 'phrase'
  $rest =~ s{([^ 0-9a-zA-Z!*/+-])}{sprintf('=%02X',ord($1))}egs;
  $rest =~ tr/ /_/;   # turn spaces into _ (rfc2047 allows it)
  my($s) = $head; my($len) = 75 - (length($prefix)+length($suffix)) - 2;
  while ($rest ne '') {
    $s .= ' '  if $s !~ /[ \t]\z/;  # encoded words must be separated by FWS
    $rest =~ /^ ( .{0,$len} [^=] (?: [^=] | \z ) ) (.*) \z/sx;
    $s .= $prefix.$1.$suffix; $rest = $2;
  }
  $s.$tail;
}

# encode "+", "=" and any character outside the range "!" (33) to "~" (126)
sub xtext_encode($) {  # rfc3461
  my($str) = @_; local($1);
  $str =~ s/([^\041-\052\054-\074\076-\176])/sprintf("+%02X",ord($1))/egs;
  $str;
}

# decode xtext-encoded string as per rfc3461
sub xtext_decode($) {
  my($str) = @_; local($1);
  $str =~ s/\+([0-9a-fA-F]{2})/pack("C",hex($1))/egs;
  $str;
}

# Set or get Amavis internal message id.
# This message id performs a similar function as queue-id in MTA responses.
# It may only be used in generating text part of SMTP responses,
# or in generating log entries. It is only unique within a limited timespan.
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);
  $id = defined $str ? $str : sprintf("%05d", $$);
  $id .= sprintf("-%02d", $cnt)  if defined $cnt;
  $id .= "-$seq"  if defined $seq && $seq > 1;
  am_id($id);
}

use vars qw($entropy);  # MD5 ctx (128 bits, 32 hex digits or 22 base64 chars)
sub add_entropy(@) {
  $entropy = Digest::MD5->new  if !defined $entropy;
  my($s) = join(",", map {!defined($_) ? 'U' : ref eq 'ARRAY' ? @$_ : $_} @_);
# do_log(5,"add_entropy: %s",$s);
  $entropy->add($s);
}

sub fetch_entropy() {
  $entropy->clone->b64digest;
}

# generate a reasonably unique (long-term) id based on collected entropy.
# The result is a pair of (mostly public) mail_id, and a secret id,
# where mail_id == b64(md5(b64(secret))). The secret id could be used to
# authorize releasing quarantined mail. Both the mail_id and secret are
# 12-char strings of characters [A-Za-z0-9+-], with an additional restriction
# for mail_id which must begin and end with an alphanumeric character.
sub generate_mail_id() {
  my($secret_id,$id,$rest);
  for (my $j=0; $j<100; $j++) {  # provide some sanity loop limit just in case
    # take 72 bits from entropy accum. to produce a secret id, leave 56 bits
    local($1,$2);  $entropy->clone->b64digest =~ /^(.{12})(.*)\z/s;
    ($secret_id,$rest) = ($1,$2);  $secret_id =~ tr{/}{-};  # [A-Za-z0-9+-]
    # mail_id computed as md5(secret_id), rely on unidirectionality of md5
    $id = Digest::MD5->new->add($secret_id)->b64digest;   # md5(b64(secret_id))
    last  if $id =~ /^[A-Za-z0-9].{10}[A-Za-z0-9]/s;  # starts&ends with alfnum
    add_entropy($j);                           # retry on less than 7% of cases
    do_log(5,"generate_mail_id retry: %s",$id);
  }
  # start with a fresh entropy accumulator, wiping out traces of secret id
  $entropy = undef;
  add_entropy($rest);  # carry over unused portion of old entropy accumulator
  add_entropy($id);    # mix-in the full mail_id before chopping it to 12 chars
  $id = substr($id,0,12);  $id =~ tr{/}{-};
  ($id,$secret_id);
}

use vars qw(@counter_names);
# elements may be counter names (increment is 1), or pairs: [name,increment]
sub snmp_counters_init() { @counter_names = () }
sub snmp_count(@) { push(@counter_names, @_) }
sub snmp_counters_get() { \@counter_names }

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

# is message log level below the current log level (i.e. eligible for logging)?
sub ll($) {
  my($level) = @_;
  $level = 0  if $level > 0 && ($DEBUG || $debug_oneshot);
  my($current_log_level) = c('log_level');
  $current_log_level = 0  if !defined($current_log_level);
  $level <= $current_log_level;
}

# write log entry
sub do_log($$;@) {
  my($level) = shift;  # my($errmsg,@args) = @_;
  if (ll($level)) {
    if ($level > 0 && ($DEBUG || $debug_oneshot)) { $level = 0 }
    write_log($level, am_id(), shift, @_);
  }
}

# map process termination status number to a string, and append optional
# user error mesage, returning the resulting string
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 (%04x)", WTERMSIG($stat),$stat);
  }
  $str .= ', '.$err  if defined $err && $err != 0;
  $str;
}

# check errno to be 0 and process exit status to be in the list of success
# status codes, returning true if both are ok, and false otherwise
sub proc_status_ok($$@) {
  my($stat,$errno,@success) = @_;
  my($ok) = 0;
  if ($errno == 0 && WIFEXITED($stat)) {
    my($j) = WEXITSTATUS($stat);
    if (!@success) { $ok = $j==0 }  # empty list implies only status 0 is good
    elsif (grep {$_ == $j} @success) { $ok = 1 }
  }
  $ok;
}

# kill a process, typically a runaway external decoder or checker
sub kill_proc($;$$$) {
  my($pid,$what,$timeout,$proc_fh) = @_;
  $pid > 0  or die "shouldn't be killing process groups: [$pid]";
  $what = defined $what ? " running $what" : '';
  do_log(-1,"killing process [%s]%s", $pid,$what);
  #
  # the following sequence is a must: SIGTEMP first, _then_ close a pipe;
  # otherwise the following can happen: closing a pipe first (explicitly or
  # implicitly by undefining $proc_fh) blocks us so we never send SIGTEMP
  # until the external process dies of natural death; on the other hand,
  # not closing the pipe after SIGTEMP does not necessarily let the process
  # notice SIGTEMP, so SIGKILL is always needed to stop it, which is not nice
  # 
  kill('TERM',$pid)    # be gentle on the first attempt
    or do_log(1,"Can't send SIGTERM to process [%s]: %s", $pid,$!);
  # close the pipe if still open, ignoring status
  $proc_fh->close  if defined $proc_fh;
  my($n) = kill(0,$pid);  # is the process still there? get number of processes
  if ($n > 0 && defined($timeout) && $timeout > 0) {
    sleep($timeout); $n = kill(0,$pid);  # wait a little and recheck
  }
  if ($n > 0) {  # the process is still there, try a stronger signal
    do_log(-1,"process [%s] is still alive, using a bigger hammer", $pid);
    kill('KILL',$pid)
      or do_log(-2,"Can't send SIGKILL to process [%s]: %s", $pid,$!);
  }
}

sub prolong_timer($;$) {
  my($which_section, $child_remaining_time) = @_;
  if (defined $child_remaining_time) {  # explicitly given
    $child_remaining_time = 10  if $child_remaining_time < 10;
    do_log(4, "prolong_timer %s: timer set to = %d s",
              $which_section,$child_remaining_time);
  } else {
    $child_remaining_time = alarm(0);  # check how much time is left
    do_log(4, "prolong_timer %s: remaining time = %d s",
              $which_section,$child_remaining_time);
    $child_remaining_time = 60  if $child_remaining_time < 60;
  }
  alarm($child_remaining_time);        # restart/prolong the timer
}

# Mostly for debugging and reporting purposes:
# Convert nonprintable characters in the argument
# to \[rnftbe], or \octal code, and '\' to '\\',
# and Unicode characters to \x{xxxx}, returning the sanitized string.
sub sanitize_str {
  my($str, $keep_eol) = @_;
  my(%map) = ("\r" => '\\r', "\n" => '\\n', "\f" => '\\f', "\t" => '\\t',
              "\b" => '\\b', "\e" => '\\e', "\\" => '\\\\');
  if ($keep_eol) {
    $str =~ s/([^\012\040-\133\135-\176])/  # and \240-\376 ?
              exists($map{$1}) ? $map{$1} :
                     sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
  } else {
    $str =~ s/([^\040-\133\135-\176])/      # and \240-\376 ?
              exists($map{$1}) ? $map{$1} :
                     sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
  }
  $str;
}

# pretty-print a structure for logging purposes: returns a string
sub fmt_struct($) {
  my($arg) = @_;
  !defined($arg) ? 'undef' : !ref($arg) ? '"'.$arg.'"' :
  ref($arg) eq 'ARRAY' ? '['.join(',',map {fmt_struct($_)} @$arg).']' : $arg;
};

#
# Removes a directory, along with its contents
sub rmdir_recursively($;$);  # prototype
sub rmdir_recursively($;$) {
  my($dir, $exclude_itself) = @_;  my($cnt) = 0;
  do_log(4,"rmdir_recursively: %s, excl=%s", $dir,$exclude_itself);
  local(*DIR); my($errn) = opendir(DIR,$dir) ? 0 : 0+$!;
  if ($errn == ENOENT) { die "Directory $dir does not exist," }
  elsif ($errn == EACCES) {  # relax protection on directory, then try again
    do_log(3,"rmdir_recursively: enabling read access to directory %s",$dir);
    chmod(0750,$dir) or die "Can't change protection-1 on dir $dir: $!";
    $errn = opendir(DIR,$dir) ? 0 : 0+$!;  # try again
  }
  if ($errn) { die "Can't open directory $dir: $!" }
  my(@dirfiles) = readdir(DIR); # must avoid modifying dir. while traversing it
  closedir(DIR) or die "Error closing directory $dir: $!";
  for my $f (@dirfiles) {
    my($fname) = "$dir/$f";
    $errn = lstat($fname) ? 0 : 0+$!;
    if ($errn == ENOENT) { die "File \"$fname\" does not exist" }
    elsif ($errn == EACCES) {  # relax protection on the directory and retry
      do_log(3,"rmdir_recursively: enabling access to files in dir %s",$dir);
      chmod(0750,$dir) or die "Can't change protection-2 on dir $dir: $!";
      $errn = lstat($fname) ? 0 : 0+$!;  # try again
    }
    if ($errn) { die "File \"$fname\" inaccessible: $!" }
    next  if ($f eq '.' || $f eq '..') && -d _;
    if (-d _) { rmdir_recursively(untaint($fname), 0) }
    else {
      $cnt++;
      if (unlink(untaint($fname))) {  # ok
      } else {  # relax protection on the directory, then try again
        do_log(3,"rmdir_recursively: enabling write access to dir %s",$dir);
        my($what) = -l _ ? 'symlink' :-d _ ? 'directory' :'non-regular file';
        chmod(0750,$dir) or die "Can't change protection-3 on dir $dir: $!";
        unlink(untaint($fname)) or die "Can't remove $what $fname: $!";
      }
    }
  }
  section_time("unlink-$cnt-files");
  if (!$exclude_itself) {
    rmdir($dir) or die "rmdir_recursively: Can't remove directory $dir: $!";
    section_time('rmdir');
  }
  1;
}

# read a multiline string from a 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
  my($nbytes,$buff);
  while (($nbytes=$inp->read($buff,16384)) > 0) { $str .= $buff }
  defined $nbytes or die "Error reading from $filename: $!";
  $inp->close or die "Error closing $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 = untaint($1);
  } else {
    die "Invalid charset $file_chset\n";
  }
  $Amavis::Conf::notify_sender_templ =
    Amavis::Util::read_text("$dir/template-dsn.txt", $file_chset);
  $Amavis::Conf::notify_virus_sender_templ =
    Amavis::Util::read_text("$dir/template-virus-sender.txt", $file_chset);
  $Amavis::Conf::notify_virus_admin_templ =
    Amavis::Util::read_text("$dir/template-virus-admin.txt", $file_chset);
  $Amavis::Conf::notify_virus_recips_templ =
    Amavis::Util::read_text("$dir/template-virus-recipient.txt", $file_chset);
  $Amavis::Conf::notify_spam_sender_templ =
    Amavis::Util::read_text("$dir/template-spam-sender.txt", $file_chset);
  $Amavis::Conf::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 associative array (Perl hash) from a 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 allows
#   comments starting at the beginning of a 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($lpcs) = c('localpart_is_case_sensitive');
  my($inp) = IO::File->new;
  $inp->open($filename,'<') or die "Can't open file $filename for reading: $!";
  my($ln);
  for ($! = 0; defined($ln=$inp->getline); $! = 0) {
    chomp($ln);
    # carefully handle comments, '#' within "" does not count as a comment
    my($lhs) = ''; my($rhs) = ''; my($at_rhs) = 0; my($trailing_comment) = 0;
    for my $t ( $ln =~ /\G ( " (?: \\. | [^"\\] )* " |
                             [^#" \t]+ | [ \t]+ | . )/gcsx) {
      if ($t eq '#') { $trailing_comment = 1; last }
      if (!$at_rhs && $t =~ /^[ \t]+\z/) { $at_rhs = 1 }
      else { ($at_rhs ? $rhs : $lhs) .= $t }
    }
    $rhs =~ s/[ \t]+\z//  if $trailing_comment ||
                             $trim_trailing_space_in_lookup_result_fields;
    next  if $lhs eq '' && $rhs eq '';
    my($source_route,$localpart,$domain) =
                      Amavis::rfc2821_2822_Tools::parse_quoted_rfc2821($lhs,1);
    $localpart = lc($localpart)  if !$lpcs;
    my($addr) = $localpart . lc($domain);
    $hashref->{$addr} = $rhs eq '' ? 1 : $rhs;
    # do_log(5, "read_hash: address: <%s>: %s", $addr, $hashref->{$addr});
  }
  defined $ln || $!==0  or die "Error reading from $filename: $!";
  $inp->close or die "Error closing $filename: $!";
  $hashref;
}

sub read_array(@) {
  unshift(@_,[])  if !ref $_[0];  # first argument is optional, defaults to []
  my($arrref, $filename, $keep_case) = @_;
  my($inp) = IO::File->new;
  $inp->open($filename,'<') or die "Can't open file $filename for reading: $!";
  my($ln);
  for ($! = 0; defined($ln=$inp->getline); $! = 0) {
    chomp($ln); my($lhs) = '';
    # carefully handle comments, '#' within "" does not count as a comment
    for my $t ( $ln =~ /\G ( " (?: \\. | [^"\\] )* " |
                             [^#" \t]+ | [ \t]+ | . )/gcsx) {
      last  if $t eq '#';
      $lhs .= $t;
    }
    $lhs =~ s/[ \t]+\z//;  # trim trailing whitespace
    push(@$arrref, Amavis::rfc2821_2822_Tools::unquote_rfc2821_local($lhs))
      if $lhs ne '';
  }
  defined $ln || $!==0  or die "Error reading from $filename: $!";
  $inp->close or die "Error closing $filename: $!";
  $arrref;
}

sub dump_hash($) {
  my($hr) = @_;
  do_log(0, "dump_hash: %s => %s", $_,$hr->{$_}) for (sort keys %$hr);
}

sub dump_array($) {
  my($ar) = @_;
  do_log(0, "dump_array: %s", $_)  for @$ar;
}

sub cloexec($;$$) { undef }
# sub cloexec($;$$) {  # hopefully not needed for Perl >= 5.6.0
#   my($fh,$newsetting,$name) = @_; my($flags);
#   $flags = fcntl($fh, F_GETFD, 0)
#     or die "Can't get close-on-exec flag for file handle $fh $name: $!";
#   $flags = 0 + $flags;  # turn into numeric, avoid: "0 but true"
#   if (defined $newsetting) {  # change requested?
#     my($newflags) = $newsetting ? ($flags|FD_CLOEXEC) : ($flags&~FD_CLOEXEC);
#     if ($flags != $newflags) {
#       do_log(4,"cloexec: turning %s flag FD_CLOEXEC for file handle %s %s",
#              $newsetting ? "ON" : "OFF", $fh, $name);
#       fcntl($fh, F_SETFD, $newflags)
#         or die "Can't set FD_CLOEXEC for file handle $fh $name: $!";
#     }
#   }
#   ($flags & FD_CLOEXEC) ? 1 : 0;  # returns old setting
# }

# POSIX::open a file or dup an existing fd (Perl open syntax), with a
# requirement that it gets opened on a prescribed file descriptor $fd_target
sub open_on_specific_fd($$$$) {
  my($fd_target,$fname,$flags,$mode) = @_;
  my($fd_got);  # fd directy given as argument, or obtained from POSIX::open
  if ($fname =~ /^&=?(\d+)\z/) { $fd_got = $1 }  # fd directly specified
  my($flags_displayed) = $flags == &POSIX::O_RDONLY ? '<'
                       : $flags == &POSIX::O_WRONLY ? '>' : $flags;
  if (!defined($fd_got) || $fd_got != $fd_target) {
    # close whatever is on a target descriptor but don't shoot self in the foot
    # with Net::Server <= 0.90 fd0 was main::stdin, but no longer is in 0.91
    do_log(5, "open_on_specific_fd: target fd%s closing, to become %s %s",
              $fd_target,$flags_displayed,$fname);
    # it pays off to close explicitly, with some luck open will get a target fd
    POSIX::close($fd_target);  # ignore error, we may have just closed a log
  }
  if (!defined($fd_got)) {  # file name was given, not a descriptor
    $fd_got = POSIX::open($fname,$flags,$mode);
    defined $fd_got or die "Can't open $fname: $!";
    $fd_got = 0 + $fd_got;  # turn into numeric, avoid: "0 but true"
  }
  if ($fd_got != $fd_target) {  # dup, ensuring we get a specified descriptor
    eval {  # we may have been left without a log file descriptor, must not die
      do_log(5, "open_on_specific_fd: target fd%s dup2 from fd%s %s %s",
                $fd_target,$fd_got,$flags_displayed,$fname);
    };
    # POSIX mandates we get the lowest fd available
    # but let's be explicit that we require a specified file descriptor
    defined POSIX::dup2($fd_got,$fd_target)
      or "Can't dup2 from $fd_got to $fd_target: $!";
    if ($fd_got > 2) {  # let's get rid of the original fd, unless 0,1,2
      my($err); defined POSIX::close($fd_got) or $err = $!;
      $err = defined $err ? ": $err" : '';
      eval {  # we may have been left without a log file descriptor, don't die
        do_log(5, "open_on_specific_fd: source fd%s closed%s", $fd_got,$err);
      };
    }
  }
  $fd_got;
}

# 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 '';
  $stderr_to  = '/dev/null'  if $stderr_to  eq '';
  my($msg) = join(' ', $cmd, @args, "<$stdin_from",
                  $stderr_to eq '' ? () : "2>$stderr_to");
  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 forked process, or we end up with
            # two running daemons!
#     use Devel::Symdump ();
#     my($dumpobj) = Devel::Symdump->rnew;
#     for my $k ($dumpobj->ios) {
#       no strict 'refs';  my($fn) = fileno($k);
#       if (!defined($fn)) { do_log(2, "not open %s", $k) }
#       elsif ($fn == 1 || $fn == 2) { do_log(2, "KEEP %s, fileno=%s",$k,$fn) }
#       else { $! = 0;
#         close(*{$k}{IO}) and do_log(2, "DID CLOSE %s (fileno=%s)", $k,$fn);
#       }
#     }
#     $sql_dataset_conn_lookups->dbh_inactive(1)  if $sql_dataset_conn_lookups;
#     $sql_dataset_conn_storage->dbh_inactive(1)  if $sql_dataset_conn_storage;
#     $sql_dataset_conn_lookups = $sql_dataset_conn_storage = undef;

      open_on_specific_fd(0,$stdin_from,&POSIX::O_RDONLY,0);
      open_on_specific_fd(2,$stderr_to,&POSIX::O_WRONLY,0) if $stderr_to ne '';
#     eval { close_log() };  # may have been closed by open_on_specific_fd
      # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
      exec {$cmd} ($cmd,@args);
      die "run_command: failed to exec $cmd_text: $!";
    };
    my($err) = $@; chomp($err);
    eval {
      open_log();  # oops, exec failed, we will need logging after all...
      do_log(-2,"run_command: child process [%s]: %s", $$,$err);
    };
    { no warnings;
      POSIX::_exit(1);  # avoid END and destructor processing
      kill('KILL',$$); exit 1;   # still kicking? die!
    }
  }
  # parent
  ll(5) && do_log(5,"run_command: [%s] %s", $pid,$msg);
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

# Run specified command as a subprocess. Return a file handle open for
# WRITING to the subprocess. Use IO::Handle to ensure the subprocess
# will be automatically reclaimed in case of failure.
#
sub run_command_consumer($$@) {
  my($stdout_to, $stderr_to, $cmd, @args) = @_;
  my($cmd_text) = join(' ', $cmd, @args);
  $stdout_to = '/dev/null'  if $stdout_to eq '';
  $stderr_to = '/dev/null'  if $stderr_to eq '';
  my($msg) = join(' ', $cmd, @args, ">$stdout_to",
                  $stderr_to eq '' ? () : "2>$stderr_to");
  my($pid); my($proc_fh) = IO::File->new;
  eval { $pid = $proc_fh->open('|-') };  # fork, catching errors
  if ($@ ne '') { chomp($@); die "run_command_consumer (open pipe): $@ ($!)" }
  defined($pid) or die "run_command_consumer: can't fork: $!";
  if (!$pid) {                           # child
    eval {  # must not use die in forked process, or we end up with
            # two running daemons!
#     $sql_dataset_conn_lookups->dbh_inactive(1)  if $sql_dataset_conn_lookups;
#     $sql_dataset_conn_storage->dbh_inactive(1)  if $sql_dataset_conn_storage;
#     $sql_dataset_conn_lookups = $sql_dataset_conn_storage = undef;

      open_on_specific_fd(1,$stdout_to,&POSIX::O_WRONLY,0);
      open_on_specific_fd(2,$stderr_to,&POSIX::O_WRONLY,0) if $stderr_to ne '';
#     eval { close_log() };  # may have been closed by open_on_specific_fd
      # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
      exec {$cmd} ($cmd,@args);
      die "run_command_consumer: failed to exec $cmd_text: $!";
    };
    my($err) = $@; chomp($err);
    eval {
      open_log();  # oops, exec failed, we will need logging after all...
      do_log(-2,"run_command_consumer: child process [%s]: %s", $$,$err);
    };
    { no warnings;
      POSIX::_exit(1);  # avoid END and destructor processing
      kill('KILL',$$); exit 1;   # still kicking? die!
    }
  }
  # parent
  ll(5) && do_log(5,"run_command_consumer: [%s] %s", $pid,$msg);
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

sub dynamic_destination($$$) {
  my($method,$conn,$force_dynamic) = @_;
  my($client_ip) = !defined($conn) ? undef : $conn->client_ip;
  if ($method =~ /^[A-Za-z0-9]*:/) {
    my(@list); $list[0] = ''; my($j) = 0;
    for ($method =~ /\G \[ (?: \\. | [^\]\\] )* \] | " (?: \\. | [^"\\] )* "
                        | : | [ \t]+ | [^:"\[ \t]+ | . /gcsx) {  # real parsing
      if ($_ eq ':') { $list[++$j] = '' } else { $list[$j] .= $_ }
    };
    my($new_method); my($via,$relayhost,$relayhost_port) = @list;
    ($relayhost,$relayhost_port) = ('*','*')  if $force_dynamic;
    if ($relayhost eq '*') {
      do_log(0,"dynamic destination expected, no client IP address: %s",
               $method)  if $client_ip eq '';
      $relayhost = "[$client_ip]";
    }
    $relayhost_port = $conn->socket_port+1  if $relayhost_port eq '*';
    $new_method = join(':', $via,$relayhost,$relayhost_port,@list[3..$#list]);
    if ($new_method ne $method) {
      do_log(3, "dynamic destination: %s -> %s", $method,$new_method);
      $method = $new_method;
    }
  }
  $method;
}

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.062';
  @ISA = qw(Exporter);
  @EXPORT = qw(
    &iso8601_timestamp &iso8601_utc_timestamp &rfc2822_timestamp
    &received_line &parse_received
    &fish_out_ip_from_received &split_address &split_localpart &make_query_keys
    &quote_rfc2821_local &qquote_rfc2821_local
    &parse_quoted_rfc2821 &unquote_rfc2821_local
    &wrap_string &wrap_smtp_resp &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 c cr ca);
  import Amavis::Util qw(ll 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, and on systems where strftime
# can not return TZ offset as a number;  (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 numeric time (seconds since 1970-01-01T00:00Z),
# provide date-time timestamp (local time) as specified in ISO 8601 (EN 28601)
#
sub iso8601_timestamp($;$$$) {
  my($t,$suppress_zone,$dtseparator,$with_field_separators) = @_;
  # can't use %z because some systems do not support it (is treated as %Z)
  my($fmt) = $with_field_separators ? "%Y-%m-%dT%H:%M:%S" : "%Y%m%dT%H%M%S";
  $fmt =~ s/T/$dtseparator/  if defined $dtseparator;
  my($s) = strftime($fmt,localtime($t));
  $s .= get_zone_offset($t)  unless $suppress_zone;
  $s;
}

# Given a Unix numeric time (seconds since 1970-01-01T00:00Z),
# provide date-time timestamp (UTC) as specified in ISO 8601 (EN 28601)
#
sub iso8601_utc_timestamp($;$$$) {
  my($t,$suppress_zone,$dtseparator,$with_field_separators) = @_;
  my($fmt) = $with_field_separators ? "%Y-%m-%dT%H:%M:%S" : "%Y%m%dT%H%M%S";
  $fmt =~ s/T/$dtseparator/  if defined $dtseparator;
  my($s) = strftime($fmt,gmtime($t));
  $s .= 'Z'  unless $suppress_zone;
  $s;
}

# Given a Unix time, provide date-time timestamp as specified in RFC 2822
# (local time), to be used in header fields such as 'Date:' and 'Received:'
#
sub rfc2822_timestamp($) {
  my($t) = @_;
  my(@lt) = localtime($t);
  # can't use %z because some systems do not support it (is treated as %Z)
# my($old_locale) = POSIX::setlocale(LC_TIME,"C");  # English dates required!
  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/;
# POSIX::setlocale(LC_TIME, $old_locale);  # restore the 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])"),
    c('localhost_name'),
    ($conn->socket_ip eq '' ? ''
      : sprintf(" (%s [%s])", c('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)MTPS?A?\z/i; # rfc3848
  $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+
              ( (?:  "  (?: \\. | [^"\\]  )* "
                  |  \[ (?: \\. | [^\]\\] )* \]
                  |  \\. | [0-9a-z]+ | .    # greedy words avoid deep recursion
                )+? (?= \(|;|\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));
    $field = ''  if !defined($field);  # mute a warning about uninit. value
    if ($field eq 'from' || $field eq 'by') {
      ($v1, $v2, $v3, $comment) = ($3, $4, $5, $11);
    } elsif ($field eq ';') {  # time
      ($v1, $comment) = ($9, $11);
    } elsif (!defined($10) || $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];
      ll(5) && do_log(5, "parse_received: %s = %s/%s/%s/%s",
                         map { !defined($_) ? '' : length($_) <= 50 ? $_
                               : substr($_,0,50)."..." }
                         ($field, @{$fields{$field}}) )  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 (map {defined $_ ? $_ : ''} ($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: %s, %s", $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 nonempty) 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 =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\]\\] )*  \]
                                 |  [^@"<>\[\]\\ \t] )*
                       ) \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) = 1;  # 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/si) {
    # 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 order:
#   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 (without localpart) keys
# get a '@' prepended (e.g. '@.example.com'). Usual for SQL and LDAP lookups.
#
# The domain part is lowercased in all but the first item in the resulting
# list; 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 !c('localpart_is_case_sensitive');
  # chop off leading @, and trailing dots
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  my($extension); my($delim) = c('recipient_delimiter');
  if ($delim ne '') {
    ($localpart,$extension) = split_localpart($localpart,$delim);
  }
  $extension = ''  if !defined($extension);  # mute warnings
  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.$delim.$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.$delim.$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
    push(@keys, $prepend_to_domain.'.');     # (@).
  } else {
    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 }
  ll(5) && do_log(5,"query_keys: %s", join(', ',@$keys_ref));
  # the rhs replacement strings are similar to what would be obtained
  # by lookup_re() given the following regular expression:
  # /^( ( ( [^@]*? ) ( \Q$delim\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
    $delim.$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.
#
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, needs q.
    $localpart =~ s/(["\\])/\\$1/g;   # quoted-pair
    $localpart = '"'.$localpart.'"';  # make it a qcontent
#   Postfix hates  ""@domain  but is not so harsh on  @domain
#   Late breaking news: don't bother, both forms are rejected by Postfix
#   when strict_rfc821_envelopes=yes, and both are accepted otherwise
  }
  # we used to strip off empty domain (just '@') unconditionally, but this
  # leads Postfix to interpret an address with a '@' in the quoted local part
  # e.g. <"h@example.net"@> as <hhh@example.net> (subject to Postfix setting
  # 'resolve_dequoted_address'), which is not what the sender requested;
  # we no longer do that if localpart contains an '@':
  $domain = ''  if $domain eq '@' && $localpart =~ /\@/;
  $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 if invoked in scalar context), quoting each element;
#
sub qquote_rfc2821_local(@) {
  my(@r) = map { $_ eq '' ? '<>' : ('<' . quote_rfc2821_local($_) . '>') } @_;
  wantarray ? @r : join(', ', @r);
}

sub parse_quoted_rfc2821($$) {
  my($addr,$unquote) = @_;
  # the angle-bracket stripping is not really a duty of this subroutine,
  # as it should have been already done elsewhere, but we allow it here anyway:
  $addr = $1  if $addr =~ /^ \s* < ( .* ) > \s* \z/xs;
  my($source_route,$localpart,$domain) = ('','','');
  # RFC 2821: so-called "source route" MUST BE accepted,
  #           SHOULD NOT be generated, and SHOULD be ignored.
  #           Path = "<" [ A-d-l ":" ] Mailbox ">"
  #           A-d-l = At-domain *( "," A-d-l )
  #           At-domain = "@" domain
  if ($addr =~ /:/ &&  # triage before more detailed testing for source route
      $addr =~ m{^ (       [ \t]* \@ (?: [0-9A-Za-z.!#\$%&*/^{}=_+-]* |
                                         \[ (?: \\. | [^\]\\] )* \] ) [ \t]*
                     (?: , [ \t]* \@ (?: [0-9A-Za-z.!#\$%&*/^{}=_+-]* |
                                         \[ (?: \\. | [^\]\\] )* \] ) [ \t]* )*
                     : [ \t]* ) (.*) \z }xs)
  { # NOTE: we are quite liberal on allowing whitespace around , and : here,
    # and liberal in allowed character set and syntax of domain names,
    # we mainly avoid stop-characters in the domain names of source route
    $source_route = $1; $addr = $2;
  }
  if ($addr =~ m{^ (    (?: [^"@]+ | " (?: \\. | [^"\\] )* " | . )*? )
                   ( \@ (?: [^"@\[\]\\ \t]+ | \[ (?: \\. | [^\]\\] )* \]
                          | [^@] )* )? \z}xs) {
    ($localpart,$domain) = ($1,$2);
  } else {
    ($localpart,$domain) = ($addr,'');
  }
  $localpart =~ s/ " | \\ (.) | \\ \z /$1/xsg  if $unquote; # undo quoted-pairs
  ($source_route, $localpart, $domain);
}

# 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) = @_;
  my($source_route,$localpart,$domain) = parse_quoted_rfc2821($mailbox,1);
  # make address with '@' in the localpart but no domain (like <"aa@bb.com"> )
  # distinguishable from <aa@bb.com> by representing it as aa@bb.com@ in
  # unquoted form; (it still obeys all regular rules, it is not a trick)
  $domain = '@'  if $domain eq '' && $localpart ne '';
  $localpart . $domain;
}

# compute a total displayed line size if a string (possibly containing TAB
# characters) would be displayed at the given character position (0-based)
sub displayed_length($$) {
  my($str,$ind) = @_;
  for my $t ($str =~ /\G ( \t | [^\t]+ )/gcsx)
    { $ind += $t ne "\t" ? length($t) : 8 - $ind % 8 }
  $ind;
}

# Wrap a string into a multiline string, inserting \n as appropriate to keep
# each line length at $max_len or shorter (not counting \n). A string $prefix
# is prepended to each line. Continuation lines get their first space or TAB
# character replaced by a string $indent (unless $indent is undefined, which
# keeps the leading whitespace character unchanged). Both the $prefix and
# $indent are included in line size calculation, and for the purpose of line
# size calculations TABs are treated as an appropriate number of spaces.
# Parameter $structured indicates where line breaks are permitted: true
# indicates that line breaks may only occur where a \n character is already
# present in the source line, indicating possible (tentative) line breaks.
# If $structured is false, permitted line breaks are chosen within existing
# whitespace substrings so that all-whitespace lines are never generated
# (even at the expense of producing longer than allowed lines if necessary),
# and that each continuation line starts by at least one whitespace character.
# Whitespace is neither added nor removed, but simply spliced into trailing
# and leading whitespace of subsequent lines. This is appropriate and required
# for wrapping of mail haeder fields. An exception to preservation of
# whitespace is when $indent string is defined but empty string, causing
# leading and trailing whitespace to be trimmed, producing a classical
# plain text wrapping results.
# 
sub wrap_string($;$$$$) {
  my($str,$max_len,$prefix,$indent,$structured) = @_;
  $max_len = 78    if !defined($max_len);
  $prefix = ''     if !defined($prefix);
  $structured = 0  if !defined($structured);
  my(@chunks);
  # split a string into chunks where each chunk starts with exactly one SP or
  # TAB character (except possibly the first chunk), followed by an unbreakable
  # string (consisting typically entirely of non-whitespace characters, but at
  # least one character must be non-whitespace), followed by an all-whitespace
  # string consisting of only SP or TAB characters.
  if ($structured) {
    # unfold all-whitespace chunks, just in case
    1 while $str =~ s/^([ \t]*)\n/$1/;  # prefixed?
    $str =~ s/\n(?=[ \t]*(\n|\z))//g;   # within and at end
    $str =~ s/\n(?![ \t])/\n /g;  # insert a space at line folds if missing
    # unbreakable parts are substrings between newlines, determined by caller
    @chunks = split(/\n/,$str,-1);
  } else {
    $str =~ s/\n(?![ \t])/\n /g;  # insert a space at line folds if missing
    $str =~ s/\n//g;  # unfold (knowing a space at folds is not missing)
    # unbreakable parts are non-whitespace substrings
    @chunks = $str =~ /\G ( (?: ^ .*? | [ \t]) [^ \t]+ [ \t]* )
                          (?=  \z | [ \t]  [^ \t] )/gcsx;
  }
  # do_log(5,"wrap_string chunk: <%s>", $_)  for @chunks;
  my($result) = '';  # wrapped multiline string will accumulate here
  my($s) = '';       # collects partially assembled single line
  my($s_displ_ind) = # display size of string in $s, including $prefix
    displayed_length($prefix,0);
  my($contin_line) = 0;  # are we assembling a continuation line?
  while (@chunks) {  # walk through input substrings and join shorter sections
    my($chunk) = shift(@chunks);
    # replace leading space char with $indent if starting a continuation line
    $chunk =~ s/^[ \t]/$indent/ if defined $indent && $contin_line && $s eq '';
    my($s_displ_l) = displayed_length($chunk, $s_displ_ind);
    if ($s_displ_l <= $max_len  # collecting in $s while still fits
        || (@chunks==0 && $s =~ /^[ \t]*\z/)) {  # or we are out of options
      $s .= $chunk; $s_displ_ind = $s_displ_l;  # absorb entire chunk
    } else {
      $chunk =~ /^ ( .* [^ \t] ) ( [ \t]* ) \z/xs  # split to head and allwhite
        or die "Assert 1 failed in wrap: /$result/, /$chunk/";
      my($solid,$white_tail) = ($1,$2);
      my($min_displayed_s_len) = displayed_length($solid, $s_displ_ind);
      if (@chunks > 0  # not being at the last chunk gives a chance to shove
                       # part of the trailing whitespace off to the next chunk
          && ($min_displayed_s_len <= $max_len  # non-whitespace part fits
              || $s =~ /^[ \t]*\z/) ) {    # or still allwhite even if too long
        $s .= $solid; $s_displ_ind = $min_displayed_s_len;  # take nonwhite
        if (defined $indent && $indent eq '') {
          # discard leading whitespace in continuation lines on a plain wrap
        } else {
          # preserve all original whitespace
          while ($white_tail ne '') {
            # stash-in as much trailing whitespace as it fits to the curr. line
            my($c) = substr($white_tail,0,1);  # one whitespace char. at a time
            my($dlen) = displayed_length($c, $s_displ_ind);
            if ($dlen > $max_len) { last }
            else {
              $s .= $c; $s_displ_ind = $dlen;  # absorb next whitespace char.
              $white_tail = substr($white_tail,1); # one down, more to go...
            }
          }
          # push remaining trailing whitespace characters back to input
          $chunks[0] = $white_tail . $chunks[0]  if $white_tail ne '';
        }
      } elsif ($s =~ /^[ \t]*\z/) {
        die "Assert 2 failed in wrap: /$result/, /$chunk/";
      } else {  # nothing more fits to $s, flush it to $result
        if ($contin_line) { $result .= "\n" } else { $contin_line = 1  }
        # trim trailing whitespace when wrapping as a plain text (not headers)
        $s =~ s/[ \t]+\z//  if defined $indent && $indent eq '';
        $result .= $prefix.$s; $s = '';
        $s_displ_ind = displayed_length($prefix,0);
        unshift(@chunks,$chunk);  # reprocess the chunk
      }
    }
  }
  if ($s !~ /^[ \t]*\z/) {  # flush last chunk if nonempty
    if ($contin_line) { $result .= "\n" } else { $contin_line = 1  }
    $s =~ s/[ \t]+\z//  if defined $indent && $indent eq '';  # trim plain text
    $result .= $prefix.$s; $s = '';
  }
  $result;
}

# wrap a SMTP response at each \n character according to rfc2821,
# returning resulting lines as a listref
sub wrap_smtp_resp($) {
  my($resp) = @_;
  # 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($max_len) = 512-2; my(@result_list); local($1,$2,$3,$4);
  if ($resp !~ /^ ([1-5]\d\d) (\ |-|\z)
                ([245] \. \d{1,3} \. \d{1,3} (?: \ |\z) )?
                (.*) \z/xs)
    { die "wrap_smtp_resp: bad SMTP response code: '$resp'" }
  my($resp_code,$continuation,$enhanced,$tail) = ($1,$2,$3,$4);
  $continuation eq ' ' || $continuation eq ''
    or die "wrap_smtp_resp: continuation SMTP response code: '$resp'";
  my($lead_len) = length($resp_code) + 1 + length($enhanced);
  while (length($tail) > $max_len-$lead_len || $tail =~ /\n/) {
    # rfc2034: When responses are continued across multiple lines the same
    # status code must appear at the beginning of the text in each line
    # of the response.
    my($head) = substr($tail, 0, $max_len-$lead_len);
    if ($head =~ /^([^\n]*\n)/s) { $head = $1 }
    $tail = substr($tail,length($head)); chomp($head);
    push(@result_list, $resp_code.'-'.$enhanced.$head);
  }
  push(@result_list, $resp_code.' '.$enhanced.$tail);
  \@result_list;
}

# 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 a non delivery notification (NDN, a form of DSN)
# is needed).
#
sub one_response_for_all($$$) {
  my($msginfo, $dsn_per_recip_capable, $am_id) = @_;
  my($smtp_resp, $exit_code, $ndn_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 <%s>: no recipients, '%s'",
              $sender, $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 <%s>: 4xx found, '%s'",
                $sender,$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, give Discard
    my($notall);
    for my $r (@$per_recip_data) {
      if ($r->recip_destiny == D_DISCARD)  # pick the first DISCARD code
        { $smtp_resp = $r->recip_smtp_response  if !defined $smtp_resp }
      else { $notall++; last }  # one is not a discard, nogood
    }
    if ($notall) { $smtp_resp = undef }
    if (defined $smtp_resp) {
      $exit_code = 99;  # helper program will interpret 99 as discard
      do_log(5, "one_response_for_all <%s>: all DISCARD, '%s'",
                $sender,$smtp_resp);
    }
  }
  if (!defined $smtp_resp) {
    # destiny for _all_ recipients is Discard or Reject, give 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 is Pass or Bounce, nogood
    }
    if ($notall) { $smtp_resp = undef }
    if (defined $smtp_resp) {
      $exit_code = EX_UNAVAILABLE;
      do_log(5, "one_response_for_all <%s>: REJECTs, '%s'",$sender,$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" }
      else { $exit_code = 99 }  # helper program DISCARD (e.g. milter)
    }
    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']);
    }
    $ndn_needed =
      ($bounce_cnt > 0 || ($rej_cnt > 0 && !$dsn_per_recip_capable)) ? 1 : 0;
    ll(5) && do_log(5,
          "one_response_for_all <%s>: %s, r=%d,b=%d,d=%s, ndn_needed=%s, '%s'",
             $sender,
             $rej_cnt + $bounce_cnt + $drop_cnt > 0 ? 'mixed' : 'success',
             $rej_cnt, $bounce_cnt, $drop_cnt, $ndn_needed, $smtp_resp);
  }
  ($smtp_resp, $exit_code, $ndn_needed);
}

1;

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

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

# Make an object out of the supplied lookup 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 or other key string
# against a list made up of regular expressions.
#
# A 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 can be accomplished by its mechanisms. The routine is useful for
# other RE tests besides the usual e-mail addresses, 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 a 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 do use a 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 ' (apostrophe), 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 a $ 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 $ and @ characters 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(0, '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)
#
# As a special allowance, the $addr argument may be a ref to a list of search
# keys. At each step in traversing the supplied regexp list, all elements of
# @$addr are tried. If any of them matches, the search stops. This is currently
# used in banned names lookups, where all attributes of a part are given as a
# list @$addr.

sub lookup_re($$;$) {
  my($self, $addr,$get_all) = @_;
  local($1,$2,$3,$4); my(@matchingkey,@result);
  for my $e (@$self) {  # try each regexp in the list
    my($key,$r);
    if (ref($e) eq 'ARRAY') {  # a pair: (regexp,result)
      ($key,$r) = ($e->[0], @$e < 2 ? 1 : $e->[1]);
    } else {                   # a single regexp (not a pair), implies result 1
      ($key,$r) = ($e, 1);
    }
    ""=~/x{0}/;  # braindead Perl: serves as explicit deflt for an empty regexp
    my(@rhs);    # match, capturing parenthesized subpatterns in @rhs
    if (!ref($addr)) { @rhs = $addr =~ /$key/ }
    else { for (@$addr) { @rhs = /$key/; last if @rhs } }
    if (@rhs) {  # regexp matches
      # do the righthand side replacements if any $n, ${n} or $(n) is specified
      if (!ref($r) && $r=~/\$/) {
        my($any) = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                          { my($j)=$2+$3+$4; $j<1 ? '' : $rhs[$j-1] }gxse;
        # bring taintedness of input to the result
        $r .= substr($addr,0,0)  if $any;
      }
      push(@result,$r); push(@matchingkey,$key);
      last  if !$get_all;
    }
  }
  if (!ll(5)) {
    # don't bother preparing log report which will not be printed
  } elsif (!@result) {
    do_log(5, "lookup_re(%s), no matches", fmt_struct($addr));
  } else {  # pretty logging
    my(%esc) = (r => "\r", n => "\n", f => "\f", b => "\b",
                e => "\e", a => "\a", t => "\t");
    my(@mk) = @matchingkey;
    for my $mk (@mk)  # undo the \-quoting, will be redone by logging routines
      { $mk =~ s{ \\(.) }{ exists($esc{$1}) ? $esc{$1} : $1 }egsx }
    if (!$get_all) {  # first match wins
      do_log(5, 'lookup_re(%s) matches key "%s", result=%s',
                fmt_struct($addr), $mk[0], fmt_struct($result[0]));
    } else {  # want all matches
      do_log(5, "lookup_re(%s) matches keys: %s", fmt_struct($addr),
          join(', ', map {sprintf('"%s"=>%s', $mk[$_],fmt_struct($result[$_]))}
                         (0..$#result)));
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

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

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

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

# 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. Brackets enclosing the address are allowed
# for Postfix compatibility, e.g. [::1]/128 .
#
# 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;
  $ipa = $1  if $ipa =~ m{^ \[ (.*) \] \z}xs;      # discard optional brackets
  $ipa = $1  if $ipa =~ m{^(.*)%[A-Za-z0-9]+\z}s;  # discard interface spec
  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
    my(@d) = ($3,$4,$5,$6);
    !grep {$_ > 255} @d
      or die "Invalid decimal field value in IPv6 address: [$ip]\n";
    $ipa = $2 . sprintf("%02X%02X:%02X%02X", @d);
  } 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]\n";
    defined($ip_len) || @d==4
      or die "IPv4 address [$ip] contains fewer than 4 fields\n";
    $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]\n";
      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]\n";
      $ip_len = $len;
    } else {
      die "Invalid IPv4 network mask or CIDR prefix length: [$ip]\n";
    }
    $ip_len<=32 or die "IPv4 network prefix length greater than 32: [$ip]\n";
    $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]\n";
  $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  # this is quite slow
    or die "Invalid syntax of IPv6 address: [$ip]\n";
  @ip_fields<8 and die "IPv6 address [$ip] contains fewer than 8 fields\n";
  @ip_fields>8 and die "IPv6 address [$ip] contains more than 8 fields\n";
  my($vec) = pack("n8", map {hex} @ip_fields);
  $ip_len=~/^\d{1,3}\z/
    or die "Invalid prefix length syntax in IP address: [$ip]\n";
  $ip_len<=128 or die "Invalid prefix length in IPv6 address: [$ip]\n";
  my($mask) = pack('B128', '1' x $ip_len);
# do_log(5, "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 or a hash of network or host addresses.
#
# IP address is compared to each member of an 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 a 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 (even syntactically invalid address).
#
# The '0/0' is equivalent to '::FFFF:0:0/96' and matches any syntactically
# valid 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, i.e. all zeros) IPv4 and IPv6
#   addresses return false, and IPv4 and IPv6 loopback addresses match
#   and return true.
#
# If the supplied lookup table is a hash reference, match a canonical IP
# address: dot-quad IPv4, or preferred IPv6 form, against hash keys. For IPv4
# addresses a simple classful subnet specification is allowed in hash keys
# by truncating trailing bytes from the looked up IPv4 address. A syntactically
# invalid IP address can only match a hash entry with an undef key.
#
sub lookup_ip_acl($@) {
  my($ip, @nets_ref) = @_;
  my($ip_vec,$ip_mask) = eval { ip_to_vec($ip,0) }; my($eval_stat) = $@;
  my($label,$fullkey,$result); my($found) = 0;
  for my $tb (@nets_ref) {
    my($t) = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
    if (!ref($t) || ref($t) eq 'SCALAR') {   # a scalar always matches
      my($r) = ref($t) ? $$t : $t;  # allow direct or indirect reference
      $result = $r; $fullkey = "(constant:$r)";
      $found++  if defined $result;
    } elsif (ref($t) eq 'HASH') {
      if (!defined $ip_vec) {  # syntactically invalid IP address
        $fullkey = undef; $result = $t->{$fullkey};
        $found++  if defined $result;
      } else {      # valid IP address
        # match the canonical IP address: dot-quad IPv4, or preferred IPv6 form
        my($ip_c);  # IP address in the canonical form: x:x:x:x:x:x:x:x
        my($ip_dq); # IPv4 in a dotted-quad form if IPv4-mapped, or undef
        $ip_c = join(':', map {sprintf('%04x',$_)} unpack('n8',$ip_vec));
        my($ipv4_vec,$ipv4_mask) = ip_to_vec('::FFFF:0:0/96',1);
        if ( ($ip_vec & $ipv4_mask) eq ($ipv4_vec & $ipv4_mask) ) {
          # is an IPv4-mapped IPv6 address, format it in a dot-quad form
          $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4))); # last 32 bits
        }
        do_log(5, 'lookup_ip_acl keys: "%s", "%s"', $ip_dq,$ip_c);
        if (defined $ip_dq) {  # try dot-quad if applicable
          for (my(@f)=split(/\./,$ip_dq); @f && !$found; $#f--) {
            $fullkey = join('.',@f); $result = $t->{$fullkey};
            $found++  if defined $result;
          }
        }
        if (!$found) {         # try the 'preferred IPv6 form'
          $fullkey = $ip_c; $result = $t->{$fullkey};
          $found++  if defined $result;
        }
      }
    } elsif (ref($t) eq 'ARRAY') {
      my($key, $acl_ip_vec, $acl_mask, $acl_mask_len);
      for my $net (@$t) {
        $fullkey = $key = $net; $result = 1;
        if ($key =~ /^(!+)(.*)\z/s) {  # starts with exclamation mark(s)
          $key = $2;
          $result = 1 - $result  if (length($1) & 1);  # negate if odd
        }
        ($acl_ip_vec, $acl_mask, $acl_mask_len) = ip_to_vec($key,1);
        if ($acl_mask_len == 0) { $found++ }  # even invalid address matches /0
        elsif (!defined($ip_vec)) {}     # no other matches for invalid address
        elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found++ }
        last  if $found;
      }
    } elsif ($t->isa('Amavis::Lookup::IP')) {  # pre-parsed IP lookup array obj
      my($acl_ip_vec, $acl_mask, $acl_mask_len);
      for my $e (@$t) {
        ($fullkey, $acl_ip_vec, $acl_mask, $acl_mask_len, $result) = @$e;
        if ($acl_mask_len == 0) { $found++ }  # even invalid address matches /0
        elsif (!defined($ip_vec)) {}     # no other matches for invalid address
        elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found++ }
        last  if $found;
      }
    } elsif ($t->isa('Amavis::Lookup::Label')) {  # logging label
      # just a convenience for logging purposes, not a real lookup method
      $label = $t->display;  # grab the name, and proceed with the next table
    } else {
      die "TROUBLE: lookup table is an unknown object: " . ref($t);
    }
    last  if $found;
  }
  $fullkey = $result = undef  if !$found;
  if ($label ne '') { $label = " ($label)" }
  ll(4) && do_log(4, 'lookup_ip_acl%s: key="%s"%s', $label, $ip,
             !$found ? ", no match" : " matches \"$fullkey\", result=$result");
  if ($eval_stat eq '') { $eval_stat = undef }
  else {
    chomp($eval_stat); $eval_stat = "lookup_ip_acl$label: $eval_stat";
    do_log(2, "%s", $eval_stat);
  }
  !wantarray ? $result : ($result, $fullkey, $eval_stat);
}

# create a pre-parsed object from a list of IP networks,
# which may be used as an argument to lookup_ip_acl to speed up its searches
sub new($@) {
  my($class,@nets) = @_;
  my(@list);
  for my $net (@nets) {
    my($key) = $net; my($result) = 1;
    if ($key =~ /^(!+)(.*)\z/s) {  # starts with exclamation mark(s)
      $key = $2;
      $result = 1 - $result  if (length($1) & 1);  # negate if odd
    }
    my($ip_vec, $ip_mask, $ip_mask_len) = ip_to_vec($key,1);
    push(@list, [$net, $ip_vec, $ip_mask, $ip_mask_len, $result]);
  }
  bless \@list, $class;
}

1;

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

# Make an object out of the supplied string, to serve as label
# in log messages generated by sub lookup
sub new($$) { my($class) = shift; my($str) = shift; bless \$str, $class }
sub display($) { my($self) = shift; $$self }

1;

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

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

BEGIN {
  import Amavis::Util qw(ll do_log fmt_struct);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Timing qw(section_time);
  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,$get_all) = @_;
  (ref($hash_ref) eq 'HASH')
    or die "lookup_hash: arg2 must be a hash ref: $hash_ref";
  local($1,$2,$3,$4); my(@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}) {  # got it
      push(@result,$$hash_ref{$key}); push(@matchingkey,$key);
      last  if !$get_all;
    }
  }
  # do the right-hand side replacements if any $n, ${n} or $(n) is specified
  for my $r (@result) {  # remember that $r is just an alias to array elements
    if (!ref($r) && $r=~/\$/) {  # is a plain string containing a '$'
      my($any) = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                        { my($j)=$2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }gxse;
      # bring taintedness of input to the result
      $r .= substr($addr,0,0)  if $any;
    }
  }
  if (!ll(5)) {
    # only bother with logging when needed
  } elsif (!@result) {
    do_log(5,"lookup_hash(%s), no matches", $addr);
  } elsif (!$get_all) {  # first match wins
    do_log(5,'lookup_hash(%s) matches key "%s", result=%s',
              $addr,$matchingkey[0],$result[0]);
  } else {  # want all matches
    do_log(5,"lookup_hash(%s) matches keys: %s", $addr,
              join(', ', map {sprintf('"%s"=>%s',$matchingkey[$_],$result[$_])}
                             (0..$#result)) );
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

# lookup_acl() performs a lookup for an e-mail address against
# access control list.
#
# The supplied e-mail address is compared with each member of the
# lookup 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.
#
# lookup_acl is not aware of address extensions and they are not
# handled specially.
#
# If a list element contains a '@', the full e-mail address is compared,
# otherwise if a list element 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 a list element decides
# whether the result will be true (without a '!') or false (with '!')
# in case this list element 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 a '.' would stop the search and return true, whereas '!.' would stop the
# search and return false (0).
#
# 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,
#   which would only make a difference if this ACL is not the last argument
#   in a call to lookup()
#
# 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: $acl_ref";
  return undef  if !@$acl_ref;  # empty list can't match anything
  my($lpcs) = c('localpart_is_case_sensitive');
  my($localpart,$domain) = split_address($addr); $domain = lc($domain);
  $localpart = lc($localpart)  if !$lpcs;
  local($1,$2);
  # chop off leading @ and trailing dots
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  my($lcaddr) = $localpart . '@' . $domain;
  my($matchingkey, $result); my($found) = 0;
  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
      $found++  if $localpart eq ($lpcs?$1:lc($1)) && $domain eq lc($2);
    } elsif ($key =~ /^\.(.*)\z/s) {   # leading dot: domain or subdomain
      my($key_t) = lc($1);
      $found++  if $domain eq $key_t || $domain =~ /(\.|\z)\Q$key_t\E\z/s;
    } else {                           # match domain (but not its subdomains)
      $found++  if $domain eq lc($key);
    }
    last  if $found;
  }
  $matchingkey = $result = undef  if !$found;
  do_log(5, "lookup_acl(%s)%s", $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 (associative array),
# - (access control) list,
# - a list of regular expressions (an Amavis::Lookup::RE object),
# - 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).
#
# when $get_all is 0 (the common usage):
#   If a match is found (a defined value), returns whatever the map returns,
#   otherwise returns undef. FIRST match aborts further search sequence.
# when $get_all is true:
#   Collects a list of results from ALL matching tables, and within each
#   table from ALL matching key. Returns a ref to the a list of results
#   (and a ref to a list of matching keys if returning a pair).
#   The first element of both lists is supposed to be what lookup() would
#   have returned if $get_all were 0. The order of returned elements
#   corresponds to the order of the search.
#
sub lookup($$@) {
  my($get_all, $addr, @tables) = @_;
  my($label, @result,@matchingkey);
  for my $tb (@tables) {
    my($t) = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
    if (!ref($t) || ref($t) eq 'SCALAR') {   # a scalar always matches
      my($r) = ref($t) ? $$t : $t;  # allow direct or indirect reference
      if (defined $r) {
        do_log(5,'lookup: (scalar) matches, result="%s"', $r);
        push(@result,$r); push(@matchingkey,"(constant:$r)");
      }
    } elsif (ref($t) eq 'HASH') {
      my($r,$mk) = lookup_hash($addr,$t,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif (ref($t) eq 'ARRAY') {
      my($r,$mk) = lookup_acl($addr,$t);
      if (defined $r)   { push(@result,$r);  push(@matchingkey,$mk)  }
    } elsif ($t->isa('Amavis::Lookup::Label')) {  # logging label
      # just a convenience for logging purposes, not a real lookup method
      $label = $t->display;  # grab the name, and proceed with the next table
    } elsif ($t->isa('Amavis::Lookup::RE')) {
      my($r,$mk) = $t->lookup_re($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::SQL')) {
      my($r,$mk) = $t->lookup_sql($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::SQLfield')) {
      my($r,$mk) = $t->lookup_sql_field($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::LDAP')) {
      my($r,$mk) = $t->lookup_ldap($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk) }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::LDAPattr')) {
      my($r,$mk) = $t->lookup_ldap_attr($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk) }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } else {
      die "TROUBLE: lookup table is an unknown object: " . ref($t);
    }
    last  if @result && !$get_all;
  }
  # pretty logging
  if (ll(4)) {  # only bother preparing log report which will be printed
    if (defined $label && $label ne '') { $label = " ($label)" }
    if (!@tables) {
      do_log(4, "lookup%s => undef, %s, no lookup tables",
               $label, fmt_struct($addr));
    } elsif (!@result) {
      do_log(4, "lookup%s => undef, %s does not match",
               $label, fmt_struct($addr));
    } elsif (!$get_all) {  # first match wins
      do_log(4, 'lookup%s => %-6s %s matches, result=%s, matching_key="%s"',
                $label, $result[0] ? 'true,' : 'false,',
                fmt_struct($addr), fmt_struct($result[0]), $matchingkey[0]);
    } else {  # want all matches
      do_log(4, 'lookup%s, %d matches for %s, results: %s',
                $label, scalar(@result), fmt_struct($addr),
                join(', ',map { sprintf('"%s"=>%s',
                                     $matchingkey[$_], fmt_struct($result[$_]))
                              } (0..$#result) ));
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

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

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&expand &tokenize);
}
use subs @EXPORT_OK;
BEGIN {
  import Amavis::Util qw(ll do_log);
}

# Given a string reference and a hashref of predefined (builtin) macros,
# expand() performs a macro expansion and returns a ref to a resulting string.
#
# This is a simple, yet fully fledged macro processor with proper lexical
# analysis, call stack, quoting levels, user supplied and builtin macros,
# three builtin flow-control macros: selector, regexp selector and iterator,
# a macro-defining macro and a macro '#' that eats input to the next newline.
# 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.
# Details are described in file README.customize, practical examples are
# in the supplied notification messages;
#   Author: Mark Martinec <Mark.Martinec@ijs.si>, 2002, 2006

use vars qw(%builtins_cached %lexmap %esc);
use vars qw($lx_lb $lx_lbS $lx_lbT $lx_lbA $lx_lbC $lx_lbE $lx_lbQQ
            $lx_rbQQ $lx_rb $lx_sep $lx_h $lx_ph);

BEGIN {
  no warnings 'qw';  # avoid "Possible attempt to put comments in qw()"
  my(@lx_str) = qw( [  [?  [~  [@  [: [=  ["  "]  ]  |  #  %#
                    %0 %1 %2 %3 %4 %5 %6 %7 %8 %9);  # lexical elem.
  # %lexmap maps string to reference in order to protect lexels
  $lexmap{$_} = \$_  for @lx_str;  # maps lexel strings to references
  ($lx_lb, $lx_lbS, $lx_lbT, $lx_lbA, $lx_lbC, $lx_lbE, $lx_lbQQ, $lx_rbQQ,
   $lx_rb, $lx_sep, $lx_h, $lx_ph) = map { $lexmap{$_} } @lx_str;
  %esc = (n => \"\n", r => "\r", f => "\f", b => "\b",
          e => "\e", a => "\a", t => "\t");
  # NOTE that \n is specific, it is represented by a ref to a newline and not
  # by a newline itself; this makes it possible for a macro '#' to skip input
  # to a true newline from source, making it possible to comment-out entire
  # lines even if containing "\n" tokens
}

# make an object out of the supplied list of tokens
sub newmacro { my($class) = shift; bless [@_], $class }

# turn a list of tokens into a single plain string
sub tokens_list_to_str($) { join('', map {ref($_) ? $$_ : $_ } @{$_[0]}) }

sub tokenize($;$) {
  my($str_ref,$tokens_ref) = @_;
  $tokens_ref = []  if !defined($tokens_ref);
  # parse lexically, replacing lexical element strings with references,
  # unquoting backslash-quoted characters and %%, and dropping \NL and \_
  @$tokens_ref = map {
    exists $lexmap{$_} ? $lexmap{$_}      # replace with ref
    : $_ eq "\\\n" || $_ eq "\\_" ? ''    # drop \NEWLINE and \_
    : /^%%\z/      ? '%'                  # %% -> %
    : /^(%#?.)\z/s ? \"$1"                # unknown builtins
    : /^\\([0-7]{1,3})\z/ ? chr(oct($1))  # \nnn
    : /^\\(.)\z/s ? (exists($esc{$1}) ? $esc{$1} : $1)
    : /^(_ [A-Z]+ (?: \( [^)]* \) )? _)\z/sx ? \"$1"
    : $_ }
    $$str_ref =~ /\G \# | \[ [?~\@:="]? | "\] | \] | \| | % \#? . | \\ [^0-7] |
                  \\ [0-7]{1,3} | _ [A-Z]+ (?: \( [^)]* \) )? _ |
                  [^\[\]\\|%\n#"_]+ | [^\n]+? | \n /gcsx;
  $tokens_ref;
}

sub evalmacro($$;@) {
  my($macro_type,$builtins_href,@args) = @_;
  my(@result);
  if ($macro_type == $lx_lbS) {  # selector built-in macro
    my($sel) = tokens_list_to_str(shift(@args));
    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
    if (@args < 2) {}  # keep $sel beyond $#args
    elsif ($sel > $#args) { $sel = $#args }  # use last alternative
    @result = @{$args[$sel]}  if $sel >= 0 && $sel <= $#args;
  } elsif ($macro_type == $lx_lbT) {  # regexp built-in macro
    my($sel) = tokens_list_to_str(shift(@args));
    my($regexp) = tokens_list_to_str(shift(@args));
    $regexp =~ s{( \@ | \$ (?!\z) )}{\\$1}gsx;  # protect $ and @
    eval { $sel = $sel=~/$regexp/ ? 0 : 1 };    # guard against invalid re
    if ($@ ne '') { $sel = 0; do_log(2,"invalid macro regexp arg: %s",$@) }
    @result = @{$args[$sel]}  if $sel >= 0 && $sel <= $#args;
  } elsif ($macro_type == $lx_lb) {    # iterator macro
    my($cvar_r,$sep_r,$body_r,$cvar);  # give meaning to arguments
    if (@args >= 3) { ($cvar_r,$body_r,$sep_r) = @args }
    else { ($body_r,$sep_r) = @args;  $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($s) = $builtins_href->{$cvar};
      if (ref($s) eq 'Amavis::Expand') {  # no arguments are implied
        $s = tokens_list_to_str([grep { !ref || $$_ !~ /^%([0-9])\z/ } @$s]);
      } elsif (ref($s) eq 'CODE') {
        if (exists($builtins_cached{$cvar})) {
          $s = $builtins_cached{$cvar};
        } else {
          while (ref($s) eq 'CODE') { $s = &$s($cvar) }
          $builtins_cached{$cvar} = $s;
        }
      }
      my($ind) = 0;
      for my $val (ref($s) ? @$s : $s) {
        push(@result, @$sep_r)  if ++$ind > 1 && ref($sep_r);
        push(@result, map {ref && $$_ eq "%$cvar" ? $val : $_} @$body_r);
      }
    }
  } elsif ($macro_type == $lx_lbE) {  # define a new macro
    my($name) = tokens_list_to_str(shift(@args));   # first arg is a macro name
    $name =~ s/^[ \t\n]+//; $name =~ s/[ \t\n]+\z//;  # trim whitespace on name
    delete $builtins_cached{$name};
    $builtins_href->{$name} = Amavis::Expand->newmacro(@{$args[0]});
  } elsif ($macro_type == $lx_lbA || $macro_type == $lx_lbC ||
           $$macro_type =~ /^%(\#)?(.)\z/s) {
    my($name); my($cardinality_only) = 0;
    if ($macro_type == $lx_lbA || $macro_type == $lx_lbC) {
      $name = tokens_list_to_str($args[0]);  # arg %0 is a macro name
      $name =~ s/^[ \t\n]+//; $name =~ s/[ \t\n]+\z//;  # trim whitespace
    } else {  # simple macro call %x or %#x
      $name = $2;
      $cardinality_only = 1  if defined $1;
    }
    my($s) = $builtins_href->{$name};
    if (!ref($s)) {  # macro expands to a plain string
      if (!$cardinality_only) { @result = $s }
      else { @result = $s !~ /^\s*\z/ ? 1 : 0 };  # %#x => nonwhite=1, other 0
    } elsif (ref($s) eq 'Amavis::Expand') {  # dynamically defined macro
      $args[0] = $name;  # replace name with a stringified and trimmed form
      # expanding a dynamically-defined macro produces a list of tokens;
      # formal argument lexels %0, %1, ... %9 are replaced by actual arguments
      @result = map { !ref || $$_ !~ /^%([0-9])\z/ ? $_
                      : ref($args[$1]) ? @{$args[$1]} : () } @$s;
      if ($cardinality_only) {  # macro call form %#x
        @result = tokens_list_to_str(\@result) !~ /^\s*\z/ ? 1 : 0;
      }
    } else {  # subroutine or array ref
      if (ref($s) eq 'CODE') {
        if (exists($builtins_cached{$name}) && @args <= 1) {
          $s = $builtins_cached{$name};
        } elsif (@args <= 1) {
          while (ref($s) eq 'CODE') { $s = &$s($name) }  # callback
          $builtins_cached{$name} = $s;
        } else {
          shift(@args);  # discard original form of a macro name
          while (ref($s) eq 'CODE')  # subroutine callback
            { $s = &$s($name, map { tokens_list_to_str($_) } @args) }
        }
      }
      if ($cardinality_only) {  # macro call form %#x
        # for array: number of elements; for scalar: nonwhite=1, other 0
        @result = ref($s) ? scalar(@$s) : $s !~ /^\s*\z/ ? 1 : 0;
      } else {  # macro call %x evaluates to the value of macro x
        @result = ref($s) ? join(', ',@$s) : $s;
      }
    }
  }
  \@result;
}

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(@tokens);
  if (ref($str_ref) eq 'ARRAY') { @tokens = @$str_ref }
  else { tokenize($str_ref,\@tokens) }
  my($call_level) = 0; my($quote_level) = 0;
  my(@arg);  # stack of arguments lists to nested calls, [0] is top of stack
  my(@macro_type); # call stack of macro types (leading lexels) of nested calls
  my(@implied_q);  # call stack: is implied quoting currently active?
                   #   0 (not active) or 1 (active); element [0] stack top
  my(@open_quote); # quoting stack: opening quote lexel for each quoting level
  %builtins_cached = (); my($output_str) = ''; my($whereto);
  while (@tokens) {
    my($t) = shift(@tokens);
    # do_log(5, "TOKEN: %s", ref($t) ? "<$$t>" : "'$t'");
    if (!ref($t)) {  # a plain string, no need to check for quoting levels
      if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $t }
    } elsif ($quote_level > 0 && $$t =~ /^\[/) {  # go even deeper into quoting
      $quote_level += ($t == $lx_lbQQ) ? 2 : 1;  unshift(@open_quote,$t);
      if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t }
    } elsif ($t == $lx_lbQQ) {  # just entering a [" ... "] quoting context
      $quote_level += 2; unshift(@open_quote,$t);
      # drop a [" , thus stripping one level of quotes
    } elsif ($$t =~ /^\[/) {  # $lx_lb $lx_lbS lx_lbT $lx_lbA $lx_lbC $lx_lbE
      $call_level++;  # open a macro call, start collecting arguments
      unshift(@arg, [[]]); unshift(@macro_type, $t); unshift(@implied_q, 0);
      $whereto = $arg[0][0];
      if ($t == $lx_lb) {  # iterator macro implicitly quotes all arguments
        $quote_level++; unshift(@open_quote,$t); $implied_q[0] = 1;
      }
    } elsif ($quote_level <= 1 && $call_level>0 && $t == $lx_sep) {  # next arg
      unshift(@{$arg[0]}, []); $whereto = $arg[0][0];
      if ($macro_type[0]==$lx_lbS && @{$arg[0]} == 2) {
        # selector macro implicitly quotes arguments beyond first argument
        $quote_level++; unshift(@open_quote,$macro_type[0]); $implied_q[0] = 1;
      }
    } elsif ($quote_level > 1 && ($t == $lx_rb || $t == $lx_rbQQ)) {
      $quote_level -= ($open_quote[0] == $lx_lbQQ) ? 2 : 1;
      shift(@open_quote);  # pop the quoting stack
      if ($t == $lx_rb || $quote_level > 0) {  # pass-on if still quoted
        if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t}
      }
    } elsif ($call_level > 0 && ($t == $lx_rb || $t == $lx_rbQQ)) {  # evaluate
      $call_level--;  my($m_type) = $macro_type[0];
      if ($t == $lx_rbQQ) {  # fudge for compatibility: treat "] as two chars
        if (defined $whereto) { push(@$whereto,'"') } else { $output_str.='"' }
      }
      if ($implied_q[0] && $quote_level > 0) {
        $quote_level -= ($open_quote[0] == $lx_lbQQ) ? 2 : 1;
        shift(@open_quote);  # pop the quoting stack
      }
      my($result_ref) = evalmacro($m_type, $builtins_href, reverse @{$arg[0]});
      shift(@macro_type); shift(@arg); shift(@implied_q);  # pop the call stack
      $whereto = $call_level > 0 ? $arg[0][0] : undef;
      if ($m_type == $lx_lbC) {  # neutral macro call, result implicitly quoted
        if (defined $whereto) { push(@$whereto, @$result_ref) }
        else { $output_str .= tokens_list_to_str($result_ref) }
      } else {  # active macro call, push result back to input for reprocessing
        unshift(@tokens, @$result_ref);
      }
    } elsif ($quote_level > 0 ) {  # still protect %x and # macro calls
      if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t }
    } elsif ($t == $lx_h) {  # discard tokens to and including a newline
      while (@tokens) { last  if shift(@tokens) eq "\n" }
    } elsif ($$t =~ /^%\#?.\z/s) {  # neutral simple macro call %x or %#x
      my($result_ref) = evalmacro($t, $builtins_href);
      if (defined $whereto) { push(@$whereto,@$result_ref) }
#     else { $output_str .= tokens_list_to_str($result_ref) }
      else { $output_str .= join('', map {ref($_) ? $$_ : $_ } @$result_ref) }
    } elsif ($$t =~ /^_ ([A-Z]+) (?: \( ( [^)]* ) \) )? _\z/sx) {
      # neutral simple SA-like macro call, $1 is name, $2 is a single! argument
      my($result_ref) = evalmacro($lx_lbC, $builtins_href, [$1],
                                  !defined($2) ? () : [$2] );
      if (defined $whereto) { push(@$whereto, @$result_ref) }
      else { $output_str .= tokens_list_to_str($result_ref) }
    } else {  # misplaced top-level lexical element
      if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t }
    }
  }
  %builtins_cached = ();  # free memory
  \$output_str;
}

1;

#
package Amavis::TempDir;

# Handles creation and cleanup of persistent temporary directory
# and email.txt file

use strict;
use re 'taint';

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

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

BEGIN {
  import Amavis::Conf qw(:confvars :platform);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(do_log add_entropy rmdir_recursively);
  import Amavis::rfc2821_2822_Tools qw(iso8601_timestamp);
}

sub new {
  my($class) = @_;
  my($self) = bless {}, $class;
  $self->{tempdir_path} = undef;
  $self->{tempdir_dev} = $self->{tempdir_ino} = undef;
  $self->{fh_pers} = undef;
  $self->{fh_dev} = $self->{fh_ino} = undef;
  $self->{empty} = 1;
  $self->{preserve} = 0;
  $self;
}

sub path {     # Temporary directory path
  my($self)=shift; !@_ ? $self->{tempdir_path} : ($self->{tempdir_path}=shift)
}
sub fh         # email.txt file handle
  { my($self)=shift; !@_ ? $self->{fh_pers} : ($self->{fh_pers}=shift) }
sub empty {    # Whether the directory is empty
  my($self)=shift; !@_ ? $self->{empty} : ($self->{empty}=shift)
}
sub preserve   # Whether to preserve directory when current task is done
  { my($self)=shift; !@_ ? $self->{preserve} : ($self->{preserve}=shift) }

# Clean up the tempdir on shutdown
sub DESTROY {
  my($self) = shift;
  eval { do_log(5,"Amavis::TempDir::DESTROY called") };
  eval {
    $self->{fh_pers}->close
      or die "Error closing temp file: $!"  if $self->{fh_pers};
    $self->{fh_pers} = undef;
    my($errn) = $self->{tempdir_path} eq '' ? ENOENT
                  : (stat($self->{tempdir_path}) ? 0 : 0+$!);
    if (defined $self->{tempdir_path} && $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} && !$self->{empty}) {
        do_log(-1,"TempDir removal: tempdir is to be PRESERVED: %s",
                  $self->{tempdir_path});
      } else {
        do_log(3, "TempDir removal: %s is being removed: %s%s",
                  $self->{empty} ? 'empty tempdir' : 'tempdir',
                  $self->{tempdir_path},
                  $self->{preserve} ? ', nothing to preserve' : '');
        rmdir_recursively($self->{tempdir_path});
      }
    }
  };
  if ($@ ne '')
    { my($eval_stat) = $@; eval { do_log(1,"TempDir removal: %s",$eval_stat) }}
}

# Creates the temporary directory, and checks that inode does not change
sub prepare {
  my($self) = @_;
  if (! defined $self->{tempdir_path} ) {
    # invent a name for a temporary directory for this child, and create it
    my($now_iso8601) = iso8601_timestamp(time,1);  # or: iso8601_utc_timestamp
    $self->{tempdir_path} = sprintf("%s/amavis-%s-%05d",
                                     $TEMPBASE, $now_iso8601, $$);
  }
  my($dname) = $self->{tempdir_path};
  my(@stat_list) = lstat($dname); my($errn) = @stat_list ? 0 : 0+$!;
  if ($errn==0 && ! -d _) {  # exists, but is not a directory !?
    die "TempDir::prepare: $dname is not a directory!!!";
  } elsif ($errn==0) {
    my($dev,$ino) = @stat_list;
    if ($dev != $self->{tempdir_dev} || $ino != $self->{tempdir_ino}) {
      do_log(-1,"TempDir::prepare: %s is no longer the same directory!!!",
                $dname);
      ($self->{tempdir_dev},$self->{tempdir_ino}) = @stat_list;
    }
  } elsif ($errn == ENOENT) {
    do_log(4,"TempDir::prepare: creating directory %s", $dname);
    mkdir($dname,0750) or die "Can't create directory $dname: $!";
    @stat_list = lstat($dname); add_entropy(@stat_list);
    ($self->{tempdir_dev},$self->{tempdir_ino}) = @stat_list;
    $self->{empty} = 1;
    section_time('mkdir tempdir');
  }
}

# Prepares the email.txt temporary file for writing (and reading later)
sub prepare_file {
  my($self) = @_;
  my($fname) = $self->path . '/email.txt';
  my(@stat_list) = lstat($fname); my($errn) = @stat_list ? 0 : 0+$!;
  if ($errn == ENOENT) {  # no file
    do_log(0,"%s no longer exists, can't re-use it",
              $fname)  if $self->{fh_pers};
    $self->{fh_pers} = undef;
  } elsif ($errn) {   # some other error
    die "TempDir::prepare_file: can't access $fname: $!";
    $self->{fh_pers} = undef;
  } elsif (! -f _) {  # not a regular file !?
    die "TempDir::prepare_file: $fname is not a regular file!!!";
    $self->{fh_pers} = undef;
  } elsif ($self->{fh_pers}) {
    my($dev,$ino) = @stat_list;
    if ($dev != $self->{file_dev} || $ino != $self->{file_ino}) {
      # may happen if some user code has replaced the file, e.g. by altermime
      do_log(1,"%s is no longer the same file, won't re-use it, deleting",
               $fname);
      unlink($fname) or die "Can't remove file $fname: $!";
      $self->{fh_pers} = undef;
    }
  }
  if ($self->{fh_pers}) {
    $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,"TempDir::prepare_file: creating file %s", $fname);
    $self->{fh_pers} = IO::File->new($fname,'+>',0640)
      or die "Can't create file $fname: $!";
    @stat_list = lstat($fname); add_entropy(@stat_list);
    ($self->{file_dev}, $self->{file_ino}) = @stat_list;
    section_time('create email.txt');
  }
}

# Cleans the temporary directory for reuse, unless it is set to be preserved
sub clean {
  my($self) = @_;
  if ($self->{preserve} && !$self->{empty}) {
    # keep evidence in case of trouble
    do_log(-1,"PRESERVING EVIDENCE in %s", $self->{tempdir_path});
    if ($self->{fh_pers}) {
      $self->{fh_pers}->close or die "Error closing mail file: $!"
    }
    $self->{fh_pers} = undef; $self->{tempdir_path} = undef;
    $self->{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 "Error closing mail file: $!";
    $self->{fh_pers} = undef;
    unlink($self->{tempdir_path}.'/email.txt')
      or die "Can't delete file ".$self->{tempdir_path}."/email.txt: $!";
    section_time('delete email.txt');
  }
  if (defined $self->{tempdir_path}) {  # prepare for the next one
    $self->strip; $self->{empty} = 1;
  }
  $self->{preserve} = 0; # reset
}

# 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 {
  my($self) = shift;
  my ($dir) = $self->{tempdir_path};
  do_log(4, "TempDir::strip: %s", $dir);
  my($errn) = lstat("$dir/parts") ? 0 : 0+$!;
  if ($errn == ENOENT) {}  # fine, no such directory
  elsif ($errn != 0) { die "TempDir::strip: error accessing $dir/parts: $!" }
  elsif ( -l _) { die "TempDir::strip: $dir/parts is a symbolic link" }
  elsif (!-d _) { die "TempDir::strip: $dir/parts is not a directory" }
  else { rmdir_recursively("$dir/parts", 1) }
  # All done. Check for any remains in the top directory just in case
  $self->check;
  1;
}

# Checks tempdir after being cleaned.
# It may only contain subdirectory 'parts' and file email.txt, nothing else.
#
sub check {
  my($self) = shift;
  my($dir) = $self->{tempdir_path};
  local(*DIR); opendir(DIR,$dir) or die "Can't open directory $dir: $!";
  eval {
    $! = 0; my($f);
    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";
      }
    }
  # $!==0 or die "Error reading directory $dir: $!";
  };
  closedir(DIR) or die "Error closing directory $dir: $!";
  if ($@ ne '') { chomp($@); die "TempDir::check: $@\n" }
  1;
}

1;

#
package Amavis::IO::Zlib;

# A simple IO::File -compatible wrapper around Compress::Zlib,
# much like IO::Zlib but simpler: does only what we need and does it carefully

use strict;
use re 'taint';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
}
use Errno qw(EIO);
use Compress::Zlib;

sub new {
  my($class) = shift;  my($self) = bless {}, $class;
  if (@_) { $self->open(@_) or return undef }
  $self;
}

sub close {
  my($self) = shift;
  my($status); eval { $status = $self->{fh}->gzclose }; delete $self->{fh};
  if ($status != Z_OK || $@ ne '') {
    die "gzclose error: $gzerrno";  # can't stash arbitrary text into $!
    $! = EIO; return undef;  # not reached
  }
  1;
}

sub DESTROY {
  my($self) = shift;
  if (ref $self && $self->{fh}) { eval { $self->close } }
}

sub open {
  my($self,$fname,$mode) = @_;
  delete $self->{fh};
  $self->{fname} = $fname; $self->{mode} = $mode; $self->{pos} = 0;
  my($gz) = gzopen($fname,$mode);
  if ($gz) { $self->{fh} = $gz }
  else {
    die "gzopen error: $gzerrno";  # can't stash arbitrary text into $!
    $! = EIO; undef $gz;  # not reached
  }
  $gz;
}

sub seek {
  my($self,$pos,$whence) = @_;
  $whence==0 && $pos==0
    or die "Seek to $whence,$pos on gzipped file not supported";
  $self->{mode} eq 'rb'
    or die "Seek to $whence,$pos on gzipped file only supported for 'rb' mode";
  if ($self->{pos}==0) { 1 }  # already there
  else { $self->close; $self->open($self->{fname},$self->{mode}) }
}

sub read {  # SCALAR,LENGTH,OFFSET
  my($self) = shift;  $self->{pos} = 1;
  !defined($_[2]) || $_[2]==0
    or die "Reading gzipped file to an offset not supported";
  my($nbytes) = $self->{fh}->gzread($_[0], defined $_[1] ? $_[1] : 4096);
  if ($nbytes < 0) {
    die "gzread error: $gzerrno";  # can't stash arbitrary text into $!
    $! = EIO; undef $nbytes;  # not reached
  }
  $nbytes;   # eof: 0;  error: undef
}

sub getline {
  my($self) = shift;  $self->{pos} = 1;  my($nbytes,$line);
  $nbytes = $self->{fh}->gzreadline($line);
  if ($nbytes <= 0) {  # eof (0) or error (-1)
    $! = 0; undef $line;
    if ($nbytes < 0 && $gzerrno != Z_STREAM_END) {
      die "gzreadline error: $gzerrno";  # can't stash arbitrary text into $!
      $! = EIO;  # not reached
    }
  }
  $line;  # eof: undef, $! zero;  error: undef, $! nonzero
}

sub print {
  my($self) = shift;
  my($nbytes); my($len) = length($_[0]);
  if ($len <= 0) { $nbytes = "0 but true" }
  else {
    $self->{pos} = 1; $nbytes = $self->{fh}->gzwrite($_[0]);
    if ($nbytes <= 0) {
      die "gzwrite error: $gzerrno";  # can't stash arbitrary text into $!
      $! = EIO; undef $nbytes;  # not reached
    }
  }
  $nbytes;
}

sub printf { shift->print(sprintf(shift,@_)) }

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.062';
  @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(A|S|SA)/LMTP(A|S|SA) # rfc3848, or QMQP/QMQPqq
  { 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.062';
  @ISA = qw(Exporter);
}

BEGIN {
  import Amavis::Conf qw(:platform);
}

sub new     # NOTE: this class is a list for historical reasons, not a hash
  { my($class) = @_; bless [(undef) x 21], $class }

# subs to set or access individual elements of a n-tuple by name
sub recip_addr       # raw (unquoted) recipient envelope e-mail address
  { my($self)=shift; !@_ ? $$self[0] : ($$self[0]=shift) }
sub recip_addr_modified  # recip. addr. with possible addr. extension inserted
  { my($self)=shift; !@_ ? $$self[1] : ($$self[1]=shift) }
sub dsn_notify       # ESMTP RCPT command NOTIFY option (DSN-rfc3461, listref)
  { my($self)=shift; !@_ ? $$self[2] : ($$self[2]=shift) }
sub dsn_orcpt        # ESMTP RCPT command ORCPT option  (DSN-rfc3461, encoded)
  { my($self)=shift; !@_ ? $$self[3] : ($$self[3]=shift) }
sub dsn_suppress_reason  # if defined disable sending DSN and supply a reason
  { my($self)=shift; !@_ ? $$self[4] : ($$self[4]=shift) }
sub recip_destiny    # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
  { my($self)=shift; !@_ ? $$self[5] : ($$self[5]=shift) }
sub recip_done       # false: not done, true: done (1: faked, 2: truly sent)
  { my($self)=shift; !@_ ? $$self[6] : ($$self[6]=shift) }
sub recip_smtp_response # rfc2821 response (3-digit + enhanced resp + text)
  { my($self)=shift; !@_ ? $$self[7] : ($$self[7]=shift) }
sub recip_remote_mta_smtp_response  # smtp response as issued by remote MTA
  { my($self)=shift; !@_ ? $$self[8] : ($$self[8]=shift) }
sub recip_remote_mta # remote MTA that issued the smtp response
  { my($self)=shift; !@_ ? $$self[9] : ($$self[9]=shift) }
sub recip_mbxname    # mailbox name or file when known (local:, bsmtp: or sql:)
  { my($self)=shift; !@_ ? $$self[10] : ($$self[10]=shift) }
sub recip_whitelisted_sender  # recip considers this sender whitelisted (> 0)
  { my($self)=shift; !@_ ? $$self[11] : ($$self[11]=shift) }
sub recip_blacklisted_sender  # recip considers this sender blacklisted
  { my($self)=shift; !@_ ? $$self[12] : ($$self[12]=shift) }
sub recip_score_boost  # recip adds penalty spam points to the final score
  { my($self)=shift; !@_ ? $$self[13] : ($$self[13]=shift) }
sub infected        # contains a virus (1); check bypassed (undef); clean (0)
  { my($self)=shift; !@_ ? $$self[14] : ($$self[14]=shift) }
sub banned_parts    # banned part descriptions (ref to a list of banned parts)
  { my($self)=shift; !@_ ? $$self[15] : ($$self[15]=shift) }
sub banned_keys     # keys of matching banned rules (a ref to a list)
  { my($self)=shift; !@_ ? $$self[16] : ($$self[16]=shift) }
sub banned_rhs      # right-hand side of matching rules (a ref to a list)
  { my($self)=shift; !@_ ? $$self[17] : ($$self[17]=shift) }
sub contents_category # sorted listref of "major,minor" strings(category types)
  { my($self)=shift; !@_ ? $$self[18] : ($$self[18]=shift) }
sub courier_control_file # path to control file containing this recipient
  { my($self)=shift; !@_ ? $$self[19] : ($$self[19]=shift) }
sub courier_recip_index # index of recipient within control file
  { my($self)=shift; !@_ ? $$self[20] : ($$self[20]=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;
}

# compare numerically two strings of the form "maj,min" or just "maj", where
# maj and min are numbers, representing major and minor contents categery
sub cmp_ccat($$) {
  my($a_maj,$a_min) = split(/,/, shift, -1);
  my($b_maj,$b_min) = split(/,/, shift, -1);
  $a_maj == $b_maj ? $a_min <=> $b_min : $a_maj <=> $b_maj;
}

# The contents_category list is a sorted list of strings, each of the form
# "major" or "major,minor", where major and minor are numbers, representing
# major and minor category type. Sort order is descending by numeric values,
# major first, and subordered by a minor value. When an entry "major,minor"
# is added, an entry "major" is added automatically (minor implied to be 0).
# A string "major" means the same as "major,0". See CC_* constants for major
# category types. Minor category types semantics is specific to each major
# category, higher number represent more important finding than a lower number.

# add new findings to the contents_category list
sub add_contents_category {
  my($self) = shift; my($major,$minor) = @_;
  my($aref) = $self->contents_category || [];
  # major category is always inserted, but "$major,$minor" only if minor>0
  if (defined $minor && $minor > 0) {  # straight insertion of "$major,$minor"
    my($el) = sprintf("%d,%d",$major,$minor); my($j)=0;
    for (@$aref) { if (cmp_ccat($_,$el) <= 0) { last } else { $j++ } };
    if ($j > $#{$aref}) { push(@$aref,$el) }  # append
    elsif (cmp_ccat($aref->[$j],$el) != 0) { splice(@$aref,$j,0,$el) }
  }
  # straight insertion of "$major" into an ordered array (descending order)
  my($el) = sprintf("%d",$major); my($j)=0;
  for (@$aref) { if (cmp_ccat($_,$el) <= 0) { last } else { $j++ } };
  if ($j > $#{$aref}) { push(@$aref,$el) }  # append
  elsif (cmp_ccat($aref->[$j],$el) != 0)
    { splice(@$aref,$j,0,$el) }  # insert at index $j
  $self->contents_category($aref);
}

# get the most relevant contents category (max number from the sorted array)
sub main_contents_category {
  my($self) = shift;  my($major,$minor);
  my($aref) = $self->contents_category;  # first element has the largest value
  ($major,$minor) = split(/,/, $aref->[0], -1)  if defined $aref;
  !wantarray ? $major : ($major,$minor);
}

# is the "$major,$minor" category in the list?
sub is_in_contents_category {
  my($self) = shift; my($major,$minor) = @_;
  my($el) = sprintf("%d,%d",$major,$minor);
  my($aref) = $self->contents_category;
  !defined($aref) ? undef : scalar(grep { cmp_ccat($_,$el) == 0 } @$aref);
}

# get a setting corresponding to the most important contents category;
# i.e. the highest entry from the category list for which a corresponding entry
# in the associative array of settings exists determines returned setting;
sub setting_by_contents_category($$) {
  my($self) = shift; my($settings_href) = @_; my($r);
  if (!defined($settings_href)) {
    # no settings specified, returns undef regardless of contents
  } elsif (ref($settings_href) eq 'HASH') {
    my($aref) = $self->contents_category;
    for my $e ( (!defined($aref) ? () : @$aref), CC_CATCHALL) {
      if (exists($settings_href->{$e})) { $r = $settings_href->{$e}; last }
    }
  } else {
    die "setting_by_contents_category: unexpected ref: ".ref($settings_href);
  }
  if (ref($r) eq 'CODE') { $r = &$r }   # support lazy evaluation
  $r;
}

1;

#
package Amavis::In::Message;
# this class contains 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.062';
  @ISA = qw(Exporter);
}

BEGIN {
  import Amavis::Conf qw(:platform);
  import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp quote_rfc2821_local);
  import Amavis::Util qw(xtext_encode);
  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 client_os_fingerprint  # SMTP client's OS fingerprint, obtained from p0f
  { my($self)=shift; !@_ ? $self->{cli_p0f} : ($self->{cli_p0f}=shift) }
sub queue_id        # MTA queue ID of message if known (Courier, milter/AM.PDP)
  { my($self)=shift; !@_ ? $self->{queue_id}   : ($self->{queue_id}=shift) }
sub mail_id         # some long-term unique id of the message on this system
  { my($self)=shift; !@_ ? $self->{mail_id}    : ($self->{mail_id}=shift) }
sub secret_id       # secret string to grant access to message with mail_id
  { my($self)=shift; !@_ ? $self->{secret_id}  : ($self->{secret_id}=shift) }
sub msg_size        # ESMTP SIZE value, later corrected by actual message size
  { 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 (addr-spec or "<>")
  { my($self)=shift; !@_ ? $self->{auth_subm}  : ($self->{auth_subm}=shift) }
sub dsn_ret         # ESMTP MAIL command RET option   (DSN-rfc3461)
  { my($self)=shift; !@_ ? $self->{dsn_ret}  : ($self->{dsn_ret}=shift) }
sub dsn_envid       # ESMTP MAIL command ENVID option (DSN-rfc3461) xtext enc.
  { my($self)=shift; !@_ ? $self->{dsn_envid}  : ($self->{dsn_envid}=shift) }
sub dsn_passed_on   # obligation to send notification on SUCCESS was relayed
  { my($self)=shift; !@_ ? $self->{dsn_pass_on}: ($self->{dsn_pass_on}=shift) }
sub requested_by    # Resent-From addr who requested release from a quarantine
  { my($self)=shift; !@_ ? $self->{requested_by}:($self->{requested_by}=shift)}
sub body_type       # ESMTP BODY param (rfc1652: 7BIT, 8BITMIME) or BINARYMIME
  { 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_text_fn    # orig. mail filename or undef, e.g. mail_tempdir/email.txt
  { my($self)=shift; !@_ ? $self->{mailtextfn} : ($self->{mailtextfn}=shift) }
sub mail_tempdir    # work directory, under $TEMPBASE or supplied by client
  { my($self)=shift; !@_ ? $self->{mailtempdir} : ($self->{mailtempdir}=shift)}
sub header_edits    # Amavis::Out::EditHeader object or undef
  { my($self)=shift; !@_ ? $self->{hdr_edits}  : ($self->{hdr_edits}=shift) }
sub orig_header_fields # some orig. header fields (first occurence) - a hashref
  { my($self)=shift; !@_ ? $self->{orig_hdr_f}: ($self->{orig_hdr_f}=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 (in bytes)
  { my($self)=shift; !@_ ? $self->{orig_hdr_s} : ($self->{orig_hdr_s}=shift) }
sub orig_body_size  # size of original body (in bytes)
  { my($self)=shift; !@_ ? $self->{orig_bdy_s} : ($self->{orig_bdy_s}=shift) }
sub body_digest     # message digest of a message body (e.g. MD5 or SHA1)
  { my($self)=shift; !@_ ? $self->{body_digest}: ($self->{body_digest}=shift) }
sub quarantined_to  # list of quar mailbox names or addresses if quarantined
  { my($self)=shift; !@_ ? $self->{quarantine} : ($self->{quarantine}=shift) }
sub quar_type     # quarantine type: F/Z/B/Q/M (file/zipfile/bsmtp/sql/mailbox)
  { my($self)=shift; !@_ ? $self->{quar_type}  : ($self->{quar_type}=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->{deliv_method}:($self->{deliv_method}=shift)}
sub client_delete   # don't delete the tempdir, it is a client's reponsibility
  { my($self)=shift; !@_ ? $self->{client_del} :($self->{client_del}=shift)}
sub contents_category # sorted arrayref of numbers CC_VIRUS/CC_BANNED/CC_SPAM..
  { my($self)=shift; !@_ ? $self->{category}   : ($self->{category}=shift) }
sub spam_level
  { my($self)=shift; !@_ ? $self->{spam_level}  :($self->{spam_level}=shift)}
sub spam_status # names+score of tests as returned by SA get_tag('TESTSSCORES')
  { my($self)=shift; !@_ ? $self->{spam_status} :($self->{spam_status}=shift)}
sub spam_report     # SA terse report of tests hit (for header reports)
  { my($self)=shift; !@_ ? $self->{spam_report} :($self->{spam_report}=shift)}
sub spam_summary    # SA summary of tests hit for standard body reports
  { my($self)=shift; !@_ ? $self->{spam_summary}:($self->{spam_summary}=shift)}
sub autolearn_status
  { my($self)=shift; !@_ ? $self->{a_learn_stat}:($self->{a_learn_stat}=shift)}

*add_contents_category =
  \&Amavis::In::Message::PerRecip::add_contents_category;
*main_contents_category =
  \&Amavis::In::Message::PerRecip::main_contents_category;
*is_in_contents_category =
  \&Amavis::In::Message::PerRecip::is_in_contents_category;
*setting_by_contents_category =
  \&Amavis::In::Message::PerRecip::setting_by_contents_category;

# 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 to be able
# to produce correct per-recipient responses to a LMTP client!
#
sub per_recip_data {  # get or set a listref of envelope recipient n-tuples
  my($self) = shift;
  # store a copy of the given listref of recip objects
  if (@_) { @{$self->{recips}} = @{$_[0]} }
  # return a listref to the original n-tuples,
  # caller may modify 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
    my($recips_list_ref, $set_dsn_orcpt_too) = @_;
    # 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->dsn_orcpt(
        'rfc822;'.xtext_encode(quote_rfc2821_local($_))) if $set_dsn_orcpt_too;
      $per_recip_obj->recip_destiny(D_PASS);  # default is Pass
      $per_recip_obj } @{$recips_list_ref} ]);
  }
  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.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&hdr);
}

BEGIN {
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools qw(wrap_string);
  import Amavis::Util qw(ll do_log safe_encode q_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 append_header_above_received($$$;$) {
  my($self, $field_name, $field_body, $structured) = @_;
  push(@{$self->{addrcvd}}, hdr($field_name,$field_body,$structured));
}

sub add_header($$$;$) {
  my($self, $field_name, $field_body, $structured) = @_;
  push(@{$self->{add}}, hdr($field_name,$field_body,$structured));
}

# delete all header fields with $field_name
sub delete_header($$) {
  my($self, $field_name) = @_;
  $self->{edit}{lc($field_name)} = [undef];
}

# all header fields with $field_name will be edited by a supplied subroutine
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";
  $field_name = lc($field_name);
  if (!exists($self->{edit}{$field_name})) {
    $self->{edit}{$field_name} = [$field_edit_sub];
  } else {
    do_log(2, "INFO: iterative header editing: %s", $field_name);
    push(@{$self->{edit}{$field_name}}, $field_edit_sub);
  }
}

# copy all header edits from another header-edits object into this one
sub inherit_header_edits($$) {
  my($self, $other_edits) = @_;
  if (defined $other_edits) {
    for (qw(prepend addrcvd add append))
      { unshift(@{$self->{$_}}, @{$other_edits->{$_}})  if $other_edits->{$_} }
    if ($other_edits->{edit}) {
      for (keys %{$other_edits->{edit}}) 
        { $self->{edit}{$_} = [ @{$other_edits->{edit}{$_}} ] }  # list copy
    }
  }
}

# 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==0 indicates an unstructured header field,
# folding may be inserted at any existing whitespace character position;
# $structured==1 indicates that folding is only allowed at positions
# indicated by \n in the provided header body, original \n will be removed.
# With $structured==2 folding is preserved, wrapping step is skipped.
#
sub hdr($$$;$) {
  my($field_name, $field_body, $structured, $wrap_char) = @_;
  $wrap_char = "\t"  if !defined($wrap_char);
  if ($field_name =~ /^(X-.*|Subject|Comments)\z/si &&
      $field_body =~ /[^\011\012\040-\176]/ #any nonprintable except TAB and LF
  ) {  # encode according to RFC 2047
    $field_body =~ s/\n([ \t])/$1/g;  # unfold
    chomp($field_body);
    my($field_body_octets);
    if (!$unicode_aware) { $field_body_octets = $field_body }
    else {
      $field_body_octets = safe_encode(c('hdr_encoding'), $field_body);
#     do_log(5, "hdr - UTF-8 body:  %s", $field_body);
#     do_log(5, "hdr - body octets: %s", $field_body_octets);
    }
    my($qb) = c('hdr_encoding_qb');
    if (uc($qb) eq 'Q') {
      $field_body = q_encode($field_body_octets, $qb, c('hdr_encoding'));
    } else {
      $field_body = MIME::Words::encode_mimeword($field_body_octets,
                                                 $qb, c('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\n]/;
  $str .= $field_body;
  if ($structured == 2) {  # already folded, keep it that way, sanitize
    1 while $str =~ s/^([ \t]*)\n/$1/;  # prefixed by whitespace lines?
    $str =~ s/\n(?=[ \t]*(\n|\z))//g;   # whitespace lines within or at end
    $str =~ s/\n(?![ \t])/\n /g;  # insert a space at line folds if missing
  } else {
    $wrap_char = "\t"  if !defined($wrap_char);
    $str = wrap_string($str, 78, '', $wrap_char, $structured
                      )  if $structured==1 || length($str) > 78;
  }
  if (length($str) > 998) {
    my(@lines) = split(/\n/,$str);  my($trunc) = 0;
    for (@lines)
      { if (length($_) > 998) { $_ = substr($_,0,998-3).'...'; $trunc = 1 } }
    if ($trunc) {
      do_log(0, "INFO: truncating long header field (len=%d): %s...",
             length($str), substr($str,0,100) );
      $str = join("\n",@lines);
    }
  }
  $str .= "\n"  if $str !~ /\n\z/;  # append final NL
  do_log(5, "header: %s", $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, $fix_whitespace_headers) = @_;
  $fix_whitespace_headers = 0  if $fix_whitespace_headers &&
                                  !c('allow_fixing_improper_header_folding');
  my($is_mime) = ref($msg) && $msg->isa('MIME::Entity') ? 1 : 0;
  do_log(5, "write_header: %s, %s", $is_mime,$out_fh);
  $out_fh = IO::Wrap::wraphandle($out_fh);  # assure an IO::Handle-like obj
  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 (!c('append_header_fields_to_bottom'))
    { for (@{$self->{add}}) { $str .= $_ } }
  for (@{$self->{addrcvd}}) { $str .= $_ }
  if ($str ne '') { $out_fh->print($str) or die "sending mail header1: $!" }
  if (!defined($msg)) {
    # existing header empty
  } else {
    push(@header, $eol)  if $is_mime;  # append empty line as end-of-header
    local($1,$2); my($curr_head,$next_head); my($illcnt) = 0; $! = 0;
    while (defined($next_head = $is_mime ? shift @header : $msg->getline)) {
      if ($next_head =~ /^[ \t]/) { $curr_head .= $next_head }  # folded
      else {  # new header
        if (!defined($curr_head)) {
          # no previous complete header field (we are at first header field)
        } elsif ($curr_head !~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s) {  # parse
          # invalid header, but we'll write it anyway
        } else {  # count, edit, or delete
          # note that 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})) {}  # keep unchanged
          else {
            chomp($field_body);
            ### $field_body =~ s/\n([ \t])/$1/g;  # unfold
            my($edit) = $self->{edit}{$field_name_lc};    # listref of edits
            for my $e (@$edit) {  # possibly multiple (iterative) edits
              if (!defined($e)) { undef($curr_head); last }  # delete
              $curr_head = hdr($field_name, &$e($field_name,$field_body), 0);
              $curr_head =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s;
              $field_body = $2; chomp($field_body);
            }
          }
        }
        if (defined $curr_head) {
          if ($fix_whitespace_headers) {
            # unfold illegal all-whitespace continuation lines
            $curr_head =~ s/\n(?=[ \t]*\n)//g  and $illcnt++;
          }
          $out_fh->print($curr_head) or die "sending mail header2: $!";
        }
        last  if $next_head eq $eol;  # end-of-header reached
        $curr_head = $next_head;
      }
      $! = 0;
    }
    defined $next_head || $is_mime || $!==0
      or die "Error reading mail header: $!";
    do_log(0, "INFO: unfolded %d illegal all-whitespace ".
              "continuation lines", $illcnt)  if $illcnt;
  }
  $str = '';
  if (c('append_header_fields_to_bottom'))
    { for (@{$self->{add}}) { $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;
use strict;
use re 'taint';

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

BEGIN {
  import Amavis::Conf qw(:platform $relayhost_is_client c cr ca);
  import Amavis::Util qw(ll do_log dynamic_destination);
  import Amavis::Out::SMTP;  import Amavis::Out::Pipe;
  import Amavis::Out::BSMTP; import Amavis::Out::Local;
}

sub mail_dispatch($$$$;$) {
  my($conn) = shift;
  my($msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_;
  my($via) = $msginfo->delivery_method;
  if ($via =~ /^smtp:/i) {
    Amavis::Out::SMTP::mail_via_smtp(
                     dynamic_destination($via,$conn,$relayhost_is_client), @_);
  } elsif ($via =~ /^pipe:/i) {
    Amavis::Out::Pipe::mail_via_pipe($via, @_);
  } elsif ($via =~ /^bsmtp:/i) {
    Amavis::Out::BSMTP::mail_via_bsmtp($via, @_);
  } elsif ($via =~ /^sql:/i) {
    $Amavis::extra_code_sql_quar && $Amavis::sql_storage
      or die "SQL quarantine code not enabled";
    Amavis::Out::SQL::Quarantine::mail_via_sql(
                                        $Amavis::sql_dataset_conn_storage, @_);
  } 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 first what is local (whatever does not contain '@')
    Amavis::Out::Local::mail_to_local_mailbox(
                          $via, $msginfo, $initial_submission,
                          sub { shift->recip_final_addr !~ /\@/ ? 1 : 0 });
    if (grep { !$_->recip_done } @{$msginfo->per_recip_data}) {
      my($nm) = c('notify_method');  # deliver the rest
      if ($nm =~ /^smtp:/i) {
        Amavis::Out::SMTP::mail_via_smtp(
                      dynamic_destination($nm,$conn,$relayhost_is_client),@_) }
      elsif ($nm =~ /^pipe:/i)  { Amavis::Out::Pipe::mail_via_pipe($nm, @_) }
      elsif ($nm =~ /^bsmtp:/i) { Amavis::Out::BSMTP::mail_via_bsmtp($nm, @_) }
      elsif ($nm =~ /^sql:/i) {
        $Amavis::extra_code_sql_quar && $Amavis::sql_storage
          or die "SQL quarantine code not enabled";
        Amavis::Out::SQL::Quarantine::mail_via_sql(
                                        $Amavis::sql_dataset_conn_storage, @_);
      }
    }
  }
}

1;

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

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&best_try_originator_ip &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(ll do_log);
  import Amavis::rfc2821_2822_Tools qw(
                   split_address parse_received fish_out_ip_from_received);
  import Amavis::Lookup qw(lookup);
  import Amavis::Lookup::IP qw(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($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!
  my($best_try_originator) = $sender;
  if ($best_try_originator ne '') {
    for my $vn (@$virusname_list) {
      my($result,$matching_key) = lookup(0,$vn,@viruses_that_fake_sender_maps);
      if ($result) {
        do_log(2,"Virus %s matches %s, sender addr ignored",$vn,$matching_key);
        $best_try_originator = undef;  last;
      }
    }
  }
  $best_try_originator;
}

# Given a dotted-quad IPv4 address try reverse DNS resolve, and then
# forward DNS resolve. If they match, return domain name,
# otherwise return the IP address in brackets. (resolves IPv4 only)
#
sub ip_addr_to_name($) {
  my($addr) = @_;     # dotted-quad address string
  local($1,$2,$3,$4); my($result);
  if ($addr !~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/) {
    $result = $addr;  # not an IPv4 address
  } else {
    my($binaddr) = pack('C4', $1,$2,$3,$4);   # to binary string
    do_log(5, "ip_addr_to_name: DNS reverse-resolving: %s", $addr);
    my(@addr) = gethostbyaddr($binaddr,2);           # IP -> name
    $result = '['.$addr.']';  # IP address in brackets if nothing matches
    if (@addr) {
      my($name,$aliases,$addrtype,$length,@addrs) = @addr;
      if ($name =~ /[^.]\.[a-zA-Z]+\z/s) {
        do_log(5, "ip_addr_to_name: DNS forward-resolving: %s", $name);
        my(@raddr) = gethostbyname($name);           # name -> IP
        my($rname,$raliases,$raddrtype,$rlength,@raddrs) = @raddr;
        for my $ra (@raddrs) {
          if (lc($ra) eq lc($binaddr)) { $result = $name; last }
        }
      }
    }
  }
  do_log(3, "ip_addr_to_name: returning: %s", $result);
  $result;
}

# Obtain and parse the first entry (oldest) 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);
      $first_received =~ s/^[ \t\n\r]+//s;   # discard leading whitespace
      $first_received =~ s/[ \t\n\r]+\z//s;  # discard trailing whitespace
    }
    do_log(5, "first_received_from: %s", $first_received);
  }
  $first_received;
}

# Try to extract sender's public IP address from the Received trace
#
use vars qw(@publicnetworks_maps);
sub best_try_originator_ip($) {
  my($entity) = @_;
  @publicnetworks_maps = (
    Amavis::Lookup::Label->new('publicnetworks'),
    Amavis::Lookup::IP->new(qw(
      !0.0.0.0/8 !127.0.0.0/8 !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
      [::FFFF:0:0]/96 ![::] ![::1] ![FF00::]/8 ![FE80::]/10 ![FEC0::]/10
      [::]/0)) )  if !@publicnetworks_maps;  # rfc3330, rfc3513
  my($first_received_from_ip);
  if (defined($entity)) {
    my(@received) = reverse $entity->head->get_all('received');
    $#received = 5  if $#received > 5;  # first six, chronologically
    for my $r (@received) {
      $first_received_from_ip = fish_out_ip_from_received($r);
      if ($first_received_from_ip ne '') {
        my($is_public,$fullkey,$err) =
          lookup_ip_acl($first_received_from_ip,@publicnetworks_maps);
        last  if (!defined($err) || $err eq '') && $is_public;
      }
    }
    do_log(5, "best_try_originator_ip: %s", $first_received_from_ip);
  }
  $first_received_from_ip;
}

# For the purpose of informing administrators try to obtain true sender
# address or at least its site, as most viruses and spam 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($msginfo, $virusname_list) = @_;
  my($from) = $msginfo->orig_header_fields->{'from'};
  my($originator) = unmangle_sender($msginfo->sender,$from,$virusname_list);
  return ($originator, $originator)  if defined $originator;
  my($first_received_from_ip) = best_try_originator_ip($msginfo->mime_entity);
  $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.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&consumed_bytes);
}

BEGIN {
  import Amavis::Conf qw(c cr ca
                         $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR
                         $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR);
  import Amavis::Util qw(ll 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: %d; quota set to: %d bytes",
           $mail_size,$avail_quota);
  # 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, $ignore_limit) = @_;
  $ignore_limit = 0  if !defined($ignore_limit);
  if (!$ignore_limit && 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, $exquota) = @_;
  my($perc) = !$avail_quota ? '' : sprintf(", (%.0f%%)",
                  100 * ($avail_quota - ($rem_quota - $bytes)) / $avail_quota);
  ll(4) && do_log(4,
               "Charging %d bytes to remaining quota %d (out of %d%s) - by %s",
               $bytes, $rem_quota, $avail_quota, $perc, $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(-1, "%s", $msg);
    die "$msg\n"  if !$exquota;   # die, unless allowed to exceed quota
  }
  $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.062';
  @ISA = qw(Exporter);
}

BEGIN {
  import Amavis::Util qw(ll 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,$ignore_limit) = @_;
  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($ignore_limit));
    $self->dir_name($dir_name)  if defined $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
    ll(4) && do_log(4, "Issued a new %s: %s",
            defined $dir_name ? "file name" : "pseudo part", $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 mime_placement    # part location within a MIME tree, e.g. "1/1/3"
  { my($self)=shift; !@_ ? $self->{place}    : ($self->{place}=shift) };
sub type_short     # string or a ref to a list of strings
  { 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  # string or a ref to a list of strings
  { 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,S=special,L=link
  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; my($d) = $self->dir_name;
  !defined($d) ? undef : $d.'/'.$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.062';
  @ISA = qw(Exporter MIME::Parser::Filer);  # subclass of MIME::Parser::Filer
}
# 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}, 1);
  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.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&check_header_validity &check_for_banned_names);
}

BEGIN {
  import Amavis::Util qw(ll do_log min max sanitize_str);
  import Amavis::Conf qw(:platform %banned_rules c cr ca);
  import Amavis::Lookup qw(lookup);
}
use subs @EXPORT_OK;

sub check_header_validity($$) {
  my($conn, $msginfo) = @_;
  my($curr_head); my(@bad);
  my($minor_badh_category) = 0;
  # minor category:  2: 8-bit char, 3: NUL/CR, 4: empty, 5: long, 6: syntax
  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 syntax";
          $minor_badh_category = max(5, $minor_badh_category);
        } elsif ($curr_head =~ /^(.*?)([\000\015])(.*)\z/s) {
          $msg1 = "Improper use of control character";
          $minor_badh_category = max(3, $minor_badh_category);
        } elsif ($curr_head =~ /^(.*?)([\200-\377])(.*)\z/s) {
          $msg1 = "Non-encoded 8-bit data";
          $minor_badh_category = max(2, $minor_badh_category);
        } elsif ($curr_head =~ /^(.*?)([^\000-\377])(.*)\z/s) {
          $msg1 = "Non-encoded Unicode character";  # should not happen
          $minor_badh_category = max(2, $minor_badh_category);
        } elsif ($curr_head =~ /^(.*?)^([ \t]+)(\n.*)?\z/ms) {
          $msg1 ="Improper folded header field made up entirely of whitespace";
          $minor_badh_category = max(4, $minor_badh_category);
        } elsif ($curr_head =~ /^(.*?)^([^\n]{999,})(\n.*)?\z/ms) {
          $msg1 = "Header line longer than 998 characters";
          $minor_badh_category = max(6, $minor_badh_category);
        }
        if (defined $msg1) {
          my($pre, $mid, $post) = ($1, $2, $3);
          if (length($mid)  > 20) { $mid  = substr($mid,0,15)  . "..." }
          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($mid))  if length($mid)==1;
        # $msg1 .= " in message header '$field_name'"     if $field_name ne '';
          $msg2 = sanitize_str($pre); my($msg2_pre_l) = length($msg2);
          $msg2 .= sanitize_str($mid . $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
      last  if @bad >= 100;         # some sanity limit
      $curr_head = $next_head;
    }
  }
  ll(5) && do_log(5,"check_header: %d, %s", $minor_badh_category,
                                            !@bad ? "OK" : join(', ',@bad) );
  (\@bad, $minor_badh_category);
}

sub check_for_banned_names($$) {
  my($msginfo,$parts_root) = @_;
  do_log(3, "Checking for banned types and filenames");
  my($bypmr) = ca('bypass_banned_checks_maps');
  my($bfnmr) = ca('banned_filename_maps');  # two-level map: recip, partname
  my(@recip_tables);  # a list of records describing banned tables for recips
  my($any_table_in_recip_tables) = 0;  my($any_not_bypassed) = 0;
  for my $r (@{$msginfo->per_recip_data}) {
    my($recip) = $r->recip_addr;
    my(@tables,@tables_m);  # list of banned lookup tables for this recipient
    if (!lookup(0,$recip,@$bypmr)) {  # not bypassed
      $any_not_bypassed = 1;
      my($t_ref,$m_ref) = lookup(1,$recip,@$bfnmr);
      if (defined $t_ref) {
        for my $ti (0..$#$t_ref) { # collect all relevant tables for each recip
          my($t) = $t_ref->[$ti];
          # an entry may be a ref to a list of lookup tables, or a comma- or
          # whitespace-separated list of table names (suitable for SQL),
          # which are mapped to actual lookup tables through %banned_rules
          if (!defined($t)) {  # ignore
          } elsif (ref($t) eq 'ARRAY') {  # a list of actual lookup tables
            push(@tables, @$t);
            push(@tables_m, ($m_ref->[$ti]) x @$t);
          } else {  # a list of rules _names_, to be mapped via %banned_rules
            my(@names);  my(@rawnames) = grep { !/^[, ]*\z/ }
               ($t =~ /\G (?: " (?: \\. | [^"\\] )* " | [^, ] )+ | [, ]+/gcsx);
            # in principle the quoted strings could be used
            # to construct lookup tables on-the-fly (not implemented)
            for my $n (@rawnames) {  # collect only valid names
              if (!exists($banned_rules{$n})) {
                do_log(2,"INFO: unknown banned table name %s, recip=%s",
                         $n,$recip);
              } elsif (!defined($banned_rules{$n})) {  # ignore undef
              } else { push(@names,$n) }
            }
            ll(3) && do_log(3,"collect banned table[%d]: %s, tables: %s",
              $ti,$recip, join(', ',map { $_.'=>'.$banned_rules{$_} } @names));
            if (@names) {  # any known and valid table names?
              push(@tables, map { $banned_rules{$_} } @names);
              push(@tables_m, ($m_ref->[$ti]) x @names);
            }
          }
        }
      }
    }
    push(@recip_tables, { r => $r, recip => $recip,
                          tables => \@tables, tables_m => \@tables_m } );
    $any_table_in_recip_tables++  if @tables;
  }
  my($bnpre) = cr('banned_namepath_re');
  if (!$any_not_bypassed) {
    do_log(3,"skipping banned check: all recipients bypass banned checks");
  } elsif (!$any_table_in_recip_tables && !(ref $bnpre && ref $$bnpre)) {
    do_log(3,"skipping banned check: no applicable lookup tables");
  } else {
    do_log(4,"starting banned checks - traversing message structure tree");
    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_trad);  # a part path: list of predecessors of a message part
      my(@descr);  # same, but in form suitable for check on banned_namepath_re
      for my $p (@path) {
        my(@k,$n);
        $n = $p->base_name;
        if ($n ne '') { $n=~s/[\t\n]/ /g; push(@k,"P=$n") }
        $n = $p->mime_placement;
        if ($n ne '') { $n=~s/[\t\n]/ /g; push(@k,"L=$n") }
        $n = $p->type_declared;
        $n = [$n]  if !ref($n);
        for (@$n) {if ($_ ne ''){my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"M=$m")}}
        $n = $p->type_short;
        $n = [$n]  if !ref($n);
        for (@$n) {if (defined($_) && $_ ne '')
                     {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"T=$m")} }
        $n = $p->name_declared;
        $n = [$n]  if !ref($n);
        for (@$n) {if (defined($_) && $_ ne '')
                     {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"N=$m")} }
        $n = $p->attributes;
        $n = [$n]  if !ref($n);
        for (@$n) {if (defined($_) && $_ ne '')
                     {my($m)=$_; $m=~s/[\t\n]/ /g; push(@k,"A=$m")} }
        push(@descr, join("\t",@k));
        push(@descr_trad, [map { local($1,$2);
             /^([a-zA-Z0-9])=(.*)\z/s; my($key_what,$key_val) = ($1,$2);
             $key_what eq 'M' || $key_what eq 'N' ? $key_val
           : $key_what eq 'T' ? ('.'.$key_val)  # prepend a dot (compatibility)
           : $key_what eq 'A' && $key_val eq 'U' ? 'UNDECIPHERABLE' : ()} @k]);
      }
      # we have obtained a description of a part as a list of its predecessors
      # in a message structure including the part itself at the end of the list
      my($key_val_str) = join(' | ',@descr);  $key_val_str =~ s/\t/,/g;
      my($key_val_trad_str) = join(' | ', map {join(',',@$_)} @descr_trad);
      # evaluate current mail component path against each recipients' tables
      ll(4) && do_log(4, "check_for_banned (%s) %s",
                      join(',', map {$_->base_name} @path), $key_val_trad_str);
      my($result,$matchingkey); my($t_ref_old);
      for my $e (@recip_tables) {  # for each recipient and his tables
        my($found,$recip,$t_ref) = @$e{'found','recip','tables'};
        if (!$e->{result} && $t_ref && @$t_ref) {
          my($same_as_prev) = $t_ref_old && @$t_ref_old==@$t_ref &&
                              !(grep { $t_ref_old->[$_] ne $t_ref->[$_] }
                                     (0..$#$t_ref)) ? 1 : 0;
          if ($same_as_prev) {
            do_log(4,
             "skip banned check for %s, same tables as previous, result => %s",
              $recip,$result);
          } else {
            do_log(5,"doing banned check for %s on %s",
                     $recip,$key_val_trad_str);
            ($result,$matchingkey) =
              lookup(0, [map {@$_} @descr_trad],  # check all attribs in one go
                     Amavis::Lookup::Label->new("check_bann:$recip"),
                     map { ref($_) eq 'ARRAY' ? @$_ : $_ } @$t_ref);
            $t_ref_old = $t_ref;
          }
          @$e{'found','result','matchk','part_descr'} =
            (1,$result,$matchingkey,$key_val_trad_str)  if defined $result;
        }
      }
      if (ref $bnpre && ref $$bnpre &&
          grep {!$_->{result}} @recip_tables) {  # any non-true remains
        # try new style: banned_namepath_re; it is global, not per-recipient
        my($result,$matchingkey) = lookup(0, join("\n",@descr),
                     Amavis::Lookup::Label->new('banned_namepath_re'), $bnpre);
        if (defined $result) {
          for my $e (@recip_tables) {
            @$e{'found','result','matchk','part_descr'} =
              (1,$result,$matchingkey,$key_val_str)  if !$e->{found};
          }
        }
      }
      my(%esc) = (r => "\r", n => "\n", f => "\f", b => "\b",
                  e => "\e", a => "\a", t => "\t");  # for pretty-printing
      my($ll) = (grep {$_->{result}} @recip_tables) ? 1 : 3;  # log level
      for my $e (@recip_tables) {  # log and store results
        my($r,$recip,$result,$matchingkey,$part_descr) =
          @$e{'r','recip','result','matchk','part_descr'};
        if (ll($ll)) {  # only bother with logging when needed
          my($mk) = defined $matchingkey ? $matchingkey : '';  # pretty-print
          $mk =~ s{ \\(.) }{ exists($esc{$1}) ? $esc{$1} : '\\'.$1 }egsx;
          do_log($result?1:3, 'p.path%s %s: "%s"%s',
                           !$result?'':" BANNED:$result", $recip, $key_val_str,
                           !defined $result ? '' : ", matching_key=\"$mk\"");
        }
        my($a);
        if ($result) {  # the part being tested is banned for this recipient
          $a = $r->banned_parts;  $a = []  if !defined($a);
          push(@$a,$part_descr);  $r->banned_parts($a);
          $a = $r->banned_keys;   $a = []  if !defined($a);
          push(@$a,$matchingkey); $r->banned_keys($a);
          $a = $r->banned_rhs;    $a = []  if !defined($a);
          push(@$a,$result);      $r->banned_rhs($a);
        }
      }
      last  if !grep {!$_->{result}} @recip_tables;  # stop if all recips true
    } # endfor: message tree traversal
  } # endif: doing parts checking
}

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.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&mime_decode);
}
use Errno qw(ENOENT EACCES);
use IO::File qw(O_CREAT O_EXCL O_WRONLY);
use MIME::Parser;
use MIME::Words;

BEGIN {
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(snmp_count ll do_log);
  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, $placement) = @_;
  if (defined $pe_lines && @$pe_lines) {
    do_log(5, "mime_decode_%s: %d lines", $pe_name, scalar(@$pe_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,1);
      $newpart_obj->mime_placement($placement);
      $newpart_obj->name_declared($pe_name);
      my($newpart) = $newpart_obj->full_name;
      my($outpart) = IO::File->new;
      $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640)
        or die "Can't create $pe_name file $newpart: $!";
      binmode($outpart, ":bytes") or die "Can't cancel :utf8 mode: $!"
        if $unicode_aware;
      my($len);
      for (@$pe_lines) {
        $outpart->print($_) or die "Can't write $pe_name to $newpart: $!";
        $len += length($_);
      }
      $outpart->close or die "Error closing $pe_name $newpart: $!";
      $newpart_obj->size($len);
      consumed_bytes($len, "mime_decode_$pe_name", 0, 1);
    }
  }
}

# traverse MIME::Entity object depth-first,
# extracting preambles and epilogues as extra (pseudo)parts, and
# filling-in additional information into Amavis::Unpackers::Part objects
sub mime_traverse($$$$$);  # prototype
sub mime_traverse($$$$$) {
  my($entity, $tempdir, $parent_obj, $depth, $placement) = @_;
  mime_decode_pre_epi('preamble', $entity->preamble,
                      $tempdir, $parent_obj, $placement);
  my($mt, $et) = ($entity->mime_type, $entity->effective_type);
  my($part); my($head) = $entity->head; my($body) = $entity->bodyhandle;
  if (!defined($body)) {  # a MIME container only contains parts, no bodypart
    # create pseudo-part objects for MIME containers (e.g. multipart/* )
    $part = Amavis::Unpackers::Part->new(undef,$parent_obj,1);
#   $part->type_short('no-file');
    do_log(2, "%s %s Content-Type: %s", $part->base_name, $placement, $mt);
  } else {  # does have a body part (i.e. not a MIME container)
    my($fn) = $body->path; my($size);
    if (!defined($fn)) { $size = length($body->as_string) }
    else {
      my($msg); my($errn) = lstat($fn) ? 0 : 0+$!;
      if ($errn == ENOENT) { $msg = "does not exist" }
      elsif ($errn) { $msg = "is inaccessible: $!" }
      elsif (!-r _) { $msg = "is not readable" }
      elsif (!-f _) { $msg = "is not a regular file" }
      else {
        $size = -s _;
        do_log(4,"mime_traverse: file %s is empty", $fn)  if !$size;
      }
      do_log(-1,"WARN: mime_traverse: file %s %s", $fn,$msg)  if defined $msg;
    }
    consumed_bytes($size, 'mime_decode', 0, 1);
    # retrieve Amavis::Unpackers::Part object (if any), stashed into head obj
    $part = Amavis::Unpackers::OurFiler::get_amavisd_part($head);
    if (defined $part) {
      $part->size($size);
      if ($size==0) { $part->type_short('empty'); $part->type_long('empty') }
      ll(2) && do_log(2, "%s %s Content-Type: %s, size: %d B, name: %s",
                      $part->base_name, $placement, $mt, $size,
                      $entity->head->recommended_filename);
      my($old_parent_obj) = $part->parent;
      if ($parent_obj ne $old_parent_obj) {  # reparent if necessary
        ll(5) && do_log(5,"reparenting %s from %s to %s", $part->base_name,
                          $old_parent_obj->base_name, $parent_obj->base_name);
        my($ch_ref) = $old_parent_obj->children;
        $old_parent_obj->children([grep {$_ ne $part} @$ch_ref]);
        $ch_ref = $parent_obj->children;
        push(@$ch_ref,$part); $parent_obj->children($ch_ref);
        $part->parent($parent_obj);
      }
    }
  }
  if (defined $part) {
    $part->mime_placement($placement);
    $part->type_declared($mt eq $et ? $mt : [$mt, $et]);
    my(@rn);  # recommended file names, both raw and RFC 2047 decoded
    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 (defined($val) && $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;
  }
  mime_decode_pre_epi('epilogue', $entity->epilogue,
                      $tempdir, $parent_obj, $placement);
  my($item_num) = 0;
  for my $e ($entity->parts) {  # recursive descent
    $item_num++;
    mime_traverse($e,$tempdir,$part,$depth+1,"$placement/$item_num");
  }
}

# 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);              # to enable or not to enable ???
  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 %s", $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;
  if (defined $mime_err) {
    $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 %s", $mime_err)  if $mime_err ne '';
  }
  mime_traverse($entity, $tempdir, $parent_obj, 0, '1');
  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.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&delivery_status_notification &delivery_short_report
                  &string_to_mime_entity &defanged_mime_entity
                  &msg_from_quarantine &expand_variables);
}

BEGIN {
  import Amavis::Util qw(ll do_log am_id safe_encode q_encode sanitize_str
                         xtext_encode xtext_decode);
  import Amavis::Timing qw(section_time);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Out::EditHeader qw(hdr);
  import Amavis::Lookup qw(lookup);
  import Amavis::Expand qw(expand);
  import Amavis::rfc2821_2822_Tools;
}
use MIME::Entity;
# use Encode;  # Perl 5.8  UTF-8 support

use subs @EXPORT_OK;

# replace substring ${myhostname} with a value of a corresponding variable
sub expand_variables($) {
  my($str) = @_;
  $str =~ s{ \$ (?: \{ ([^\}]+) \} |
                    ([a-zA-Z](?:[a-zA-Z0-9_-]*[a-zA-Z0-9])?\b) ) }
           { { 'myhostname' => c('myhostname') }->{lc($1.$2)} }egx;
  $str;
}

# Convert mail (that was obtained by macro-expanding notification templates)
# into proper MIME::Entity object. Optionally attach message headers from
# original mail or a complete original message.
#
sub string_to_mime_entity($$$$$) {
  my($mail_as_string_ref, $msginfo, $mime_type,
     $attach_orig_headers, $attach_orig_message) = @_;
  my($do_multipart) = defined $msginfo &&
                      ($attach_orig_headers || $attach_orig_message);
  my($entity,$m_hdr,$m_body);
  # calling index and substr is much faster than an equivalent split into $1,$2
  # by a regular expression: /^( (?!\n) .*? (?:\n|\z))? (?: \n (.*) )? \z/sx
  if (substr($$mail_as_string_ref, 0,1) eq "\n") {  # empty header?
    $m_hdr = ''; $m_body = substr($$mail_as_string_ref,1);
  } else {
    my($ind) = index($$mail_as_string_ref,"\n\n");  # find hdr/body separator
    if ($ind < 0) { $m_hdr = $$mail_as_string_ref; $m_body = '' }   # no body
    else {  # normal mail structure, nonempty header and nonempty body
      $m_hdr  = substr($$mail_as_string_ref, 0, $ind+1);
      $m_body = substr($$mail_as_string_ref, $ind+2);
    }
  }
  $m_body = safe_encode(c('bdy_encoding'), $m_body);
  my($nxmh) = c('notify_xmailer_header');
  $mime_type =
    $do_multipart ? 'multipart/mixed' : 'text/plain'  if !defined($mime_type);
  # make sure _our_ source line number is reported in case of failure
  eval {$entity = MIME::Entity->build(
    (defined $nxmh && $nxmh eq '' ? ()  # leave the MIME::Entity default
     : ('X-Mailer' => $nxmh) ),         # X-Mailer hdr or undef
    Type => $mime_type,
    $do_multipart ? (Encoding => '7bit')
      : (Data => $m_body, Encoding => '-SUGGEST', Charset =>c('bdy_encoding')),
    ); 1}  or do {chomp($@); die $@};
  # Mail::Header::modify allows all-or-nothing control over automatic header
  # folding by Mail::Header, which is too bad - we would prefer to have full
  # control on folding of header fields that are explicitly inserted here,
  # and let Mail::Header handle the rest. Sorry, can't be done, so let's just
  # disable folding by Mail::Header (which does a poor job when presented with
  # few break opportunities), and wrap our header fields ourselves, hoping the
  # remaining automatically generated header fields won't be too long.
  my($head) = $entity->head;  $head->modify(0);
  # insert header fields from template into MIME::Head entity
  local($1,$2);
  $m_hdr =~ s/\r?\n([ \t])/$1/g;  # unfold template header
  for my $hdr_line (split(/\r?\n/, $m_hdr)) {
    if ($hdr_line =~ /^([^:]*):[ \t]*(.*)\z/s) {
      my($fhead,$fbody) = ($1,$2);
      my($str) = hdr($fhead,$fbody,0,' ');  # encode, wrap, ...
      # re-split the result
      ($fhead,$fbody) = ($1,$2)  if $str =~ /^([^:]*):[ \t]*(.*)\z/s;
      chomp($fbody);
      do_log(5, "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);
      }
    }
  }
  if ($do_multipart) {
    eval {$entity->attach(
      Type => 'text/plain', Data => $m_body,
      Encoding => '-SUGGEST', Charset => c('bdy_encoding'),
      ); 1}  or do {chomp($@); die $@};
  }
  if (defined($msginfo) && $attach_orig_message) {
    do_log(4, "string_to_mime_entity: attaching entire original message");
    eval {$entity->attach(  # rfc2046
      Type => 'message/rfc822; x-spam-type=original',
      Encoding => '8bit', Path => $msginfo->mail_text_fn,
      Disposition => 'attachment', Filename => 'message',
      Description => 'Original message'); 1} or do {chomp($@); die $@};
  } elsif (defined($msginfo) && $attach_orig_headers) {
    do_log(4, "string_to_mime_entity: attaching original message headers");
    my($rp) = sprintf("Return-Path: %s\n",  # fake a local delivery agent
                      qquote_rfc2821_local($msginfo->sender));
    eval {$entity->attach(
      Type => 'text/rfc822-headers',  # rfc3462
      Encoding => '-SUGGEST', Data => [$rp, @{$msginfo->orig_header}],
      Disposition => 'inline',  Filename => 'header',
      Description => 'Message headers'); 1} or do {chomp($@); die $@};
  }
  $entity;  # return the constructed MIME::Entity
}

# Generate delivery status notification according to
# rfc3462 (ex rfc1892), rfc3464 (ex rfc1894) and rfc3461 (ex rfc1891).
# Return a message object containing DSN if DSN is needed, or undef otherwise.
#
sub delivery_status_notification($$$$$) {
  my($conn,$msginfo,$dsn_per_recip_capable,$all_rejected,$builtins_ref) = @_;
  my($notification);
  my($dsn_time) = time;  # time of dsn creation - now
  my($txt_recip) = '';   # per-recipient part of dsn text according to rfc3464
  my($sender) = $msginfo->sender;
  my($dsn_passed_on) = $msginfo->dsn_passed_on;  # NOTIFY=SUCCESS passed to MTA
  my($delivery_method) = $msginfo->delivery_method;

  my($spam_level) = $msginfo->spam_level;
  my($os_fingerprint) = $msginfo->client_os_fingerprint;
  my($is_bulk) = $msginfo->orig_header_fields->{'precedence'};
  $is_bulk = $is_bulk=~/^[ \t]*(bulk|list|junk)\b/i ? $1 : undef;
  my($dsn_cutoff_level);
  my($cutoff_level_maps) = ca('spam_dsn_cutoff_level_maps');

  my($any_succ,$any_fail,$any_delayed);
  for my $r (@{$msginfo->per_recip_data}) {  # prepare per-recip fields first
    my($recip) = $r->recip_addr;
    my($smtp_resp) = $r->recip_smtp_response;
    my($recip_done) = $r->recip_done; # 2=relayed to MTA, 1=faked deliv/quarant
    my($ccat_name) =
      $msginfo->setting_by_contents_category(\%ccat_display_names);
    my($boost) = $r->recip_score_boost;
    if (!$recip_done) {
      if ($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(-2,"TROUBLE: recipient not done: <%s> %s", $recip,$smtp_resp);
      }
    }
    my($smtp_resp_class) = $smtp_resp =~ /^(\d)/  ? $1 : '0';
    my($smtp_resp_code)  = $smtp_resp =~ /^(\d+)/ ? $1 : '0';
    my($dsn_notify) = $r->dsn_notify;
    my($notify_on_failure,$notify_on_success,$notify_on_delay,$notify_never) =
      (0,0,0,0);
    if (!defined($dsn_notify))  { $notify_on_failure = $notify_on_delay = 1 }
    else {
      for (@$dsn_notify) {    # validity of the list has already been checked
        if    ($_ eq 'FAILURE') { $notify_on_failure = 1 }
        elsif ($_ eq 'SUCCESS') { $notify_on_success = 1 }
        elsif ($_ eq 'DELAY')   { $notify_on_delay   = 1 }
        elsif ($_ eq 'NEVER')   { $notify_never = 1 }
      }
    }
    if ($notify_never || $sender eq '')
      { $notify_on_failure = $notify_on_success = $notify_on_delay = 0 }
    my($dest) = $r->recip_destiny;
    my($remote_or_local) = $recip_done==2 ? 'from MTA' :
                           $recip_done==1 ? '.' :  # this agent
                           'status-to-be-passed-back';
    # warn_sender is an old relict and does not fit well into DSN concepts;
    # we'll sneak it in, pretending to cause a DELAY notification
    my($warn_sender) =
      $notify_on_delay && $smtp_resp_class eq '2' && $recip_done==2 &&
      $r->setting_by_contents_category(cr('warnsender_by_ccat'));
    ll(5) && do_log(5,
              "dsn: %s %s %s <%s> -> <%s>: on_succ=%d, on_dly=%d, on_fail=%d,".
              " never=%d, warn_sender=%s, DSN_passed_on=%s",
              $remote_or_local, $smtp_resp_code, $ccat_name, $sender, $recip,
              $notify_on_success, $notify_on_delay, $notify_on_failure,
              $notify_never, $warn_sender, $dsn_passed_on);
    # clearly log common cases to facilitate troubleshooting;

    # first look for some standard reasons for not sending a DSN
    if ($smtp_resp_class eq '4') {
      do_log(4, "DSN: TMPFAIL %s %s %s, need not be reported: <%s> -> <%s>",
                $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip);
    } elsif ($smtp_resp_class eq '5' && $dest==D_REJECT &&
             ($dsn_per_recip_capable || $all_rejected)) {
      do_log(4, "DSN: FAIL %s %s %s, status propagated back: <%s> -> <%s>",
                $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip);
    } elsif ($smtp_resp_class eq '5' && !$notify_on_failure) {
      do_log($recip_done==2 ? 0 : 4,  # log level 0 for remotes, rfc3461 5.2.2d
                "DSN: FAIL %s %s %s, %s requested to be IGNORED: <%s> -> <%s>",
                $remote_or_local,$smtp_resp_code,$ccat_name,
                $notify_never?'explicitly':'implicitly', $sender, $recip);
    } elsif ($smtp_resp_class eq '2' && !$notify_on_success && !$warn_sender) {
      my($fmt) = $r->recip_destiny == D_DISCARD
                   ? "SUCC (discarded) %s %s %s, destiny=DISCARD"
                   : "SUCC %s %s %s, no DSN requested";
      do_log(5, "DSN: $fmt: <%s> -> <%s>",
             $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip);
    } elsif ($smtp_resp_class eq '2' && $notify_on_success && $dsn_passed_on &&
             !$warn_sender) {
      do_log(5, "DSN: SUCC %s %s %s, DSN parameters PASSED-ON: <%s> -> <%s>",
                $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip);
    } elsif ($notify_never || $sender eq '') {  # test sender just in case
      do_log(5, "DSN: NEVER %s %s, <%s> -> %s",
                $smtp_resp_code,$ccat_name,$sender,$recip);

    # next, look for some good _excuses_ for not sending a DSN

    } elsif ($r->recip_destiny == D_DISCARD) {  # requested by final_*_destiny
      do_log(4, "DSN: FILTER %s %s %s, destiny=DISCARD: <%s> -> <%s>",
                $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip);
    } elsif ($msginfo->sender_contact eq '') {  # faked sender most likely
      do_log(3, "DSN: FILTER %s %s, <%s> (faked?) -> <%s>",
                $smtp_resp_code,$ccat_name,$sender,$recip);
    } elsif (defined $r->dsn_suppress_reason) {
      do_log(3, "DSN: FILTER %s %s, %s <%s> -> <%s>",
                $smtp_resp_code,$ccat_name,$r->dsn_suppress_reason,
                $sender,$recip);
    } elsif ($dsn_cutoff_level = lookup(0,$recip,@$cutoff_level_maps),
             defined($dsn_cutoff_level) &&
             $spam_level+$boost >= $dsn_cutoff_level) {
      do_log(3, "DSN: FILTER %s %s, spam level %.3f exceeds cutoff level %s, ".
                "<%s> -> <%s>", $smtp_resp_code, $ccat_name,
                $spam_level+$boost, $dsn_cutoff_level, $sender, $recip);
    } elsif ($is_bulk && $r->main_contents_category > CC_CLEAN) {
      do_log(3, "DSN: FILTER %s %s, suppressed, bulk mail (%s), <%s> -> <%s>",
                $smtp_resp_code,$ccat_name,$is_bulk,$sender,$recip);
    } elsif ($os_fingerprint =~ /^Windows\b/ &&   # hard-coded limits!
             $spam_level+$boost >= ($os_fingerprint=~/^Windows XP/ ? 5 : 8)) {
      $os_fingerprint =~ /^(\S+\s+\S+)/;
      do_log(3, "DSN: FILTER %s %s, suppressed for mail from %s ".
                "at %s, score=%s, <%s> -> <%s>", $smtp_resp_code, $ccat_name,
                $1, $msginfo->client_addr, $spam_level+$boost, $sender,$recip);
    } else {
      # rfc3461, section 5.2.8: "A single DSN may describe attempts to deliver
      # a message to multiple recipients of that message. If a DSN is issued
      # for some recipients in an SMTP transaction and not for others according
      # to the rules above, the DSN SHOULD NOT contain information for
      # recipients for whom DSNs would not otherwise have been issued."
      $txt_recip .= "\n";  # empty line between groups of per-recipient fields
      my($dsn_orcpt) = $r->dsn_orcpt;
      if (defined $dsn_orcpt) {
        $dsn_orcpt = sanitize_str(xtext_decode($dsn_orcpt));
        $txt_recip .= "Original-Recipient: $dsn_orcpt\n";
      }
      my($remote_mta) = $r->recip_remote_mta;
      if (!defined($dsn_orcpt) && $remote_mta ne '' &&
          $r->recip_final_addr ne $recip) {
        $txt_recip .= "X-NextToLast-Final-Recipient: rfc822;" .
                      quote_rfc2821_local($recip) . "\n";
        $txt_recip .= "Final-Recipient: rfc822;" .
                      quote_rfc2821_local($r->recip_final_addr) . "\n";
      } else {
        $txt_recip .= "Final-Recipient: rfc822;" .
                      quote_rfc2821_local($recip) . "\n";
      }
      local($1,$2,$3);  my($smtp_resp_code,$smtp_resp_enhcode,$smtp_resp_msg);
      if ($smtp_resp =~ /^ (\d{3}) [ \t]+ ([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;
      }
      if ($smtp_resp_enhcode eq '' && $smtp_resp_class =~ /^([245])\z/) {
        $smtp_resp_enhcode = "$1.0.0";
      }
      my($action);  # failed / relayed / delivered / expanded
      if ($recip_done == 2) {  # truly forwarded to MTA
        $action = $smtp_resp_class eq '5' ? 'failed'     # remote reject
                : $smtp_resp_class ne '2' ? undef        # shouldn't happen
                : !$dsn_passed_on ? 'relayed'   # relayed to non-conforming MTA
                : $warn_sender ? 'delayed'  # disguised as a DELAY notification
                : undef;  # shouldn't happen
      } elsif ($recip_done == 1) { # faked delivery to bit bucket or quarantine
        $action = $smtp_resp_class eq '5' ? 'failed'     # local reject
                : $smtp_resp_class eq '2' ? 'delivered'  # discard / bit bucket
                : undef;  # shouldn't happen
      } elsif (!defined($recip_done) || $recip_done == 0) {
        $action = $smtp_resp_class eq '2' ? 'relayed'  #????
                : undef;  # shouldn't happen
      }
      defined $action
        or die "Assert failed: $smtp_resp_class, $recip_done, $dsn_passed_on";
      if ($action eq 'failed') { $any_fail++ }
      elsif ($action eq 'delayed') { $any_delayed++ } else { $any_succ++ }
      $txt_recip .= "Action: $action\n";
      $txt_recip .= "Status: $smtp_resp_enhcode\n";
      my($rem_smtp_resp) = $r->recip_remote_mta_smtp_response;
      if ($warn_sender && $action eq 'delayed') {
        $smtp_resp = '250 2.6.0 Bad message, but will be delivered anyway';
      } elsif ($remote_mta ne '' && $rem_smtp_resp ne '') {
        $txt_recip .= "Remote-MTA: dns; $remote_mta\n";
        $smtp_resp = $rem_smtp_resp;
      } elsif ($smtp_resp !~ /\n/ && length($smtp_resp) > 78-23) { # wrap magic
        # take liberty to wrap our own SMTP responses
        $smtp_resp = wrap_string("x" x (23-11) . $smtp_resp, 78-11,'','',0);
        # length(" 550 5.0.0 ") = 11; length("Diagnostic-Code: smtp; ") = 23
        # insert and then remove prefix to maintain consistent wrapped size
        $smtp_resp =~ s/^x{12}//;
        # wrap response code according to rfc3461 section 9.2
        $smtp_resp = join("\n", @{wrap_smtp_resp($smtp_resp)});
      }
      $smtp_resp =~ s/\n(?![ \t])/\n /gs;
      $txt_recip .= "Diagnostic-Code: smtp; $smtp_resp\n";
      $txt_recip .= "Last-Attempt-Date: ".rfc2822_timestamp($dsn_time)."\n";
      do_log(2, "DSN: NOTIFICATION: Action:%s, %s %s %s, <%s> -> <%s>",
                 $action,
                 $recip_done==2 && $action ne 'delayed' ? 'RELAYED' : 'LOCAL',
                 $smtp_resp_code, $ccat_name, $sender, $recip);
    }
  }
  if ($any_succ || $any_fail || $any_delayed) {
    my($to_hdr) = qquote_rfc2821_local($sender);
    my($hdrfrom_sender) = $msginfo->setting_by_contents_category(
                                          cr('hdrfrom_notify_sender_by_ccat'));
    # use the provided template text
    my(%mybuiltins) = %$builtins_ref;  # make a local copy
    # not really needed, these header fields are overridden later
    $mybuiltins{'f'} = expand_variables($hdrfrom_sender);
    $mybuiltins{'T'} = $to_hdr;
    $mybuiltins{'d'} = rfc2822_timestamp($dsn_time);

    # rfc3461 section 6.2: "If a DSN contains no notifications of
    # delivery failure, the MTA SHOULD return only the headers."
    my($dsn_ret) = $msginfo->dsn_ret;
    my($attach_full_msg) = defined $dsn_ret && $dsn_ret eq 'FULL' && $any_fail;
    if ($attach_full_msg) {
      # apologize in the log, we should have supplied the full message, yet
      # rfc3461 section 6.2 gives us an excuse: "However, if the length of the
      # message is greater than some implementation-specified length, the MTA
      # MAY return only the headers even if the RET parameter specified FULL."
      do_log(1,"DSN RET=%s requested, but we'll only attach header", $dsn_ret);
      $attach_full_msg = 0;  # override, just attach header
    }
    my($template_ref) = $msginfo->setting_by_contents_category(
                                            cr('notify_sender_templ_by_ccat'));
    my($dsn_str_ref) = expand($template_ref, \%mybuiltins);
    my($dsn_entity) = string_to_mime_entity($dsn_str_ref, $msginfo,
                         'multipart/report; report-type=delivery-status',
                         1, $attach_full_msg);
    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.
    # Override header fields from the template:
    eval { $head->replace('From',expand_variables($hdrfrom_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($txt_msg) = '';  # per-message part of dsn text according to rfc3464
    my($from_mta) = $conn->smtp_helo; my($client_ip) = $conn->client_ip;
    my($dsn_envid) = $msginfo->dsn_envid;
    if (defined $dsn_envid) {   # encoded as xtext: rfc3461, must be decoded
      $txt_msg .= "Original-Envelope-ID: " .
                  sanitize_str(xtext_decode($dsn_envid)) . "\n";
    }
    $txt_msg .= "Reporting-MTA: dns; " . c('myhostname') . "\n";
    $txt_msg .= "Received-From-MTA: smtp; $from_mta ([$client_ip])\n"
      if $from_mta ne '';
    $txt_msg .= "Arrival-Date: " . rfc2822_timestamp($msginfo->rx_time) . "\n";

    # make sure _our_ source line number is reported in case of failure
    eval { $dsn_entity->add_part(
             MIME::Entity->build(Top => 0,
               Type => 'message/delivery-status', Encoding => '7bit',
               Description => $any_fail ? 'Delivery error report' :
                    $any_delayed ? 'Delivery delay report' : 'Delivery report',
               Disposition => 'inline',  Filename => 'dsn_status',
               Data => $txt_msg.$txt_recip),
             1);  # insert as second mime part (at offset 1)
           1} or do {chomp($@); die $@};
    $notification = Amavis::In::Message->new;
    $notification->rx_time($dsn_time);
  # $notification->body_type('7BIT');
    $notification->mail_text($dsn_entity);
    $notification->delivery_method(c('notify_method'));
    $notification->sender('');  # DSN envelope sender must be empty!
    $notification->auth_submitter('<>');
    $notification->auth_user(c('amavis_auth_user'));
    $notification->auth_pass(c('amavis_auth_pass'));
    my($bcc) = $msginfo->setting_by_contents_category(cr('dsn_bcc_by_ccat'));
    $notification->recips([$sender, defined $bcc && $bcc ne '' ? $bcc : ()],1);
  }
  $notification;  # possibly undef if DSN not needed
}

# Return a triple 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,
        (!defined($remote_mta)||$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,
# original mail becomes an attachment of type 'message/rfc822'.
# Text in $first_part becomes the first MIME part of type 'text/plain',
# $first_part may be a scalar or a ref to a list of lines
#
sub defanged_mime_entity($$$) {
  my($conn,$msginfo,$first_part) = @_;
  my($new_entity);
  $_ = safe_encode(c('bdy_encoding'), $_)
    for (ref $first_part ? @$first_part : $first_part);
  my($nxmh) = c('notify_xmailer_header');
  # make sure _our_ source line number is reported in case of failure
  eval {$new_entity = MIME::Entity->build(
    Type => 'multipart/mixed',
    (defined $nxmh && $nxmh eq '' ? ()  # leave the MIME::Entity default
     : ('X-Mailer' => $nxmh) ),         # X-Mailer hdr or undef
    ); 1}  or do {chomp($@); die $@};

  # reinserting some of the original header fields to a new header, sanitized
  my($hdr_edits) = $msginfo->header_edits;
  if (!$hdr_edits) {
    $hdr_edits = Amavis::Out::EditHeader->new;
    $msginfo->header_edits($hdr_edits);
  }
  my(%desired_field);
  for (qw(Received From Sender To Cc Reply-To Date Message-ID
          Resent-From Resent-Sender Resent-To Resent-Cc
          Resent-Date Resent-Message-ID In-Reply-To References Subject Comments
          Keywords Organization X-Mailer)) { $desired_field{lc($_)} = 1 };
  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);
        if ($desired_field{lc($field_name)}) {  # only desired header fields
          # protect NUL, CR, and characters with codes above \177
          $field_body =~ s{ ( [^\001-\014\016-\177] ) }
                          { sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o',
                                    ord($1)) }gsxe;
          # protect NL in illegal all-whitespace continuation lines
          $field_body =~ s{\n([ \t]*)(?=\n)}{\\012$1}gs;
          chomp($field_body);
          $hdr_edits->append_header($field_name,$field_body,2); #already folded
        }
      }
      last  if $next_head eq $eol;  # end-of-header reached
      $curr_head = $next_head;
    }
  }
  eval {$new_entity->attach(
    Type => 'text/plain', Encoding => '-SUGGEST', Charset => c('bdy_encoding'),
    Data => $first_part); 1}  or do {chomp($@); die $@};
  eval {$new_entity->attach(  # rfc2046
    Type => 'message/rfc822; x-spam-type=original',
    Encoding => '8bit', Path => $msginfo->mail_text_fn,
    Description => 'Original message',
    Filename => 'message', Disposition => 'attachment'); 1}
      or do {chomp($@); die $@};
  $new_entity;
}

# Fill-in message object information based on a quarantined mail
sub msg_from_quarantine($$) {
  my($conn,$msginfo) = @_;
  my($fh) = $msginfo->mail_text;
  my($fname) = $msginfo->mail_text_fn;
  my($quarantine_id) = $msginfo->mail_id;
  $msginfo->delivery_method(c('notify_method'));  # c('forward_method') ???
  $msginfo->auth_submitter('<>');
  $msginfo->auth_user(c('amavis_auth_user'));
  $msginfo->auth_pass(c('amavis_auth_pass'));
  $fh->seek(0,0) or die "Can't rewind mail file: $!";
  my($qid,$sender,@recips,$curr_head); my($ln); my($bsmtp) = 0;
  # extract envelope information from the quarantine file
  do_log(4, "msg_from_quarantine: releasing %s", $quarantine_id);
  for ($! = 0; defined($ln=$fh->getline); $! = 0) {
    if ($ln =~ /^[ \t]/) { $curr_head .= $ln }
    else {
      my($next_head) = $ln; local($1,$2);
      local($_) = $curr_head;  chomp;  s/\n([ \t])/$1/g;  # unfold
      if (!defined($curr_head)) {  # first time
      } elsif (/^(EHLO|HELO)( |$)/i) { $bsmtp = 1;
      } elsif (/^MAIL FROM:[ \t]*(<.*>)(.*)$/i) {
        $bsmtp = 1; $sender = $1; $sender = unquote_rfc2821_local($sender);
      } elsif ( $bsmtp && /^RCPT TO:[ \t]*(<.*>)(.*)$/i) {
        push(@recips, unquote_rfc2821_local($1));
      } elsif ( $bsmtp && /^(DATA|NOOP)$/i) {
      } elsif ( $bsmtp && /^RSET$/i) { $sender = undef; @recips = ();
      } elsif (!$bsmtp && /^Return-Path:[ \t]*(.*)$/i) {
      } elsif (!$bsmtp && /^Delivered-To:[ \t]*(.*)$/i) {
      } elsif (!$bsmtp && /^X-Envelope-From:[ \t]*<(.*)>$/i) {
        $sender = $1; $sender = unquote_rfc2821_local($sender);
      } elsif (!$bsmtp && /^X-Envelope-To:[ \t]*(.*)$/i) {
        my($to) = $1;
        push(@recips, map {unquote_rfc2821_local($_)}
                          ($to =~ /\G < ([^>]*) > (?: , \s* )?/gcx) );
      } elsif (/^X-Quarantine-ID:[ \t]*(.*)$/i) {
        $qid = $1;   $qid = $1 if $qid =~ /^<(.*)>\z/s;
      } else {
        last;  # end of known headers
      }
      last  if $next_head eq "\n";  # end-of-header reached
      $curr_head = $next_head;
    }
  }
  defined $ln || $!==0  or die "Error reading file $fname: $!";
  do_log(0,"Quarantined message release: %s %s -> %s", $quarantine_id,
           qquote_rfc2821_local($sender),
           join(',', qquote_rfc2821_local(@recips)) );
  my(@m);
  if (!defined $qid) { push(@m, 'missing X-Quarantine-ID') }
  elsif ($qid ne $quarantine_id) {
    push(@m, sprintf("stored quar. ID '%s' does not match requested ID '%s'",
                     $qid,$quarantine_id));
  }
  push(@m, 'missing '.($bsmtp?'MAIL FROM':'X-Envelope-From'))
    if !defined $sender;
  push(@m, 'missing '.($bsmtp?'RCPT TO'  :'X-Envelope-To'))
    if !@recips;
  if (!defined($msginfo->sender)) { $msginfo->sender($sender) }
  else {  # sender specified in the request, overrides stored info
    push(@m, sprintf("overriding sender %s by %s",
                     qquote_rfc2821_local($sender, $msginfo->sender) ));
  }
  if (!defined($msginfo->per_recip_data)) { $msginfo->recips(\@recips) }
  else {  # recipients specified in the request, overrides stored info
    push(@m, sprintf("overriding recips %s by %s",
                     join(',', qquote_rfc2821_local(@recips)),
                     join(',', qquote_rfc2821_local(@{$msginfo->recips})) ));
  }
  do_log(0, "Quarantine release %s: %s", $quarantine_id, join("; ",@m))  if @m;
  my($hdr_edits) = Amavis::Out::EditHeader->new;
  for my $h (qw(Return-Path Delivered-To X-Quarantine-ID
                X-Envelope-From X-Envelope-To X-Amavis-Hold))
    { $hdr_edits->delete_header($h) }
  # Resent-* header fields must precede corresponding Received header field
  # "Resent-From:" and "Resent-Date:" are required fields!
  my($hdrfrom_recip) = $msginfo->setting_by_contents_category(
                                           cr('hdrfrom_notify_recip_by_ccat'));
  $hdrfrom_recip = expand_variables($hdrfrom_recip);
  if ($msginfo->requested_by eq '') {
    $hdr_edits->append_header_above_received('Resent-From',$hdrfrom_recip);
  } else {
    $hdr_edits->append_header_above_received('Resent-From',
                               qquote_rfc2821_local($msginfo->requested_by));
    $hdr_edits->append_header_above_received('Resent-Sender',$hdrfrom_recip);
  }
  $hdr_edits->append_header_above_received('Resent-To',
         @{$msginfo->recips} != 1 ? 'undisclosed-recipients:;'
                                  : qquote_rfc2821_local(@{$msginfo->recips}));
  $hdr_edits->append_header_above_received('Resent-Date', # time of the release
                rfc2822_timestamp($msginfo->rx_time));
  $hdr_edits->append_header_above_received('Resent-Message-ID',
                sprintf('<QR%s@%s>', $msginfo->mail_id, c('myhostname')) );
  $hdr_edits->append_header_above_received('Received',
                received_line($conn,$msginfo,$msginfo->mail_id,1), 1);
  $msginfo->header_edits($hdr_edits);
  if ($qid ne $quarantine_id)
    { die "Stored quarantine ID '$qid' does not match ".
          "requested ID '$quarantine_id'" }
  if ($bsmtp)
    { die "Releasing messages in BSMTP format not yet supported ".
           "(dot stuffing not implemented)" }
  $msginfo;
}

1;

#
package Amavis::Cache;
# offer an 'IPC::Cache'-compatible simple interface
# to a local (per-process) memory-based cache;
use strict;
use re 'taint';

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

# simple local memory-based cache
sub new {  # called by each child process
  my($class) = @_;
  do_log(5,"BerkeleyDB-based Amavis::Cache not available, ".
           "using memory-based local cache");
  bless {}, $class;
}
sub get { my($self,$key) = @_; thaw($self->{$key}) }
sub set { my($self,$key,$obj) = @_; $self->{$key} = freeze($obj) }

# protect % and ~, as well as NUL and \200 for good measure
sub encode($) {
  my($str) = @_; local($1);
  $str =~ s/([%~\000\200])/sprintf("%%%02X",ord($1))/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';
no warnings 'uninitialized';

use Errno qw(ENOENT EACCES);
use POSIX qw(locale_h);
use IO::File ();
use Time::HiRes ();
# body digest for caching, either SHA1 or MD5
#use Digest::SHA1;
use Digest::MD5;
use Net::Server 0.87;  # need Net::Server::PreForkSimple::done
use Net::Server::PreForkSimple;

BEGIN {
  import Amavis::Conf qw(:platform :sa :confvars c cr ca);
  import Amavis::Util qw(untaint min max ll do_log sanitize_str debug_oneshot
                         am_id add_entropy generate_mail_id prolong_timer
                         snmp_counters_init snmp_count dynamic_destination
                         cloexec xtext_encode);
  import Amavis::Log qw(open_log close_log);
  import Amavis::Timing qw(section_time get_time_so_far);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Lookup qw(lookup);
  import Amavis::Lookup::IP qw(lookup_ip_acl);
  import Amavis::Out;
  import Amavis::Out::EditHeader;
  import Amavis::UnmangleSender qw(best_try_originator_ip 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 tokenize);
  import Amavis::Notify qw(delivery_status_notification delivery_short_report
                  string_to_mime_entity defanged_mime_entity expand_variables);
  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);

add_entropy(Time::HiRes::gettimeofday, $$, $], @INC, %ENV);
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

use vars qw(
  $extra_code_db $extra_code_cache
  $extra_code_sql_base $extra_code_sql_log $extra_code_sql_quar
  $extra_code_sql_lookup $extra_code_ldap
  $extra_code_in_amcl $extra_code_in_smtp $extra_code_in_courier
  $extra_code_out_smtp $extra_code_out_pipe
  $extra_code_out_bsmtp $extra_code_out_local $extra_code_p0f
  $extra_code_antivirus $extra_code_antispam $extra_code_antispam_sa
  $extra_code_unpackers);

use vars qw(%modules_basic);
use vars qw($user_id_sql $wb_listed_sql $implicit_maps_inserted);
use vars qw($db_env $snmp_db);
use vars qw($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_begin_task (and check_mail) calls;
                     # this often 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(@config_files);
use vars qw($CONN $MSGINFO);
use vars qw($av_output @virusname @detecting_scanners
            $banned_filename_any $banned_filename_all @bad_headers);

# Amavis::In::AMCL, Amavis::In::SMTP and In::Courier objects
use vars qw($amcl_in_obj $smtp_in_obj $courier_in_obj);
use vars qw($sql_dataset_conn_lookups); # Amavis::Out::SQL::Connection object
use vars qw($sql_dataset_conn_storage); # Amavis::Out::SQL::Connection object
use vars qw($sql_storage);              # Amavis::Out::SQL::Log object
use vars qw($sql_policy $sql_wblist);   # Amavis::Lookup::SQL objects
use vars qw($ldap_connection);          # Amavis::LDAP::Connection object
use vars qw($ldap_policy);              # Amavis::Lookup::LDAP object

# implements macros: T, and SA lookalikes: TESTS, TESTSSCORES
sub macro_tests {
  my($name,$sep) = @_;
  my(@s) = split(/,/, $MSGINFO->spam_status);
  if (@s > 50) { $#s = 50-1; push(@s,"...") }   # sanity limit
  @s = map {my($tn,$ts)=split(/=/); $tn} @s  if $name eq 'TESTS';
  if ($name eq 'T' || !defined($sep)) { \@s } else { join($sep,@s) }
};

# implements macros: 2, and SA lookalikes: YESNO, YESNOCAPS
sub macro_yesno {
  my($name) = @_;
  my($any); my($tag2_level);
  my($spam_level) = $MSGINFO->spam_level;
  for my $r (@{$MSGINFO->per_recip_data}) {
    my($recip) = $r->recip_addr;
    my($blacklisted) = $r->recip_blacklisted_sender;
    my($whitelisted) = $r->recip_whitelisted_sender;
    my($boost)       = $r->recip_score_boost;
    my($is_local,$tag2_level,$bypassed);
    $is_local   = lookup(0,$recip, @{ca('local_domains_maps')});
    $tag2_level = lookup(0,$recip, @{ca('spam_tag2_level_maps')});
    $bypassed   = lookup(0,$recip, @{ca('bypass_spam_checks_maps')});
    my($do_tag2) = $is_local && !$bypassed && !$whitelisted &&
      ( $blacklisted ||
        (defined $tag2_level && $spam_level+$boost >= $tag2_level) );
    $any = 1  if $do_tag2;  # above tag2 level for any recipient?
  }
  if ($name eq 'YESNOCAPS') { $any ? 'YES' : 'NO' }
  elsif ($name eq 'YESNO')  { $any ? 'Yes' : 'No' }
  else { $any ? '1' : '0' }
};

# implements macros: c, and SA lookalikes: SCORE(pad), STARS(*)
sub macro_score {
  my($recip_index) = shift;  # extra argument provided by caller!
  my($name,$arg) = @_; my($result); my(@boost); my($w) = '';
  if ($name eq 'SCORE' && defined($arg) && $arg=~/^(0+| +)\z/)
    { $w = length($arg)+4; $w = $arg=~/^0/ ? "0$w" : "$w" }  # SA style padding
  my($fmt) = "%$w.3f"; my($fmts) = "%+$w.3f";  # padding, sign
  if (defined $recip_index) {  # return info on one particular recipient
    my($r) = $MSGINFO->per_recip_data->[$recip_index];
    @boost = ( !defined($r) ? undef : $r->recip_score_boost );
  } else {                     # return summary info on all recipients
    @boost = map { $_->recip_score_boost } @{$MSGINFO->per_recip_data};
  }
  my($sl) = $MSGINFO->spam_level;
  if ($name eq 'STARS') {
    my($slc) = $arg ne '' ? $arg : c('sa_spam_level_char');
    $result = $slc eq '' || !defined($sl) ?'' : $slc x min(50,$sl+max(@boost));
  } elsif (!defined($sl)) {
    $result = '-';
  } else {
    $sl = sprintf($fmt,$sl);  $sl =~ s/0+\z//;  # trim trailing zeroes
    if (!grep {defined($_) && abs($_) >= 0.0005} @boost) { $result = $sl }
    else {  # format SA score +/- by-sender score boosts
      if (@boost <= 1) {
        $result = sprintf($fmts,$boost[0]); $result=~s/\.?0+\z//;  # with sign
      } else {
        $result = '+(' . join(',',
             map {my($s)=sprintf($fmt,$_); $s=~s/\.?0+\z//; $s} @boost) . ')' }
      $result = $sl . $result;
    }
  }
  $result;
};

# implements macros: header_field
# Can only obtain header field stored in $msginfo->orig_header_fields,
# and only its first occurrence; currently these are: from, to, subject,
# precedence, received, x-mailer, message-id, resent-message-id
sub macro_header_field {
  my($name,$header_field_name) = @_;
  local($_) = $MSGINFO->orig_header_fields->{lc($header_field_name)};
  if (defined $_) {  # unfold, trim, protect CR LF
    chomp; s/\n([ \t])/$1/gs; s/^[ \t]+//; s/[ \t\n]+\z//;
    s{([\r\n])}{sprintf("\\%03O",ord($1))}eg;
  };
  $_;
};

# initialize the %builtins, which is an associative array of built-in macros
# to be used in notification message expansion.
sub init_builtin_macros() {
  # A key (macro name) used to be a single character, but can now be a longer
  # string, typically a name containing letters, numbers and '_' or '-'.
  # 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. All-uppercase multicharacter names are
  # intended for SpamAssassin-lookalike macros, although there is nothing
  # special about them and can be called like other macros.
  #
  # 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 at the time of initialization, such
  # as AV scanner results, or provide a lazy evaluation for more expensive
  # calculations. Subroutine will be called in scalar context, its first
  # argument is a macro name (a string), remaining arguments (strings, if any)
  # are arguments of a macro call as specified in the call. The subroutine may
  # return a scalar string (or undef), or an array reference.
  #
  # for SpamAssassin-lookalike macros semantics see Mail::SpamAssassin::Conf
  %builtins = (
    '.' => undef,
    p => sub {c('policy_bank_path')},

    # mail reception timestamp (e.g. start of a SMTP transaction):
    DATE => sub {rfc2822_timestamp($MSGINFO->rx_time)},
    d    => sub {rfc2822_timestamp($MSGINFO->rx_time)},  # rfc2822 local time
    U => sub {iso8601_utc_timestamp($MSGINFO->rx_time)}, # iso8601 UTC
    u => sub {sprintf("%010d",$MSGINFO->rx_time)},   # s since Unix epoch (UTC)
    # equivalent, but with more descriptive macro names:
    date_unix_utc      => sub {sprintf("%010d",$MSGINFO->rx_time)},
    date_iso8601_utc   => sub {iso8601_utc_timestamp($MSGINFO->rx_time)},
    date_iso8601_local => sub {iso8601_timestamp($MSGINFO->rx_time)},
    date_rfc2822_local => sub {rfc2822_timestamp($MSGINFO->rx_time)},

    y => sub {sprintf("%.0f", 1000*get_time_so_far())},  # elapsed time in ms
    h        => sub {c('myhostname')},  # fqdn name of this host
    HOSTNAME => sub {c('myhostname')},
    l => sub {my($ip) = $MSGINFO->client_addr; my($val);
              $val = $ip ne '' ? lookup_ip_acl($ip,@{ca('mynetworks_maps')})
                               : lookup(0,$MSGINFO->sender_source,
                                        @{ca('local_domains_maps')});
              $val ? 1 : undef}, # sender client IP (if known) from @mynetworks
                                 # (if IP is known), or sender domain is local
    s => sub {qquote_rfc2821_local($MSGINFO->sender)}, # orig.env. sender in <>
    S => sub { # unmangled sender or sender address to be notified, or empty...
               sanitize_str($MSGINFO->sender_contact) },  # ..if sender unknown
    o => sub { # best attempt at determining true sender (origin) of the virus,
               sanitize_str($MSGINFO->sender_source) },   # normally same as %s
    R => sub {$MSGINFO->recips},    # original message recipients list
    D => sub {my($y,$n,$f)=delivery_short_report($MSGINFO); $y}, #succ. delivrd
    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
    Q => sub {$MSGINFO->queue_id},  # MTA queue ID of the message if known
    m => sub {macro_header_field('header','Message-ID')},
    r => sub {macro_header_field('header','Resent-Message-ID')},
    j => sub {macro_header_field('header','Subject')},
    'x-mailer' => sub {macro_header_field('header','X-Mailer')},
    header_field => \&macro_header_field,
    ccat_maj => sub {my($maj,$min)=$MSGINFO->main_contents_category;
                     $maj ne '' ? "$maj" : "0" },
    ccat_min => sub {my($maj,$min)=$MSGINFO->main_contents_category;
                     $min ne '' ? "$min" : "0" },
    ccat_name=> sub {$MSGINFO->setting_by_contents_category(
                                                        \%ccat_display_names)},
    b => sub {$MSGINFO->body_digest},  # original message body digest
    n => sub {am_id()},  # amavis internal message id (for log entries)
    i => sub {$MSGINFO->mail_id},  # long-term unique mail id on this system
    q => sub {my($q) = $MSGINFO->quarantined_to;
              !defined($q) ? undef :
                [map { my($m)=$_; $m=~s{^\Q$QUARANTINEDIR\E/}{}; $m } @$q];
             },  # list of quarantine mailboxes
    v => sub {[split(/[ \t]*\r?\n/,$av_output)]},   # anti-virus scanner output
    V => sub {my(%seen); [grep {!$seen{$_}++} @virusname]}, #unique virus names
    F => sub { my(%seen);                           # list of banned file names
               my(@b) = grep { !$seen{$_}++ }
                        map  { @{$_->banned_parts} }
                        grep { defined $_->banned_parts }
                        @{$MSGINFO->per_recip_data};
               my($b_chopped) = @b > 2;  @b = (@b[0,1],'...')  if $b_chopped;
               s/[ \t]{6,}/ ... /g  for @b;
               \@b },
    X => sub {\@bad_headers},
    W => sub {\@detecting_scanners}, # list of av scanners detecting a virus
    H => sub {[map {my $h=$_; chomp($h); $h} @{$MSGINFO->orig_header}]},
    A       => sub {[split(/\r?\n/, $MSGINFO->spam_summary)]}, # SA report text
    SUMMARY => sub {$MSGINFO->spam_summary},
    REPORT  => sub {$MSGINFO->spam_report},
    TESTSSCORES => \&macro_tests,  # tests triggered, with scores
    TESTS       => \&macro_tests,  # tests triggered, without scores
    z => sub {$MSGINFO->msg_size}, # mail size
    t => sub { # first entry in the Received trace
               sanitize_str(first_received_from($MSGINFO->mime_entity)) },
    e => sub { # first valid public IP in the Received trace
               sanitize_str(best_try_originator_ip($MSGINFO->mime_entity)) },
    a => sub {$MSGINFO->client_addr}, # original SMTP session client IP address
    g => sub { # original SMTP session client DNS name
               sanitize_str($MSGINFO->client_name) },
    REMOTEHOSTADDR => sub {$CONN->client_ip}, # where the request was sent from
    REMOTEHOSTNAME =>
         sub {my($ip) = $CONN->client_ip; $ip ne '' ? "[$ip]" : 'localhost'},
#   VERSION    => Mail::SpamAssassin::Version(),     # SA version
#   SUBVERSION => $Mail::SpamAssassin::SUB_VERSION,  # SA sub-version/revision
    AUTOLEARN  => sub {$MSGINFO->autolearn_status},
    REQD => sub { my($tag2_level);
                  for (@{$MSGINFO->per_recip_data}) {  # get minimal tag2_level
                    my($tag2_l) = lookup(0,$_->recip_addr,
                                         @{ca('spam_tag2_level_maps')});
                    $tag2_level = $tag2_l  if defined($tag2_l) &&
                              (!defined($tag2_level) || $tag2_l < $tag2_level);
                  }
                  !defined($tag2_level) ? '-' : 0+sprintf("%.3f",$tag2_level);
                },
    k => sub { my($name) = @_;  my($kill_level);
               scalar(grep   # any recipient declared the message be killed ?
                 { !$_->recip_whitelisted_sender &&
                   ($_->recip_blacklisted_sender ||
                     ($kill_level = lookup(0,$_->recip_addr,
                                         @{ca('spam_kill_level_maps')}),
                      defined $kill_level &&
                      $MSGINFO->spam_level + $_->recip_score_boost
                                                              >= $kill_level) )
                 } @{$MSGINFO->per_recip_data}) },
    '1'=> sub { my($name) = @_;  my($tag_level);
                scalar(grep  # above tag level for any recipient?
                 { !$_->recip_whitelisted_sender &&
                   ($_->recip_blacklisted_sender ||
                     ($tag_level=lookup(0,$_->recip_addr,
                                        @{ca('spam_tag_level_maps')}),
                      defined $tag_level &&
                      $MSGINFO->spam_level + $_->recip_score_boost
                                                               >= $tag_level) )
                 } @{$MSGINFO->per_recip_data}) },
    '2'       => \&macro_yesno,
    YESNO     => \&macro_yesno,
    YESNOCAPS => \&macro_yesno,
    c         => sub {macro_score(undef,@_)},  # info on all recipients
    SCORE     => sub {macro_score(undef,@_)},  # info on all recipients
    STARS     => sub {macro_score(undef,@_)},  # info on all recipients

    wrap   => sub {my($name,$width,$prefix,$indent,$str) = @_;
                   wrap_string($str,$width,$prefix,$indent)},
    lc     => sub {my($name)=shift; lc(join('',@_))},  # to lowercase
    uc     => sub {my($name)=shift; uc(join('',@_))},  # to uppercase
    substr => sub {my($name,$s,$ofs,$len) = @_;
                   defined $len ? substr($s,$ofs,$len) : substr($s,$ofs)},
    index  => sub {my($name,$s,$substr,$pos) = @_;
                   index($s, $substr, defined $pos?$pos:0)},
    len    => sub {my($name,$s) = @_; length($s)},
    incr   => sub {my($name,$v,@rest) = @_;
                   if (!@rest) { $v++ } else { $v += $_ for @rest };  "$v"},
    decr   => sub {my($name,$v,@rest) = @_;
                   if (!@rest) { $v-- } else { $v -= $_ for @rest };  "$v"},
    # macros f, T, C, B will be defined for each notification as appropriate
    # (representing From:, To:, Cc:, and Bcc: respectively)
    # remaining free letters: xEGIJKLMPYZ
  );
}

# initialize %local_delivery_aliases
sub init_local_delivery_aliases() {
  # The %local_delivery_aliases maps local virtual 'localpart' to a mailbox
  # (e.g. to a quarantine filename or a directory). Used by method 'local:',
  # i.e. in mail_to_local_mailbox(), 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.
  #
  %Amavis::Conf::local_delivery_aliases = (
    'clean-quarantine'      => sub { ($QUARANTINEDIR, undef) },
    'virus-quarantine'      => sub { ($QUARANTINEDIR, undef) },
    'banned-quarantine'     => sub { ($QUARANTINEDIR, undef) },
    'bad-header-quarantine' => sub { ($QUARANTINEDIR, undef) },
    'spam-quarantine'       => sub { ($QUARANTINEDIR, undef) },

    # some more examples:
    'archive-files'     => sub { ("$QUARANTINEDIR",              undef) },
    'archive-mbox'      => sub { ("$QUARANTINEDIR/archive.mbox", undef) },
    'recip-quarantine'  => sub { ("$QUARANTINEDIR/recip-archive.mbox",undef) },
    'sender-quarantine' =>
      sub { my($s) = $MSGINFO->sender;
            $s = substr($s,0,100)."..."  if length($s) > 100+3;
            $s =~ tr/a-zA-Z0-9@._+-/=/c; $s =~ s/\@/_at_/g;
            $s = untaint($s)  if $s =~ /^(?:[a-zA-Z0-9%=._+-]+)\z/;  # untaint
            ($QUARANTINEDIR, "sender-$s-%m.gz");   # suggested file name
          },
#   'recip-quarantine2' => sub {
#      my(@fnames);
#      my($myfield) =
#         Amavis::Lookup::SQLfield->new($sql_policy,'some_field_name','S');
#       for my $r (@{$MSGINFO->recips}) {
#         my($field_value) = lookup(0,$r,$myfield);
#         my($fname) = $field_value;  # or perhaps: my($fname) = $r;
#         local($1); $fname =~ s/[^a-zA-Z0-9._@]/=/g; $fname =~ s/\@/%/g;
#         $fname = untaint($fname)  if $fname =~ /^([a-zA-Z0-9._=%]+)\z/;
#         $fname =~ s/%/%%/g;  # protect %
#         do_log(3, "Recipient: %s, field: %s, fname: %s",
#                   $r, $field_value, $fname);
#         push(@fnames, $fname);
#       }
#       # ???what file name to choose if there is more than one recipient???
#       ( $QUARANTINEDIR, "sender-$fnames[0]-%i-%n.gz" ); # suggested file name
#     },
  );
}

# initialize some remaining global variables;
# invoked after chroot and after privileges have been dropped
sub after_chroot_init() {
  $child_invocation_count = $child_task_count = 0;
  %modules_basic = %INC;  # helps to track missing modules in chroot
  my(@msg);
  my($euid) = $>;   # effective UID
  $> = 0;           # try to become root
  POSIX::setuid(0)  if $> != 0;  # and try some more
  if ($> == 0) {    # succeded? panic!
    @msg = ("It is possible to change EUID from $euid to root, ABORTING!",
            "Please use the most recent Net::Server or apply a patch - see:",
            "  http://www.ijs.si/software/amavisd/#net-server-sec",
            "or start as non-root, e.g. by su(1) or using option -u user");
  } elsif ($daemon_chroot_dir eq '') {
    # A quick check on vulnerability/protection of a config file
    # (non-exhaustive: doesn't test for symlink tricks and higher directories).
    # The config file has already been executed by now, so it may be
    # too late to feel sorry now, but better late then never.
    for my $config_file (@config_files) {
      my($fh) = IO::File->new;
      my($errn) = lstat($config_file) ? 0 : 0+$!;
      if ($errn) {  # not accessible, don't bother to test further
      } elsif ($fh->open($config_file,'+<')) {
        push(@msg, "Config file \"$config_file\" is writable, ".
                   "UID $<, EUID $>, EGID $)" );
        $fh->close;  # close, ignoring status
      } elsif (rename($config_file, $config_file.'.moved')) {
        my($m) = 'appears writable (unconfirmed)';
        if (!-e($config_file) && -e($config_file.'.moved')) {
          rename($config_file.'.moved', $config_file);  # try to rename back
          $m = 'is writable (confirmed)';
        }
        push(@msg, "Directory of a config file \"$config_file\" $m, ".
                   "UID $<, EUID $>, EGID $)" );
      }
      last  if @msg;
    }
  }
  if (@msg) {
    do_log(-3,"FATAL: %s",$_)  for @msg;
    print STDERR (map {"$_\n"} @msg);
    die "SECURITY PROBLEM, ABORTING";
    exit 1;  # just in case
  }
  # report versions of some modules
  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::ClamAV Mail::SpamAssassin Mail::SpamAssassin::SpamCopURI URI
      Razor2::Client::Version Mail::SPF::Query Digest::MD5 Authen::SASL
      IO::Socket::INET6 Net::DNS Net::SMTP Net::Cmd Net::Server Net::LDAP
      DBI DBD::mysql DBD::Pg DBD::SQLite BerkeleyDB DB_File
      SAVI Unix::Syslog Time::HiRes);
    do_log(0, "Module %-19s %s", $m, $m->VERSION || '?');
  }
  do_log(0,"Amavis::DB code     %s loaded", $extra_code_db         ?'':" NOT");
  do_log(0,"Amavis::Cache code  %s loaded", $extra_code_cache      ?'':" NOT");
  do_log(0,"SQL base code       %s loaded", $extra_code_sql_base   ?'':" NOT");
  do_log(0,"SQL::Log code       %s loaded", $extra_code_sql_log    ?'':" NOT");
  do_log(0,"SQL::Quarantine     %s loaded", $extra_code_sql_quar   ?'':" NOT");
  do_log(0,"Lookup::SQL code    %s loaded", $extra_code_sql_lookup ?'':" NOT");
  do_log(0,"Lookup::LDAP code   %s loaded", $extra_code_ldap       ?'':" NOT");
  do_log(0,"AM.PDP-in proto code%s loaded", $extra_code_in_amcl    ?'':" NOT");
  do_log(0,"SMTP-in proto code  %s loaded", $extra_code_in_smtp    ?'':" NOT");
  do_log(0,"Courier proto code  %s loaded", $extra_code_in_courier ?'':" NOT");
  do_log(0,"SMTP-out proto code %s loaded", $extra_code_out_smtp   ?'':" NOT");
  do_log(0,"Pipe-out proto code %s loaded", $extra_code_out_pipe   ?'':" NOT");
  do_log(0,"BSMTP-out proto code%s loaded", $extra_code_out_bsmtp  ?'':" NOT");
  do_log(0,"Local-out proto code%s loaded", $extra_code_out_local  ?'':" NOT");
  do_log(0,"OS_Fingerprint code %s loaded", $extra_code_p0f        ?'':" NOT");
  do_log(0,"ANTI-VIRUS code     %s loaded", $extra_code_antivirus  ?'':" NOT");
  do_log(0,"ANTI-SPAM code      %s loaded", $extra_code_antispam   ?'':" NOT");
  do_log(0,"ANTI-SPAM-SA code   %s loaded", $extra_code_antispam_sa?'':" NOT");
  do_log(0,"Unpackers code      %s loaded", $extra_code_unpackers  ?'':" NOT");

  # store policy names into 'policy_bank_name' fields, if not explicitly set
  for my $name (keys %policy_bank) {
    if (ref($policy_bank{$name}) eq 'HASH' &&
        !exists($policy_bank{$name}{'policy_bank_name'})) {
      $policy_bank{$name}{'policy_bank_name'} = $name;
      $policy_bank{$name}{'policy_bank_path'} = $name;
    }
  }
};

# overlay the current policy bank by settings from the
# $policy_bank{$policy_bank_name}, or load the default policy bank (empty name)
sub load_policy_bank($) {
  my($policy_bank_name) = @_;
  if (!exists $policy_bank{$policy_bank_name}) {
    do_log(-1,'policy bank "%s" does not exist, ignored', $policy_bank_name);
  } elsif ($policy_bank_name eq '') {
    %current_policy_bank = %{$policy_bank{$policy_bank_name}};
    do_log(4,'loaded base policy bank');
  } else {
    my($cpbp) = c('policy_bank_path');  # currently loaded bank
    for my $k (keys %{$policy_bank{$policy_bank_name}}) {
      do_log(-1,'loading policy bank "%s": unknown field "%s"',
                $policy_bank_name,$k)  if !exists $current_policy_bank{$k};
      $current_policy_bank{$k} = $policy_bank{$policy_bank_name}{$k};
    }
    $current_policy_bank{'policy_bank_path'} =
      ($cpbp eq '' ? '' : $cpbp.'/') . $policy_bank_name;
    do_log(2,'loaded policy bank "%s"%s', $policy_bank_name,
                     $cpbp eq '' ? '' : " over \"$cpbp\"");
  }
}

### Net::Server hook
### This hook occurs in the parent (master) process after chroot,
### change of user, and change of group has occured. It allows
### for preparation before looping begins.
sub pre_loop_hook {
  my($self) = @_;
  local $SIG{CHLD} = 'DEFAULT';
  eval {
    after_chroot_init();  # the rest of the top-level initialization

    # this needs to be done only after chroot, otherwise paths will be wrong
    find_external_programs([split(/:/,$path,-1)]);  # path, decoders, scanners
    # 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 ($enable_global_cache && $extra_code_db) {
      my($name) = $db_home;
      $name = "$daemon_chroot_dir $name"  if $daemon_chroot_dir ne '';
      $errn = stat($db_home) ? 0 : 0+$!;
      if ($errn == ENOENT) {
        die "Please create an empty directory $name to hold a database".
            " (config variable \$db_home)\n" }
      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" }
      Amavis::DB::init(1);
    }
    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_pre_fork()  if $extra_code_antispam;
  };
  if ($@ ne '') {
    chomp($@); my($msg) = "TROUBLE in pre_loop_hook: $@"; do_log(-2,"%s",$msg);
    die("Suicide (" . am_id() . ") " . $msg . "\n");
  }
  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: %s", $msg);  # just call Amavis' traditional logging
  1;
}

### user customizable Net::Server hook (Net::Server 0.88 or later),
### hook occurs in the master process
sub run_n_children_hook {
  Amavis::AV::sophos_savi_reload()
    if $extra_code_antivirus && Amavis::AV::sophos_savi_stale();
  add_entropy(Time::HiRes::gettimeofday);
}
### compatibility with patched Net::Server by SAVI patch (Net::Server <= 0.87)
sub parent_fork_hook { my($self) = @_; $self->run_n_children_hook }

### user customizable Net::Server hook
sub child_init_hook {
  my($self) = @_;
  local $SIG{CHLD} = 'DEFAULT';
  $0 = 'amavisd (virgin child)';
  my($inherited_entropy);
  eval {
    $db_env = $snmp_db = $body_digest_cache = undef;  # just in case
    Amavis::Timing::init(); snmp_counters_init();
    close_log(); open_log();  # reopen syslog or log file to get per-process fd
    if ($extra_code_db) {
      $db_env = Amavis::DB->new;  # get access to a bdb environment
      $snmp_db = Amavis::DB::SNMP->new($db_env);
      $snmp_db->register_proc('')  if defined $snmp_db;  # process alive & idle
      my($var_ref) = $snmp_db->read_snmp_variables('entropy');
      $inherited_entropy = $var_ref->[0]  if $var_ref && @$var_ref;
    }
    # if $db_env is undef the Amavis::Cache::new creates a memory-based cache
    $body_digest_cache = Amavis::Cache->new($db_env);
    if ($extra_code_db) {  # is it worth reporting the timing? (probably not)
      section_time('bdb-open');
      do_log(2, "%s", Amavis::Timing::report());  # report elapsed times
    }

    # Prepare permanent SQL dataset connection objects, does not connect yet!
    # $sql_dataset_conn_lookups and $sql_dataset_conn_storage may be the
    # same dataset (one connection used), or they may be separate objects,
    # which will make separate connections to distinct datasets,
    # possibly using different SQL engine types or servers
    if ($extra_code_sql_lookup && @lookup_sql_dsn) {
      $sql_dataset_conn_lookups =
        Amavis::Out::SQL::Connection->new(@lookup_sql_dsn);
    }
    if ($extra_code_sql_log && @storage_sql_dsn) {
      if (!$sql_dataset_conn_lookups || @storage_sql_dsn != @lookup_sql_dsn
          || grep { $storage_sql_dsn[$_] ne $lookup_sql_dsn[$_] }
                  (0..$#storage_sql_dsn) )
      { # DSN differs or no SQL lookups, storage needs its own connection
        $sql_dataset_conn_storage =
          Amavis::Out::SQL::Connection->new(@storage_sql_dsn);
        do_log(2,"storage and lookups will use separate connections to SQL")
          if $sql_dataset_conn_lookups;
      } else {  # same dataset, use the same database connection object
        $sql_dataset_conn_storage = $sql_dataset_conn_lookups;
        do_log(2,"storage and lookups will use the same connection to SQL");
      }
    }
    # Make storage/lookup objs to hold DBI handles and 'prepared' statements.
    $sql_storage = Amavis::Out::SQL::Log->new($sql_dataset_conn_storage)
                                                  if $sql_dataset_conn_storage;
    $sql_policy = Amavis::Lookup::SQL->new($sql_dataset_conn_lookups,
                                   'sel_policy')  if $sql_dataset_conn_lookups;
    $sql_wblist = Amavis::Lookup::SQL->new($sql_dataset_conn_lookups,
                                   'sel_wblist')  if $sql_dataset_conn_lookups;
  };
  if ($@ ne '') {
    chomp($@); do_log(-2, "TROUBLE in child_init_hook: %s", $@);
    die "Suicide in child_init_hook: $@\n";
  }
  add_entropy($$, Time::HiRes::gettimeofday, $inherited_entropy);
  Amavis::Timing::go_idle('vir');
}

### user customizable Net::Server hook
sub post_accept_hook {
  my($self) = @_;
  local $SIG{CHLD} = 'DEFAULT';
  $child_invocation_count++;
  $0 = sprintf("amavisd (ch%d-accept)", $child_invocation_count);
  Amavis::Timing::go_busy('hi ');
  # establish initial time right after 'accept'
  Amavis::Timing::init(); snmp_counters_init();
  $snmp_db->register_proc('A')  if defined $snmp_db;  # in 'accept' state
  load_policy_bank('');    # start with a builting policy bank
}

### 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) = @_;
  local($1,$2,$3,$4);  # Perl bug: $1 and $2 come tainted from Net::Server !
  local $SIG{CHLD} = 'DEFAULT';
  my($prop) = $self->{server}; my($sock) = $prop->{client}; my($bank_name);
  my($is_ux) = UNIVERSAL::can($sock,'NS_proto') && $sock->NS_proto eq 'UNIX';
  if ($is_ux) {
    $bank_name = $interface_policy{"SOCK"};  # possibly undef
  } else {
    my($myif,$myport) = ($prop->{sockaddr}, $prop->{sockport});
    if (defined $interface_policy{"$myif:$myport"}) {
      $bank_name = $interface_policy{"$myif:$myport"};
    } elsif (defined $interface_policy{$myport}) {
      $bank_name = $interface_policy{$myport};
    }
  }
  load_policy_bank($bank_name)  if defined $bank_name &&
                                   $bank_name ne c('policy_bank_name');
  # note that the new policy bank may have replaced the inet_acl access table
  if ($is_ux) {
    # always permit access - unix sockets are immune to this check
  } else {
    my($permit,$fullkey,$err) = lookup_ip_acl($prop->{peeraddr},
                       Amavis::Lookup::Label->new('inet_acl'), ca('inet_acl'));
    if (defined($err) && $err ne '') {
      do_log(-1, "DENIED ACCESS due to INVALID IP ADDRESS %s: %s",
                 $prop->{peeraddr}, $err);
      return 0;
    } elsif (!$permit) {
      do_log(-1, "DENIED ACCESS from IP %s, policy bank '%s'%s",
                 $prop->{peeraddr}, c('policy_bank_name'),
                 !defined $fullkey ? '' : ", blocked by rule $fullkey");
      return 0;
    }
  }
  1;
}

### The heart of the program
### user customizable Net::Server hook
sub process_request {
  my($self) = shift;
  local $SIG{CHLD} = 'DEFAULT';
  local($1,$2,$3,$4);  # Perl bug: $1 and $2 come tainted from Net::Server !
  my($prop) = $self->{server}; my($sock) = $prop->{client};
  ll(3) && do_log(3, "process_request: fileno sock=%s, STDIN=%s, STDOUT=%s",
                     fileno($sock), fileno(STDIN), fileno(STDOUT));
  # Net::Server 0.91 dups a socket to STDIN and STDOUT, which we do not want;
  #   it also forgets to close STDIN & STDOUT afterwards, so session remains
  #   open (smtp QUIT does not work), fixed in 0.92;
  # Net::Server 0.92 introduced option no_client_stdout, but it
  #   breaks Net::Server::get_client_info by setting it, so we can't use it;
  # On NetBSD closing fh STDIN (on fd0) somehow leaves fd0 still assigned to
  #   a socket (Net::Server 0.91) and can not be closed even by a POSIX::close
  # Let's just leave STDIN and STDOUT as they are, which works for versions of
  # Net::Server 0.90 and older, is wasteful with 0.91 and 0.92, and hopefully
  # will be resolved with 0.93.
  binmode($sock) or die "Can't set socket to binmode: $!";
  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
#     { cloexec($_,1,$_)  for @{$prop->{sock}} }
    prolong_timer('new request - timer reset', $child_timeout);  # timer init
    if ($extra_code_ldap && !defined $ldap_policy) {
      # make LDAP lookup object
      $ldap_connection = Amavis::LDAP::Connection->new($default_ldap);
      $ldap_policy = Amavis::Lookup::LDAP->new($default_ldap,$ldap_connection)
        if $ldap_connection;
    }
    if (defined $ldap_policy && !$implicit_maps_inserted) {
      # make LDAP field lookup objects with incorporated field names
      # fieldtype: B=boolean, N=numeric, S=string, L=list
      #            B-, N-, S-, L-  returns undef if field does not exist
      #            B0: boolean, nonexistent field treated as false,
      #            B1: boolean, nonexistent field treated as true
      my $lf = sub{Amavis::Lookup::LDAPattr->new($ldap_policy,@_)};
      unshift(@Amavis::Conf::virus_lovers_maps,        $lf->('amavisVirusLover',         'B-'));
      unshift(@Amavis::Conf::spam_lovers_maps,         $lf->('amavisSpamLover',          'B-'));
      unshift(@Amavis::Conf::banned_files_lovers_maps, $lf->('amavisBannedFilesLover',   'B-'));
      unshift(@Amavis::Conf::bad_header_lovers_maps,   $lf->('amavisBadHeaderLover',     'B-'));
      unshift(@Amavis::Conf::bypass_virus_checks_maps, $lf->('amavisBypassVirusChecks',  'B-'));
      unshift(@Amavis::Conf::bypass_spam_checks_maps,  $lf->('amavisBypassSpamChecks',   'B-'));
      unshift(@Amavis::Conf::bypass_banned_checks_maps,$lf->('amavisBypassBannedChecks', 'B-'));
      unshift(@Amavis::Conf::bypass_header_checks_maps,$lf->('amavisBypassHeaderChecks', 'B-'));
      unshift(@Amavis::Conf::spam_tag_level_maps,      $lf->('amavisSpamTagLevel',       'N-'));
      unshift(@Amavis::Conf::spam_tag2_level_maps,     $lf->('amavisSpamTag2Level',      'N-'));
      unshift(@Amavis::Conf::spam_kill_level_maps,     $lf->('amavisSpamKillLevel',      'N-'));
      unshift(@Amavis::Conf::spam_modifies_subj_maps,  $lf->('amavisSpamModifiesSubj',   'B-'));
      unshift(@Amavis::Conf::message_size_limit_maps,  $lf->('amavisMessageSizeLimit',   'N-'));
      unshift(@Amavis::Conf::clean_quarantine_to_maps, $lf->('amavisCleanQuarantineTo',  'S-'));
      unshift(@Amavis::Conf::virus_quarantine_to_maps, $lf->('amavisVirusQuarantineTo',  'S-'));
      unshift(@Amavis::Conf::spam_quarantine_to_maps,  $lf->('amavisSpamQuarantineTo',   'S-'));
      unshift(@Amavis::Conf::banned_quarantine_to_maps, $lf->('amavisBannedQuarantineTo','S-'));
      unshift(@Amavis::Conf::bad_header_quarantine_to_maps, $lf->('amavisBadHeaderQuarantineTo', 'S-'));
      unshift(@Amavis::Conf::local_domains_maps,       $lf->('amavisLocal',              'B1'));
      unshift(@Amavis::Conf::warnvirusrecip_maps,      $lf->('amavisWarnVirusRecip',     'B-'));
      unshift(@Amavis::Conf::warnbannedrecip_maps,     $lf->('amavisWarnBannedRecip',    'B-'));
      unshift(@Amavis::Conf::warnbadhrecip_maps,       $lf->('amavisWarnBadHeaderRecip', 'B-'));
      unshift(@Amavis::Conf::virus_admin_maps,         $lf->('amavisVirusAdmin',         'S-'));
      unshift(@Amavis::Conf::newvirus_admin_maps,      $lf->('amavisNewVirusAdmin',      'S-'));
      unshift(@Amavis::Conf::spam_admin_maps,          $lf->('amavisSpamAdmin',          'S-'));
      unshift(@Amavis::Conf::banned_admin_maps,        $lf->('amavisBannedAdmin',        'S-'));
      unshift(@Amavis::Conf::bad_header_admin_maps,    $lf->('amavisBadHeaderAdmin',     'S-'));
      unshift(@Amavis::Conf::banned_filename_maps,     $lf->('amavisBannedRuleNames',    'S-'));
      section_time('ldap-prepare');
    }
    if (defined $sql_policy && !$implicit_maps_inserted) {
      # 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(@Amavis::Conf::local_domains_maps,        $nf->('local',                'B1'));

      unshift(@Amavis::Conf::virus_lovers_maps,         $nf->('virus_lover',          'B-'));
      unshift(@Amavis::Conf::spam_lovers_maps,          $nf->('spam_lover',           'B-'));
      unshift(@Amavis::Conf::banned_files_lovers_maps,  $nf->('banned_files_lover',   'B-'));
      unshift(@Amavis::Conf::bad_header_lovers_maps,    $nf->('bad_header_lover',     'B-'));

      unshift(@Amavis::Conf::bypass_virus_checks_maps,  $nf->('bypass_virus_checks',  'B-'));
      unshift(@Amavis::Conf::bypass_spam_checks_maps,   $nf->('bypass_spam_checks',   'B-'));
      unshift(@Amavis::Conf::bypass_banned_checks_maps, $nf->('bypass_banned_checks', 'B-'));
      unshift(@Amavis::Conf::bypass_header_checks_maps, $nf->('bypass_header_checks', 'B-'));

      unshift(@Amavis::Conf::spam_tag_level_maps,       $nf->('spam_tag_level',       'N-'));
      unshift(@Amavis::Conf::spam_tag2_level_maps,      $nf->('spam_tag2_level',      'N-'));
      unshift(@Amavis::Conf::spam_kill_level_maps,      $nf->('spam_kill_level',      'N-'));
      unshift(@Amavis::Conf::spam_dsn_cutoff_level_maps,$nf->('spam_dsn_cutoff_level','N-'));
      unshift(@Amavis::Conf::spam_quarantine_cutoff_level_maps,$nf->('spam_quarantine_cutoff_level','N-'));

      unshift(@Amavis::Conf::spam_modifies_subj_maps,   $nf->('spam_modifies_subj',   'B-'));
      unshift(@Amavis::Conf::spam_subject_tag_maps,     $nf->('spam_subject_tag',     'S-'));
      unshift(@Amavis::Conf::spam_subject_tag2_maps,    $nf->('spam_subject_tag2',    'S-'));

      unshift(@Amavis::Conf::clean_quarantine_to_maps,  $nf->('clean_quarantine_to',  'S-'));
      unshift(@Amavis::Conf::virus_quarantine_to_maps,  $nf->('virus_quarantine_to',  'S-'));
      unshift(@Amavis::Conf::banned_quarantine_to_maps, $nf->('banned_quarantine_to', 'S-'));
      unshift(@Amavis::Conf::bad_header_quarantine_to_maps, $nf->('bad_header_quarantine_to','S-'));
      unshift(@Amavis::Conf::spam_quarantine_to_maps,   $nf->('spam_quarantine_to',   'S-'));
      unshift(@Amavis::Conf::message_size_limit_maps,   $nf->('message_size_limit',   'N-'));

      unshift(@Amavis::Conf::addr_extension_virus_maps, $nf->('addr_extension_virus', 'S-'));
      unshift(@Amavis::Conf::addr_extension_spam_maps,  $nf->('addr_extension_spam',  'S-'));
      unshift(@Amavis::Conf::addr_extension_banned_maps,$nf->('addr_extension_banned','S-'));
      unshift(@Amavis::Conf::addr_extension_bad_header_maps,$nf->('addr_extension_bad_header','S-'));

      unshift(@Amavis::Conf::warnvirusrecip_maps,       $nf->('warnvirusrecip',       'B-'));
      unshift(@Amavis::Conf::warnbannedrecip_maps,      $nf->('warnbannedrecip',      'B-'));
      unshift(@Amavis::Conf::warnbadhrecip_maps,        $nf->('warnbadhrecip',        'B-'));

      unshift(@Amavis::Conf::newvirus_admin_maps,       $nf->('newvirus_admin',       'S-'));
      unshift(@Amavis::Conf::virus_admin_maps,          $nf->('virus_admin',          'S-'));
      unshift(@Amavis::Conf::banned_admin_maps,         $nf->('banned_admin',         'S-'));
      unshift(@Amavis::Conf::bad_header_admin_maps,     $nf->('bad_header_admin',     'S-'));
      unshift(@Amavis::Conf::spam_admin_maps,           $nf->('spam_admin',           'S-'));
      unshift(@Amavis::Conf::banned_filename_maps,      $nf->('banned_rulenames',     'S-'));
      section_time('sql-prepare');
    }
    Amavis::Conf::label_default_maps()  if !$implicit_maps_inserted;
    $implicit_maps_inserted = 1;

    my($conn) = Amavis::In::Connection->new;
    $conn->proto($sock->NS_proto);
    my($suggested_protocol) = c('protocol');  # suggested by the policy bank
    ll(5) && do_log(5,"process_request: suggested_protocol=\"%s\" on %s",
                    $suggested_protocol,$sock->NS_proto);
    if ($sock->NS_proto eq 'UNIX') {     # traditional amavis helper program
      if ($suggested_protocol eq 'COURIER') {
        die "unavailable support for protocol: $suggested_protocol";
      } elsif ($suggested_protocol eq 'AM.PDP') {
        $amcl_in_obj = Amavis::In::AMCL->new  if !$amcl_in_obj;
        $amcl_in_obj->process_policy_request($sock, $conn, \&check_mail, 0);
      } else {  # default to old amavis helper program protocol
        $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') {
      $conn->socket_ip($prop->{sockaddr});
      $conn->socket_port($prop->{sockport});
      $conn->client_ip($prop->{peeraddr});
      if ($suggested_protocol eq 'TCP-LOOKUP') {  # postfix maps (experimental)
        process_tcp_lookup_request($sock, $conn);
        do_log(2, "%s", Amavis::Timing::report());  # report elapsed times
      } elsif ($suggested_protocol eq 'AM.PDP') {
        # amavis policy delegation protocol (e.g. new milter helper program)
        $amcl_in_obj = Amavis::In::AMCL->new  if !$amcl_in_obj;
        $amcl_in_obj->process_policy_request($sock, $conn, \&check_mail, 0);
      } else {  # defaults to SMTP or LMTP
        if (!$extra_code_in_smtp) {
          die "incoming TCP connection, but dynamic SMTP/LMTP code not loaded";
        }
        $smtp_in_obj = Amavis::In::SMTP->new  if !$smtp_in_obj;
        $smtp_in_obj->process_smtp_request(
              $sock, ($suggested_protocol eq 'LMTP'?1:0), $conn, \&check_mail);
      }
    } else {
      die("unsupported protocol: $suggested_protocol, " . $sock->NS_proto);
    }
  };  # eval
  alarm(0);  # stop the timer
  if ($@ ne '') {
    chomp($@); my($timed_out) = $@ eq "timed out";
    if ($timed_out) {
      do_log(-1, "Requesting process rundown, task exceeded allowed time");
    } else {
      do_log(-2, "TROUBLE in process_request: %s", $@);
      $smtp_in_obj->preserve_evidence(1)  if $smtp_in_obj;
      do_log(-1, "Requesting process rundown after fatal error");
    }
    undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj;
    $self->done(1);
  } elsif ($child_task_count >= $max_requests) {
    # in case of multiple-transaction protocols (e.g. SMTP, LMTP)
    # we do not like to keep running indefinitely at the mercy of MTA
    do_log(2, "Requesting process rundown after %d tasks (and %s sessions)",
              $child_task_count,$child_invocation_count);
    undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj;
    $self->done(1);
  } elsif ($extra_code_antivirus && Amavis::AV::sophos_savi_stale() ) {
    do_log(0, "Requesting process rundown due to stale Sophos virus data");
    undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj;
    $self->done(1);
  }
  my(@modules_extra) = grep {!exists $modules_basic{$_}} keys %INC;
# do_log(2, "modules loaded: %s", join(", ", sort keys %modules_basic));
  do_log(1, "extra modules loaded: %s",
            join(", ", sort @modules_extra))  if @modules_extra;
  do_log(5, "exiting process_request");
}

### override Net::Server::PreForkSimple::done (needed for Net::Server <= 0.87)
### 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 {
  my($self) = @_;
  my($prop) = $self->{server}; my($sock) = $prop->{client};
  local $SIG{CHLD} = 'DEFAULT';
  debug_oneshot(0);
  $0 = sprintf("amavisd (ch%d-avail)", $child_invocation_count);
  my($remaining_time) = alarm(0);
  do_log(5,"post_process_request_hook: %s",
            $remaining_time==0 ? "timer was not running" : "timer stopped");
  $snmp_db->register_proc('')  if defined $snmp_db; # process is alive and idle
  Amavis::Timing::go_idle('bye'); Amavis::Timing::report_load();
  # workaround: Net::Server 0.91 forgets to disconnect session
  if (Net::Server->VERSION eq '0.91') { close STDIN; close STDOUT }
}

### Child is about to be terminated
### user customizable Net::Server hook
sub child_finish_hook {
  my($self) = @_;
  local $SIG{CHLD} = 'DEFAULT';
# for my $m (sort map { s/\.pm\z//; s[/][::]g; $_ } grep {/\.pm\z/} keys %INC){
#   do_log(0, "Module %-19s %s", $m, $m->VERSION || '?')
#     if grep {$m=~/^$_/} qw(Mail::ClamAV Mail::SpamAssassin Razor2 Net::DNS);
# }
  $0 = sprintf("amavisd (ch%d-finish)", $child_invocation_count);
  do_log(5,"child_finish_hook: invoking DESTROY methods");
  undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj;
  undef $sql_storage; undef $sql_wblist; undef $sql_policy; undef $ldap_policy;
  undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage;
  undef $ldap_connection; undef $body_digest_cache;
  eval { $snmp_db->register_proc(undef) }  if defined $snmp_db;  # going away
  undef $snmp_db; undef $db_env;
}

sub END {                # runs before exiting the module
# do_log(5,"at the END handler: invoking DESTROY methods");
  undef $smtp_in_obj; undef $amcl_in_obj; undef $courier_in_obj;
  undef $sql_storage; undef $sql_wblist; undef $sql_policy; undef $ldap_policy;
  undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage;
  undef $ldap_connection; undef $body_digest_cache;
  eval { $snmp_db->register_proc(undef) }  if defined $snmp_db;  # going away
  undef $snmp_db; undef $db_env;
}

# implements Postfix TCP lookup server, see tcp_table(5) man page; experimental
sub process_tcp_lookup_request($$) {
  my($sock, $conn) = @_;
  local($/) = "\012";  # set line terminator to LF (regardless of platform)
  my($req_cnt); my($ln);
  for ($! = 0; defined($ln=$sock->getline); $! = 0) {
    $req_cnt++; my($level) = 0;
    my($resp_code, $resp_msg) = (400, 'INTERNAL ERROR');
    if ($ln =~ /^get (.*?)\015?\012\z/si) {
      my($key) = tcp_lookup_decode($1);
      my($sl); $sl = lookup(0,$key, @{ca('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 ($ln =~ /^put ([^ ]*) (.*?)\015?\012\z/si) {
      $resp_code = 500; $resp_msg = 'request not implemented: ' . $ln;
    } else {
      $resp_code = 500; $resp_msg = 'illegal request: ' . $ln;
    }
    do_log($level, "tcp_lookup(%s): %s %s", $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: $!";
  }
  defined $ln || $!==0 or die "Error reading from socket: $!";
  do_log(0, "tcp_lookup: RUNDOWN after %d requests", $req_cnt);
}

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

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

sub check_mail_begin_task() {
  # The check_mail_begin_task (and 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++;
  do_log(4, "check_mail_begin_task: task_count=%d", $child_task_count);

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

  # reset certain global variables for each task
  $av_output = undef; @detecting_scanners = ();
  @virusname = (); @bad_headers = ();
  $banned_filename_any = $banned_filename_all = 0;
  undef $MSGINFO; undef $CONN;  # just in case
}

# 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) = @_;

  my($point_of_no_return) = 0;  # past the point where mail or DSN was sent
  my($am_id) = am_id();
  $snmp_db->register_proc($am_id)  if defined $snmp_db;
  my($tempdir) = $msginfo->mail_tempdir; my($fh) = $msginfo->mail_text;
  my($sender) = $msginfo->sender; my(@recips) = @{$msginfo->recips};
  # ugly - save in a global, to make it accessible to %builtins
  $MSGINFO = $msginfo; $CONN = $conn;
  $msginfo->add_contents_category(CC_CLEAN,0);
  $_->add_contents_category(CC_CLEAN,0)  for @{$msginfo->per_recip_data};
  # compute body digest, measure mail size and check for 8-bit data
  my($body_digest) = get_body_digest($fh, $msginfo);

  my($mail_size) = $msginfo->msg_size;  # use corrected ESMTP size if available
  if ($mail_size <= 0) {                # not available?
    $mail_size = $msginfo->orig_header_size + 1 + $msginfo->orig_body_size;
    $msginfo->msg_size($mail_size);     # store back
  }
  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($virus_dejavu) = 0;
  my($virus_presence_checked,$spam_presence_checked);

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

  my($mime_err); # undef, or MIME parsing error string as given by MIME::Parser

  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($cl_ip) = $msginfo->client_addr;
  add_entropy(Time::HiRes::gettimeofday,
              "$child_task_count $am_id $cl_ip $mail_size", $msginfo->queue_id,
              $msginfo->mail_text_fn, $sender, $msginfo->recips);
  my($mail_id); my($os_fingerprint_obj,$os_fingerprint);
  my($which_section);

  $which_section = 'gen_mail_id';
  # create unique mail_id and save preliminary information to SQL (if enabled)
  for (my($attempt)=5; $attempt>0; ) {  # sanity limit on retries
    my($secret_id);
    ($mail_id,$secret_id) = generate_mail_id();
    $msginfo->secret_id($secret_id);  $secret_id = '';
    $msginfo->mail_id($mail_id);  # assign some long-term unique id to the msg
    if (!$sql_storage) { last }  # no need to store and to check for uniqueness
    else {   # attempt to save message placeholder to SQL ensuring it is unique
      $which_section = 'sql-enter';
      $sql_storage->save_info_preliminary($conn,$msginfo) and last;
      if (--$attempt <= 0) {
        do_log(-2,"ERROR sql_storage: too many retries ".
                  "on storing preliminary, info not saved");
      } else {
        do_log(2,"sql_storage: retrying preliminary, %d attempts remain",
                 $attempt);
        sleep(int(1+rand(3))); add_entropy(Time::HiRes::gettimeofday,$attempt);
      }
    }
  };
  section_time($which_section);

  my($os_fingerprint_method) = c('os_fingerprint_method');
  if (!defined($os_fingerprint_method) || $os_fingerprint_method eq '') {
    # no fingerprinting service configured
  } elsif ($cl_ip eq '' || $cl_ip eq '0.0.0.0' || $cl_ip eq '::') {
    # original client IP address not available, can't query p0f
  } else {
    $which_section = "os_fingerprint";
    $os_fingerprint_obj = Amavis::OS_Fingerprint->new(
                           dynamic_destination($os_fingerprint_method,$conn,0),
                           0.050, $cl_ip, $mail_id);
  }
  my($pbn) = c('policy_bank_path');
  do_log(1,"Checking: %s %s%s%s -> %s", $mail_id,
           $pbn eq   '' ? '' : "$pbn ",  $cl_ip eq '' ? '' : "[$cl_ip] ",
           qquote_rfc2821_local($sender),
           join(',', qquote_rfc2821_local(@recips)) );
  eval {
    snmp_count('InMsgs');
    snmp_count('InMsgsNullRPath')  if $sender eq '';
    if    (@recips == 1) { snmp_count(  'InMsgsRecips' ) }
    elsif (@recips >  1) { snmp_count( ['InMsgsRecips',scalar(@recips)] ) }

    # 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!  (no spam checking, depending on file system)
    $which_section = "creating_partsdir";
    my($errn) = lstat("$tempdir/parts") ? 0 : 0+$!;
    if ($errn == ENOENT) {  # needs to be created
      mkdir("$tempdir/parts", 0750)
        or die "Can't create directory $tempdir/parts: $!";
      section_time('mkdir parts'); }
    elsif ($errn != 0) { die "$tempdir/parts is not accessible: $!" }
    elsif (!-d _)      { die "$tempdir/parts is not a directory" }
    else {}  # fine, directory already exists

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

    # 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)     = iso8601_utc_timestamp($now,1);
    my($expires_utc_iso8601) = iso8601_utc_timestamp($now+$cache_entry_ttl,1);
    $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');
      $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 = %d s", $ttl);
          $virus_presence_checked  = 0;
        }
      }
      if ($spam_presence_checked && defined $cache_entry->{'St'}) {
        # check for expiration of cached spam test results
        # (note: hard-wired spam level 6)
        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 = %d s", $ttl);
          $spam_presence_checked  = 0;
        }
      }
      if ($virus_presence_checked) {
        $av_output = $cache_entry->{'VO'};
        @virusname = @{$cache_entry->{'VN'}};
        @detecting_scanners = @{$cache_entry->{'VD'}};
        $virus_dejavu = 1;
      }
      if ($spam_presence_checked) {
        my($spam_level,$spam_status,$spam_report,$spam_summary) =
          @$cache_entry{'SL','SS','SR','SY'};
        $msginfo->spam_level($spam_level);
        $msginfo->spam_status($spam_status);
        $msginfo->spam_report($spam_report);
        $msginfo->spam_summary($spam_summary);
      }
      do_log(1,"cached %s from <%s> (%s,%s)", $body_digest, $sender,
               $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 $msginfo->spam_level >= 6;  # a hack
      ll(5) && do_log(5,"cache entry age: %s c=%s a=%s",
                 (@virusname ? 'V' : $msginfo->spam_level > 5 ? 'S' : '.'),
                 $cache_entry->{'ctime'}, $cache_entry->{'atime'} );
    }  # if defined $cache_entry

    my($will_do_virus_scanning, $all_bypass_virus_checks);
    if ($extra_code_antivirus) {
      $all_bypass_virus_checks =
         !grep {!lookup(0,$_, @{ca('bypass_virus_checks_maps')})} @recips;
      $will_do_virus_scanning =
         !$virus_presence_checked && !$all_bypass_virus_checks;
    }
    my($will_do_banned_checking) =  # banned name checking will be needed?
       @{ca('banned_filename_maps')} || cr('banned_namepath_re');

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

    $which_section = "mime_decode-1";
    my($ent); ($ent,$mime_err) = mime_decode($fh, $tempdir, $parts_root);
    $msginfo->mime_entity($ent);
    prolong_timer($which_section);

    if ($will_do_parts_decoding) {  # decoding parts can take a lot of time
      $which_section = "parts_decode_ext";
      snmp_count('OpsDec');
      ($hold,$any_undecipherable) =
        Amavis::Unpackers::decompose_mail($tempdir,$file_generator_object);
      if ($hold ne '' || $any_undecipherable) {
        $msginfo->add_contents_category(CC_UNCHECKED,0);
        $_->add_contents_category(CC_UNCHECKED,0)
          for @{$msginfo->per_recip_data};
      }
    }

    my($bphcm) = ca('bypass_header_checks_maps');
    if (grep {!lookup(0,$_->recip_addr,@$bphcm)} @{$msginfo->per_recip_data}) {
      # check for bad headers and for bad MIME subheaders / bad MIME structure
      if (defined $mime_err && $mime_err ne '') {
        push(@bad_headers, "MIME error: ".$mime_err);
        $msginfo->add_contents_category(CC_BADH,1);
      }
      my($badh_ref,$minor_badh_cc) = check_header_validity($conn,$msginfo);
      if (@$badh_ref) {
        push(@bad_headers, @$badh_ref);
        $msginfo->add_contents_category(CC_BADH,$minor_badh_cc);
      }
      for my $r (@{$msginfo->per_recip_data}) {
        my($bypassed) = lookup(0,$r->recip_addr,@$bphcm);
        if (!$bypassed && defined $mime_err && $mime_err ne '')
          { $r->add_contents_category(CC_BADH,1) } # CC_BADH min: 1=broken mime
        if (!$bypassed && @$badh_ref)
          { $r->add_contents_category(CC_BADH,$minor_badh_cc) }
      }
    }

    if ($will_do_banned_checking) {      # check for banned file contents
      $which_section = "check-banned";
      check_for_banned_names($msginfo,$parts_root); # saves results in $msginfo
      $banned_filename_any = 0; $banned_filename_all = 1;
      for my $r (@{$msginfo->per_recip_data}) {
        my($a) = $r->banned_parts;
        if (!defined $a || !@$a) { $banned_filename_all = 0 }
        else {
          my($rhs) = $r->banned_rhs;
          if (defined $rhs) {
            for my $j (0..$#{$a}) {
              $r->dsn_suppress_reason(sprintf("BANNED:%s suggested by rule",
                                     $rhs->[$j]))  if $rhs->[$j] =~ /^DISCARD/;
            }
          }
          $banned_filename_any++;
          $r->add_contents_category(CC_BANNED,0);
        }
      }
      $msginfo->add_contents_category(CC_BANNED,0)  if $banned_filename_any;
      ll(4) && do_log(4,"banned check: any=%d, all=%s (%d)",
                        $banned_filename_any, $banned_filename_all?'Y':'N',
                        scalar(@{$msginfo->per_recip_data}));
    }

    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 ($all_bypass_virus_checks) {
      do_log(5, "bypassing of virus checks requested");
    } elsif (defined $hold && $hold ne '') { # protect virus scanner from bombs
      do_log(0, "NOTICE: Virus scanning skipped: %s", $hold);
      $will_do_virus_scanning = 0;
    } else {
      if (!$will_do_virus_scanning)
        { do_log(-1, "NOTICE: will_do_virus_scanning is false???") }
      if (!defined($msginfo->mime_entity)) {
        $which_section = "mime_decode-3";
        my($ent); ($ent,$mime_err) = mime_decode($fh, $tempdir, $parts_root);
        $msginfo->mime_entity($ent);
        prolong_timer($which_section);
      }
      # special case to make available a complete mail file for inspection
      if ((defined($mime_err) && $mime_err ne '') ||
          lookup(0,'MAIL',@keep_decoded_original_maps) ||
          $any_undecipherable && lookup(0,'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,1);
        my($newpart) = $newpart_obj->full_name;
        do_log(2, "providing full original message to scanners as %s%s%s",
             $newpart,
             !$any_undecipherable ? '' :", $any_undecipherable undecipherable",
             $mime_err eq '' ? '' : ", MIME error: $mime_err");
        link($msginfo->mail_text_fn, $newpart)
          or die sprintf("Can't create hard link %s to %s: %s",
                         $newpart, $msginfo->mail_text_fn, $!);
        $newpart_obj->type_short('MAIL');
        $newpart_obj->type_declared('message/rfc822');
      }
      $which_section = "virus_scan";
      my($av_ret);
      eval {
        my($vn, $ds);
        ($av_ret, $av_output, $vn, $ds) =
          Amavis::AV::virus_scan($tempdir, $child_task_count==1, $parts_root);
        @virusname = @$vn; @detecting_scanners = @$ds;  # copy
      };
      if ($@ ne '') {
        chomp($@);
        if ($@ eq "timed out") {     # can't happen, timer is stopped
          @virusname = (); $av_ret = 0;  # assume not a virus!
          do_log(-1, "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'} =
        ($now, $av_output, \@virusname, \@detecting_scanners);
      $virus_presence_checked = 1;
      if (defined $snmp_db && @virusname) {
        $which_section = "read_snmp_variables";
        $virus_dejavu = 1
          if !grep {!defined($_) || $_ == 0}  # none with counter zero or undef
          @{$snmp_db->read_snmp_variables(map {"virus.byname.$_"} @virusname)};
        section_time($which_section);
      }
    }
    $which_section = "post_virus_scan";
    if ($virus_presence_checked) {
      my($bpvcm) = ca('bypass_virus_checks_maps');
      for my $r (@{$msginfo->per_recip_data}) {
        my($bypassed) = lookup(0,$r->recip_addr,@$bpvcm);
        $r->infected($bypassed ? undef : @virusname ? 1 : 0);
        $r->add_contents_category(CC_VIRUS,0)  if !$bypassed && @virusname;
      }
    }
    $msginfo->add_contents_category(CC_VIRUS,0)  if @virusname;
    my($sender_contact,$sender_source);
    if (!@virusname) { $sender_contact = $sender_source = $sender }
    else {
      ($sender_contact,$sender_source) =
        best_try_originator($msginfo,\@virusname);
      section_time('best_try_originator');
    }
    $msginfo->sender_contact($sender_contact);  # save it
    $msginfo->sender_source($sender_source);    # save it

    if (defined($os_fingerprint_obj)) {
      $which_section = "fingerprint_collect";
      $os_fingerprint = $os_fingerprint_obj->collect_response;
      if (defined $os_fingerprint && $os_fingerprint ne '') {
        if (lookup_ip_acl($cl_ip,@{ca('mynetworks_maps')}))
          { $os_fingerprint = 'MYNETWORKS' }  # override for our smtp clients
        $msginfo->client_os_fingerprint($os_fingerprint);  # store info
      }
    }
    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
    # consider doing spam scanning
    if (!$extra_code_antispam) {
      do_log(5, "no anti-spam code loaded, skipping spam_scan");
    } elsif (@virusname) {
      do_log(5, "infected contents, skipping spam_scan");
    } elsif ($banned_filename_all) {
      do_log(5, "banned contents, skipping spam_scan");
    } elsif (!grep {!lookup(0,$_,@{ca('bypass_spam_checks_maps')})} @recips) {
      do_log(5, "bypassing of spam checks requested");
    } else {
      $which_section = "spam-wb-list";
      my($any_wbl, $all_wbl) = Amavis::SpamControl::white_black_list(
                     $conn, $msginfo, $sql_wblist, $user_id_sql, $ldap_policy);
      section_time($which_section);
      if ($all_wbl) {
        do_log(5, "sender white/blacklisted, skipping spam_scan");
      } elsif ($spam_presence_checked) {
        do_log(5, "spam_presence cached, skipping spam_scan");
      } else {
        $which_section = "spam_scan";
        # sets $msginfo->spam_level, spam_status,
        #      spam_report, spam_summary, autolearn_status
        Amavis::SpamControl::spam_scan($conn,$msginfo);
        prolong_timer($which_section);
        snmp_count('OpsSpamCheck');
        @$cache_entry{'St','SL','SS','SR','SY'} =
          ($now, $msginfo->spam_level, $msginfo->spam_status,
                 $msginfo->spam_report, $msginfo->spam_summary);
        $spam_presence_checked = 1;
      }
    }

    # store to cache
    $which_section = 'update_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($which_section);

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

    # SECOND: now that we know what we got, decide what to do with it
    $which_section = 'after_scanning';

    $which_section = "decide_mail_destiny";
    my($spam_level) = $msginfo->spam_level;
    my($is_bulk) = $msginfo->orig_header_fields->{'precedence'};
    $is_bulk = $is_bulk=~/^[ \t]*(bulk|list|junk)\b/i ? $1 : undef;
    my($considered_oversize_by_some_recips);
    my($mslm) = ca('message_size_limit_maps');
    for my $r (@{$msginfo->per_recip_data}) {
      next  if $r->recip_done;  # already dealt with
      my($recip) = $r->recip_addr;

      # consider adding CC_SPAM to the contents_category list;
      # spaminess is an individual matter, we must compare spam level
      # with each recipient setting, there is no single global criterium
      my($kill_level);
      $kill_level = lookup(0,$recip, @{ca('spam_kill_level_maps')});
      my($boost) = $r->recip_score_boost;
      $boost = 0  if !defined($boost);  # avoid uninitialized value warning
      my($should_be_killed) =
        !$r->recip_whitelisted_sender &&
        ($r->recip_blacklisted_sender ||
         (defined $kill_level && $spam_level+$boost >= $kill_level) );
      if ($should_be_killed) {
        # message spaminess is at or above kill level, or sender is blacklisted
        $msginfo->add_contents_category(CC_SPAM,0);
        $r->add_contents_category(CC_SPAM,0)
          if !lookup(0,$recip, @{ca('bypass_spam_checks_maps')});
      }
      # consider adding CC_OVERSIZED to the contents_category list;
      if (@$mslm) {  # checking of mail size required?
        my($size_limit) = lookup(0,$r->recip_addr, @$mslm);
        $size_limit = 65536  if $size_limit && $size_limit < 65536;  # rfc2821
        if ($size_limit && $mail_size > $size_limit) {
          do_log(1,"OVERSIZE from %s to %s: size %s B, limit %s B",
                   qquote_rfc2821_local($sender),
                   qquote_rfc2821_local($r->recip_addr),
                   $mail_size, $size_limit)
            if !$considered_oversize_by_some_recips;
          $considered_oversize_by_some_recips = 1;
          $r->add_contents_category(CC_OVERSIZED,0);
          $msginfo->add_contents_category(CC_OVERSIZED,0);
        }
      }

      my($final_destiny) = $r->setting_by_contents_category(
                                                  cr('final_destiny_by_ccat'));
#     if ($final_destiny != D_PASS && lookup(0,$sender,
#             [new_RE(qr'bugtraq-return-.*@securityfocus\.com')] )) {
#       $final_destiny = D_PASS;
#       do_log(0, "malware accepted from sender %s", $sender);
#     }
      if ($final_destiny == D_PASS) {
        # recipient wants this message, malicious or not
        do_log(4, "final_destiny PASS, recip %s", $recip);
      } else {
        my($lovers_map_ref) = $r->setting_by_contents_category(
                                                    cr('lovers_maps_by_ccat'));
        if (defined($lovers_map_ref) && lookup(0,$recip, @$lovers_map_ref)) {
          # clean, not noticed (bypass...), or recipient wants it
          do_log(4, "malware lover %s", $recip);
        } elsif ($final_destiny == D_BOUNCE &&
                 (defined $is_bulk || $sender eq '') &&
                 $r->main_contents_category == CC_BADH) {
          # have mercy on mailing lists and DSN: since a bounce for such mail
          # will be suppressed, it is probably better to just let a mail pass
          $final_destiny = D_PASS;
          do_log(1,"allow bad header from %s<%s> -> <%s>: %s",
            $is_bulk eq '' ?'' :"($is_bulk) ", $sender,$recip,$bad_headers[0]);
        } else {  # recipient does not want this content
          $r->recip_destiny($final_destiny);
          my($status_and_reason) = $r->setting_by_contents_category({
            CC_VIRUS,
              ["550 5.7.1", "VIRUS: ".join(", ", @virusname)],
            CC_BANNED,
              ["550 5.7.1", "BANNED: ".join(", ",@{$r->banned_parts || []})],
            CC_SPAM,
              ["550 5.7.1", "SPAM". ($r->recip_blacklisted_sender ?
                                                 ', sender blacklisted' : '')],
            CC_BADH.",1",
              ["550 5.6.3", "BAD_HEADER: ".(split(/\n/,$bad_headers[0]))[0]],
            CC_BADH,
              ["550 5.7.1", "BAD_HEADER: ".(split(/\n/,$bad_headers[0]))[0]],
            CC_OVERSIZED,
              ["552 5.3.4", "Message size ($mail_size B) ".
                                             "exceeds recipient's size limit"],
            CC_CLEAN,    ["550 5.7.1", "CLEAN"],
            CC_CATCHALL, ["550 5.7.1", "other"],
          });
          my($status,$reason);
          ($status,$reason) = @$status_and_reason  if $status_and_reason;
          $final_destiny!=D_PASS or die "Assert failed: $final_destiny==pass";
          if ($final_destiny == D_DISCARD)
            { $status =~ s{^5(\d\d) 5(\.\d\.\d)\z}{2$1 2$2} }  # 5xx -> 2xx
          $reason = substr($reason,0,100)."..."  if length($reason) > 100+3;
          if (ll(3) && $r->main_contents_category == CC_SPAM) {
            my($sl) = !defined($spam_level) ? 'x'
                        : 0+sprintf("%.3f",$spam_level);  # trim fraction
            do_log(3, "SPAM-KILL, %s -> %s, score=%s, kill=%s%s",
              qquote_rfc2821_local($sender, $recip),
              (!defined($boost) || $boost==0 ? $sl
               : $boost >= 0 ? $sl.'+'.$boost : $sl.$boost),
              !defined($kill_level) ? 'x' : 0+sprintf("%.3f",$kill_level),
              $r->recip_blacklisted_sender ? ', BLACKLISTED' : '');
          }
          $r->recip_smtp_response( $status . ' ' .
                                   ($final_destiny == D_PASS ? "Ok" :
                                    $final_destiny == D_DISCARD ?
                                      "Ok, discarded" : "Rejected") .
                                   ", id=$am_id - $reason");
          $r->recip_done(1);
          # note that 5xx status rejects may later be converted to bounces or
          # discards, according to $*_destiny setting
        }
      }
    }
    section_time($which_section);

    $which_section = "quar+notif";
    do_notify_and_quarantine($conn, $msginfo, $virus_dejavu);

    $which_section = "aux_quarantine";
#   do_quarantine($conn, $msginfo, undef,
#                 ['archive-files'], 'local:archive/%m');
#   do_quarantine($conn, $msginfo, undef,
#                 ['archive@localhost'], 'local:all-%m');
#   do_quarantine($conn, $msginfo, undef,
#                 ['sender-quarantine'], 'local:user-%m'
#     ) if lookup(0,$sender, ['user1@domain','user2@domain']);
#   section_time($which_section);

    if (defined $hold && $hold ne '')
      { do_log(-1, "NOTICE: HOLD reason: %s", $hold) }

    # THIRD: now that we know what to do with it, do it! (deliver or bounce)

    my($ccat_name) =
      $msginfo->setting_by_contents_category(\%ccat_display_names);
    snmp_count('Content'.$ccat_name.'Msgs');
    my($hdr_edits) = $msginfo->header_edits;
    if (!$hdr_edits) {
      $hdr_edits = Amavis::Out::EditHeader->new;
      $msginfo->header_edits($hdr_edits);
    }
    if ($msginfo->delivery_method eq '') {   # AM.PDP or AM.CL (milter)
      $which_section = "AM.PDP headers";
      ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
      $hdr_edits = add_forwarding_header_edits_common(
        $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
        $virus_presence_checked, $spam_presence_checked, undef);
      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, undef);
      $msginfo->header_edits($hdr_edits);  # store edits (redundant?)
      if (@$recip_cl && !$done_all) {
        do_log(-1, "AM.PDP: CLIENTS REQUIRE DIFFERENT HEADERS");
      };
    } elsif (grep { !$_->recip_done } @{$msginfo->per_recip_data}) {  # forward
      # To be delivered explicitly - only to those recipients not yet marked
      # as 'done' by the above content filtering sections.
      $which_section = "forwarding";
      ensure_mime_entity($msginfo, $fh, $tempdir, \@virusname, $parts_root);
      # a quick-fix solution to defang dangerous contents
      my($mail_defanged);  # nonempty indicates mail body is replaced
      my(@explanation);
      if (!$msginfo->setting_by_contents_category(cr('defang_by_ccat'))) {
        # no defanging
      } else {
        push(@explanation, 'WARNING: contains virus '.join(' ',@virusname))
          if $msginfo->is_in_contents_category(CC_VIRUS);
        push(@explanation, "WARNING: contains banned part")
          if $msginfo->is_in_contents_category(CC_BANNED);
        if ($msginfo->is_in_contents_category(CC_UNCHECKED)) {
          if ($hold ne '') {
            push(@explanation,
                 "WARNING: NOT CHECKED FOR VIRUSES (mail bomb?):\n  $hold");
          } elsif ($any_undecipherable) {
            push(@explanation, "WARNING: contains undecipherable part");
          }
        }
        push(@explanation, split(/\n/, $msginfo->spam_summary))
          if $msginfo->is_in_contents_category(CC_SPAM);
        push(@explanation, split(/\n/, wrap_string(
                   'WARNING: bad headers '.join(' ',@bad_headers), 78,'',' ')))
          if $msginfo->is_in_contents_category(CC_BADH);
        push(@explanation, 'oversized')
          if $msginfo->is_in_contents_category(CC_OVERSIZED);
      }
      if (@explanation) {  # mail needs to be defanged
        my($s) = join(' ',@explanation);
        do_log(1, "DEFANGING MAIL: %s",
                  length($s) <= 150 ? $s : substr($s,0,150-3)."...");
        for (@explanation)
          { if (length($_) > 100) { $_ = substr($_,0,100-3) . "..." } }
        $_ .= "\n"  for (@explanation); # append newlines
        my($d) = defanged_mime_entity($conn,$msginfo,\@explanation);
        $msginfo->mail_text($d);  # substitute mail with rewritten version
        $msginfo->mail_text_fn(undef);  # remove filename information
        $mail_defanged = 'Original mail wrapped as attachment (defanged)';
        section_time('defang');
      }
      $hdr_edits = add_forwarding_header_edits_common(
        $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
        $virus_presence_checked, $spam_presence_checked, $mail_defanged);
      for (;;) {  # do the delivery
        my($r_hdr_edits) = Amavis::Out::EditHeader->new;  # per-recip edits set
        $r_hdr_edits->inherit_header_edits($hdr_edits);
        my($done_all);
        my($recip_cl);  # ref to a list of similar recip objects
        ($r_hdr_edits, $recip_cl, $done_all) =
          add_forwarding_header_edits_per_recip(
            $conn, $msginfo, $r_hdr_edits, $hold, $any_undecipherable,
            $virus_presence_checked, $spam_presence_checked,
            $mail_defanged, undef);
        last  if !@$recip_cl;
        $msginfo->header_edits($r_hdr_edits);  # store edits
        mail_dispatch($conn, $msginfo, 0, $dsn_per_recip_capable,
                      sub { my($r) = @_; grep { $_ eq $r } @$recip_cl });
        snmp_count('OutForwMsgs');
        snmp_count('OutForwHoldMsgs')  if $hold ne '';
        $point_of_no_return = 1;  # now past the point where mail was sent
        last  if $done_all;
      }
    }
    prolong_timer($which_section);

    $which_section = "delivery-notification";
    my($ndn_needed);
    ($smtp_resp, $exit_code, $ndn_needed) =
      one_response_for_all($msginfo, $dsn_per_recip_capable, $am_id);
    do_log(4, "ndn_needed=%s, exit=%s, %s", $ndn_needed,$exit_code,$smtp_resp);
    $msginfo->add_contents_category(CC_TEMPFAIL,0)  if $smtp_resp =~ /^4/;
    # generate delivery status notification according to rfc3462 & rfc3464
    my($notification) = delivery_status_notification($conn,$msginfo,
                         $dsn_per_recip_capable, $smtp_resp=~/^5/, \%builtins);
    section_time('prepare-dsn');
    if (defined $notification) {   # dsn needed, send delivery notification
      mail_dispatch($conn, $notification, 1, 0);
      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
        $point_of_no_return = 2;   # now past the point where DSN was sent
      } elsif ($n_smtp_resp =~ /^4/) {
        snmp_count('OutDsnTempFails');
        die sprintf("temporarily unable to send DSN to <%s>: %s",
                    $msginfo->sender_contact, $n_smtp_resp);
      } else {
        snmp_count('OutDsnRejects');
        do_log(-1,"NOTICE: UNABLE TO SEND DSN to <%s>: %s",
                  $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, 0);
      }
    # $notification->purge;
    }
    prolong_timer($which_section);

    # generate customized log report at log level 0 - this is usually the
    # only log entry interesting to administrators during normal operation
    $which_section = 'main_log_entry';
    my(%mybuiltins) = %builtins;  # make a local copy
    { # do a per-message log entry
      # macro %T has overloaded semantics, ugly
      $mybuiltins{'T'} = $mybuiltins{'TESTSSCORES'};
      my($y,$n,$f) = delivery_short_report($msginfo);
      @mybuiltins{'D','O','N'} = ($y,$n,$f);
      my($strr) = expand(cr('log_templ'), \%mybuiltins);
      for my $logline (split(/[ \t]*\n/, $$strr)) {
        do_log(0, "%s", $logline)  if $logline ne '';
      }
    }
#   if (@virusname || $spam_level > 10) {
#     use IO::Socket::UNIX;
#     my($socketname) = '/var/tmp/some-socket';
#     my($sock);
#     $sock = IO::Socket::UNIX->new(Type => SOCK_STREAM)
#       or die "Can't create UNIX socket: $!";
#     if (!$sock->connect(pack_sockaddr_un($socketname))) {
#       do_log(0, "Can't connect to UNIX socket %s: %s", $socketname, $!);
#     } else {
#       my($sr) = expand(\'-envelope="%s", -first="%e" -last="%a"',
#                        \%mybuiltins);
#       do_log(2, "Sending to %s: %s", $socketname,$$sr);
#       $sock->print($$sr) or die "Can't write to socket $socketname: $!";
#       $sock->close or die "Error closing socket $socketname: $!";
#     }
#   }
    if (c('log_recip_templ') ne '') {  # do per-recipient log entries
      # redefine some macros with a by-recipient semantics
      my($j) = 0;
      for my $r (@{$msginfo->per_recip_data}) {
        # recipient counter in macro %. may indicate to the template
        # that a per-recipient expansion semantics is expected
        $j++; $mybuiltins{'.'} = $j;
        my($recip) = $r->recip_addr;
        my($smtp_resp)   = $r->recip_smtp_response;
        my($qrecip_addr) = scalar(qquote_rfc2821_local($recip));
        $mybuiltins{'D'} = $mybuiltins{'O'} = $mybuiltins{'N'} = undef;
        if ($r->recip_destiny==D_PASS &&($smtp_resp=~/^2/ || !$r->recip_done)){
          $mybuiltins{'D'} = $qrecip_addr;
        } else {
          $mybuiltins{'O'} = $qrecip_addr;
          my($remote_mta)  = $r->recip_remote_mta;
          $mybuiltins{'N'} = sprintf("%s:%s\n   %s", $qrecip_addr,
                  ($remote_mta eq '' ? '' : " $remote_mta said:"), $smtp_resp);
        }
        my(@b);  @b = @{$r->banned_parts}  if defined $r->banned_parts;
        my($b_chopped) = @b > 2;  @b = (@b[0,1],'...')  if $b_chopped;
        s/[ \t]{6,}/ ... /g  for @b;
        $mybuiltins{'F'} = \@b;  # list of banned file names
        my($maj,$min) = $r->main_contents_category;
        $mybuiltins{'ccat_maj'} = $maj ne '' ? "$maj" : "0";
        $mybuiltins{'ccat_min'} = $min ne '' ? "$min" : "0";
        $mybuiltins{'ccat_name'} = $r->setting_by_contents_category(
                                                         \%ccat_display_names);
        my($blacklisted) = $r->recip_blacklisted_sender;
        my($whitelisted) = $r->recip_whitelisted_sender;
        my($boost)       = $r->recip_score_boost;
        my($is_local,$tag_level,$tag2_level,$kill_level,$bypassed);
        $is_local   = lookup(0,$recip, @{ca('local_domains_maps')});
        $tag_level  = lookup(0,$recip, @{ca('spam_tag_level_maps')});
        $tag2_level = lookup(0,$recip, @{ca('spam_tag2_level_maps')});
        $kill_level = lookup(0,$recip, @{ca('spam_kill_level_maps')});
        $bypassed   = lookup(0,$recip, @{ca('bypass_spam_checks_maps')});
        my($do_tag) = $is_local && !$bypassed &&
          ( $blacklisted || !defined $tag_level ||
            ($spam_level+$boost + ($whitelisted?-10:0) >= $tag_level) );
        my($do_tag2) = $is_local && !$bypassed && !$whitelisted &&
          ( $blacklisted ||
            (defined $tag2_level && $spam_level+$boost >= $tag2_level) );
        my($do_kill) = !$bypassed && !$whitelisted &&
          ( $blacklisted ||
            (defined $kill_level && $spam_level+$boost >= $kill_level) );
        for ($do_tag,$do_tag2,$do_kill) { $_ = $_ ? 'Y' : '0' }  # normalize
        for ($is_local)                 { $_ = $_ ? 'L' : '0' }  # normalize
        for ($tag_level,$tag2_level,$kill_level) { $_ = 'x'  if !defined($_) }
        $mybuiltins{'R'} = $recip;
        $mybuiltins{'c'} = $mybuiltins{'SCORE'} = $mybuiltins{'STARS'} =
          sub { macro_score($j-1, @_) };   # info on one recipient
        $mybuiltins{'tag_level'} =         # replacement for deprecated %3
          !defined($tag_level) ? '-' : 0+sprintf("%.3f",$tag_level);
        $mybuiltins{'tag2_level'} = $mybuiltins{'REQD'} =  # replacement for %4
          !defined($tag2_level) ? '-' : 0+sprintf("%.3f",$tag2_level);
        $mybuiltins{'kill_level'} =        # replacement for deprecated %5
          !defined($kill_level) ? '-' : 0+sprintf("%.3f",$kill_level);
        @mybuiltins{('0','1','2','k')} = ($is_local,$do_tag,$do_tag2,$do_kill);
        # macros %3, %4, %5 are deprecated, replaced by tag/tag2/kill_level
        @mybuiltins{('3','4','5')} = ($tag_level,$tag2_level,$kill_level);
        my($strr) = expand(cr('log_recip_templ'), \%mybuiltins);
        for my $logline (split(/[ \t]*\n/, $$strr)) {
          do_log(0, "%s", $logline)  if $logline ne '';
        }
      }
    }
    section_time($which_section);

    if (defined $os_fingerprint) { # collect statistics on contents type vs. OS
      my($spam_ham_level) = 2.0;   # reasonable guesstimate
      my($os_short);  # extract just the operating system name if possible
      $os_short = $1  if $os_fingerprint =~ /^([^,([]*)/;
      $os_short = $1  if $os_short =~ /^[ \t,-]*(.*?)[ \t,-]*\z/;
      if ($os_short ne '') {
        $os_short = $1  if $os_short =~ /^(Windows [^ ]+|[^ ]+)/;  # drop vers.
        $os_short =~ s{[^0-9A-Za-z:./_+-]}{-}g; $os_short =~ s{\.}{,}g;
        my($snmp_counter_name) = $msginfo->setting_by_contents_category(
                       { CC_VIRUS,'virus', CC_SPAM,'spam', CC_CLEAN,'clean' });
        if ($snmp_counter_name eq 'clean')
          { $snmp_counter_name = $spam_level<=$spam_ham_level ? 'ham' : undef }
        if (defined $snmp_counter_name) {
          snmp_count("$snmp_counter_name.byOS.$os_short");
          do_log(3, 'Ham from Windows XP? Most weird! %s [%s] score=%.3f',
                    $mail_id, $cl_ip, $spam_level)
            if $snmp_counter_name eq 'ham' && $os_fingerprint =~ /^Windows XP/;
        }
      }
    }
    if ($sql_storage) {  # save final information to SQL (if enabled)
      $which_section = 'sql-update';
      my($ds) = $msginfo->dsn_sent;
      $ds = !$ds ? 'N' : $ds==1 ? 'Y' : $ds==2 ? 'q' : '?';
      for (my($attempt)=5; $attempt>0; ) {  # sanity limit on retries
        $sql_storage->save_info_final($conn,$msginfo,$ds)
          and last;
        if (--$attempt <= 0) {
          do_log(-2,"ERROR sql_storage: too many retries ".
                    "on storing final, info not saved");
        } else {
          do_log(2,"sql_storage: retrying on final, %d attempts remain",
                   $attempt);
          sleep(int(1+rand(3)));  # can't mix Time::HiRes::sleep with alarm
        }
      };
      section_time($which_section);
    }
    if (defined $snmp_db) {
      $which_section = 'update_snmp';
      snmp_count( ['entropy',0,'STR'] );
      $snmp_db->update_snmp_variables;
      section_time($which_section);
    }
    $which_section = 'finishing';
  };  # end eval
  if ($@ ne '') {
    chomp($@);
    $preserve_evidence = 1;
    my($msg) = "$which_section FAILED: $@";
    if ($point_of_no_return) {
      do_log(-2, "TROUBLE in check_mail, but must continue (%s): %s",
                 $point_of_no_return,$msg);
    } else {
      do_log(-2, "TROUBLE in check_mail: %s", $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})
        { $r->recip_smtp_response($smtp_resp); $r->recip_done(1) }
    }
  }
# if ($hold ne '') {
#   do_log(-1, "NOTICE: Evidence is to be preserved: %s", $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);
  $snmp_db->register_proc('.')  if defined $snmp_db;  # content checking done
  undef $MSGINFO; undef $CONN;  # release global references
  ($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
    my($ent,$mime_err) = mime_decode($fh, $tempdir, $parts_root);
    $msginfo->mime_entity($ent);
    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,
     $mail_defanged) = @_;
  $hdr_edits->add_header('X-Quarantine-ID', '<'.$msginfo->mail_id.'>')
    if defined($msginfo->quarantined_to);
  # discard existing X-Amavis-Hold header field, only allow our own
  $hdr_edits->delete_header('X-Amavis-Hold');
  if ($hold ne '') {
    $hdr_edits->add_header('X-Amavis-Hold', $hold);
    do_log(-1, "Inserting header field: X-Amavis-Hold: %s", $hold);
  }
  # example on how to remove subject tag inserted by some other MTA:
  # $hdr_edits->edit_header('Subject',
  #           sub { my($h,$s)=@_; $s=~s/^\s*\*\*\* SPAM \*\*\*(.*)/$1/s; $s });
  if ($mail_defanged ne '') {
    my($msg) = "$mail_defanged by " . c('myhostname');
    $hdr_edits->add_header('X-Amavis-Modified', $msg);
    do_log(1, "Inserting header field: X-Amavis-Modified: %s", $msg);
  }
  if ($extra_code_antivirus) {
    $hdr_edits->delete_header('X-Amavis-Alert');
    $hdr_edits->delete_header(c('X_HEADER_TAG'))
      if c('remove_existing_x_scanned_headers') &&
         (c('X_HEADER_LINE') ne '' && c('X_HEADER_TAG') =~ /^[!-9;-\176]+\z/);
  }
  if ($extra_code_antispam) {
    if (c('remove_existing_spam_headers')) {
      my(@which_headers) = qw(
          X-Spam-Status X-Spam-Level X-Spam-Flag X-Spam-Score
          X-Spam-Report X-Spam-Checker-Version X-Spam-Tests);
      push(@which_headers, qw(
          X-DSPAM-Result X-DSPAM-Confidence X-DSPAM-Probability
          X-DSPAM-Signature X-DSPAM-User X-DSPAM-Factors))  if defined $dspam;
      for my $h (@which_headers) { $hdr_edits->delete_header($h) }
    }
  # $hdr_edits->add_header('X-Spam-Checker-Version',
  # sprintf("SpamAssassin %s (%s) on %s", Mail::SpamAssassin::Version(),
  #         $Mail::SpamAssassin::SUB_VERSION, c('myhostname')));
  }
  if ($mail_defanged ne '') {
    # prepend Resent-* header fields, they must precede corresponding Received
    my($hdrfrom_recip) = $msginfo->setting_by_contents_category(
                                         cr('hdrfrom_notify_recip_by_ccat'));
    $hdr_edits->append_header_above_received('Resent-From',
                                         expand_variables($hdrfrom_recip));
    $hdr_edits->append_header_above_received('Resent-Date',
                                         rfc2822_timestamp($msginfo->rx_time));
    $hdr_edits->append_header_above_received('Resent-Message-ID',
                    sprintf('<RE%s@%s>', $msginfo->mail_id, c('myhostname')) );
  }
  # misnomer, this _is_ the Received line
  $hdr_edits->append_header_above_received('Received',
    received_line($conn,$msginfo,$msginfo->mail_id,1), 1)
    if c('insert_received_line') && $msginfo->delivery_method ne '';
  $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 SMTP transaction).
#
sub add_forwarding_header_edits_per_recip($$$$$$$$$) {
  my($conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
     $virus_presence_checked, $spam_presence_checked,
     $mail_defanged, $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);
  my($spam_level) = $msginfo->spam_level;
  for my $r (@per_recip_data) {
    my($recip) = $r->recip_addr;
    my($is_local,$blacklisted,$whitelisted,$boost,$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,$subject_tag,$subject_tag2);
    $is_local = lookup(0,$recip, @{ca('local_domains_maps')});
    $do_tag_badh  = $r->is_in_contents_category(CC_BADH);
    $do_tag_banned= $r->is_in_contents_category(CC_BANNED);
    $do_tag_virus = $r->is_in_contents_category(CC_VIRUS);
    $do_tag_virus_checked = defined($r->infected) &&
      (c('X_HEADER_LINE') ne '' && c('X_HEADER_TAG') =~ /^[!-9;-\176]+\z/);
    if ($extra_code_antispam) {
      my($bypassed);
      $blacklisted = $r->recip_blacklisted_sender;
      $whitelisted = $r->recip_whitelisted_sender;
      $boost       = $r->recip_score_boost;
      $bypassed    = lookup(0,$recip, @{ca('bypass_spam_checks_maps')});
      $tag_level   = lookup(0,$recip, @{ca('spam_tag_level_maps')});
      $tag2_level  = lookup(0,$recip, @{ca('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;
      #  - everyone when the spam level (+ boost if applicable) is below the
      #    tag level or the sender was whitelisted and tag level is below -10
      #    (undefined tag level is treated as lower than any spam score).
      $do_tag = $is_local && !$bypassed &&
        ( $blacklisted || !defined $tag_level ||
          ($spam_level+$boost + ($whitelisted?-10:0) >= $tag_level) );
      $do_tag2 = $is_local && !$bypassed && !$whitelisted &&
        ( $blacklisted ||
          (defined $tag2_level && $spam_level+$boost >= $tag2_level) );
      $subject_tag2 = !$do_tag2 ? undef
                           : lookup(0,$recip, @{ca('spam_subject_tag2_maps')});
      $subject_tag  = !($do_tag||$do_tag2) ? undef
                           : lookup(0,$recip, @{ca('spam_subject_tag_maps')});
      $do_subj = ($subject_tag2 ne '' || $subject_tag ne '') &&
                 lookup(0,$recip, @{ca('spam_modifies_subj_maps')});
    }
    if ($hold ne '' || $any_undecipherable) { # adding *UNCHECKED* subject tag?
       $do_subj_u = $is_local && !$r->infected &&
                    c('undecipherable_subject_tag') ne '';
    }
    # normalize
    for ($do_tag_virus_checked, $do_tag_virus, $do_tag_banned, $do_tag_badh,
         $do_tag, $do_tag2, $do_subj, $do_subj_u, $is_local) { $_ = $_?1:0 }
    my($spam_level_bar, $full_spam_status);
    if ($do_tag || $do_tag2) {
      my($slc) = c('sa_spam_level_char');
      $spam_level_bar = $slc x min(64, $whitelisted ? 0 : $blacklisted ? 64
                                       : 0+$spam_level+$boost)  if $slc ne '';
      my($s) = $msginfo->spam_status;
      $s =~ s/,/,\n /g;  # allow header field wrapping
      my($sl) = !defined($spam_level) ? 'x'
                  : 0+sprintf("%.3f",$spam_level);  # trim fraction
      $full_spam_status = sprintf("%s,\n score=%s\n %s%s%stests=[%s]",
        $do_tag2 ? 'Yes' : 'No',
        (!defined($boost) || $boost==0 ? $sl
         : $boost >= 0 ? $sl.'+'.$boost : $sl.$boost),
        !defined $tag_level   ? '' : sprintf("tagged_above=%s\n ",$tag_level),
        !defined $tag2_level  ? '' : sprintf("required=%s\n ",  $tag2_level),
        join('', $blacklisted ? "BLACKLISTED\n " : (),
                 $whitelisted ? "WHITELISTED\n " : ()),
        $s);
    }
    my($subject_insert);  # concatenation of triggered subject tag strings
    if ($do_subj || $do_subj_u) {
      if ($do_subj_u) {
        $subject_insert = c('undecipherable_subject_tag');
        do_log(3,"adding %s, %s, %s",
                 $subject_insert, $any_undecipherable, $hold);
      }
      if ($do_subj) {
        $subject_insert .= $do_tag2 && $subject_tag2 ne '' ? $subject_tag2
                                                           : $subject_tag;
      }
    }
    my($key) = join("\000", map {defined $_ ? $_ : ''} (
      $do_tag_virus_checked, $do_tag_virus, $do_tag_banned, $do_tag_badh,
      $do_tag, $do_tag2, $do_subj, $do_subj_u, $subject_insert,
      $spam_level_bar, $full_spam_status) );
    if ($first) {
      if (ll(4)) {
        my($sl) = !defined($spam_level) ? 'x'
                    : 0+sprintf("%.3f",$spam_level);  # trim fraction
        do_log(4, "headers CLUSTERING: NEW CLUSTER <%s>: score=%s, ".
          "tag=%s, tag2=%s, subj=%s, subj_u=%s, local=%s, bl=%s, s=%s",
          $recip,
          (!defined $boost || $boost==0 ? $sl
           : $boost >= 0 ? $sl.'+'.$boost : $sl.$boost),
          $do_tag, $do_tag2, $do_subj, $do_subj_u, $is_local, $blacklisted,
          $subject_insert);
      }
      $cluster_key = $key; $cluster_full_spam_status = $full_spam_status;
    } elsif ($key eq $cluster_key) {
      do_log(5,"headers CLUSTERING: <%s> joining cluster", $recip);
    } else {
      do_log(5,"headers CLUSTERING: skipping <%s> (tag=%s, tag2=%s)",
               $recip,$do_tag,$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->add_header(c('X_HEADER_TAG'), c('X_HEADER_LINE'));
      }
      if ($do_tag_virus) {
        $hdr_edits->add_header('X-Amavis-Alert',
          "INFECTED, message contains virus: " . join(", ",@virusname));
      }
      if ($do_tag_banned) {
        my(@b);  @b = @{$r->banned_parts}  if defined $r->banned_parts;
        my($b_chopped) = @b > 2;  @b = (@b[0,1],'...')  if $b_chopped;
        my($msg) = "BANNED, message contains " . (@b==1 ? 'part' : 'parts') .
                   ": " . join(", ", @b) . ($b_chopped ? ", ..." : "");
        $msg =~ s/[ \t]{6,}/ ... /g;
        $hdr_edits->add_header('X-Amavis-Alert', $msg);
      }
      if ($do_tag_badh) {
        $hdr_edits->add_header('X-Amavis-Alert','BAD HEADER '.$bad_headers[0]);
      }
      if ($do_tag2) {
        $hdr_edits->add_header('X-Spam-Flag', 'YES');
      }
      if ($do_tag) {
        $hdr_edits->add_header('X-Spam-Score',
          !defined $spam_level ? '-' : 0+sprintf("%.3f",0+$spam_level+$boost));
        $hdr_edits->add_header('X-Spam-Level', $spam_level_bar)
          if defined $spam_level_bar;
        $hdr_edits->add_header('X-Spam-Status', $full_spam_status, 1);
      }
      if ($do_tag2) {
        $hdr_edits->add_header('X-Spam-Report', "\n".$msginfo->spam_report, 2)
          if c('sa_spam_report_header') && $msginfo->spam_report ne '';
      }
      if ($do_subj || $do_subj_u) {
        if (defined $msginfo->orig_header_fields->{'subject'}) {
          $hdr_edits->edit_header('Subject',
                    sub { $_[1]=~/^([ \t]?)(.*)\z/s; ' '.$subject_insert.$2 });
        } else {  # no Subject header field present, insert one
          $subject_insert =~ s/[ \t]+\z//;  # trim
          $hdr_edits->append_header('Subject', $subject_insert);
          do_log(0,"INFO: no existing header field 'Subject', inserting it");
        }
      }
    }
    push(@recip_cluster,$r);  $first = 0;

    my($delim) = c('recipient_delimiter');
    if ($delim ne '' && $is_local) {
      # append address extensions to mailbox names if desired
      my($ext_map) = $r->setting_by_contents_category(
                                            cr('addr_extension_maps_by_ccat'));
      my($ext) = !ref($ext_map) ? undef : lookup(0,$recip, @$ext_map);
      if ($ext ne '') {
        my($orig_extension);  my($localpart,$domain) = split_address($recip);
        ($localpart,$orig_extension) = split_localpart($localpart,$delim)
          if c('replace_existing_extension');  # strip existing extension
        my($new_addr) = $localpart.$delim.$ext.$domain;
        if (ll(5)) {
          if (!defined($orig_extension)) {
            do_log(5, "appending addr ext '%s', giving '%s'", $ext,$new_addr);
          } else {
            do_log(5, "replacing addr ext '%s' by '%s', giving '%s'",
                       $orig_extension,$ext,$new_addr);
          }
        }
        # rfc3461: If no ORCPT parameter was present in the RCPT command when
        # the message was received, an ORCPT parameter MAY be added to the
        # RCPT command when the message is relayed. If an ORCPT parameter is
        # added by the relaying MTA, it MUST contain the recipient address
        # from the RCPT command used when the message was received by that MTA.
        $r->dsn_orcpt('rfc822;'.xtext_encode(quote_rfc2821_local($recip)))
          if !defined($r->dsn_orcpt);
        $r->recip_addr_modified($new_addr);
      }
    }
  }
  my($done_all);
  if (@recip_cluster == $per_recip_data_len) {
    do_log(5,"headers CLUSTERING: done all %d recips in one go",
             $per_recip_data_len);
    $done_all = 1;
  } else {
    ll(4) && do_log(4, "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;
    ll(2) && do_log(2, "SPAM-TAG, %s -> %s, %s",
                       qquote_rfc2821_local($msginfo->sender),
                       join(',', qquote_rfc2821_local(
                                  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 {
    my($sender) = $msginfo->sender;
    my($quar_msg) = Amavis::In::Message->new;
    $quar_msg->rx_time($msginfo->rx_time);      # copy the reception time
    $quar_msg->body_type($msginfo->body_type);  # use the same BODY= type
    $quar_msg->mail_id($msginfo->mail_id);      # use the same the mail_id
    $quar_msg->body_digest($msginfo->body_digest);  # copy original digest
    $quar_msg->delivery_method($quarantine_method);
    if ($quarantine_method =~ /^(bsmtp|sql):/i) {
      $quar_msg->sender($sender);      # original sender & recipients
      $quar_msg->recips($msginfo->recips);
    } else {
      my($mftq) = c('mailfrom_to_quarantine');
      $quar_msg->sender(defined $mftq ? $mftq : $sender);
      $quar_msg->recips($recips_ref);  # e.g. per-recip quarantine
    }
    $hdr_edits = Amavis::Out::EditHeader->new  if !defined($hdr_edits);
    $hdr_edits->prepend_header('X-Quarantine-ID', '<'.$msginfo->mail_id.'>');
    if ($quarantine_method =~ /^bsmtp:/i) {  # X-Envelope-* would be redundant
    } else {
      # NOTE: RFC2821 mentions possible headers X-SMTP-MAIL and X-SMTP-RCPT
      # Exim uses: Envelope-To,  Sendmail uses X-Envelope-To;
      # No need with bsmtp or sql, which carry addresses in the envelope
      $hdr_edits->prepend_header('X-Envelope-To',
        join(",\n ", qquote_rfc2821_local(@{$msginfo->recips})), 1);
      $hdr_edits->prepend_header('X-Envelope-From',
        qquote_rfc2821_local($sender));
    }
    $hdr_edits->append_header_above_received('Received',
                  received_line($conn,$msginfo,$msginfo->mail_id,1), 1);
    do_log(5, "DO_QUARANTINE, sender: <%s>", $quar_msg->sender);
    $quar_msg->auth_submitter(quote_rfc2821_local($quar_msg->sender));
    $quar_msg->auth_user(c('amavis_auth_user'));
    $quar_msg->auth_pass(c('amavis_auth_pass'));
    $quar_msg->header_edits($hdr_edits);
    $quar_msg->mail_text($msginfo->mail_text);  # use the same mail contents

    snmp_count('QuarMsgs');
    mail_dispatch($conn, $quar_msg, 1, 0);
    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($quar_type);
    my(@qa); my(%seen);  # collect unique quarantine mailboxes or addresses
    my($existing_qa) = $msginfo->quarantined_to;
    if (ref $existing_qa) { @qa = @$existing_qa; $seen{$_}++ for (@qa) }
    for my $r (@{$quar_msg->per_recip_data}) {
      my($mbxname) = $r->recip_mbxname;
      if ($mbxname ne '' && !$seen{$mbxname}++) {
        push(@qa,$mbxname);
        $quar_type = /^bsmtp:/ ? 'B' : /^smtp:/ ? 'M' : /^sql:/ ? 'Q' :
            /^local:/ ? ($mbxname=~/\@/ ? 'M' : $mbxname=~/\.gz\z/ ? 'Z' : 'F')
            : '?'  for (lc($quarantine_method));
      }
    }
    $msginfo->quar_type($quar_type);
    $msginfo->quarantined_to(!@qa ? undef : \@qa);  # remember quar. location
    do_log(5, "DO_QUARANTINE done");
  }
}

# Quarantine according to contents and send admin & recip notif. as needed
# (this subroutine replaces the former subroutines do_virus and do_spam)
#
sub do_notify_and_quarantine($$$) {
  my($conn, $msginfo, $virus_dejavu) = @_;
  my($q_method, $quarantine_to_maps_ref, $admin_maps_ref,
     $mailfrom_admin, $hdrfrom_admin, $mailfrom_recip, $hdrfrom_recip,
     $notify_admin_templ_ref, $notify_recip_templ_ref, $warnrecip_maps_ref) =
    map { $msginfo->setting_by_contents_category(cr($_)) }
        qw(quarantine_method_by_ccat
           quarantine_to_maps_by_ccat admin_maps_by_ccat
           mailfrom_notify_admin_by_ccat hdrfrom_notify_admin_by_ccat
           mailfrom_notify_recip_by_ccat hdrfrom_notify_recip_by_ccat
           notify_admin_templ_by_ccat notify_recips_templ_by_ccat
           warnrecip_maps_by_ccat);
  my($ccat_name) =
    $msginfo->setting_by_contents_category(\%ccat_display_names);
  my($ccat,$ccat_min) = $msginfo->main_contents_category;
  do_log(3,"do_notify_and_quarantine: ccat=%s, (%d,%d)",
           $ccat_name,$ccat,$ccat_min);
  my($newvirus_admin_maps_ref) =
     @virusname && !$virus_dejavu ? ca('newvirus_admin_maps') : undef;
  my($blacklisted_any,$whitelisted_any,$do_tag2_any);
  my($tag_level_min,$tag2_level_min,$kill_level_min,$boost_max);
  my($spam_level) = $msginfo->spam_level;
  my(@q_addr,@a_addr);  # get per-recipient quarantine address(es) and admins
  for my $r (@{$msginfo->per_recip_data}) {
    my($rec) = $r->recip_addr;
    my($rec_ccat,$rec_ccat_min) = $r->main_contents_category;
    my($bypassed,$tag_level,$tag2_level,$kill_level,$do_tag2);
    my($blacklisted) = $r->recip_blacklisted_sender;
    my($whitelisted) = $r->recip_whitelisted_sender;
    my($boost)       = $r->recip_score_boost;
    my($spam_level_boosted) = (!defined($spam_level) ? 0 : $spam_level) +
                              (!defined($boost)      ? 0 : $boost);
    do_log(2,"do_notify_and_quarantine: rec_ccat=(%d,%d), ccat=(%d,%s), %s",
           $rec_ccat, $rec_ccat_min, $ccat, $ccat_min, $rec)
           if $rec_ccat != $ccat || $rec_ccat_min != $ccat_min;
    if ($rec_ccat == CC_SPAM) {
      # do the more expensive lookups only when needed
      $bypassed   = lookup(0,$rec, @{ca('bypass_spam_checks_maps')});
      $tag_level  = lookup(0,$rec, @{ca('spam_tag_level_maps')});
      $tag2_level = lookup(0,$rec, @{ca('spam_tag2_level_maps')});
      $kill_level = lookup(0,$rec, @{ca('spam_kill_level_maps')});
    }
#   $do_tag = !$bypassed &&
#     ( $blacklisted || !defined $tag_level ||
#       ($spam_level_boosted + ($whitelisted?-10:0) >= $tag_level) );
    $do_tag2 = !$bypassed && !$whitelisted &&
      ( $blacklisted ||
        (defined $tag2_level && $spam_level_boosted >= $tag2_level) );
#   $do_kill = !$bypassed && !$whitelisted &&
#     ( $blacklisted ||
#       (defined $kill_level && $spam_level_boosted >= $kill_level) );
    # summarize
    $blacklisted_any++  if $blacklisted;
    $whitelisted_any++  if $whitelisted;
    $tag_level_min = $tag_level  if defined($tag_level) &&
                  (!defined($tag_level_min) || $tag_level < $tag_level_min);
    $tag2_level_min = $tag2_level  if defined($tag2_level) &&
                  (!defined($tag2_level_min) || $tag2_level < $tag2_level_min);
    $kill_level_min = $kill_level  if defined($kill_level) &&
                  (!defined($kill_level_min) || $kill_level < $kill_level_min);
    $boost_max = $boost  if defined($boost) &&
                  (!defined($boost_max) || $boost > $boost_max);
#   $do_tag_any  = 1  if $do_tag;
    $do_tag2_any = 1  if $do_tag2;
#   $do_kill_any = 1  if $do_kill;
    # get per-recipient quarantine address(es) and admins
    my($q);  # quarantine (pseudo) address associated with the recipient
    my($a);  # administrator's e-mail address
    ($q) = lookup(0,$rec,@$quarantine_to_maps_ref)  if $quarantine_to_maps_ref;
    if ($rec_ccat == CC_SPAM && $q ne '') {
      # consider suppressing spam quarantine
      # ???how should we treat blacklisted???
      my($cutoff) = lookup(0,$rec,@{ca('spam_quarantine_cutoff_level_maps')});
      if (!defined $cutoff || $cutoff eq '') {}
      elsif ($spam_level_boosted >= $cutoff) {
        do_log(2,"do_notify_and_quarantine: spam level exceeds ".
                 "quarantine cutoff level %s", $cutoff);
        $q = '';  # disable quarantine on behalf of this recipient
      }
    }
    $q = $rec  if $q ne '' && $q_method =~ /^bsmtp:/i;  # orig.recip when BSMTP
    ($a) = lookup(0,$rec,@$admin_maps_ref)  if $admin_maps_ref;
    push(@q_addr, $q)  if defined $q && $q ne '' && !grep {$_ eq $q} @q_addr;
    push(@a_addr, $a)  if defined $a && $a ne '' && !grep {$_ eq $a} @a_addr;
    if ($rec_ccat == CC_VIRUS && $newvirus_admin_maps_ref) {
      ($a) = lookup(0,$rec,@$newvirus_admin_maps_ref);
      push(@a_addr, $a)  if defined $a && $a ne '' && !grep {$_ eq $a} @a_addr;
    }
  }
  if ($ccat == CC_SPAM) {
    my($sqbsm) = ca('spam_quarantine_bysender_to_maps');
    if (@$sqbsm) {  # by-sender spam quarantine (hardly useful, rarely used)
      my($q);  $q = lookup(0,$msginfo->sender, @$sqbsm);
      push(@q_addr, $q)  if defined $q && $q ne '' && !grep {$_ eq $q} @q_addr;
    }
  }

  my($spam_level_bar); my($slc) = c('sa_spam_level_char');
  $spam_level_bar = $slc x min(64, $whitelisted_any ? 0 : $blacklisted_any ? 64
                                   : 0+$spam_level+$boost_max)  if $slc ne '';
  my($s) = $msginfo->spam_status;
  $s =~ s/,/,\n /g;  # allow header field wrapping
  my($sl) = !defined($spam_level) ? 'x' : 0+sprintf("%.3f",$spam_level); # trim
  my($full_spam_status) = sprintf(
    "%s,\n score=%s\n tag=%s\n tag2=%s\n kill=%s\n %stests=[%s]",
    $do_tag2_any ? 'Yes' : 'No',
    (!defined($boost_max) || $boost_max==0 ? $sl
     : $boost_max >= 0 ? $sl.'+'.$boost_max : $sl.$boost_max),
    (map { !defined $_ ? 'x' : 0+sprintf("%.3f",$_) }
      ($tag_level_min, $tag2_level_min, $kill_level_min)),
    join('', $blacklisted_any ? "BLACKLISTED\n " : (),
             $whitelisted_any ? "WHITELISTED\n " : ()),
    $s);
  if (defined($q_method) && @q_addr) {  # do the quarantining
    # prepare header edits for the quarantined message
    my($hdr_edits) = Amavis::Out::EditHeader->new;
    if ($msginfo->is_in_contents_category(CC_VIRUS)) {
      $hdr_edits->add_header('X-Amavis-Alert',
        "INFECTED, message contains virus: " . join(", ", @virusname));
    }
    if ($msginfo->is_in_contents_category(CC_BANNED)) {
      for my $r (@{$msginfo->per_recip_data}) {
        my(@b);  @b = @{$r->banned_parts}  if defined $r->banned_parts;
        if (@b) {
          my($b_chopped) = @b > 3;  @b = @b[0..2]  if $b_chopped;
          my($msg) = "BANNED, message contains " . (@b==1 ? 'part' : 'parts') .
                     ": " . join(", ", @b) . ($b_chopped ? ", ..." : "");
          $msg =~ s/[ \t]{6,}/ ... /g;
          $hdr_edits->add_header('X-Amavis-Alert', $msg);
          last;   # fudge: only the first recipient's banned hit will be shown
        }
      }
    }
    if ($msginfo->is_in_contents_category(CC_BADH)) {
      $hdr_edits->add_header('X-Amavis-Alert', 'BAD HEADER '.$bad_headers[0]);
    }
    if ($msginfo->is_in_contents_category(CC_SPAM)) {
      $hdr_edits->add_header('X-Spam-Flag', $do_tag2_any ? 'YES' : 'NO');
      $hdr_edits->add_header('X-Spam-Score',
                             0+sprintf("%.3f",0+$spam_level+$boost_max) );
      my($slc) = c('sa_spam_level_char');
      $hdr_edits->add_header('X-Spam-Level', $spam_level_bar)
        if defined $spam_level_bar;
      $hdr_edits->add_header('X-Spam-Status', $full_spam_status, 1);
      $hdr_edits->add_header('X-Spam-Report', "\n".$msginfo->spam_report, 2)
        if c('sa_spam_report_header') && $msginfo->spam_report ne '';
    }
    do_quarantine($conn,$msginfo,$hdr_edits,\@q_addr,$q_method,
                  'Quar'.$ccat_name.'Msgs');
  }
  if ($ccat == CC_SPAM) {  # log entry for compatibility with older log parsers
    my($autolearn_status) = $msginfo->autolearn_status;
    $s = $full_spam_status; $s =~ s/\n[ \t]/ /g;
    ll(2) && do_log(2,"SPAM, %s -> %s, %s%s%s",
               qquote_rfc2821_local($msginfo->sender_source),
               join(',', qquote_rfc2821_local(@{$msginfo->recips})),  $s,
               $autolearn_status eq '' ? '' : ", autolearn=$autolearn_status",
               !@q_addr ? '' : sprintf(", quarantine %s (%s)",
                                  $msginfo->mail_id, join(',',@q_addr)) );
  }
  if (!@a_addr) {
    do_log(4, "Skip admin notification, no administrators");
  } else {   # notify per-recipient administrators
    ll(5) && do_log(5, "Admin notifications to %s; sender: %s",
                    join(',',qquote_rfc2821_local(@a_addr)), $msginfo->sender);
    my($notification) = Amavis::In::Message->new;
    $notification->rx_time($msginfo->rx_time);  # copy the reception time
    $notification->delivery_method(c('notify_method'));
    $notification->sender($mailfrom_admin);
    $notification->auth_submitter(quote_rfc2821_local($mailfrom_admin));
    $notification->auth_user(c('amavis_auth_user'));
    $notification->auth_pass(c('amavis_auth_pass'));
    $notification->recips([@a_addr]);
#   if ($mailfrom_admin ne '')
#     { $_->dsn_notify(['NEVER'])  for @{$notification->per_recip_data} }
    my(%mybuiltins) = %builtins;  # make a local copy
    $mybuiltins{'T'} = \@a_addr;                         # used in To:
    $mybuiltins{'f'} = expand_variables($hdrfrom_admin); # From:
    $notification->mail_text(
      string_to_mime_entity(expand($notify_admin_templ_ref,\%mybuiltins),
                            $msginfo, undef,1,0) );
#   $notification->body_type('7BIT');
    my($hdr_edits) = Amavis::Out::EditHeader->new;
    $notification->header_edits($hdr_edits);
    mail_dispatch($conn, $notification, 1, 0);
    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 admin: $n_smtp_resp";
    } else {
      do_log(-1, "FAILED to notify admin: %s", $n_smtp_resp);
    }
    # $notification->purge;
  }
  # recipient notifications (don't bother for spam and clean)
  for my $r (@{$msginfo->per_recip_data}) {
    my($rec) = $r->recip_addr;
    my($wr) = lookup(0,$rec,@$warnrecip_maps_ref);
    if (!defined($wr) || !$wr) {
      # no recipient notification required
    } elsif (!c('warn_offsite') &&
             !lookup(0,$rec,@{ca('local_domains_maps')})) {
      $wr = 0;  # do not notify foreign recipients
#   } elsif (! defined($msginfo->sender_contact) ) {  # (not general enough)
#     do_log(5,"skip recipient notifications for unknown sender");
#     $wr = 0;
    }
    if ($wr) {  # warn recipient
      my($notification) = Amavis::In::Message->new;
      $notification->rx_time($msginfo->rx_time);  # copy the reception time
      $notification->delivery_method(c('notify_method'));
      $notification->sender($mailfrom_recip);
        $notification->auth_submitter(quote_rfc2821_local($mailfrom_recip));
      $notification->auth_user(c('amavis_auth_user'));
      $notification->auth_pass(c('amavis_auth_pass'));
      $notification->recips([$rec]);
#     if ($mailfrom_recip ne '')
#       { $_->dsn_notify(['NEVER'])  for @{$notification->per_recip_data} }
      my(@b);  @b = @{$r->banned_parts}  if defined $r->banned_parts;
      my($b_chopped) = @b > 2;  @b = (@b[0,1],'...')  if $b_chopped;
      s/[ \t]{6,}/ ... /g  for @b;
      my(%mybuiltins) = %builtins;  # make a local copy
      $mybuiltins{'F'} = \@b;  # list of banned file names
      $mybuiltins{'f'} = expand_variables($hdrfrom_recip); # From:
      $mybuiltins{'T'} = quote_rfc2821_local($rec);        # To:
      $notification->mail_text(
        string_to_mime_entity(expand($notify_recip_templ_ref,\%mybuiltins),
                              $msginfo, undef,0,0) );
#     $notification->body_type('7BIT');
      my($hdr_edits) = Amavis::Out::EditHeader->new;
      $notification->header_edits($hdr_edits);
      mail_dispatch($conn, $notification, 1, 0);
      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 recipient rec: $n_smtp_resp";
      } else {
        do_log(-1, "FAILED to notify recipient %s: %s", $rec,$n_smtp_resp);
      }
      # $notification->purge;
    }
  }
  do_log(5, "do_notify_and_quarantine - done");
}

# Calculate message digest;
# While at it, also get message size, check for 8-bit data, 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: $!";

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

  my($header_size)=0; my($body_size)=0; my($h_8bit,$b_8bit) = (0,0);
  my(@orig_header,%orig_header_fields); my($ln,$collecting);
  for ($! = 0; defined($ln=<$fh>); $! = 0) {  # read mail header
    last  if $ln eq $eol;
    $header_size += length($ln);
    $ln=~/^[\000-\177]*\z/ or $h_8bit=1;
    $hctx->add($ln); push(@orig_header,$ln);      # with trailing EOL
    if ($ln =~ /^[ \t]/) {  # header field continuation
      $orig_header_fields{$collecting} .= $ln  if defined $collecting;
    } elsif ($ln =~ /^(from|to|subject|precedence|received|x-mailer|
                       message-id|resent-message-id)[ \t]*:(.*)\z/xsi) {
      $collecting = lc($1);
      if (exists $orig_header_fields{$collecting}) { undef $collecting }
      else { $orig_header_fields{$collecting} = $2 }  # keep first occurrence
    } else { undef $collecting }
  }
  defined $ln || $!==0  or die "Error reading mail header: $!";
  add_entropy($hctx->digest);  # faster than traversing @orig_header again
  my($len);
  while (($len = read($fh,$_,16384)) > 0) {
    $bctx->add($_); $body_size += $len;
    /^[\000-\177]*\z/ or $b_8bit=1;  # much faster than !/[^\000-\177]/
  }
  defined $len or die "Error reading mail body: $!";
  my($signature) = $bctx->hexdigest;
# my($signature) = $bctx->b64digest;
  add_entropy($signature);
  $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_fields(\%orig_header_fields);
  $msginfo->orig_header(\@orig_header);
  $msginfo->orig_header_size($header_size);
  $msginfo->orig_body_size($body_size);
  $msginfo->body_digest($signature);

  # check for 8-bit characters and adjust body type if necessary (rfc1652)
  my($bt_orig) = $msginfo->body_type;
  my($bt_true) = $h_8bit || $b_8bit ? '8BITMIME' : '7BIT';
  if (!defined($bt_orig) || $bt_orig eq '') {
    do_log(4,"setting body type: %s (h=%s, b=%s)", $bt_true, $h_8bit, $b_8bit);
    $msginfo->body_type($bt_true);
  } elsif ($bt_true eq '8BITMIME' && uc($bt_orig) ne '8BITMIME') {
    do_log(4,"changing body type: %s => %s (h=%s, b=%s)",
             $bt_orig, $bt_true, $h_8bit, $b_8bit);
    $msginfo->body_type($bt_true);
  }
  do_log(3, "body hash: %s", $signature);
  section_time('body_digest');
  $signature;
}

sub find_program_path($$$) {
  my($fv_list, $path_list_ref, $may_log) = @_;
  $fv_list = [$fv_list]  if !ref $fv_list;
  my($found);
  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(-1, "find_program_path: %s inaccessible: %s", $fv_cmd[0], $!)
          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(-1, "find_program_path: %s/%s inaccessible: %s",
                     $p, $fv_cmd[0], $!)
            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 $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,"No %-19s not using it", "$f,") }
    else {
      do_log(0,"Found %-16s at %s%s", $f,
             $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '',
             $found);
    }
  }
  # map program name path hints to full paths for decoders
  my(%any_st);
  for my $f (@{ca('decoders')}) {
    next  if !defined $f || !ref $f;  # empty, skip
    my($short_type) = $f->[0];  my(@tried,@found);  my($any) = 0;
    for my $d (@$f[2..$#$f]) {  # all but the first two elements are programs
      # allow one level of indirection
      my($dd) = (ref $d eq 'SCALAR' || ref $d eq 'REF') ? $$d : $d;
      my($found) = find_program_path($dd, $path_list_ref, 1);
      if (defined $found) { $any++; $dd = $found; $d = $dd; push(@found,$dd) }
      else { push(@tried, !ref($dd) ? $dd : join(", ",@$dd))  if $dd ne '' }
    }
    my($is_a_backup) = $any_st{$short_type};
    my($ll,$tier) = !$is_a_backup ? (0,'') : (2,' (backup, not used)');
    if (@$f <= 2) {    # no external programs specified
      do_log($ll, "Internal decoder for .%-4s%s", $short_type,$tier);
      $f = undef  if $is_a_backup;  # discard a backup entry
    } elsif (!$any) {  # external programs specified but none found
      do_log($ll, "No decoder for       .%-4s%s",  $short_type,
              !@tried ? '' : ' tried: '.join("; ",@tried))  if !$is_a_backup;
      $f = undef;  # release its storage
    } else {
      do_log($ll, "Found decoder for    .%-4s at %s%s%s", $short_type,
          $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '',
          join("; ",@found), $tier);
      $f = undef  if $is_a_backup;  # discard a backup entry
    }
    $any_st{$short_type}++  if defined $f;
  }
  # map program name hints to full paths - av scanners
  my($tier) = 'primary';  # primary, secondary, ...   av scanners
  for my $f (@{ca('av_scanners')}, "\000", @{ca('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 (%s) %s", $tier,$f->[0]);
    } else {
      my($found) = $f->[1] = find_program_path($f->[1], $path_list_ref, 1);
      if (!defined $found) {
        do_log(3, "No %s av scanner: %s", $tier, $f->[0]);
        $f = undef;                     # release its storage
      } else {
        do_log(0, "Found $tier av scanner %-11s at %s%s", $f->[0],
              $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '',
              $found);
      }
    }
  }
}

# Fetch remaining modules, all must be loaded before chroot and fork occurs
sub fetch_modules_extra() {
  my(@modules);
  if ($extra_code_sql_base) {
    push(@modules, 'DBI');
    for (@lookup_sql_dsn, @storage_sql_dsn) {
      my(@dsn) = split(/:/,$_->[0],-1);
      push(@modules, 'DBD::'.$dsn[1])  if uc($dsn[0]) eq 'DBI';
    }
  }
  push(@modules, qw(Net::LDAP Net::LDAP::Util Net::LDAP::Search
                    Net::LDAP::Bind))  if $extra_code_ldap;
  if (c('bypass_decode_parts') &&
      !grep {exists $policy_bank{$_}{'bypass_decode_parts'} &&
             !$policy_bank{$_}{'bypass_decode_parts'} } keys %policy_bank) {
  } else {
    push(@modules, qw(Convert::TNEF Convert::UUlib Archive::Zip Archive::Tar));
  }
  push(@modules, 'Authen::SASL')  if c('auth_required_out');
  Amavis::Boot::fetch_modules('REQUIRED ADDITIONAL MODULES', 1, @modules);
  @modules = ();  # now start collecting optional modules
  if ($unicode_aware) {
    push(@modules, qw(
      bytes bytes_heavy.pl utf8 utf8_heavy.pl
      Encode Encode::Byte Encode::MIME::Header Encode::Unicode::UTF7
      Encode::CN Encode::TW Encode::KR Encode::JP
      unicore::Canonical.pl unicore::Exact.pl unicore::PVA.pl
      unicore::To::Fold.pl unicore::To::Title.pl
      unicore::To::Lower.pl unicore::To::Upper.pl
    ));
  }
  my($missing);
  $missing = Amavis::Boot::fetch_modules('PRE-COMPILE OPTIONAL MODULES', 0,
                                         @modules)  if @modules;
  do_log(2, 'INFO: no optional modules: %s', join(' ',@$missing))
    if ref $missing && @$missing;
  # require minimal version 0.32, Net::LDAP::Util::escape_filter_value() needed
  Net::LDAP->VERSION(0.32)  if $extra_code_ldap;
  DBI->VERSION(1.43)  if $extra_code_sql_base;  # need working last_insert_id
  MIME::Entity->VERSION ne '5.419'
    or die "MIME::Entity 5.419 breaks quoted-printable encoding, ".
           "please upgrade to 5.420 or later (or use 5.418)";
  # load optional modules SAVI and Mail::ClamAV if available and requested
  if ($extra_code_antivirus) {
    my($clamav_module_ok);
    for my $entry (@{ca('av_scanners')}, @{ca('av_scanners_backup')}) {
      if (ref($entry) ne 'ARRAY') {  # none
      } elsif ($entry->[1] eq \&ask_sophos_savi ||
               $entry->[1] eq \&sophos_savi ||
               $entry->[0] eq 'Sophos SAVI') {
        if (defined(eval { require SAVI }) && SAVI->VERSION(0.30) &&
            Amavis::AV::sophos_savi_init(@$entry)) {}  # ok, loaded
        else { $entry->[1] = undef }  # disable entry
      } elsif ($entry->[1] eq \&ask_clamav ||
               $entry->[0] =~ /^Mail::ClamAV/) {
        if (!defined($clamav_module_ok)) {
          $clamav_module_ok = eval { require Mail::ClamAV };
          $clamav_module_ok = 0  if !defined $clamav_module_ok;
        }
        $entry->[1] = undef  if !$clamav_module_ok;  # disable entry
      }
    }
  }
}

#
# Main program starts here
#

# Read dynamic source code, and logging and notification message templates
# from the end of this file (pseudo file handle DATA)
#
$Amavis::Conf::notify_spam_admin_templ  = '';  # not used
$Amavis::Conf::notify_spam_recips_templ = '';  # not used
do { local($/) = "__DATA__\n";   # set line terminator to this string
  chomp($_ = <Amavis::DATA>)  for (
    $extra_code_db, $extra_code_cache,
    $extra_code_sql_lookup, $extra_code_ldap,
    $extra_code_in_amcl, $extra_code_in_smtp, $extra_code_in_courier,
    $extra_code_out_smtp, $extra_code_out_pipe,
    $extra_code_out_bsmtp, $extra_code_out_local, $extra_code_p0f,
    $extra_code_sql_base, $extra_code_sql_log, $extra_code_sql_quar,
    $extra_code_antivirus, $extra_code_antispam, $extra_code_antispam_sa,
    $extra_code_unpackers,
    $Amavis::Conf::log_templ, $Amavis::Conf::log_recip_templ);
  if ($unicode_aware) {
#   binmode(\*Amavis::DATA, ":encoding(utf8)")    #  :encoding(iso-8859-1)
#     or die "Can't set \*DATA encoding: $!";
  }
  chomp($_ = <Amavis::DATA>)  for (
    $Amavis::Conf::notify_sender_templ,
    $Amavis::Conf::notify_virus_sender_templ,
    $Amavis::Conf::notify_virus_admin_templ,
    $Amavis::Conf::notify_virus_recips_templ,
    $Amavis::Conf::notify_spam_sender_templ,
    $Amavis::Conf::notify_spam_admin_templ );
}; # restore line terminator
close(\*Amavis::DATA) or die "Error closing *Amavis::DATA: $!";
# close(STDIN)        or die "Error closing STDIN: $!";
# note: don't close STDIN just yet to prevent some other file taking up fd 0

# discard trailing NL
s/^(.*?)[\r\n]+\z/$1/s
  for ($Amavis::Conf::log_templ, $Amavis::Conf::log_recip_templ);

# Consider droping privileges early, before reading config file.
# This is only possible if running under chroot will not be needed.
#
my($desired_group);                      # defaults to $desired_user's group
my($desired_user);                       # username or UID
if ($> != 0) { $desired_user = $> }      # use effective UID if not root
#else {
# for my $u ('amavis', 'vscan') {        # try to guess a good default username
#   my($username,$passwd,$uid,$gid) = getpwnam($u);
#   if (defined $uid && $uid != 0) { $desired_user = $u; last }
# }
#}

# collect and parse command line options
while (@ARGV >= 2 && $ARGV[0] =~ /^-[ugc]\z/) {
  my($opt) = shift @ARGV;
  if ($opt eq '-u') {       # -u username
    my($val) = shift @ARGV;
    if ($> == 0) { $desired_user = $val }
    else { print STDERR "Ignoring option -u when not running as root\n" }
  } elsif ($opt eq '-g') {  # -g group
    my($val) = shift @ARGV;
    if ($> == 0) { $desired_group = $val }
    else { print STDERR "Ignoring option -g when not running as root\n" }
  } elsif ($opt eq '-c') {  # -c config_file
    push(@config_files, untaint(shift @ARGV));
  }
}

if (defined $desired_user && ($> == 0 || $< == 0)) {   # drop privileges early
  my($username,$passwd,$uid,$gid) =
    $desired_user=~/^(\d+)$/ ? (undef,undef,$1,undef) :getpwnam($desired_user);
  defined $uid or die "No such username: $desired_user\n";
  if ($desired_group eq '') { $desired_group = $gid }  # for logging purposes
  else { $gid = $desired_group=~/^(\d+)$/ ? $1 : getgrnam($desired_group) }
  defined $gid or die "No such group: $desired_group\n";
  $( = $gid;  # real GID
  $) = "$gid $gid";  # effective GID
  POSIX::setuid($uid) or die "Can't setuid to $uid: $!";
  $> = $uid; $< = $uid;  # just in case
# print STDERR "desired user=$desired_user ($uid), current: EUID: $> ($<)\n";
# print STDERR "desired group=$desired_group, current: EGID: $) ($()\n";
  $> != 0 or die "Still running as root, aborting\n";
  $< != 0 or die "Effective UID changed, but Real UID is 0\n";
}

umask(0027);
POSIX::setlocale(LC_TIME,"C");  # English dates required in syslog and rfc2822!

# do some remaining initialization
init_builtin_macros();
init_local_delivery_aliases();
Amavis::Conf::init_decoders();
Amavis::Conf::build_default_maps();

# default location of the config file if none specified
push(@config_files, '/etc/amavisd.conf')  if !@config_files;
# Read/execute the config file, which may override default settings
Amavis::Conf::read_config(@config_files);

if (defined $desired_user && $daemon_user ne '') {
  # compare the config file settings to current UID
  my($username,$passwd,$uid,$gid) =
    $daemon_user=~/^(\d+)$/ ? (undef,undef,$1,undef) : getpwnam($daemon_user);
  $uid == $> or warn sprintf(
    "WARN: running under user '%s' (UID=%s), the config file".
    " specifies \$daemon_user='%s' (UID=%s)\n",
    $desired_user, $>, $daemon_user, defined $uid ? $uid : '?');
}

# compile optional modules if needed
# %modules_basic = %INC;  # helps to track missing modules in chroot

if (!$enable_db) { $extra_code_db = undef }
else {
  eval $extra_code_db
    or die "Problem in Amavis::DB or Amavis::DB::SNMP code: $@";
  $extra_code_db = 1;         # release memory occupied by the source code
}
if (!$enable_global_cache || !$extra_code_db) { $extra_code_cache = undef }
else {
  eval $extra_code_cache or die "Problem in the Amavis::Cache code: $@";
  $extra_code_cache = 1;      # release memory occupied by the source code
}

if (!@storage_sql_dsn) { $extra_code_sql_log = undef }
if (!@lookup_sql_dsn)  { $extra_code_sql_lookup = undef }
if (!defined($extra_code_sql_log) ||        # sql quarantine depends on sql log
    !grep { c($_)=~/^sql:/i } qw(clean_quarantine_method
                   virus_quarantine_method spam_quarantine_method
                   banned_files_quarantine_method bad_header_quarantine_method)
   ) { $extra_code_sql_quar = undef }

if (!defined($extra_code_sql_log) && !defined($extra_code_sql_quar) &&
    !defined($extra_code_sql_lookup)) { $extra_code_sql_base = undef }
else {
  eval $extra_code_sql_base or die "Problem in Amavis SQL base code: $@";
  $extra_code_sql_base = 1;   # release memory occupied by the source code
}
if (defined $extra_code_sql_log) {
  eval $extra_code_sql_log or die "Problem in Amavis::SQL::Log code: $@";
  $extra_code_sql_log = 1;    # release memory occupied by the source code
}
if (defined $extra_code_sql_quar) {
  eval $extra_code_sql_quar or die "Problem in Amavis::SQL::Quarantine code: $@";
  $extra_code_sql_quar = 1;   # release memory occupied by the source code
}
if (defined $extra_code_sql_lookup) {
  eval $extra_code_sql_lookup or die "Problem in Amavis SQL lookup code: $@";
  $extra_code_sql_lookup = 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
}

{ my(%needed_protocols_in);
  for my $bank_name (keys %policy_bank) {
    my($var) = $policy_bank{$bank_name}{'protocol'};
    $var = $$var  if ref($var) eq 'SCALAR';  # allow one level of indirection
    $needed_protocols_in{$var} = 1  if defined $var;
  }
  # compatibility with older config files unaware of $protocol config variable
  $needed_protocols_in{'AM.CL'} = 1
    if $unix_socketname ne '' &&
       !(grep {$needed_protocols_in{$_}} qw(AM.PDP COURIER));
  $needed_protocols_in{'SMTP'} = 1
    if $inet_socket_port ne '' && c('forward_method') ne '' &&
       (!ref $inet_socket_port || @$inet_socket_port) &&
       !(grep {$needed_protocols_in{$_}} qw(SMTP LMTP QMQPqq));
  if ($needed_protocols_in{'AM.PDP'} || $needed_protocols_in{'AM.CL'}) {
    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
  } else {
    $extra_code_in_amcl = undef;
  }
  if ($needed_protocols_in{'SMTP'} || $needed_protocols_in{'LMTP'}) {
    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
  } else {
    $extra_code_in_smtp = undef;
  }
  if ($needed_protocols_in{'COURIER'}) {
    eval $extra_code_in_courier or die "Problem in the In::Courier code: $@";
    $extra_code_in_courier = 1; # release memory occupied by the source code
  } else {
    $extra_code_in_courier = undef;
  }
  if ($needed_protocols_in{'QMQPqq'})  { die "In::QMQPqq code not available" }
}

{ my(%needed_protocols_out);
  for my $bank_name (keys %policy_bank) {
    for my $method_name qw(forward_method notify_method os_fingerprint_method
         clean_quarantine_method virus_quarantine_method spam_quarantine_method
         banned_files_quarantine_method bad_header_quarantine_method) {
      my($var) = $policy_bank{$bank_name}{$method_name};
      $var = $$var  if ref($var) eq 'SCALAR';  # allow one level of indirection
      $needed_protocols_out{uc($1)} = 1  if $var =~ /^([A-Za-z0-9]*):/;
    }
  }
  if (!$needed_protocols_out{'SMTP'}) { $extra_code_out_smtp = undef }
  else {
    eval $extra_code_out_smtp or die "Problem in Amavis::Out::SMTP code: $@";
    $extra_code_out_smtp = 1;  # release memory occupied by the source code
  }
  if (!$needed_protocols_out{'PIPE'}) { $extra_code_out_pipe = undef }
  else {
    eval $extra_code_out_pipe or die "Problem in Amavis::Out::Pipe code: $@";
    $extra_code_out_pipe = 1;  # release memory occupied by the source code
  }
  if (!$needed_protocols_out{'BSMTP'}) { $extra_code_out_bsmtp = undef }
  else {
    eval $extra_code_out_bsmtp or die "Problem in Amavis::Out::BSMTP code: $@";
    $extra_code_out_bsmtp = 1;  # release memory occupied by the source code
  }
  if (!$needed_protocols_out{'LOCAL'}) { $extra_code_out_local = undef }
  else {
    eval $extra_code_out_local or die "Problem in Amavis::Out::Local code: $@";
    $extra_code_out_local = 1;  # release memory occupied by the source code
  }
  if (!$needed_protocols_out{'P0F'}) { $extra_code_p0f = undef }
  else {
    eval $extra_code_p0f or die "Problem in OS_Fingerprint code: $@";
    $extra_code_p0f = 1;        # release memory occupied by the source code
  }
}

my($bpvcm) = ca('bypass_virus_checks_maps');
if (!@{ca('av_scanners')} && !@{ca('av_scanners_backup')}) {
  $extra_code_antivirus = undef;
} elsif (@$bpvcm && !ref($bpvcm->[0]) && $bpvcm->[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 (!$extra_code_antivirus)  # release storage
  { @Amavis::Conf::av_scanners = @Amavis::Conf::av_scanners_backup = () }

my($bpscm) = ca('bypass_spam_checks_maps');
if (@$bpscm && !ref($bpscm->[0]) && $bpscm->[0]) {
  # do a simple-minded test to make it easy to turn off spam checks
  $extra_code_antispam = undef;
  $extra_code_antispam_sa = undef;
} else {
  eval $extra_code_antispam or die "Problem in the antispam code: $@";
  $extra_code_antispam = 1;     # release memory occupied by the source code
  eval $extra_code_antispam_sa or die "Problem in the antispam SA code: $@";
  $extra_code_antispam_sa = 1;  # release memory occupied by the source code
}

if (c('bypass_decode_parts') &&
    !grep {exists $policy_bank{$_}{'bypass_decode_parts'} &&
           !$policy_bank{$_}{'bypass_decode_parts'} } keys %policy_bank) {
  $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
}

# act on command line parameters
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,all'  if $cmd eq 'debug-sa';
} elsif ($cmd !~ /^(reload|stop)\z/) {
  die "$myversion: Unknown argument.  Usage:\n  $0 [-u user] [-g group] [-c config-file] ( [start] | stop | reload | debug | debug-sa | foreground )\n";
} else {  # stop or reload
  eval {  # first stop a running daemon
    $pid_file ne '' or die "Config parameter \$pid_file not defined";
    my($errn) = stat($pid_file) ? 0 : 0+$!;
    $errn != ENOENT or die "No PID file $pid_file\n";
    $errn == 0      or die "PID file $pid_file inaccessible: $!";
    my($amavisd_pid); local(*PID_FILE); my($ln);
    open(PID_FILE, "< $pid_file\0") or die "Can't open file $pid_file: $!";
    for ($! = 0; defined($ln=<PID_FILE>); $! = 0)
      { chomp($ln);  $amavisd_pid = $ln  if $ln =~ /^\d+\z/ }
    defined $ln || $!==0  or die "Error reading from $pid_file: $!";
    close(PID_FILE) or die "Error closing file $pid_file: $!";
    defined($amavisd_pid) or die "Invalid PID in the $pid_file";
    $amavisd_pid = untaint($amavisd_pid);
    kill('TERM',$amavisd_pid) or die "Can't SIGTERM amavisd[$amavisd_pid]: $!";
    my($waited) = 0; my($sigkill_sent) = 0; my($delay) = 1;  # seconds
    for (;;) {  # wait for the old running daemon to go away
      sleep($delay); $waited += $delay; $delay = 5;
      last  if !kill(0,$amavisd_pid);  # is the old daemon still there?
      if ($waited < 60 || $sigkill_sent) {
        print STDERR "Waiting for the process $amavisd_pid to terminate\n";
      } else {  # use stronger hammer
        print STDERR "Sending SIGKILL to amavisd[$amavisd_pid]\n";
        kill('KILL',$amavisd_pid)
          or warn "Can't SIGKILL amavisd[$amavisd_pid]: $!";
        $sigkill_sent = 1;
      }
    }
  };
  if ($@ ne '') { chomp($@); die "$@, can't $cmd the process\n" }
  exit 0  if $cmd eq 'stop';
  print STDERR "daemon terminated, waiting for the dust to settle...\n";
  sleep 5;  # wait for the TCP socket to be released
  print STDERR "becoming a new daemon...\n";
}
$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($DEBUG, $DO_SYSLOG, $LOGFILE);

# report version of Perl and process UID
do_log(1, "user=%s, EUID: %s (%s);  group=%s, EGID: %s (%s); log_level=%s",
          $desired_user, $>, $<, $desired_group, $), $(, c('log_level'));
#do_log(c('log_level'), "Test log entry at log_level %s", c('log_level'));
do_log(0, "Perl version               %s", $]);

# insist on a FQDN in $myhostname
my($myhn) = c('myhostname');
$myhn =~ /[^.]\.[a-zA-Z0-9]+\z/s || lc($myhn) eq 'localhost'
  or die <<"EOD";
  The value of variable \$myhostname is \"$myhn\", but should have been
  a fully qualified domain name; perhaps uname(3) did not provide such.
  You must explicitly assign a FQDN of this host to variable \$myhostname
  in amavisd.conf, or fix what uname(3) provides as a host's network name!
EOD

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

do {  # pre-parse IP lookup tables to speed up lookups; tokenize templates
  my(@templ_names) = qw(log_templ log_recip_templ
     notify_sender_templ notify_virus_recips_templ 
     notify_virus_sender_templ notify_virus_admin_templ
     notify_spam_sender_templ notify_spam_admin_templ);
  for my $bank_name (keys %policy_bank) {
    my($r) = $policy_bank{$bank_name}{'inet_acl'};
    if (ref($r) eq 'ARRAY')    # should be a ref to single IP lookup table
      { $policy_bank{$bank_name}{'inet_acl'} = Amavis::Lookup::IP->new(@$r) }
    $r = $policy_bank{$bank_name}{'mynetworks_maps'};  # ref to list of tables
    if (ref($r) eq 'ARRAY') {  # should be an array, test just to make sure
      for my $table (@$r) # replace plain lists with Amavis::Lookup::IP objects
        { $table = Amavis::Lookup::IP->new(@$table) if ref($table) eq 'ARRAY' }
    }
    for my $n (@templ_names) { # tokenize templates to speed up macro expansion
      my($s) = $policy_bank{$bank_name}{$n};  $s = $$s if ref($s) eq 'SCALAR';
      $policy_bank{$bank_name}{$n} = tokenize(\$s)  if defined $s;
    }
  }
};

fetch_modules_extra();  # bring additional modules into memory and compile them
Amavis::SpamControl::init_pre_chroot()  if $extra_code_antispam;

# set up Net::Server configuration
my $server = bless {
  server => {
    # command args to be used after HUP must be untainted, deflt: [$0,@ARGV]
  # commandline => ['/usr/local/sbin/amavisd','-c',$config_file[0] ],
    commandline => [],  # disable

    # listen on the following sockets (one or more):
    port => [ (!defined($unix_socketname) || $unix_socketname eq '' ? ()
                : "$unix_socketname|unix"), # helper
              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 => (!defined($inet_socket_bind) || $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       => (($> == 0 || $< == 0) ? $daemon_user  : undef),
    group      => (($> == 0 || $< == 0) ? $daemon_group : undef),
    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,
    # no_client_stdout introduced with Net::Server 0.92, but is broken in 0.92
    no_client_stdout => (Net::Server->VERSION >= 0.93 ? 1 : 0),
    # 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::DB::SNMP;
use strict;
use re 'taint';
no warnings 'uninitialized';

BEGIN {
  import Amavis::Conf qw($myversion $myhostname);
  import Amavis::Util qw(ll do_log snmp_counters_get
                         add_entropy fetch_entropy);
}

use BerkeleyDB;

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

# open existing databases (called by each child process)
sub new {
  my($class,$db_env) = @_; $! = 0; my($env) = $db_env->get_db_env;
  defined $env or die "BDB bad db env.: $BerkeleyDB::Error, $!.";
  $! = 0; my($dbs) = BerkeleyDB::Hash->new(-Filename=>'snmp.db', -Env=>$env);
  defined $dbs or die "BDB no dbS: $BerkeleyDB::Error, $!.";
  $! = 0; my($dbn) = BerkeleyDB::Hash->new(-Filename=>'nanny.db',-Env=>$env);
  defined $dbn or die "BDB no dbN: $BerkeleyDB::Error, $!.";
  bless { 'db_snmp'=>$dbs, 'db_nanny'=>$dbn }, $class;
}

sub DESTROY {
  my($self) = shift;
  eval { do_log(5,"Amavis::DB::SNMP DESTROY called") };
  for my $db ($self->{'db_snmp'}, $self->{'db_nanny'}) {
    if (defined $db) {
      eval { $db->db_close==0 or die "db_close: $BerkeleyDB::Error, $!." };
      if ($@ ne '') { warn "BDB S+N DESTROY $@" }
      $db = undef;
    }
  }
}

#sub lock_stat($) {
# my($label) = @_;
# my($s) = qx'/usr/local/bin/db_stat-4.2 -c -h /var/amavis/db | /usr/local/bin/perl -ne \'$a{$2}=$1 if /^(\d+)\s+Total number of locks (requested|released)/; END {printf("%d, %d\n",$a{requested}, $a{requested}-$a{released})}\'';
# do_log(0, "lock_stat %s: %s", $label,$s);
#}

# insert startup time SNMP entry, called from the master process at startup
# (a classical subroutine, not a method)
sub put_initial_snmp_data($) {
  my($db) = @_;
  my($cursor) = $db->db_cursor(DB_WRITECURSOR);
  defined $cursor or die "BDB S db_cursor: $BerkeleyDB::Error, $!.";
  for my $obj (['sysDescr',    'STR', $myversion],
               ['sysObjectID', 'OID', '1.3.6.1.4.1.15312.2.1'],
                 # iso.org.dod.internet.private.enterprise.ijs.amavisd-new.snmp
               ['sysUpTime',   'INT', int(time)],
                 # later it must be converted to timeticks (10ms since start)
               ['sysContact',  'STR', ''],
               ['sysName',     'STR', $myhostname],
               ['sysLocation', 'STR', ''],
               ['sysServices', 'INT', 64],  # application
  ) {
    my($key,$type,$val) = @$obj;
    $cursor->c_put($key, sprintf("%s %s",$type,$val), DB_KEYLAST) == 0
      or die "BDB S c_put: $BerkeleyDB::Error, $!.";
  };
  $cursor->c_close==0 or die "BDB S c_close: $BerkeleyDB::Error, $!.";
}

sub update_snmp_variables {
  my($self) = @_;
  do_log(5,"updating snmp variables");
  my($snmp_var_names_ref) = snmp_counters_get();
  my($eval_stat,$interrupt); $interrupt = '';
  if (defined $snmp_var_names_ref && @$snmp_var_names_ref) {
    my($db) = $self->{'db_snmp'}; my($cursor);
    my($h1) = sub { $interrupt = $_[0] };
    local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8;
    eval {  # ensure cursor will be unlocked even in case of errors or signals
      $cursor = $db->db_cursor(DB_WRITECURSOR);  # obtain write lock
      defined $cursor or die "db_cursor: $BerkeleyDB::Error, $!.";
      for my $key (@$snmp_var_names_ref) {
        my($snmp_var_name,$arg,$type) = ref $key ? @$key : ($key);
        $type = 'C32' if !defined($type) || $type eq '';
        $arg  = 1     if !defined($arg) && $type eq 'C32';
        my($val,$flags);
        my($stat) = $cursor->c_get($snmp_var_name,$val,DB_SET);
        if ($stat==0) {  # exists, update it
          if    ($type eq 'C32' && $val=~/^C32 (\d+)\z/) { $val = $1+$arg }
          elsif ($type eq 'INT' && $val=~/^INT (\d+)\z/) { $val = $arg }
          elsif ($type=~/^(STR|OID)\z/ && $val=~/^\Q$type\E (.*)\z/) {
            if ($snmp_var_name ne 'entropy') { $val = $arg }
            else {  # blend-in entropy
              $val = $1; add_entropy($val, Time::HiRes::gettimeofday);
              $val = substr(fetch_entropy(),-10,10);  # save only 60 tail bits
            }
          }
          else { do_log(-2,"WARN: variable syntax? %s, clearing",$val); $val=0}
          $flags = DB_CURRENT;
        } else {  # create new entry
          $stat==DB_NOTFOUND  or die "c_get: $BerkeleyDB::Error, $!.";
          $flags = DB_KEYLAST; $val = $arg;
        }
        my($str) = $type =~ /^(C32|INT)\z/ ? sprintf("%010d",$val) : $val;
        $cursor->c_put($snmp_var_name, "$type $str", $flags) == 0
          or die "c_put: $BerkeleyDB::Error, $!.";
      }
      $cursor->c_close==0 or die "c_close: $BerkeleyDB::Error, $!.";
      $cursor = undef;
    };
    $eval_stat = $@;
    if (defined $db) {
      $cursor->c_close  if defined $cursor;  # unlock, ignoring status
      $cursor = undef;
#     if ($eval_stat eq '') {
#       my($stat); $db->db_sync();  # not really needed
#       $stat==0 or warn "BDB S db_sync, status $stat: $BerkeleyDB::Error, $!.";
#     }
    }
  }
  delete $self->{'cnt'};
  if ($interrupt ne '') { kill($interrupt,$$) }  # resignal
  elsif ($eval_stat ne '')
    { chomp($eval_stat); die "update_snmp_variables: BDB S $eval_stat\n" }
}

sub read_snmp_variables {
  my($self,@snmp_var_names) = @_;
  my($eval_stat,$interrupt); $interrupt = '';
  my($db) = $self->{'db_snmp'}; my($cursor); my(@values);
  my($h1) = sub { $interrupt = $_[0] };
  local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8;
  eval {  # ensure cursor will be unlocked even in case of errors or signals
    $cursor = $db->db_cursor;  # obtain read lock
    defined $cursor or die "db_cursor: $BerkeleyDB::Error, $!.";
    for my $cname (@snmp_var_names) {
      my($val); my($stat) = $cursor->c_get($cname,$val,DB_SET);
      push(@values, $stat==0 ? $val : undef);
      $stat==0 || $stat==DB_NOTFOUND  or die "c_get: $BerkeleyDB::Error, $!.";
    }
    $cursor->c_close==0 or die "c_close: $BerkeleyDB::Error, $!.";
    $cursor = undef;
  };
  $eval_stat = $@;
  if (defined $db) {
    $cursor->c_close  if defined $cursor;  # unlock, ignoring status
    $cursor = undef;
  }
  if ($interrupt ne '') { kill($interrupt,$$) }  # resignal
  elsif ($eval_stat ne '')
    { chomp($eval_stat); die "read_snmp_variables: BDB S $eval_stat\n" }
  for my $val (@values) {
    if (!defined($val)) {}  # keep undefined
    elsif ($val =~ /^(?:C32|INT) (\d+)\z/) { $val = 0+$1 }
    elsif ($val =~ /^(?:STR|OID) (.*)\z/)  { $val = $1 }
    else { do_log(-2,"WARN: counter syntax? %s", $val); $val = undef }
  }
  \@values;
}

sub register_proc {
  my($self,$task_id) = @_;
  my($db) = $self->{'db_nanny'}; my($cursor);
  my($val,$new_val); my($key) = sprintf("%05d",$$);
  $new_val = sprintf("%010d %-12s", time, $task_id)  if defined $task_id;
  my($eval_stat,$interrupt); $interrupt = '';
  my($h1) = sub { $interrupt = $_[0] };
  local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8;
  eval {  # ensure cursor will be unlocked even in case of errors or signals
    $cursor = $db->db_cursor(DB_WRITECURSOR);  # obtain write lock
    defined $cursor or die "db_cursor: $BerkeleyDB::Error, $!.";
    my($stat) = $cursor->c_get($key,$val,DB_SET);
    $stat==0 || $stat==DB_NOTFOUND or die "c_get: $BerkeleyDB::Error, $!.";
    if ($stat==0 && !defined $task_id) {  # remove existing entry
      $cursor->c_del==0 or die "c_del: $BerkeleyDB::Error, $!.";
    } elsif (defined $task_id && !($stat==0 && $new_val eq $val)) {
      # add new, or update existing entry if different
      $cursor->c_put($key, $new_val,
                     $stat==0 ? DB_CURRENT : DB_KEYLAST ) == 0
        or die "c_put: $BerkeleyDB::Error, $!.";
    }
    $cursor->c_close==0 or die "c_close: $BerkeleyDB::Error, $!.";
    $cursor = undef;
  };
  $eval_stat = $@;
  if (defined $db) {
    $cursor->c_close  if defined $cursor;  # unlock, ignoring status
    $cursor = undef;
#   if ($eval_stat eq '') {
#     my($stat) = $db->db_sync();  # not really needed
#     $stat==0 or warn "BDB N db_sync, status $stat: $BerkeleyDB::Error, $!.";
#   }
  }
  if ($interrupt ne '') { kill($interrupt,$$) }  # resignal
  elsif ($eval_stat ne '')
    { chomp($eval_stat); die "register_proc: BDB N $eval_stat\n" }
}

1;

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

BEGIN {
  import Amavis::Conf qw($db_home $daemon_chroot_dir);
  import Amavis::Util qw(untaint ll do_log);
}

use BerkeleyDB;

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

# create new databases, then close them (called by the parent process)
# (called only if $db_home is nonempty)
sub init($) {
  my($predelete) = @_;  # delete existing db files first?
  my($name) = $db_home;
  $name = "$daemon_chroot_dir $name"  if $daemon_chroot_dir ne '';
  if ($predelete) {     # delete old database files
    local(*DIR);
    opendir(DIR,$db_home) or die "db_init: Can't open directory $name: $!";
    my(@dirfiles) = readdir(DIR); #must avoid modifying dir while traversing it
    closedir(DIR) or die "db_init: Error closing directory $name: $!";
    for my $f (@dirfiles) {
      next  if ($f eq '.' || $f eq '..') && -d _;
      if ($f =~ /^(__db\.\d+|(cache-expiry|cache|snmp|nanny)\.db)\z/s) {
        $f = untaint($f);
        unlink("$db_home/$f") or die "db_init: Can't delete file $name/$f: $!";
      }
    }
  }
  $! = 0; my($env) = BerkeleyDB::Env->new(-Home=>$db_home, -Mode=>0640,
    -Flags=> DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL);
  defined $env
    or die "db_init: BDB bad db env. at $db_home: $BerkeleyDB::Error, $!.";
  do_log(0, "Creating db in %s/; BerkeleyDB %s, libdb %s",
            $name, BerkeleyDB->VERSION, $BerkeleyDB::db_version);
  $! = 0; my($dbc) = BerkeleyDB::Hash->new(
    -Filename=>'cache.db', -Flags=>DB_CREATE, -Env=>$env );
  defined $dbc or die "db_init: BDB no dbC: $BerkeleyDB::Error, $!.";
  $! = 0; 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 "db_init: BDB no dbQ: $BerkeleyDB::Error, $!.";
  $! = 0; my($dbs) = BerkeleyDB::Hash->new(
    -Filename=>'snmp.db', -Flags=>DB_CREATE, -Env=>$env );
  defined $dbs or die "db_init: BDB no dbS: $BerkeleyDB::Error, $!.";
  $! = 0; my($dbn) = BerkeleyDB::Hash->new(
    -Filename=>'nanny.db', -Flags=>DB_CREATE, -Env=>$env );
  defined $dbn or die "db_init: BDB no dbN: $BerkeleyDB::Error, $!.";

  Amavis::DB::SNMP::put_initial_snmp_data($dbs);
  for my $db ($dbc, $dbq, $dbs, $dbn) {
    $db->db_close==0 or die "db_init: BDB db_close: $BerkeleyDB::Error, $!.";
  }
}

# open an existing databases environment (called by each child process)
sub new {
  my($class) = @_; my($env);
  if (defined $db_home) {
    $env = BerkeleyDB::Env->new(
      -Home=>$db_home, -Mode=>0640, -Flags=> DB_INIT_CDB | DB_INIT_MPOOL);
    defined $env or die "BDB bad db env. at $db_home: $BerkeleyDB::Error, $!.";
  }
  bless \$env, $class;
}
sub get_db_env { my($self) = shift; $$self }

1;

__DATA__
#
package Amavis::Cache;
# offer an 'IPC::Cache'-compatible interface to a BerkeleyDB-based cache.
# Replaces methods new,get,set of the memory-based cache.
use strict;
use re 'taint';
no warnings 'uninitialized';

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

use BerkeleyDB;

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

# open existing databases (called by each child process);
# if $db_env is undef a memory-based cache is created, otherwise use BerkeleyDB
sub new {
  my($class,$db_env) = @_;
  my($dbc,$dbq,$mem_cache);
  if (!defined($db_env)) {
    do_log(1,"BerkeleyDB not available, using memory-based local cache");
    $mem_cache = {};
  } else {
    my($env) = $db_env->get_db_env;
    defined $env or die "BDB bad db env.: $BerkeleyDB::Error, $!.";
    $dbc = BerkeleyDB::Hash->new(-Filename=>'cache.db', -Env=>$env);
    defined $dbc or die "BDB no dbC: $BerkeleyDB::Error, $!.";
    $dbq = BerkeleyDB::Queue->new(-Filename=>'cache-expiry.db', -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, $!.";
  }
  bless {'db_cache'=>$dbc, 'db_queue'=>$dbq, 'mem_cache'=>$mem_cache}, $class;
}

sub DESTROY {
  my($self) = shift;
  eval { do_log(5,"Amavis::Cache DESTROY called") };
  for my $db ($self->{'db_cache'}, $self->{'db_queue'}) {
    if (defined $db) {
      eval { $db->db_close==0 or die "db_close: $BerkeleyDB::Error, $!." };
      if ($@ ne '') { warn "BDB C+Q DESTROY $@" }
      $db = undef;
    }
  }
}

# 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'};
  local($1,$2); my($stat,$key,$val); $key = '';
  my($qcursor) = $dbq->db_cursor(DB_WRITECURSOR);
  defined $qcursor or die "BDB Q db_cursor: $BerkeleyDB::Error, $!.";
  # no warnings 'numeric';  # seems like c_get can return an empty string?!
  while ( $stat=$qcursor->c_get($key,$val,DB_NEXT), $stat eq '' || $stat==0 ) {
    do_log(5,'enqueue: stat is not numeric: "%s"', $stat) if $stat !~ /^\d+\z/;
    if ($val !~ /^([^ ]+) (.*)\z/s) {
      do_log(-2,"WARN: queue head invalid, deleting: %s", $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 C db_cursor: $BerkeleyDB::Error, $!.";
      my($v); my($st1) = $cursor->c_get($digest,$v,DB_SET);
      $st1==0 || $st1==DB_NOTFOUND or die "BDB C c_get: $BerkeleyDB::Error, $!.";
      if ($st1==0 && $v=~/^([^ ]+) /s) {  # record exists and appears valid
         if ($1 ne $t) {
           do_log(5,"enqueue: not deleting: %s, was refreshed since", $digest);
         } else {  # its expiration time correspond to timestamp in the queue
           do_log(5,"enqueue: deleting: %s", $digest);
           my($st2) = $cursor->c_del;     # delete expired entry from the cache
           $st2==0 || $st2==DB_KEYEMPTY
             or die "BDB C c_del: $BerkeleyDB::Error, $!.";
         }
      }
      $cursor->c_close==0 or die "BDB C 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, $!.";
  # syncing would only be worth doing if we would want the cache to persist
  # across restarts - but we scratch the databases to avoid rebuild worries
# $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); my($db) = $self->{'db_cache'};
  if (!defined($db)) {
    $val = $self->{'mem_cache'}{$key};  # simple local memory-based cache
  } else {
    my($stat) = $db->db_get($key,$val);
    $stat==0 || $stat==DB_NOTFOUND
      or die "BDB C c_get: $BerkeleyDB::Error, $!.";
    local($1,$2);
    if ($stat==0 && $val=~/^([^ ]+) (.*)/s) { $val = $2 } else { $val = undef }
  }
  thaw($val);
}

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

1;

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

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

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,$get_all) = @_;
  my(@result,@matchingkey);
  if (!defined($self)) {
    do_log(5, 'lookup_sql_field - undefined, "%s" no match', $addr);
  } elsif (!defined($self->{sql_query})) {
    do_log(5, 'lookup_sql_field(%s) - null query, "%s" no match',
              $self->{fieldname}, $addr);
  } else {
    my($field) = $self->{fieldname};
    my($res_ref,$mk_ref) = $self->{sql_query}->lookup_sql($addr,1,
                                  !exists($self->{args}) ? () : $self->{args});
    do_log(5, 'lookup_sql_field(%s), "%s" no matching records', $field,$addr)
      if !defined($res_ref) || !@$res_ref;
    for my $ind (0 .. (!defined($res_ref) ? -1 : $#$res_ref)) {
      my($match); my($h_ref) = $res_ref->[$ind]; my($mk) = $mk_ref->[$ind];
      if (!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(%s), no field, "%s" result=%s',
                    $field,$addr,$match);
        } elsif ($self->{fieldtype} =~ /^B1/) {  # defaults to true
          $match = 1;  # nonexistent field treated as 1
          do_log(5,'lookup_sql_field(%s), no field, "%s" result=%s',
                   $field,$addr,$match);
        } elsif ($self->{fieldtype}=~/^.-/s) {   # allowed to not exist
          do_log(5,'lookup_sql_field(%s), no field, "%s" result=undef',
                   $field,$addr);
        } else {       # treated as 'no match', issue a warning
          do_log(1,'lookup_sql_field(%s) '.
                   '(WARN: no such field in the SQL table), "%s" result=undef',
                    $field,$addr);
        }
      } else {  # field exists
        # fieldtype: B=boolean, N=numeric, S=string
        $match = $h_ref->{$field};
        if (!defined($match)) {   # NULL field values represented as undef
        } 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
          # trim trailing spaces
          $match =~ s/ +\z//  if $trim_trailing_space_in_lookup_result_fields;
        }
        do_log(5, 'lookup_sql_field(%s) "%s" result=%s', $field, $addr,
                  defined $match ? $match : 'undef' );
      }
      if (defined $match) {
        push(@result,$match); push(@matchingkey,$mk);
        last  if !$get_all;
      }
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@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.062';
  @ISA = qw(Exporter);
}

use DBI;

BEGIN {
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(untaint snmp_count ll do_log);
  import Amavis::rfc2821_2822_Tools qw(make_query_keys);
  import Amavis::Out::SQL::Connection ();
}

# return a new Lookup::SQL object to contain DBI handle and prepared selects
sub new {
  my($class, $conn_h, $clause_name) = @_;
  if ($clause_name eq '') { undef }
  else {
    # $clause_name is an key into %sql_clause of the currently selected
    # policy bank; one level of indirection is allowed in %sql_clause result,
    # the resulting SQL clause may include %k, to be expanded
    bless { conn_h => $conn_h, incarnation => 0, clause_name => $clause_name },
          $class;
  }
}

sub DESTROY {
  my($self) = shift; eval { do_log(5,"Amavis::Lookup::SQL DESTROY called") };
}

sub init {
  my($self) = @_;
  if ($self->{incarnation} != $self->{conn_h}->incarnation) {  # invalidated?
    $self->{incarnation} = $self->{conn_h}->incarnation;
    $self->clear_cache;  # db handle has changed, invalidate cache
  }
  $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, unless $get_all is true.
#
# 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:
#    - a 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,$get_all,$extra_args) = @_;
  my(@matchingkey,@result);
  my($sel); my($sql_cl_r) = cr('sql_clause');
  $sel = $sql_cl_r->{$self->{clause_name}}  if defined $sql_cl_r;
  $sel = $$sel  if ref $sel eq 'SCALAR';  # allow one level of indirection
  if (!defined($sel) || $sel eq '') {
    ll(4) && do_log(4,"lookup_sql disabled for clause: %s",
                      $self->{clause_name});
    return(!wantarray ? undef : (undef,undef));
  } elsif (!defined $extra_args &&
           exists $self->{cache} && exists $self->{cache}->{$addr})
  { # cached ?
    my($c) = $self->{cache}->{$addr}; @result = @$c  if ref $c;
    @matchingkey = map {'/cached/'} @result; #will do for now, improve some day
#   if (!ll(5)) {}# don't bother preparing log report which will not be printed
#   elsif (!@result) { do_log(5,'lookup_sql (cached): "%s" no match', $addr) }
#   else {
#     for my $m (@result) {
#       do_log(5, "lookup_sql (cached): \"%s\" matches, result=(%s)",
#         $addr, join(", ", map { sprintf("%s=>%s", $_,
#                                 !defined($m->{$_})?'-':'"'.$m->{$_}.'"'
#                                        ) } sort keys(%$m) ) );
#     }
#   }
    if (!$get_all) {
      return(!wantarray ? $result[0] : ($result[0], $matchingkey[0]));
    } else {
      return(!wantarray ? \@result   : (\@result,   \@matchingkey));
    }
  }
  my($is_local);  # $local_domains_sql is not looked up to avoid recursion!
  $is_local = Amavis::Lookup::lookup(0,$addr,
                                     grep {ref ne 'Amavis::Lookup::SQL' &&
                                           ref ne 'Amavis::Lookup::SQLfield' &&
                                           ref ne 'Amavis::Lookup::LDAP' &&
                                           ref ne 'Amavis::Lookup::LDAPattr'}
                                           @{ca('local_domains_maps')});
  my($keys_ref,$rhs_ref) = make_query_keys($addr,0,$is_local);
  my($n) = sprintf("%d",scalar(@$keys_ref));  # number of keys
  my(@pos_args);  my(@extras_tmp) = !ref $extra_args ? () : @$extra_args;
  $sel =~ s{ ( %k | \? ) }  # substitute %k for keys and ? for each extra arg
           { push(@pos_args, map { untaint($_) }
                  $1 eq '%k' ? @$keys_ref : shift @extras_tmp),
             $1 eq '%k' ? join(',', ('?') x $n) : '?' }gxe;
  ll(4) && do_log(4,"lookup_sql \"%s\", query args: %s",
                    $addr, join(', ', map{"\"$_\""} @pos_args) );
  ll(4) && do_log(4,"lookup_sql select: %s", $sel);
  my($a_ref,$found); my($match) = {}; my($conn_h) = $self->{conn_h};
  $conn_h->begin_work_nontransaction;  # (re)connect if not connected
  eval {
    snmp_count('OpsSqlSelect');
    $conn_h->execute($sel,@pos_args);  # do the query
    # fetch query results
    while ( defined($a_ref=$conn_h->fetchrow_arrayref($sel)) ) {
      my(@names) = @{$conn_h->sth($sel)->{NAME_lc}};
      $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: "%s" matches catchall, local=>undef', $addr);
      }
      push(@result, {%$match});  # copy hash
      push(@matchingkey, join(", ", map { sprintf("%s=>%s", $_,
                                !defined($match->{$_})?'-':'"'.$match->{$_}.'"'
                                ) } @names));
      last  if !$get_all;
    }
    $conn_h->finish($sel)  if defined $a_ref;  # only if not all read
  };  # eval
  if ($@ ne '') {
    my($err) = $@; chomp($err);
    do_log(-1, "lookup_sql: %s, %s, %s", $err, $DBI::err, $DBI::errstr);
    die $err;
  }
  if (!ll(4)) {
    # don't bother preparing log report which will not be printed
  } elsif (!@result) {
    do_log(4,'lookup_sql, "%s" no match', $addr);
  } else {
    do_log(4,'lookup_sql(%s) matches, result=(%s)',$addr,$_)  for @matchingkey;
  }
  # save for future use, but only within processing of this message
  $self->{cache}->{$addr} = \@result;
  section_time('lookup_sql');
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

__DATA__
#^L
package Amavis::LDAP::Connection;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll do_log);
  import Amavis::Timing qw(section_time);

  $ldap_sys_default = {
    hostname       => 'localhost',
    port           => 389,
    version        => 3,
    timeout        => 120,
    tls            => 0,
    bind_dn        => undef,
    bind_password  => undef,
    deref          => 'find',
  };
}

sub new {
  my($class,$default) = @_;
  my($self) = bless {}, $class;
  $self->{ldap}        = undef;
  $self->{incarnation} = 1;
  $ldap_sys_default->{port} = 636  if $default->{hostname} =~ /^ldaps/i;
  for (qw(hostname port timeout tls base scope bind_dn bind_password deref)) {
    # replace undefined attributes with user values or defaults
    $self->{$_} = $default->{$_}          unless defined($self->{$_});
    $self->{$_} = $ldap_sys_default->{$_} unless defined($self->{$_});
  }
  $self;
}

sub ldap { # get/set ldap handle
  my($self)=shift;
  !@_ ? $self->{ldap} : ($self->{ldap}=shift);
}

sub DESTROY {
  my($self)=shift;
  eval { do_log(5,"Amavis::LDAP::Connection DESTROY called") };
  eval { $self->disconnect_from_ldap };
}

sub incarnation { my($self)=shift; $self->{incarnation} }
sub in_transaction { 0 }

sub begin_work {
  my($self)=shift;
  do_log(5,"ldap begin_work");
  $self->ldap or $self->connect_to_ldap;
}

sub connect_to_ldap {
  my($self) = shift;
  my($bind_err,$start_tls_err);
  do_log(3,"Connecting to LDAP server");
  my $hostlist = ref $self->{hostname} eq 'ARRAY' ?
                     join(", ",@{$self->{hostname}}) : $self->{hostname};
  do_log(4,"connect_to_ldap: trying %s", $hostlist);
  my $ldap = Net::LDAP->new($self->{hostname},
                            port    => $self->{port},
                            version => $self->{version},
                            timeout => $self->{timeout},
                            );
  if ($ldap) {
    do_log(3,"connect_to_ldap: connected to %s", $hostlist);
    if ($self->{tls}) { # TLS required
      my($mesg) = $ldap->start_tls(verify=>'none');
      if ($mesg->code) { # start TLS failed
        my($err) = $mesg->error_name;
        do_log(-1,"connect_to_ldap: start TLS failed: %s", $err);
        $self->ldap(undef);
        $start_tls_err = 1;
      } else { # started TLS
        do_log(3,"connect_to_ldap: TLS version %s enabled", $mesg);
      }
    }
    if ($self->{bind_dn}) { # bind required
      my($mesg) = $ldap->bind($self->{bind_dn},
                              password => $self->{bind_password});
      if ($mesg->code) { # bind failed
        my($err) = $mesg->error_name;
        do_log(-1,"connect_to_ldap: bind failed: %s", $err);
        $self->ldap(undef);
        $bind_err = 1;
      } else { # bind succeeded
        do_log(3,"connect_to_ldap: bind %s succeeded", $self->{bind_dn});
      }
    }
  } else { # connect failed
    do_log(-1,"connect_to_ldap: unable to connect to host %s", $hostlist);
  }
  $self->ldap($ldap); $self->{incarnation}++;
  $ldap or die "connect_to_ldap: unable to connect";
  if ($start_tls_err) { die "connect_to_ldap: start TLS failed" }
  if ($bind_err)      { die "connect_to_ldap: bind failed" }
  section_time('ldap-connect');
  $self;
}

sub disconnect_from_ldap {
  my($self)=shift;
  if ($self->ldap) {
    do_log(4,"disconnecting from LDAP");
    $self->ldap->disconnect;
    $self->ldap(undef);
  }
}

sub do_search {
  my($self,$base,$scope,$filter) = @_;
  my($result);
  $self->ldap or die "do_search: ldap not available";
  do_log(5,"lookup_ldap: searching base=\"%s\", scope=\"%s\", filter=\"%s\"",
           $base, $scope, $filter);
  eval {
    $result = $self->{ldap}->search(base   => $base,
                                    scope  => $scope,
                                    filter => $filter,
                                    deref  => $self->{deref},
                                    );
    if ($result->code) { die $result->error_name, "\n"; }
  };
  if ($@ ne '') {
    my($err) = $@; chomp $err;
    if ($err !~ /^LDAP_/) {
      die "do_search: $err";
    } else {  #  LDAP related error
      do_log(0, "NOTICE: do_search: trying again: %s", $err);
      $self->disconnect_from_ldap;
      $self->connect_to_ldap;
      $self->ldap or die "do_search: reconnect failed";
      do_log(5,
        'lookup_ldap: searching (again) base="%s", scope="%s", filter="%s"',
        $base, $scope, $filter);
      eval {
        $result = $self->{ldap}->search(base   => $base,
                                        scope  => $scope,
                                        filter => $filter,
                                        deref  => $self->{deref},
                                        );
        if ($result->code) { die $result->error_name, "\n"; }
      };
      if ($@ ne '') {
        my($err) = $@; chomp $err;
        $self->disconnect_from_ldap;
        die "do_search: failed again, $err";
      }
    }
  }
  $result;
}

1;

#
package Amavis::Lookup::LDAPattr;

use strict;
use re 'taint';

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

  import Amavis::Util qw(ll do_log);
  import Amavis::Conf qw($trim_trailing_space_in_lookup_result_fields);
}

# attrtype: B=boolean, N=numeric, S=string, L=list
#           N-: numeric, nonexistent field returns undef without complaint
#           S-: string,  nonexistent field returns undef without complaint
#           L-: list,    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

sub new($$$;$) {
  my($class,$ldap_query,$attrname,$attrtype) = @_;
  return undef  if !defined($ldap_query);
  my($self) = bless {}, $class;
  $self->{ldap_query} = $ldap_query;
  $self->{attrname}   = lc($attrname);
  $self->{attrtype}   = uc($attrtype);
  $self;
}

sub lookup_ldap_attr($$$) {
  my($self,$addr,$get_all) = @_;
  my(@result,@matchingkey);
  if (!defined($self)) {
    do_log(5,'lookup_ldap_attr - undefined, "%s" no match', $addr);
  } elsif (!defined($self->{ldap_query})) {
    do_log(5,'lookup_ldap_attr(%s) - null query, "%s" no match',
             $self->{attrname}, $addr);
  } else {
    my($attr) = $self->{attrname};
    my($res_ref,$mk_ref) = $self->{ldap_query}->lookup_ldap($addr,1);
    do_log(5,'lookup_ldap_attr(%s), "%s" no matching records', $attr,$addr)
      if !defined($res_ref) || !@$res_ref;
    for my $ind (0 .. (!defined($res_ref) ? -1 : $#$res_ref)) {
      my($match); my($h_ref) = $res_ref->[$ind]; my($mk) = $mk_ref->[$ind];
      if (!exists($h_ref->{$attr})) {
        # record found, but no attribute with that name in the table
        if (     $self->{attrtype} =~ /^B0/) { # boolean, defaults to false
          $match = 0; # nonexistent attribute treated as 0
          do_log(5,'lookup_ldap_attr(%s), no attribute, "%s" result=%s',
                   $attr,$addr,$match);
        } elsif ($self->{attrtype} =~ /^B1/) { # boolean, defaults to true
          $match = 1; # nonexistent attribute treated as 1
          do_log(5,'lookup_ldap_attr(%s), no attribute, "%s" result=%s',
                   $attr,$addr,$match);
        } elsif ($self->{attrtype}=~/^.-/s) { # allowed to not exist
          do_log(5,'lookup_ldap_attr(%s), no attribute, "%s" result=undef',
                 $attr,$addr);
        } else { # treated as 'no match', issue a warning
          do_log(1,'lookup_ldap_attr(%s) '.
                  '(WARN: no such attribute in LDAP entry), "%s" result=undef',
                  $attr,$addr);
        }
      } else { # attribute exists
        $match = $h_ref->{$attr};
        if (!defined($match)) { # NULL attribute values represented as undef
        } elsif ($self->{attrtype} =~ /^B/) { # boolean
          $match = $match eq "TRUE" ? 1 : 0; # convert TRUE|FALSE to 1|0
        } elsif ($self->{attrtype} =~ /^N/) { # numeric
          $match = $match + 0;  # unify different numeric forms
        } elsif ($self->{attrtype} =~ /^S/) { # string
          # trim trailing spaces
          $match =~ s/ +\z//  if $trim_trailing_space_in_lookup_result_fields;
        } elsif ($self->{attrtype} =~ /^L/) { # list
          #$match = join(", ",@$match);
        }
        do_log(5,'lookup_ldap_attr(%s) "%s" result=(%s)',
                  $attr, $addr, defined($match) ? $match : 'undef');
      }
      if (defined $match) {
        push(@result,$match); push(@matchingkey,$mk);
        last  if !$get_all;
      }
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

#
package Amavis::Lookup::LDAP;

use strict;
use re 'taint';

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

  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(untaint snmp_count ll do_log);
  import Amavis::rfc2821_2822_Tools qw(make_query_keys split_address);
  import Amavis::LDAP::Connection ();

  $ldap_sys_default = {
    base           => undef,
    scope          => 'sub',
    query_filter   => '(&(objectClass=amavisAccount)(mail=%m))',
  };

  @ldap_attrs = qw(amavisVirusLover amavisSpamLover amavisBannedFilesLover
    amavisBadHeaderLover amavisBypassVirusChecks amavisBypassSpamChecks
    amavisBypassBannedChecks amavisBypassHeaderChecks amavisSpamTagLevel
    amavisSpamTag2Level amavisSpamKillLevel amavisSpamModifiesSubj
    amavisVirusQuarantineTo amavisSpamQuarantineTo amavisBannedQuarantineTo
    amavisBadHeaderQuarantineTo amavisBlacklistSender amavisWhitelistSender
    amavisLocal amavisMessageSizeLimit amavisWarnVirusRecip
    amavisWarnBannedRecip amavisWarnBadHeaderRecip amavisVirusAdmin
    amavisNewVirusAdmin amavisSpamAdmin amavisBannedAdmin
    amavisBadHeaderAdmin amavisBannedRuleNames
  );

  @mv_ldap_attrs = qw(amavisBlacklistSender amavisWhitelistSender);
}

sub new {
  my($class,$default,$conn_h) = @_;
  my($self) = bless {}, $class;
  $self->{conn_h}      = $conn_h;
  $self->{incarnation} = 0;
  for (qw(base scope query_filter)) {
    # replace undefined attributes with config values or defaults
    $self->{$_} = $default->{$_}          unless defined($self->{$_});
    $self->{$_} = $ldap_sys_default->{$_} unless defined($self->{$_});
  }
  $self;
}

sub DESTROY {
  my($self) = shift;
  eval { do_log(5,"Amavis::Lookup::LDAP DESTROY called") };
}

sub init {
  my($self) = @_;
  if ($self->{incarnation} != $self->{conn_h}->incarnation) {  # invalidated?
    $self->{incarnation} = $self->{conn_h}->incarnation;
    $self->clear_cache;  # db handle has changed, invalidate cache
  }
  $self;
}

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

sub lookup_ldap($$$) {
  my($self,$addr,$get_all) = @_;
  my(@result,@matchingkey,@tmp_result,@tmp_matchingkey);
  if (exists $self->{cache} && exists $self->{cache}->{$addr}) { # cached?
    my($c) = $self->{cache}->{$addr}; @result = @$c if ref $c;
    @matchingkey = map {'/cached/'} @result; # will do for now, improve some day
#    if (!ll(5)) {
#      # don't bother preparing log report which will not be printed
#    } elsif (!@result) {
#      do_log(5,'lookup_ldap (cached): "%s" no match', $addr);
#    } else {
#      for my $m (@result) {
#        do_log(5, 'lookup_ldap (cached): "%s" matches, result=(%s)',
#          $addr, join(", ", map { sprintf("%s=>%s", $_,
#                                  !defined($m->{$_})?'-':'"'.$m->{$_}.'"'
#                                         ) } sort keys(%$m) ) );
#      }
#    }
    if (!$get_all) {
      return(!wantarray ? $result[0] : ($result[0], $matchingkey[0]));
    } else {
      return(!wantarray ? \@result   : (\@result,   \@matchingkey));
    }
  }
  my($is_local);  # LDAP is not looked up to avoid recursion!
  $is_local = Amavis::Lookup::lookup(0,$addr,
                                     grep {ref ne 'Amavis::Lookup::SQL' &&
                                           ref ne 'Amavis::Lookup::SQLfield' &&
                                           ref ne 'Amavis::Lookup::LDAP' &&
                                           ref ne 'Amavis::Lookup::LDAPattr'}
                                           @{ca('local_domains_maps')});
  my($keys_ref,$rhs_ref,@keys);
  ($keys_ref,$rhs_ref) = make_query_keys($addr,0,$is_local);
  @keys = @$keys_ref;
  unshift(@keys, '<>')  if $addr eq '';  # a hack for a null return path
  $_ = untaint($_) for @keys; # untaint keys
  $_ = Net::LDAP::Util::escape_filter_value($_) for @keys;
  # process %m
  my @filter_attr;
  my $filter = $self->{query_filter};
  while ($filter =~ /%m/) {
    (my $filter_pair) = $filter =~ /\(([^(]*=%m)\)/;
    my ($filter_attr) = split(/=/, $filter_pair);
    my $filter_string = '|' . join('', map { "($filter_attr=$_)" } @keys);
    $filter =~ s/\Q$filter_pair\E/$filter_string/;
    push(@filter_attr, $filter_attr);
  }
  # process %d
  my($base) = $self->{base};
  if ($base =~ /%d/) {
    my($localpart,$domain) = split_address($addr);
    if ($domain) {
      $domain = untaint($domain); $domain = lc($domain);
      $domain =~ s/^\@?(.*?)\.*\z/$1/s;
      $base   =~ s/%d/&Net::LDAP::Util::escape_dn_value($domain)/ge;
    }
  }
  # build hash of keys and array position
  my(%xref,$key_num);
  $xref{$_} = $key_num++ for @keys;
  #
  do_log(4,'lookup_ldap "%s", query keys: %s, base: %s, filter: %s',
      $addr,join(', ',map{"\"$_\""}@keys),$self->{base},$self->{query_filter});
  my($conn_h) = $self->{conn_h};
  $conn_h->begin_work;  # (re)connect if not connected
  eval {
    snmp_count('OpsLDAPSearch');
    my($result) = $conn_h->do_search($base, $self->{scope}, $filter );
    my(@entry) = $result->entries;
    for my $entry (@entry) {
      my($match) = {};
      $match->{dn} = $entry->dn;
      for my $attr (@ldap_attrs) {
        my($value);
        $attr = lc($attr);
        do_log(9,'lookup_ldap: reading attribute "%s" from object', $attr);
        if (grep /^$attr\z/i, @mv_ldap_attrs) { # multivalued
          $value = $entry->get_value($attr, asref => 1);
        } else {
          $value = $entry->get_value($attr);
        }
        $match->{$attr} = $value if $value;
      }
      my $pos;
      for my $attr (@filter_attr) {
        my $value = $entry->get_value($attr);
        if ($value) {
          if (!exists $match->{'amavislocal'} && $value eq '@.') {
            # NOTE: see lookup_sql
            $match->{'amavislocal'} = undef;
            do_log(5, 'lookup_ldap: "%s" matches catchall, amavislocal=>undef',
                      $addr);
          }
          $pos = $xref{$value};
          last;
        }
      }
      my $key_str = join(", ",map {sprintf("%s=>%s",$_,!defined($match->{$_})?
        '-':'"'.$match->{$_}.'"')} keys(%$match));
      push(@tmp_result,      [$pos,{%$match}]); # copy hash
      push(@tmp_matchingkey, [$pos,$key_str]);
      last if !$get_all;
    }
  }; # eval
  if ($@ ne '') {
    my($err) = $@; chomp $err;
    do_log(-1,"lookup_ldap: %s", $err);
    die $err;
  }
  @result      = map {$_->[1]} sort {$a->[0] <=> $b->[0]} @tmp_result;
  @matchingkey = map {$_->[1]} sort {$a->[0] <=> $b->[0]} @tmp_matchingkey;
  if (!ll(4)) {
    # don't bother preparing log report which will not be printed
  } elsif (!@result) {
    do_log(4,'lookup_ldap, "%s" no match', $addr);
  } else {
    do_log(4,'lookup_ldap(%s) matches, result=(%s)',$addr,$_) for @matchingkey;
  }
  # save for future use, but only within processing of this message
  $self->{cache}->{$addr} = \@result;
  section_time('lookup_ldap');
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

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

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

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

BEGIN {
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll do_log debug_oneshot snmp_counters_init snmp_count
                        am_id new_am_id untaint rmdir_recursively add_entropy);
  import Amavis::Lookup qw(lookup);
  import Amavis::Lookup::IP qw(lookup_ip_acl);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::In::Message;
  import Amavis::In::Connection;
  import Amavis::IO::Zlib;
  import Amavis::Out::EditHeader qw(hdr);
  import Amavis::Out qw(mail_dispatch);
  import Amavis::Notify qw(msg_from_quarantine);
}

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

# used with sendmail milter and traditional (non-SMTP) MTA interface,
# but also to request a message release from a quarantine
#
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);
  ll(5) && do_log(5, "process_policy_request: %s, %s, fileno=%s",
                     $old_amcl,$0,fileno($sock));
  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 follows; \3 means EOT (end of transmission)
    my($state) = 0; $attr{'request'} = 'AM.CL'; my($response) = "\001";
    my($rv,@recips,@ldaargs,$inbuff); local($1);
    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;
        $attr{'delivery_care_of'} = @ldaargs ? 'client' : 'server';
        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(-2, "policy_server FAILED: %s", $@);
          $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: $!, fileno=".fileno($sock);
      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 a runaway state
      die "helper client session terminated unexpectedly, state: $state";
    }
    do_log(2, "%s", Amavis::Timing::report());  # report elapsed times

  } else {  # new amavis helper protocol AM.PDP or a Postfix policy server
    # for Postfix policy server see Postfix docs SMTPD_POLICY_README
    my(@response); local($1,$2,$3);
    local($/) = "\012";  # set line terminator to LF (Postfix idiosyncrasy)
    my($ln);  # can accept multiple tasks
    for ($! = 0; defined($ln=$sock->getline); $! = 0) {
      $0 = sprintf("amavisd (ch%d-P)", $Amavis::child_invocation_count);
      Amavis::Timing::init(); snmp_counters_init();
      # must not use \r and \n, not \015 and \012 on certain platforms
      if ($ln =~ /^\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)
                    : $attr{'request'} eq 'release'
                        ? dispatch_from_quarantine($conn,$msginfo)
                    : check_amcl_policy($conn,$msginfo,$check_mail,0);
        };
        if ($@ ne '') {
          chomp($@); do_log(-2, "policy_server FAILED: %s", $@);
          @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 { $_."\015\012" } (@response,'') )
          or die "Can't write response to socket: $!, fileno=".fileno($sock);
        %attr = (); @response = ();
        do_log(2, "%s", Amavis::Timing::report());
      } elsif ($ln =~ /^ ([^=\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 {
          $attr{$attr_name} = [ $attr{$attr_name} ]  if !ref $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 delivery_care_of
          mail_id secret_id quar_type mail_file tempdir tempdir_removed_by) );
        do_log(!$known_attr?-1:3,
               "policy protocol: %s=%s", $attr_name,$attr_val);
      } else {
        do_log(-1, "policy protocol: INVALID ATTRIBUTE LINE: %s", $ln);
      }
      $0 = sprintf("amavisd (ch%d-P-idle)", $Amavis::child_invocation_count);
    }
    defined $ln || $!==0  or die "Read from client socket FAILED: $!";
  };
  $0 = sprintf("amavisd (ch%d-P)", $Amavis::child_invocation_count);
}

# Based on given policy query attributes describing message to be cached
# or released, return a new Amavis::In::Message object
#
sub preprocess_policy_query($) {
  my($attr_ref) = @_;

  my($msginfo) = Amavis::In::Message->new;
  $msginfo->rx_time(time);  # now
  $msginfo->add_contents_category(CC_CLEAN,0);
  add_entropy(%$attr_ref);

  # 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, but multivalued attributes such as
  # 'recipient' must retain their relative order.
  # Required AM.PDP fields are: request, tempdir, sender, recipient(s)
  #   request=AM.PDP
  #   tempdir=/var/amavis/amavis-milter-MWZmu9Di
  #   tempdir_removed_by=client    (tempdir_removed_by=server is a default)
  #   mail_file=/var/amavis/am.../email.txt (defaults to tempdir/email.txt)
  #   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)
  #   queue_id=qid
  #   protocol_name=ESMTP
  #   helo_name=b.example.com
  #   client_address=10.2.3.4
  # Required 'release' fields are: request, mail_id
  #   request=release
  #   mail_id=xxxxxxxxxxxx
  #   secret_id=xxxxxxxxxxxx              (authorizes a release)
  #   quar_type=x                         F/Z/B/Q/M  (defaults to Q or F)
  #                                       file/zipfile/bsmtp/sql/mailbox
  #   mail_file=...  (optional: overrides automatics; $QUARANTINEDIR prepended)
  #   requested_by=<releaser@example.com> (optional: lands in Resent-From:)
  #   sender=<foo@example.com>            (optional: replaces envelope sender)
  #   recipient=<bar1@example.net>        (optional: replaces envelope recips)
  #   recipient=<bar2@example.net>
  #   recipient=<bar3@example.net>
  my($sender,@recips);
  exists $attr_ref->{'request'} or die "Missing 'request' field";
  my($ampdp) = $attr_ref->{'request'} =~ /^AM\.CL|AM\.PDP|release\z/i;
  $msginfo->delivery_method(
    lc($attr_ref->{'delivery_care_of'}) eq 'server' ? c('forward_method') :'');
  $msginfo->client_delete(lc($attr_ref->{'tempdir_removed_by'}) eq 'client'
                          ? 1 : 0);
  $msginfo->queue_id($attr_ref->{'queue_id'})
    if exists $attr_ref->{'queue_id'};
  $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'};
# $msginfo->body_type('8BITMIME');  # get_body_digest will set this if undef
  $msginfo->requested_by(unquote_rfc2821_local($attr_ref->{'requested_by'}))
    if exists $attr_ref->{'requested_by'};
  if (exists $attr_ref->{'sender'}) {
    $sender = $attr_ref->{'sender'};
    $sender = unquote_rfc2821_local($sender);
    $msginfo->sender($sender);
  }
  if (exists $attr_ref->{'recipient'}) {
    my($r) = $attr_ref->{'recipient'};
    @recips = !ref($r) ? $r : @$r;
    $_ = unquote_rfc2821_local($_)  for @recips;
    $msginfo->recips(\@recips);
  }
  if (!exists $attr_ref->{'tempdir'}) {
    $msginfo->mail_tempdir($TEMPBASE);  # defaults to $TEMPBASE
  } else {
    local($1,$2); my($tempdir) = $attr_ref->{tempdir};
    $tempdir =~ /^ (?: \Q$TEMPBASE\E | \Q$MYHOME\E )
                   \/ (?! \.{1,2} \z) [A-Za-z0-9_.-]+ \z/xso
      or die "Invalid/unexpected temporary directory name '$tempdir'";
    $msginfo->mail_tempdir(untaint($tempdir));
  }
  my($quar_type);
  if (!$ampdp) {}  # don't bother with filenames
  elsif ($attr_ref->{'request'} eq 'release') {
    exists $attr_ref->{'mail_id'} or die "Missing 'mail_id' field";
    my($fn) = $attr_ref->{'mail_id'};
    $fn =~ m{^[A-Za-z0-9][A-Za-z0-9/_.+-]*\z}s  or die "Invalid mail_id '$fn'";
    $msginfo->mail_id($fn);
    if (!exists($attr_ref->{'secret_id'}) || $attr_ref->{'secret_id'} eq '') {
      die "Secret_id is required, but missing"  if c('auth_required_release');
    } else {
      my($id) = Digest::MD5->new->add($attr_ref->{'secret_id'})->b64digest;
      $id = substr($id,0,12); $id =~ tr{/}{-};
      $id eq $fn  or die "Result $id of secret_id does not match mail_id $fn";
    }
    $quar_type = $attr_ref->{'quar_type'};
    if ($quar_type eq '')  # choose some reasonable default (simpleminded)
      { $quar_type = c('spam_quarantine_method') =~ /^sql:/i ? 'Q' : 'F' }
    if ($quar_type eq 'F' || $quar_type eq 'Z') {
      $QUARANTINEDIR ne '' or die "Config variable \$QUARANTINEDIR is empty";
      if ($attr_ref->{'mail_file'} ne '') {
        $fn = $attr_ref->{'mail_file'};
        $fn =~ m{^[A-Za-z0-9][A-Za-z0-9/_.+-]*\z}s && $fn !~ m{\.\./}
          or die "Unsafe filename '$fn'";
        $fn = $QUARANTINEDIR.'/'.untaint($fn);
      } else {  # automatically guess a filename - simpleminded
        if ($quarantine_subdir_levels < 1) { $fn = "$QUARANTINEDIR/$fn" }
        else { my($subd) = substr($fn,0,1);  $fn = "$QUARANTINEDIR/$subd/$fn" }
        $fn .= '.gz'  if $quar_type eq 'Z';
      }
    }
    $msginfo->mail_text_fn($fn);
  } elsif (!exists $attr_ref->{'mail_file'}) {
    $msginfo->mail_text_fn($msginfo->mail_tempdir . '/email.txt');
  } else {
    # SECURITY: just believe the supplied file name, blindly untainting it
    $msginfo->mail_text_fn(untaint($attr_ref->{'mail_file'}));
  }
  if ($ampdp && $msginfo->mail_text_fn ne '') {
    my($fh); my($fname) = $msginfo->mail_text_fn;
    new_am_id('rel-'.$msginfo->mail_id) if $attr_ref->{'request'} eq 'release';
    if ($attr_ref->{'request'} eq 'release' && $quar_type eq 'Q') {
      do_log(5, "preprocess_policy_query: opening in sql: %s",
                $msginfo->mail_id);
      my($obj) = $Amavis::sql_storage;
      $Amavis::extra_code_sql_quar && $obj
        or die "SQL quarantine code not enabled";
      my($conn_h) = $obj->{conn_h}; my($sql_cl_r) = cr('sql_clause');
      $conn_h->begin_work_nontransaction;  # (re)connect if not connected
      $fh = Amavis::IO::SQL->new;
      $fh->open($conn_h,$sql_cl_r->{'sel_quar'},untaint($msginfo->mail_id))
        or die "Can't open sql obj for reading: $!";
    } else {
      do_log(5, "preprocess_policy_query: opening mail '%s'", $fname);
      # set new amavis message id
      new_am_id( ($fname =~ m{amavis-(milter-)?([^/ \t]+)}s ? $2 : undef) )
        if $attr_ref->{'request'} ne 'release';
      # file created by amavis helper program or other client, just open it
      my(@stat_list) = lstat($fname); my($errn) = @stat_list ? 0 : 0+$!;
      if ($errn == ENOENT) { die "File $fname does not exist" }
      elsif ($errn) { die "File $fname inaccessible: $!" }
      elsif (!-f _) { die "File $fname is not a plain file" }
      add_entropy(@stat_list);
      if ($fname =~ /\.gz\z/) {
        $fh = Amavis::IO::Zlib->new;
        $fh->open($fname,'rb') or die "Can't open gzipped file $fname: $!";
      } else {
        $msginfo->msg_size(-s _);
        $fh = IO::File->new;
        $fh->open($fname,'<') or die "Can't open file $fname: $!";
        binmode($fh,":bytes") or die "Can't cancel :utf8 mode: $!"
          if $unicode_aware;
      }
    }
    $msginfo->mail_text($fh);  # save file handle to object
  }
  if ($ampdp) {
    do_log(1, "%s %s %s: <%s> -> %s", $attr_ref->{'request'},
              $attr_ref->{'mail_id'}, $msginfo->mail_tempdir, $sender,
              join(',', qquote_rfc2821_local(@recips)) );
  } else {
    do_log(1, "Request: %s(%s): %s %s %s: %s[%s] <%s> -> <%s>",
              @$attr_ref{qw(request protocol_state mail_id 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);
  my(%baseline_policy_bank); my($policy_changed) = 0;
  %baseline_policy_bank = %current_policy_bank;
  # 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 {
    my($cl_ip) = $msginfo->client_addr;  my($sender) = $msginfo->sender;
    if ($cl_ip ne '' && defined $policy_bank{'MYNETS'}
        && lookup_ip_acl($cl_ip,@{ca('mynetworks_maps')}) ) {
      Amavis::load_policy_bank('MYNETS'); $policy_changed = 1;
    }
    if ($sender ne '' && defined $policy_bank{'MYUSERS'}
        && lookup(0,$sender,@{ca('local_domains_maps')})) {
      Amavis::load_policy_bank('MYUSERS'); $policy_changed = 1;
    }
    debug_oneshot(1)  if lookup(0,$sender,@{ca('debug_sender_maps')});
    # check_mail() expects open file on $fh, need not be rewound
    Amavis::check_mail_begin_task();
    ($smtp_resp, $exit_code, $preserve_evidence) =
      &$check_mail($conn,$msginfo,0);
    my($fh) = $msginfo->mail_text;  my($tempdir) = $msginfo->mail_tempdir;
    $fh->close or die "Error closing 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 %s is client's responsibility", $tempdir);
    } elsif ($preserve_evidence) {
      do_log(-1,"AM.PDP: tempdir is to be PRESERVED: %s", $tempdir);
    } else {
      my($fname) = $msginfo->mail_text_fn;
      do_log(4, "AM.PDP: tempdir and file being removed: %s, %s",
                $tempdir,$fname);
      unlink($fname) or die "Can't remove file $fname: $!"  if $fname ne '';
      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
  #   delheader=index hdr_head
  #   replacebody=new_body  (not implemented)
  #   return_value=continue|reject|discard|accept|tempfail
  #   setreply=rcode xcode message
  #   exit_code=n

  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++ } }
  }
  local($1,$2,$3);
  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 || $rcpt_deletes >= $rcpt_count) {
    $exit_code = 99; # let MTA discard the message, it was already handled here
    push(@response, proto_encode('return_value','discard'));
  } elsif ($msginfo->delivery_method ne '') {  # explicit forwarding by us
    die "Not all recips done, but explicit forwarding";  # just in case
  } 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?
      local($1,$2);
      # Inserting. Not posible to specify placement of header fields in milter!
      for my $hf (map { ref $hdr_edits->{$_} ? @{$hdr_edits->{$_}} : () }
                      qw(prepend addrcvd add 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
        } else {                 # edit the first occurrence
          chomp($field_body);
          for my $e (@$edit) {   # possibly multiple (iterative) edits
            if (!defined($e)) {  # delete existing header field
              push(@response, proto_encode('delheader',"1",$field_name));
              last;
            }
            my($curr_head) = hdr($field_name, &$e($field_name,$field_body), 0);
            $curr_head =~ /^([^:]+):[ \t]*(.*)\z/s;
            $field_body = $2; chomp($field_body);
            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(-1, "WARN: MTA can't do: %s", $_) }
      if ($rcpt_deletes && $rcpt_count-$rcpt_deletes > 0) {
        do_log(-1, "WARN: ACCEPT THE WHOLE MESSAGE, ".
                   "MTA-in can't do selective recips deletion");
      }
    }
    push(@response, proto_encode('return_value','continue'));
  }
  push(@response, proto_encode('exit_code',sprintf("%d",$exit_code)));
  ll(2) && do_log(2, "mail checking ended: %s", join("\n",@response));
  if ($policy_changed) {
    %current_policy_bank = %baseline_policy_bank; $policy_changed = 0;
  }
  @response;
}

sub postfix_policy($$$) {
  my($conn,$msginfo,$attr_ref) = @_;
  my(@response);
  if ($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) = @_; local($1);
  $attribute_name =~    # encode all but alfanumerics, '_' and '-'
    s/([^0-9a-zA-Z_-])/sprintf("%%%02x",ord($1))/eg;
  for (@strings) {      # encode % and nonprintables
    s/([^\041-\044\046-\176])/sprintf("%%%02x",ord($1))/eg;
  }
  $attribute_name . '=' . join(' ',@strings);
}

sub dispatch_from_quarantine($$) {
  my($conn,$msginfo) = @_;
  eval {
    msg_from_quarantine($conn,$msginfo);  # fill message object information
    mail_dispatch($conn,$msginfo,0,1);    # re-send the mail
  };
  my($err) = $@; chomp($err);
  if ($@ ne '') { do_log(0, "WARN: dispatch_from_quarantine failed: %s",$err) }
  my(@response);
  for my $r (@{$msginfo->per_recip_data}) {
    local($1,$2,$3); my($smtp_s,$smtp_es,$msg);
    my($resp) = $r->recip_smtp_response;
    if ($err ne '')
      { ($smtp_s,$smtp_es,$msg) = ('450', '4.5.0', "ERROR: $err") }
    elsif ($resp =~ /^([1-5]\d\d) ([245]\.\d{1,3}\.\d{1,3})(?: |\z)(.*)\z/s)
      { ($smtp_s,$smtp_es,$msg) = ($1,$2,$3) }
    else
      { ($smtp_s,$smtp_es,$msg) = ('450', '4.5.0', "Unexpected: $resp") }
    push(@response, proto_encode('setreply',$smtp_s,$smtp_es,$msg));
  }
  @response;
}

1;

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

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
}
use Errno qw(ENOENT EACCES);
use MIME::Base64;

BEGIN {
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll do_log am_id new_am_id snmp_counters_init
                         xtext_encode xtext_decode prolong_timer debug_oneshot
                         sanitize_str rmdir_recursively add_entropy);
  import Amavis::Lookup qw(lookup);
  import Amavis::Lookup::IP qw(lookup_ip_acl);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::TempDir;
  import Amavis::In::Message;
  import Amavis::In::Connection;
}

sub new($) {
  my($class) = @_;
  my($self) = bless {}, $class;
  $self->{sock} = undef;              # SMTP socket
  $self->{proto} = undef;             # SMTP / ((ESMTP / LMTP) (A | S | SA)? )
  $self->{pipelining}  = undef;       # may we buffer responses?
  $self->{smtp_outbuf} = undef;       # SMTP responses buffer for PIPELINING
  $self->{session_closed_normally} = undef; # closed properly with QUIT
  $self->{tempdir} = Amavis::TempDir->new; # TempDir object
  $self->{waiting_for_client} = undef;  # which timeout is running:
                                        # false: processing is in our courtyard
                                        # true:  waiting for a client
  $self;
}

sub DESTROY {
  my($self) = shift;
  eval { do_log(5,"Amavis::In::SMTP DESTROY called, sock=%s, normal=%s",
                  $self->{sock}, $self->{session_closed_normally}) };
  eval {
    if (ref($self->{sock}) && ! $self->{session_closed_normally}) {
      my($msg) = "421 4.3.2 Service shutting down, closing channel";
      $msg .= ", during waiting for input from client"
        if $self->{waiting_for_client};
      $self->smtp_resp(1,$msg);
    }
  };
  if ($@ ne '')
    { my($eval_stat) = $@; eval { do_log(1,"SMTP shutdown: %s",$eval_stat) } }
}

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 transactions)
# 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
  $self->{session_closed_normally} = 0;  # closed properly with QUIT?
  $self->{waiting_for_client} = 0;  # processing is in our courtyard

  my($myheloname);
# $myheloname = c('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($max_recip_size_limit);  # maximum of per-recipient message size limits
  my($terminating,$aborting,$eof,$voluntary_exit); my($seq) = 0;
  my(%xforward_args); my(%baseline_policy_bank); my($policy_changed);
  %baseline_policy_bank = %current_policy_bank; $policy_changed = 0;
  $conn->smtp_proto($self->{proto} = $lmtp ? 'LMTP' : 'SMTP');

  # system-wide message size limit, if any
  my($message_size_limit) = c('smtpd_message_size_limit');
  if ($message_size_limit && $message_size_limit < 65536)
    { $message_size_limit = 65536 }   # rfc2821 requires at least 64k
  my($smtpd_greeting_banner_tmp) = c('smtpd_greeting_banner');
  $smtpd_greeting_banner_tmp =~
    s{ \$ (?: \{ ([^\}]+) \} |
              ([a-zA-Z](?:[a-zA-Z0-9_-]*[a-zA-Z0-9])?\b) ) }
     { { 'helo-name'    => $myheloname,
         'myhostname'   => c('myhostname'),
         'version'      => $myversion,
         'version-id'   => $myversion_id,
         'version-date' => $myversion_date,
         'product'      => $myproduct_name,
         'protocol'     => $lmtp?'LMTP':'ESMTP' }->{lc($1.$2)}
     }egx;
  $self->smtp_resp(1, "220 $smtpd_greeting_banner_tmp");
  # each call to smtp_resp starts a $smtpd_timeout timeout to tame slow clients

  $0 = sprintf("amavisd (ch%d-idle)", $Amavis::child_invocation_count);
  Amavis::Timing::go_idle(4);
  local($_);  local($/) = "\012";  # input line terminator set to LF
  for ($! = 0; defined($_=<$sock>); $! = 0) {
    $0 = sprintf("amavisd (ch%d-%s)",
                 $Amavis::child_invocation_count, am_id());
    Amavis::Timing::go_busy(5);
    # the ball is now in our courtyard, start a $child_timeout timer;
    # each of our smtp responses will switch back to a $smtpd_timeout timer
    { # a block is used as a 'switch' statement - 'last' will exit from it
      my($cmd) = $_;
      do_log(4, "%s< %s", $self->{proto},$cmd);
      !/^ [ \t]* ([A-Za-z]+) (?: [ \t]+ (.*?) )? [ \t]* \015\012 \z/xs && do {
        $self->smtp_resp(1,"500 5.5.2 Error: bad syntax", 1, $cmd); last;
      };
      $_ = uc($1); my($args) = $2;
      $self->switch_to_my_time("SMTP $_ received");

# (causes holdups in Postfix, it doesn't retry immediately; better set max_use)
#     $Amavis::child_task_count >= $max_requests    # exceeded max_requests
#     && /^(?:HELO|EHLO|LHLO|DATA|NOOP)\z/ && do {  # pipelining checkpoints
#       # in case of multiple-transaction protocols (e.g. SMTP, LMTP)
#       # we do not like to keep running indefinitely at the MTA's mercy
#       my($msg) = "Closing transmission channel ".
#                  "after $Amavis::child_task_count transactions, $_";
#       do_log(2,"%s",$msg); $self->smtp_resp(1,"421 4.3.0 ".$msg);
#       $terminating=1; last;
#     };
      /^(?: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;
                        $max_recip_size_limit = undef; $msginfo = undef;
                        if ($policy_changed) {
                          %current_policy_bank = %baseline_policy_bank;
                          $policy_changed = 0;
                        }
                        $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) = c('smtpd_quit_banner');
        $smtpd_quit_banner_tmp =~
          s{ \$ (?: \{ ([^\}]+) \} |
                    ([a-zA-Z](?:[a-zA-Z0-9_-]*[a-zA-Z0-9])?\b) ) }
           { { 'helo-name'    => $myheloname,
               'myhostname'   => c('myhostname'),
               'version'      => $myversion,
               'version-id'   => $myversion_id,
               'version-date' => $myversion_date,
               'product'      => $myproduct_name,
               '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
        $max_recip_size_limit = undef; $msginfo = undef;  # forget previous
        if ($policy_changed)
          { %current_policy_bank = %baseline_policy_bank; $policy_changed = 0 }
        $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|LHLO)\z/ && do {
        $sender = undef; @recips = (); $got_rcpt = 0;     # implies RSET
        $max_recip_size_limit = undef; $msginfo = undef;  # forget previous
        if ($policy_changed)
          { %current_policy_bank = %baseline_policy_bank; $policy_changed = 0 }
        $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",
          'VRFY',
          'PIPELINING',           # rfc2920
          !defined($message_size_limit) ? 'SIZE'  # rfc1870
            : sprintf('SIZE %d',$message_size_limit),
          'ENHANCEDSTATUSCODES',  # rfc2034, rfc3463
          '8BITMIME',             # rfc1652
          'DSN',                  # rfc3461
          !@{ca('auth_mech_avail')} ? ()   # rfc2554
                                   : join(' ','AUTH',@{ca('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-\176]{0,255} )\z/xs) {
            $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/) {
              $val = undef  if uc($val) eq '[UNAVAILABLE]';
              $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/ && @{ca('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} @{ca('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 %s, user=%s", $auth_mech,$auth_user);
              # do_log(2,"AUTH %s, user=%s, pass=%s",
              #          $auth_mech,$auth_user,$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,''));
            $! = 0; $auth_resp = <$sock>;
            defined $auth_resp || $!==0  or die "Error reading auth resp: $!";
            $self->switch_to_my_time('AUTH challenge reply received');
            do_log(5, "%s< %s", $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 {
        if ($args eq '') {
          $self->smtp_resp(1,"501 5.5.2 Syntax: VRFY address", 1, $cmd);
        } else {  # rfc2505
          $self->smtp_resp(1,"252 2.0.0 Argument not checked", 0, $cmd);
        }
        last;
      };
      /^MAIL\z/ && do {  # begin new SMTP transaction
        if (defined($sender)) {
          $self->smtp_resp(0,"503 5.5.1 Error: nested MAIL command", 1, $cmd);
          last;
        }
        if (!$authenticated &&
            c('auth_required_inp') && @{ca('auth_mech_avail')} ) {
          $self->smtp_resp(0,"530 5.7.1 Authentication required", 1, $cmd);
          last;
        }
        # begin SMTP transaction
        my($now) = time;
        if (!$seq) { # the first connect
          section_time('SMTP pre-MAIL');
        } else {     # establish new time reference for each transaction
          Amavis::Timing::init(); snmp_counters_init();
        }
        $seq++;
        new_am_id(undef,$Amavis::child_invocation_count,$seq)
          if !$initial_am_id;
        $initial_am_id = 0;
        Amavis::check_mail_begin_task();
        $self->{tempdir}->prepare;
        $self->{tempdir}->prepare_file;
        my($cl_ip) = $xforward_args{'ADDR'};
        if ($cl_ip ne '' && defined $policy_bank{'MYNETS'}
            && lookup_ip_acl($cl_ip,@{ca('mynetworks_maps')}) ) {
          Amavis::load_policy_bank('MYNETS'); $policy_changed = 1;
        }
        $msginfo = Amavis::In::Message->new;
        $msginfo->rx_time($now);
      # $msginfo->body_type('7bit');  # presumed, unless explicitly declared
        $msginfo->delivery_method(c('forward_method'));
        my($submitter);
        if ($authenticated) {
          $msginfo->auth_user($auth_user); $msginfo->auth_pass($auth_pass);
          $conn->smtp_proto($self->{proto}.'A')  # rfc3848
            if $self->{proto} =~ /^(LMTP|ESMTP)\z/i;
        } elsif (c('auth_reauthenticate_forwarded') &&
                 c('amavis_auth_user') ne '') {
          $msginfo->auth_user(c('amavis_auth_user'));
          $msginfo->auth_pass(c('amavis_auth_pass'));
          $submitter = quote_rfc2821_local(c('mailfrom_notify_recip'));
        }
        $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 transaction
        if ($args !~ /^FROM: [ \t]*
                      ( < (?: " (?: \\. | [^\\"] )* " | [^"@ \t] )*
                          (?: @ (?: \[ (?: \\. | [^\]\\] )* \] |
                                    [^\[\]\\> \t] )* )? > )
                      (?: [ \t]+ (.+) )? \z/isx ) {
          $self->smtp_resp(0,"501 5.5.2 Syntax: MAIL FROM: <address>",1,$cmd);
          last;
        }
        my($addr,$opt) = ($1,$2);  my($msg);  my($size,$dsn_ret,$dsn_envid);
        for (split(' ',$opt)) {
          if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]*  ) =
                  ( [\041-\074\076-\176]+ ) \z/xs) { # printable, not '=' or SP
            $msg = "501 5.5.4 Syntax error in MAIL FROM parameters";
          } else {
            my($name,$val) = (uc($1),$2);
            if ($name eq 'SIZE' && $val=~/^\d{1,20}\z/) {  # rfc1870
              if (!defined($size)) { $size = $val }
              else { $msg = "501 5.5.4 Syntax error in MAIL parameter: $name" }
            } elsif ($name eq 'BODY' && $val=~/^(?:7BIT|8BITMIME)\z/i) {
              $msginfo->body_type(uc($val));
            } elsif ($name eq 'RET') {    # rfc3461
              if (!defined($dsn_ret)) { $dsn_ret = uc($val) }
              else { $msg = "501 5.5.4 Syntax error in MAIL parameter: $name" }
            } elsif ($name eq 'ENVID') {  # rfc3461, value encoded as xtext
              if (!defined($dsn_envid)) { $dsn_envid = $val }
              else { $msg = "501 5.5.4 Syntax error in MAIL parameter: $name" }
            } elsif ($name eq 'AUTH' && @{ca('auth_mech_avail')} &&
                     !defined($submitter) ) {  # rfc2554
              $submitter = xtext_decode($val); # encoded as xtext: rfc3461
              do_log(5, "MAIL command, %s, submitter: %s",
                        $authenticated,$submitter);
            } elsif ($name eq 'AUTH' && !@{ca('auth_mech_avail')}) {
              $msg = "503 5.7.4 Error: authentication disabled";
            } else {
              $msg = "504 5.5.4 MAIL command parameter error: $name=$val";
            }
          }
          last  if defined $msg;
        }
        if (!defined($msg) && defined $dsn_ret && $dsn_ret!~/^(FULL|HDRS)\z/) {
          $msg = "501 5.5.4 Syntax error in MAIL parameter RET: $dsn_ret";
        }
        if (!defined($msg) && defined $size) {
          if ($message_size_limit && $size > $message_size_limit) {
            $msg = "552 5.3.4 Declared message size ($size B) ".
                   "exceeds fixed size limit";
            do_log(0, "%s REJECT 'MAIL FROM': %s", $self->{proto},$msg);
          }
        }
        if (!defined($msg)) {
          $addr = $1  if $addr =~ /^<(.*)>\z/s;
          $sender = unquote_rfc2821_local($addr);
          my($requoted) = qquote_rfc2821_local($sender);
          do_log(0, "WARN: address modified (sender): <%s> -> %s",
                    $addr, $requoted)  if $requoted ne "<$addr>";
          if ($sender ne '' && defined $policy_bank{'MYUSERS'}
              && lookup(0,$sender,@{ca('local_domains_maps')})) {
            Amavis::load_policy_bank('MYUSERS'); $policy_changed = 1;
          }
          debug_oneshot(lookup(0,$sender,@{ca('debug_sender_maps')}) ? 1 : 0,
                        $self->{proto} . "< $cmd");
        # $submitter = $addr  if !defined($submitter);  # rfc2554: MAY
          $submitter = '<>'   if !defined($msginfo->auth_user);
          $msginfo->auth_submitter($submitter);
          $msginfo->msg_size(0+$size)  if defined $size;
          if (defined $dsn_ret || defined $dsn_envid) {
            # keep ENVID in xtext-encoded form
            $msginfo->dsn_ret($dsn_ret)      if defined $dsn_ret;
            $msginfo->dsn_envid($dsn_envid)  if defined $dsn_envid;
          }
          $msg = "250 2.1.0 Sender $addr OK";
        };
        $self->smtp_resp(0, $msg,
                         ($msg=~/^5/ && $msg!~/^552 5\.3\.4\b/ ? 1 : 0), $cmd);
        last;
      };
      /^RCPT\z/ && do {
        if (!defined($sender)) {
          $self->smtp_resp(0,"503 5.5.1 Need MAIL command before RCPT",1,$cmd);
          @recips = (); $got_rcpt = 0;
          last;
        }
        $got_rcpt++;
        if ($args !~ /^TO: [ \t]*
                      ( < (?: " (?: \\. | [^\\"] )* " | [^"@ \t] )*
                          (?: @ (?: \[ (?: \\. | [^\]\\] )* \] |
                                    [^\[\]\\> \t] )* )? > )
                      (?: [ \t]+ (.+) )? \z/isx ) {
          $self->smtp_resp(0,"501 5.5.2 Syntax: RCPT TO: <address>",1,$cmd);
          last;
        }
        my($addr,$opt) = ($1,$2);  my($msg);  my($notify,$orcpt);
        for (split(' ',$opt)) {
          if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]*  ) =
                  ( [\041-\074\076-\176]+ ) \z/xs) { # printable, not '=' or SP
            $msg = "501 5.5.4 Syntax error in RCPT parameters";
          } else {
            my($name,$val) = (uc($1),$2);
            if ($name eq 'NOTIFY') {  # rfc3461
              if (!defined($notify)) { $notify = $val }
              else { $msg = "501 5.5.4 Syntax error in RCPT parameter $name" }
            } elsif ($name eq 'ORCPT') {  # rfc3461, value encoded as xtext
              if (!defined($orcpt)) { $orcpt = $val }
              else { $msg = "501 5.5.4 Syntax error in RCPT parameter $name" }
            } else {
              $msg = "555 5.5.4 RCPT command parameter unrecognized: $name";
              # 504 5.5.4 RCPT command parameter not implemented:
              # 504 5.5.4 RCPT command parameter error:
              # 555 5.5.4 RCPT command parameter unrecognized:
            }
          }
          last  if defined $msg;
        }
        $addr = $1  if $addr =~ /^<(.*)>\z/s;
        my($addr_unq) = unquote_rfc2821_local($addr);
        my($requoted) = qquote_rfc2821_local($addr_unq);
        if ($requoted ne "<$addr>") {  # check for valid canonical quoting
          do_log(0, "WARN: address modified (recip): <%s> -> %s",
                    $addr, $requoted);
          # rfc3461: If no ORCPT parameter was present in the RCPT command when
          # the message was received, an ORCPT parameter MAY be added to the
          # RCPT command when the message is relayed. If an ORCPT parameter is
          # added by the relaying MTA, it MUST contain the recipient address
          #from the RCPT command used when the message was received by that MTA
          $orcpt = 'rfc822;'.xtext_encode($addr)  if !defined($orcpt);
        }
        my($recip_size_limit); my($mslm) = ca('message_size_limit_maps');
        $recip_size_limit = lookup(0,$addr_unq, @$mslm)  if @$mslm;
        if ($recip_size_limit && $recip_size_limit < 65536)
          { $recip_size_limit = 65536 }  # rfc2821 requires at least 64k
        if ($recip_size_limit > $max_recip_size_limit)
          { $max_recip_size_limit = $recip_size_limit }
        my($mail_size) = $msginfo->msg_size;
        if (!defined($msg) && defined($notify)) {
          my(@v) = split(/,/,uc($notify),-1);
          if (grep {!/^(NEVER|SUCCESS|FAILURE|DELAY)\z/} @v) {
            $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ".
                   "illegal value: $notify";
          } elsif (@v > 1 && grep {$_ eq 'NEVER'} @v) {
            $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ".
                   "illegal combination of values: $notify";
          } elsif (!@v) {
            $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ".
                   "missing value: $notify";
          }
          $notify = \@v;  # replace a string with a listref of items
        }
        if (!defined($msg) && defined($mail_size) && $recip_size_limit &&
            $mail_size > $recip_size_limit) {
          $msg = "552 5.3.4 Declared message size ($mail_size B) ".
                 "exceeds recipient's size limit <$addr>";
          do_log(0, "%s REJECT 'RCPT TO': %s", $self->{proto},$msg);
        }
        if (!defined($msg) && $got_rcpt > $smtpd_recipient_limit) {
          $msg = "452 4.5.3 Too many recipients";
        }
        if (!defined($msg)) {
          my($recip_obj) = Amavis::In::Message::PerRecip->new;
          $recip_obj->recip_addr($addr_unq);
          $recip_obj->recip_destiny(D_PASS);  # default is Pass
          $recip_obj->dsn_notify($notify)  if defined $notify;
          $recip_obj->dsn_orcpt($orcpt)    if defined $orcpt;
          push(@recips,$recip_obj);
          $msg = "250 2.1.5 Recipient $addr OK";
        }
        $self->smtp_resp(0, $msg, $msg=~/^5/ ? 1 : 0, $cmd);
        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",0,$cmd);
        } else {
          $self->smtp_resp(1,"554 5.1.1 Error (DATA): no valid recipients",0,$cmd);
        }
        last;
      };
      /^DATA\z/ && do {
        # set timer to the initial value, MTA timer starts here
        if ($message_size_limit) {  # enforce system-wide size limit
          if (!$max_recip_size_limit ||
              $max_recip_size_limit > $message_size_limit) {
            $max_recip_size_limit = $message_size_limit;
          }
        }
        my($within_data_transfer,$complete);
        my($size) = 0; my($over_size) = 0;
        eval {
          $msginfo->sender($sender); $msginfo->per_recip_data(\@recips);
          ll(1) && do_log(1, "%s:%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}->path,
            $sender, join(',',qquote_rfc2821_local(@{$msginfo->recips})),
            join('',
              !defined $msginfo->msg_size  ? () : ' SIZE='.$msginfo->msg_size,
              !defined $msginfo->body_type ? () : ' BODY='.$msginfo->body_type,
              !defined $msginfo->auth_submitter ||
                       $msginfo->auth_submitter eq '<>' ? ():
                                   ' AUTH='.$msginfo->auth_submitter,
              !defined $msginfo->dsn_ret   ? () : ' RET='.$msginfo->dsn_ret,
              !defined $msginfo->dsn_envid ? () :
                                   ' ENVID='.xtext_decode($msginfo->dsn_envid),
            ),
            received_line($conn,$msginfo,undef,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);
          $self->switch_to_client_time('receiving data');
          if ($max_recip_size_limit == 0) {  # no message size limit enforced
            my($ln);  local($/) = "\015\012";  # input line terminator CRLF
            for ($! = 0; defined($ln=<$sock>); $! = 0) {  # optimized for speed
              alarm($smtpd_timeout);  # as fast as:  last if time>$tmax;
              if ($ln =~ /^\./) {
                if ($ln eq ".\015\012")
                  { $complete = 1; $within_data_transfer = 0; last }
                $ln =~ s/^\.(.+\015\012)\z/$1/s;   # dot de-stuffing, rfc2821
              }
              $size += length($ln);  # message size is defined in rfc1870
              # remove \015\012: s/// slowest, chomp faster, substr(,0,-2) best
              print {$self->{tempdir}->fh} substr($ln,0,-2),$eol
                or die "Can't write to mail file: $!";
            }
            defined $ln || $!==0  or die "Connection broken during DATA: $!";
          } else {  # enforce size limit
            do_log(5,"enforcing size limit %s during DATA",
                     $max_recip_size_limit);
            my($ln);  local($/) = "\015\012";  # input line terminator CRLF
            for ($! = 0; defined($ln=<$sock>); $! = 0) {
              alarm($smtpd_timeout);  # as fast as:  last if time>$tmax;
            # do_log(5, "%s< %s", $self->{proto},$ln);
              if ($ln =~ /^\./) {
                if ($ln eq ".\015\012")
                  { $complete = 1; $within_data_transfer = 0; last }
                $ln =~ s/^\.(.+\015\012)\z/$1/s;   # dot de-stuffing, rfc2821
              }
              $size += length($ln);  # message size is defined in rfc1870
              if (!$over_size) {
                print {$self->{tempdir}->fh} substr($ln,0,-2),$eol
                  or die "Can't write to mail file: $!";
                if ($max_recip_size_limit && $size > $max_recip_size_limit) {
                  do_log(1,"Message size exceeded %d B, skiping further input",
                           $max_recip_size_limit);
                  print {$self->{tempdir}->fh} $eol,"***TRUNCATED***",$eol
                    or die "Can't write to mail file: $!";
                  $over_size = 1;
                }
              }
            }
            defined $ln || $!==0  or die "Connection broken during DATA: $!";
          }; # restores line terminator
          $self->switch_to_my_time('data-end received');
          $eof = 1  if !$complete;
          # normal data termination, eof on socket, timeout, fatal error
          do_log(4, "%s< .<CR><LF>", $self->{proto})  if $complete;
          $self->{tempdir}->fh->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->{tempdir}->fh->seek(0,1) or die "Can't seek on file: $!";
          section_time('SMTP DATA');
        };  # end eval
        if ($@ ne '' || !$complete || $over_size) {  # err or connection broken
          chomp($@);
          # on error, either send: '421 Shutting down',
          # or: '451 Aborted, error in processing' and NOT shut down!
          if ($over_size && $@ eq '' && !$within_data_transfer) {
            my($msg) = "552 5.3.4 Message size ($size B) exceeds size limit";
            do_log(0, "%s REJECT: %s", $self->{proto},$msg);
            $self->smtp_resp(0,$msg, 0,$cmd);
          } elsif (!$within_data_transfer) {
            my($msg) = "Error in processing: " .
                       !$complete && $@ eq '' ? 'incomplete' : $@;
            do_log(-2, "%s TROUBLE: 451 4.5.0 %s", $self->{proto},$msg);
            $self->smtp_resp(1, "451 4.5.0 $msg");
        ### $aborting = $msg;
          } else {
            $aborting = "Connection broken during data transfer"  if $eof;
            $aborting .= ', '  if $aborting ne '' && $@ ne '';
            $aborting .= $@;
            $aborting .= " during waiting for input from client"
              if $@ eq 'timed out' && $self->{waiting_for_client};
            $aborting = '???'  if $aborting eq '';
            do_log($@ ne '' ? -1 : 3,
                   "%s ABORTING: %s", $self->{proto},$aborting);
          }
        } else {  # all OK
          # According to rfc1047 it is not a good idea to do lengthy processing
          # here, 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->{tempdir}->fh,
          # need not be rewound
          $msginfo->mail_tempdir($self->{tempdir}->path);
          $msginfo->mail_text_fn($self->{tempdir}->path . '/email.txt');
          $msginfo->mail_text($self->{tempdir}->fh);
          my($declared_size) = $msginfo->msg_size;
          if (!defined($declared_size)) {
          } elsif ($size > $declared_size) { # shouldn't happen with decent MTA
            do_log(2,"Actual message size %s B greater than the ".
                     "declared %s B", $size,$declared_size);
          } elsif ($size < $declared_size) { # not unusual, but permitted
            do_log(4,"Actual message size %d B, declared %d B",
                     $size,$declared_size);
          }
          $msginfo->msg_size($size);  # store actual mail size
          my($smtp_resp, $exit_code, $preserve_evidence) =
            &$check_mail($conn,$msginfo,$lmtp);
          prolong_timer('check done');
          if ($preserve_evidence) { $self->{tempdir}->preserve(1) }
          if ($smtp_resp !~ /^4/ &&
              grep { !$_->recip_done } @{$msginfo->per_recip_data}) {
            if ($msginfo->delivery_method eq '') {
              do_log(2,"not all recipients done, forward_method is empty");
            } else {
              die "TROUBLE: (MISCONFIG) not all recipients done, " .
                  "forward_method is: " . $msginfo->delivery_method;
            }
          }
          if (!$lmtp) {  # smtp
            do_log(4, 'sending SMTP response: "%s"', $smtp_resp);
            $self->smtp_resp(0, $smtp_resp);
          } else {       # lmtp
            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 %s, DSN %s (%s)",
                        $r->recip_addr, $bounced==1 ? 'sent' : 'muted', $resp);
              }
              do_log(4, 'sending LMTP response for <%s>: "%s"',
                        $r->recip_addr, $resp);
              $self->smtp_resp(0, $resp);
            }
          }
        };
        $self->{tempdir}->clean;
        $sender = undef; @recips = (); $got_rcpt = 0;     # implicit RSET
        $max_recip_size_limit = undef; $msginfo = undef;  # forget previous
        if ($policy_changed)
          { %current_policy_bank = %baseline_policy_bank; $policy_changed = 0 }
        # report elapsed times by section for each transaction
        # (the time for the QUIT remains unaccounted for)
        do_log(2, "%s", Amavis::Timing::report());
        Amavis::Timing::init(); snmp_counters_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.
    $self->smtp_resp_flush;
    $0 = sprintf("amavisd (ch%d-%s-idle)",
                 $Amavis::child_invocation_count, am_id());
    Amavis::Timing::go_idle(6);
  } # end of loop
  my($errn,$errs);
  if (!$voluntary_exit) {
    $eof = 1;
    if (!defined($_)) { $errn = 0+$!; $errs = "$!" }
  }
  # come here when: QUIT is received, eof or err on socket, or we need to abort
  $0 = sprintf("amavisd (ch%d)", $Amavis::child_invocation_count);
  alarm(0); do_log(4,"SMTP session over, timer stopped");
  Amavis::Timing::go_busy(7);
  # flush just in case, session might have been disconnected
  eval { $self->smtp_resp_flush };
  do_log(1, "flush failed: %s", $@)  if $@ ne '';
  my($msg) =
    defined $aborting && !$eof ? "ABORTING the session: $aborting" :
    defined $aborting ? $aborting :
    !$terminating ? "client broke the connection without a QUIT ($errs)" : '';
  do_log($aborting?-1:3, "%s: NOTICE: %s", $self->{proto},$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;
  # Net::Server 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(-1, "%s: %s; PENALIZE: %s", $self->{proto},$resp,$line);
    sleep 5;
    section_time('SMTP penalty wait');
  }
  push(@{$self->{smtp_outbuf}}, @{wrap_smtp_resp(sanitize_str($resp,1))});
  $self->smtp_resp_flush   if $flush || !$self->{pipelining} ||
                              @{$self->{smtp_outbuf}} > 200;
}

sub smtp_resp_flush($) {
  my($self) = shift;
  if (ref($self->{smtp_outbuf}) && @{$self->{smtp_outbuf}}) {
    if (ll(4)) {
      for my $resp (@{$self->{smtp_outbuf}})
        { do_log(4, "%s> %s", $self->{proto},$resp) };
    }
    my($stat) =
      $self->{sock}->print(map { $_."\015\012" } @{$self->{smtp_outbuf}} );
    @{$self->{smtp_outbuf}} = ();  # prevent printing again even if error
    $stat or die "Error writing a SMTP response to the socket: $!";
    # put a ball in client's courtyard, start his timer
    $self->switch_to_client_time('smtp response sent');
  }
}

sub switch_to_my_time($$) {
  my($self,$msg) = @_;
  prolong_timer($msg, $child_timeout);
  $self->{waiting_for_client} = 0;  # processing is in our courtyard
}

sub switch_to_client_time($$) {
  my($self,$msg) = @_;
  prolong_timer($msg, $smtpd_timeout);
  $self->{waiting_for_client} = 1;  # processing is now in client's hands
}

1;

__DATA__
#
package Amavis::In::Courier;
use strict;
use re 'taint';
no warnings 'uninitialized';

BEGIN { die "Code not available for module Amavis::In::Courier" }

1;

__DATA__
#
package Amavis::Out::SMTP;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

use IO::Wrap;
use Net::Cmd;
use Net::SMTP 2.24;
# use Authen::SASL;
BEGIN {
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Util qw(untaint min max ll do_log debug_oneshot snmp_count
                         xtext_encode xtext_decode am_id prolong_timer);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Out::EditHeader;
}

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


# simple OO wrapper around Net::SMTP::datasend to provide a method 'print'
# and to buffer data, avoiding a bottleneck in Net::Cmd::datasend
#
sub new_smtp_data {
  my($class, $handle) = @_;
  bless { handle => $handle, buff => '' }, $class;
}

sub close { my($self) = shift; $self->flush }

sub print {
  my($self) = shift;  $self->{buff} .= join('',@_);
  $self->flush  if length($self->{buff}) >= 16384;
  1;
}

sub flush {
  my($self) = shift;
  if ($self->{buff} ne '') {
    $self->{handle}->datasend($self->{buff})
      or die "datasend timed out while sending buffered data\n";
    $self->{buff} = '';
  }
  1;
}


# 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,$dsn_per_recip_capable,$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(-2, "TROUBLE: Number of recipients (%d) not reduced in SMTP ".
                 "transaction, abandoning effort", $num_recips_undone_after);
      last;
    }
    if ($num_recips_undone_after > 0) {
      do_log(1, "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,$dsn_per_recip_capable,$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($mta_id) = sprintf("[%s]:%s", $relayhost, $relayhost_port);
  my($btype) = $msginfo->body_type;
  if (!defined $btype || uc($btype) eq '7BIT') { $btype = '' }
  my($dsn_envid) = $msginfo->dsn_envid; my($dsn_ret) = $msginfo->dsn_ret;
  my($logmsg) = sprintf("%s via SMTP: %s", ($initial_submission?'SEND':'FWD'),
                        qquote_rfc2821_local($msginfo->sender) );
  my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) }
                             @{$msginfo->per_recip_data};
  if (!@per_recip_data) { do_log(5, "%s, nothing to do", $logmsg); return 1 }
  ll(4) && do_log(4, "(about to connect to %s) %s -> %s", $mta_id, $logmsg,
                     join(',', qquote_rfc2821_local(
                               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($dsn_capable) = 0; my($eightbitmime_capable) = 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 server.
    # 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
    my($localaddr) = c('local_client_bind_address');  # IP assigned to socket
    my($heloname)  = c('localhost_name');       # host name used in HELO/EHLO
    $! = 0; $@ = undef;  # seems like Net::SMTP puts its error status in $@
    $smtp_handle = Net::SMTP->new($relayhost, Port => $relayhost_port,
      ($localaddr eq '' ? () : (LocalAddr => $localaddr)),
      ($heloname  eq '' ? () : (Hello     => $heloname)),
      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(),
    );
    defined($smtp_handle)  # don't change die text, it is referred to later
      or die "Can't connect to $relayhost port $relayhost_port, $@ ($!)";
    $dsn_capable = c('propagate_dsn_if_possible') &&
                 defined($smtp_handle->supports('DSN'));  # undocumented method
    my($net_smtp_supports_orcpt) = Net::SMTP->VERSION > 2.29;
    my($net_smtp_supports_envid) = $net_smtp_supports_orcpt;
    my($net_smtp_supports_auth)  = $net_smtp_supports_orcpt;
    $eightbitmime_capable =
      defined($smtp_handle->supports('8BITMIME'));   # rfc1652
    ll(5) && do_log(5,"Remote host presents itself as: %s%s, %sORCPT",
                   $smtp_handle->domain, $dsn_capable ? ', handles DSN' : '',
                   $net_smtp_supports_orcpt ? '' : 'no ');
    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')) {
      my($cmd) = join(' ', 'XFORWARD', map
        { my($n,$v) = @$_;
          # may encode value as xtext/rfc3461 in future attributes:
          # char between "!" (33) and "~" (126) inclusive, except "+" and "="
          # $v = xtext_encode($v);
          # Wietse says not to xtext-encode these four attrs, just neuter them
          $v =~ s/[^\041-\176]/?/g;
          $v =~ s/[<>()\\";@]/?/g;  # other chars that are special in headers
                   # postfix/smtpd/smtpd.c NEUTER_CHARACTERS (but ':' for IPv6)
          $v = substr($v,0,255)  if length($v) > 255;  # see XFORWARD_README
          $v eq '' ? () : ("$n=$v") }
        ( ['ADDR', $msginfo->client_addr], ['NAME',$msginfo->client_name],
          ['PROTO',$msginfo->client_proto],['HELO',$msginfo->client_helo] ));
      do_log(5, "sending %s", $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 (!c('auth_required_out')) {
      do_log(3,"AUTH not needed, user='%s', MTA offers '%s'",
               $auth_user,$mechanisms);
    } elsif ($mechanisms eq '') {
      do_log(3,"INFO: MTA does not offer AUTH capability, user='%s'",
               $auth_user);
    } elsif (!defined $auth_user) {
      do_log(0,"INFO: AUTH needed for submission but AUTH data not available");
    } else {
      do_log(3,"INFO: authenticating %s, server supports AUTH %s",
               $auth_user,$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';
    if ($initial_submission && $dsn_capable && !defined($dsn_envid)) {
      # ENVID identifies transaction, not a message
      $dsn_envid = xtext_encode(sprintf("AM.%s.%s@%s",
        $msginfo->mail_id, iso8601_utc_timestamp(time), c('myhostname')));
    }
    my($submitter) = $msginfo->auth_submitter;
    $smtp_handle->mail(qquote_rfc2821_local($msginfo->sender),
      $eightbitmime_capable && uc($btype) eq '8BITMIME' ? (Bits => '8') : (),
      $dsn_capable && defined $dsn_ret   ? (Return => $dsn_ret) : (),
      $dsn_capable && defined $dsn_envid ?  # Net::SMTP expects non-encoded
                     ( $net_smtp_supports_envid ? (ENVID => $dsn_envid)
                               : (Envelope => xtext_decode($dsn_envid)) ) : (),
      $net_smtp_supports_auth && $mechanisms ne '' &&
        defined($submitter) && $submitter ne '' && $submitter ne '<>' ?
                                     (AUTH => xtext_encode($submitter)) : (),
    ) 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;
      }
      # send a RCPT TO command and get the response
      my($raddr) = qquote_rfc2821_local($r->recip_final_addr);
      if (!$dsn_capable) {
        $smtp_handle->recipient($raddr);
      } else {
        my(@dsn_notify);  # implies a default when the list is empty 
        my($dn) = $r->dsn_notify;
        @dsn_notify = @$dn  if $dn && $msginfo->sender ne '';  # if nondefault
        if (c('terminate_dsn_on_notify_success')) {
          # we want to handle option SUCCESS locally
          if (grep {$_ eq 'SUCCESS'} @dsn_notify) {  # strip out SUCCESS
            @dsn_notify = grep {$_ ne 'SUCCESS'} @dsn_notify;
            @dsn_notify = ('NEVER')  if !@dsn_notify;
            do_log(3,"stripped out SUCCESS, result: NOTIFY=%s",
                     join(',',@dsn_notify));
          }
        }
        ll(5) && do_log(5, "sending RCPT TO:%s %s", $raddr,
          join(' ', (@dsn_notify ? 'NOTIFY='.join(',',@dsn_notify) : ()),
          $net_smtp_supports_orcpt && defined $r->dsn_orcpt
                                 ? 'ORCPT='.$r->dsn_orcpt : ''));
        $smtp_handle->recipient($raddr, {
          @dsn_notify ? (Notify => \@dsn_notify) : (),
          $net_smtp_supports_orcpt && defined $r->dsn_orcpt
                                 ? (ORCPT => $r->dsn_orcpt) : (),
        });
      }
      $smtp_code = $smtp_handle->code;
      $smtp_msg  = $smtp_handle->message;
      chomp($smtp_msg);
      my($rcpt_smtp_resp) = "$smtp_code $smtp_msg";
      if ($smtp_code =~ /^2/) {
        $any_valid_recips++;
        do_log(3, 'response to RCPT TO for %s: "%s"', $raddr,$rcpt_smtp_resp);
      } else {  # not ok
        do_log(1, 'response to RCPT TO for %s: "%s"', $raddr,$rcpt_smtp_resp);
        if ($rcpt_smtp_resp =~ /^0/) {
          # timeout, what to do, could cause duplicates
          do_log(-1, "response to RCPT TO not yet available");
          $rcpt_smtp_resp = "450 4.4.2 ($rcpt_smtp_resp - probably timed out)";
        }
        $r->recip_remote_mta($relayhost);
        $r->recip_remote_mta_smtp_response($rcpt_smtp_resp);
        if ($rcpt_smtp_resp =~ /^ (\d{3}) [ \t]+ ([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($c1) = $1;
            $resp_enhcode = $resp_code eq '452' ? "$c1.5.3" : "$c1.1.0";
          }
          $rcpt_smtp_resp = sprintf("%s %s %s, id=%s, from MTA(%s): %s",
                                    $resp_code, $resp_enhcode,
                                    ($resp_code=~/^2/ ? 'Ok' : 'Failed'),
                                    am_id(), $mta_id, $rcpt_smtp_resp);
        }
        if ($rcpt_smtp_resp =~ /^452/) {  # too many recipients - see rfc2821
          do_log(-1, 'Only %d recips sent in one go: "%s"',
                     $any_valid_recips, $rcpt_smtp_resp);
          $skipping_resp = $rcpt_smtp_resp;
        } elsif ($rcpt_smtp_resp =~ /^4/) {
          $any_tempfail_recips++;
          $smtp_response = $rcpt_smtp_resp  if !defined($smtp_response);
        }
        $r->recip_smtp_response($rcpt_smtp_resp); $r->recip_done(2);
        $smtp_response = $rcpt_smtp_resp
          if $rcpt_smtp_resp =~ /^5/ && $smtp_response !~ /^5/; # keep first 5x
      }
    }
    section_time($which_section); prolong_timer($which_section);
    $smtp_code = $smtp_msg = undef;

    if (!$any_valid_recips) {
      do_log(-1,"mail_via_smtp: DATA skipped, no valid recips, %s",
                $any_tempfail_recips);
    } elsif ($any_tempfail_recips && !$dsn_per_recip_capable) {
      # we must not proceede if mail did not came in as LMTP,
      # or we would generate mail duplicates on each delivery attempt
      do_log(-1,"mail_via_smtp: DATA skipped, tempfailed recips: %s",
                $any_tempfail_recips);
    } else {  # send the message contents (enter DATA phase)
      $which_section = 'fwd-data-cmd';
      $smtp_handle->data or die "sending DATA command\n";
      $in_datasend_mode = 1;

      my($smtp_resp) = $smtp_handle->code . " " . $smtp_handle->message;
      section_time($which_section); prolong_timer($which_section);
      $which_section = 'fwd-data-contents';
      chomp($smtp_resp);
      do_log(4, 'response to DATA: "%s"', $smtp_resp);

      # provide OO wrapper and buffering around Net::Cmd::datasend
      my($smtp_data_fh) = Amavis::Out::SMTP->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,!$initial_submission);
      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 {
        my($nbytes,$buff);
        # 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 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' loop, reading line by line, instead of the normal one below
###     for ($! = 0; defined($buff=$msg->getline); $! = 0) {
###       $smtp_handle->datasend($buff)
###         or die "datasend timed out while sending body";
###     }
###     defined $buff || $!==0  or die "Error reading: $!";

        # must flush buffering through $smtp_data_fh, as from now on
        # we'll be calling Net::Cmd::datasend directly for speed
        $smtp_data_fh->flush or die "Error flushing smtp_data_fh: $!";

        while (($nbytes=$msg->read($buff,16384)) > 0) {
          $smtp_handle->datasend($buff)
            or die "datasend timed out while sending body";
        }
        defined $nbytes or die "Error reading: $!";
      }
      $smtp_data_fh->close or die "Error closing smtp_data_fh: $!";
      $smtp_data_fh = undef;
      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(4, 'response to data end: "%s"', $smtp_response);
      # replace success responses to RCPT TO commands with a final response
      for my $r (@per_recip_data) {
        next  if $r->recip_done;  # skip those that failed at RCPT TO
        $r->recip_remote_mta($relayhost);
        $r->recip_remote_mta_smtp_response($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: %s", $err);
    if (!defined($smtp_handle)) { $smtp_code = ''; $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(-1, "mail_via_smtp: NOTICE: aborting SMTP session, %s", $err);
    $smtp_handle->close; # abruptly terminate the SMTP session, ignoring status
  } 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(-1,"WARN: sending SMTP QUIT command failed: %s %s",
                $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): %s",
                am_id(), $mta_id, $smtp_response);
    } elsif ($smtp_response =~ /^((\d)\d{2})/) {
      my($smtp_code,$smtp_status) = ($1,$2);
      $smtp_response = sprintf("%s %d.6.0 %s, id=%s, from MTA(%s): %s",
             $smtp_code, $smtp_status, ($smtp_status == 2 ? 'Ok' : 'Failed'),
             am_id(), $mta_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, MTA(%s), id=%s",
                             $saved_section_name, $msg, $mta_id, am_id());
  } elsif ($err =~ /^Can't connect/) {
    $smtp_response = sprintf("450 4.4.1 %s, MTA(%s), id=%s",
                             $err, $mta_id, 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 %s, id=%s",
                             ($smtp_code !~ /^5\d\d\z/ ? "550" : $smtp_code),
                             $mta_id, $smtp_code, $smtp_msg, am_id());
  } elsif ($smtp_code =~ /^0/) {  # 000
    $smtp_response = sprintf("450 4.4.2 No response from MTA(%s) ".
                             "during %s (%s), id=%s",
                             $mta_id, $saved_section_name, $err, am_id());
  } else {
    $smtp_response = sprintf("%s 4.5.0 From MTA(%s) ".
                             "during %s (%s): %s %s, id=%s",
                             ($smtp_code !~ /^4\d\d\z/ ? "451" : $smtp_code),
                             $mta_id, $saved_section_name, $err,
                             $smtp_code, $smtp_msg, am_id());
  }
  do_log( ($smtp_response =~ /^2/ ? 1 : -1), "%s -> %s,%s %s", $logmsg,
          join(',', qquote_rfc2821_local(
                      map {$_->recip_final_addr} @per_recip_data)),
          join('', $eightbitmime_capable && uc($btype) eq '8BITMIME' ?
                                                       " BODY=$btype"     :"",
                   $dsn_capable && defined $dsn_ret   ?" RET=$dsn_ret"    :"",
                   $dsn_capable && defined $dsn_envid ?" ENVID=$dsn_envid":""),
          $smtp_response);
  if (defined $smtp_response) {
    $msginfo->dsn_passed_on($dsn_capable && $smtp_response=~/^2/ &&
                            !c('terminate_dsn_on_notify_success') ? 1 : 0);
    for my $r (@per_recip_data) {
      if (!$r->recip_done) {  # mark it as done
        $r->recip_smtp_response($smtp_response); $r->recip_done(2);
        $r->recip_mbxname($r->recip_final_addr)  if $smtp_response =~ /^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;
}

1;

__DATA__
#
package Amavis::Out::Pipe;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

use IO::Wrap;
use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);
BEGIN {
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Util qw(untaint min max ll do_log
                         am_id snmp_count run_command_consumer
                         exit_status_str proc_status_ok prolong_timer);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Out::EditHeader;
}

# Send mail using external mail submission program 'sendmail' (also available
# with Postfix and Exim) - used for forwarding original mail or sending notif.
# May throw exception (die) if temporary failure (4xx) or other problem
#
sub mail_via_pipe(@) {
  my($via,$msginfo,$initial_submission,$dsn_per_recip_capable,$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'),
                        qquote_rfc2821_local($msginfo->sender));
  if (!@per_recip_data) {
    do_log(5, "%s, nothing to do", $logmsg);
    return 1;
  }
  do_log(1, "%s -> %s", $logmsg, join(',', qquote_rfc2821_local(
                                 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')) {
    $msg = IO::Wrap::wraphandle($msg);  # now we have an IO::Handle-like obj
    $msg->seek(0,0) or die "Can't rewind mail file: $!";
  }
  my(@pipe_args) = split(' ',$pipe_args);  my(@command) = shift(@pipe_args);
  my($dsn_capable) = c('propagate_dsn_if_possible');  # assume, unless disabled
  if ($dsn_capable) {    # DSN is supported since Postfix 2.3
    # notify options are per-recipient, yet a command option -N applies to all
    my($common_list); my($not_all_the_same) = 0;
    for my $r (@{$msginfo->per_recip_data}) {
      my($dsn_notify) = $r->dsn_notify;
      my($d) = uc(join(",", $msginfo->sender eq '' ? ('NEVER')
                            : !$dsn_notify ? ('DELAY','FAILURE')  # sorted
                            : sort @$dsn_notify));  # normalize order
      if (!defined($common_list)) { $common_list = $d }
      elsif ($d ne $common_list) { $not_all_the_same = 1 }
    }
    if ($common_list=~/\bSUCCESS\b/ && c('terminate_dsn_on_notify_success')) {
      # strip out option SUCCESS, we want to handle it locally
      my(@dsn_notify) = grep {$_ ne 'SUCCESS'} split(/,/,$common_list);
      @dsn_notify = ('NEVER')  if !@dsn_notify;
      $common_list = join(',',@dsn_notify);
      do_log(3,"stripped out SUCCESS, result: NOTIFY=%s",$common_list);
    }
    if ($not_all_the_same || $msginfo->sender eq '') {}  # leave at default
    elsif ($common_list eq "DELAY,FAILURE") {}           # leave at default
    else { unshift(@pipe_args, '-N', $common_list) }
    unshift(@pipe_args,
            '-V', $msginfo->dsn_envid)  if defined $msginfo->dsn_envid;
    # but there is no mechanism to specify ORCPT or RET
  }
  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.
    # NOTE: the -fsender is not allowed, -f and sender must be separate args!
    my($null_ret_path) = '<>';  # some sendmail lookalikes want '<>', others ''
    # Courier sendmail accepts '' but not <> for null reverse path
    $null_ret_path = ''  if $Amavis::extra_code_in_courier;
    if (/^\$\{sender\}\z/i) {
      push(@command,
           map { $_ eq '' ? $null_ret_path : untaint(quote_rfc2821_local($_)) }
               $msginfo->sender);
    } elsif (/^\$\{recipient\}\z/i) {
      push(@command,
           map { $_ eq '' ? $null_ret_path : untaint(quote_rfc2821_local($_)) }
           map { $_->recip_final_addr } @per_recip_data);
    } else {
      push(@command, $_);
    }
  }
  do_log(5, "mail_via_pipe running command: %s", join(' ', @command));
  local $SIG{CHLD} = 'DEFAULT';
  local $SIG{PIPE} = 'IGNORE';     # write to broken pipe would throw a signal
  my($proc_fh,$pid) = run_command_consumer(undef,undef,@command);
  # binmode on pipes and sockets is a default since Perl 5.8.1
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";
  my($hdr_edits) = $msginfo->header_edits;
  $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
  my($received_cnt) =
    $hdr_edits->write_header($msg,$proc_fh,!$initial_submission);
  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($proc_fh);
  } else {
    my($nbytes,$buff);
    while (($nbytes=$msg->read($buff,16384)) > 0)
      { $proc_fh->print($buff) or die "Submitting mail text failed: $!" }
    defined $nbytes or die "Error reading: $!";
  }
  my($smtp_response);
  if ($received_cnt > 100) { # loop detection required by rfc2821 6.2
    do_log(-2, "Too many hops: %d 'Received:' header lines", $received_cnt);
    kill('TERM',$pid);       # kill the process running mail submission program
    $proc_fh->close; undef $proc_fh; undef $pid;  # and ignore status
    $smtp_response = "550 5.4.6 Rejected: " .
                     "Too many hops: $received_cnt 'Received:' header lines";
  } else {
    my($err) = 0; $proc_fh->close or $err=$!; undef $proc_fh; undef $pid;
    my($child_stat) = $?;
    # sendmail program (Postfix variant) can return the following exit codes:
    # EX_OK(0), EX_DATAERR, EX_SOFTWARE, EX_TEMPFAIL, EX_NOUSER, EX_UNAVAILABLE
    if (proc_status_ok($child_stat,$err, EX_OK)) {
      $smtp_response = "250 2.6.0 Ok";  # submitted to MTA
      snmp_count('OutMsgsDelivers');
    } elsif (proc_status_ok($child_stat,$err, EX_TEMPFAIL)) {
      $smtp_response = "450 4.5.0 Temporary failure submitting message";
      snmp_count('OutAttemptFails');
    } elsif (proc_status_ok($child_stat,$err, EX_NOUSER)) {
      $smtp_response = "550 5.1.1 Recipient unknown";
      snmp_count('OutMsgsRejects');
    } elsif (proc_status_ok($child_stat,$err, EX_UNAVAILABLE)) {
      $smtp_response = "550 5.5.0 Mail submission service unavailable";
      snmp_count('OutMsgsRejects');
    } else {
      $smtp_response = "451 4.5.0 Failed to submit a message: ".
                       exit_status_str($child_stat,$err);
      snmp_count('OutAttemptFails');
    }
    ll(3) && do_log(3,"mail_via_pipe %s, %s, %s", $command[0],
                      exit_status_str($child_stat,$err), $smtp_response);
  }
  $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);
    $r->recip_mbxname($r->recip_final_addr)  if $smtp_response =~ /^2/;
  }
  $msginfo->dsn_passed_on($dsn_capable && $smtp_response=~/^2/ &&
                          !c('terminate_dsn_on_notify_success') ? 1 : 0);
  section_time('fwd-pipe');
  1;
}

1;

__DATA__
#
package Amavis::Out::BSMTP;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

use Errno qw(ENOENT EACCES);
use IO::File qw(O_CREAT O_EXCL O_WRONLY);
use IO::Wrap;
BEGIN {
  import Amavis::Conf qw(:platform $QUARANTINEDIR c cr ca);
  import Amavis::Util qw(untaint min max ll do_log
                         am_id snmp_count prolong_timer);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Out::EditHeader;
}

sub mail_via_bsmtp(@) {
  my($via,$msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_;
  snmp_count('OutMsgs'); local($1);
  $via =~ /^bsmtp:(.*)\z/si or die "Bad fwd method: $via";
  my($bsmtp_file_final) = $1; my($mbxname);
  my($s) = $msginfo->sender;  # defanged sender name for use in filename
  $s =~ tr/a-zA-Z0-9@._+-/=/c;
  $s = substr($s,0,100)."..."  if length($s) > 100+3;
  $s =~ s/\@/_at_/g; $s =~ s/^(\.{0,2})\z/_$1/;
  $bsmtp_file_final =~ s{%(.)}
    {  $1 eq 'b' ? $msginfo->body_digest
     : $1 eq 'm' ? $msginfo->mail_id
     : $1 eq 's' ? untaint($s)
     : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1,'-')
     : $1 eq 'n' ? am_id()
     : $1 eq '%' ? '%' : '%'.$1 }egs;
  # prepend directory if not specified
  $bsmtp_file_final = $QUARANTINEDIR."/".$bsmtp_file_final
    if $QUARANTINEDIR ne '' && $bsmtp_file_final !~ m{^/};
  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'),
                        qquote_rfc2821_local($msginfo->sender));
  if (!@per_recip_data) { do_log(5, "%s, nothing to do", $logmsg); return 1 }
  do_log(1, "%s -> %s, file %s", $logmsg, join(',', qquote_rfc2821_local(
                                  map {$_->recip_final_addr} @per_recip_data)),
            $bsmtp_file_final);
  my($msg) = $msginfo->mail_text;  # a scalar reference, or a file handle
  if (defined($msg) && !$msg->isa('MIME::Entity')) {
    $msg = IO::Wrap::wraphandle($msg);  # now we have an IO::Handle-like obj
    $msg->seek(0,0) or die "Can't rewind mail file: $!";
  }
  my($mp);
  eval {
    my($errn) = stat($bsmtp_file_tmp) ? 0 : 0+$!;
    if ($errn == ENOENT) {}   # good, no file, as expected
    elsif ($errn==0 && -f _)
      { die "File $bsmtp_file_tmp already exists, refuse to overwrite" }
    else
      { die "File $bsmtp_file_tmp exists??? Refuse to overwrite it, $!" }
    $mp = IO::File->new;
    $mp->open($bsmtp_file_tmp, O_CREAT|O_EXCL|O_WRONLY, 0640)
      or die "Can't create BSMTP file $bsmtp_file_tmp: $!";
    binmode($mp, ":bytes") or die "Can't set :bytes, $!"  if $unicode_aware;
    $mp->print("EHLO ", c('localhost_name'), $eol)
      or die "print failed (EHLO): $!";
    my($btype) = $msginfo->body_type;
    if (!defined $btype || uc($btype) eq '7BIT') { $btype = '' }
    $mp->printf("MAIL FROM:%s%s%s",  # rfc1652: need "8bit Data"? (rfc2045)
                qquote_rfc2821_local($msginfo->sender),
                $btype ne '' ? ' BODY='.uc($btype) : '', $eol)
      or die "print failed (MAIL FROM): $!";
    for my $r (@per_recip_data) {
      $mp->print("RCPT TO:", qquote_rfc2821_local($r->recip_final_addr), $eol)
        or die "print failed (RCPT TO): $!";
    }
    $mp->print("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,!$initial_submission);
    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 {
      my($ln);
      for ($! = 0; defined($ln=$msg->getline); $! = 0) {
        $mp->print($ln=~/^\./ ?(".",$ln) :$ln) or die "print failed-data: $!";
      }
      defined $ln || $!==0  or die "Error reading: $!";
    }
    $mp->print(".", $eol) or die "print failed (final dot): $!";
  # $mp->print("QUIT",$eol) or die "print failed (QUIT): $!";
    $mp->close or die "Error closing BSMTP file $bsmtp_file_tmp: $!";
    $mp = undef;
    rename($bsmtp_file_tmp, $bsmtp_file_final)
      or die "Can't rename BSMTP file to $bsmtp_file_final: $!";
    $mbxname = $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(-2,"Can't delete half-finished BSMTP file %s: %s",
                   $bsmtp_file_tmp, $!);
    $mp->close  if defined $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);
    $r->recip_mbxname($mbxname)  if $mbxname ne '' && $smtp_response =~ /^2/;
  }
  section_time('fwd-bsmtp');
  1;
}

1;

__DATA__
#
package Amavis::Out::Local;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

use Errno qw(ENOENT EACCES);
#use File::Spec;
use IO::File qw(O_CREAT O_EXCL O_WRONLY);
use IO::Wrap;

BEGIN {
  import Amavis::Conf qw(:platform $quarantine_subdir_levels c cr ca);
  import Amavis::Lock;
  import Amavis::Util qw(ll do_log am_id run_command_consumer);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Out::EditHeader;
}

use subs @EXPORT_OK;

# Deliver to local mailboxes only, ignore the rest: either to directory
# (maildir style), or file (Unix mbox).  (normally used as a quarantine method)
#
sub mail_to_local_mailbox(@) {
  my($via, $msginfo, $initial_submission, $filter) = @_;
  $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) {
    # each recipient gets its own copy; these are not the original recipients
    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($ldar) = cr('local_delivery_aliases');  # a ref to a hash
      my($alias) = $ldar->{$localpart};
      if (ref($alias) eq 'ARRAY') {
        ($mbxname, $suggested_filename) = @$alias;
      } elsif (ref($alias) eq 'CODE') {  # lazy (delayed) evaluation
        ($mbxname, $suggested_filename) = &$alias;
      } elsif ($alias ne '') {
        ($mbxname, $suggested_filename) = ($alias, undef);
      } elsif (!exists $ldar->{$localpart}) {
        do_log(0, "no key '%s' in %s, skip local delivery",
                  $localpart, '%local_delivery_aliases');
      }
      if ($mbxname eq '') {
        my($why) = !exists $ldar->{$localpart} ? 1 : $alias eq '' ? 2 : 3;
        do_log(2, "skip local delivery(%s): <%s> -> <%s>",$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 directory (amavis/maildir style mailbox)
        my($explicitly_suggested_filename) = $suggested_filename ne '';
        if ($suggested_filename eq '')
          { $suggested_filename = $via_arg ne '' ? $via_arg : '%m' }
        $suggested_filename =~ s{%(.)}
          {  $1 eq 'b' ? $msginfo->body_digest
           : $1 eq 'm' ? $msginfo->mail_id
           : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1,'-')
           : $1 eq 'n' ? am_id()
           : $1 eq '%' ? '%' : '%'.$1 }egs;
      # $mbxname = File::Spec->catfile($mbxname, $suggested_filename);
        $mbxname = "$mbxname/$suggested_filename";
        if ($quarantine_subdir_levels>=1 && !$explicitly_suggested_filename) {
          # using a subdirectory structure to disperse quarantine files
          local($1,$2); my($subdir) = substr($msginfo->mail_id, 0, 1);
          $subdir=~/^[A-Z0-9]\z/i or die "Unexpected first char: $subdir";
          $mbxname =~ m{^ (.*/)? ([^/]+) \z}sx; my($path,$fname) = ($1,$2);
        # $mbxname = File::Spec->catfile($path, $subdir, $fname);
          $mbxname = "$path$subdir/$fname";  # resulting full filename
          my($errn) = stat("$path$subdir") ? 0 : 0+$!;
          if ($errn == ENOENT) {  # check/prepare a set of subdirectories
            do_log(2, "checking/creating quarantine subdirs under %s", $path);
            for my $d ('A'..'Z','a'..'z','0'..'9') {
              $errn = stat("$path$d") ? 0 : 0+$!;
              if ($errn == ENOENT) {
                mkdir("$path$d", 0750) or die "Can't create dir $path$d: $!";
              }
            }
          }
        }
      }
      do_log(1,"local delivery: <%s> -> <%s>, mbx=%s",$sender,$recip,$mbxname);
      my($mp,$pos,$pid);
      my($errn) = stat($mbxname) ? 0 : 0+$!;
      local $SIG{CHLD} = 'DEFAULT';
      local $SIG{PIPE} = 'IGNORE';  # write to broken pipe would throw a signal
      eval {                        # try to open the mailbox file for writing
        if (!$ux) {  # one mail per file, will create specified file
          if ($errn == ENOENT) {}   # good, no file, as expected
          elsif ($errn==0 && -f _)
            { die "File $mbxname already exists, refuse to overwrite" }
          else
            { die "File $mbxname exists??? Refuse to overwrite it, $!" }
          if ($mbxname =~ /\.gz\z/) {
            $mp = Amavis::IO::Zlib->new;
            $mp->open($mbxname,'wb')
              or die "Can't create gzip file $mbxname: $!";
          } else {
            $mp = IO::File->new;
            $mp->open($mbxname, O_CREAT|O_EXCL|O_WRONLY, 0640)
              or die "Can't create file $mbxname: $!";
            binmode($mp, ":bytes") or die "Can't cancel :utf8 mode: $!"
              if $unicode_aware;
          }
        } else {  # append to UNIX-style mailbox
                  # deliver only to non-executable regular files
          if ($errn == ENOENT) {
            $mp = IO::File->new;
            $mp->open($mbxname, O_CREAT|O_EXCL|O_WRONLY, 0640)
              or die "Can't create file $mbxname: $!";
          } elsif ($errn==0 && !-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 {
            $mp = IO::File->new;
            $mp->open($mbxname,'>>',0640)
              or die "Can't append to $mbxname: $!";
          }
          binmode($mp, ":bytes") or die "Can't cancel :utf8 mode: $!"
            if $unicode_aware;
          lock($mp);
          $mp->seek(0,2) or die "Can't position mailbox file to its tail: $!";
          $pos = $mp->tell;
        }
        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
        if ($ux) {
          # a null return path may not appear in the 'From ' delimiter line
          my($snd) = $sender eq '' ? 'MAILER-DAEMON' # as in sendmail & Postfix
                                   : quote_rfc2821_local($sender);
          $mp->printf("From %s %s$eol", $snd,
                      scalar(localtime($msginfo->rx_time)) )   # English date!
            or die "Can't write to $mbxname: $!";
        }
        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,!$initial_submission);
        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
          my($nbytes,$buff);
          while (($nbytes=$msg->read($buff,16384)) > 0)
            { $mp->print($buff) or die "Can't write to $mbxname: $!" }
          defined $nbytes or die "Error reading: $!";
        } else {     # for UNIX-style mailbox delivery: escape 'From '
          # mail(1) and elm(1) recognize /^From / as a message delimiter
          # only after a blank line, which is correct. Other MUAs like mutt,
          # thunderbird, kmail and pine need all /^From / lines escaped.
          my($ln); my($blank_line) = 1;
          for ($! = 0; defined($ln=$msg->getline); $! = 0) {
            $mp->print('>') or die "Can't write to $mbxname: $!"
              if $ln=~/^From /;                 # escape all "From " lines
            # if $blank_line && $ln=~/^From /;  # escape only after blank line
            $mp->print($ln) or die "Can't write to $mbxname: $!";
            $blank_line = $ln eq $eol;
          }
          defined $ln || $!==0  or die "Error reading: $!";
        }
        # must append an empty line for a Unix mailbox format
        $mp->print($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 the system
          $mp->truncate($pos) or die "Can't truncate file $mbxname: $!";
        }
        $failed = 1;
      }
      unlock($mp)  if $ux;
      $mp->close or die "Error closing $mbxname: $!";
      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(-1, "%s", $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 $mbxname ne '' && $smtp_response =~ /^2/;
  }
  section_time('save-to-local-mailbox');
}

1;

__DATA__
#
package Amavis::OS_Fingerprint;
use strict;
use re 'taint';
no warnings 'uninitialized';

BEGIN {
  import Amavis::Util qw(ll do_log);
}
BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.0621';
  @ISA = qw(Exporter);
}
use Time::HiRes ();
use IO::Socket::INET;

sub new {
  my($class, $hostport,$timeout,$query,$nonce) = @_;
  $hostport =~ /^(?: p0f: )? (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) /six
    or die "Bad p0f method syntax: $hostport";
  my($host,$port) = ($1.$2, $3);  my($sock);
  do_log(4,"Fingerprint query: %s port=%s %s %s", $host,$port,$query,$nonce);
  $sock = IO::Socket::INET->new(Type=>SOCK_DGRAM, Proto=>'udp')
    or die "Can't create INET socket: $!";
  my($hisiaddr) = inet_aton($host)  or die "Fingerprint - unknown host: $host";
  my($hispaddr) = scalar(sockaddr_in($port, $hisiaddr));
  defined($sock->send("$query $nonce", 0, $hispaddr))
    or die "Fingerprint - send: $!";
  bless { sock=>$sock, wait_until=>(Time::HiRes::time + $timeout),
          query=>$query, nonce=>$nonce }, $class;
}

sub collect_response {
  my($self) = @_;
  my($timeout) = $self->{wait_until} - Time::HiRes::time;
  if ($timeout < 0) { $timeout = 0 };
  my($sock) = $self->{sock};
  my($resp,$nfound); my($rin,$rout); $rin = ''; vec($rin,fileno($sock),1) = 1;
  while ($nfound=select($rout=$rin, undef,undef,$timeout)) {
    my($inbuf); my($rv) = $sock->recv($inbuf,1024,0);
    defined $rv or die "Fingerprint - error receiving from socket: $!";
    if ($inbuf =~ /^([^ ]*) ([^ ]*) (.*)\015\012\z/) {
      my($r_query,$r_nonce,$r_resp) = ($1,$2,$3);
      if ($r_query eq $self->{query} && $r_nonce eq $self->{nonce})
        { $resp = $r_resp };
    }
    do_log(4,"Fingerprint collect: max_wait=%.3f, %.35s... => %s",
             $timeout,$inbuf,$resp);
    $timeout = 0;
  }
  defined $nfound or die "Fingerprint - select on socket failed: $!";
  $resp;
}

1;

__DATA__
#^L
package Amavis::Out::SQL::Connection;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

use DBI;

BEGIN {
  import Amavis::Conf qw(c cr ca);
  import Amavis::Util qw(ll do_log);
  import Amavis::Timing qw(section_time);
}

# one object per connection (normally exactly one) to a database server;
# connection need not exist at all times, stores info on how to connect;
# when connected it holds database handle
sub new {
  my($class, @dsns) = @_;  # a list of DSNs to try connecting to sequentially
  bless { dbh=>undef, sth=>undef, incarnation=>1, in_transaction=>0,
          dsn_list=>\@dsns, dsn_current=>undef }, $class;
}

sub dsn_current {  # get/set information on currently connected data set name
  my($self)=shift; !@_ ? $self->{dsn_current} : ($self->{dsn_current}=shift);
}

sub dbh {  # get/set database handle
  my($self)=shift; !@_ ? $self->{dbh} : ($self->{dbh}=shift);
}

sub sth {  # get/set statement handle
  my($self)=shift; my($clause)=shift;
  !@_ ? $self->{sth}{$clause} : ($self->{sth}{$clause}=shift);
}

sub dbh_inactive {  # get/set dbh "InactiveDestroy" attribute
  my($self)=shift;  my($dbh) = $self->dbh;
  if (!$dbh) { undef }
  else { !@_ ? $dbh->{'InactiveDestroy'} : ($dbh->{'InactiveDestroy'}=shift) }
}

sub DESTROY {
  my($self) = shift;
  eval { do_log(5,"Amavis::Out::SQL::Connection DESTROY called") };
  eval { $self->disconnect_from_sql };
}

# returns current connection version; works like cache versioning/invalidation:
# SQL statement handles need to rebuilt and caches cleared when SQL connection
# is re-established and a new database handle provided
#
sub incarnation { my($self)=shift; $self->{incarnation} }

sub in_transaction {
  my($self)=shift;
  !@_ ? $self->{in_transaction} : ($self->{in_transaction}=shift)
}

# DBI method wrappers:
sub begin_work {
  my($self)=shift; do_log(5,"sql begin transaction");
  # DBD::mysql man page: if you detect an error while changing
  # the AutoCommit mode, you should no longer use the database handle.
  # In other words, you should disconnect and reconnect again
  $self->dbh or $self->connect_to_sql;
  my($stat) = eval { $self->dbh->begin_work(@_) };
  if (!$stat || $@ ne '') {
    chomp($@); do_log(-1,"sql begin transaction failed, ".
                     "probably disconnected by server, reconnecting (%s)", $@);
    $self->disconnect_from_sql; $self->connect_to_sql;
    $self->dbh->begin_work(@_);
  }
  $self->in_transaction(1);
};

sub begin_work_nontransaction {
  my($self)=shift; do_log(5,"sql begin, nontransaction");
  $self->dbh or $self->connect_to_sql;
};

sub commit {
  my($self)=shift; do_log(5,"sql commit");
  $self->in_transaction(0);
  $self->dbh or die "commit: dbh not available";
  $self->dbh->commit(@_);
};

sub rollback {
  my($self)=shift; do_log(5,"sql rollback");
  $self->in_transaction(0);
  $self->dbh or die "rollback: dbh not available";
  eval { $self->dbh->rollback(@_) };
  if ($@ ne '') {
    chomp($@); do_log(-1,"sql rollback error, reconnecting (%s)", $@);
    $self->disconnect_from_sql; $self->connect_to_sql;
#   $self->dbh->rollback(@_);  # too late now, hopefully implied in disconnect
  }
};

sub last_insert_id {
  my($self)=shift;
  $self->dbh  or die "last_insert_id: dbh not available";
  $self->dbh->last_insert_id(@_);
};

sub fetchrow_arrayref {
  my($self,$clause,@args) = @_;
  $self->dbh          or die "fetchrow_arrayref: dbh not available";
  $self->sth($clause) or die "fetchrow_arrayref: sth not available";
  $self->sth($clause)->fetchrow_arrayref(@args);
};

sub finish {
  my($self,$clause,@args) = @_;
  $self->dbh          or die "finish: dbh not available";
  $self->sth($clause) or die "finish: sth not available";
  $self->sth($clause)->finish(@args);
};

sub execute {
  my($self,$clause,@args) = @_;
  $self->dbh or die "sql execute: dbh not available";
  my($sth) = $self->sth($clause);  # fetch cached st. handle or prepare new
  if ($sth) {
    do_log(5,"sql: executing clause: %s", $clause);
  } else {
    do_log(4,"sql: preparing and executing: %s", $clause);
    $sth = $self->dbh->prepare($clause); $self->sth($clause,$sth);
  }
  eval { $sth->execute(@args) };
  if ($@ ne '') {
    my($err) = $@; chomp($err);
    # man DBI: ->err code is typically an integer but you should not assume so
    # $DBI::errstr is normally already contained in $err
    my($msg) = sprintf("err=%s, %s, %s", $DBI::err,$DBI::state,$err);
    if (!$sth) {
      die "sql execute (no handle): ".$msg;
    } elsif (! ($sth->err eq '2006' || $sth->err eq '2013' ||     # MySQL
                ($sth->err == -1 && $sth->state eq 'S1000')) ) {  # PostgreSQL
      die "sql exec: $msg\n";
    } else {  # Server has gone away; Lost connection to...
      # MySQL: 2006, 2013;  PostgreSQL: 7
      if ($self->in_transaction) {
        $self->disconnect_from_sql;
        die "sql execute failed within transaction, $msg";
      } else {  # try one more time
        do_log(0,"NOTICE: reconnecting in response to: %s", $msg);
        $self->disconnect_from_sql;
        $self->connect_to_sql;
        $self->dbh or die "sql execute: reconnect failed";
        do_log(4,"sql: preparing and executing (again): %s", $clause);
        $sth = $self->dbh->prepare($clause); $self->sth($clause,$sth);
        eval { $sth->execute(@args) };
        if ($@ ne '') {
          $err = $@; chomp($err);
          $msg = sprintf("err=%s, %s, %s", $DBI::err,$DBI::state,$err);
          $self->disconnect_from_sql;
          die "sql execute failed again, $msg";
        }
      }
    }
  }
  1;
}

# 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($self) = shift;  # a list of DSNs to try connecting to sequentially
  my($dbh); my(@dsns) = @{$self->{dsn_list}};
  do_log(3,"Connecting to SQL database server");
  for my $tmpdsn (@dsns) {
    my($dsn, $username, $password) = @$tmpdsn;
    do_log(4,"connect_to_sql: trying '%s'", $dsn);
    $dbh = DBI->connect($dsn, $username, $password,
             {PrintError => 0, RaiseError => 0, Taint => 1, AutoCommit => 1} );
    if ($dbh) {
      $self->dsn_current($dsn);
      do_log(3,"connect_to_sql: '%s' succeeded", $dsn);
      last;
    }
    do_log(-1,"connect_to_sql: unable to connect to DSN '%s': %s",
              $dsn,$DBI::errstr);
  }
  $self->dbh($dbh); delete($self->{sth});
  $self->in_transaction(0); $self->{incarnation}++;
  $dbh or die "connect_to_sql: unable to connect to any dataset";
  $dbh->{'RaiseError'} = 1;
# $dbh->{mysql_auto_reconnect} = 1;  # questionable benefit
# $dbh->func(30000,'busy_timeout');  # milliseconds (SQLite)
  section_time('sql-connect');
  $self;
}

sub disconnect_from_sql($) {
  my($self) = shift; $self->in_transaction(0);
  if ($self->dbh) {
    do_log(4,"disconnecting from SQL");
    $self->dbh->disconnect; $self->dbh(undef); $self->dsn_current(undef);
  }
}

1;

__DATA__
#^L
package Amavis::Out::SQL::Log;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

use DBI;
use Encode;  # Perl 5.8  UTF-8 support

BEGIN {
  import Amavis::Conf qw(:platform c cr ca
                         $QUARANTINEDIR $timestamp_fmt_mysql);
  import Amavis::rfc2821_2822_Tools qw(split_address iso8601_utc_timestamp);
  import Amavis::Util qw(ll do_log am_id untaint safe_decode snmp_count
                         add_entropy);
  import Amavis::Out::SQL::Connection ();
}

sub new {
  my($class,$conn_h) = @_; bless { conn_h=>$conn_h, incarnation=>0 }, $class;
}

sub DESTROY {
  my($self) = shift;
  eval { do_log(5,"Amavis::Out::SQL::Log DESTROY called") };
}

# find an existing e-mail address record or insert one, returning its id
sub find_or_save_addr {
  my($self,$addr) = @_;
  my($id); my($existed) = 0; my($conn_h) = $self->{conn_h};
  my($sql_cl_r) = cr('sql_clause'); my($sel_adr) = $sql_cl_r->{'sel_adr'};
  my($a_ref,$a2_ref);
  $conn_h->begin_work_nontransaction; #(re)connect if not connected, autocommit
  $conn_h->execute($sel_adr,untaint($addr));
  if (defined($a_ref=$conn_h->fetchrow_arrayref($sel_adr))) {  # exists?
    $id = $a_ref->[0]; $conn_h->finish($sel_adr);
    $existed = 1;
  } else {  # does not exist, attempt to insert a new e-mail address record
    my($invdomain) = '';  # inverse domain, chopped to 255 characters
    if ($addr ne '') {
      local($1); my($localpart,$domain) = split_address($addr);
      $domain = lc($domain);
      $localpart = lc($localpart)  if !c('localpart_is_case_sensitive');
      $domain = $1 if $domain=~/^\@?(.*?)\.*\z/s;  # chop leading @ and tr. dot
      $addr = $localpart.'@'.$domain;
      $addr = substr($addr,0,255)  if length($addr) > 255;
      $invdomain = join('.', reverse split(/\./,$domain,-1));
      $invdomain = substr($invdomain,0,255)  if length($invdomain) > 255;
    }
    my($ins_adr) = $sql_cl_r->{'ins_adr'};
    $conn_h->begin_work_nontransaction; #(re)connect if not connected
    eval { $conn_h->execute($ins_adr,untaint($addr),untaint($invdomain)) };
    my($eval_stat) = $@; chomp($eval_stat);
    # INSERT may have failed because of race condition with other processes;
    # try the SELECT again, it will most likely succeed this time;
    # SELECT after INSERT also avoids the need for a working last_insert_id()
    $conn_h->begin_work_nontransaction; #(re)connect if not connected
    $conn_h->execute($sel_adr,untaint($addr));  # try select again
    if ( defined($a2_ref=$conn_h->fetchrow_arrayref($sel_adr)) ) {
      $id = $a2_ref->[0]; $conn_h->finish($sel_adr);
      add_entropy($id);
      if ($eval_stat eq '') {
        do_log(5,"find_or_save_addr: record inserted, id=%s, %s",
                 $id,$addr);
      } else {
        do_log(5,"find_or_save_addr: found on the next attempt, ".
                 "id=%s, %s, (first attempt: %s)", $id,$addr,$eval_stat);
      }
    } else {  # still does not exist
      undef $id; undef $existed;
      die "find_or_save_addr: failed to insert addr $addr: $eval_stat";
    }
  }
  ($id, $existed);
}

sub save_info_preliminary {
  my($self, $conn,$msginfo) = @_;
  my($addr) = $msginfo->sender;
  # find an existing e-mail address record for sender, or insert a new one
  my($sid,$existed) = $self->find_or_save_addr($addr);
  # there is perhaps 30-50% chance the sender address is already in the db
  snmp_count('SqlAddrSender');
  snmp_count('SqlAddrSenderHits')  if $existed;
  do_log(4,"save_info_preliminary: %s, %s, %s",
           $sid, $addr, $existed ? 'exists' : 'new' );
  my($conn_h) = $self->{conn_h}; my($sql_cl_r) = cr('sql_clause');
  $conn_h->begin_work;  # SQL transaction starts
  eval {
    # MySQL does not like a standard iso8601 delimiter 'T' or a timezone,
    # when data type of msgs.time_iso is TIMESTAMP (instead of a string)
    my($time_iso) = $timestamp_fmt_mysql
                      ? iso8601_utc_timestamp($msginfo->rx_time,1,'')
                      : iso8601_utc_timestamp($msginfo->rx_time);
    # insert a placeholder message record with sender information
    $conn_h->execute($sql_cl_r->{'ins_msg'},
      $msginfo->mail_id, $msginfo->secret_id, am_id(),
      $msginfo->rx_time, $time_iso,
      untaint($sid), c('policy_bank_path'), untaint($msginfo->client_addr),
      untaint($msginfo->msg_size), substr(c('myhostname'),0,255));
    $conn_h->commit;
  };
  if ($@ ne '') {
    my($err) = $@; chomp($err);
    if ($conn_h->in_transaction) {
      eval { $conn_h->rollback };
      do_log(1,"save_info_preliminary: rollback%s",
               $@ eq '' ? " done" : ": $@");
    }
    do_log(-1, "WARN save_info_preliminary: %s", $err);
    return 0;
  }
  1;
}

sub save_info_final {
  my($self, $conn,$msginfo,$dsn_sent) = @_;
  my($mail_id) = $msginfo->mail_id; my($spam_level) = $msginfo->spam_level;
  my(@rid_list); # find existing address records for recipients, or insert them
  for my $r (@{$msginfo->per_recip_data}) {
    my($addr) = $r->recip_addr;
    my($rid,$existed) = $self->find_or_save_addr($addr);
    # there is perhaps 90-100% chance the recipient addr is already in the db
    snmp_count('SqlAddrRecip');
    snmp_count('SqlAddrRecipHits')  if $existed;
    do_log(4,"save_info_final %s, recip id: %s, %s, %s",
             $mail_id, $rid, $addr, $existed?'exists':'new' );
    push(@rid_list, $rid);
  }
  my($conn_h) = $self->{conn_h};
  my($sql_cl_r) = cr('sql_clause'); my($ins_rcp) = $sql_cl_r->{'ins_rcp'};
  $conn_h->begin_work;  # SQL transaction starts
  eval {
    for my $r (@{$msginfo->per_recip_data}) {
      my($addr) = $r->recip_addr;  my($rid) = shift(@rid_list);
      my($dest,$resp) = ($r->recip_destiny, $r->recip_smtp_response);
      my($d) = $resp=~/^4/ ? 'TEMPFAIL'
            : ($dest==D_BOUNCE && $resp=~/^5/) ? 'BOUNCE'
            : ($dest!=D_BOUNCE && $resp=~/^5/) ? 'REJECT'
            : ($dest==D_PASS  && ($resp=~/^2/ || !$r->recip_done)) ? 'PASS'
            : ($dest==D_DISCARD) ? 'DISCARD' : '?';
      # insert recipient record
      $conn_h->execute($ins_rcp,
        $mail_id, untaint($rid),
      # $msginfo->rx_time,
        substr($d,0,1), ' ',
        $r->recip_blacklisted_sender ? 'Y' : 'N',
        $r->recip_whitelisted_sender ? 'Y' : 'N',
        !defined($spam_level) ? undef :
          untaint($spam_level + $r->recip_score_boost),
        untaint($resp) );
    };
    my($m_id) = $msginfo->orig_header_fields->{'message-id'};
    my($from) = $msginfo->orig_header_fields->{'from'};
    my($subj) = $msginfo->orig_header_fields->{'subject'};
    for ($m_id,$from,$subj) {
      local($1); chomp;
      s/\n([ \t])/$1/sg; s/^[ \t]+//s; s/[ \t]+\z//s;  # unfold, trim
      if ($unicode_aware) {
        my($octets);  # string of bytes (not logical chars), UTF8 encoded
        eval { $octets = Encode::encode_utf8(safe_decode('MIME-Header',$_))};
        if ($@ eq '') { $_ = $octets }
        else { do_log(1,"save_info_final INFO: header field ".
                        "not decodable, keeping raw bytes: %s", $@) }
      }
      $_ = substr($_,0,255)  if length($_) > 255;
    }
    my($q_to) = $msginfo->quarantined_to;  # a ref to a list of quar. locations
    if (!defined($q_to)) {}
    elsif (!@$q_to) { undef $q_to }
    else {
      $q_to = $q_to->[0];  # keep only the first quarantine location
      $q_to =~ s{^\Q$QUARANTINEDIR\E/}{};  # strip directory
      $q_to = substr($q_to,0,255)  if length($q_to) > 255;
    }
    $q_to = defined $q_to ? untaint($q_to) : '';
    my($content_type) = $msginfo->setting_by_contents_category({
      CC_VIRUS,'V', CC_BANNED,'B', CC_SPAM,'S', CC_BADH.",2",'M', CC_BADH,'H',
      CC_OVERSIZED,'O', CC_CLEAN,'C', CC_CATCHALL,'?'});
    my($quar_type) = $msginfo->quar_type;
    for ($quar_type,$content_type) { $_ = ' '  if !defined || /^ *\z/ }
    do_log(4,"save_info_final %s, %s, %s, %s, %s, %s, ".
             "Message-ID: %s, From: '%s', Subject: '%s'",
             $mail_id, $content_type, $quar_type, $q_to, $dsn_sent,
             $spam_level, $m_id, $from, $subj);
    # update message record with additional information
    $conn_h->execute($sql_cl_r->{'upd_msg'},
             $content_type, $quar_type, $q_to, $dsn_sent,
             untaint($spam_level), untaint($m_id), untaint($from),
             untaint($subj), $mail_id);
    $conn_h->commit;
  };
  if ($@ ne '') {
    my($err) = $@; chomp($err);
    if ($conn_h->in_transaction) {
      eval { $conn_h->rollback };
      do_log(1, "save_info_final: rollback%s", $@ eq '' ? " done" : ": $@" );
    }
    do_log(-1, "WARN save_info_final: %s", $err);
    return 0;
  }
  1;
}

1;

__DATA__
#
package Amavis::IO::SQL;
# a simple IO wrapper around SQL for inserting/retrieving mail text
# to/from a database

use strict;
use re 'taint';
no warnings 'uninitialized';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
}
use Errno qw(ENOENT EACCES EIO);
use DBI;

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

sub new {
  my($class) = shift;  my($self) = bless {}, $class;
  if (@_) { $self->open(@_) or return undef }
  $self;
}

sub open {
  my($self) = shift; @$self{qw(conn_h clause dbkey mode maxbuf rx_time)} = @_;
  $self->{buf} = '';
  $self->{chunk_ind} = $self->{pos} = $self->{bufpos} = $self->{eof} = 0;
  if ($self->{mode} ne 'w') {
    eval { $self->{conn_h}->execute($self->{clause}, $self->{dbkey}) };
    my($ll) = $@ ne '' ? -1 : 4;
    ll($ll) && do_log($ll,"Amavis::IO::SQL::open (%s); key=%s: %s",
                          $self->{clause}, $self->{dbkey}, $@);
    if ($@ ne '') {
      chomp($@); die "Amavis::IO::SQL::open error: $@";
      $! = EIO; return undef;  # not reached
    }
  }
  $self;
}

sub DESTROY {
  my($self) = shift;
  if (ref $self && $self->{conn_h}) {
    eval { $self->close or die "Error closing: $!" };
    if ($@ ne '') { warn "Amavis::IO::SQL::close error: $@" }
    delete $self->{conn_h};
  }
}

sub close {
  my($self) = shift; $@ = undef;
  eval {
    if ($self->{mode} eq 'w') {
      $self->flush or die "Can't flush: $!";
    } elsif ($self->{conn_h} && $self->{clause} && !$self->{eof}) {
      # reading, closing before eof was reached
      $self->{conn_h}->finish($self->{clause}) or die "Can't finish: $!";
    }
  };
  delete @$self{
    qw(conn_h clause dbkey mode maxbuf rx_time buf chunk_ind pos bufpos eof) };
  if ($@ ne '') {
    chomp($@); die "Error closing, $@";
    $! = EIO; return undef;  # not reached
  }
  1;
}

sub seek {
  my($self,$pos,$whence) = @_;
  $whence==0 && $pos==0 or die "Seek to $whence,$pos on sql i/o not supported";
  ll(5) && do_log(5, "Amavis::IO::SQL::seek mode=%s", $self->{mode});
  $self->{mode} ne 'w'
    or die "Seek to $whence,$pos on sql i/o only supported for read mode";
  if ($self->{chunk_ind} <= 1)  # still in the first chunk, just reset bufpos
    { $self->{pos} = $self->{bufpos} = $self->{eof} = 0; 1 }   # reset, success
  else { # beyond the first chunk, need to restart the query from the beginning
    my($con,$clause,$key,$mode,$maxb) =
      @$self{qw(conn_h clause dbkey mode maxbuf)};
    $self->close or die "seek: error closing, $!";
    $self->open($con,$clause,$key,$mode,$maxb)
      or die "seek: reopen failed, $!";
  }
  1;
}

sub read {  # SCALAR,LENGTH,OFFSET
  my($self) = shift;
  !defined($_[2]) || $_[2]==0
    or die "Reading from sql to an offset not supported";
  my($req_len) = $_[1]; my($conn_h) = $self->{conn_h}; my($a_ref);
  ll(5) && do_log(5, "Amavis::IO::SQL::read, %d, %d",
                     $self->{chunk_ind}, $self->{bufpos});
  eval {
    while (!$self->{eof} && length($self->{buf})-$self->{bufpos} < $req_len) {
      $a_ref = $conn_h->fetchrow_arrayref($self->{clause});
      if (!defined($a_ref)) { $self->{eof} = 1 }
      else { $self->{buf} .= $a_ref->[0]; $self->{chunk_ind}++ }
    }
  };
  if ($@ ne '') {
    # we can't stash an arbitrary error message string into $!,
    # which forces us to use 'die' to properly report an error
    chomp($@); die "read: sql select failed, $@";
    $! = EIO; return undef;  # not reached
  };
  $_[0] = substr($self->{buf}, $self->{bufpos}, $req_len);
  my($nbytes) = length($_[0]);
  $self->{bufpos} += $nbytes; $self->{pos} += $nbytes;
  if ($self->{bufpos} > 0 && $self->{chunk_ind} > 1) {
    # discard used-up part of the buf unless at ch.1, which may still be useful
    do_log(5,"read: moving on by %d chars", $self->{bufpos});
    $self->{buf} = substr($self->{buf},$self->{bufpos}); $self->{bufpos} = 0;
  }
  $nbytes;   # eof: 0, error: undef
}

sub getline {
  my($self) = shift;  my($conn_h) = $self->{conn_h};
  ll(5) && do_log(5, "Amavis::IO::SQL::getline, %d, %d",
                     $self->{chunk_ind}, $self->{bufpos});
  my($a_ref,$line); my($ind) = -1;
  eval {
    while (!$self->{eof} &&
           ($ind=index($self->{buf},"\n",$self->{bufpos})) < 0) {
      $a_ref = $conn_h->fetchrow_arrayref($self->{clause});
      if (!defined($a_ref)) { $self->{eof} = 1 }
      else { $self->{buf} .= $a_ref->[0]; $self->{chunk_ind}++ }
    }
  };
  if ($@ ne '') {
    chomp($@); die "getline: reading sql select results failed, $@";
    $! = EIO; return undef;  # not reached
  };
  if ($ind < 0 && $self->{eof})  # imply a NL before eof if missing
    { $self->{buf} .= "\n"; $ind = index($self->{buf}, "\n", $self->{bufpos}) }
  $ind >= 0  or die "Programming error, NL not found";
  if (length($self->{buf}) > $self->{bufpos}) {  # nonempty buffer?
    $line = substr($self->{buf}, $self->{bufpos}, $ind+1-$self->{bufpos});
    my($nbytes) = length($line);
    $self->{bufpos} += $nbytes; $self->{pos} += $nbytes;
    if ($self->{bufpos} > 0 && $self->{chunk_ind} > 1) {
      # discard used-up part of the buf unless at ch.1, which may still be useful
      ll(5) && do_log(5,"getline: moving on by %d chars", $self->{bufpos});
      $self->{buf} = substr($self->{buf},$self->{bufpos}); $self->{bufpos} = 0;
    }
  }
  # eof: undef, $! zero;  error: undef, $! nonzero
  $! = 0;  $line eq '' ? undef : $line;
}

sub flush {
  my($self) = shift;
  $self->{mode} eq 'w' or die "Can't flush, opened for reading";
  my($msg); my($conn_h) = $self->{conn_h};
  while (length($self->{buf}) > 0) {
    my($ind) = $self->{chunk_ind} + 1;
    ll(4) && do_log(4, "sql flush: key: (%s, %d), rx_time=%d, size=%d",
                 $self->{dbkey}, $ind, $self->{rx_time},
                 length($self->{buf}) < $self->{maxbuf} ? length($self->{buf})
                                                        : $self->{maxbuf} );
    eval {
      $conn_h->execute($self->{clause}, $self->{dbkey}, $ind,
                     # $self->{rx_time},
                       untaint(substr($self->{buf},0,$self->{maxbuf})));
    };
    if ($@ ne '') { $msg = $@; last }
    substr($self->{buf},0,$self->{maxbuf}) = ''; $self->{chunk_ind} = $ind;
  }
  if (defined($msg)) {
    chomp($msg); $msg = "flush: sql inserting text failed, $msg";
    die $msg;  # we can't stash an arbitrary error message string into $!,
               # which forces us to use 'die' to properly report an error
    $! = EIO; return undef;  # not reached
  }
  1;
}

sub print {
  my($self) = shift;
  $self->{mode} eq 'w' or die "Can't print, not opened for writing";
  my($nbytes); my($conn_h) = $self->{conn_h}; my($len) = length($_[0]);
  if ($len <= 0) { $nbytes = "0 but true" }
  else {
    $self->{buf} .= $_[0]; $self->{pos} += $len; $nbytes = $len;
    while (length($self->{buf}) >= $self->{maxbuf}) {
      my($ind) = $self->{chunk_ind} + 1;
      ll(4) && do_log(4, "sql print: key: (%s, %d), size=%d",
                         $self->{dbkey}, $ind, $self->{maxbuf});
      eval {
        $conn_h->execute($self->{clause}, $self->{dbkey}, $ind,
                       # $self->{rx_time},
                         untaint(substr($self->{buf},0,$self->{maxbuf})));
      };
      if ($@ ne '') {
        # we can't stash an arbitrary error message string into $!,
        # which forces us to use 'die' to properly report an error
        chomp($@); die "print: sql inserting mail text failed, $@";
        $! = EIO; return undef;  # not reached
      };
      substr($self->{buf},0,$self->{maxbuf}) = ''; $self->{chunk_ind} = $ind;
    }
  }
  $nbytes;
}

sub printf { shift->print(sprintf(shift,@_)) }

1;

#^L
package Amavis::Out::SQL::Quarantine;
use strict;
use re 'taint';

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

use subs @EXPORT;
use DBI;
use IO::Wrap;

BEGIN {
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::rfc2821_2822_Tools qw(qquote_rfc2821_local);
  import Amavis::Util qw(ll do_log am_id snmp_count);
  import Amavis::Timing qw(section_time);
  import Amavis::Out::SQL::Connection ();
}

sub mail_via_sql {
  my($conn_h,$msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_;
  snmp_count('OutMsgs'); local($1);
  my($mail_id) = $msginfo->mail_id;
  my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) }
                             @{$msginfo->per_recip_data};
  my($logmsg) =
    sprintf("%s via SQL (%s): %s", ($initial_submission?'SEND':'FWD'),
            $conn_h->dsn_current, qquote_rfc2821_local($msginfo->sender));
  if (!@per_recip_data) { do_log(5, "%s, nothing to do", $logmsg); return 1 }
  do_log(1, "%s -> %s, mail_id %s", $logmsg,
            join(',', qquote_rfc2821_local(
                                  map {$_->recip_final_addr} @per_recip_data)),
            $mail_id);
  my($msg) = $msginfo->mail_text;  # a scalar reference, or a file handle
  if (defined($msg) && !$msg->isa('MIME::Entity')) {
    $msg = IO::Wrap::wraphandle($msg);  # now we have an IO::Handle-like obj
    $msg->seek(0,0) or die "Can't rewind mail file: $!";
  }
  eval {
    my($sql_cl_r) = cr('sql_clause');
    $conn_h->begin_work;  # SQL transaction starts
    eval {
      my($mp) = Amavis::IO::SQL->new;
      $mp->open($conn_h, $sql_cl_r->{'ins_quar'},
                $msginfo->mail_id,'w',16384,$msginfo->rx_time)
        or die "Can't open Amavis::IO::SQL object: $!";
      my($hdr_edits) = $msginfo->header_edits;
      $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
      my($received_cnt) =
        $hdr_edits->write_header($msg,$mp,!$initial_submission);
      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 {
        my($nbytes,$buff);
        while (($nbytes=$msg->read($buff,16384)) > 0)
          { $mp->print($buff) or die "Can't write to SQL sorage: $!" }
        defined $nbytes or die "Error reading: $!";
      }
      $mp->close or die "Error closing Amavis::IO::SQL object: $!";
      $conn_h->commit;
    };
    if ($@ ne '') {
      my($msg) = $@; chomp($msg);
      $msg = "writing mail text to SQL failed: $msg"; do_log(0,"%s",$msg);
      if ($conn_h->in_transaction) {
        eval { $conn_h->rollback };
        do_log(1, "mail_via_sql: rollback%s", $@ eq '' ? " done" : ": $@" );
      }
      die $msg;
    }
  };
  my($err) = $@; my($smtp_response);
  if ($err eq '') {
    $smtp_response = "250 2.6.0 Ok, Stored to sql db as mail_id $mail_id";
    snmp_count('OutMsgsDelivers');
  } else {
    chomp($err);
    if ($err =~ /too many hops/i) {
      $smtp_response = "550 5.4.6 Rejected: $err";
      snmp_count('OutMsgsRejects');
    } else {
      $smtp_response = "451 4.5.0 Storing to sql db as mail_id $mail_id 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);
    $r->recip_mbxname($mail_id)  if $smtp_response =~ /^2/;
  }
  section_time('fwd-sql');
  1;
}

1;

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

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

use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);
use Errno qw(EPIPE ENOTCONN ENOENT EACCES EAGAIN ECONNRESET);
use Socket;
use IO::Socket;
use IO::Socket::UNIX;

use subs @EXPORT_OK;
use vars @EXPORT;

BEGIN {
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll untaint min max do_log am_id rmdir_recursively
                         exit_status_str proc_status_ok kill_proc run_command
                         prolong_timer);
  import Amavis::Timing qw(section_time);
}

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

# subroutine available for calling from @av_scanners list entries;
# it has the same args and returns as run_av() below
sub ask_daemon { ask_av(\&ask_daemon_internal, @_) }

sub clamav_module_init($) {
  my($av_name) = @_;
  # each child should reinitialize clamav module to reload databases.
  my($clamav_version) = Mail::ClamAV->VERSION;
  my($dbdir) = Mail::ClamAV::retdbdir();
  my($clamav_obj) = Mail::ClamAV->new($dbdir);
  ref $clamav_obj
    or die "$av_name: Can't load db from $dbdir: $Mail::ClamAV::Error";
  $clamav_obj->buildtrie;
  $clamav_obj->maxreclevel($MAXLEVELS)  if $MAXLEVELS;
  $clamav_obj->maxfiles($MAXFILES);
  $clamav_obj->maxfilesize($MAX_EXPANSION_QUOTA || 30*1024*1024);
  if ($clamav_version >= 0.12) {
    $clamav_obj->maxratio($MAX_EXPANSION_FACTOR);
#   $clamav_obj->archivememlim(0);  # limit memory usage for bzip2 (0/1)
  }
  do_log(2,"%s init", $av_name);
  section_time('clamav_module_init');
  ($clamav_obj,$clamav_version);
}

# to be called from sub ask_clamav
use vars qw($clamav_obj $clamav_version);
sub clamav_module_internal($@) {
  my($query, $bare_fnames,$names_to_parts,$tempdir, $av_name) = @_;
  if (!defined $clamav_obj) {
    ($clamav_obj,$clamav_version) = clamav_module_init($av_name);  # first time
  } elsif ($clamav_obj->statchkdir) {            # db reload needed?
    do_log(2, "%s: reloading virus database", $av_name);
    ($clamav_obj,$clamav_version) = clamav_module_init($av_name);
  }
  my($fname) = "$tempdir/parts/$query";   # file to be checked
  my($part) = $names_to_parts->{$query};  # get corresponding parts object
  my($options) = 0;  # bitfield of options to Mail::ClamAV::scan
  my($opt_archive,$opt_mail);
  if ($clamav_version < 0.12) {
    $opt_archive = &Mail::ClamAV::CL_ARCHIVE;
    $opt_mail    = &Mail::ClamAV::CL_MAIL;
  } else {         # >= 0.12, reflects renamed flags in libclamav 0.80
    $opt_archive = &Mail::ClamAV::CL_SCAN_ARCHIVE;
    $opt_mail    = &Mail::ClamAV::CL_SCAN_MAIL;
  }
  $options |= &Mail::ClamAV::CL_SCAN_STDOPT  if $clamav_version >= 0.13;
  $options |= $opt_archive;  # turn on ARCHIVE
  $options &= ~$opt_mail;    # turn off MAIL
  if (ref($part) && (lc($part->type_short) eq 'mail' ||
                     lc($part->type_declared) eq 'message/rfc822')) {
    do_log(2, "%s: $query - enabling option CL_MAIL", $av_name);
    $options |= $opt_mail;   # turn on MAIL
  }
  my($ret) = $clamav_obj->scan(untaint($fname), $options);
  my($output,$status);
  if    ($ret->virus) { $status = 1; $output = "INFECTED: $ret" }
  elsif ($ret->clean) { $status = 0; $output = "CLEAN" }
  else { $status = 2; $output = $ret->error.", errno=".$ret->errno }
  ($status,$output);  # return synthesised status and a result string
}

# subroutine available for calling from @av_scanners list entries;
# it has the same args and returns as run_av() below
sub ask_clamav { ask_av(\&clamav_module_internal, @_) }

my($savi_obj);
sub sophos_savi_init {
  my($av_name, $command) = @_;
  my(@savi_bool_options) = qw(
         GrpArchiveUnpack GrpSelfExtract GrpExecutable GrpInternet GrpMSOffice
         GrpMisc !GrpDisinfect !GrpClean
         EnableAutoStop FullSweep FullPdf Xml
  );
  $savi_obj = SAVI->new;
  ref $savi_obj or die "$av_name: Can't create SAVI object, err=$savi_obj";
  my($status) = $savi_obj->load_data;
  !defined($status) or die "$av_name: Failed to load SAVI virus data " .
                           $savi_obj->error_string($status) . " ($status)";
  my($version) = $savi_obj->version;
  ref $version or die "$av_name: Can't get SAVI version, err=$version";
  do_log(2,"%s init: Version %s (engine %d.%d) recognizing %d viruses",
           $av_name, $version->string, $version->major, $version->minor,
           $version->count);
  my($error);
  if ($MAXLEVELS) {
    $error = $savi_obj->set('MaxRecursionDepth', $MAXLEVELS);
    !defined $error
      or die "$av_name: error setting MaxRecursionDepth: err=$error";
  }
  $error = $savi_obj->set('NamespaceSupport', 3);  # new with Sophos 3.67
  !defined $error
    or do_log(-1,"%s: error setting NamespaceSupport: err=%s",$av_name,$error);
  for (@savi_bool_options) {
    my($value) = /^!/ ? 0 : 1;  s/^!+//;
    $error = $savi_obj->set($_, $value);
    !defined $error or die "$av_name: Error setting $_: err=$error";
  }
  section_time('sophos_savi_init');
  1;
}

sub sophos_savi_stale {
  defined $savi_obj && $savi_obj->stale;
}

sub sophos_savi_reload {
  if (defined $savi_obj) {
    my($status) = $savi_obj->load_data();
    !defined($status) or die "Failed to load SAVI virus data " .
                             $savi_obj->error_string($status) . " ($status)";
    my($version) = $savi_obj->version;
    ref $version or die "Can't get SAVI version, err=$version";
    do_log(2,"Updated SAVI data: Version %s (engine %d.%d) ".
             "recognizing %d viruses", $version->string,
             $version->major, $version->minor, $version->count);
  }
}

# to be called from sub sophos_savi
sub sophos_savi_internal {
  my($query,
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_;
  my($fname) = "$tempdir/parts/$query";   # file to be checked
  if (!c('bypass_decode_parts')) {
    my($part) = $names_to_parts->{$query};  # get corresponding parts object
    my($mime_option_value) = 0;
    if (ref($part) && (lc($part->type_short) eq 'mail' ||
                       lc($part->type_declared) eq 'message/rfc822')) {
      do_log(2, "%s: $query - enabling option Mime", $av_name);
      $mime_option_value = 1;
    }
    my($error) = $savi_obj->set('Mime', $mime_option_value);
    !defined $error or die sprintf("%s: Error %s option Mime: err=%s",
                $av_name, $mime_option_value ? 'setting' : 'clearing', $error);
  }
  my($output,$status); my($result) = $savi_obj->scan($fname);
  if (!ref($result)) {  # error
    my($msg) = "error scanning file $fname, " .
               $savi_obj->error_string($result) . " ($result) $!";
    if (! grep {$result == $_} (514,527,530,538,549) ) {
      $status = 2; $output = "ERROR $query: $msg";
    } else { # don't panic on non-fatal (encrypted, corrupted, partial)
      $status = 0; $output = "CLEAN $query: $msg";
    }
    do_log(5,"%s: %s", $av_name,$output);
  } elsif ($result->infected) {
    $status = 1; $output = join(", ", $result->viruses) . " FOUND";
  } else {
    $status = 0; $output = "CLEAN $query";
  }
  ($status,$output);  # return synthesised status and a result string
}

# subroutine available for calling from @av_scanners list entries;
# it has the same args and returns as run_av() below
sub ask_sophos_savi {
  my($bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args,
     $sts_clean,$sts_infected,$how_to_get_names) = @_;
  if (@_ < 3+6) {  # supply default arguments for backwards compatibility
    $args = ["*"]; $sts_clean = [0]; $sts_infected = [1];
    $how_to_get_names = qr/^(.*) FOUND$/;
  }
  ask_av(\&sophos_savi_internal,
         $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args,
         $sts_clean, $sts_infected, $how_to_get_names);
}


# 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,  # expanded query template, often a command and a file or dir name
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args,
     $sts_clean,$sts_infected,$how_to_get_names,  # regexps
  ) = @_;
  my($query_template_orig,$sockets) = @$args;
  my($output) = ''; 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
  # Sophie and Trophie can accept multiple requests per session
  # and return a single line response each time
  my($multisession) = $av_name =~ /^(Sophie|Trophie)/i ? 1 : 0;
  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; # simpleminded: unix vs. inet sock
    eval {
      if (!$st_socket_created{$socketname}) {
        ll(3) && do_log(3, "%s: Connecting to socket %s %s%s",
                           $av_name, $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";
        }
      }
      ll(3) && do_log(3,"%s: Sending %s to %s socket %s",
                        $av_name, $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";
      my($rv); my($buff) = ''; $! = 0;
      while (defined($rv = $st_sock{$socketname}->recv($buff,8192,0))) {
        $output .= $buff;
        last  if $multisession || $buff eq '';
        $! = 0;
      }
      defined $rv || $!==0 || $!==ECONNRESET
        or die "Error receiving from $socketname: $!\n";
      if (!$multisession) {
        $st_sock{$socketname}->close
          or die "Error closing socket $socketname: $!\n";
        $st_sock{$socketname} = undef; $st_socket_created{$socketname} = 0;
      }
      $! = 0;
      $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,"%s broken pipe (don't worry), retrying (%d)",
               $av_name,$retries);
    } else {
      do_log( ($retries>1?-1:1), "%s: %s, retrying (%d)",$av_name,$@,$retries);
      if ($retries % @$sockets == 0) {  # every time the list is exhausted
        my($dly) = min(20, 1 + 5 * ($retries/@$sockets - 1));
        do_log(3,"%s: sleeping for %s s", $av_name,$dly);
        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
  }
  (0,$output);  # return synthesised status and result string
}

# ask_av is a common subroutine available to be used by ask_daemon, ask_clamav,
# ask_sophos_savi and similar front-end routines used in @av_scanners entries.
# It traverses supplied files or directory ($bare_fnames) and calls a supplied
# subroutine for each file to be scanned, summarizing the final av scan result.
# It has the same args and returns as run_av() below, prepended by a checking
# subroutine argument.
sub ask_av {
  my($code) = shift; # strip away the first argument, a subroutine ref
  my($bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args,
     $sts_clean,$sts_infected,$how_to_get_names) = @_;
  my($query_template) = ref $args eq 'ARRAY' ? $args->[0] : $args;
  do_log(5, "ask_av (%s): query template1: %s", $av_name,$query_template);
  my($checking_each_file) = $query_template =~ /\*/;
  my($scan_status,@virusname); my($output) = '';
  for my $f ($checking_each_file ? @$bare_fnames : ("$tempdir/parts")) {
    my($query) = $query_template;
    if (!$checking_each_file) {  # scanner can be given a directory name
      $query =~ s[{}][$tempdir/parts]g;  # replace {} with directory name
      do_log(3,"Using (%s) on dir: %s", $av_name,$query);
    } else {                     # must check each file individually
      # replace {}/* with directory name and file, and * with current file name
      $query =~ s[ ({}/)? \* ]
                 [ !defined($1) || $1 eq '' ? $f : "$tempdir/parts/$f" ]gesx;
      do_log(3,"Using (%s) on file: %s", $av_name,$query);
    }
    my($t_status,$t_output) = &$code($query, @_);
    do_log(4,"ask_av (%s) result: %s", $av_name,$t_output);
    # braindead Perl: ""=~/x{0}/ serves as explicit default for an empty regexp
    if (defined $sts_infected && (
        ref($sts_infected) eq 'ARRAY' ? (grep {$_==$t_status} @$sts_infected)
                 : ""=~/x{0}/ && $t_output=~/$sts_infected/m)) {  # is infected
      # test for infected first, in case both expressions match
      $scan_status = 1;  # 'true' indicates virus found, no errors
      my(@t_virusnames) = ref($how_to_get_names) eq 'CODE'
                            ? &$how_to_get_names($t_output)
                            : ""=~/x{0}/ && $t_output=~/$how_to_get_names/gm;
      @t_virusnames = map { defined $_ ? $_ : () } @t_virusnames;
      push(@virusname, @t_virusnames);
      $output .= $t_output . $eol;
      do_log(2,"ask_av (%s): %s INFECTED: %s",
               $av_name, $f, join(", ",@t_virusnames) );
    } elsif (!defined($sts_clean)) {  # clean, but inconclusive
      # by convention: undef $sts_clean means result is inconclusive,
      # file appears clean, but continue scanning with other av scanners,
      # the current scanner does not want to vouch for it; useful for a
      # scanner like jpeg checker which tests for one vulnerability only
      do_log(3,"ask_av (%s): %s CLEAN, but inconclusive", $av_name,$f);
    } elsif (ref($sts_clean) eq 'ARRAY'
                  ? (grep {$_==$t_status} @$sts_clean)
                  : ""=~/x{0}/ && $t_output=~/$sts_clean/m) {  # is clean
      $scan_status = 0  if !$scan_status;   # no viruses, no errors
      do_log(3,"ask_av (%s): %s CLEAN", $av_name,$f);
    } else {
      do_log(-2,"ask_av (%s) FAILED - unexpected result: %s",
                $av_name,$t_output);
      last;  # error, bail out
    }
  }
  if (!@$bare_fnames) { $scan_status = 0 }  # no errors, no viruses
  do_log(3,"%s result: clean",
           $av_name)  if defined($scan_status) && !$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 job;
# 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 {
  # first three args are prepended, not part of n-tuple
  my($bare_fnames,  # a ref to a list of filenames to scan (basenames)
     $names_to_parts, # ref to a hash that maps base file names to parts object
     $tempdir,      # temporary directory
     $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 %s: (built-in interface)", $av_name);
    ($scan_status,$output,$virusnames) = &$command(@_);
  } else {
    local($1); my(@args) = split(' ',$args);
    if (grep { m{^({}/)?\*\z} } @args) {    #  {}/* or *, list each file
      # replace asterisks with bare file names (basenames) if alone or in {}/*
      @args = map { !m{^({}/)?\*\z} ? $_
                                  : map {$1.untaint($_)} @$bare_fnames } @args;
    }
    for (@args) { s[{}][$tempdir/parts]g }  # replace {} with directory name
    # NOTE: RAV does not like '</dev/null' in its command!

    ll(3) && do_log(3, "Using (%s): %s", $av_name, join(' ',$command,@args));
    my($remaining_time) = alarm(0);  # check time left, stop the timer
    my($dt) = max(10, int(2 * $remaining_time / 3));
    alarm($dt);  do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time);
    my($proc_fh,$pid); my($child_stat);
    eval {
      ($proc_fh,$pid) = run_command(undef, "&1", $command, @args);
      my($nbytes,$buff);
      while (($nbytes=$proc_fh->read($buff,4096)) > 0) { $output .= $buff }
      defined $nbytes or die "Error reading: $!";
      my($err) = 0; $proc_fh->close or $err=$!; undef $proc_fh; undef $pid;
      $child_stat = $?; $error_str = exit_status_str($?,$err);
    };
    my($eval_stat) = $@;
    prolong_timer('run_av', $remaining_time-($dt-alarm(0)));  # restart timer
    if ($eval_stat ne '') {
      chomp($eval_stat);
      if (defined $pid) {
        do_log(-1, "%s is taking longer than %d s and will be killed",
                   $command, $dt)  if $eval_stat eq "timed out";
        kill_proc($pid,$command,1,$proc_fh);  undef $pid;
      }
      do_log(-1, "run_av: %s", $eval_stat);
      $error_str = $eval_stat;
    }
    chomp($output); my($output_trimmed) = $output;
    $output_trimmed =~ s/\r\n/\n/gs;
    $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: %s %s, %s", $command,$error_str,$output_trimmed);
    my($retval);
    $retval = WEXITSTATUS($child_stat)  if defined $child_stat;
    # braindead Perl: ""=~/x{0}/ serves as explicit default for an empty regexp
    if (!defined($child_stat) || !WIFEXITED($child_stat)) {
      # leave $scan_status undefined
    } elsif (defined $sts_infected && (
             ref($sts_infected) eq 'ARRAY'
                  ? (grep {$_==$retval} @$sts_infected)
                  : ""=~/x{0}/ && $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)
                          : ""=~/x{0}/ && $output=~/$how_to_get_names/gm;
      @$virusnames = map { defined $_ ? $_ : () } @$virusnames;
      $scan_status = 1;  # 'true' indicates virus found
      do_log(2,"run_av (%s): INFECTED: %s", $av_name, join(", ",@$virusnames));
    } elsif (!defined($sts_clean)) {  # clean, but inconclusive
      # by convention: undef $sts_clean means result is inconclusive,
      # file appears clean, but continue scanning with other av scanners,
      # the current scanner does not want to vouch for it; useful for a
      # scanner like jpeg checker which tests for one vulnerability only
      do_log(3,"run_av (%s): clean, but inconclusive", $av_name);
    } elsif (ref($sts_clean) eq 'ARRAY' ? (grep {$_==$retval} @$sts_clean)
                          : ""=~/x{0}/ && $output=~/$sts_clean/m) {  # is clean
      $scan_status = 0;  # 'false' (but defined) indicates no viruses
      do_log(3,"run_av (%s): CLEAN", $av_name);
    } else {
      $error_str = "unexpected $error_str, output=\"$output_trimmed\"";
      do_log(-2,"run_av (%s) FAILED - %s", $av_name,$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,$parts_root) = @_;
  my($scan_status,$output,@virusname,@detecting_scanners);
  my($anyone_done); my($anyone_tried);
  my($bare_fnames_ref,$names_to_parts);
  my(@errors); my($j); my($tier) = 'primary';
  for my $av (@{ca('av_scanners')}, "\000", @{ca('av_scanners_backup')}) {
    next  if !defined $av;
    if ($av eq "\000") {  # 'magic' separator between lists
      last  if $anyone_done;
      do_log(-2,"WARN: all %s virus scanners failed, considering backups",
                $tier);
      $tier = 'secondary';  next;
    }
    next  if !ref $av || !defined $av->[1];
    if (!defined $bare_fnames_ref) {  # first time: collect file names to scan
      ($bare_fnames_ref,$names_to_parts) =
        files_to_scan("$tempdir/parts",$parts_root);
      do_log(2, "Not calling virus scanners, no files to scan in %s/parts",
                $tempdir)  if !@$bare_fnames_ref;
    }
    $anyone_tried++; my($this_status,$this_output,$this_vn);
    if (!@$bare_fnames_ref) {  # no files to scan?
      ($this_status,$this_output,$this_vn) = (0, '', []);  # declare clean
    } else {  # call virus scanner
      eval {
        ($this_status,$this_output,$this_vn) =
          run_av($bare_fnames_ref,$names_to_parts,$tempdir, @$av);
      };
      if ($@ ne '') {
        my($err) = $@; chomp($err);
        $err = "$av->[0] av-scanner FAILED: $err";
        do_log(-2,"%s",$err); push(@errors,$err);
        $this_status = undef;
      };
    }
    $anyone_done++  if defined $this_status;
    $j++; section_time("AV-scan-$j");
    if ($this_status) {  # virus detected by this scanner
      push(@detecting_scanners, $av->[0]);
      if (!@virusname) { # store results of the first scanner detecting
        @virusname = @$this_vn;
        $scan_status = $this_status; $output = $this_output;
      }
      last  if c('first_infected_stops_scan');  # stop now if we found a virus?
    } elsif (!defined($scan_status)) {  # tentatively keep regardless of status
      $scan_status = $this_status; $output = $this_output;
    }
  }
  if (@virusname && @detecting_scanners) {
    my(@ds) = @detecting_scanners;  for (@ds) { s/,/;/ }  # facilitates parsing
    ll(2) && do_log(2, "virus_scan: (%s), detected by %d scanners: %s",
                      join(', ',@virusname), scalar(@ds), join(', ',@ds));
  }
  $output =~ s{\Q$tempdir\E/parts/?}{}gs  if defined $output;  # hide path info
  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
}

# return a ref to a list of files to be scanned in a given directory
sub files_to_scan($$) {
  my($dir,$parts_root) = @_;
  my($names_to_parts) = {};  # a hash that maps base file names
                             # to Amavis::Unpackers::Part object
  # traverse decomposed parts tree breadth-first, match it to actual files
  for (my($part), my(@unvisited)=($parts_root);
       @unvisited and $part=shift(@unvisited);
       push(@unvisited,@{$part->children}))
    { $names_to_parts->{$part->base_name} = $part  if $part ne $parts_root }
  my($bare_fnames_ref) = []; my(%bare_fnames);
  local(*DIR); opendir(DIR,$dir) or die "Can't open directory $dir: $!";
  my(@dirfiles) = readdir(DIR); # must avoid modifying dir. while traversing it
  closedir(DIR) or die "Error closing directory $dir: $!";
  # traverse parts directory and check for actual files
  for my $f (@dirfiles) {
    my($fname) = "$dir/$f";
    my($errn) = lstat($fname) ? 0 : 0+$!;
    next  if $errn == ENOENT;
    if ($errn) { die "files_to_scan: file $fname inaccessible: $!" }
    if (!-r _) {  # attempting to gain read access to the file
      do_log(3,"files_to_scan: attempting to gain read access to %s", $fname);
      chmod(0750,untaint($fname))
        or die "files_to_scan: Can't change protection on $fname: $!";
      $errn = lstat($fname) ? 0 : 0+$!;
      if ($errn) { die "files_to_scan: file $fname inaccessible: $!" }
      if (!-r _) { die "files_to_scan: file $fname not readable" }
    }
    next  if ($f eq '.' || $f eq '..') && -d _;  # this or the parent directory
    if (!-f _ || !exists $names_to_parts->{$f}) { # nonregular f. or unexpected
      my($what) = -l _ ? 'symlink' : -d _ ? 'directory' : -f _ ? 'file'
                 : 'non-regular file';
      my($msg) = "removing unexpected $what $fname";
      $msg .= ", it has no corresponding parts object"
        if !exists $names_to_parts->{$f};
      do_log(-1, "WARN: files_to_scan: %s", $msg);
      if (-d _) { rmdir_recursively(untaint($fname)) }
      else { unlink(untaint($fname)) or die "Can't delete $what $fname: $!" }
    } elsif (-z _) {
      # empty file
    } else {
      if ($f !~ /^[A-Za-z0-9_.-]+\z/s) {
        do_log(-1,"WARN: files_to_scan: unexpected/suspicious file name: %s",
                  $f);
      }
      push(@$bare_fnames_ref,$f); $bare_fnames{$f} = 1;
    }
  }
  # remove entries from %$names_to_parts that have no corresponding files
  my($fname,$part);
  while ( ($fname,$part) = each %$names_to_parts ) {
    next  if exists $bare_fnames{$fname};
    if (ll(4) && $part->exists) {
      my($type_short) = $part->type_short;
      do_log(4,"files_to_scan: info: part %s (%s) no longer present",
          $fname, (!ref $type_short ? $type_short : join(', ',@$type_short)) );
    }
    delete $names_to_parts->{$fname}; # delete is allowed for the current elem.
  }
  ($bare_fnames_ref, $names_to_parts);
}

1;

__DATA__
#
package Amavis::SpamControl;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

BEGIN {
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Util qw(ll do_log untaint);
  import Amavis::Lookup qw(lookup);
  import Amavis::rfc2821_2822_Tools qw(make_query_keys);
}

use vars qw($scanner_obj);

# called at startup, before chroot and before main fork
sub init_pre_chroot() {
  if (! $Amavis::extra_code_antispam_sa) {
    do_log(0, "SpamControl: antispam_SA code not loaded, no spam scanning");
    $scanner_obj = undef;
  } else {
    $scanner_obj = Amavis::SpamControl::SpamAssassin->new;
  }
  if ($scanner_obj) {
    $scanner_obj->init_pre_chroot;
    do_log(1, "SpamControl: init_pre_chroot done");
  }
}

# called at startup, after chroot and changing UID, but before main fork
sub init_pre_fork() {
  if ($scanner_obj) {
    $scanner_obj->init_pre_fork;
    do_log(1, "SpamControl: init_pre_fork done");
  }
}

# returns an array of values: ($spam_level)
# throws exception (die) in case of errors,
# or just returns undef if it did not complete its jobs
sub spam_scan($$) {
  my($conn,$msginfo) = @_;
  if (!$scanner_obj) {
    do_log(5, "SpamControl: no spam scanners available");
  } else {
    do_log(5, "SpamControl: calling spam scanner");
    $scanner_obj->check($msginfo);
  }
}

# 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,$ldap_policy) = @_;
  my($any_w)=0; my($any_b)=0; my($all)=1; my($wr,$br);
  my($sender) = $msginfo->sender;
  do_log(4,"wbl: checking sender <%s>", $sender);
  for my $r (@{$msginfo->per_recip_data}) {
    next  if $r->recip_done;  # already dealt with
    my($found,$wb,$boost); my($recip) = $r->recip_addr;
    my($user_id_ref,$mk_ref) = !defined $sql_wblist ? ([],[])
                                 : lookup(1,$recip,$user_id_sql);
    do_log(5,"wbl: (SQL) recip <%s>, %s matches",
             $recip, scalar(@$user_id_ref))  if defined $sql_wblist && ll(5);
    for my $ind (0..$#{$user_id_ref}) {  # for ALL SQL sets matching the recip
      my($user_id) = $user_id_ref->[$ind];  my($mkey);
      ($wb,$mkey) = lookup(0,$sender,
                Amavis::Lookup::SQLfield->new($sql_wblist,'wb','S',$user_id) );
      do_log(4,'wbl: (SQL) recip <%s>, rid=%s, got: "%s"',
               $recip,$user_id,$wb);
      if (!defined($wb)) {  # NULL field or no match: remains undefined
      } elsif ($wb =~ /^ *([+-]?\d+(?:\.\d*)?) *\z/) {  # numeric
        my($val) = 0+$1;    # penalty points to be added to the score
        $boost += $val;
        ll(2) && do_log(2,
                  'wbl: (SQL) soft-%slisted (%s) sender <%s> => <%s> (rid=%s)',
                  ($val<0?'white':'black'), $val, $sender, $recip, $user_id);
        $wb = undef;  # not hard- white or blacklisting
      } elsif ($wb =~ /^[ \000]*\z/) {        # neutral, stops the search
        $found++; $wb = 0;
        do_log(5, 'wbl: (SQL) recip <%s> is neutral to sender <%s>',
                  $recip,$sender);
      } elsif ($wb =~ /^([BbNnFf])[ ]*\z/) {  # blacklisted (B, N, F)
        $found++; $wb = -1; $any_b++; $br = $recip;
        $r->recip_blacklisted_sender(1);
        do_log(5, 'wbl: (SQL) recip <%s> blacklisted sender <%s>',
                  $recip,$sender);
      } else {                         # whitelisted (W, Y, T) or anything else
        if ($wb =~ /^([WwYyTt])[ ]*\z/) {
          do_log(5, 'wbl: (SQL) recip <%s> whitelisted sender <%s>',
                    $recip,$sender);
        } else {
          do_log(-1,'wbl: (SQL) recip <%s> whitelisted sender <%s>, '.
                    'unexpected wb field value: "%s"', $recip,$sender,$wb);
        }
        $found++; $wb = +1; $any_w++; $wr = $recip;
        $r->recip_whitelisted_sender(1);
      }
      last  if $found;
    }
    if (!$found && defined($ldap_policy)) {
      my($wblist);
      my($keys_ref,$rhs_ref) = make_query_keys($sender,0,0);
      my(@keys) = @$keys_ref;
      unshift(@keys, '<>')  if $sender eq '';  # a hack for a null return path
      $_ = untaint($_) for @keys; # untaint keys
      $_ = Net::LDAP::Util::escape_filter_value($_) for @keys;
      do_log(5,'wbl: (LDAP) query keys: %s', join(', ',map{"\"$_\""}@keys));
      $wblist = lookup(0,$recip,Amavis::Lookup::LDAPattr->new(
                                  $ldap_policy,'amavisBlacklistSender','L-'));
      for my $key (@keys) {
        if (grep {/^\Q$key\E\z/i} @$wblist) {
          $found++; $wb = -1; $br = $recip; $any_b++;
          $r->recip_blacklisted_sender(1);
          do_log(5,'wbl: (LDAP) recip <%s> blacklisted sender <%s>',
                   $recip,$sender);
        }
      }
      $wblist = lookup(0,$recip,Amavis::Lookup::LDAPattr->new(
                                  $ldap_policy,'amavisWhitelistSender','L-'));
      for my $key (@keys) {
        if (grep {/^\Q$key\E\z/i} @$wblist) {
          $found++; $wb = +1; $wr = $recip; $any_w++;
          $r->recip_whitelisted_sender(1);
          do_log(5,'wbl: (LDAP) recip <%s> whitelisted sender <%s>',
                   $recip,$sender);
        }
      }
    }
    if (!$found) {  # fall back to static lookups if no match
      # sender can be both white- and blacklisted at the same time
      my($val); my($r_ref,$mk_ref,@t);

      # NOTE on the specifics of $per_recip_blacklist_sender_lookup_tables :
      # the $r_ref below is supposed to be a ref to a single lookup table
      # for compatibility with pre-2.0 versions of amavisd-new;
      # Note that this is different from @score_sender_maps, which is
      # supposed to contain a ref to a _list_ of lookup tables as a result
      # of the first-level lookup (on the recipient address as a key).
      #
      ($r_ref,$mk_ref) = lookup(0,$recip,
                         Amavis::Lookup::Label->new("blacklist_recip<$recip>"),
                         cr('per_recip_blacklist_sender_lookup_tables'));
      @t = ( (defined $r_ref ? $r_ref : ()), @{ca('blacklist_sender_maps')} );
      $val = lookup(0,$sender,
                    Amavis::Lookup::Label->new("blacklist_sender<$sender>"),
                    @t)  if @t;
      if ($val) {
        $found++; $wb = -1; $br = $recip; $any_b++;
        $r->recip_blacklisted_sender(1);
        do_log(5,'wbl: recip <%s> blacklisted sender <%s>', $recip,$sender);
      }
      # similar for whitelists:
      ($r_ref,$mk_ref) = lookup(0,$recip,
                         Amavis::Lookup::Label->new("whitelist_recip<$recip>"),
                         cr('per_recip_whitelist_sender_lookup_tables'));
      @t = ( (defined $r_ref ? $r_ref : ()), @{ca('whitelist_sender_maps')} );
      $val = lookup(0,$sender,
                    Amavis::Lookup::Label->new("whitelist_sender<$sender>"),
                    @t)  if @t;
      if ($val) {
        $found++; $wb = +1; $wr = $recip; $any_w++;
        $r->recip_whitelisted_sender(1);
        do_log(5,'wbl: recip <%s> whitelisted sender <%s>', $recip,$sender);
      }
    }
    if (!defined($boost)) {        # static lookups if no match
      # note the first argument of lookup() is true, requesting ALL matches
      my($r_ref,$mk_ref) = lookup(1,$recip,
                             Amavis::Lookup::Label->new("score_recip<$recip>"),
                             @{ca('score_sender_maps')});
      for my $j (0..$#{$r_ref}) {  # for ALL tables matching the recipient
        my($val,$key) = lookup(0,$sender,
                           Amavis::Lookup::Label->new("score_sender<$sender>"),
                           @{$r_ref->[$j]} );
        if (defined $val && $val != 0) {
          $boost += $val;
          ll(2) && do_log(2,'wbl: soft-%slisted (%s) sender <%s> => <%s>, '.
                            'recip_key="%s"', ($val<0?'white':'black'),
                            $val, $sender, $recip, $mk_ref->[$j]);
        }
      }
    }
    $r->recip_score_boost($boost)  if defined $boost;
    $all = 0  if !$wb;
  }
  if (!ll(2)) {
    # don't bother preparing log report which will not be printed
  } else {
    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,"wbl: %s sender <%s>", $msg,$sender)  if $msg ne '';
  }
  ($any_w+$any_b, $all);
}

1;

__DATA__
#
package Amavis::SpamControl::SpamAssassin;
use strict;
use re 'taint';
no warnings 'uninitialized';

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

BEGIN {
  import Amavis::Conf qw(:platform :sa $daemon_user c cr ca);
  import Amavis::Util qw(ll do_log sanitize_str run_command
                         prolong_timer min max add_entropy
                         exit_status_str proc_status_ok kill_proc);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Timing qw(section_time);
  import Amavis::Lookup qw(lookup);
  import Amavis::Lookup::IP qw(lookup_ip_acl);
}

use subs @EXPORT_OK;

sub getCommonSAModules {
  my($self) = shift;
  my(@modules) = qw(
    Mail::SpamAssassin::Locker::Flock
    Mail::SpamAssassin::Locker::UnixNFSSafe
    Mail::SpamAssassin::DBBasedAddrList
    Mail::SpamAssassin::SQLBasedAddrList
    Mail::SpamAssassin::PersistentAddrList
    Mail::SpamAssassin::PerMsgLearner
    Mail::SpamAssassin::AutoWhitelist
    Mail::SpamAssassin::BayesStore::DBM
    Mail::SpamAssassin::BayesStore::SQL
    Mail::SpamAssassin::Plugin::Hashcash
    Mail::SpamAssassin::Plugin::RelayCountry
    Mail::SpamAssassin::Plugin::SPF
    Mail::SpamAssassin::Plugin::URIDNSBL

    DBD::mysql Sys::Hostname::Long
    Mail::SPF::Query Razor2::Client::Agent 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
  );
  # ??? ArchiveIterator Reporter Data::Dumper Getopt::Long Sys::Syslog lib
  # Mail::SpamAssassin::BayesStore::SDBM
  @modules;
}

sub getSA2Modules {
  my($self) = shift;
  my(@modules) = qw(
    Mail::SpamAssassin::UnixLocker Mail::SpamAssassin::BayesStoreDBM
    Mail::SpamAssassin::SpamCopURI
    URI URI::Escape URI::Heuristic URI::QueryParam URI::Split URI::URL
    URI::WithBase URI::_foreign URI::_generic URI::_ldap URI::_login
    URI::_query URI::_segment URI::_server URI::_userpass URI::data URI::ftp
    URI::gopher URI::http URI::https URI::ldap URI::ldapi URI::ldaps
    URI::mailto URI::mms URI::news URI::nntp URI::pop URI::rlogin URI::rsync
    URI::rtsp URI::rtspu URI::sip URI::sips URI::snews URI::ssh URI::telnet
    URI::tn3270 URI::urn URI::urn::isbn URI::urn::oid
    URI::file URI::file::Base URI::file::Unix URI::file::Win32
  );
  @modules;
}

sub getSA31Modules {
  my($self) = shift;
  my(@modules) = qw(
    Mail::SpamAssassin::BayesStore::MySQL
    Mail::SpamAssassin::Plugin::AutoLearnThreshold
    Mail::SpamAssassin::Plugin::ReplaceTags
    Mail::SpamAssassin::Plugin::MIMEHeader
    Mail::SpamAssassin::Plugin::AWL Mail::SpamAssassin::Plugin::DCC
    Mail::SpamAssassin::Plugin::Pyzor Mail::SpamAssassin::Plugin::Razor2
    Mail::SpamAssassin::Plugin::SpamCop
    Mail::SpamAssassin::Plugin::WhiteListSubject
    Mail::SpamAssassin::Plugin::DomainKeys
    Mail::DomainKeys::Header Mail::DomainKeys::Message
    Mail::DomainKeys::Policy Mail::DomainKeys::Signature
    Mail::DomainKeys::Key Mail::DomainKeys::Key::Public
    Crypt::OpenSSL::RSA auto::Crypt::OpenSSL::RSA::new_public_key
    auto::Crypt::OpenSSL::RSA::load_public_key
    auto::Crypt::OpenSSL::RSA::_new auto::Crypt::OpenSSL::RSA::DESTROY
    IP::Country::Fast
  );
  # BayesStore::PgSQL BayesStore::SDBM
  # Plugin::AntiVirus Plugin::DomainKeys Plugin::NetCache Plugin::TextCat
  @modules;
}

sub loadSpamAssassinModules {
  my($self) = shift;
  # must be loaded before chroot takes place
  my(@modules) = $self->getCommonSAModules;
  my($sa_version) = $self->sa_version;  # could be 3.0.1, which is not numeric!
  if (!defined($sa_version)) {
    die "loadSpamAssassinModules: unknown version of Mail::SpamAssassin";
  } elsif ($sa_version=~/^(\d+(?:\.\d+)?)/ && $1 < 3) {
    push(@modules, $self->getSA2Modules);
  } elsif ($sa_version=~/^(\d+(?:\.\d+)?)/ && $1 >= 3.1) {
    push(@modules, $self->getSA31Modules);
  }
  my($missing) = Amavis::Boot::fetch_modules('PRE-COMPILE OPTIONAL MODULES', 0,
                                             @modules)  if @modules;
  do_log(2, 'INFO: no optional modules: '.join(' ',@$missing))
    if ref $missing && @$missing;
}

sub initializeSpamAssassin {
  my($self) = shift;
  do_log(1, "SpamControl: initializing Mail::SpamAssassin");
  my($saved_umask) = umask;
  my($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
  });
# $Mail::SpamAssassin::DEBUG->{rbl}=-3;
# $Mail::SpamAssassin::DEBUG->{dcc}=-3;
# $Mail::SpamAssassin::DEBUG->{pyzor}=-3;
# $Mail::SpamAssassin::DEBUG->{bayes}=-3;
# $Mail::SpamAssassin::DEBUG->{rulesrun}=4+64;
  my($sa_version) = $self->sa_version;
  if ($sa_auto_whitelist && $sa_version=~/^(\d+(?:\.\d+)?)/ && $1 < 3) {
    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;     # try to ensure modules are preloaded
  alarm(0);              # seems like SA forgets to clear alarm in some cases
  umask($saved_umask);   # restore our umask, SA clobbered it
  $self->{'spamassassin_obj'} = $spamassassin_obj;
}

sub sa_version {
  my($self) = shift;
  !@_ ? $self->{'sa_version'} : ($self->{'sa_version'}=shift);
}

sub new {
  my($class) = shift; 
  my($self) = bless({}, $class);
  $self->{'initialized_stage'} = 1;
  $self->{'spamassassin_obj'} = undef;
  $self->{'sa_version'} = Mail::SpamAssassin::Version();
  $self;
}

sub init_pre_chroot {
  my($self) = shift;
  $self->loadSpamAssassinModules;
  $self->{'initialized_stage'} == 1
    or die "Wrong initialization sequence: " . $self->{'initialized_stage'};
  $self->{'initialized_stage'} = 2;
}

sub init_pre_fork {
  my($self) = shift;
  $self->initializeSpamAssassin;
  $self->{'initialized_stage'} == 2
    or die "Wrong initialization sequence: " . $self->{'initialized_stage'};
  $self->{'initialized_stage'} = 3;
}

sub check {
  my($self,$msginfo) = @_;
  my($spamassassin_obj) = $self->{'spamassassin_obj'};
  my($dspam_signature,$dspam_result,$dspam_fname);
  my($which_section); my(@lines);
  my($spam_level,$sa_tests,$spam_report,$spam_summary,$autolearn_status);
  my($fh) = $msginfo->mail_text;
  my($hdr_edits) = $msginfo->header_edits;
  if (!$hdr_edits) {
    $hdr_edits = Amavis::Out::EditHeader->new;
    $msginfo->header_edits($hdr_edits);
  }
  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($os_fp) = $msginfo->client_os_fingerprint;
  push(@lines, sprintf("X-Amavis-OS-Fingerprint: %s\n",
                       sanitize_str($os_fp)))  if $os_fp ne '';
  my($mbsl) = c('sa_mail_body_size_limit');
  if ( defined $mbsl &&
       ($msginfo->orig_body_size > $mbsl ||
        $msginfo->msg_size > 5*1024 + $mbsl)
     ) {
    do_log(1,"spam_scan: not wasting time on SA, ".
             "message longer than %s bytes: %s+%s",
             $mbsl, $msginfo->orig_header_size, $msginfo->orig_body_size);
  } else {
    if (!defined($dspam) || $dspam eq '') {
      do_log(5,"spam_scan: DSPAM not available, skipping it");
    } else {
      $which_section = 'DSPAM';
      # 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;  # will receive output from DSPAM
      $dspam_fh->open($dspam_fname, O_CREAT|O_EXCL|O_WRONLY, 0640)
        or die "Can't create file $dspam_fname: $!";
      $fh->seek(0,0) or die "Can't rewind mail file: $!";
      no warnings qw(qw);
      my($proc_fh,$pid) = run_command('&'.fileno($fh), "&1", $dspam,
              qw(--stdout --deliver=spam,innocent
                 --mode=tum --feature=chained,noise
                 --enable-signature-headers
                 --user), $daemon_user,
            );  # --mode=teft
            # qw(--stdout --deliver-spam)  # dspam < 3.0
      # keep X-DSPAM-*, ignore other changes e.g. Content-Transfer-Encoding
      my($all_local) = !grep { !lookup(0,$_,@{ca('local_domains_maps')}) }
                             @{$msginfo->recips};
      my($first_line); my($ln);
      # scan mail header from DSPAM
      for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
        $dspam_fh->print($ln) or die "Can't write to $dspam_fname: $!";
        if (!defined($first_line)) {
          $first_line = $ln;
          do_log(5,"spam_scan: from DSPAM: %s", $first_line);
        }
        last  if $ln eq $eol;
        local($1,$2);
        if ($ln =~ /^(X-DSPAM[^:]*):[ \t]*(.*)$/) {  # does not handle folding
          my($hh,$hb) = ($1,$2);
          $dspam_signature = $hb  if $ln =~ /^X-DSPAM-Signature:/i;
          $dspam_result    = $hb  if $ln =~ /^X-DSPAM-Result:/i;
          do_log(3,"%s",$ln);
          push(@lines,$ln);  # store header in array passed to SA
          # add DSPAM header fields to passed mail for all recipients
          $hdr_edits->add_header($hh,$hb)  if $all_local;
        }
      }
      defined $ln || $!==0 || $!==EAGAIN
        or die "Error reading from DSPAM process: $!";
      my($nbytes,$buff);
      while (($nbytes=$proc_fh->read($buff,16384)) > 0) { #copy body from DSPAM
        $dspam_fh->print($buff) or die "Can't write to $dspam_fname: $!";
      }
      defined $nbytes or die "Error reading: $!";
      my($err) = 0; $proc_fh->close or $err = $!; my($retval) = $?;
      $dspam_fh->close or die "Error closing $dspam_fname: $!";
      proc_status_ok($retval,$err) && defined $first_line
        or do_log(-1,"WARN: DSPAM problem, %s, result=%s",
                     exit_status_str($retval,$err), $first_line);
      do_log(4,"spam_scan: DSPAM gave: %s, %s",
               $dspam_signature,$dspam_result);
      section_time($which_section);
    }

    $which_section = 'SA msg read';
    # read mail into memory (horror!) in preparation for SpamAssasin
    $fh->seek(0,0) or die "Can't rewind mail file: $!";
    my($body_lines)=0; my($ln);
    for ($! = 0; defined($ln=<$fh>); $! = 0)   # header
      { push(@lines,$ln); last if $ln eq $eol }
    defined $ln || $!==0  or die "Error reading mail header: $!";
    for ($! = 0; defined($ln=<$fh>); $! = 0)   # body
      { push(@lines,$ln); $body_lines++ }
    defined $ln || $!==0  or die "Error reading mail body: $!";
    section_time($which_section);

    my($per_msg_status);
    my($saved_umask) = umask; my($saved_pid) = $$;
    my($start_time) = time;  # SA may use timer for its own purposes, get time
    my($remaining_time) = alarm(0);  # check time left, stop the timer
    eval {
      $which_section = 'SA parse';
      # 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(-1,"%s",$s);
      };
      my($dt) = max(10, int(2 * $remaining_time / 3));
      $dt = $sa_timeout  if $sa_timeout > $dt;
      alarm($dt);
      do_log(5,"timer set to %d s for SA (was %d s)", $dt,$remaining_time);
      my($mail_obj); my($sa_version) = $self->sa_version;
      do_log(5,"calling SA parse, SA version %s", $sa_version);
      # *** note that $sa_version could be 3.0.1, which is not really numeric!
      if ($sa_version=~/^(\d+(?:\.\d+)?)/ && $1 >= 3) {
        $mail_obj = $spamassassin_obj->parse(\@lines);
      } else {  # 2.63 or earlier
        $mail_obj = Mail::SpamAssassin::NoMailAudit->new(data => \@lines,
                                                         add_From_line => 0);
      }
      section_time($which_section);

      $which_section = 'SA check';
      do_log(4,"CALLING SA check");
      { local($1,$2,$3,$4,$5,$6);  # avoid Perl 5.8.0 bug, $1 gets tainted
        $per_msg_status = $spamassassin_obj->check($mail_obj);
      }
      section_time($which_section);

      $which_section = 'SA collect';
      { local($1,$2,$3,$4);  # avoid Perl 5.8.0..5.8.3...? taint bug
        if ($sa_version=~/^(\d+(?:\.\d+)?)/ && $1 >= 3) {
          $spam_level  = $per_msg_status->get_score;
          $sa_tests = $per_msg_status->get_tag('TESTSSCORES',',');
          $autolearn_status = $per_msg_status->get_autolearn_status;
        } else {
          $spam_level  = $per_msg_status->get_hits;
          $sa_tests = $per_msg_status->get_names_of_tests_hit;  # only names
        }
        $spam_summary = $per_msg_status->get_report;  # taints $1 and $2 !
      # $spam_summary = $per_msg_status->get_tag('SUMMARY');
        $spam_report  = $per_msg_status->get_tag('REPORT');

        #example of how to obtain aditional information from SA:
        # my($trusted) = $per_msg_status->get_tag('RELAYSTRUSTED');
        # $hdr_edits->add_header('X-TESTING',$trusted);

        #Experimental, never finished:
        # $per_msg_status->rewrite_mail;
        # my($entity) = nomailaudit_to_mime_entity($mail_obj);
      }
    };
    my($eval_stat) = $@;
    # section_time($which_section);  # don't bother reporting separately, short

    $which_section = 'SA finish';
    prolong_timer('spam_scan_sa_finish',
      max(20, $remaining_time - max(0,time-$start_time)));  # restart the timer
    if (defined $per_msg_status)
      { $per_msg_status->finish; undef $per_msg_status }
    if ($$ != $saved_pid) {
      eval { do_log(-2,"PANIC, SA produced a clone process ".
                       "of [%s], TERMINATING CLONE [%s]", $saved_pid,$$) };
      POSIX::_exit(1);  # avoid END and destructor processing
    }
    umask($saved_umask);  # SA changes umask to 0077
    section_time($which_section);

    if ($eval_stat ne '') {  # SA timed out?
      chomp($eval_stat);
      die "$eval_stat\n"  if $eval_stat ne "timed out";
    }
    if (defined $dspam && $dspam ne '' && defined $spam_level) {  # auto-learn
      $which_section = 'DSPAM learn';
      my($eat,@options);
      @options = (qw(--stdout --mode=tum --user), $daemon_user);  # --mode=teft
      if (   $spam_level >  7.0 && $dspam_result eq 'Innocent') {
        $eat = 'SPAM'; push(@options, qw(--class=spam --source=error));
      }
      elsif ($spam_level <  0.5 && $dspam_result eq 'Spam') {
        $eat = 'HAM'; push(@options, qw(--class=innocent --source=error));
      }
      if (defined $eat && $dspam_signature ne '') {
        do_log(2,"DSPAM learn %s (%s), %s", $eat,$spam_level,$dspam_signature);
        my($proc_fh,$pid) = run_command($dspam_fname, "&1", $dspam, @options);
        # consume remaining output to avoid broken pipe
        my($nbytes,$buff);
        while (($nbytes=$proc_fh->read($buff,4096)) > 0) { }
        defined $nbytes or die "Error reading from DSPAM process: $!";
        my($err) = 0; $proc_fh->close or $err = $!; my($retval) = $?;
#       do_log(-1,"DSPAM learn %s response: %s",$eat,$output) if $output ne '';
        proc_status_ok($retval,$err)
          or die("DSPAM learn $eat FAILED: ".exit_status_str($retval,$err));
      }
      section_time($which_section);
    }
  }
  if (defined $dspam_fname) {
    if (($spam_level > 5.0 ? 1 : 0) != ($dspam_result eq 'Spam' ? 1 : 0)) {
      do_log(2,"DSPAM: different opinions: %s, %s", $dspam_result,$spam_level);
    }
    unlink($dspam_fname) or die "Can't delete file $dspam_fname: $!";
  }
  add_entropy($spam_level,$sa_tests);
  do_log(2,"OS_fingerprint: %s %s %s", $msginfo->client_addr,
           defined $spam_level ? $spam_level : '-', $os_fp)  if $os_fp ne '';
  do_log(3,"spam_scan: score=%s tests=[%s]", $spam_level,$sa_tests);
  $msginfo->spam_level($spam_level); $msginfo->spam_status($sa_tests);
  $msginfo->spam_report($spam_report); $msginfo->spam_summary($spam_summary);
  $msginfo->autolearn_status($autolearn_status);
  $spam_level;
}

#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';
no warnings 'uninitialized';

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.062';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&init &decompose_part &determine_file_types);
}
use Errno qw(ENOENT EACCES EAGAIN);
use IO::File qw(O_CREAT O_EXCL O_WRONLY);
use File::Basename qw(basename);
use Convert::TNEF;
use Convert::UUlib 1.05 qw(:constants);  # avoid security bug in 1.04 and older
use Compress::Zlib 1.35;  # avoid security vulnerability in <= 1.34
use Archive::Tar;
use Archive::Zip 1.14 qw(:CONSTANTS :ERROR_CODES);

BEGIN {
  import Amavis::Util qw(untaint min max ll do_log sanitize_str run_command
                         exit_status_str proc_status_ok kill_proc snmp_count
                         prolong_timer rmdir_recursively add_entropy);
  import Amavis::Conf qw(:platform :confvars $file c cr ca);
  import Amavis::Timing qw(section_time);
  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 a pair: number of bytes that 'sanitized' files now occupy,
# and a number of parts objects created.
#
sub flatten_and_tidy_dir($$$;$$);  # prototype
sub flatten_and_tidy_dir($$$;$$) {
  my($dir, $outdir, $parent_obj, $item_num_offset, $orig_names) = @_;
  do_log(4, 'flatten_and_tidy_dir: processing directory "%s"', $dir);
  my($cnt_r,$cnt_u) = (0,0); my($consumed_bytes) = 0;
  my($item_num) = 0; my($parent_placement) = $parent_obj->mime_placement;
  chmod(0750, $dir) or die "Can't change protection of \"$dir\": $!";
  local(*DIR); opendir(DIR,$dir) or die "Can't open directory \"$dir\": $!";
  my(@dirfiles) = readdir(DIR); # must avoid modifying dir. while traversing it
  closedir(DIR) or die "Error closing directory \"$dir\": $!";
  for my $f (@dirfiles) {
    my($msg);  my($fname) = "$dir/$f";
    my(@stat_list) = lstat($fname); my($errn) = @stat_list ? 0 : 0+$!;
    if    ($errn == ENOENT) { $msg = "does not exist" }
    elsif ($errn)           { $msg = "inaccessible: $!" }
    if (defined $msg) { die "flatten_and_tidy_dir: \"$fname\" $msg," }
    next  if ($f eq '.' || $f eq '..') && -d _;
    add_entropy(@stat_list);
    my($newpart_obj) = Amavis::Unpackers::Part->new($outdir,$parent_obj);
    $item_num++;
    $newpart_obj->mime_placement(sprintf("%s/%d",$parent_placement,
                                                 $item_num+$item_num_offset) );
    # save tainted original member name if available, or a tainted file name
    my($original_name) = !ref($orig_names) ? undef : $orig_names->{$f};
    $newpart_obj->name_declared(defined $original_name ? $original_name : $f);
    # untaint, but if $dir happens to still be tainted, we want to know and die
    $fname = $dir.'/'.untaint($f);
    if (-d _) {
      $newpart_obj->attributes_add('D');
      my($bytes,$cnt) = flatten_and_tidy_dir($fname, $outdir, $parent_obj,
                                      $item_num+$item_num_offset, $orig_names);
      $consumed_bytes += $bytes; $item_num += $cnt;
    } elsif (-l _) {
      $cnt_u++; $newpart_obj->attributes_add('L');
      unlink($fname) or die "Can't remove soft link \"$fname\": $!";
    } elsif (!-f _) {
      do_log(4, 'flatten_and_tidy_dir: NONREGULAR FILE "%s"', $fname);
      $cnt_u++; $newpart_obj->attributes_add('S');
      unlink($fname) or die "Can't remove nonregular file \"$fname\": $!";
    } elsif (-z _) {
      $cnt_u++;
      unlink($fname) or die "Can't remove empty file \"$fname\": $!";
    } else {
      chmod(0750, $fname)
        or die "Can't change protection of file \"$fname\": $!";
      my($size) = 0 + (-s _);
      $newpart_obj->size($size);
      $consumed_bytes += $size;
      my($newpart) = $newpart_obj->full_name;
      ll(5) && do_log(5,'flatten_and_tidy_dir: renaming "%s"%s to %s', $fname,
                !defined $original_name ? '' : " ($original_name)", $newpart);
      $cnt_r++;
      rename($fname, $newpart)
        or die "Can't rename \"$fname\" to $newpart: $!";
    }
  }
  rmdir($dir) or die "Can't remove directory \"$dir\": $!";
  section_time("ren$cnt_r-unl$cnt_u-files$item_num");
  ($consumed_bytes, $item_num);
}

# 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) =   # collect full file names, remove cwd if possible
      map { my($n) = $_->full_name; $n =~ s{^\Q$cwd\E/(.*)\z}{$1}s; $n }
      @part_list;
    chdir($cwd) or die "Can't chdir to $cwd: $!";
    my($proc_fh,$pid) = run_command(undef, "&1", $file, @file_list);
    chdir($tempdir) or die "Can't chdir to $tempdir: $!";
    my($index)=0; my($ln);
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      chomp($ln);
      do_log(5, "result line from file(1): %s", $ln);
      if ($index > $#file_list) {
        do_log(-1, "NOTICE: Skipping extra output from file(1): %s", $ln);
      } else {
        my($part)   = $part_list[$index];  # walk through @part_list in sync
        my($expect) = $file_list[$index];  # walk through @file_list in sync
        if ($ln !~ /^(\Q$expect\E):[ \t]*(.*)\z/s) { #split file name from type
          do_log(-1,"NOTICE: Skipping bad output from file(1) ".
                    "at [%d, %s], got: %s", $index,$expect,$ln);
        } else {
          my($type_short); my($actual_name) = $1; my($type_long) = $2;
          $type_short = lookup(0,$type_long,@map_full_type_to_short_type_maps);
          ll(4) && do_log(4, "File-type of %s: %s%s",
                             $part->base_name, $type_long,
                             (!defined $type_short ? ''
                                : !ref $type_short ? "; ($type_short)"
                                : '; (' . join(', ',@$type_short) . ')'
                             ) );
          $part->type_long($type_long); $part->type_short($type_short);
          $part->attributes_add('C')    # simpleminded
            if !ref($type_short) ? $type_short eq 'pgp'  # encrypted?
                                 : grep {$_ eq 'pgp'} @$type_short;
          $index++;
        }
      }
    }
    defined $ln || $!==0 || $!==EAGAIN
      or die "Error reading from file(1) utility: $!";
    if ($index < @part_list) {
      die sprintf("parsing file(1) results - missing last %d results",
                  @part_list - $index);
    }
    my($err) = 0; $proc_fh->close or $err = $!;
    proc_status_ok($?,$err)
      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;
    ll(4) && do_log(4,"decode_parts: level=%d, #parts=%d : %s",
                     $depth, scalar(@parts),
                     join(', ', (map { $_->base_name } @chopped_parts),
                     (@chopped_parts >= @parts ? () : "...")) );
    for my $part (@parts) {  # test for existence of all expected files
      my($fname) = $part->full_name;  my($errn) = 0;
      if ($fname eq '') { $errn = ENOENT }
      else {
        my(@stat_list) = lstat($fname);
        if (@stat_list) { add_entropy(@stat_list) } else { $errn = 0+$! }
      }
      if ($errn == ENOENT) {
        $part->exists(0);
#       $part->type_short('no-file')  if !defined $part->type_short;
      } elsif ($errn) {
        die "decompose_mail: inaccessible file $fname: $!";
      } elsif (!-f _) {  # not a regular file
        my($what) = -l _ ? 'symlink' : -d _ ? 'directory' : 'non-regular file';
        do_log(-1, "WARN: decompose_mail: removing unexpected %s %s",
                   $what,$fname);
        if (-d _) { rmdir_recursively($fname) }
        else { unlink($fname) or die "Can't delete $what $fname: $!" }
        $part->exists(0);
        $part->type_short(-l _ ? 'symlink' : -d _ ? 'dir' : 'special')
          if !defined $part->type_short;
      } elsif (-z _) {   # empty file
        unlink($fname) or die "Can't remove \"$fname\": $!";
        $part->exists(0);
        $part->type_short('empty')  if !defined $part->type_short;
        $part->type_long('empty')   if !defined $part->type_long;
      } else {
        $part->exists(1);
      }
    }
    determine_file_types($tempdir, \@parts);
    for my $part (@parts) {
      if ($part->exists && !defined($hold))
        { $hold = decompose_part($part, $tempdir) }
      $any_undecipherable++  if grep {$_ eq 'U'} @{ $part->attributes || [] };
    }
    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) = @_;
  # possible return values from eval:
  # 0 - truly atomic, or unknown or archiver failure; consider atomic
  # 1 - some archive, successfully unpacked, result replaces original
  # 2 - probably unpacked, but keep the original (eg self-extracting archive)
  my($hold,$none_called);
  my($sts) = eval {
    my($type_short) = $part->type_short;
    my(@ts) = !defined $type_short ? ()
                : !ref $type_short ? ($type_short) : @$type_short;
    return 0  if !@ts;  # consider atomic if unknown (returns from eval)
    snmp_count("OpsDecType-".join('.',@ts));
    for my $dec_tuple (@{ca('decoders')}) {  # first matching decoder wins
      next  if !defined $dec_tuple;
      my($dec_ts,$code,@args) = @$dec_tuple;
      if ($code && grep {$_ eq $dec_ts} @ts)
        { return &$code($part,$tempdir,@args) }  # returns from eval
    }
    # falling through (e.g. HTML) - no match, consider atomic
    $none_called = 1;
    return 0;  # returns from eval
  };
  if ($@ ne '') {
    chomp($@);
    if ($@ =~ /^Exceeded storage quota/ ||
        $@ =~ /^Maximum number of files\b.*\bexceeded/) { $hold = $@ }
    else {
      do_log(-1,"Decoding of %s (%s) failed, leaving it unpacked: %s",
                $part->base_name, $part->type_long, $@);
    }
    $sts = 2;
    chdir($tempdir) or die "Can't chdir to $tempdir: $!";  # just in case
  }
  if ($sts == 1 && lookup(0,$part->type_long, @keep_decoded_original_maps)) {
    # don't trust this file type or unpacker,
    # keep both the original and the unpacked file
    ll(4) && do_log(4,"file type is %s, retain original %s",
                      $part->type_long, $part->base_name);
    $sts = 2;
  }
  if ($sts == 1) {
    ll(5) && do_log(5,"decompose_part: deleting %s", $part->full_name);
    unlink($part->full_name)
      or die sprintf("Can't unlink %s: %s", $part->full_name, $!);
  }
  ll(4) && do_log(4,"decompose_part: %s - %s", $part->base_name,
                    ['atomic','archive, unpacked','source retained']->[$sts]);
  section_time('decompose_part')  unless $none_called;
  $hold;
}

# a trivial wrapper around mime_decode() to adjust arguments and result
sub do_mime_decode($$) {
  my($part, $tempdir) = @_;
  mime_decode($part,$tempdir,$part);
  2;  # probably unpacked, but keep the original mail
};

#
# Uncompression/unarchiving routines
# Possible return codes:
# 0 - truly atomic, or 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) = @_;
  ll(4) && do_log(4,"do_ascii: Decoding part %s", $part->base_name);

  snmp_count('OpsDecByUUlibAttempt');
  # prevent uunconc.c/UUDecode() from trying to create temp file in '/'
  my($old_env_tmpdir) = $ENV{TMPDIR}; $ENV{TMPDIR} = "$tempdir/parts";

  my($any_errors,$any_decoded);
  eval {  # must not go away without calling Convert::UUlib::CleanUp !
    my($sts,$count);
    $sts = Convert::UUlib::Initialize();
    $sts = 0  if !defined($sts); #avoid Use of uninit. value in numeric eq (==)
    $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 "bad uulib OPT_IGNMODE";
  # !Convert::UUlib::SetOption(OPT_DESPERATE,1) or die "bad uulib OPT_DESPERATE";
    ($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";
    }
    ll(4) && do_log(4,"do_ascii: Decoding part %s (%d items), uulib V%s",
                      $part->base_name, $count, $uulib_version);
    my($uu);
    my($item_num) = 0; my($parent_placement) = $part->mime_placement;
    for (my($j) = 0; $uu = Convert::UUlib::GetFileListItem($j); $j++) {
      $item_num++;
      ll(4) && do_log(4,
                 "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: %s not decodable, %s",
                 $j,$uu->state);
      } else {
        my($newpart_obj)=Amavis::Unpackers::Part->new("$tempdir/parts",$part);
        $newpart_obj->mime_placement("$parent_placement/$item_num");
        $newpart_obj->name_declared($uu->filename);
        my($newpart) = $newpart_obj->full_name;
        $! = 0;
        $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) = lstat($newpart) ? 0 : 0+$!;
        if    ($errn == ENOENT) { $statmsg = "does not exist"   }
        elsif ($errn) { $statmsg = "inaccessible: $!" }
        elsif ( -l _) { $statmsg = "is a symlink"     }
        elsif ( -d _) { $statmsg = "is a directory"   }
        elsif (!-f _) { $statmsg = "not a regular file" }
        if (defined $statmsg) { $statmsg = "; file status: $newpart $statmsg" }
        my($size) = 0 + (-s _);
        $newpart_obj->size($size);
        consumed_bytes($size, 'do_ascii');
        if ($sts == RET_OK && $errn==0) {
          $any_decoded++;
          do_log(4,"do_ascii: RET_OK%s", $statmsg)  if defined $statmsg;
        } elsif ($sts == RET_NODATA || $sts == RET_NOEND) {
          $any_errors++;
          do_log(-1,"do_ascii: Convert::UUlib error: %s%s",
                    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);
        }
      }
    }
  };
  my($eval_stat) = $@;
  Convert::UUlib::CleanUp();
  snmp_count('OpsDecByUUlib')  if $any_decoded;
  if (defined $old_env_tmpdir) { $ENV{TMPDIR} = $old_env_tmpdir }
  else { delete $ENV{TMPDIR} }
  if ($eval_stat ne '') { chomp($eval_stat); die "do_ascii: $eval_stat\n" }
  ($any_decoded && !$any_errors) ? 1 : $any_errors ? 2 : 0;
}

# use Archive-Zip
sub do_unzip($$;$$) {
  my($part, $tempdir, $archiver_dummy, $testing_for_sfx) = @_;
  ll(4) && do_log(4, "Unzipping %s", $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);
  my($retval) = 1;
  # need to set up a temporary minimal error handler
  Archive::Zip::setErrorHandler(sub { return 5 });
  my($sts) = $zip->read($part->full_name);
  Archive::Zip::setErrorHandler(sub { die @_ });
  my($any_unsupp_compmeth,$any_zero_length);
  my($encryptedcount,$extractedcount) = (0,0);
  if ($sts != AZ_OK) {  # not a zip? corrupted zip file? other errors?
    if ($testing_for_sfx && $sts == AZ_FORMAT_ERROR) {
      # a normal status for executable that is not a self extracting archive
      do_log(4, "do_unzip: ok, exe is not a zip sfx: %s (%s)",
                $err_nm[$sts], $sts);
    } else {
      do_log(-1, "do_unzip: not a zip: %s (%s)", $err_nm[$sts], $sts);
#     $part->attributes_add('U');  # perhaps not, it flags as **UNCHECKED** too
#                                  # many bounces containing chopped-off zip
    }
    $retval = 0;
  } else {
    my($item_num) = 0; my($parent_placement) = $part->mime_placement;
    for my $mem ($zip->members()) {
      my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
      $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num");
      $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 {
        # want to read uncompressed - set to COMPRESSION_STORED
        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;
        my($outpart) = IO::File->new;
        $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640)
          or die "Can't create file $newpart: $!";
        binmode($outpart) or die "Can't set file $newpart to binmode: $!";
        my($size) = 0;
        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);
          my($buf_len) = length($$buf_ref);
          if ($buf_len > 0) {
            $size += $buf_len;
            $outpart->print($$buf_ref) or die "Can't write to $newpart: $!";
            consumed_bytes($buf_len, 'do_unzip');
          }
        }
        $any_zero_length = 1  if $size == 0;
        $newpart_obj->size($size);
        $outpart->close or die "Error closing $newpart: $!";
        $mem->desiredCompressionMethod($oldc);
        $mem->endRead();
        $extractedcount++;
      }
    }
    snmp_count('OpsDecByArZip');
  }
  if ($any_unsupp_compmeth) {
    $retval = 2;
    do_log(-1, "do_unzip: %s, unsupported compr. method: %s",
               $part->base_name, $any_unsupp_compmeth);
  } elsif ($any_zero_length) {  # possible zip vulnerability exploit
    $retval = 2;
    do_log(1, "do_unzip: %s, zero length members, archive retained",
              $part->base_name);
  } elsif ($encryptedcount) {
    $retval = 2;
    do_log(1, 
      "do_unzip: %s, %d members are encrypted, %s extracted, archive retained",
      $part->base_name, $encryptedcount,
      !$extractedcount ? 'none' : $extractedcount);
  }
  $retval;
}

# use external decompressor program from the gzip/bzip2/compress family
# (there *is* a perl module for bzip2, but is not ready for prime time)
sub do_uncompress($$$) {
  my($part, $tempdir, $decompressor) = @_;
  ll(4) && do_log(4,"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);
  $newpart_obj->mime_placement($part->mime_placement."/1");
  my($newpart) = $newpart_obj->full_name;
  my($type_short, $name_declared) = ($part->type_short, $part->name_declared);
  my(@rn);  # collect recommended file names
  push(@rn,$1)
    if $part->type_long =~ /^\S+\s+compressed data, was "(.+)"(\z|, from\b)/;
  for my $name_d (!ref $name_declared ? ($name_declared) : @$name_declared) {
    next  if $name_d eq '';
    my($name) = $name_d;
    for (!ref $type_short ? ($type_short) : @$type_short) {
      /^F\z/   and  $name=~s/\.F\z//;
      /^Z\z/   and  $name=~s/\.Z\z//    || $name=~s/\.tg?z\z/.tar/;
      /^gz\z/  and  $name=~s/\.gz\z//   || $name=~s/\.tgz\z/.tar/;
      /^bz\z/  and  $name=~s/\.bz\z//   || $name=~s/\.tbz\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/;
    }
    push(@rn,$name)  if !grep { $_ eq $name } @rn;
  }
  $newpart_obj->name_declared(@rn==1 ? $rn[0] : \@rn)  if @rn;
  my($proc_fh,$pid); my($retval) = 1;

  my($remaining_time) = alarm(0);  # check time left, stop the timer
  my($dt) = max(10, int(2 * $remaining_time / 3));
  alarm($dt);  do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time);
  eval {
    ($proc_fh,$pid) =
      run_command($part->full_name, undef, split(' ',$decompressor));
    my($rv,$err) = run_command_copy($newpart,$proc_fh);
    undef $proc_fh; undef $pid;
    if (proc_status_ok($rv,$err)) {}
    else {
#     unlink($newpart) or die "Can't unlink $newpart: $!";
      my($msg) = sprintf('Error running decompressor %s on %s, %s',
                   $decompressor, $part->base_name, exit_status_str($rv,$err));
      # bzip2 and gzip use status 2 as a warning about corrupted file
      if (proc_status_ok($rv,$err, 2)) {do_log(0,"%s",$msg)} else {die $msg}
    }
  };
  my($eval_stat) = $@;
  prolong_timer('do_uncompress',$remaining_time-($dt-alarm(0))); #restart timer
  if ($eval_stat ne '') {
    $retval = 0; chomp($eval_stat);
    if (defined $pid) {
      do_log(-1, "%s is taking longer than %d s and will be killed",
                 $decompressor, $dt)  if $eval_stat eq "timed out";
      kill_proc($pid,$decompressor,1,$proc_fh);  undef $pid;
    }
    do_log(-1, "do_uncompress: %s", $eval_stat);
  }
  $retval;
}

# use Compress::Zlib to inflate
sub do_gunzip($$) {
  my($part, $tempdir) = @_;  my($retval) = 0;
  do_log(4, "Inflating gzip archive %s", $part->base_name);
  snmp_count('OpsDecByZlib');
  my($gz) = Amavis::IO::Zlib->new;
  $gz->open($part->full_name,'rb')
    or die("do_gunzip: Can't open gzip file ".$part->full_name.": $!");
  my($newpart_obj) = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
  $newpart_obj->mime_placement($part->mime_placement."/1");
  my($newpart) = $newpart_obj->full_name;
  my($outpart) = IO::File->new;
  $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640)
    or die "Can't create file $newpart: $!";
  binmode($outpart) or die "Can't set file $newpart to binmode: $!";
  my($nbytes,$buff); my($size) = 0;
  while (($nbytes=$gz->read($buff,16384)) > 0) {
    $outpart->print($buff) or die "Can't write to $newpart: $!";
    $size += $nbytes; consumed_bytes($nbytes, 'do_gunzip');
  }
  my($err) = defined $nbytes ? 0 : $!;
  $newpart_obj->size($size);
  $outpart->close or die "Error closing $newpart: $!";
  my(@rn);  # collect recommended file name
  my($name_declared) = $part->name_declared;
  for my $name_d (!ref $name_declared ? ($name_declared) : @$name_declared) {
    next  if $name_d eq '';
    my($name) = $name_d;
    $name=~s/\.(gz|Z)\z// || $name=~s/\.tgz\z/.tar/;
    push(@rn,$name)  if !grep { $_ eq $name } @rn;
  }
  $newpart_obj->name_declared(@rn==1 ? $rn[0] : \@rn)  if @rn;
  if (defined $nbytes && $nbytes==0) { $retval = 1 }  # success
  else {
    do_log(-1, "do_gunzip: Error reading file %s: %s", $part->full_name,$err);
    unlink($newpart) or die "Can't unlink $newpart: $!";
    $newpart_obj->size(undef); $retval = 0;
  }
  $gz->close or die "Error closing gzipped file: $!";
  $retval;
}

# 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, "Faulty archive %s: %s", $part->full_name, $@);
    return 0;
  }
  do_log(4,"Untarring %s", $part->base_name);
  my($item_num) = 0; my($parent_placement) = $part->mime_placement;
  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);
    $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num");
    my($newpart) = $newpart_obj->full_name;
    my($outpart) = IO::File->new;
    $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640)
      or die "Can't create file $newpart: $!";
    binmode($outpart) or die "Can't set file $newpart to binmode: $!";
    $outpart->print($data) or die "Can't write to $newpart: $!";
    $newpart_obj->size(length($data));
    consumed_bytes(length($data), 'do_tar');
    $outpart->close or die "Error closing $newpart: $!";
  }
  1;
}

# use external program to expand RAR archives
sub do_unrar($$$;$) {
  my($part, $tempdir, $archiver, $testing_for_sfx) = @_;
  ll(4) && do_log(4, "Expanding RAR archive %s", $part->base_name);
  my($decompressor_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}Attempt");
  # 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
  my(@list); my($hypcount) = 0; my($encryptedcount) = 0;
  my($lcnt) = 0; my($member_name); my($bytes) = 0; my($last_line);
  my($item_num) = 0; my($parent_placement) = $part->mime_placement;
  my($retval) = 1; my($fn) = $part->full_name; my($proc_fh,$pid);
  my(@common_rar_switches) = qw(-c- -p- -av- -idcdp);  

  my($remaining_time) = alarm(0);  # check time left, stop the timer
  my($dt) = max(10, int(2 * $remaining_time / 3));
  alarm($dt);  do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time);
  eval {
    ($proc_fh,$pid) =
      run_command(undef, "&1", $archiver, 'v',@common_rar_switches,'--',$fn);
    local($_);
    # jump hoops because there is no simple way to just list all the files
    for ($! = 0; defined($_=$proc_fh->getline); $! = 0) {
      $last_line = $_  if !/^\s*$/;  # keep last nonempty line
      chomp;
      if (/^unexpected end of archive/) {
        last;
      } elsif (/^------/) {
        $hypcount++;
        last  if $hypcount >= 2;
      } elsif ($hypcount < 1 && /^Encrypted file:/) {
        do_log(4,"do_unrar: %s", $_);
        $part->attributes_add('U','C');
      } elsif ($hypcount == 1) {
        $lcnt++; local($1,$2,$3);
        if ($lcnt % 2 == 0) {  # information line (every other line)
          if (!/^\s+(\d+)\s+(\d+)\s+(\d+%|-->|<--)/) {
            do_log($testing_for_sfx ? 4 : -1,
                   "do_unrar: can't parse info line for \"%s\" %s",
                   $member_name,$_);
          } elsif (defined $member_name) {
            do_log(5,'do_unrar: member: "%s", size: %s', $member_name,$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 '*')
          if ($1 eq '*') {   # member is encrypted
            $encryptedcount++; $item_num++;
            # make a phantom entry - carrying only name and attributes
            my($newpart_obj) =
              Amavis::Unpackers::Part->new("$tempdir/parts",$part);
            $newpart_obj->mime_placement("$parent_placement/$item_num");
            $newpart_obj->name_declared($member_name);
            $newpart_obj->attributes_add('U','C');
            $member_name = undef;  # makes no sense extracting encrypted files
          }
        }
      }
    }
    defined $_ || $!==0 || $!==EAGAIN  or die "Error reading: $!";
    # consume all remaining output to avoid broken pipe
    my($ln);
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0)
      { $last_line = $ln  if $ln !~ /^\s*$/ }
    defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
    my($err) = 0; $proc_fh->close or $err = $!; my($rv) = $?;
    undef $proc_fh; undef $pid;  local($1,$2);
    if (proc_status_ok($rv,$err, 7)) {       # USER_ERROR
      die printf("perhaps this %s does not recognize switches ".
                 "-av- and -idcdp, it is probably too old. Upgrade: %s",
                 $archiver, 'http://www.rarlab.com/');
    } elsif (proc_status_ok($rv,$err, 3)) {  # CRC_ERROR
      # NOTE: password protected files in the archive cause CRC_ERROR
      do_log(4,"do_unrar: CRC_ERROR - undecipherable, %s",
               exit_status_str($rv,$err));
      $part->attributes_add('U');
    } elsif (proc_status_ok($rv,$err, 1) && @list && $bytes > 0) {
                                             # WARNING, probably still ok
      do_log(4,"do_unrar: warning, %s", exit_status_str($rv,$err));
    } elsif (!proc_status_ok($rv,$err)) {
      die("can't get a list of archive members: " .
          exit_status_str($rv,$err) ."; ".$last_line);
    } elsif (!$bytes && $last_line =~ /^\Q$fn\E is not RAR archive$/) {
      chomp($last_line);  die $last_line;
    } elsif ($last_line !~ /^\s*(\d+)\s+(\d+)/s) {
      do_log(-1,"do_unrar: unable to obtain orig total size: %s", $last_line);
    } else {
      do_log(4,"do_unrar: summary size: %d, sum of sizes: %d",
             $2,$bytes)  if abs($bytes - $2) > 100;
      $bytes = $2  if $2 > $bytes;
    }
    consumed_bytes($bytes, 'do_unrar-pre', 1);  # pre-check on estimated size
    if (!@list) {
      do_log(4,"do_unrar: no archive members, or not an archive at all");
      if ($testing_for_sfx) { return 0 } else { $part->attributes_add('U') }
    } else {
      snmp_count("OpsDecBy\u${decompressor_name}");
      # unrar/rar can make a dir by itself, but can't hurt (sparc64 problem?)
      mkdir("$tempdir/parts/rar", 0750)
        or die "Can't mkdir $tempdir/parts/rar: $!";
      ($proc_fh,$pid) =
        run_command(undef, "&1", $archiver, qw(x -inul -ver -o- -kb),
                    @common_rar_switches, '--', $fn, "$tempdir/parts/rar/");
      my($nbytes,$buff); my($output) = '';
      while (($nbytes=$proc_fh->read($buff,4096)) > 0) { $output .= $buff }
      defined $nbytes or die "Error reading: $!";
      my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
      proc_status_ok($?,$err, 0,1,3)  # one of: SUCCESS, WARNING, CRC
        or do_log(-1, 'do_unrar %s', exit_status_str($?,$err));
      my($errn) = lstat("$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');
      }
    }
  };
  my($eval_stat) = $@;
  prolong_timer('do_unrar', $remaining_time-($dt-alarm(0)));  # restart timer
  if ($encryptedcount) {
    do_log(1,
      "do_unrar: %s, %d members are encrypted, %s extracted, archive retained",
      $part->base_name, $encryptedcount, !@list ? 'none' : 0+@list );
    $retval = 2;
  }
  if ($eval_stat ne '') {
    $retval = 0; chomp($eval_stat);
    if (defined $pid) {
      do_log(-1, "%s is taking longer than %d s and will be killed",
                 $archiver, $dt)  if $eval_stat eq "timed out";
      kill_proc($pid,$archiver,1,$proc_fh);  undef $pid;
    }
    if ($testing_for_sfx) { die "do_unrar: $eval_stat" }
    else { do_log(-1, "do_unrar: %s", $eval_stat) };
  }
  $retval;
}

# use external program to expand LHA archives
sub do_lha($$$;$) {
  my($part, $tempdir, $archiver, $testing_for_sfx) = @_;
  ll(4) && do_log(4, "Expanding LHA archive %s", $part->base_name);
  my($decompressor_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}Attempt");
  # lha needs extension .exe to understand SFX!
  my($fn) = $part->full_name;
  symlink($fn, $fn.".exe")
    or die sprintf("Can't symlink %s %s.exe: %s", $fn, $fn, $!);
  my(@list); my(@checkerr); my($retval) = 1; my($proc_fh,$pid);

  my($remaining_time) = alarm(0);  # check time left, stop the timer
  my($dt) = max(10, int(2 * $remaining_time / 3));
  alarm($dt);  do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time);
  eval {
    ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'lq', $fn.".exe");
    my($ln);
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      chomp($ln); local($1);
      next  if $ln =~ m{/\z};  # ignore directories
      if ($ln =~ /^LHa: (Warning|Fatal error): /)
        { push(@checkerr,$ln)  if @checkerr < 3 }
      elsif ($ln =~ /^(?:\S+\s+){6}\S+\s*(\S.*?)\s*\z/s) { push(@list,$1) }
      else { do_log(5,"do_lha: skip: %s", $ln) }
    }
    defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
    my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
    if (!proc_status_ok($?,$err) || @checkerr) {
      die('(' . join(", ",@checkerr) .') ' . exit_status_str($?,$err));
    } elsif (!@list) {
      $part->attributes_add('U')  if !$testing_for_sfx;
      die "no archive members, or not an archive at all";
    }
  };
  my($eval_stat) = $@;
  prolong_timer('do_lha', $remaining_time-($dt-alarm(0)));  # restart timer
  if ($eval_stat ne '') {
    unlink($fn.".exe") or do_log(-1, "Can't unlink %s.exe: %s", $fn,$!);
    $retval = 0; chomp($eval_stat);
    if (defined $pid) {
      do_log(-1, "%s is taking longer than %d s and will be killed",
                 $archiver, $dt)  if $eval_stat eq "timed out";
      kill_proc($pid,$archiver,1,$proc_fh);  undef $pid;
    }
    if ($testing_for_sfx) { die "do_lha: $eval_stat" }
    else { do_log(-1, "do_lha: %s", $eval_stat) };
  } else {  # preliminary archive traversal done, now extract files
    snmp_count("OpsDecBy\u${decompressor_name}");
    my $rv = store_mgr($tempdir, $part, \@list, $archiver, 'pq', $fn.".exe");
    $rv==0  or die exit_status_str($rv);
    unlink($fn.".exe") or die "Can't unlink $fn.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, $archiver) = @_;
  my($decompressor_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  my($is_nomarch) = $archiver =~ /nomarch/i;
  ll(4) && do_log(4,"Unarcing %s, using %s",
                    $part->base_name, ($is_nomarch ? "nomarch" : "arc") );
  my($cmdargs) = ($is_nomarch ? "-l -U" : "ln") . " " . $part->full_name;
  my($proc_fh,$pid) = run_command(undef,undef,$archiver, split(' ',$cmdargs));
  my(@list); my($ln);
  for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { push(@list,$ln) }
  defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
  my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err) or do_log(-1, 'do_arc: %s',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, $archiver,
                       ($is_nomarch ? ('-p', '-U') : 'p'), $part->full_name);
    do_log(-1, 'arc %', exit_status_str($rv))  if $rv;
  }
  1;
}

# use external program to expand ZOO archives
sub do_zoo($$$) {
  my($part, $tempdir, $archiver) = @_;
  do_log(4, "Expanding ZOO archive %s", $part->base_name);
  my($decompressor_name) = basename((split(' ',$archiver))[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,$pid) =
    run_command(undef, undef, $archiver, 'lf1q', $part->full_name.".zoo");
  my(@list); my($ln);
  for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) { push(@list,$ln) }
  defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
  my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err) or do_log(-1, 'do_zoo: %s',exit_status_str($?,$err));
  if (@list) {
    chomp(@list);
    my $rv = store_mgr($tempdir, $part, \@list, $archiver, 'xpqqq:',
                       $part->full_name . ".zoo");
    do_log(-1, 'zoo %s', 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, $archiver, $testing_for_sfx) = @_;
  do_log(4, "Expanding ARJ archive %s", $part->base_name);
  my($decompressor_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}Attempt");
  # 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$tempdir/parts";
  # unarj needs extension of .arj!
  my($fn) = $part->full_name;
  symlink($part->full_name, $fn.".arj")
    or die sprintf("Can't symlink %s %s.arj: %s", $fn, $fn, $!);
  my($retval) = 1; my($proc_fh,$pid);

  my($remaining_time) = alarm(0);  # check time left, stop the timer
  my($dt) = max(10, int(2 * $remaining_time / 3));
  alarm($dt);  do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time);
  eval {
    # obtain total original size of archive members from the index/listing
    ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'l', $fn.".arj");
    my($last_line); my($ln);
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0)
      { $last_line = $ln  if $ln !~ /^\s*$/ }
    defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
    my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
    my($rv) = $?;
    if (!proc_status_ok($rv,$err, 0,1,3)) {  # one of: success, warn, CRC err
      $part->attributes_add('U')  if !$testing_for_sfx;
      die "not an ARJ archive? ".exit_status_str($rv,$err);
    } elsif ($last_line =~ /^\Q$fn\E.arj is not an ARJ archive$/) {
      die "last line: $last_line";
    } elsif ($last_line !~ /^\s*(\d+)\s*files\s*(\d+)/s) {
      $part->attributes_add('U')  if !$testing_for_sfx;
      die "unable to obtain orig size of files: $last_line, ".
          exit_status_str($rv,$err);
    } 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: $!";
    snmp_count("OpsDecBy\u${decompressor_name}");
    ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'e', $fn.".arj");
    my($encryptedcount,$skippedcount) = (0,0);
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      $encryptedcount++
        if $ln =~ /^(Extracting.*\bBad file data or bad password|File is password encrypted, Skipped)\b/s;
      $skippedcount++
        if $ln =~ /(\bexists|^File is password encrypted|^Unsupported .*), Skipped\b/s;
    }
    defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
    $err = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
    $rv = $?;
    chdir($tempdir) or die "Can't chdir to $tempdir: $!";
    if (proc_status_ok($rv,$err, 0,1)) {}  # success, warn
    elsif (proc_status_ok($rv,$err, 3))    # CRC err
      { $part->attributes_add('U')  if !$testing_for_sfx }
    else { do_log(0, "unarj: error extracting: %s",exit_status_str($rv,$err)) }
    # 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) = lstat("$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}");
    }
    proc_status_ok($rv,$err, 0,1,3)  # one of: success, warn, CRC err
      or die "unarj: can't extract archive members: ".
             exit_status_str($rv,$err);
    if ($encryptedcount || $skippedcount) {
      do_log(1,
        "do_unarj: %s, %d members are encrypted, %d skipped, archive retained",
        $part->base_name, $encryptedcount, $skippedcount);
      $retval = 2;
    }
  };
  my($eval_stat) = $@;
  prolong_timer('do_unarj', $remaining_time-($dt-alarm(0)));  # restart timer
  unlink($fn.".arj") or die "Can't unlink $fn.arj: $!";
  if ($eval_stat ne '') {
    $retval = 0; chomp($eval_stat);
    if (defined $pid) {
      do_log(-1, "%s is taking longer than %d s and will be killed",
                 $archiver, $dt)  if $eval_stat eq "timed out";
      kill_proc($pid,$archiver,1,$proc_fh);  undef $pid;
    }
    if ($testing_for_sfx) { die "do_unarj: $eval_stat" }
    else { do_log(-1, "do_unarj: %s", $eval_stat) };
  }
  $retval;
}

# use external program to expand TNEF archives
sub do_tnef_ext($$$) {
  my($part, $tempdir, $archiver) = @_;
  do_log(4, "Extracting from TNEF encapsulation (ext) %s", $part->base_name);
  my($archiver_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${archiver_name}");
  mkdir("$tempdir/parts/tnef",0750)
    or die "Can't mkdir $tempdir/parts/tnef: $!";
  my($proc_fh,$pid) = run_command(undef, "&1", $archiver, '--number-backups',
                          '-C', "$tempdir/parts/tnef", '-f', $part->full_name);
  my($nbytes,$buff); my($output) = '';
  while (($nbytes=$proc_fh->read($buff,4096)) > 0) { $output .= $buff }
  defined $nbytes or die "Error reading: $!";
  my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err)
    or do_log(0, 'tnef %s', exit_status_str($?,$err).' '.$output);
  my($b) = flatten_and_tidy_dir("$tempdir/parts/tnef","$tempdir/parts",$part);
  if ($b > 0) {
    do_log(4, "tnef extracted %d bytes from a tnef container", $b);
    consumed_bytes($b, 'do_tnef');
  }
  1;
}

# use Convert-TNEF
sub do_tnef($$) {
  my($part, $tempdir) = @_;
  do_log(4, "Extracting from TNEF encapsulation (int) %s", $part->base_name);
  snmp_count('OpsDecByTnef');
  my($tnef) = Convert::TNEF->read_in($part->full_name,
       {output_dir=>"$tempdir/parts", buffer_size=>16384, ignore_checksum=>1});
  defined $tnef or die "Convert::TNEF failed: ".$Convert::TNEF::errstr;
  my($item_num) = 0; my($parent_placement) = $part->mime_placement;
  for my $a ($tnef->message, $tnef->attachments) {
    for my $attr_name ('AttachData','Attachment') {
      my($dh) = $a->datahandle($attr_name);
      if (defined $dh) {
        my($newpart_obj)= Amavis::Unpackers::Part->new("$tempdir/parts",$part);
        $item_num++;
        $newpart_obj->mime_placement("$parent_placement/$item_num");
        $newpart_obj->name_declared([$a->name, $a->longname]);
        my($newpart) = $newpart_obj->full_name;
        my($outpart) = IO::File->new;
        $outpart->open($newpart, O_CREAT|O_EXCL|O_WRONLY, 0640)
          or die "Can't create file $newpart: $!";
        binmode($outpart) or die "Can't set file $newpart to binmode: $!";
        my($file) = $dh->path; my($size) = 0;
        if (defined $file) {
          my($io,$nbytes,$buff); $dh->binmode(1);
          $io = $dh->open("r") or die "Can't open MIME::Body handle: $!";
          while (($nbytes=$io->read($buff,16384)) > 0) {
            $outpart->print($buff) or die "Can't write to $newpart: $!";
            $size += $nbytes; consumed_bytes($nbytes, 'do_tnef_1');
          }
          defined $nbytes or die "Error reading from MIME::Body handle: $!";
          $io->close or die "Error closing MIME::Body handle: $!";
        } else {
          my($buff) = $dh->as_string; my($nbytes) = length($buff);
          $outpart->print($buff) or die "Can't write to $newpart: $!";
          $size += $nbytes; consumed_bytes($nbytes, 'do_tnef_2');
        }
        $newpart_obj->size($size);
        $outpart->close or die "Error closing $newpart: $!";
      }
    }
  }
  $tnef->purge  if defined $tnef;
  1;
}

# The pax and cpio utilities usually support the following archive formats:
#   cpio, bcpio, sv4cpio, sv4crc, tar (old tar), ustar (POSIX.2 tar).
# The utilities from http://heirloom.sourceforge.net/ support
# several other tar/cpio variants such as SCO, Sun, DEC, Cray, SGI
sub do_pax_cpio($$$) {
  my($part, $tempdir, $archiver) = @_;
  my($archiver_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${archiver_name}");
  ll(4) && do_log(4,"Expanding archive %s, using %s",
                    $part->base_name,$archiver_name);
  my($is_pax) = $archiver_name =~ /^cpio/i ? 0 : 1;
  do_log(-1,"WARN: Using %s instead of pax can be a security ".
            "risk; please add:  \$pax='pax';  to amavisd.conf and check that ".
            "the pax(1) utility is available on the system!",
            $archiver_name)  if !$is_pax;
  my(@cmdargs) = $is_pax ? qw(-v) : qw(-i -t -v);
  my($proc_fh,$pid) = run_command($part->full_name, undef, $archiver,@cmdargs);
  my($bytes) = 0; local($1,$2); local($_);
  for ($! = 0; defined($_=$proc_fh->getline); $! = 0) {
    chomp;
    next  if /^\d+ blocks\z/;
    last  if /^(cpio|pax): (.*bytes read|End of archive volume)/;
    if (!/^ (?: \S+\s+ ){4} (\d+) \s+ (.+) \z/xs) {
      do_log(-1,"do_pax_cpio: can't parse toc line: %s", $_);
    } else {
      my($size,$mem) = ($1,$2);
      if ($mem =~ /^( (?: \s* \S+ ){3} (?: \s+ \d{4}, )? ) \s+ (.+)\z/xs) {
        $mem = $2;  # strip away time and date
      } elsif ($mem =~ /^\S \s+ (.+)\z/xs) {
        # -rwxr-xr-x  1 1121  users 3135 C errorReport.sh
        $mem = $1;  # strip away a letter in place of a date (?)
      }
      $mem = $1 if $is_pax && $mem =~ /^(.*) =[=>] (.*)\z/; # hard or soft link
      do_log(5,'do_pax_cpio: size: %5s, member: "%s"', $size,$mem);
      $bytes += $size  if $size > 0;
    }
  }
  defined $_ || $!==0 || $!==EAGAIN  or die "Error reading: $!";
  # consume remaining output to avoid broken pipe
  my($nbytes,$buff);
  while (($nbytes=$proc_fh->read($buff,4096)) > 0) { }
  defined $nbytes or die "Error reading: $!";
  my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err)
    or do_log(-1, 'do_pax_cpio/1: %s', exit_status_str($?,$err));
  consumed_bytes($bytes, 'do_pax_cpio/pre', 1);  # pre-check on estimated size
  mkdir("$tempdir/parts/arch", 0750)
    or die "Can't mkdir $tempdir/parts/arch: $!";
  my($name_clash) = 0;
  my(%orig_names);  # maps filenames to archive member names when possible

  my($remaining_time) = alarm(0);  # check time left, stop the timer
  my($dt) = max(10, int(2 * $remaining_time / 3));
  alarm($dt);  do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time);
  eval {
    chdir("$tempdir/parts/arch")
      or die "Can't chdir to $tempdir/parts/arch: $!";
    my(@cmdargs) = $is_pax ? qw(-r -k -p am -s /[^A-Za-z0-9_]/-/gp)
                       : qw(-i -d --no-absolute-filenames --no-preserve-owner);
    ($proc_fh,$pid) = run_command($part->full_name, "&1", $archiver, @cmdargs);
    my($output) = ''; my($ln);
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      chomp($ln);
      if (!$is_pax || $ln !~ /^(.*) >> (\S*)\z/) { $output .= $ln."\n" }
      else {  # parse output from pax -s///p
        my($member_name,$file_name) = ($1,$2);
        if (!exists $orig_names{$file_name}) {
          $orig_names{$file_name} = $member_name;
        } else {
          do_log(0,'do_pax_cpio: member "%s" is hidden by a '.
                   'previous archive member "%s", file: %s',
                   $member_name, $orig_names{$file_name}, $file_name);
          $orig_names{$file_name} = undef;  # cause it to exist but undefined
          $name_clash++;
        }
      }
    }
    defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
    my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
    chomp($output);
    proc_status_ok($?,$err) or die(exit_status_str($?,$err).' '.$output);
  };
  my($eval_stat) = $@;
  prolong_timer('do_pax_cpio', $remaining_time-($dt-alarm(0))); # restart timer
  chdir($tempdir) or die "Can't chdir to $tempdir: $!";
  my($b) = flatten_and_tidy_dir("$tempdir/parts/arch", "$tempdir/parts",
                                $part, 0, \%orig_names);
  consumed_bytes($b, 'do_pax_cpio');
  if ($eval_stat ne '') {
    chomp($eval_stat);
    if (defined $pid) {
      do_log(-1, "%s is taking longer than %d s and will be killed",
                 $archiver, $dt)  if $eval_stat eq "timed out";
      kill_proc($pid,$archiver,1,$proc_fh);  undef $pid;
    }
    die "do_pax_cpio: $eval_stat\n";
  }
  $name_clash ? 2 : 1;
}

# command line unpacker from stuffit.com for Linux
# decodes Macintosh StuffIt archives and others
# (but it appears the Linux version is buggy and a security risk, not to use!)
sub do_unstuff($$$) {
  my($part, $tempdir, $archiver) = @_;
  my($archiver_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${archiver_name}");
  do_log(4,"Expanding archive %s, using %s", $part->base_name,$archiver_name);
  mkdir("$tempdir/parts/unstuff", 0750)
    or die "Can't mkdir $tempdir/parts/unstuff: $!";
  my($proc_fh,$pid) = run_command(undef, "&1", $archiver,  # '-q',
                               "-d=$tempdir/parts/unstuff", $part->full_name);
  my($nbytes,$buff); my($output) = '';
  while (($nbytes=$proc_fh->read($buff,4096)) > 0) { $output .= $buff }
  defined $nbytes or die "Error reading: $!";
  my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  do_log(proc_status_ok($?,$err) ? 5 : -1,
         'do_unstuff %s %s', exit_status_str($?,$err), $output);
  my($b) = flatten_and_tidy_dir("$tempdir/parts/unstuff",
                                "$tempdir/parts", $part);
  consumed_bytes($b, 'do_unstuff');
  1;
}

# ar is a standard Unix binary archiver, also used by Debian packages
sub do_ar($$$) {
  my($part, $tempdir, $archiver) = @_;
  ll(4) && do_log(4,"Expanding Unix ar archive %s", $part->full_name);
  my($archiver_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${archiver_name}");
  my($proc_fh,$pid) = run_command(undef,undef,$archiver,'tv',$part->full_name);
  my($ln); my($bytes) = 0; local($1,$2,$3);
  for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
    chomp($ln);
    if ($ln !~ /^(?:\S+\s+){2}(\d+)\s+((?:\S+\s+){3}\S+)\s+(.*)\z/) {
      do_log(-1,"do_ar: can't parse contents listing line: %s", $ln);
    } else {
      do_log(5,"do_ar: member: \"%s\", size: %s", $3,$1);
      $bytes += $1  if $1 > 0;
    }
  }
  defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
  # consume remaining output to avoid broken pipe
  my($nbytes,$buff);
  while (($nbytes=$proc_fh->read($buff,4096)) > 0) { }
  defined $nbytes or die "Error reading: $!";
  my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err) or do_log(-1, 'ar-1 %s', exit_status_str($?,$err));
  consumed_bytes($bytes, 'do_ar-pre', 1);  # pre-check on estimated size
  mkdir("$tempdir/parts/ar", 0750)
    or die "Can't mkdir $tempdir/parts/ar: $!";
  chdir("$tempdir/parts/ar") or die "Can't chdir to $tempdir/parts/ar: $!";
  ($proc_fh,$pid) = run_command(undef, "&1", $archiver, 'x', $part->full_name);
  my($output) = '';
  while (($nbytes=$proc_fh->read($buff,4096)) > 0) { $output .= $buff }
  defined $nbytes or die "Error reading: $!";
  $err = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err)
    or do_log(-1, 'ar-2 %s %s', exit_status_str($?,$err), $output);
  chdir($tempdir) or die "Can't chdir to $tempdir: $!";
  my($b) = flatten_and_tidy_dir("$tempdir/parts/ar","$tempdir/parts",$part);
  consumed_bytes($b, 'do_ar');
  1;
}

sub do_cabextract($$$) {
  my($part, $tempdir, $archiver) = @_;
  do_log(4, "Expanding cab archive %s", $part->base_name);
  my($archiver_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${archiver_name}");
  local($_); my($bytes) = 0; my($ln);
  my($proc_fh,$pid) =
    run_command(undef,undef,$archiver,'-l',$part->full_name);
  for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
    chomp($ln);
    next  if $ln =~ /^(File size|----|Viewing cabinet:|\z)/;
    if ($ln !~ /^\s* (\d+) \s* \| [^|]* \| \s (.*) \z/x) {
      do_log(-1, "do_cabextract: can't parse toc line: %s", $ln);
    } else {
      do_log(5, 'do_cabextract: member: "%s", size: %s', $2,$1);
      $bytes += $1  if $1 > 0;
    }
  }
  defined $ln || $!==0 || $!==EAGAIN  or die "Error reading: $!";
  # consume remaining output to avoid broken pipe (just in case)
  my($nbytes,$buff);
  while (($nbytes=$proc_fh->read($buff,4096)) > 0) { }
  defined $nbytes or die "Error reading: $!";
  my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err)
    or do_log(-1, 'cabextract-1 %s', exit_status_str($?,$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,$pid) = run_command(undef, undef, $archiver, '-q', '-d',
                                "$tempdir/parts/cab", $part->full_name);
  my($output) = '';
  while (($nbytes=$proc_fh->read($buff,4096)) > 0) { $output .= $buff }
  defined $nbytes or die "Error reading: $!";
  $err = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err)
    or do_log(-1, 'cabextract-2 %s %s', exit_status_str($?,$err), $output);
  my($b) = flatten_and_tidy_dir("$tempdir/parts/cab", "$tempdir/parts", $part);
  consumed_bytes($b, 'do_cabextract');
  1;
}

sub do_ole($$$) {
  my($part, $tempdir, $archiver) = @_;
  do_log(4,"Expanding MS OLE document %s", $part->base_name);
  my($archiver_name) = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${archiver_name}");
  mkdir("$tempdir/parts/ole",0750) or die "Can't mkdir $tempdir/parts/ole: $!";
  my($proc_fh,$pid) = run_command(undef, "&1", $archiver, '-v',
                            '-i', $part->full_name, '-d',"$tempdir/parts/ole");
  my($nbytes,$buff); my($output) = '';
  while (($nbytes=$proc_fh->read($buff,4096)) > 0) { $output .= $buff }
  defined $nbytes or die "Error reading: $!";
  my($err) = 0; $proc_fh->close or $err = $!; undef $proc_fh; undef $pid;
  proc_status_ok($?,$err)
    or do_log(0, 'ripOLE %s %s', exit_status_str($?,$err), $output);
  my($b) = flatten_and_tidy_dir("$tempdir/parts/ole", "$tempdir/parts", $part);
  if ($b > 0) {
    do_log(4, "ripOLE extracted %d bytes from an OLE document", $b);
    consumed_bytes($b, 'do_ole');
  }
  2;  # always keep the original OLE document
}

# 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, $unrar, $lha, $unarj) = @_;

  ll(4) && do_log(4,"Check whether %s is a self-extracting archive",
                    $part->base_name);
  # ZIP?
  return 2  if eval { do_unzip($part,$tempdir,undef,1) };
  chomp($@);
  do_log(3, "do_executable: not a ZIP sfx, ignoring: %s", $@)  if $@ ne '';

  # RAR?
  return 2  if defined $unrar && eval { do_unrar($part,$tempdir,$unrar,1) };
  chomp($@);
  do_log(3, "do_executable: not a RAR sfx, ignoring: %s", $@)  if $@ ne '';

  # LHA?
  return 2  if defined $lha && eval { do_lha($part,$tempdir,$lha,1) };
  chomp($@);
  do_log(3, "do_executable: not a LHA sfx, ignoring: %s", $@)    if $@ ne '';

  # ARJ?
  return 2  if defined $unarj && eval { do_unarj($part,$tempdir,$unarj,1) };
  chomp($@);
  do_log(3, "do_executable: not an ARJ sfx, ignoring: %s", $@)  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 pipe to a 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, O_CREAT|O_EXCL|O_WRONLY, 0640)
    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);
  for ($! = 0; ($len=$ifh->sysread($buf,16384)) > 0; $! = 0) {
    $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;
    }
  }
  my($rv,$rerr); $rerr = 0;
  if (defined $len || $!==0) { $ifh->close or $rerr = $! }  # ok
  else { $rerr = $!; $ifh->close }  # remember error, ignore stat on close
  $rv = $?;
  $ofh->close or die "Error closing $outfile: $!";
  ($rv,$rerr);  # return subprocess termination status and reading/close errno
}

# extract listed files from archive and store in new file
sub store_mgr($$$@) {
  my($tempdir, $parent_obj, $list, $archiver, @args) = @_;
  my($item_num) = 0; my($parent_placement) = $parent_obj->mime_placement;
  my($retval) = 0; my($proc_fh,$pid);

  my($remaining_time) = alarm(0);  # check time left, stop the timer
  my($dt) = max(10, int(2 * $remaining_time / 3));
  alarm($dt);  do_log(5,"timer set to %d s (was %d s)", $dt,$remaining_time);
  eval {
    for my $f (@$list) {
      next  if $f =~ m{/\z};  # ignore directories
      my($newpart_obj) =
        Amavis::Unpackers::Part->new("$tempdir/parts",$parent_obj);
      $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num");
      $newpart_obj->name_declared($f);  # store tainted name
      my($newpart) = $newpart_obj->full_name;
      ll(5) && do_log(5,'store_mgr: extracting "%s" to file %s using %s',
                        $f, $newpart, $archiver);
      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 "%s"', $f);
      }
      ($proc_fh,$pid) = run_command(undef,undef,$archiver,@args,untaint($f));
      my($rv,$err) = run_command_copy($newpart,$proc_fh);
      my($ll) = proc_status_ok($rv,$err) ? 5 : 1;
      ll($ll) && do_log($ll,"store_mgr: extracted by %s, %s",
                            $archiver, exit_status_str($rv,$err));
      $retval = $rv  if $retval == 0 && $rv != 0;
    }
  };
  my($eval_stat) = $@;
  prolong_timer('store_mgr', $remaining_time-($dt-alarm(0)));  # restart timer
  if ($eval_stat ne '') {
    $retval = 0; chomp($eval_stat);
    if (defined $pid) {
      do_log(-1, "%s is taking longer than %d s and will be killed",
                 "store_mgr: $archiver", $dt)  if $eval_stat eq "timed out";
      kill_proc($pid,$archiver,1,$proc_fh);  undef $pid;
    }
    do_log(-1, "store_mgr: %s", $eval_stat);
  }
  $retval;  # return the first nonzero status (if any), or 0
}

1;

__DATA__
#
# =============================================================================
# This text section governs how a main per-message amavisd-new log entry is
# formed (config variable $log_templ). 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 #
[? [:ccat_maj] |OTHER|[?%2|CLEAN|SPAM.TAG2]|TEMPFAIL|\
OVERSIZED[?%2||.TAG2]|BAD-HEADER[?%2||.TAG2]|SPAM|\
UNCHECKED|BANNED (%F)|INFECTED (%V)]#
#([:ccat_maj],[:ccat_min])#
, [? %p ||%p ][?%a||[?%l||LOCAL ]\[%a\] ][?%e||\[%e\] ]%s -> [%D|,]#
[? %q ||, quarantine: %q]#
[? %Q ||, Queue-ID: %Q]#
[? %m ||, Message-ID: %m]#
[? %r ||, Resent-Message-ID: %r]#
, mail_id: %i#
, Hits: %c#
#, size: %z#
#[? %j ||, Subject: "%j\"]#
#[? %#T ||, Tests: \[[%T|,]\]]#
, %y ms#
]
[?%#O|#|Blocked #
[? [:ccat_maj] |OTHER|[?%2|CLEAN|SPAM.TAG2]|TEMPFAIL|\
OVERSIZED[?%2||.TAG2]|BAD-HEADER[?%2||.TAG2]|SPAM|\
UNCHECKED|BANNED (%F)|INFECTED (%V)]#
#([:ccat_maj],[:ccat_min])#
, [? %p ||%p ][?%a||[?%l||LOCAL ]\[%a\] ][?%e||\[%e\] ]%s -> [%O|,]#
[? %q ||, quarantine: %q]#
[? %Q ||, Queue-ID: %Q]#
[? %m ||, Message-ID: %m]#
[? %r ||, Resent-Message-ID: %r]#
, mail_id: %i#
, Hits: %c#
#, size: %z#
#[? %j ||, Subject: "%j\"]#
#[? %#T ||, Tests: \[[%T|,]\]]#
, %y ms#
]
__DATA__
#
# =============================================================================
# This text section governs how a main per-recipient amavisd-new log entry
# is formed (config variable $log_recip_templ). An empty text will prevent a
# log entry, multi-line text will produce several log entries, one for each
# nonempty line. Macro %. might be useful, it counts recipients starting
# from 1. Syntax is explained in the README.customize file.
# Long header fields will be automatically wrapped by the program.
#
[?%#D|#|Passed #
[? [:ccat_maj] |OTHER|[?%2|CLEAN|SPAM.TAG2]|TEMPFAIL|\
OVERSIZED[?%2||.TAG2]|BAD-HEADER[?%2||.TAG2]|SPAM|\
UNCHECKED|BANNED (%F)|INFECTED (%V)]#
#([:ccat_maj],[:ccat_min])#
, %s -> [%D|,], Hits: %c#
, tag=[:tag_level], tag2=[:tag2_level], kill=[:kill_level]#
, %0/%1/%2/%k#
]
[?%#O|#|Blocked #
[? [:ccat_maj] |OTHER|[?%2|CLEAN|SPAM.TAG2]|TEMPFAIL|\
OVERSIZED[?%2||.TAG2]|BAD-HEADER[?%2||.TAG2]|SPAM|\
UNCHECKED|BANNED (%F)|INFECTED (%V)]#
#([:ccat_maj],[:ccat_min])#
, %s -> [%O|,], Hits: %c#
, tag=[:tag_level], tag2=[:tag2_level], kill=[:kill_level]#
, %0/%1/%2/%k#
]
__DATA__
#
# =============================================================================
# This is a template for (neutral: non-virus, non-spam, non-banned)
# DELIVERY STATUS NOTIFICATIONS to sender.
# For syntax and customization instructions see README.customize.
# The From, To and Date header fields will be provided automatically.
# Long header fields will be automatically wrapped by the program.
#
Subject: [?%#D|Undeliverable mail|Delivery status notification]\
[? [:ccat_maj] |, CLEAN (other)||, TEMPFAIL\
|, OVERSIZED message\
|, invalid header[?[:ccat_min]||: bad MIME|: unencoded 8-bit character\
|: improper use of control char|: all-whitespace header field|]\
|, UNSOLICITED BULK EMAIL apparently from you\
|, contents UNCHECKED\
|, BANNED contents type (%F)\
|, VIRUS in message apparently from you (%V)\
]
Message-ID: <DSN%i@%h>

[? %#D |#|Your message WAS SUCCESSFULLY RELAYED to:[\n  %D]
]
[? %#N |#|The message WAS NOT relayed to:[\n  %N]
]
[:wrap|78|||This [?%#D|nondelivery|delivery] report was \
generated by the program amavisd-new at host %h. \
Our internal reference code for your message is %n/%i]

# ccat_min 0: other,  1: bad MIME,  2: 8-bit char,  3: NUL/CR,
#          4: empty,  5: long,  6: syntax
[? %#X ||[? [:ccat_min]
|INVALID HEADER
|INVALID HEADER: BAD MIME HEADERS OR BAD MIME STRUCTURE
|INVALID HEADER: INVALID 8-BIT CHARACTERS IN HEADER
|INVALID HEADER: INVALID CONTROL CHARACTERS IN HEADER
|INVALID HEADER: FOLDED HEADER FIELD MADE UP ENTIRELY OF WHITESPACE
|INVALID HEADER: HEADER LINE LONGER THAN RFC2822 LIMIT OF 998 CHARACTERS
|INVALID HEADER
]
[[:wrap|78|  |  |%X]\n]
]\
#[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: \[%a\] %g]]
#[? %e |#|[:wrap|78||  |According to a 'Received:' trace,\
# the message originated at: \[%e\], %t]]
[? %s |#|[:wrap|78||  |Return-Path: %s]]
[? %m |#|[:wrap|78||  |Message-ID: %m]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: %r]]
[? %j |#|[:wrap|78||  |Subject: %j]]

# ccat_min 0: other,  1: bad MIME,  2: 8-bit char,  3: NUL/CR,
#          4: empty,  5: long,  6: syntax
[? %#X ||[? [:ccat_min]
|# 0: other
|# 1: bad MIME
|# 2: 8-bit char
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.

  If such 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.
#
[~[:x-mailer]|^Microsoft Outlook Express 6\\.00|["
  If using Microsoft Outlook Express as your MUA, make sure its
  settings under:
     Tools -> Options -> Send -> Mail Sending Format -> Plain & HTML
  are: "MIME format" MUST BE selected,
  and  "Allow 8-bit characters in headers" MUST NOT be enabled!
"]]#
|# 3: NUL/CR
IMPROPER USE OF CONTROL CHARACTER IN MESSAGE HEADER

  The RFC 2822 standard specifies rules for forming internet messages.
  It does not allow the use of control characters NUL and bare CR
  to be used directly in mail header.
|# 4: empty
IMPROPER FOLDED HEADER FIELD MADE UP ENTIRELY OF WHITESPACE

  The RFC 2822 standard specifies rules for forming internet messages.
  In section '3.2.3. Folding white space and comments' it explicitly
  prohibits folding of header fields in such a way that any line of a
  folded header field is made up entirely of white-space characters
  (control characters SP and HTAB) and nothing else.
|# 5: long
HEADER LINE LONGER THAN RFC2822 LIMIT OF 998 CHARACTERS

  The RFC 2822 standard specifies rules for forming internet messages.
  Section '2.1.1. Line Length Limits' prohibits each line of a header
  to be more than 998 characters in length (excluding the CRLF).
|# 6: syntax
|# other
]]#
__DATA__
#
# =============================================================================
# This is a template for VIRUS/BANNED SENDER NOTIFICATIONS.
# For syntax and customization instructions see README.customize.
# The From, To and Date header fields will be provided automatically.
# Long header fields will be automatically wrapped by the program.
#
Subject: [? [:ccat_maj]
|Clean message from you (other)\
|Clean message from you (tempfail)\
|Clean message from you\
|OVERSIZED message from you\
|BAD-HEADER in message from you\
|SPAM apparently from you\
|A message with UNCHECKED contents from you\
|BANNED message from you (%F)\
|VIRUS in message apparently from you (%V)\
]
[? %m  |#|In-Reply-To: %m]
Message-ID: <VS%i@%h>

[? [:ccat_maj] |Clean (other)|Clean|TEMPFAIL|OVERSIZED|\
INVALID HEADER|SPAM|UNCHECKED contents|BANNED CONTENTS ALERT|VIRUS ALERT]

Our content checker found
[? %#V |#|[:wrap|78|    |  |[? %#V |viruses|virus|viruses]: %V]]
[? %#F |#|[:wrap|78|    |  |banned [? %#F |names|name|names]: %F]]
[? %#X |#|[[:wrap|78|    |  |%X]\n]]

in email presumably from you %s
to the following [? %#R |recipients|recipient|recipients]:[
-> %R]

Our internal reference code for your message is %n/%i

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: \[%a\] %g]]
[? %e |#|[:wrap|78||  |According to a 'Received:' trace,\
 the message originated at: \[%e\], %t]]

[? %s |#|[:wrap|78||  |Return-Path: %s]]
[? %m |#|[:wrap|78||  |Message-ID: %m]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: %r]]
[? %j |#|[:wrap|78||  |Subject: %j]]

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

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

]#
[? %#V |[? %#F ||#
The message [?%#D|has been blocked|triggered this warning] 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 more popular mail readers (Microsoft
mail readers and browsers are a common target). By requiring an explicit
and decisive action from the recipient to decode mail, the danger of
automatic malware propagation is largely reduced.
#
# Details of our mail restrictions policy are available at ...

]]#
__DATA__
#
# =============================================================================
# This is a template for non-spam (VIRUS,...) ADMINISTRATOR NOTIFICATIONS.
# For syntax and customization instructions see README.customize.
# Long header fields will be automatically wrapped by the program.
#
Date: %d
From: %f
Subject: [? [:ccat_maj] |Clean (?) mail|Clean mail|TEMPFAIL-ed mail|\
OVERSIZED mail|INVALID HEADER in mail|SPAM|UNCHECKED contents in mail|\
BANNED contents (%F) in mail|VIRUS (%V) in mail]\
 FROM [?%l||LOCAL ][?%a||\[%a\] ][?%s|<>|[?%o|(?)|%s]]
To: [? %#T |undisclosed-recipients: ;|[<%T>|, ]]
[? %#C |#|Cc: [<%C>|, ]]
Message-ID: <VA%i@%h>

[? %#V |No viruses were found.
|A virus was found: %V
|Two viruses were found:\n  %V
|%#V viruses were found:\n  %V
]
[? %#F |#|[:wrap|78||  |Banned [?%#F|names|name|names]: %F]]
[? %#X |#|Bad header:[\n[:wrap|78|  |  |%X]]]
[? %#W |#\
|Scanner detecting a virus: %W
|Scanners detecting a virus: %W
]
Content type: [:ccat_name] ([:ccat_maj],[:ccat_min])
Internal reference code for the message is %n/%i

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: \[%a\] %g]]
[? %e |#|[:wrap|78||  |According to a 'Received:' trace,\
 the message originated at: \[%e\], %t]]

[? %s |#|[:wrap|78||  |Return-Path: %s]]
[? %m |#|[:wrap|78||  |Message-ID: %m]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: %r]]
[? [:x-mailer]|#|[:wrap|78||  |X-Mailer: [:x-mailer]]]
[? %j |#|[:wrap|78||  |Subject: %j]]
[? %q |Not quarantined.|The message has been quarantined as: %q]

[? %#S |Notification to sender will not be mailed.

]#
[? %#D |#|The message WILL BE relayed to:[\n%D]
]
[? %#N |#|The message WAS NOT relayed to:[\n%N]
]
[? %#V |#|[? %#v |#|Virus scanner output:[\n  %v]
]]
__DATA__
#
# =============================================================================
# This is a template for VIRUS/BANNED/BAD-HEADER RECIPIENTS NOTIFICATIONS.
# For syntax and customization instructions see README.customize.
# Long header fields will be automatically wrapped by the program.
#
Date: %d
From: %f
Subject: [? [:ccat_maj] |Clean (?) mail|Clean mail|TEMPFAIL-ed mail|\
OVERSIZED mail|INVALID HEADER in mail|SPAM|UNCHECKED contents in mail|\
BANNED contents (%F) in mail|VIRUS (%V) in mail]\
 TO YOU from [?%s|<>|[?%o|(?)|%s]]
To: [? %#T |undisclosed-recipients: ;|[<%T>|, ]]
[? %#C |#|Cc: [<%C>|, ]]
Message-ID: <VR%i@%h>

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

Our content checker found
[? %#V |#|[:wrap|78|    |  |[?%#V|viruses|virus|viruses]: %V]]
[? %#F |#|[:wrap|78|    |  |banned [?%#F|names|name|names]: %F]]
[? %#X |#|[[:wrap|78|    |  |%X]\n]]

in an email to you [? %S |from unknown sender:|from:]
  %o
[? %S |claiming to be: %s|#]

Our internal reference code for your message is %n/%i

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: \[%a\] %g]]
[? %e |#|[:wrap|78||  |According to a 'Received:' trace,\
 the message originated at: \[%e\], %t]]

[? %s |#|[:wrap|78||  |Return-Path: %s]]
[? %m |#|[:wrap|78||  |Message-ID: %m]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: %r]]
[? [:x-mailer]|#|[:wrap|78||  |X-Mailer: [:x-mailer]]]
[? %j |#|[:wrap|78||  |Subject: %j]]
[? %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.
# The From, To and Date header fields will be provided automatically.
# Long header fields will be automatically wrapped by the program.
#
Subject: Considered UNSOLICITED BULK EMAIL, apparently from you
[? %m  |#|In-Reply-To: %m]
Message-ID: <SS%i@%h>

A message from %s to:[
-> %R]

was considered unsolicited bulk e-mail (UBE).

Our internal reference code for your message is %n/%i

The message carried your return address, so it was either a genuine mail
from you, or a sender address was faked and your e-mail address abused
by third party, in which case we apologize for undesired notification.

We do try to minimize backscatter for more prominent cases of UBE and
for infected mail, but for less obvious cases of UBE some balance
between losing genuine mail and sending undesired backscatter is sought,
and there can be some collateral damage on both sides.

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: \[%a\] %g]]
[? %e |#|[:wrap|78||  |According to a 'Received:' trace,\
 the message originated at: \[%e\], %t]]

[? %s |#|[:wrap|78||  |Return-Path: %s]]
[? %m |#|[:wrap|78||  |Message-ID: %m]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: %r]]
[? %j |#|[:wrap|78||  |Subject: %j]]
[? %#X |#|\n[[:wrap|78||  |%X]\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.
# Long header fields will be automatically wrapped by the program.
#
Date: %d
From: %f
Subject: SPAM FROM [?%l||LOCAL ][?%a||\[%a\] ][?%s|<>|[?%o|(?)|%s]]
To: [? %#T |undisclosed-recipients: ;|[<%T>|, ]]
[? %#C |#|Cc: [<%C>|, ]]
[? %#B |#|Bcc: [<%B>|, ]]
Message-ID: <SA%i@%h>

Internal reference code for the message is %n/%i

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: \[%a\] %g]]
[? %e |#|[:wrap|78||  |According to a 'Received:' trace,\
 the message originated at: \[%e\], %t]]

[? %s |#|[:wrap|78||  |Return-Path: %s]]
[? %m |#|[:wrap|78||  |Message-ID: %m]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: %r]]
[? [:x-mailer]|#|[:wrap|78||  |X-Mailer: [:x-mailer]]]
[? %j |#|[:wrap|78||  |Subject: %j]]
[? %q |Not quarantined.|The message has been quarantined as: %q]

[? %#D |#|The message WILL BE relayed to:[\n%D]
]
[? %#N |#|The message WAS NOT relayed to:[\n%N]
]
SpamAssassin report:
[%A
]\
