amavisd   [plain text]


#!/usr/bin/perl -T

#------------------------------------------------------------------------------
# This is amavisd-new.
# It is an interface between a 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-2009 Mark Martinec,
#   All Rights Reserved.
# with contributions from the amavis-user mailing list 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::Log
#  Amavis::Timing
#  Amavis::Util
#  Amavis::ProcControl
#  Amavis::rfc2821_2822_Tools
#  Amavis::Lookup::RE
#  Amavis::Lookup::IP
#  Amavis::Lookup::Label
#  Amavis::Lookup
#  Amavis::Expand
#  Amavis::TempDir
#  Amavis::IO::FileHandle
#  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::Custom
#  Amavis
#optionally compiled-in packages: ---------------------------------------------
#  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::Protocol
#  Amavis::Out::SMTP::Session
#  Amavis::Out::SMTP
#  Amavis::Out::Pipe
#  Amavis::Out::BSMTP
#  Amavis::Out::Local
#  Amavis::OS_Fingerprint
#  Amavis::Out::SQL::Connection
#  Amavis::Out::SQL::Log
#  Amavis::IO::SQL
#  Amavis::Out::SQL::Quarantine
#  Amavis::AV
#  Amavis::SpamControl
#  Amavis::SpamControl::ExtProg
#  Amavis::SpamControl::SpamdClient
#  Mail::SpamAssassin::Logger::Amavislog
#  Amavis::SpamControl::SpamAssassin
#  Amavis::Unpackers
#  Amavis::DKIM
#  Amavis::Tools
#------------------------------------------------------------------------------

use strict;
use re 'taint';
use warnings FATAL => 'utf8';
no warnings 'uninitialized';

#
package Amavis::Boot;
use strict;
use re 'taint';
use Errno qw(ENOENT EACCES);

# replacement for a 'require' with a more informative error handling
#sub my_require($) {
# my($filename) = @_;
# my($result);
# if (exists $INC{$filename} && !$INC{$filename}) {
#   die "Compilation failed in require\n";
# } elsif (exists $INC{$filename}) {
#   $result = 1;  # already loaded
# } else {
#   my($found) = 0;
#   for my $prefix (@INC) {
#     my($full_fname) = "$prefix/$filename";
#     my(@stat_list) = stat($full_fname);  # symlinks-friendly
#     my($errn) = @stat_list ? 0 : 0+$!;
#     if ($errn != ENOENT) {
#       $found = 1;
#       $INC{$filename} = $full_fname;
#       my($owner_uid) = $stat_list[4];
#       my($msg);
#       if ($errn)         { $msg = "is inaccessible: $!" }
#       elsif (-d _)       { $msg = "is a directory" }
#       elsif (!-f _)      { $msg = "is not a regular file" }
#       elsif ($> && -o _) { $msg = "should not be owned by EUID $>"  }
#       elsif ($> && -w _) { $msg = "is writable by EUID $>, EGID $)" }
#       elsif ($owner_uid) { $msg = "should be owned by root (uid 0) "}
#       !defined($msg) or die "Requiring $full_fname, file $msg,\n";
#       $! = 0;
#       $result = do $full_fname;
#       if (!defined($result) && $@ ne '') {
#         undef $INC{$filename}; chomp($@);
#         die "Error in file $full_fname: $@\n";
#       } elsif (!defined($result) && $! != 0) {
#         undef $INC{$filename};
#         die "Error reading file $full_fname: $!\n";
#       } elsif (!$result) {
#         undef $INC{$filename};
#         die "Module $full_fname did not return a true value\n";
#       }
#       last;
#     }
#   }
#   die sprintf("my_require: Can't locate %s in \@INC (\@INC contains: %s)\n",
#               $filename, join(' ',@INC))  if !$found;
# }
# $result;
#}

# 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($have_sawampersand) = Devel::SawAmpersand->UNIVERSAL::can("sawampersand");
  my($amp) = $have_sawampersand && Devel::SawAmpersand::sawampersand() ? 1 : 0;
  warn "fetch_modules: PL_sawampersand flag was already turned on"  if $amp;
  my(@missing);
  for my $m (@modules) {
    local($_) = $m;
    $_ .= /^auto::/ ? '.al' : '.pm'  if !m{^/} && !m{\.(pm|pl|al|ix)\z};
    s{::}{/}g;
  # eval { my_require $_ } #more informative on err, but some problems reported
    eval { require $_ }
    or do {
      my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      push(@missing,$m);
      printf STDERR ("fetch_modules: error loading %s module %s:\n%s\n",
                     $required ? 'required' : 'optional',  $_,
                     join("\n", map {"  $_"} split(/\n/,$eval_stat)))
        if $eval_stat !~ /\bCan't locate \Q$_\E in \@INC\b/;
    };
    if ($have_sawampersand && !$amp && Devel::SawAmpersand::sawampersand())
      { $amp = 1; warn "Loading of module $m turned on PL_sawampersand flag" }
  }
  die "ERROR: MISSING $reason:\n" . join('', map { "  $_\n" } @missing)
    if $required && @missing;
  \@missing;
}

BEGIN {
  if ($] < 5.008000) {  # deal with a perl 5.6.1 glob() taint bug
    fetch_modules('REQUIRED BASIC MODULES', 1, qw(File::Glob));
    File::Glob->import(':globally');  # use the same module as Perl 5.8 uses
  }
  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::Stringy Digest::MD5 Unix::Syslog File::Basename
    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::Server Net::Server::PreFork
  ));
  # 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(
    PerlIO PerlIO::scalar Unix::Getrusage
    Carp::Heavy auto::POSIX::setgid auto::POSIX::setuid
    auto::POSIX::SigAction::new auto::POSIX::SigAction::safe
    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, in increasing order of importance
sub CC_CATCHALL()  { 0 }
sub CC_CLEAN ()    { 1 }  # tag_level = "CC_CLEAN,1"
sub CC_MTA   ()    { 2 }  # trouble passing mail back to MTA
sub CC_OVERSIZED() { 3 }
sub CC_BADH  ()    { 4 }
sub CC_SPAMMY()    { 5 }  # tag2_level  (and: tag3_level = "CC_SPAMMY,1")
sub CC_SPAM  ()    { 6 }  # kill_level
sub CC_UNCHECKED() { 7 }
sub CC_BANNED()    { 8 }
sub CC_VIRUS ()    { 9 }
#
*CC_TEMPFAIL = \&CC_MTA;  # alias - old name, cc 2 was repurposed/generalized)
#
#  in other words:              major_ccat minor_ccat %subject_tag_maps_by_ccat
## if    score >= kill level  =>  CC_SPAM    0
## elsif score >= tag3 level  =>  CC_SPAMMY  1        @spam_subject_tag3_maps
## elsif score >= tag2 level  =>  CC_SPAMMY  0        @spam_subject_tag2_maps
## elsif score >= tag  level  =>  CC_CLEAN   1        @spam_subject_tag_maps
## else                       =>  CC_CLEAN   0

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = (
    'dynamic_confvars' =>  # per- policy bank settings
    [qw(
      $policy_bank_name $protocol @inet_acl
      $myhostname $snmp_contact $snmp_location
      $syslog_ident $syslog_facility $syslog_priority
      $log_level $log_templ $log_recip_templ
      $forward_method $notify_method $resend_method
      $release_method $requeue_method $release_format $report_format
      $os_fingerprint_method $os_fingerprint_dst_ip_and_port
      $originating @smtpd_discard_ehlo_keywords
      $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 $tls_security_level_in $tls_security_level_out
      $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 @spam_scanners
      $first_infected_stops_scan
      $sa_spam_report_header $sa_spam_level_char $sa_mail_body_size_limit
      $penpals_bonus_score $penpals_halflife $bounce_killer_score
      $reputation_factor
      $undecipherable_subject_tag $localpart_is_case_sensitive
      $recipient_delimiter $replace_existing_extension
      $hdr_encoding $bdy_encoding $hdr_encoding_qb
      $allow_disclaimers $insert_received_line
      $append_header_fields_to_bottom $prepend_header_fields_hdridx
      $allow_fixing_improper_header
      $allow_fixing_improper_header_folding $allow_fixing_long_header_lines
      %allowed_added_header_fields %allowed_header_tests
      $X_HEADER_TAG $X_HEADER_LINE $notify_xmailer_header
      $remove_existing_x_scanned_headers $remove_existing_spam_headers
      %sql_clause $sql_partition_tag
      %local_delivery_aliases $banned_namepath_re
      $per_recip_whitelist_sender_lookup_tables
      $per_recip_blacklist_sender_lookup_tables
      @anomy_sanitizer_args @altermime_args_defang
      @altermime_args_disclaimer @disclaimer_options_bysender_maps
      %signed_header_fields @dkim_signature_options_bysender_maps

      @local_domains_maps @mynetworks_maps @client_ipaddr_policy
      @newvirus_admin_maps @banned_filename_maps
      @spam_quarantine_bysender_to_maps
      @spam_tag_level_maps @spam_tag2_level_maps @spam_tag3_level_maps
      @spam_kill_level_maps @spam_modifies_subj_maps
      @spam_subject_tag_maps @spam_subject_tag2_maps @spam_subject_tag3_maps
      @spam_dsn_cutoff_level_maps @spam_dsn_cutoff_level_bysender_maps
      @spam_crediblefrom_dsn_cutoff_level_maps
      @spam_crediblefrom_dsn_cutoff_level_bysender_maps
      @spam_quarantine_cutoff_level_maps @spam_notifyadmin_cutoff_level_maps
      @whitelist_sender_maps @blacklist_sender_maps @score_sender_maps
      @author_to_policy_bank_maps @signer_reputation_maps
      @message_size_limit_maps @debug_sender_maps
      @bypass_virus_checks_maps @bypass_spam_checks_maps
      @bypass_banned_checks_maps @bypass_header_checks_maps
      @viruses_that_fake_sender_maps @virus_name_to_spam_score_maps
      @remove_existing_spam_headers_maps

      %final_destiny_by_ccat %lovers_maps_by_ccat
      %defang_maps_by_ccat %subject_tag_maps_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 %notify_autoresp_templ_by_ccat
      %notify_release_templ_by_ccat %notify_report_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
      %hdrfrom_notify_release_by_ccat %hdrfrom_notify_report_by_ccat
      %admin_maps_by_ccat %warnrecip_maps_by_ccat
      %always_bcc_by_ccat %dsn_bcc_by_ccat
      %addr_extension_maps_by_ccat %addr_rewrite_maps_by_ccat
      %smtp_reason_by_ccat
    )],
    'confvars' =>  # global settings (not per-policy, not per-recipient)
    [qw(
      $myproduct_name $myversion_id $myversion_id_numeric $myversion_date
      $myversion $instance_name @additional_perl_modules
      $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 $logline_maxlen $nanny_details_level
      $max_servers $max_requests
      $min_servers $min_spare_servers $max_spare_servers
      $child_timeout $smtpd_timeout
      %current_policy_bank %policy_bank
      %interface_policy @client_ipaddr_policy
      $unix_socketname $inet_socket_port $inet_socket_bind $listen_queue_size
      $smtp_connection_cache_on_demand $smtp_connection_cache_enable
      $relayhost_is_client $smtpd_recipient_limit
      $smtpd_tls_cert_file $smtpd_tls_key_file
      $enforce_smtpd_message_size_limit_64kb_min
      $MAXLEVELS $MAXFILES
      $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR
      $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR
      @lookup_sql_dsn @storage_sql_dsn $timestamp_fmt_mysql
      $sql_quarantine_chunksize_max $sql_allow_8bit_address
      $sql_lookups_no_at_means_domain $ldap_lookups_no_at_means_domain
      $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
      %banned_rules $penpals_threshold_low $penpals_threshold_high
      $enable_dkim_verification $enable_dkim_signing
      %dkim_signing_keys_by_domain
      @dkim_signing_keys_list @dkim_signing_keys_storage
      $file $altermime $enable_anomy_sanitizer
    )],
    'sa' =>  # global SpamAssassin settings
    [qw(
      $spamcontrol_obj
      $helpers_home $sa_configpath $sa_siteconfigpath
      $sa_local_tests_only $sa_auto_whitelist $sa_timeout $sa_debug
      $dspam $sa_spawned
    )],
    'platform' => [qw(
      $can_truncate $unicode_aware $eol $my_pid
      &D_REJECT &D_BOUNCE &D_DISCARD &D_PASS
      &CC_CATCHALL &CC_CLEAN &CC_MTA &CC_OVERSIZED
      &CC_BADH &CC_SPAMMY &CC_SPAM &CC_UNCHECKED &CC_BANNED &CC_VIRUS
      %ccat_display_names %ccat_display_names_major
    )],
    # other variables settable by user in amavisd.conf,
    # but not directly accessible to the program
    'hidden_confvars' => [qw(
      $mydomain
    )],
    'legacy_dynamic_confvars' =>
      # the rest of the program does not use these settings directly and they
      # should not be visible in, or imported to other modules, but may be
      # referenced indirectly through *_by_ccat variables for compatibility
    [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
      $always_bcc $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
      $hdrfrom_notify_release $hdrfrom_notify_report
      $notify_virus_admin_templ  $notify_spam_admin_templ
      $notify_virus_recips_templ $notify_spam_recips_templ
      $notify_virus_sender_templ $notify_spam_sender_templ
      $notify_sender_templ $notify_release_templ
      $notify_report_templ $notify_autoresp_templ
      $warnvirussender $warnspamsender $warnbannedsender $warnbadhsender
      $defang_virus $defang_banned $defang_spam
      $defang_bad_header $defang_undecipherable $defang_all
      $virus_quarantine_method $banned_files_quarantine_method
      $spam_quarantine_method $bad_header_quarantine_method
      $clean_quarantine_method $archive_quarantine_method
      @virus_quarantine_to_maps @banned_quarantine_to_maps
      @spam_quarantine_to_maps  @bad_header_quarantine_to_maps
      @clean_quarantine_to_maps @archive_quarantine_to_maps
      @virus_admin_maps @banned_admin_maps
      @spam_admin_maps @bad_header_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_confvars' =>
      # 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 for backwards compatibility
    [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
      $virus_quarantine_to $banned_quarantine_to
      $spam_quarantine_to $spam_quarantine_bysender_to
      $bad_header_quarantine_to $clean_quarantine_to $archive_quarantine_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_tag3_level_deflt
      $sa_kill_level_deflt
      $sa_quarantine_cutoff_level @spam_notifyadmin_cutoff_level_maps
      $sa_dsn_cutoff_level $sa_crediblefrom_dsn_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 EBADF);

use vars @EXPORT;

sub c($); sub cr($); sub ca($); sub dkim_key(@);  # prototypes
use subs qw(c cr ca dkim_key);  # access subroutine to config vars and keys
BEGIN { push(@EXPORT,qw(c cr ca dkim_key)) }

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

# Store a private DKIM signing key for a given domain and selector.
# The argument $key can be a Mail::DKIM::PrivateKey object or a file
# name containing a key in a PEM format (e.g. as generated by openssl).
# For compatibility with dkim_milter the signing domain can include a '*'
# as a wildcard - this is not recommended as this way amavisd can produce
# signatures which have no corresponding public key published in DNS.
# The proper way is to have one dkim_key entry for each published DNS RR.
# Optional arguments can provide additional information about the resource
# record (RR) of a public key, i.e. its options according to RFC 4871.
# The subroutine is typically called from a configuration file.
#
sub dkim_key($$$;@) {
  my($domain,$selector,$key) = @_;  shift; shift; shift;
  @_%2 == 0 or die "dkim_key: a list of key/value pairs expected as options\n";
  my(%key_options) = @_;  # remaining args are options from a public key RR
  defined $domain && $domain ne ''
    or die "dkim_key: domain must not be empty: ($domain,$selector,$key)";
  defined $selector && $selector ne ''
    or die "dkim_key: selector must not be empty: ($domain,$selector,$key)";
  my($key_storage_ind);
  if (ref $key) {
    push(@dkim_signing_keys_storage, [$key]);
    $key_storage_ind = $#dkim_signing_keys_storage;
  } else {  # assume a file name with a private key in PEM format
    my($fname) = $key;
    my($pem_fh) = IO::File->new;  # open a file with a private key
    $pem_fh->open($fname,'<') or die "Can't open PEM file $fname: $!";
    my(@stat_list) = stat($pem_fh);
    @stat_list or warn "Error on stat($fname): $!";
    my($dev,$inode) = @stat_list;
    if ($dev && $inode) {
      for my $j (0..$#dkim_signing_keys_storage) {  # same file reused?
        my($k,$dv,$in,$fn) = @{$dkim_signing_keys_storage[$j]};
        if ($dv == $dev && $in == $inode) { $key_storage_ind = $j; last }
      }
    }
    if (!defined($key_storage_ind)) {
      # read file and store its contents as new entry
      my($ln); $key = '';
      for ($! = 0; defined($ln=$pem_fh->getline); $! = 0) { $key .= $ln }
      defined $ln || $!==0  or         # returning EBADF at EOF is a perl bug
        $!==EBADF ? do_log(0,"Error reading key from file %s: %s", $fname,$!)
                  : die "Error reading key from file $fname: $!";
      push(@dkim_signing_keys_storage, [$key,$dev,$inode,$fname]);
      $key_storage_ind = $#dkim_signing_keys_storage;
    }
    $pem_fh->close or die "Error closing file $fname: $!";
    $key_options{k} = 'rsa'  if defined $key_options{k};  # force RSA
  }
  $domain   = lc($domain)  if !ref($domain);  # possibly a regexp
  $selector = lc($selector);
  $key_options{domain} = $domain; $key_options{selector} = $selector;
  $key_options{key_storage_ind} = $key_storage_ind;
  !grep { $_->{domain} eq $domain && $_->{selector} eq $selector }
        @dkim_signing_keys_list
    or die "dkim_key: selector $selector for domain $domain already in use\n";
  $key_options{key_ind} = $#dkim_signing_keys_list + 1;
  push(@dkim_signing_keys_list, \%key_options);  # using list to preserve order
}

# essential initializations, right at the program start time, may run as root!
#
use vars qw($read_config_files_depth @actual_config_files);
BEGIN {  # init_primary: version, $unicode_aware, base policy bank
  $myproduct_name = 'amavisd-new';
  $myversion_id = '2.6.4'; $myversion_date = '20090625';

  $myversion = "$myproduct_name-$myversion_id ($myversion_date)";
  $myversion_id_numeric =  # x.yyyzzz, allows numerical compare, 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 };
  $read_config_files_depth = 0;
  eval { require Devel::SawAmpersand }; # load if avail, don't bother otherwise
  # initialize policy bank hash to contain dynamic config settings
  for my $tag (@EXPORT_TAGS{'dynamic_confvars', 'legacy_dynamic_confvars'}) {
    for my $v (@$tag) {
      local($1,$2);
      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
} # end BEGIN - init_primary


# boot-time initializations of simple global settings, may run as root!
#
BEGIN {
  # serves only as a quick default for other configuration settings
  $MYHOME   = '/var/amavis';
  $mydomain = '!change-mydomain-variable!.example.com';#intentionally bad deflt

  # 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 = 20;  # retire a child after that many accepts, 0=unlimited

  # 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's 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 wasn't infected
  $virus_check_positive_ttl= 30*60; # time to remember that mail was infected
  $spam_check_negative_ttl = 10*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 and the
  #   mail rate. With high 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';

  # should be less than 1023-prefix, i.e. 980, see sub write_log
  $logline_maxlen = 980;

  $enable_db = 0;         # load optional modules Amavis::DB & Amavis::DB::SNMP
  $enable_global_cache = 0;  # enable use of bdb-based Amavis::Cache
  $nanny_details_level = 1;  # register_proc verbosity: 0, 1, 2
# $enable_dkim_signing = undef;
# $enable_dkim_verification = undef;

  $reputation_factor = 0.2;  # a value between 0 and 1, controlling the amount
    # of 'bending' of a calculated spam score towards a fixed score assigned
    # to a signer identity (its 'reputation') through @signer_reputation_maps;
    # the formula is: adjusted_spam_score = f*reputation + (1-f)*spam_score;
    # which has the same semantics as auto_whitelist_factor in SpamAssassin AWL

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

  # Does a database mail address field with no '@' character represent a
  # local username or a domain name?  By default it implies a username in
  # SQL and LDAP lookups (but represents a domain in hash and acl lookups),
  # so domain names in SQL and LDAP should be specified as '@domain'.
  # Setting these to true will cause 'xxx' to be interpreted as a domain
  # name, just like in hash or acl lookups.
  #
  $sql_lookups_no_at_means_domain  = 0;
  $ldap_lookups_no_at_means_domain = 0;

  # Maximum size (in bytes) for data written to a field 'quarantine.mail_text'
  # when quarantining to SQL. Must not exceed size allowed for a data type
  # on a given SQL server. It also determines a buffer size in amavisd.
  # Too large a value may exceed process virtual memory limits or just waste
  # memory, too small a value splits large mail into too many chunks, which
  # may be less efficient to process.
  #
  $sql_quarantine_chunksize_max = 16384;
  $sql_allow_8bit_address = 0;

  $penpals_bonus_score = undef;  # maximal (positive) score value by which spam
       # score is lowered when sender is known to have previously received mail
       # from our local user from this mail system. Zero or undef disables
       # pen pals lookups in SQL tables msgs and msgrcpt, and is a default.
  $penpals_halflife = 7*24*60*60; # exponential decay time constant in seconds;
       # pen pal bonus is halved for each halflife period since the last mail
       # sent by a local user to a current message's sender
  $penpals_threshold_low = 1.0;   # SA score below which pen pals lookups are
       # not performed to save time; undef lets the threshold be ignored;
  $penpals_threshold_high = undef;
       # when (SA_score - $penpals_bonus_score > $penpals_threshold_high)
       # pen pals lookup will not be performed to save time, as it could not
       # influence blocking of spam even at maximal penpals bonus (age=0);
       # usual choice for value would be kill level or other reasonably high
       # value; undef lets the threshold be ignored and is a default (useful
       # for testing and statistics gathering);

  $bounce_killer_score = 0;

  #
  # Receiving mail related

  # $unix_socketname = '/var/amavis/amavisd.sock'; # old 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 );
  $originating = 0;  # a boolean, initially reflects @mynetworks,
                     # but may be modified later through a policy bank
  $notify_method  = 'smtp:[127.0.0.1]:10025';
  $forward_method = 'smtp:[127.0.0.1]:10025';
  $resend_method  = undef; # overrides $forward_method on defanging if nonempty
  $release_method = undef; # overrides $notify_method on releasing
                           #   from quarantine if nonempty
  $requeue_method = 'smtp:[127.0.0.1]:25'; # requeueing release from a quarant.
  $release_format = 'resend';  # (dsn), (arf), attach,  plain,  resend
  $report_format  = 'arf';     # (dsn),  arf,  attach,  plain,  resend
  $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';
  $clean_quarantine_method = undef;   # 'local:clean-%m';
  $archive_quarantine_method = undef; # 'local:archive-%m.gz';

  $insert_received_line = 1; # insert Received: header field? (not with milter)
  $append_header_fields_to_bottom    = 0;  # obsolete! (always treated as 0)
  $prepend_header_fields_hdridx      = 0;  # normally 0, use 1 for co-existence
                                           # with signing DK and DKIM milters
  $remove_existing_x_scanned_headers = 0;
  $remove_existing_spam_headers      = 1;

  # fix improper header fields in passed or released mail - this setting
  # is a pre-condition for $allow_fixing_improper_header_folding and similar
  # (future) fixups; (desirable, but may break DKIM validation of messages
  # with illegal header section)
  $allow_fixing_improper_header = 1;

  # fix improper folded header fields made up entirely of whitespace, by
  # removing all-whitespace lines ($allow_fixing_improper_header must be true)
  $allow_fixing_improper_header_folding = 1;

  # truncate header section lines longer than 998 characters as limited
  # by the rfc2822 ($allow_fixing_improper_header must be true)
  $allow_fixing_long_header_lines = 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 !

  $snmp_contact  = '';  # a value of sysContact OID
  $snmp_location = '';  # a value of sysLocation OID

  $smtpd_greeting_banner = '${helo-name} ${protocol} ${product} service ready';
  $smtpd_quit_banner = '${helo-name} ${product} closing transmission channel';
  $enforce_smtpd_message_size_limit_64kb_min = 1;

  # $localhost_name is the name of THIS host running amavisd
  # (typically 'localhost'). It is used in HELO SMTP command
  # when reinjecting mail back to MTA via SMTP for final delivery,
  # and in inserted Received header field
  $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
  $tls_security_level_in  = undef;  # undef, 'may', 'encrypt', ...
  $tls_security_level_out = undef;  # undef, 'may', 'encrypt', ...
  $smtpd_tls_cert_file = undef;  # e.g. "$MYHOME/cert/amavisd-cert.pem"
  $smtpd_tls_key_file  = undef;  # e.g. "$MYHOME/cert/amavisd-key.pem"

  # 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
  $smtp_connection_cache_on_demand = 1;
  $smtp_connection_cache_enable = 1;

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

  # where to send quarantined malware - specify undef to disable, or an
  # e-mail address containing '@', or just a local part, which will be
  # mapped by %local_delivery_aliases into local mailbox name or directory.
  # The lookup key is a recipient address
  $virus_quarantine_to      = 'virus-quarantine';
  $banned_quarantine_to     = 'banned-quarantine';
  $spam_quarantine_to       = 'spam-quarantine';
  $bad_header_quarantine_to = 'bad-header-quarantine';
  $clean_quarantine_to      = 'clean-quarantine';
  $archive_quarantine_to    = 'archive-quarantine';

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

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

  @spam_scanners = (
    ['SpamAssassin', 'Amavis::SpamControl::SpamAssassin' ],
  # ['SpamdClient',  'Amavis::SpamControl::SpamdClient'  ],
  # ['DSPAM',  'Amavis::SpamControl::ExtProg', $dspam,
  #   [ qw(--stdout --classify --deliver=innocent,spam
  #        --mode=tum --tokenizer=chained,noise
  #        --user), $daemon_user ],
  #   # use option --feature instead of --tokenizer with dspam < 3.8.0
  #   mail_body_size_limit => 65000, score_factor => 0.1,
  # ],
  # ['CRM114', 'Amavis::SpamControl::ExtProg', 'crm',
  #   [ qw(-u /var/amavis/home/.crm114 mailreaver.crm
  #        --dontstore --report_only --stats_only
  #        --good_threshold=10 --spam_threshold=-10) ],
  #   mail_body_size_limit => 65000, score_factor => -0.20,
  # ],
  );

  $sa_spawned = 0;  # true: run SA in a subprocess;  false: call SA directly

  # 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 low boundary in seconds for a call to SpamAssassin

  $file = 'file';  # path to the file(1) utility for classifying contents
  $altermime = 'altermime';  # path to the altermime utility (optional)
  @altermime_args_defang     = qw(--verbose --removeall);
  @altermime_args_disclaimer = qw(--disclaimer=/etc/altermime-disclaimer.txt);
  # @altermime_args_disclaimer =
  #  qw(--disclaimer=/etc/_OPTION_.txt --disclaimer-html=/etc/_OPTION_.html);
  # @disclaimer_options_bysender_maps = ( 'altermime-disclaimer' );

  $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:    accept/forward a message
  #
  # COMPATIBILITY 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
  #            (unless suppressed). 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 (if 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
  #            and its interface to a content checker; 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.
  #            Exceeded spam cutoff limit or faked virus sender implicitly
  #            turns D_BOUNCE into a D_DISCARD;

  $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 decided to pass viruses (or spam) to certain recipients using
  # %lovers_maps_by_ccat, or by %final_destiny_by_ccat resulting in D_PASS,
  # one may set the corresponding %addr_extension_maps_by_ccat to some string,
  # and the recipient address will have this string appended as an address
  # extension to a local-part (mailbox part) of the address. This extension
  # can be used by a final local delivery agent for example to place such mail
  # in different folder. Leaving these variable undefined or empty string
  # prevents appending address extension. 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 variable %addr_extension_maps_by_ccat.
  # 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_maps_by_ccat setting.

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

} # end BEGIN - init_secondary


# init structured variables like %sql_clause, $map_full_type_to_short_type_re,
# %ccat_display_names, @decoders, build default maps;  may run as root!
#
BEGIN {
  $allowed_added_header_fields{lc($_)} = 1  for qw(
    Received DKIM-Signature Authentication-Results
    X-Quarantine-ID X-Amavis-Alert X-Amavis-Hold X-Amavis-Modified
    X-Amavis-PenPals X-Amavis-OS-Fingerprint X-Amavis-PolicyBank
    X-Spam-Status X-Spam-Level X-Spam-Flag X-Spam-Score
    X-Spam-Report X-Spam-Checker-Version X-Spam-Tests
    X-CRM114-Status X-CRM114-CacheID X-CRM114-Notice X-CRM114-Action
    X-DSPAM-Result X-DSPAM-Class X-DSPAM-Signature X-DSPAM-Processed
    X-DSPAM-Confidence X-DSPAM-Probability X-DSPAM-User X-DSPAM-Factors
  );
  $allowed_added_header_fields{lc('X-Spam-Checker-Version')} = 0;
  # $allowed_added_header_fields{lc(c('X_HEADER_TAG'))} = 1; #later:read_config
  # $allowed_added_header_fields{lc('Received')} = 0 if !$insert_received_line;

  # controls which header section tests are performed in check_header_validity,
  # keys correspond to minor contents categories for CC_BADH
  $allowed_header_tests{lc($_)} = 1  for qw(
                   other mime 8bit control empty long syntax missing multiple);

  # rfc4871 standard set of header fields to be signed:
  my(@sign_headers) = qw(From Sender Reply-To Subject Date Message-ID To Cc
    In-Reply-To References MIME-Version Content-Type Content-Transfer-Encoding
    Content-ID Content-Description Resent-Date Resent-From Resent-Sender
    Resent-To Resent-Cc Resent-Message-ID List-Id List-Post List-Owner
    List-Subscribe List-Unsubscribe List-Help List-Archive);
  # additional header fields considered appropriate, see also rfc4021
  # and IANA registry "Permanent Message Header Field Names";
  # see rfc3834 for Auto-Submitted
  push(@sign_headers, qw(Received Precedence
    Original-Message-ID Message-Context PICS-Label Sensitivity Solicitation
    Content-Location Content-Features Content-Disposition Content-Language
    Content-Alternative Content-Base Content-MD5 Content-Duration Content-Class
    Accept-Language Auto-Submitted Archived-At));
  # note that we are signing Received despite the advise in rfc4871;
  # some additional nonstandard header fields:
  push(@sign_headers, qw(Organization Organisation User-Agent X-Mailer));
  $signed_header_fields{lc($_)} = 1  for @sign_headers;
  # Excluded:
  #   DKIM-Signature DomainKey-Signature Keywords Comments
  #   Errors-To X-Archived-At X-Virus-Scanned
  # Some MTAs are dropping Disposition-Notification-To, exclude:
  #   Disposition-Notification-To Disposition-Notification-Options
  # Signing a 'Sender' may not be a good idea because when such mail is sent
  # through a mailing list, this header field is usually replaced by a new one,
  # invalidating a signature. Long To and Cc address lists are often mangled,
  # especially when containing non-encoded display names. Off: Sender, To, Cc
  $signed_header_fields{lc($_)} = 0  for qw(Sender To Cc);
  #
  # a value greater than 1 causes signing of one additional null instance of
  # a header field, thus prohibiting prepending additional occurences of such
  # header field without breaking a signature
  $signed_header_fields{lc($_)} = 2  for qw(From Date Subject Content-Type);

  # 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_CLEAN.',1', 'CleanTag',   # tag_level
    CC_MTA,        'MtaFailed',  # unable to forward (general)
    CC_MTA.',1',   'MtaTempFailed',  # MTA response was 4xx
    CC_MTA.',2',   'MtaRejected',    # MTA response was 5xx
    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_BADH.',7',  'BadHdrMissing',
    CC_BADH.',8',  'BadHdrDupl',
    CC_SPAMMY,     'Spammy',     # tag2_level
    CC_SPAMMY.',1','Spammy3',    # tag3_level
    CC_SPAM,       'Spam',       # kill_level
    CC_UNCHECKED,  'Unchecked',
    CC_BANNED,     'Banned',
    CC_VIRUS,      'Virus',
  );

  # provide names for content categories - to be used only for logging,
  # SNMP counter names and display purposes, similar to %ccat_display_names
  # but only major contents category names are listed
  %ccat_display_names_major = (
    CC_CATCHALL,   'CatchAll',   # last resort, should not normally appear
    CC_CLEAN,      'Clean',
    CC_MTA,        'MtaFailed',  # unable to forward
    CC_OVERSIZED,  'Oversized',
    CC_BADH,       'BadHdr',
    CC_SPAMMY,     'Spammy',     # tag2_level
    CC_SPAM,       'Spam',       # kill_level
    CC_UNCHECKED,  'Unchecked',
    CC_BANNED,     'Banned',
    CC_VIRUS,      'Virus',
  );

  # $sql_partition_tag is a user-specified SQL field value in tables
  # maddr, msgs, msgrcpt and quarantine, inserted into new records. It is
  # usually an integer, but depending on a schema may be other data type
  # e.g. a string. May be used to speed up purging of old records by using
  # partitioned tables (MySQL 5.1+, PostgreSQL 8.1+). A possible usage can
  # be a week-of-a-year, or some other slowly changing value, allowing to
  # quickly drop old table partitions without wasting time on deleting
  # individual records. Mail addresses in table maddr are self-contained
  # within a partition tag, which means that the same mail address may
  # appear in more than one maddr partition (using different 'id's), and
  # that tables msgs and msgrcpt are guaranteed to reference a maddr.id
  # within their own partition tag. The $sql_partition_tag may be a scalar
  # (usually an integer or a string), or a reference to a subroutine, which
  # will be called with an object of type Amavis::In::Message as argument,
  # and its result will be used as a partition tag value. Possible usage:
  #
  #  $sql_partition_tag =
  #    sub { my($msginfo)=@_; iso8601_week($msginfo->rx_time) };

  # The SQL select clause to fetch per-recipient policy settings.
  # The %k will be replaced by a comma-separated list of query addresses
  # for a recipient (e.g. a full address, domain only, catchall), %a will be
  # replaced by an exact recipient address (same as the first entry in %k,
  # suitable for pattern matching). Use ORDER, if there is a chance that
  # multiple records will match - the first match wins (i.e. the first
  # returned record). 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.*, policy.*, users.id', i.e. the id is repeated at the end.
  # This is a legacy variable for upwards compatibility, now only referenced
  # by the program through a %sql_clause entry 'sel_policy' - newer config
  # files may assign directly to $sql_clause{'sel_policy'} if preferred.
  #
  $sql_select_policy =
    'SELECT users.*, policy.*, users.id'.
    ' FROM users LEFT JOIN policy ON users.policy_id=policy.id'.
    ' WHERE users.email IN (%k) ORDER BY users.priority DESC';

  # Btw, MySQL and PostgreSQL are happy with 'SELECT *, users.id',
  # but Oracle wants 'SELECT users.*, policy.*, users.id', which is
  # also acceptable to MySQL and PostgreSQL.

  # 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 a sender addresses (e.g. a full address, a domain only, a
  # catchall), the %a will be an exact sender address (same as the first entry
  # in %k). 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 or %a, lookup keys will be
  # replicated accordingly. Up until version 2.2.0 the '?' had to be placed
  # before the '%k'; starting with 2.2.1 this restriction is lifted.
  # This is a separate legacy variable for upwards compatibility, now only
  # referenced by the program through %sql_clause entry 'sel_wblist' - newer
  # config files may assign directly to $sql_clause{'sel_wblist'} if preferred.
  #
  $sql_select_white_black_list =
    'SELECT wb FROM wblist 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 partition_tag=? AND email=?',
    'ins_adr' =>
      'INSERT INTO maddr (partition_tag, email, domain) VALUES (?,?,?)',
    'ins_msg' =>
      'INSERT INTO msgs (partition_tag, 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=?, client_addr=?'.
      ' WHERE partition_tag=? AND mail_id=?',
    'ins_rcp' =>
      'INSERT INTO msgrcpt (partition_tag, mail_id, rid,'.
      ' ds, rs, bl, wl, bspam_level, smtp_resp) VALUES (?,?,?,?,?,?,?,?,?)',
#     'INSERT INTO msgrcpt (partition_tag, mail_id, rid,'.
#     ' ds, rs, content, bl, wl, bspam_level, sql_policy_id, smtp_resp)'.
#     ' VALUES (?,?,?,?,?,?,?,?,?,?,?)',
    'ins_quar' =>
      'INSERT INTO quarantine (partition_tag, mail_id, chunk_ind, mail_text)'.
      ' VALUES (?,?,?,?)',
    'sel_msg' =>  # obtains partition_tag if missing in a release request
      'SELECT partition_tag FROM msgs WHERE mail_id=?',
    'sel_quar' =>
      'SELECT mail_text FROM quarantine'.
      ' WHERE coalesce(partition_tag,0)=coalesce(?,0) AND mail_id=?'.
      ' ORDER BY chunk_ind',
    'sel_penpals' =>  # no message-id references list
      "SELECT msgs.time_num, msgs.mail_id, subject".
      " FROM msgs JOIN msgrcpt USING (partition_tag,mail_id)".
      " WHERE sid=? AND rid=? AND msgs.content!='V' AND ds='P'".
      " ORDER BY msgs.time_num DESC",  # LIMIT 1
    'sel_penpals_msgid' =>  # with a nonempty message-id references list
      "SELECT msgs.time_num, msgs.mail_id, subject, message_id, rid".
      " FROM msgs JOIN msgrcpt USING (partition_tag,mail_id)".
      " WHERE sid=? AND msgs.content!='V' AND ds='P' AND message_id IN (%m)".
        " AND rid!=sid".
      " ORDER BY rid=? DESC, msgs.time_num DESC",  # LIMIT 1
  );
  # NOTE on $sql_clause{'upd_msg'}: MySQL clobbers timestamp on update
  # (unless DEFAULT 0 is used) setting it to current local time and
  # losing the cherishly preserved and prepared time of mail reception.
  # From the MySQL 4.1 documentation:
  # * With neither DEFAULT nor ON UPDATE clauses, it is the same as
  #   DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP.
  # * suppress the automatic initialization and update behaviors for the first
  #   TIMESTAMP column by explicitly assigning it a constant DEFAULT value
  #   (for example, DEFAULT 0)
  # * The first TIMESTAMP column in table row automatically is updated to
  #   the current timestamp when the value of any other column in the row is
  #   changed, unless the TIMESTAMP column explicitly is assigned a value
  #   other than NULL.

  # maps full string as returned by a file(1) utility into a short string;
  # 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()

  # prepare an arrayref, later to be converted to an Amavis::Lookup::RE object
  $map_full_type_to_short_type_re = [
    [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:/                        => '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/^UTF.* Unicode text\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.*\banimated cursor\b/   =>['movie','ani'] ],
    [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/^Microsoft Installer\b/i        => 'doc'],  # file(1) may misclassify
    [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/^7-zip archive\b/i              => '7z'],
    [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','unzoo'] ],
    [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 empty line
    [qr/\bscript text executable\b/     => 'txt'],

    [qr/^MS Windows\b.*\bDLL\b/                 => ['exe','dll'] ],
    [qr/\bexecutable for MS Windows\b.*\bDLL\b/ => ['exe','dll'] ],
    [qr/^MS-DOS executable \(built-in\)/        => 'asc'],  # starts with LZ
    [qr/^(MS-)?DOS executable\b.*\bDLL\b/       => ['exe','dll'] ],
    [qr/^MS Windows\b.*\bexecutable\b/          => ['exe','exe-ms'] ],
    [qr/\bexecutable for MS Windows\b/          => ['exe','exe-ms'] ],
    [qr/^COM executable for DOS\b/              => 'asc'],  # misclassified?
    [qr/^DOS executable \(COM\)/                => 'asc'],  # misclassified?
    [qr/^(MS-)?DOS executable\b(?!.*\(COM\))/   => ['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/\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
  # MS-DOS executable PE  for MS Windows (DLL) (GUI) Intel 80386 32-bit
  # MS-DOS executable PE  for MS Windows (DLL) (GUI) Alpha 32-bit
  # MS-DOS executable, NE for MS Windows 3.x (driver)
  # MS-DOS executable (built-in)  (any file starting with LZ!)
  # PE executable for MS Windows (DLL) (GUI) Intel 80386 32-bit
  # PE executable for MS Windows (GUI) Intel 80386 32-bit
  # NE executable for MS Windows 3.x
  # 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


  # 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],  # no longer supported
    ['deb',  \&Amavis::Unpackers::do_ar, \$ar],
#   ['a',    \&Amavis::Unpackers::do_ar, \$ar], #unpacking .a seems an overkill
    ['zip',  \&Amavis::Unpackers::do_unzip],
    ['7z',   \&Amavis::Unpackers::do_7zip,       ['7zr','7za','7z'] ],
    ['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],  # not safe
    ['exe',  \&Amavis::Unpackers::do_executable, \$unrar,\$lha,\$unarj],
  );

  # build_default_maps

  @local_domains_maps = (
    \%local_domains, \@local_domains_acl, \$local_domains_re);
  @mynetworks_maps = (\@mynetworks);
  @client_ipaddr_policy = map { $_ => 'MYNETS' } @mynetworks_maps;

  @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);
  @virus_quarantine_to_maps = (\$virus_quarantine_to);
  @banned_quarantine_to_maps = (\$banned_quarantine_to);
  @spam_quarantine_to_maps = (\$spam_quarantine_to);
  @spam_quarantine_bysender_to_maps = (\$spam_quarantine_bysender_to);
  @bad_header_quarantine_to_maps = (\$bad_header_quarantine_to);
  @clean_quarantine_to_maps = (\$clean_quarantine_to);
  @archive_quarantine_to_maps = (\$archive_quarantine_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);    # CC_SPAMMY
  @spam_tag3_level_maps = (\$sa_tag3_level_deflt);    # CC_SPAMMY,1
  @spam_kill_level_maps = (\$sa_kill_level_deflt);    # CC_SPAM
  @spam_dsn_cutoff_level_maps = (\$sa_dsn_cutoff_level);
  @spam_dsn_cutoff_level_bysender_maps = (\$sa_dsn_cutoff_level);
  @spam_crediblefrom_dsn_cutoff_level_maps =
    (\$sa_crediblefrom_dsn_cutoff_level);
  @spam_crediblefrom_dsn_cutoff_level_bysender_maps =
    (\$sa_crediblefrom_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
  @spam_subject_tag3_maps = ();   # new variable, no backwards compatib. needed
  @whitelist_sender_maps = (
    \%whitelist_sender, \@whitelist_sender_acl, \$whitelist_sender_re);
  @blacklist_sender_maps = (
    \%blacklist_sender, \@blacklist_sender_acl, \$blacklist_sender_re);
  @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);
  @remove_existing_spam_headers_maps = (\$remove_existing_spam_headers);

  # new variables, no backwards compatibility needed
  # @score_sender_maps, @author_to_policy_bank_maps, @signer_reputation_maps,
  # @message_size_limit_maps

  # 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,
  );
  %smtp_reason_by_ccat = (
    # currently only used for blocked messages only, status 5xx
    # a multiline message will produce a valid multiline SMTP response
    CC_VIRUS,       "id=%n - INFECTED: %V",
    CC_BANNED,      "id=%n - BANNED: %F",
    CC_UNCHECKED,   "id=%n - UNCHECKED",
    CC_SPAM,        "id=%n - SPAM",
    CC_SPAMMY.',1', "id=%n - SPAMMY (tag3)",
    CC_SPAMMY,      "id=%n - SPAMMY",
    CC_BADH.',1',   "id=%n - BAD HEADER: MIME error",
    CC_BADH.',2',   "id=%n - BAD HEADER: nonencoded 8-bit character",
    CC_BADH.',3',   "id=%n - BAD HEADER: contains invalid control character",
    CC_BADH.',4',   "id=%n - BAD HEADER: line made up entirely of whitespace",
    CC_BADH.',5',   "id=%n - BAD HEADER: line longer than RFC 2822 limit",
    CC_BADH.',6',   "id=%n - BAD HEADER: syntax error",
    CC_BADH.',7',   "id=%n - BAD HEADER: missing required header field",
    CC_BADH.',8',   "id=%n - BAD HEADER: duplicate header field",
    CC_BADH,        "id=%n - BAD HEADER",
    CC_OVERSIZED,   "id=%n - Message size exceeds recipient's size limit",
    CC_MTA.',1',    "id=%n - Temporary MTA failure on relaying",
    CC_MTA.',2',    "id=%n - Rejected by MTA on relaying",
    CC_MTA,         "id=%n - Unable to relay message back to MTA",
    CC_CLEAN,       "id=%n - CLEAN",
    CC_CATCHALL,    "id=%n - OTHER",  # should not happen
  );
  %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_maps_by_ccat = (
    CC_VIRUS,       sub { c('defang_virus') },
    CC_BANNED,      sub { c('defang_banned') },
    CC_UNCHECKED,   sub { c('defang_undecipherable') },
    CC_SPAM,        sub { c('defang_spam') },
    CC_SPAMMY,      sub { c('defang_spam') },
  # CC_BADH.',3',   1,  # NUL or CR character in header section
  # CC_BADH.',5',   1,  # header line longer than 998 characters
  # CC_BADH.',6',   1,  # header field syntax error
    CC_BADH,        sub { c('defang_bad_header') },
  );
  %subject_tag_maps_by_ccat = (
    CC_VIRUS,       [ '***INFECTED*** ' ],
    CC_BANNED,      undef,
    CC_UNCHECKED,   sub { [ c('undecipherable_subject_tag') ] }, # not by-recip
    CC_SPAM,        undef,
    CC_SPAMMY.',1', sub { ca('spam_subject_tag3_maps') },
    CC_SPAMMY,      sub { ca('spam_subject_tag2_maps') },
    CC_CLEAN.',1',  sub { ca('spam_subject_tag_maps') },
  );
  %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_SPAMMY,      sub { c('clean_quarantine_method') }, #formally a clean msg
    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_SPAMMY,      sub { ca('clean_quarantine_to_maps') }, # formally is clean
    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') },
  );
  %always_bcc_by_ccat = (
    CC_CATCHALL,    sub { c('always_bcc') },
  );
  %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') },
  );
  %hdrfrom_notify_release_by_ccat = (
    CC_CATCHALL,    sub { c('hdrfrom_notify_release') },
  );
  %hdrfrom_notify_report_by_ccat = (
    CC_CATCHALL,    sub { c('hdrfrom_notify_report') },
  );
  %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') },  #usualy empty
    CC_CATCHALL,    sub { cr('notify_virus_recips_templ') },
  );
  %notify_sender_templ_by_ccat = (  # bounce templates
    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') },
  );
  %notify_release_templ_by_ccat = (
    CC_CATCHALL,    sub { cr('notify_release_templ') },
  );
  %notify_report_templ_by_ccat = (
    CC_CATCHALL,    sub { cr('notify_report_templ') },
  );
  %notify_autoresp_templ_by_ccat = (
    CC_CATCHALL,    sub { cr('notify_autoresp_templ') },
  );
  %warnsender_by_ccat = (  # deprecated use, except perhaps for CC_BADH
    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_SPAM,        undef,
    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_SPAMMY,      sub { ca('addr_extension_spam_maps') },
    CC_BADH,        sub { ca('addr_extension_bad_header_maps') },
#   CC_OVERSIZED,   'oversized';
  );
  %addr_rewrite_maps_by_ccat = ( );

} # end BEGIN - init_tertiary


# 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($$);  # no longer supported
sub Amavis::Unpackers::do_ar($$$);
sub Amavis::Unpackers::do_unzip($$;$$);
sub Amavis::Unpackers::do_7zip($$$;$);
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 'once';
# Define alias names or shortcuts in this module to make it simpler
# to call these routines from amavisd.conf
*read_l10n_templates = \&Amavis::Util::read_l10n_templates;
*read_text       = \&Amavis::Util::read_text;
*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;
*ask_av_smtp     = \&Amavis::AV::ask_av_smtp;
*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;  # no longer supported
*do_ar           = \&Amavis::Unpackers::do_ar;
*do_unzip        = \&Amavis::Unpackers::do_unzip;
*do_unrar        = \&Amavis::Unpackers::do_unrar;
*do_7zip         = \&Amavis::Unpackers::do_7zip;
*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;
*iso8601_week          = \&Amavis::rfc2821_2822_Tools::iso8601_week;
*iso8601_timestamp     = \&Amavis::rfc2821_2822_Tools::iso8601_timestamp;
*iso8601_utc_timestamp = \&Amavis::rfc2821_2822_Tools::iso8601_utc_timestamp;
sub new_RE { Amavis::Lookup::RE->new(@_) }
*defang_by_ccat  = \%defang_maps_by_ccat;  # compatibility with old name
use vars qw(%defang_by_ccat);

@virus_name_to_spam_score_maps =
  (new_RE(  # the order matters!
    [ qr'^Phishing\.'                                             => 0.1 ],
    [ qr'^Structured\.(SSN|CreditCardNumber)\b'                   => 0.1 ],
    [ qr'^(Email|HTML)\.Phishing\.(?!.*Sanesecurity)'             => 0.1 ],
    [ qr'^Sanesecurity\.(Malware|Rogue|Trojan)\.' => undef ],# keep as infected
    [ qr'^Sanesecurity\.'                                         => 0.1 ],
    [ qr'^Sanesecurity_PhishBar_'                                 => 0   ],
    [ qr'^Sanesecurity.TestSig_'                                  => 0   ],
    [ qr'^Email\.Spam\.Bounce(\.[^., ]*)*\.Sanesecurity\.'        => 0   ],
    [ qr'^Email\.Spammail\b'                                      => 0.1 ],
    [ qr'^MSRBL-(Images|SPAM)\b'                                  => 0.1 ],
    [ qr'^VX\.Honeypot-SecuriteInfo\.com\.Joke'                   => 0.1 ],
    [ qr'^VX\.not-virus_(Hoax|Joke)\..*-SecuriteInfo\.com(\.|\z)' => 0.1 ],
    [ qr'^Email\.Spam.*-SecuriteInfo\.com(\.|\z)'                 => 0.1 ],
    [ qr'^Safebrowsing\.'                                         => 0.1 ],
    [ qr'^winnow\.(phish|spam)\.'                                 => 0.1 ],
    [ qr'^INetMsg\.SpamDomain'                                    => 0.1 ],
    [ qr'-SecuriteInfo\.com(\.|\z)'         => undef ],  # keep as infected
    [ qr'^MBL_NA\.UNOFFICIAL'               => 0.1 ],    # false positives
    [ qr'^MBL_'                             => undef ],  # keep as infected
  ));
# Sanesecurity       http://www.sanesecurity.co.uk/
# MSRBL-             http://www.msrbl.com/site/contact
# MBL                http://www.malware.com.br/index.shtml
# -SecuriteInfo.com  http://clamav.securiteinfo.com/malwares.html

# 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
    @virus_quarantine_to_maps @banned_quarantine_to_maps
    @spam_quarantine_to_maps @spam_quarantine_bysender_to_maps
    @bad_header_quarantine_to_maps @clean_quarantine_to_maps
    @archive_quarantine_to_maps @banned_filename_maps
    @keep_decoded_original_maps @map_full_type_to_short_type_maps
    @viruses_that_fake_sender_maps @virus_name_to_spam_score_maps
    @spam_tag_level_maps @spam_tag2_level_maps @spam_tag3_level_maps
    @spam_kill_level_maps @spam_modifies_subj_maps
    @spam_dsn_cutoff_level_maps @spam_dsn_cutoff_level_bysender_maps
    @spam_quarantine_cutoff_level_maps @spam_notifyadmin_cutoff_level_maps
    @spam_subject_tag_maps @spam_subject_tag2_maps @spam_subject_tag3_maps
    @whitelist_sender_maps @blacklist_sender_maps @score_sender_maps
    @author_to_policy_bank_maps @signer_reputation_maps
    @message_size_limit_maps
    @addr_extension_virus_maps @addr_extension_spam_maps
    @addr_extension_banned_maps @addr_extension_bad_header_maps
    @remove_existing_spam_headers_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
    }
  }
}

# return a list of actually read&evaluated configuration files
sub get_config_files_read() { @actual_config_files }

# read and evaluate a configuration file, some sanity checking and housekeeping
sub read_config_file($$) {
  my($config_file,$is_optional) = @_;
  my(@stat_list) = stat($config_file);  # symlinks-friendly
  my($errn) = @stat_list ? 0 : 0+$!;
  if ($errn == ENOENT && $is_optional) {
    # don't complain if missing
  } else {
    my($owner_uid) = $stat_list[4];
    my($msg);
    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 = "should not be owned by EUID $>"}
    elsif ($> && -w _)   { $msg = "is writable by EUID $>, EGID $)" }
    elsif ($owner_uid)   { $msg = "should be owned by root (uid 0) "}
    if (defined $msg)    { die "Config file \"$config_file\" $msg," }
    $read_config_files_depth++;  push(@actual_config_files, $config_file);
    if ($read_config_files_depth >= 100) {
      print STDERR "read_config_files: recursion depth limit exceeded\n";
      exit 1;  # avoid unwinding deep recursion, abort right away
    }
    $! = 0;
    if (defined(do $config_file)) {}
    elsif ($@ ne '') { die "Error in config file \"$config_file\": $@" }
    elsif ($! != 0)  { die "Error reading config file \"$config_file\": $!" }
    $read_config_files_depth--  if $read_config_files_depth > 0;
  }
  1;
}

sub include_config_files(@)          { read_config_file($_,0)  for @_;  1 }
sub include_optional_config_files(@) { read_config_file($_,1)  for @_;  1 }

# supply remaining defaults after config files have already been read/evaluated
sub supply_after_defaults() {
  $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;
  local($1,$2);
  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_LINE= "$myproduct_name at $mydomain"  if !defined $X_HEADER_LINE;
  $X_HEADER_TAG = 'X-Virus-Scanned'               if !defined $X_HEADER_TAG;
  if ($X_HEADER_TAG =~ /^[!-9;-\176]+\z/) {
    # implicitly add to %allowed_added_header_fields for compatibility,
    # unless the hash entry already exists
    my($allowed_hdrs) = cr('allowed_added_header_fields');
    $allowed_hdrs->{lc($X_HEADER_TAG)} = 1
      if $allowed_hdrs && !exists($allowed_hdrs->{lc($X_HEADER_TAG)});
  }
  $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;
  $hdrfrom_notify_release = $hdrfrom_notify_sender
    if !defined $hdrfrom_notify_release;
  $hdrfrom_notify_report = $hdrfrom_notify_sender
    if !defined $hdrfrom_notify_report;

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

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&init &collect_log_stats &log_to_stderr &log_fd
                  &write_log &open_log &close_log);
  import Amavis::Conf qw(:platform $DEBUG c cr ca
                         $myversion $logline_maxlen $daemon_user);
}
use subs @EXPORT_OK;

use POSIX qw(locale_h strftime);
use Fcntl qw(LOCK_SH LOCK_EX LOCK_UN);
use Unix::Syslog qw(:macros :subs);
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Time::HiRes ();

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

sub init($$) {
  ($do_syslog, $logfile) = @_;
  $log_lines = 0; %log_entries_by_level = ();
  $log_retries = 0; %log_status_counts = ();
  # 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;
  }
  $myname = $0;
  open_log();
  if (!$do_syslog && $logfile eq '')
    { print STDERR "Logging to STDERR (no \$LOGFILE and no \$DO_SYSLOG)\n" }
}

sub collect_log_stats() {
  my(@result) = ($log_lines, {%log_entries_by_level},
                 $log_retries, {%log_status_counts});
  $log_lines = 0; %log_entries_by_level = ();
  $log_retries = 0; %log_status_counts = ();
  @result;
}

# turn debug logging to STDERR on or off
sub log_to_stderr(;$) {
  $log_to_stderr = shift  if @_ > 0;
  $log_to_stderr;
}

# try to obtain file descriptor used by write_log, undef if unknown
sub log_fd() {
  $log_to_stderr ? fileno(STDERR)
  : $do_syslog ? undef  # how to obtain fd on syslog?
  : defined $loghandle ? $loghandle->fileno : fileno(STDERR);
}

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');
    $fac =~ /^[A-Za-z0-9_]+\z/
      or die "Suspicious syslog facility name: $fac";
    my($syslog_facility_num) = eval("LOG_\U$fac");
    $syslog_facility_num =~ /^\d+\z/
      or die "Unknown syslog facility name: $fac";
    openlog($id, LOG_PID | LOG_NDELAY, $syslog_facility_num);
    $current_syslog_ident = $id; $current_syslog_facility = $fac;
  } elsif ($logfile ne '') {
    $loghandle = IO::File->new;
    $loghandle->open($logfile, O_CREAT|O_APPEND|O_WRONLY, 0640)
      or die "Failed to open log file $logfile: $!";
    binmode($loghandle,":bytes") or die "Can't cancel :utf8 mode: $!"
      if $unicode_aware;
    $loghandle->autoflush(1);
    if ($> == 0) {
      local($1);
      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: $!";
      }
    }
  } else {  # logging to STDERR
    STDERR->autoflush(1);  # just in case
  }
}

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

# Log either to syslog or to a file
sub write_log($$$;@) {
  my($level,$am_id,$errmsg,@args) = @_;
  return  if $within_write_log;
  $within_write_log = 1;
  $am_id = !defined $am_id ? '' : "($am_id) ";
  # treat $errmsg as sprintf format string if additional arguments provided
  if (@args && index($errmsg,'%') >= 0) { $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) . "...";
# }
  my($alert_mark) = $level >= 0 ? '' : $level >= -1 ? '(!)' : '(!!)';
# $alert_mark .= '*'  if $> == 0;
  $log_entries_by_level{"$level"}++;
  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 >   2) { $prio = LOG_DEBUG   if $prio > LOG_DEBUG   }
    elsif ($level >=  1) { $prio = LOG_INFO    if $prio > LOG_INFO    }
    elsif ($level >=  0) { $prio = LOG_NOTICE  if $prio > LOG_NOTICE  }
    elsif ($level >= -1) { $prio = LOG_WARNING if $prio > LOG_WARNING }
    elsif ($level >= -2) { $prio = LOG_ERR     if $prio > LOG_ERR     }
    else                 { $prio = LOG_CRIT    if $prio > LOG_CRIT    }
    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();
    }
    my($pre) = $alert_mark;
    # $logline_maxlen should be less than (1023 - prefix) for a typical syslog,
    # 980 is a suitable length to avoid truncations by the syslogd daemon
    my($logline_size) = $logline_maxlen;
    $logline_size = 50  if $logline_size < 50;  # let at least something out
    while (length($am_id)+length($pre)+length($errmsg) > $logline_size) {
      my($avail) = $logline_size - length($am_id . $pre . "...");
      $log_lines++; $! = 0;
      syslog($prio, "%s", $am_id . $pre . substr($errmsg,0,$avail) . "...");
      if ($! != 0) { $log_retries++; $log_status_counts{"$!"}++ }
      $pre = $alert_mark . "...";  $errmsg = substr($errmsg,$avail);
    }
    $log_lines++; $! = 0; syslog($prio, "%s", $am_id . $pre . $errmsg);
    if ($! != 0) { $log_retries++; $log_status_counts{"$!"}++ }
  } else {
    $log_lines++;
    if ($log_to_stderr || !defined $loghandle) {
      my($now) = Time::HiRes::time;
      my($prefix) = sprintf("%s:%06.3f %s %s[%s]: ",  # syslog-like prefix
        strftime("%b %e %H:%M",localtime($now)), $now-int($now/60)*60,
        c('myhostname'), $myname, $$);  # include milliseconds in a timestamp
      # avoid multiple calls to write(2), join the string first!
      my($s) = $prefix . $am_id . $alert_mark . $errmsg . "\n";
      print STDERR ($s)  or die "Error writing to STDERR: $!";
    } else {
      my($prefix) = sprintf("%s %s %s[%s]: ",  # prepare a syslog-like prefix
        strftime("%b %e %H:%M:%S",localtime), c('myhostname'), $myname, $$);
      my($s) = $prefix . $am_id . $alert_mark . $errmsg . "\n";
      # NOTE: a lock is on a file, not on a file handle
      flock($loghandle,LOCK_EX)  or die "Can't lock a log file: $!";
      seek($loghandle,0,2)   or die "Can't position log file to its tail: $!";
      $loghandle->print($s)  or die "Error writing to log file: $!";
      flock($loghandle,LOCK_UN)  or die "Can't unlock a log file: $!";
    }
  }
# POSIX::setlocale(LC_TIME, $old_locale);
  $within_write_log = 0;
}

1;

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

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

use Time::HiRes ();

# 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, %s: was %s, %.1f ms, total idle %.3f s, busy %.3f s",
        $_[0],  $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() {
  $t_busy_cum + $t_idle_cum <= 0 ? undef
  : sprintf("load: %.0f %%, total idle %.3f s, busy %.3f s",
      100*$t_busy_cum / ($t_busy_cum + $t_idle_cum), $t_idle_cum, $t_busy_cum);
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&untaint &min &max &unique_list &unique_ref
                  &safe_encode &safe_decode &q_encode
                  &xtext_encode &xtext_decode &orcpt_encode &orcpt_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 &prolong_timer
                  &waiting_for_client &switch_to_my_time &switch_to_client_time
                  &sanitize_str &fmt_struct &freeze &thaw
                  &ccat_split &ccat_maj &cmp_ccat &cmp_ccat_maj
                  &setting_by_given_contents_category_all
                  &setting_by_given_contents_category
                  &rmdir_recursively &read_text &read_l10n_templates
                  &read_hash &read_array &dump_hash &dump_array
                  &dynamic_destination);
  import Amavis::Conf qw(:platform $DEBUG c cr ca $child_timeout $smtpd_timeout
                         $trim_trailing_space_in_lookup_result_fields);
  import Amavis::Log qw(write_log);
  import Amavis::Timing qw(section_time);
}
use subs @EXPORT_OK;

use Errno qw(ENOENT EACCES EAGAIN ESRCH EBADF);
use IO::File ();
use Digest::MD5 2.22;  # need 'clone' method
# use Encode;  # Perl 5.8  UTF-8 support

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

# Returns a sublist of the supplied list of elements in an unchanged order,
# where only the first occurrence of each defined element is retained
# and duplicates removed
sub unique_list(@) {
  my($r) = @_ == 1 && ref($_[0]) ? $_[0] : \@_;  # accept list, or a list ref
  my(%seen);  my(@result) = grep { defined($_) && !$seen{$_}++ } @$r;
  @result;
}

# same as unique, except that it returns a ref to the resulting list
sub unique_ref(@) {
  my($r) = @_ == 1 && ref($_[0]) ? $_[0] : \@_;  # accept list, or a list ref
  my(%seen);  my(@result) = grep { defined($_) && !$seen{$_}++ } @$r;
  \@result;
}

# 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 UTF8 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 (not for use in comments or phrase)
  $rest =~ s{([\000-\037\177\200-\377=?_])}{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 = safe_encode('UTF-8',$str)  if $unicode_aware && Encode::is_utf8($str);
  $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;
}

# xtext_encode and prepend 'rfc822;' to form a string to be used as ORCPT
sub orcpt_encode($) {  # rfc3461
  # rfc3461: Due to limitations in the Delivery Status Notification format,
  # the value of the original recipient address prior to encoding as "xtext"
  # MUST consist entirely of printable (graphic and white space) characters
  # from the US-ASCII [4] repertoire.
  my($str) = @_; local($1);  # argument should be SMTP-quoted address
  $str = $1  if $str =~ /^<(.*)>\z/s;  # strip-off <>
  $str =~ s/[^\040-\176]/?/gs;
  'rfc822;' . xtext_encode($str);
}

sub orcpt_decode($) {  # rfc3461
  my($str) = @_;  # argument should be rfc3461-encoded address
  my($addr_type,$orcpt); local($1,$2);
  if (defined $str) {
    if ($str =~ /^([^\000-\040\177()<>\[\]\@\\:;,."]*);(.*\z)/si){ # atom;xtext
      ($addr_type,$orcpt) = ($1,$2);
    } else {
      ($addr_type,$orcpt) = ('rfc822',$str);  # rfc3464 address-type
    }
    $orcpt = xtext_decode($orcpt);  # decode
    $orcpt =~ s/[^\040-\176]/?/gs;  # some minimal sanitation
  }
  # result in $orcpt is presumably a rfc2822-encoded address, no angle brackets
  ($addr_type,$orcpt);
}

# Set or get Amavis internal task id (also called: message id).
# This task 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 task id
#                   (accessible via am_id() and later also as $msginfo->log_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(@) {  # arguments may be strings or array references
  $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.
# As the number of encoded bits is an integral multiple of 24, no base64
# trailing padding characters '=' are needed for the time being (rfc4648).
# Note the difference in base64-like encodings:
#   amavisd almost-base64: 62 +, 63 -
#   rfc4648 base64:        62 +, 63 /
#   rfc4648 base64url:     62 -, 63 _
# Generally, rfc2822 controls, SP and specials must be avoided: ()<>[]:;@\,."
# Some day we may want to switch from almost-base64 to base64url to avoid
# having to quote a '+' in regular expressions and URL.
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{/}{-};  # base64 -> almost-base64
  ($id,$secret_id);
}

use vars qw(@counter_names);
# elements may be counter names (increment is 1), or pairs: [name,increment],
# or triples: [name,value,type], where type can be: C32, C64, INT, TIN or OID
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 ($DEBUG || $debug_oneshot) && $level > 0;
  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) = @_;
  # duplicate code from ll() to avoid one subroutine call
  $level = 0  if ($DEBUG || $debug_oneshot) && $level > 0;
  my($current_log_level) = c('log_level');
  $current_log_level = 0  if !defined $current_log_level;
  write_log($level, am_id(), shift, @_)  if $level <= $current_log_level;
  1;
}

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(5, "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(5, "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
}

use vars qw($waiting_for_client);  # which timeout is running:
                                   # false: processing is in our courtyard
                                   # true:  waiting for a client
sub waiting_for_client() {
  !@_ ? $waiting_for_client : ($waiting_for_client=shift);
}

sub switch_to_my_time($) {      # processing is in our courtyard
  my($msg) = @_;
  my($interval) = $child_timeout < 5 ? 5 : $child_timeout;
  do_log(5, "switch_to_my_time     %d s, %s", $interval,$msg);
  alarm($interval); $waiting_for_client = 0;
}

sub switch_to_client_time($) {  # processing is now in client's hands
  my($msg) = @_;
  my($interval) = $smtpd_timeout < 5 ? 5 : $smtpd_timeout;
  do_log(5, "switch_to_client_time %d s, %s", $interval,$msg);
  alarm($interval); $waiting_for_client = 1;
}

# 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', "\\" => '\\\\');
  local($1);
  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 = safe_encode('utf8',$str)  if $unicode_aware && Encode::is_utf8($str);
  $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;
};

# used by freeze: protect % and ~, as well as NUL and \200 for good measure
sub st_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('~', '',  st_encode($obj))  }  # string
  elsif ($ty eq 'SCALAR') { join('~', 'S', st_encode(freeze($$obj))) }
  elsif ($ty eq 'REF')    { join('~', 'R', st_encode(freeze($$obj))) }
  elsif ($ty eq 'ARRAY')  { join('~', 'A', map {st_encode(freeze($_))} @$obj) }
  elsif ($ty eq 'HASH') {
    join('~', 'H',
         map {(st_encode($_),st_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" }
}

# accepts either a single contents category (a string: "maj,min" or "maj"),
# or a list of contents categories, in which case only the first element
# is considered; returns a passed pair: (major_ccat, minor_ccat)
sub ccat_split($) {
  my($ccat) = @_; my($major,$minor);
  $ccat = $ccat->[0]  if ref $ccat;  # pick the first element if a list
  ($major,$minor) = split(/,/,$ccat,-1)  if defined $ccat;
  !wantarray ? $major : ($major,$minor);
}

# accepts either a single contents category (a string: "maj,min" or "maj"),
# or a list of contents categories, in which case only the first element
# is considered; returns major_ccat
sub ccat_maj($) {
  my($ccat) = @_; my($major,$minor);
  $ccat = $ccat->[0]  if ref $ccat;  # pick the first element if a list
  ($major,$minor) = split(/,/,$ccat,-1)  if defined $ccat;
  $major;
}

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

# similar to cmp_ccat, but consider only the major category of both arguments
sub cmp_ccat_maj($$) {
  my($a_maj,$a_min) = split(/,/, shift, -1);
  my($b_maj,$b_min) = split(/,/, shift, -1);
  $a_maj <=> $b_maj;
}

# get a list of settings corresponding to all listed contents categories,
# ordered from the most important category to the least;  @ccat is a list of
# relevant contents categories for which a query is made, it MUST already be
# sorted in descending order;  this is a classical subroutine, not a method!
sub setting_by_given_contents_category_all($@) {
  my($ccat,@settings_href_list) = @_; my(@r);
  if (!@settings_href_list) {}  # no settings provided
  else {
    for my $e ((!defined($ccat) ?() :ref($ccat) ?@$ccat :$ccat), CC_CATCHALL) {
      if (grep { defined($_) && exists($_->{$e}) } @settings_href_list) {
        # supports lazy evaluation (setting may be a subroutine)
        my(@slist) = map { !defined($_) || !exists($_->{$e}) ? undef :
                           do {my($s)=$_->{$e}; ref($s) eq 'CODE' ? &$s : $s}
                         } @settings_href_list;
        push(@r, [$e,@slist]);  # a tuple: [corresponding ccat, settings list]
      }
    }
  }
  @r;  # a list of tuples
}

# similar to setting_by_given_contents_category_all(), but only the first
# (the most relevant) setting is returned, without a corresponding ccat
sub setting_by_given_contents_category($@) {
  my($ccat,@settings_href_list) = @_; my(@slist);
  if (!@settings_href_list) {}  # no settings provided
  else {
    for my $e ((!defined($ccat) ?() :ref($ccat) ?@$ccat :$ccat), CC_CATCHALL) {
      if (grep { defined($_) && exists($_->{$e}) } @settings_href_list) {
        # supports lazy evaluation (setting may be a subroutine)
        @slist = map { !defined($_) || !exists($_->{$e}) ? undef :
                       do {my($s)=$_->{$e}; ref($s) eq 'CODE' ? &$s : $s}
                     } @settings_href_list;
        last;
      }
    }
  }
  !wantarray ? $slist[0] : @slist;  # only the first entry
}

# 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";
    next  if $f eq '.' || $f eq '..';
    $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: $!" }
    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 && defined($encoding) && $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");
  local($1,$2);
  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 introducer (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 (iff $trim_trailing_space_in_lookup_result_fields),
# empty lines (containing only whitespace or 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   # returning EBADF at EOF is a perl bug
    $!==EBADF ? do_log(0,"Error reading from %s: %s", $filename,$!)
              : 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   # returning EBADF at EOF is a perl bug
    $!==EBADF ? do_log(0,"Error reading from %s: %s", $filename,$!)
              : 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 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] .= $_ }
    };
    if ($list[1] =~ m{^/}) {
      # presumably the second field is a Unix socket name, keep unchanged
    } else {
      my($new_method); my($proto,$relayhost,$relayport) = @list;
      ($relayhost,$relayport) = ('*','*')  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]";
      }
      $relayport = $conn->socket_port + 1  if $relayport eq '*';
      $list[1] = $relayhost;  $list[2] = $relayport;
      $new_method = join(':',@list);
      if ($new_method ne $method) {
        do_log(3, "dynamic destination: %s -> %s", $method,$new_method);
        $method = $new_method;
      }
    }
  }
  $method;
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&exit_status_str &proc_status_ok &kill_proc &cloexec
                  &run_command &run_command_consumer &run_as_subprocess
                  &collect_results &collect_results_structured);
  import Amavis::Conf qw(:platform);
  import Amavis::Util qw(ll do_log prolong_timer);  # freeze thaw
  import Amavis::Log qw(open_log close_log log_fd);
}
use subs @EXPORT_OK;

use POSIX qw(:sys_wait_h WIFEXITED WIFSIGNALED WIFSTOPPED WEXITSTATUS
             WTERMSIG WSTOPSIG);
use Errno qw(ENOENT EACCES EAGAIN ESRCH);
use IO::File ();
use Time::HiRes ();
# use Fcntl qw(F_GETFD F_SETFD FD_CLOEXEC);  # used in cloexec, if enabled

# map process termination status number to an informative string, and
# append optional mesage (dual-valued errno or a string or a number),
# returning the resulting string
sub exit_status_str($;$) {
  my($stat,$errno) = @_; my($str);
  if (WIFEXITED($stat)) {
    $str = sprintf("exit %d", WEXITSTATUS($stat));
  } elsif (WIFSTOPPED($stat)) {
    $str = sprintf("stopped, signal %d", WSTOPSIG($stat));
  } else {
    my($sig) = WTERMSIG($stat);
    $str = sprintf("%s, signal %d (%04x)",
             $sig == 2 ? 'INTERRUPTED' : $sig == 6 ? 'ABORTED' :
             $sig == 9 ? 'KILLED' : $sig == 15 ? 'TERMINATED' : 'DIED',
             $sig, $stat);
  }
  if (defined $errno) {  # deal with dual-valued and plain variables
    $str .= ', '.$errno  if (0+$errno) != 0 || ($errno ne '' && $errno ne '0');
  }
  $str;
}

# check errno to be 0 and a 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($exit_status,$errno,@success) = @_;
  my($ok) = 0;
  if ((!defined $errno || $errno == 0) && WIFEXITED($exit_status)) {
    my($j) = WEXITSTATUS($exit_status);
    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,$reason) = @_;
  $pid >= 0  or die "Shouldn't be killing process groups: [$pid]";
  $pid != 1  or die "Shouldn't be killing process 'init': [$pid]";
  $what   = defined $what   ? " running $what"     : '';
  $reason = defined $reason ? " (reason: $reason)" : '';
  #
  # the following sequence is a must: SIGTERM 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 SIGTERM
  # until the external process dies of natural death; on the other hand,
  # not closing the pipe after SIGTERM does not necessarily let the process
  # notice SIGTERM, so SIGKILL is always needed to stop it, which is not nice
  #
  my($n) = kill(0,$pid);  # does the process really exist?
  if ($n == 0 && $! != ESRCH) {
    die sprintf("Can't send SIG 0 to process [%s]%s: %s", $pid,$what,$!);
  } elsif ($n == 0) {
    do_log(2, "no need to kill process [%s]%s, already gone", $pid,$what);
  } else {
    do_log(-1,"killing process [%s]%s%s", $pid,$what,$reason);
    kill('TERM',$pid) or $! == ESRCH  # be gentle on the first attempt
      or die sprintf("Can't send SIGTERM to process [%s]%s: %s",$pid,$what,$!);
  }
  # close the pipe if still open, ignoring status
  $proc_fh->close  if defined $proc_fh;
  my($child_stat) = defined $pid && waitpid($pid,WNOHANG) > 0 ? $? : undef;
  $n = kill(0,$pid);  # is the process still there?
  if ($n > 0 && defined($timeout) && $timeout > 0) {
    sleep($timeout); $n = kill(0,$pid);  # wait a little and recheck
  }
  if ($n == 0 && $! != ESRCH) {
    die sprintf("Can't send SIG 0 to process [%s]%s: %s", $pid,$what,$!);
  } elsif ($n > 0) {  # the process is still there, try a stronger signal
    do_log(-1,"process [%s]%s is still alive, using a bigger hammer",
              $pid,$what);
    kill('KILL',$pid) or $! == ESRCH
      or die sprintf("Can't send SIGKILL to process [%s]%s: %s",$pid,$what,$!);
  }
}

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.
# Returns a file descriptor number (not a Perl file handle, there is no
# associated file handle). Usually called from a forked process prior to exec.
#
sub open_on_specific_fd($$$$) {
  my($fd_target,$fname,$flags,$mode) = @_;
  my($fd_got);  # fd directly given as argument, or obtained from POSIX::open
  my($logging_safe) = 0;
  if (ll(5)) {
    # crude attempt to prevent a forked process from writing log records
    # to its parent process on STDOUT or STDERR
    my($log_fd) = log_fd();
    $logging_safe = 1  if !defined($log_fd) || $log_fd > 2;
  }
  local($1);
  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)  if $logging_safe;
    # 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)) {  # a 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 requested 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)  if $logging_safe;
    };
    # POSIX mandates we got the lowest fd available (but some kernels have
    # bugs), let's be explicit that we require a specified file descriptor
    defined POSIX::dup2($fd_got,$fd_target)
      or die "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)  if $logging_safe;
      };
    }
  }
  $fd_got;
}

sub release_parent_resources() {
  $Amavis::sql_dataset_conn_lookups->dbh_inactive(1)
    if $Amavis::sql_dataset_conn_lookups;
  $Amavis::sql_dataset_conn_storage->dbh_inactive(1)
    if $Amavis::sql_dataset_conn_storage;
# undef $Amavis::sql_dataset_conn_lookups;
# undef $Amavis::sql_dataset_conn_storage;
# undef $Amavis::body_digest_cache; undef $Amavis::snmp_db;
# undef $Amavis::db_env;
}

# Run specified command as a subprocess (like qx operator, but more careful
# with error reporting and cancels :utf8 mode). If $stderr_to is undef or
# an empty string it is converted to "&1", merging stderr to stdout on fd1.
# Return a file handle open for reading from the subprocess.
#
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 = '&1'  if !defined($stderr_to) || $stderr_to eq '';  # to stdout
  my($msg) = join(' ', $cmd, @args, "<$stdin_from", "2>$stderr_to");
# $^F == 2  or do_log(-1,"run_command: SYSTEM_FD_MAX not 2: %d", $^F);
  my($proc_fh)      = IO::File->new;  # parent reading side of the pipe
  my($child_out_fh) = IO::File->new;  # child writing side of the pipe
  pipe($proc_fh,$child_out_fh)
    or die "run_command: Can't create a pipe: $!";
  my($pid);
  eval {
    # Avoid using open('-|') which is just too damn smart: possibly waiting
    # indefinitely when resources are tight, and not catching fork errors as
    # expected but just bailing out of eval; make a pipe explicitly and fork.
    # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
    # process limit is reached; we want it to fail in both cases and not obey
    # the EAGAIN and keep retrying, as perl open() does.
    $pid = fork(); 1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die "run_command (forking): $eval_stat";
  };
  defined($pid) or die "run_command: can't fork: $!";
  if (!$pid) {  # child
    alarm(0); my($interrupt) = '';
    my($h1) = sub { $interrupt = $_[0] };
    my($h2) = sub { die "Received signal ".$_[0] };
    @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
    eval {  # die must be caught, otherwise we end up with two running daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
#     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);
#       }
#     }
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      release_parent_resources();
      open_on_specific_fd(0, $stdin_from, &POSIX::O_RDONLY, 0);
      open_on_specific_fd(1, '&='.fileno($child_out_fh), &POSIX::O_WRONLY, 0);
      open_on_specific_fd(2, $stderr_to, &POSIX::O_WRONLY, 0);
    # 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) = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    eval {
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
      open_log();  # oops, exec failed, we will need logging after all...
      # we're in trouble if stderr was attached to a terminal, but no longer is
      do_log(-1,"run_command: child process [%s]: %s", $$,$err);
    };
    { no warnings;
      POSIX::_exit(6);  # avoid END and destructor processing
      kill('KILL',$$); exit 1;   # still kicking? die!
    }
  }
  # parent
  ll(5) && do_log(5,"run_command: [%s] %s", $pid,$msg);
  $child_out_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  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 a specified command as a subprocess. Return a file handle open for
# WRITING to the subprocess, utf8 mode canceled and autoflush turned on.
# If $stderr_to is undef or an empty string it is converted to "&1",
# merging stderr to stdout on fd1.
#
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 = '&1'  if !defined($stderr_to) || $stderr_to eq '';  # to stdout
  my($msg) = join(' ', $cmd, @args, ">$stdout_to", "2>$stderr_to");
# $^F == 2  or do_log(-1,"run_command_consumer: SYSTEM_FD_MAX not 2: %d", $^F);
  my($proc_fh)     = IO::File->new;  # parent writing side of the pipe
  my($child_in_fh) = IO::File->new;  # child reading side of the pipe
  pipe($child_in_fh,$proc_fh)
    or die "run_command_consumer: Can't create a pipe: $!";
  my($pid);
  eval {
    # Avoid using open('|-') which is just too damn smart: possibly waiting
    # indefinitely when resources are tight, and not catching fork errors as
    # expected but just bailing out of eval; make a pipe explicitly and fork.
    # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
    # process limit is reached; we want it to fail in both cases and not obey
    # the EAGAIN and keep retrying, as perl open() does.
    $pid = fork(); 1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die "run_command_consumer (fork): $eval_stat";
  };
  defined($pid) or die "run_command_consumer: can't fork: $!";
  if (!$pid) {  # child
    alarm(0); my($interrupt) = '';
    my($h1) = sub { $interrupt = $_[0] };
    my($h2) = sub { die "Received signal ".$_[0] };
    @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
    eval {  # die must be caught, otherwise we end up with two running daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      release_parent_resources();
      open_on_specific_fd(0, '&='.fileno($child_in_fh), &POSIX::O_RDONLY, 0);
      open_on_specific_fd(1, $stdout_to, &POSIX::O_WRONLY, 0);
      open_on_specific_fd(2, $stderr_to, &POSIX::O_WRONLY, 0);
#     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) = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    eval {
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
      open_log();  # oops, exec failed, we will need logging after all...
      # we're in trouble if stderr was attached to a terminal, but no longer is
      do_log(-1,"run_command_consumer: child process [%s]: %s", $$,$err);
    };
    { no warnings;
      POSIX::_exit(6);  # 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);
  $child_in_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  $proc_fh->autoflush(1);
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

# run a specified subroutine with given arguments as a (forked) subprocess,
# collecting results (if any) over a pipe from a subprocess and propagating
# them back to a caller; (useful to prevent a potential process crash from
# bringing down the main process, and allows cleaner timeout aborts)
#
sub run_as_subprocess($@) {
  my($code,@args) = @_;
  my($remaining_time) = alarm(0);  # check time left, stop the timer
  my($proc_fh)      = IO::File->new;  # parent reading side of the pipe
  my($child_out_fh) = IO::File->new;  # child writing side of the pipe
  pipe($proc_fh,$child_out_fh)
    or die "run_as_subprocess: Can't create a pipe: $!";
  my($pid);
  eval {
    # Avoid using open('-|') which is just too damn smart: possibly waiting
    # indefinitely when resources are tight, and not catching fork errors as
    # expected but just bailing out of eval; make a pipe explicitly and fork.
    # Note that fork(2) returns ENOMEM on lack of swap space, and EAGAIN when
    # process limit is reached; we want it to fail in both cases and not obey
    # the EAGAIN and keep retrying, as perl open() does.
    $pid = fork(); 1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die "run_as_subprocess (forking): $eval_stat";
  };
  defined($pid) or die "run_as_subprocess: can't fork: $!";
  if (!$pid) {  # child
    # timeouts will be also be handled by a parent process
    my($t0) = Time::HiRes::time; my(@result); my($interrupt) = '';
    my($h1) = sub { $interrupt = $_[0] };
    my($h2) = sub { die "Received signal ".$_[0] };
    @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
    $SIG{PIPE} = 'IGNORE';  # don't signal on a write to a widowed pipe
    $0 = 'sub-' . $0;  # let it show in ps(1)
    my($eval_stat);
    eval {  # die must be caught, otherwise we end up with two running daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
      prolong_timer("child[$$]", $remaining_time);  # restart the timer
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      binmode($child_out_fh) or die "Can't set pipe to binmode: $!";
      release_parent_resources();
      # we don't really need STDOUT here, but just in case the supplied code
      # happens to write there, let's make STDOUT a dup of a pipe
      close STDOUT;  # ignoring status
      # prefer dup(2) here instead of fdopen, with some luck this gives us fd1
      open(STDOUT, '>&'.fileno($child_out_fh))
        or die "Child can't dup pipe to STDOUT: $!";
      binmode(STDOUT) or die "Can't set STDOUT to binmode: $!";
      ll(5) && do_log(5,"[%s] run_as_subprocess: running as child, ".
                        "stdin=%s, stdout=%s, pipe=%s",  $$, fileno(STDIN),
                        fileno(STDOUT), fileno($child_out_fh));
      @result = &$code(@args);  # invoke the caller-specified subroutine
      1;
    } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
    my($dt) = Time::HiRes::time - $t0;
    eval {  # must not use die in forked process, or we end up with two daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
      my($status); my($ll) = 3;
      if (defined $eval_stat) {  # failure
        chomp $eval_stat; $ll = -2;
        $status = sprintf("STATUS: FAILURE %s", $eval_stat);
      } else {  # success
        $status = sprintf("STATUS: SUCCESS, %d results", scalar(@result));
      };
      my($frozen) = Amavis::Util::freeze([$status,@result]);
      ll($ll) && do_log($ll, "[%s] run_as_subprocess: child done (%.1f ms), ".
                             "sending results: res_len=%d, %s",
                             $$, $dt*1000, length($frozen), $status);
      # write results back to a parent process over a pipe as a frozen struct.
      # writing to broken pipe must return an error, not throw a signal
      local $SIG{PIPE} = sub { die "Broken pipe\n" };  # locale-independent err
      $child_out_fh->print($frozen) or die "Can't write result to pipe: $!";
      $child_out_fh->close or die "Child can't close its side of a pipe: $!";
      close STDOUT or die "Child can't close its STDOUT: $!";
      POSIX::_exit(0); # normal completion, avoid END and destructor processing
    };
    my($eval2_stat) = $@ ne '' ? $@ : "errno=$!";
    eval {
      chomp $eval2_stat;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
      # broken pipe is common when parent process is shutting down
      my($ll) = $eval2_stat =~ /^Broken pipe\b/ ? 1 : -1;
      do_log($ll,"run_as_subprocess: child process [%s]: %s", $$,$eval2_stat);
    };
    POSIX::_exit(6);  # avoid END and destructor processing in a subprocess
  }
  # parent
  ll(5) && do_log(5,"run_as_subprocess: spawned a subprocess [%s]", $pid);
  $child_out_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  prolong_timer('run_as_subprocess', $remaining_time);  # restart the timer
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

# read results from a subprocess over a pipe, returns a ref to a results string
# and a subprocess exit status;  close the pipe and dismiss the subprocess,
# by force if necessary; if $success_list_ref is defined, check also the
# subprocess exit status against the provided list and log results
#
sub collect_results($$;$$$) {
  my($proc_fh,$pid, $what,$results_max_size,$success_list_ref) = @_;
  # $results_max_size is interpreted as follows:
  #   undef .. no limit, read and return all data;
  #      0 ... no limit, read and discard all data, returns ref to empty string
  #   >= 1 ... read all data, but truncate results string at limit
  my($child_stat); my($close_err) = 0; my($pid_orig) = $pid;
  my($result) = ''; my($result_l) = 0; my($skipping) = 0; my($eval_stat);
  eval {  # read results; could be aborted by a read error or a timeout
    my($nbytes,$buff);
    while (($nbytes=$proc_fh->read($buff,16384)) > 0) {
      if (!defined($results_max_size)) { $result .= $buff }  # keep all data
      elsif ($results_max_size == 0 || $skipping)  {}        # discard data
      elsif ($result_l <= $results_max_size) { $result .= $buff }
      else {
        $skipping = 1;  # sanity limit exceeded
        do_log(-1,'collect_results from [%s] (%s): results size limit '.
                  '(%d bytes) exceeded', $pid_orig,$what,$results_max_size);
      }
      $result_l += $nbytes;
    }
    defined $nbytes or die "Error reading from a subprocess [$pid_orig]: $!";
    ll(5) && do_log(5,'collect_results from [%s] (%s), %d bytes, (limit %s)',
                      $pid_orig,$what,$result_l,$results_max_size);
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  if ($results_max_size > 0 && length($result) > $results_max_size)
    { $result = substr($result,0,$results_max_size) . "..." }
  if (defined $eval_stat) {  # read error or timeout; abort the subprocess
    chomp $eval_stat;
    undef $_[0];  # release the caller's copy of $proc_fh
    kill_proc($pid,$what,1,$proc_fh, "on reading: $eval_stat") if defined $pid;
    undef $proc_fh; undef $pid;
    die "collect_results - reading aborted: $eval_stat";
  }
  # normal subprocess exit, close pipe, collect exit status
  undef $eval_stat;
  eval {
    $proc_fh->close or $close_err = $!;
    $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;
    undef $_[0];  # release also the caller's copy of $proc_fh
    1;
  } or do {  # just in case close itself timed out
    $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    undef $_[0];  # release the caller's copy of $proc_fh
    kill_proc($pid,$what,1,$proc_fh, "on closing: $eval_stat") if defined $pid;
    undef $proc_fh; undef $pid;
    die "collect_results - closing aborted: $eval_stat";
  };
  if (defined $success_list_ref) {
    proc_status_ok($child_stat,$close_err, @$success_list_ref)
      or do_log(-2, 'collect_results from [%s] (%s): %s %s', $pid_orig,$what,
                    exit_status_str($child_stat,$close_err), $result);
  } elsif ($close_err != 0) {
    die "Can't close pipe to subprocess [$pid_orig]: $close_err";
  }
  (\$result,$child_stat);
}

# read results from a subprocess over a pipe as a frozen data structure;
# close the pipe and dismiss the subprocess; returns results as a ref to a list
sub collect_results_structured($$;$$) {
  my($proc_fh,$pid, $what,$results_max_size) = @_;
  my($result_ref,$child_stat) =
    collect_results($proc_fh,$pid, $what,$results_max_size,[0]);
  my($result_ref) = Amavis::Util::thaw($$result_ref);
  my(@result) = !ref($result_ref) ? () : @$result_ref;
  @result >= 1
    or die "collect_results_structured: no results from subprocess [$pid]";
  my($status) = shift(@result);
  $status =~ /^STATUS: (?:SUCCESS|FAILURE)\b/
    or die "collect_results_structured: subprocess [$pid] returned: $status";
  (\@result,$child_stat);
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT = qw(
    &rfc2822_timestamp &iso8601_timestamp &iso8601_utc_timestamp &iso8601_week
    &format_time_interval &make_received_header_field &parse_received
    &fish_out_ip_from_received &parse_message_id
    &split_address &split_localpart &replace_addr_fields &make_query_keys
    &quote_rfc2821_local &qquote_rfc2821_local
    &parse_quoted_rfc2821 &unquote_rfc2821_local &parse_address_list
    &wrap_string &wrap_smtp_resp &one_response_for_all
    &EX_OK &EX_NOUSER &EX_UNAVAILABLE &EX_TEMPFAIL &EX_NOPERM);
  import Amavis::Conf qw(:platform c cr ca $myproduct_name);
  import Amavis::Util qw(ll do_log unique_list);
}
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);
}

# Given a Unix time, return the local time zone offset at that time
# as a string +HHMM or -HHMM, appropriate for the RFC 2822 date format.
# Works also for non-full-hour zone offsets, and on systems where strftime
# cannot 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 time, provide date-time timestamp as specified in RFC 2822
# (local time), to be used in header fields such as 'Date:' and 'Received:'
# See also RFC 3339.
#
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;
}

# 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 numeric time (seconds since 1970-01-01T00:00Z),
# provide a week number 1..53 (local time) as specified in ISO 8601 (EN 28601)
# ( equivalent to PostgreSQL extract(week from ...), and MySQL week(date,3) )
#
sub iso8601_week($) {
  my($unix_time) = @_;
  my($y,$dowm0,$doy0) = (localtime($unix_time))[5,6,7];
  $y += 1900; $dowm0--; $dowm0=6 if $dowm0<0;  # normalize, Monday==0
  my($dow0101) = ($dowm0 - $doy0 + 53*7) % 7;  # dow Jan 1
  my($wn) = int(($doy0 + $dow0101) / 7);
  if ($dow0101 < 4) { $wn++ }
  if ($wn == 0) { $wn = iso8601_year_is_long($y-1) ? 53 : 52 }
  elsif ($wn == 53 && !iso8601_year_is_long($y)) { $wn = 1 }
  $wn;
}

# Does the given year have 53 weeks?  Using a formula by Simon Cassidy.
sub iso8601_year_is_long($) {
  my($y) = @_;
  my($p) = $y + int($y/4) - int($y/100) + int($y/400);
  if (($p % 7) == 4) { return 1 }
  $y--;  $p = $y + int($y/4) - int($y/100) + int($y/400);
  if (($p % 7) == 3) { return 1 } else { return 0 }
}

sub format_time_interval($) {
  my($t) = @_;
  return 'undefined'  if !defined $t;
  my($sign) = '';  if ($t < 0) { $sign = '-'; $t = - $t };
  my($dd) = int($t / (24*3600));  $t = $t - $dd*(24*3600);
  my($hh) = int($t / 3600);       $t = $t - $hh*3600;
  my($mm) = int($t / 60);         $t = $t - $mm*60;
  sprintf("%s%d %d:%02d:%02d", $sign,$dd,$hh,$mm,int($t+0.5));
}

sub make_received_header_field($$$$) {
  my($conn, $msginfo, $id, $folded) = @_;
  my($smtp_proto, $recips) = ($conn->appl_proto, $msginfo->recips);
  my($client_ip) = $conn->client_ip;
  if ($client_ip =~ /:/ && $client_ip !~ /^IPv6:/i) {
    $client_ip = 'IPv6:' . $client_ip;  # rfc5321 (ex rfc2821), section 4.1.3
  }
  my($tls) = $msginfo->tls_cipher;
  my($s) = sprintf("from %s%s%s\n by %s%s (%s, %s)",
    $conn->smtp_helo eq '' ? 'unknown' : $conn->smtp_helo,
    $client_ip eq '' ? '' : " ([$client_ip])",
    !defined $tls    ? '' : " (using TLS with cipher $tls)",
    c('localhost_name'),
    $conn->socket_ip eq '' ? ''
      : sprintf(" (%s [%s])", c('myhostname'), $conn->socket_ip),
    $myproduct_name,
    $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;
}

# parse Received header field according to rfc2821, somewhat liberalized syntax
#   Stamp = From-domain By-domain [Via] [With] [ID] [For] datetime
#   From-domain = "FROM" FWS Extended-Domain           CFWS
#   By-domain   = "BY"   FWS Extended-Domain           CFWS
#   Via         = "VIA"  FWS ("TCP"            / Atom) CFWS
#   With        = "WITH" FWS ("ESMTP" / "SMTP" / Atom) CFWS
#   ID          = "ID"   FWS (Atom / DQUOTE *qcontent DQUOTE / msg-id) CFWS
#   For         = "FOR"  FWS 1*( Path / Mailbox )      CFWS
#     Path = "<" [ A-d-l ":" ] Mailbox ">"
#   datetime    = ";"    FWS [ day-of-week "," ] date FWS time [CFWS]
#   Extended-Domain =
#    (Domain / Address-literal) [ FWS "(" [ Domain FWS ] Address-literal ")" ]
# Avoid regexps like ( \\. | [^"\\] )* which cause recursion trouble / crashes!
#
sub parse_received($) {
  local($_) = $_[0]; my(%fld);
  local($1); tr/\n//d;  # unfold, chomp
  my($comm_lvl) = 0; my($in_option) = '';
  my($in_ext_dom) = 0; my($in_tcp_info) = 0;
  my($in_qcontent) = 0; my($in_literal) = 0; my($in_angle) = 0;
  my($str_l) = length($_); my($new_pos);
  for (my $pos=-1;  $new_pos=pos($_), $new_pos<$str_l;  $pos=$new_pos) {
    $new_pos > $pos or die "parse_received PANIC1 $new_pos"; # just in case
    # comment (may be nested: rfc2822 section 3.2.3)
    if ($comm_lvl > 0 && /\G( \) )/gcsx) {
      if ($comm_lvl >  1 ||  $in_tcp_info) { $fld{$in_option} .= $1 }  # nested
      if ($comm_lvl == 1 && !$in_tcp_info) { $in_option =~ s/-com\z// }
      $comm_lvl--; next;  # pop up one level of comments
    }
    if ($in_tcp_info && /\G( \) )/gcsx)  # leaving TCP-info
      { $in_option =~ s/-tcp\z//; $in_tcp_info = 0; $in_ext_dom = 4; next }
    if (!$in_qcontent && !$in_literal && !$comm_lvl &&
        !$in_tcp_info && $in_ext_dom==1 && /\G( \( )/gcsx) {
      # entering TCP-info part, only once after 'from' or 'by'
      $in_option .= '-tcp'; $in_tcp_info = 1; $in_ext_dom = 2; next;
    }
    if (!$in_qcontent && !$in_literal && /\G( \( )/gcsx) {
      $comm_lvl++;  # push one level of comments
      if ($comm_lvl >  1 ||  $in_tcp_info) { $fld{$in_option} .= $1 }  # nested
      if ($comm_lvl == 1 && !$in_tcp_info) {  # comment starts here
        $in_option .= '-com';
        $fld{$in_option} .= ' ' if defined $fld{$in_option};  # looks better
      }
      next;
    }
    if ($comm_lvl > 0 && /\G( \\.      )/gcsx) { $fld{$in_option} .= $1; next }
    if ($comm_lvl > 0 && /\G( [^()\\]+ )/gcsx) { $fld{$in_option} .= $1; next }
    # quoted content
    if ($in_qcontent && /\G( " )/gcsx)  # normal exit from qcontent
      { $in_qcontent = 0; $fld{$in_option} .= $1; next }
    if ($in_qcontent && /\G( > )/gcsx)  # bail out of qcontent
      { $in_qcontent = 0; $in_angle = 0; $fld{$in_option} .= $1; next }
    if ($in_qcontent && /\G( \\.      )/gcsx) { $fld{$in_option} .= $1; next }
    if ($in_qcontent && /\G( [^"\\>]+ )/gcsx) { $fld{$in_option} .= $1; next }
    # address literal
    if ($in_literal && /\G( \] )/gcsx)
      { $in_literal = 0; $fld{$in_option} .= $1; next }
    if ($in_literal && /\G( > )/gcsx)  # bail out of address literal
      { $in_literal = 0; $in_angle = 0; $fld{$in_option} .= $1; next }
    if (!$comm_lvl && !$in_qcontent && /\G( \[ )/gcsx)
      { $in_literal = 1; $fld{$in_option} .= $1; next }
    if ($in_literal && /\G( \\.       )/gcsx) { $fld{$in_option} .= $1; next }
    if ($in_literal && /\G( [^\]\\>]+ )/gcsx) { $fld{$in_option} .= $1; next }

    if (!$comm_lvl && !$in_qcontent && !$in_literal && !$in_tcp_info) {  # top
      if (!$in_angle && /\G( < )/gcsx)
        { $in_angle = 1; $fld{$in_option} .= $1; next }
      if ( $in_angle && /\G( > )/gcsx)
        { $in_angle = 0; $fld{$in_option} .= $1; next }
      if (!$in_angle && /\G (from|by)       (?:[ \t]+|\z|(?=[\[\(",;<]))/gcsxi)
        { $in_option = lc($1); $in_ext_dom = 1; next }
      if (!$in_angle &&/\G (via|with|id|for)(?:[ \t]+|\z|(?=[\[\(",;<]))/gcsxi)
        { $in_option = lc($1); $in_ext_dom = 0; next }
      if (!$in_angle &&/\G( ; )/gcsxi)
        { $in_option = lc($1); $in_ext_dom = 0; next }
      if (/\G( [ \t]+ )/gcsx)                  { $fld{$in_option} .= $1; next }
      if (/\G( [^ \t,:;\@<>()"\[\]\\]+ )/gcsx) { $fld{$in_option} .= $1; next }
    }
    if (/\G( . )/gcsx) { $fld{$in_option} .= $1; next }  # other junk
    die "parse_received PANIC2 $new_pos";  # just in case
  }
  for my $f ('from-tcp','by-tcp') {
    # a tricky part is handling the syntax:
    #   (Domain/Addr-literal) [ FWS "(" [ Domain FWS ] Addr-literal ")" ] CFWS
    # where absence of Address-literal in TCP-info means that what looked
    # like a domain in the optional TCP-info, is actually a comment in CFWS
    local($_) = $fld{$f};
    if (!defined($_)) {}
    elsif (/\[ (\d{1,3} (?: \. \d{1,3}){3}) \] /x) {}
    elsif (/\[ [^\]]* : [^\]]* \]/x &&  # triage, must contain a colon
           /\[ (?: IPv6: )?  [0-9a-f]{0,4}
               (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,9} \]/xi) {}
  # elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /x) {}
    elsif (/^(?: localhost | ( [a-z0-9_\/+-]{1,63} \. )+ [a-z-]{2,} )\b/xi) {}
    else {
      my($fc) = $f;  $fc =~ s/-tcp\z/-com/;
      $fld{$fc} = ''  if !defined $fld{$fc};
      $fld{$fc} = $_ . (/[ \t]\z/||$fld{$fc}=~/^[ \t]/?'':' ') .$fld{$fc};
      delete $fld{$f};
    }
  }
  for (values %fld) { s/[ \t]+\z//; s/^[ \t]+// }
# for my $f (sort {$s{$a}<=>$s{$b}} keys %fld)
#   { do_log(5, "%-8s -> /%s/", $f,$fld{$f}) }
  \%fld;
}

sub fish_out_ip_from_received($) {
  my($received) = @_;
  my($fields_ref) = parse_received($received);
  my($ip); local($1);
  for (grep {defined} (@$fields_ref{qw(from-tcp from from-com)})) {
    if (/ \[ (\d{1,3} (?: \. \d{1,3}){3}) (?: \. \d{4,5} )? \] /x) {
      $ip = $1;  last;
    } elsif (/\[ [^\]]* : [^\]]* \]/x &&  # triage, must contain a colon
             /\[ ( (?: IPv6: )?  [0-9a-f]{0,4}
                   (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,9} ) \]/xi) {
      $ip = $1;  last;
    } elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /x) {
      $ip = $1;  last;
    }
  }
  do_log(5, "fish_out_ip_from_received: %s", $ip)  if defined $ip;
  !defined($ip) ? undef : $ip;  # undef need not be tainted
}

# Splits unquoted fully qualified e-mail address, or an address
# with a 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 a localpart.
# The domain part can be an address literal, as specified by rfc2822.
# Does not handle explicit route paths, use parse_quoted_rfc2821 for that.
#
sub split_address($) {
  my($mailbox) = @_;  local($1,$2);
  $mailbox =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\]\\] ){0,999} (?: \] | \z)
                              |  [^\[\@] )*
                       ) \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); local($1,$2);
  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);  # extension includes a delimiter
    # do not split the address if the result would have a null localpart
  }
  ($localpart, $extension);
}

# replace localpart/extension/domain fields of an original email address
# with nonempty fields of a replacement
#
sub replace_addr_fields($$;$) {
  my($orig_addr, $repl_addr, $delim) = @_;
  my($localpart_o, $domain_o, $ext_o, $localpart_r, $domain_r, $ext_r);
  ($localpart_o,$domain_o) = split_address($orig_addr);
  ($localpart_r,$domain_r) = split_address($repl_addr);
  $localpart_r = $localpart_o  if $localpart_r eq '';
  $domain_r    = $domain_o     if $domain_r    eq '';
  if ($delim ne '') {
    ($localpart_o,$ext_o) = split_localpart($localpart_o,$delim);
    ($localpart_r,$ext_r) = split_localpart($localpart_r,$delim);
    $ext_r = $ext_o  if !defined $ext_r;
  }
  $localpart_r . (defined $ext_r ? $ext_r : '') . $domain_r;
}

# given a (potentially multiline) header field Message-ID, Resent-Message-ID.
# In-Reply-To, or References, parse the rfc5322 (rfc2822) syntax extracting
# all message IDs while ignoring comments, and return them as a list
# See also: rfc2392 - Content-ID and Message-ID Uniform Resource Locators
#
sub parse_message_id($) {
  my($str) = @_;
  $str =~ tr/\n//d; my(@message_id); my($garbage) = 0;
  $str =~ s/[ \t]+/ /g;  # compress whitespace as a quickfix/bandaid
  for my $t ( $str =~ /\G ( [ \t]+ | \( (?: \\. | [^()\\] ){0,999} \) |
                             <  (?:  "  (?: \\. | [^"\\>] ){0,999} "  |
                                     \[ (?: \\. | [^\]\\>]){0,999} \] |
                                     [^"<>\[\]\\]+ )*  >  |
                             [^<( \t]+ | . )/gcsx ) {
    if    ($t =~ /^<.*>\z/) { push(@message_id,$t) }
    elsif ($t =~ /^[ \t]*\z/) {}   # ignore FWS
    elsif ($t =~ /^\(.*\)\z/)      # ignore CFWS
      { do_log(2, "parse_message_id ignored comment: /%s/ in %s", $t,$str) }
    else { $garbage = 1 }
  }
  if (@message_id > 1) {
    @message_id = unique_list(\@message_id);  # remove possible duplicates
  } elsif ($garbage && !@message_id) {
    local($_) = $str; s/^[ \t]+//; s/[ \t\n]+\z//;  # trim and sanitize <...>
    s/^<//; s/>\z//; s/>/_/g; $_ = '<'.$_.'>'; @message_id = ($_);
    do_log(5, "parse_message_id sanitizing garbage: /%s/ to %s", $str,$_);
  }
  @message_id;
}

# 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,$append_string) = @_;
  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
  local($1);
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  my($extension); my($delim) = c('recipient_delimiter');
  if ($delim ne '') {
    ($localpart,$extension) = split_localpart($localpart,$delim);
    # extension includes a delimiter since amavisd-new-2.5.0!
  }
  $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.$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.$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);
  }
  if (defined $append_string && $append_string ne '') {
    $_ .= $append_string  for @keys;
  }
  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
    $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 rfc5321 (ex rfc2821).
#
# internal (unquoted) form is used internally by amavisd-new and other mail sw,
# external (quoted) form is used in SMTP commands and in message header section
#
# 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 rfc5321 (ex 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.
    local($1);  # qcontent = qtext / quoted-pair
    $localpart =~ s/([\000-\037\177-\377"\\])/\\$1/g;  # quote non-qtext
    $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 =~ s/^\s*<//s;  $addr =~ s/>\s*\z//s;  # tolerate unmatched angle brkts
  local($1,$2); 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 (index($addr,':') >= 0 &&  # triage before more testing for source route
      $addr =~ m{^ (       [ \t]* \@ (?: [0-9A-Za-z.!\#\$%&*/^{}=_+-]* |
                                   \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \t]*
                     (?: , [ \t]* \@ (?: [0-9A-Za-z.!\#\$%&*/^{}=_+-]* |
                                   \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \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{^ ( .*? )
                 ( \@ (?: [^\@\[\]]+ | \[ (?: \\. | [^\]\\] ){0,999} \]
                          | [^\@] )* )
                 \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 rfc5321 (ex rfc2821).
# Internal (unquoted) form is used internally by amavisd-new and other mail sw,
# external (quoted) form is used in SMTP commands and in message header section
#
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 dirty trick)
  $domain = '@'  if $domain eq '' && $localpart ne '' && $localpart =~ /\@/;
  $localpart . $domain;
}

# Parse a rfc2822.address-list, returning a list of rfc2822(quoted) addresses.
# Properly deals with group addresses, nested comments, address literals,
# qcontent, addresses with source route, discards display names and comments.
# The following header fields accept address-list: To, Cc, Bcc, Reply-To.
# A header field 'From' accepts a 'mailbox-list' syntax (which is similar,
# but does not allow groups); a header field 'Sender' accepts a 'mailbox'
# syntax, i.e. only one address and not a group.
#
use vars qw($s $p @addresses);
sub flush_a() {
  $s =~ s/^[ \t]+//s; $s =~ s/[ \t]\z//s;  # trim
  $p =~ s/^[ \t]+//s; $p =~ s/[ \t]\z//s;
  if ($p ne '') { $p =~ s/^<//; $p =~ s/>\z//; push(@addresses,$p) }
  elsif ($s ne '') { push(@addresses,$s) }
  $p = ''; $s = '';
}
sub parse_address_list($) {
  local($_) = $_[0];
  local($1); s/\n(?=[ \t])//gs; s/\n+\z//s;  # unfold, chomp
  my($str_l) = length($_); $p = ''; $s = ''; @addresses = ();
  my($comm_lvl) = 0; my($in_qcontent) = 0; my($in_literal) = 0;
  my($in_group) = 0; my($in_angle) = 0; my($after_at) = 0; my($new_pos);
  for (my $pos=-1;  $new_pos=pos($_), $new_pos<$str_l;  $pos=$new_pos) {
    $new_pos > $pos or die "parse_address_list PANIC1 $new_pos"; # just in case
    # comment (may be nested: rfc2822 section 3.2.3)
    if ($comm_lvl > 0 && /\G( \) )/gcsx) { $comm_lvl--; next }
    if (!$in_qcontent && !$in_literal && /\G( \( )/gcsx) { $comm_lvl++; next }
    if ($comm_lvl > 0 && /\G( \\.      )/gcsx) { next }
    if ($comm_lvl > 0 && /\G( [^()\\]+ )/gcsx) { next }
    # quoted content
    if ($in_qcontent && /\G( " )/gcsx)  # normal exit from qcontent
      { $in_qcontent = 0; ($in_angle?$p:$s) .= $1; next }
    if ($in_qcontent && /\G( > )/gcsx)  # bail out of qcontent
      { $in_qcontent = 0; $in_angle = 0; $after_at = 0;
        ($in_angle?$p:$s) .= $1; next }
    if (!$comm_lvl && !$in_qcontent && !$in_literal && /\G( " )/gcsx)
      { $in_qcontent = 1; ($in_angle?$p:$s) .= $1; next }
    if ($in_qcontent && /\G( \\.      )/gcsx) { ($in_angle?$p:$s) .= $1; next }
    if ($in_qcontent && /\G( [^"\\>]+ )/gcsx) { ($in_angle?$p:$s) .= $1; next }
    # address literal
    if ($in_literal && /\G( \] )/gcsx)
      { $in_literal = 0; ($in_angle?$p:$s) .= $1; next }
    if ($in_literal && /\G( > )/gcsx)  # bail out of address literal
      { $in_literal = 0; $in_angle = 0; $after_at = 0;
        ($in_angle?$p:$s) .= $1; next }
    if (!$comm_lvl && !$in_qcontent && /\G( \[ )/gcsx)
      { $in_literal = 1 if $after_at; ($in_angle?$p:$s) .= $1; next }
    if ($in_literal && /\G( \\.       )/gcsx) { ($in_angle?$p:$s) .= $1; next }
    if ($in_literal && /\G( [^\]\\>]+ )/gcsx) { ($in_angle?$p:$s) .= $1; next }
    # normal content
    if (!$comm_lvl && !$in_qcontent && !$in_literal) {
      if (!$in_angle && /\G( < )/gcsx)
        { $in_angle = 1; $after_at = 0; flush_a() if $p ne ''; $p .= $1; next }
      if ( $in_angle && /\G( > )/gcsx)
        { $in_angle = 0; $after_at = 0; $p .= $1; next }
      if (/\G( , )/gcsx)  # top-level addr separator or source route delimiter
        { !$in_angle ? flush_a() : ($p.=$1); $after_at = 0; next }
      if (!$in_angle && !$in_group && /\G( : )/gcsx)  # group name terminator
        { $in_group = 1; $s .= $1; $p=$s=''; next }   # discard group name
      if ($after_at && /\G( : )/gcsx)                 # source route terminator
        { $after_at = 0; ($in_angle?$p:$s) .= $1; next }
      if ( $in_group && /\G( ; )/gcsx)                # group terminator
        { $in_group = 0; $after_at = 0; next }
      if (!$in_group && /\G( ; )/gcsx)                # out of place special
        { ($in_angle?$p:$s) .= $1; $after_at = 0; next }
      if (/\G( \@ )/gcsx)    { $after_at = 1; ($in_angle?$p:$s) .= $1; next }
      if (/\G( [ \t]+ )/gcsx)               { ($in_angle?$p:$s) .= $1; next }
      if (/\G( [^,:;\@<>()"\[\]\\]+ )/gcsx) { ($in_angle?$p:$s) .= $1; next }
    }
    if (/\G( . )/gcsx) { ($in_angle?$p:$s) .= $1; next }  # other junk
    die "parse_address_list PANIC2 $new_pos";  # just in case
  }
  flush_a(); @addresses;
}

# 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. Typically leading whitespace
# is a single character, but may include part of the trailing whitespace of
# the preceeding line if it would otherwise be too long. This is appropriate
# and required for wrapping of mail haeder fields. An exception to preservation
# of whitespace is when $indent string is defined but is an empty string,
# causing leading and trailing whitespace to be trimmed, producing a classical
# plain text wrapping results. Intricate!
#
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, at
  # least one character must be non-whitespace), followed by an all-whitespace
  # string consisting of only SP or TAB characters.
  if ($structured) {
    local($1);
    # 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- all-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 {
      local($1,$2);
      $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 rfc5321 (ex rfc2821),
# returning resulting lines as a listref
sub wrap_smtp_resp($) {
  my($resp) = @_;
  # rfc5321: The maximum total length of a reply line including the
  # reply code and the <CRLF> is 512 octets. 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, $suppressed) = @_;
  my($smtp_resp, $exit_code, $ndn_needed);
  my($am_id)           = $msginfo->log_id;
  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=1; last }  # one is not a discard, nogood
    }
    if ($notall) { undef $smtp_resp }
    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=1; last }  # one is Pass or Bounce, nogood
    }
    if ($notall) { undef $smtp_resp }
    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, $suppressed ? 'DISCARD(bounce.suppressed)' :'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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  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 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 a Perl m// operator. The number after a $ may be a multi-digit
# decimal number. To avoid possible ambiguity a ${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, as a loop on attributes must be an inner loop

sub lookup_re($$;$%) {
  my($self, $addr,$get_all,%options) = @_;
  local($1,$2,$3,$4); my(@matchingkey,@result);
  $addr .= $options{AppendStr}  if exists $options{AppendStr};
  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 into @rhs
    if (!ref($addr)) { @rhs = $addr =~ /$key/ }
    else { for (@$addr) { @rhs = /$key/; last if @rhs } }  # inner loop
    if (@rhs) {  # regexp matches
      # do the righthand side replacements if any $n, ${n} or $(n) is specified
      if (!ref($r) && $r=~/\$/) {  # triage
        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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&lookup_ip_acl);
  import Amavis::Util qw(ll do_log);
}
use subs @EXPORT_OK;

# 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 rfc5321 (ex rfc2821). Brackets enclosing the address
# are optional, but 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\r\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 specif.
  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
  }
  $ipa =~ s/^IPv6://i;
  # now we presumably have an IPv6 compressed or preferred form x:x:x:x:x:x:x:x
  if ($ipa !~ /^(.*?)::(.*)\z/s) {  # zero-compressing form used?
    @ip_fields = split(/:/,$ipa,-1);  # no, have preferred form
  } 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);
  }
  @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";
  !grep { !/^[0-9a-zA-Z]{1,4}\z/ } @ip_fields  # this is quite slow
    or die "Invalid syntax of IPv6 address: [$ip]\n";
  my($vec) = pack("n8", map {hex} @ip_fields);
  if (!defined($ip_len)) { $ip_len = 128 }
  elsif ($ip_len !~ /^\d{1,3}\z/)
    { die "Invalid prefix length syntax in IP address: [$ip]\n" }
  elsif ($ip_len > 128)
    { die "IPv6 network prefix length greater than 128: [$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 a list
# of lookup tables, each may be a constant, or a ref to an access control
# list or a ref to an associative array (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);  my($eval_stat);
  eval { ($ip_vec,$ip_mask) = ip_to_vec($ip,0);  1 }
    or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  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=1  if defined $result;
    } elsif (ref($t) eq 'HASH') {
      if (!defined $ip_vec) {  # syntactically invalid IP address
        undef $fullkey; $result = $t->{$fullkey};  # only matches undef key
        $found=1  if defined $result;
      } else {      # valid IP address
        # match a 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 as 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, stripping off trailing bytes
          for (my(@f)=split(/\./,$ip_dq); @f && !$found; $#f--) {
            $fullkey = join('.',@f); $result = $t->{$fullkey};
            $found=1  if defined $result;
          }
        }
        if (!$found) {         # try the 'preferred IPv6 form'
          $fullkey = $ip_c; $result = $t->{$fullkey};
          $found=1  if defined $result;
        }
      }
    } elsif (ref($t) eq 'ARRAY') {
      my($key,$acl_ip_vec,$acl_mask,$acl_mask_len); local($1,$2);
      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=1 } #even an invalid addr matches ::/0
        elsif (!defined($ip_vec)) {}     # no other matches for invalid address
        elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found=1 }
        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=1 } #even an invalid addr matches ::/0
        elsif (!defined($ip_vec)) {}     # no other matches for invalid address
        elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found=1 }
        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 (defined $eval_stat) {
    chomp $eval_stat;
    die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
    $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); local($1,$2);
  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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&lookup &lookup2 &lookup_hash &lookup_acl);
  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);
}
use subs @EXPORT_OK;

# 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,%options) = @_;
  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($append_string);
  $append_string = $options{AppendStr}  if exists $options{AppendStr};
  my($keys_ref,$rhs_ref) = make_query_keys($addr,1,1,$append_string);
  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], !defined($result[0])?'undef':$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 always case-insensitive on domain part,
# local part matching depends on $localpart_is_case_sensitive setting.
#
# NOTE: 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 a character '!' prepended to a list element decides
# whether the result will be true (without a '!') or false (with '!')
# in case where 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(), because a defined result stops further lookups
#
# 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,%options) = @_;
  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;
  $domain .= $options{AppendStr}  if exists $options{AppendStr};
  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=1  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=1  if $domain eq $key_t || $domain =~ /(\.|\z)\Q$key_t\E\z/s;
    } else {                           # match domain (but not its subdomains)
      $found=1  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 a 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 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.
#
# traditional API
sub lookup($$@) {
  my($get_all, $addr, @tables) = @_;
  lookup2($get_all, $addr, \@tables);
}
#
# generalized API
sub lookup2($$$%) {
  my($get_all, $addr, $tables_ref, %options) = @_;
  (@_ - 3) % 2 == 0 or die "lookup2: options argument not in pairs (not hash)";
  my($label, @result,@matchingkey);
  for my $tb (!$tables_ref ? () : @$tables_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
      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,%options);
      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,%options);
      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,%options);
      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,%options);
      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,%options);
      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,%options);
      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,%options);
      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
    my($opt_label);  $opt_label = $options{Label};
    my(@lbl) = grep { defined $_ && $_ ne '' } ($opt_label,$label);
    $label = " [" . join(",",@lbl) . "]"  if @lbl;
    if (!$tables_ref || !@$tables_ref) {
      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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&expand &tokenize);
  import Amavis::Util qw(ll do_log);
}
use subs @EXPORT_OK;

# Given a string reference and a hashref of predefined (builtin) macros,
# expand() performs a macro expansion and returns a ref to 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 of use
# 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 ref to 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) = @_;  local($1);
  $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)  # \r, \n, \f, ...
    : /^(_ [A-Z]+ (?: \( [^)]* \) )? _)\z/sx ? \"$1"  # SpamAssassin-compatible
    : $_ }
    $$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); local($1,$2);
  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
    # args: string, regexp1, then1, regexp2, then2, ... regexpN, thenN[, else]
    my($str) = tokens_list_to_str(shift(@args));  # collect the first argument
    my($match,@repl);
    while (@args >= 2) {  # at least a regexp and a 'then' argument still there
      @repl = ();
      my($regexp) = tokens_list_to_str(shift(@args));  # collect a regexp arg
      ""=~/x{0}/; #braindead Perl: serves as explicit deflt for an empty regexp
      eval {  # guard against invalid regular expression
        local($1,$2,$3,$4,$5,$6,$7,$8,$9);
        $match = $str=~/$regexp/ ? 1 : 0;
        @repl = ($1,$2,$3,$4,$5,$6,$7,$8,$9)  if $match;
        1;
      } or do {
        my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
        do_log(2,"invalid macro regexp arg: %s", $eval_stat);
        $match = 0; @repl = ();
      };
      if ($match) { last } else { shift(@args) }  # skip 'then' arg if no match
    }
    if (@args > 0) {
      unshift(@repl,$str);  # prepend the whole string as a %0
      # formal arg lexels %0, %1, ... %9 are replaced by captured substrings
      @result = map { !ref || $$_ !~ /^%([0-9])\z/ ? $_ : $repl[$1] }
                    @{$args[0]};
    }
  } elsif ($macro_type == $lx_lb) {    # iterator macro
    my($cvar_r,$sep_r,$body_r); my($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 iterator name
    for (@$cvar_r) { if (ref && $$_ =~ /^%(.)\z/s) { $cvar = $1; last } }
    my($name) = $cvar;  # macro name is usually the same as the iterator name
    if (@args >= 3 && !defined($name)) {
      # instead of iterator like %x, the first arg may be a long macro name,
      # in which case the iterator name becomes a hard-wired 'x'
      $name = tokens_list_to_str($cvar_r);
      $name =~ s/^[ \t\n]+//; $name =~ s/[ \t\n]+\z//;  # trim whitespace
      if ($name eq '') { $name = undef } else { $cvar = 'x' }
    }
    if (exists($builtins_href->{$name})) {
      my($s) = $builtins_href->{$name};
      if (ref($s) eq 'Amavis::Expand') {  # expand a dynamically defined macro
        my(@margs) = ($name);  # no arguments beyond %0
        my(@res) = map { !ref || $$_ !~ /^%([0-9])\z/ ? $_
                           : ref($margs[$1]) ? @{$margs[$1]} : () } @$s;
        $s = tokens_list_to_str(\@res);
      } elsif (ref($s) eq 'CODE') {
        if (exists($builtins_cached{$name})) {
          $s = $builtins_cached{$name};
        } else {
          while (ref($s) eq 'CODE') { $s = &$s($name) }
          $builtins_cached{$name} = $s;
        }
      }
      my($ind) = 0;
      for my $val (ref($s) ? @$s : $s) {  # do substitutions in the body
        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 call
           $$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
                               # 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); local($1,$2);
  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 up 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,
# file 'email.txt', and subdirectory 'parts'

use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(ll do_log add_entropy rmdir_recursively);
  import Amavis::rfc2821_2822_Tools qw(iso8601_timestamp);
}

use Errno qw(ENOENT EACCES);
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);

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

sub path {      # path to a temporary directory
  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; local($@,$!);
  if (defined($my_pid) && $$ != $my_pid) {
    eval { do_log(5,"Amavis::TempDir DESTROY skip, clone [%s] (born as [%s])",
                    $$,$my_pid) };
  } else {
    eval { do_log(5,"Amavis::TempDir DESTROY called") };
    eval {
      $self->{fh_pers}->close
        or do_log(-1,"Error closing temp file: %s",$!)  if $self->{fh_pers};
      undef $self->{fh_pers};
      my($errn) = $self->{tempdir_path} eq '' ? ENOENT
                    : (lstat($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});
        }
      };
      1;
    } or do {
      my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      eval { do_log(1,"TempDir removal: %s",$eval_stat) };
    };
  }
}

# Creates the temporary directory, and checks that inode did not change
sub prepare {
  my($self) = @_;
  if (! defined $self->{tempdir_path} ) {
    # invent a name of a temporary directory for this child
    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 == ENOENT) {
    do_log(4,"TempDir::prepare: creating directory %s", $dname);
    mkdir($dname,0750) or die "Can't create directory $dname: $!";
    @stat_list = lstat($dname);
    @stat_list or die "Failed to access directory $dname: $!";
    ($self->{tempdir_dev},$self->{tempdir_ino}) = @stat_list;
    $self->{empty} = 1; add_entropy(@stat_list);
    section_time('mkdir tempdir');
  } elsif ($errn != 0) {
    die "TempDir::prepare: Can't access temporary directory $dname: $!";
  } elsif (! -d _) {  # exists, but is not a directory !?
    die "TempDir::prepare: $dname is not a directory!!!";
  } else {  # existing directory
    my($dev,$ino,$mode,$nlink) = @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;
    }
    if ($nlink > 3) {
      # when a directory's link count is > 2, it has "n-2" sub-directories;
      # this does not apply to file systems like AFS, FAT, ISO-9660,
      # but it also seems it does not apply to Mac OS 10 (Leopard)
      do_log(5, "TempDir::prepare: directory %s has %d subdirectories",
                $dname, $nlink-2);
    }
  }
}

# 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};
    undef $self->{fh_pers};
  } elsif ($errn != 0) {  # some other error
    undef $self->{fh_pers};
    die "TempDir::prepare_file: can't access temporary file $fname: $!";
  } elsif (! -f _) {  # not a regular file !?
    undef $self->{fh_pers};
    die "TempDir::prepare_file: $fname is not a regular file!!!";
  } 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
      undef $self->{fh_pers};
      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: $!";
    }
  }
  if ($self->{fh_pers} && !$can_truncate) {  # just in case clean() retained it
    undef $self->{fh_pers};
    do_log(1,"Unable to truncate temporary file %s, deleting it", $fname);
    unlink($fname) or die "Can't remove file $fname: $!";
  }
  if ($self->{fh_pers}) {  # rewind and truncate existing file
    $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);
  # $^F == 2  or do_log(-1,"prepare_file: SYSTEM_FD_MAX not 2: %d", $^F);
    my($newfh) = IO::File->new;
    # this can fail if a previous task of this process just recently stumbled
    # on some error and preserved its evidence, not deleting a file email.txt
    $newfh->open($fname, O_CREAT|O_EXCL|O_RDWR, 0640)
      or die "Can't create file $fname: $!";
    if ($unicode_aware) {
      binmode($newfh,":bytes") or die "Can't cancel :utf8 mode on $fname: $!";
      if (ll(5) && $] >= 5.008001) {  # get_layers was added with Perl 5.8.1
        my(@layers) = PerlIO::get_layers($newfh);
        do_log(5,"TempDir::prepare_file: layers: %s", join(",",@layers));
      }
    }
    $self->{fh_pers} = $newfh;
    @stat_list = lstat($fname);
    @stat_list or die "Failed to access temporary file $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: $!"
    }
    undef $self->{fh_pers}; undef $self->{tempdir_path}; $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: $!";
    undef $self->{fh_pers};
    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 files and subdirectories from the temporary directory, leaving only
# the directory itself, file email.txt, and empty subdirectory ./parts .
# Leaving directories for reuse can represent an important saving in time,
# as directory creation + deletion can be an expensive operation,
# requiring atomic file system operation, including flushing buffers
# to disk (depending on the file system in use).
#
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($eval_stat); 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))) {
      next  if $f eq '.' || $f eq '..';
      my(@stat_list) = lstat("$dir/$f");
      my($errn) = @stat_list ? 0 : 0+$!;
      if ($errn) {
        die "Inaccessible $dir/$f: $!";
      } elsif (-f _) {
        if ($f ne 'email.txt') { die "Unexpected file $dir/$f" }
      } elsif (-d _) {
        if ($f ne 'parts') {
          die "Unexpected directory $dir/$f";
        } elsif ($stat_list[3] > 2) {  # number of hard links
          die "Directory $dir/$f has subdirectories: ".($stat_list[3]-2);
        }
      } else {
        die "Unexpected non-regular file $dir/$f";
      }
    }
    # checking status on directory read ops doesn't work as expected, Perl bug
    # $!==0 or die "Error reading directory $dir: $!";
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  closedir(DIR) or die "Error closing directory $dir: $!";
  if (defined $eval_stat) {
    chomp $eval_stat;
    die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
    die "TempDir::check: $eval_stat\n";
  }
  1;
}

1;

#
package Amavis::IO::FileHandle;

# Provides a virtual file (a filehandle tie - a TIEHANDLE) representing
# a view to a mail message (accessed on an open file handle) prefixed by
# a couple of synthesized mail header fields supplied as an array of lines.

use strict;
use re 'taint';
no warnings 'uninitialized';
use warnings FATAL => 'utf8';
use Errno qw(EAGAIN);

sub new { shift->TIEHANDLE(@_) }

sub TIEHANDLE {
  my($class) = shift;
  my($self) = bless { 'fileno' => undef }, $class;
  if (@_) { $self->OPEN(@_) or return undef }
  $self;
}

sub UNTIE {
  my($self,$count) = @_;
  $self->CLOSE  if !$count && defined $self->FILENO;
  1;
}

sub DESTROY {
  my($self) = @_; local($@,$!);
  $self->CLOSE  if defined $self->FILENO;
  1;
}

sub BINMODE { 1 }
sub FILENO { my($self) = @_; $self->{'fileno'} }
sub CLOSE  { my($self) = @_; undef $self->{'fileno'}; 1 }
sub EOF    { my($self) = @_; defined $self->{'fileno'} ? $self->{'eof'} : 1 }

# creates a view on an already open file, prepended by some text
sub OPEN {
  my($self, $filehandle,$prefix_lines_ref,$size_limit) = @_;
  # $filehandle is a fh of an already open file;
  # $prefix_lines_ref is a ref to an array of lines, to be prepended
  #   to a created view on an existing file; these lines must each
  #   be terminated by a \n, and must not include other \n characters
  $self->CLOSE  if defined $self->FILENO;
  $self->{'fileno'} = 9999; $self->{'eof'} = 0;
  $self->{'prefix'} = $prefix_lines_ref;
  $self->{'prefix_n'} = 0;  # number of lines of a prefix
  $self->{'prefix_l'} = 0;  # number of characters of a prefix
  $self->{'pos'} = 0; $self->{'rec_ind'} = 0;
  $self->{'size_limit'} = $size_limit;  # pretend file ends at the limit
  if (ref $prefix_lines_ref) {
    my($len) = 0;  for (@$prefix_lines_ref) { $len += length($_) }
    $self->{'prefix_l'} = $len;
    $self->{'prefix_n'} = @$prefix_lines_ref;
  }
  $self->{'handle'} = $filehandle;
  seek($filehandle, 0,0);  # also provides a return value and errno
};

sub SEEK {
  my($self,$offset,$whence) = @_;
  $whence == 0  or die "Only absolute SEEK is supported on this file";
  $offset == 0  or die "Only SEEK(0,0) is supported on this file";
  $self->{'eof'} = 0; $self->{'pos'} = 0; $self->{'rec_ind'} = 0;
  seek($self->{'handle'}, 0,0);  # also provides a return value and errno
}

# sub TELL (not implemented)
#   Returns the current position in bytes for FILEHANDLE, or -1 on error.

# mixing of READ and READLINE is not supported (without rewinding inbetween)
sub READLINE {
  my($self) = @_; $! = 0;
  my($size_limit) = $self->{'size_limit'};
  my($pos) = $self->{'pos'};
  if ($self->{'eof'}) {
    return undef;
  } elsif (defined $size_limit && $pos >= $size_limit) {
    $self->{'eof'} = 1;
    return undef;
  } elsif (wantarray) {  # return entire file as an array
    my($rec_ind) = $self->{'rec_ind'};  $self->{'eof'} = 1;
    my($fh) = $self->{'handle'};
    if (!defined $size_limit) {
      $self->{'rec_ind'} = $self->{'prefix_n'};  # just an estimate
      $self->{'pos'} = $self->{'prefix_l'};      # just an estimate
      if ($rec_ind >= $self->{'prefix_n'}) {
        return readline($fh);
      } elsif ($rec_ind == 0) {  # common case: get the whole thing
        return ( @{$self->{'prefix'}}, readline($fh) );
      } else {
        return ( @{$self->{'prefix'}}[ $rec_ind .. $#{$self->{'prefix'}} ],
                 readline($fh) );
      }
    } else {
      my(@array); my($beyond_limit) = 0;
      if ($rec_ind == 0) {
        @array = @{$self->{'prefix'}};
      } elsif ($rec_ind < $self->{'prefix_n'}) {
        @array = @{$self->{'prefix'}}[ $rec_ind .. $#{$self->{'prefix'}} ];
      }
      for my $j (0..$#array) {
        $pos += length($array[$j]);
        if ($pos >= $size_limit && $j < $#array) { # truncate at NL past limit
          $#array = $j; $beyond_limit = 1; last;
        }
      }
      my($nread) = 0;
      if (!$beyond_limit) {
        my($inbuf,$carry);
        while ( $nread=read($fh,$inbuf,16384) ) {  # faster than line-by-line
          if ($pos+$nread > $size_limit) {
            my($k) = index($inbuf, "\n",  # find a clean break at next NL
                           $pos >= $size_limit ? 0 : $size_limit-$pos);
            $inbuf = substr($inbuf, 0, $k >= 0 ? $k+1 : $size_limit-$pos);
            $beyond_limit = 1;
          }
          $pos += $nread;
          my($k) = $#array + 1;  # insertion point
          push(@array, split(/^/m, $inbuf, -1));
          if (defined $carry) { $array[$k] = $carry.$array[$k]; undef $carry }
          $carry = pop(@array)  if substr($array[-1],-1,1) ne "\n";
          last  if $beyond_limit;
        }
        push(@array,$carry)  if defined $carry;
      }
      $self->{'rec_ind'} = $rec_ind + @array;
      $self->{'pos'} = $pos;
      if (!defined $nread) {
        @array = ();
        # errno should still be in $!, caller should be checking it
        # die "error reading: $!";
      }
      return @array;
    }
  } elsif ($self->{'rec_ind'} < $self->{'prefix_n'}) {
    my($line) = $self->{'prefix'}->[$self->{'rec_ind'}];
    $self->{'rec_ind'}++; $self->{'pos'} += length($line);
    return $line;
  } else {
    my($line) = scalar(readline($self->{'handle'}));
    if (!defined($line)) { $self->{'eof'} = 1 }
    else { $self->{'rec_ind'}++; $self->{'pos'} += length($line) }
    return $line;
  }
}

# mixing of READ and READLINE is not supported (without rewinding inbetween)
sub READ {  # SCALAR,LENGTH,OFFSET
  my($self) = shift; my($len) = $_[1]; my($offset) = $_[2];
  my($str) = ''; my($nbytes) = 0;
  my($pos) = $self->{'pos'};
  my($beyond_limit) = 0;
  my($size_limit) = $self->{'size_limit'};
  if (defined $size_limit && $pos+$len > $size_limit) {
    $len = $pos < $size_limit ? $size_limit - $pos : 0;
    $beyond_limit = 1;
  }
  if ($len > 0 && $pos < $self->{'prefix_l'}) {
    # not terribly efficient, but typically only occurs once
    $str = substr(join('',@{$self->{'prefix'}}), $pos, $len);
    $nbytes += length($str); $len -= $nbytes;
  }
  my($msg);  my($buff_directly_accessed) = 0;  $! = 0;
  if ($len > 0) {
    # avoid shuffling data through multiple buffers for a common case
    $buff_directly_accessed = $nbytes == 0;
    my($nb) = $buff_directly_accessed
                ? read($self->{'handle'}, $_[0], $len, $offset)
                : read($self->{'handle'}, $str,  $len, $nbytes);
    if (!defined $nb) {
      $msg = "Error reading: $!";
    } elsif ($nb < 1) {  # read returns 0 at eof
      $self->{'eof'} = 1;
    } else {
      $nbytes += $nb; $len -= $nb;
    }
  }
  if (defined $msg) {
    undef $nbytes;  # $! already set by a failed sysread
  } elsif ($beyond_limit && $nbytes == 0) {
    $self->{'eof'} = 1;
  } else {
    if (!$buff_directly_accessed) {
      ($offset ? substr($_[0],$offset) : $_[0]) = $str;
    }
    $pos += $nbytes; $self->{'pos'} = $pos;
  }
  $nbytes;   # eof: 0;  error: undef
}

sub close    { shift->CLOSE(@_) }
sub fileno   { shift->FILENO(@_) }
sub binmode  { shift->BINMODE(@_) }
sub seek     { shift->SEEK(@_) }
#sub tell    { shift->TELL(@_) }
sub read     { shift->READ(@_) }
sub readline { shift->READLINE(@_) }
sub getlines { shift->READLINE(@_) }
sub getline  { scalar(shift->READLINE(@_)) }

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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @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); my($eval_stat);
  eval { $status = $self->{fh}->gzclose; 1 }
    or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  delete $self->{fh};
  if ($status != Z_OK || defined $eval_stat) {
    chomp $eval_stat;
    die $eval_stat  if $eval_stat =~ /^timed out\b/;   # resignal timeout
    die "gzclose error: $gzerrno";  # can't stash arbitrary text into $!
    $! = EIO; return undef;  # not reached
  }
  1;
}

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

sub open {
  my($self,$fname,$mode) = @_;
  if (exists($self->{fh})) { eval { $self->close }; 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  or die "Only absolute seek is supported on gzipped file";
  $pos >= 0     or die "Can't seek to a negative absolute position";
  $self->{mode} eq 'rb'
    or die "Seek to $whence,$pos on gzipped file only supported for 'rb' mode";
  if ($pos < $self->{pos}) {
    $self->close or die "seek: can't close gzipped file: $!";
    $self->open($self->{fname},$self->{mode})
      or die "seek: can't reopen gzipped file: $!";
  }
  my($skip) = $pos - $self->{pos};
  while ($skip > 0) {
    my($s);  my($nbytes) = $self->read($s,$skip);  # acceptable for small skips
    defined $nbytes && $nbytes > 0
      or die "seek: error skipping $skip bytes on gzipped file: $!";
    $skip -= $nbytes;
  }
  1;  # seek is supposed to return 1 upon success, 0 otherwise
}

sub read {  # SCALAR,LENGTH,OFFSET
  my($self) = shift; my($len) = $_[1]; my($offset) = $_[2];
  defined $len  or die "Amavis::IO::Zlib::read: length argument undefined";
  my($nbytes);
  if (!defined($offset) || $offset == 0) {
    $nbytes = $self->{fh}->gzread($_[0], $len);
  } else {
    my($buff);
    $nbytes = $self->{fh}->gzread($buff, $len);
    substr($_[0],$offset) = $buff;
  }
  if ($nbytes < 0) {
    die "gzread error: $gzerrno";  # can't stash arbitrary text into $!
    $! = EIO; undef $nbytes;  # not reached
  }
  $self->{pos} += $nbytes;
  $nbytes;   # eof: 0;  error: undef
}

sub getline {
  my($self) = shift;  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
    }
  }
  $self->{pos} += $nbytes;
  $line;  # eof: undef, $! zero;  error: undef, $! nonzero
}

sub print {
  my($self) = shift;
  my($buff_ref) = @_ == 1 ? \$_[0] : \join('',@_);
  my($nbytes); my($len) = length($$buff_ref);
  if ($len <= 0) { $nbytes = "0 but true" }
  else {
    $nbytes = $self->{fh}->gzwrite($$buff_ref);  $self->{pos} += $len;
    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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @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 socket_proto   # TCP/UNIX
  { my($self)=shift; !@_ ? $self->{socket_proto}:($self->{socket_proto}=shift)}
# rfc3848
sub appl_proto     # SMTP/ESMTP(A|S|SA)/LMTP(A|S|SA) / AM.PDP/AM.CL/QMQP/QMQPqq
  { my($self)=shift; !@_ ? $self->{appl_proto} : ($self->{appl_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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform);
  import Amavis::Util qw(setting_by_given_contents_category_all
                         setting_by_given_contents_category cmp_ccat);
}

sub new     # NOTE: this class is a list for historical reasons, not a hash
  { my($class) = @_; bless [(undef) x 35], $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_smtp  # SMTP-encoded recipient envelope e-mail address in <>
  { my($self)=shift; !@_ ? $$self[1] : ($$self[1]=shift) }
sub recip_addr_modified  # recip. addr. with possible addr. extension inserted
  { my($self)=shift; !@_ ? $$self[2] : ($$self[2]=shift) }
sub recip_is_local   # recip_addr matches @local_domains_maps
  { my($self)=shift; !@_ ? $$self[3] : ($$self[3]=shift) }
sub recip_maddr_id   # maddr.id field from SQL if logging to SQL is enabled
  { my($self)=shift; !@_ ? $$self[4] : ($$self[4]=shift) }
sub recip_penpals_age  # penpals age in sec from SQL if logging to SQL enabled
  { my($self)=shift; !@_ ? $$self[5] : ($$self[5]=shift) }
sub recip_penpals_score # penpals score (also added to recip_score_boost)
  { my($self)=shift; !@_ ? $$self[6] : ($$self[6]=shift) }
sub dsn_notify       # ESMTP RCPT command NOTIFY option (DSN-rfc3461, listref)
  { my($self)=shift; !@_ ? $$self[7] : ($$self[7]=shift) }
sub dsn_orcpt        # ESMTP RCPT command ORCPT option  (DSN-rfc3461, encoded)
  { my($self)=shift; !@_ ? $$self[8] : ($$self[8]=shift) }
sub dsn_suppress_reason  # if defined disable sending DSN and supply a reason
  { my($self)=shift; !@_ ? $$self[9] : ($$self[9]=shift) }
sub recip_destiny    # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
  { my($self)=shift; !@_ ? $$self[10] : ($$self[10]=shift) }
sub recip_done       # false: not done, true: done (1: faked, 2: truly sent)
  { my($self)=shift; !@_ ? $$self[11] : ($$self[11]=shift) }
sub recip_smtp_response # rfc2821 response (3-digit + enhanced resp + text)
  { my($self)=shift; !@_ ? $$self[12] : ($$self[12]=shift) }
sub recip_remote_mta_smtp_response  # smtp response as issued by remote MTA
  { my($self)=shift; !@_ ? $$self[13] : ($$self[13]=shift) }
sub recip_remote_mta # remote MTA that issued the smtp response
  { my($self)=shift; !@_ ? $$self[14] : ($$self[14]=shift) }
sub recip_mbxname    # mailbox name or file when known (local:, bsmtp: or sql:)
  { my($self)=shift; !@_ ? $$self[15] : ($$self[15]=shift) }
sub recip_whitelisted_sender  # recip considers this sender whitelisted
  { my($self)=shift; !@_ ? $$self[16] : ($$self[16]=shift) }
sub recip_blacklisted_sender  # recip considers this sender blacklisted
  { my($self)=shift; !@_ ? $$self[17] : ($$self[17]=shift) }
sub recip_score_boost  # recip adds spam points to the final score
  { my($self)=shift; !@_ ? $$self[18] : ($$self[18]=shift) }
sub infected    # contains a virus (1); is clean (0); or check bypassed (undef)
  { my($self)=shift; !@_ ? $$self[19] : ($$self[19]=shift) }
sub bypass_virus_checks # boolean: virus checks to be bypassed for this recip
  { my($self)=shift; !@_ ? $$self[20] : ($$self[20]=shift) }
sub bypass_banned_checks # bool: ban checks are to be bypassed for this recip
  { my($self)=shift; !@_ ? $$self[21] : ($$self[21]=shift) }
sub bypass_spam_checks # boolean: spam checks are to be bypassed for this recip
  { my($self)=shift; !@_ ? $$self[22] : ($$self[22]=shift) }
sub banned_parts     # banned part descriptions (ref to a list of banned parts)
  { my($self)=shift; !@_ ? $$self[23] : ($$self[23]=shift) }
sub banning_rule_key  # matching banned rules (lookup table keys) (ref to list)
  { my($self)=shift; !@_ ? $$self[24] : ($$self[24]=shift) }
sub banning_rule_comment #comments (or whole expr) from banning_rule_key regexp
  { my($self)=shift; !@_ ? $$self[25] : ($$self[25]=shift) }
sub banning_reason_short  # just one banned part leaf name with a rule comment
  { my($self)=shift; !@_ ? $$self[26] : ($$self[26]=shift) }
sub banning_rule_rhs  # a right-hand side of matching rules (a ref to a list)
  { my($self)=shift; !@_ ? $$self[27] : ($$self[27]=shift) }
sub mail_body_mangle  # mail body is being modified (and how) (e.g. defanged)
  { my($self)=shift; !@_ ? $$self[28] : ($$self[28]=shift) }
sub contents_category # sorted listref of "major,minor" strings(category types)
  { my($self)=shift; !@_ ? $$self[29] : ($$self[29]=shift) }
sub blocking_ccat   # category type most responsible for blocking msg, or undef
  { my($self)=shift; !@_ ? $$self[30] : ($$self[30]=shift) }
sub user_id   # listref of recipient IDs from a lookup, e.g. SQL field users.id
  { my($self)=shift; !@_ ? $$self[31] : ($$self[31]=shift) }
sub user_policy_id  # recipient's policy ID, e.g. SQL field users.policy_id
  { my($self)=shift; !@_ ? $$self[32] : ($$self[32]=shift) }
sub courier_control_file # path to control file containing this recipient
  { my($self)=shift; !@_ ? $$self[33] : ($$self[33]=shift) }
sub courier_recip_index # index of recipient within control file
  { my($self)=shift; !@_ ? $$self[34] : ($$self[34]=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;
}

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

# 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_main_contents_category($@) {
  my($self) = shift; my(@settings_href_list) = @_;
  return undef  if !@settings_href_list;
  my($aref) = $self->contents_category;
  setting_by_given_contents_category($aref, @settings_href_list);
}

# get a list of settings corresponding to all relevant contents categories,
# sorted from the most important to the least important entry;  entries which
# have no corresponding setting are not included in the list
sub setting_by_main_contents_category_all($@) {
  my($self) = shift; my(@settings_href_list) = @_;
  return undef  if !@settings_href_list;
  my($aref) = $self->contents_category;
  setting_by_given_contents_category_all($aref, @settings_href_list);
}

sub setting_by_blocking_contents_category($@) {
  my($self) = shift; my(@settings_href_list) = @_;
  my($blocking_ccat) = $self->blocking_ccat;
  !defined($blocking_ccat) ? undef
    : setting_by_given_contents_category($blocking_ccat, @settings_href_list);
}

sub setting_by_contents_category($@) {
  my($self) = shift; my(@settings_href_list) = @_;
  my($blocking_ccat) = $self->blocking_ccat;
  !defined($blocking_ccat)
    ? $self->setting_by_main_contents_category(@settings_href_list)
    : setting_by_given_contents_category($blocking_ccat, @settings_href_list);
}

1;

#
package Amavis::In::Message;
# this class keeps information about the message being processed

use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform);
  import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp quote_rfc2821_local
                                       qquote_rfc2821_local);
  import Amavis::Util qw(orcpt_encode);
  import Amavis::In::Message::PerRecip;
}

sub new
  { my($class) = @_; my($self)=bless({},$class); $self->skip_bytes(0); $self }
sub conn_obj        # ref to a connection object Amavis::In::Connection
  { my($self)=shift; !@_ ? $self->{conn}       : ($self->{conn}=shift) }
sub rx_time         # Unix time (s since epoch) of message reception by amavisd
  { my($self)=shift; !@_ ? $self->{rx_time}    : ($self->{rx_time}=shift) }
sub partition_tag   # SQL partition tag (e.g. an ISO week number 1..53, or 0)
  { my($self)=shift; !@_ ? $self->{partition}  : ($self->{partition}=shift) }
sub client_proto    # orig. client protocol, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_proto}  : ($self->{cli_proto}=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_addr_mynets  # client IP address matches @mynetworks_maps (boolean)
  { my($self)=shift; !@_ ? $self->{cli_mynets} : ($self->{cli_mynets}=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_port     # orig. client port num., obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_port}   : ($self->{cli_port}=shift) }
sub client_source   # LOCAL/REMOTE/undef, local_header_rewrite_clients/XFORWARD
  { my($self)=shift; !@_ ? $self->{cli_source} : ($self->{cli_source}=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 originating     # originating from our users, copied from c('originating')
  { my($self)=shift; !@_ ? $self->{originating}: ($self->{originating}=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 log_id          # task id as shown in the log, also known as am_id
  { my($self)=shift; !@_ ? $self->{log_id}     : ($self->{log_id}=shift) }
sub mail_id         # 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 to actual size, rfc1870
  { 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 tls_cipher      # defined if TLS was on, e.g. contains cipher alg., rfc3207
  { my($self)=shift; !@_ ? $self->{auth_tlscif}: ($self->{auth_tlscif}=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 header_8bit     # true if header contains illegal chars with code above 255
  { my($self)=shift; !@_ ? $self->{header_8bit}: ($self->{header_8bit}=shift) }
sub body_8bit       # true if body contains chars with code above 255
  { my($self)=shift; !@_ ? $self->{body_8bit}: ($self->{body_8bit}=shift) }
sub sender          # envelope sender, internal form, e.g.: j doe@example.com
  { my($self)=shift; !@_ ? $self->{sender}     : ($self->{sender}=shift) }
sub sender_smtp     # env sender, SMTP form in <>, e.g.: <"j doe"@example.com>
  { my($self)=shift; !@_ ? $self->{sender_smtp}: ($self->{sender_smtp}=shift) }
sub sender_credible # envelope sender is believed to be valid
  { my($self)=shift; !@_ ? $self->{sender_cred}: ($self->{sender_cred}=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 addr. or info from the trace (log/notif)
  { my($self)=shift; !@_ ? $self->{sender_src} : ($self->{sender_src}=shift) }
sub sender_maddr_id # maddr.id field from SQL if logging to SQL is enabled
  { my($self)=shift; !@_ ? $self->{maddr_id}   : ($self->{maddr_id}=shift) }
sub mime_entity     # MIME::Parser entity holding the parsed 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 skip_bytes      # file offset where mail starts, useful for quar. release
  { my($self)=shift; !@_ ? $self->{file_ofs}   : ($self->{file_ofs}=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 rfc2822_from #author addresses list (rfc allows one or more), parsed 'From'
  { my($self)=shift; !@_ ? $self->{hdr_from}   : ($self->{hdr_from}=shift) }
sub rfc2822_sender  # sender address (rfc allows none or one), parsed 'Sender'
  { my($self)=shift; !@_ ? $self->{hdr_sender} : ($self->{hdr_sender}=shift) }
sub rfc2822_resent_from # resending author addresses list, parsed 'Resent-From'
  { my($self)=shift; !@_ ? $self->{hdr_rfrom}  : ($self->{hdr_rfrom}=shift) }
sub rfc2822_resent_sender  # resending sender addresses, parsed 'Resent-Sender'
  { my($self)=shift; !@_ ? $self->{hdr_rsender}: ($self->{hdr_rsender}=shift) }
sub rfc2822_to      # parsed 'To' header field: a list of recipients
  { my($self)=shift; !@_ ? $self->{hdr_to}     : ($self->{hdr_to}=shift) }
sub rfc2822_cc      # parsed 'Cc' header field: a list of Cc recipients
  { my($self)=shift; !@_ ? $self->{hdr_cc}     : ($self->{hdr_cc}=shift) }
sub orig_header_fields # orig. header fields indices (LAST occurence) - hashref
  { my($self)=shift; !@_ ? $self->{orig_hdr_f} : ($self->{orig_hdr_f}=shift) }
sub orig_header # orig.h.sect, arrayref of h.fields, with folding & trailing LF
  { my($self)=shift; !@_ ? $self->{orig_header}: ($self->{orig_header}=shift) }
sub orig_header_size # size of original header, incl. a separator line, rfc1870
  { my($self)=shift; !@_ ? $self->{orig_hdr_s} : ($self->{orig_hdr_s}=shift) }
sub orig_body_size  # size of original body (in bytes), rfc1870
  { my($self)=shift; !@_ ? $self->{orig_bdy_s} : ($self->{orig_bdy_s}=shift) }
sub body_digest     # message digest of a message body (e.g. MD5, SHA1, SHA256)
  { my($self)=shift; !@_ ? $self->{body_digest}: ($self->{body_digest}=shift) }
sub is_mlist        # mail is from a mailing list (boolean/string)
  { my($self)=shift; !@_ ? $self->{is_mlist}   : ($self->{is_mlist}=shift) }
sub is_auto         # mail is an auto-response (boolean/string)
  { my($self)=shift; !@_ ? $self->{is_auto}    : ($self->{is_auto}=shift) }
sub is_bulk         # mail from a m.list or bulk or auto-response (bool/string)
  { my($self)=shift; !@_ ? $self->{is_bulk}    : ($self->{is_bulk}=shift) }
sub dkim_signatures_all # a ref to a list of DKIM signature objects, or undef
  { my($self)=shift; !@_ ? $self->{dkim_sall}  : ($self->{dkim_sall}=shift) }
sub dkim_signatures_valid # a ref to a list of valid DKIM signature objects
  { my($self)=shift; !@_ ? $self->{dkim_sval}  : ($self->{dkim_sval}=shift) }
sub dkim_author_sig # author signature is present and is valid (bool/domain)
  { my($self)=shift; !@_ ? $self->{dkim_auth_s}: ($self->{dkim_auth_s}=shift) }
sub dkim_thirdparty_sig # third-party signature present and valid (bool/domain)
  { my($self)=shift; !@_ ? $self->{dkim_3rdp_s}: ($self->{dkim_3rdp_s}=shift) }
sub dkim_sender_sig # a sender signature is present and is valid (bool/domain)
  { my($self)=shift; !@_ ? $self->{dkim_sndr_s}: ($self->{dkim_sndr_s}=shift) }
sub dkim_envsender_sig # boolean: envelope sender signature present and valid
  { my($self)=shift; !@_ ? $self->{dkim_envs_s}: ($self->{dkim_envs_s}=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 suppressed(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 CC_VIRUS/CC_BANNED/CC_SPAM../CC_CLEAN
  { my($self)=shift; !@_ ? $self->{category}   : ($self->{category}=shift) }
sub blocking_ccat   # category type most responsible for blocking msg, or undef
  { my($self)=shift; !@_ ? $self->{bl_ccat}    : ($self->{bl_ccat}=shift) }
sub virusnames      # a ref to a list of virus names detected, or undef
  { my($self)=shift; !@_ ? $self->{virusnames} : ($self->{virusnames}=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 section 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)}

# new style of providing additional information from checkers
sub supplementary_info  # holds a hash of tag/value pairs, like from SA get_tag
  { my($self)=shift; my($key)=shift;
    !@_ ? $self->{info_tag}{$key} : ($self->{info_tag}{$key}=shift);
}

# the following methods apply on a per-message level as well, summarizing
# per-recipient information as far as possible
*add_contents_category =
  \&Amavis::In::Message::PerRecip::add_contents_category;
*is_in_contents_category =
  \&Amavis::In::Message::PerRecip::is_in_contents_category;
*setting_by_main_contents_category =
  \&Amavis::In::Message::PerRecip::setting_by_main_contents_category;
*setting_by_main_contents_category_all =
  \&Amavis::In::Message::PerRecip::setting_by_main_contents_category_all;
*setting_by_blocking_contents_category =
  \&Amavis::In::Message::PerRecip::setting_by_blocking_contents_category;
*setting_by_contents_category =
  \&Amavis::In::Message::PerRecip::setting_by_contents_category;

# The order of entries in a per-recipient 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 (without precution)! 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 objects
  my($self) = shift;
  # store a copy of the a given listref of recip objects
  if (@_) { $self->{recips} = [@{$_[0]}] }
  # caller may modify data if he knows what he is doing
  $self->{recips};    # return a list of recipient objects
}

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) = @_;
    $self->per_recip_data([ map {
      my($per_recip_obj) = Amavis::In::Message::PerRecip->new;
      $per_recip_obj->recip_addr($_);
      $per_recip_obj->recip_addr_smtp(qquote_rfc2821_local($_));
      $per_recip_obj->dsn_orcpt(orcpt_encode($per_recip_obj->recip_addr_smtp))
        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} ];
}

# for each header field maintain a list of signature indices which covered it;
# returns a list of signature indices for a given header field position
#
sub header_field_signed_by {
  my($self,$header_field_index) = @_; shift; shift;
  my($h) = $self->{hdr_sig_ind};  my($hf);
  if (@_) {
    $self->{hdr_sig_ind} = $h = []  if !$h;
    $hf = $h->[$header_field_index];
    $h->[$header_field_index] = $hf = []  if !$hf;
    push(@$hf, @_);  # store signature index(es) at a given header position
  }
  $hf = $h->[$header_field_index]  if $h && !$hf;
  $hf ? @{$hf} : ();
}

# return a j-th header field with a given field name, along with its index
# into the array of all header fields; if a field name is undef then all
# header fields are considered; search proceeds top-down if j >= 0,
# or bottom up for negative values (-1=last, -2=next-to-last, ...);
# access to the last header field (j=-1) is optimized and avoids a
# sequential scan; undefined j is equivalent to -1
#
sub get_header_field {
  my($self,$field_name,$j) = @_;
  my($field_ind,$field); my($all_fields) = $self->orig_header;
  $field_name = lc($field_name)  if defined $field_name;
  if (!ref($all_fields)) {
    # no header section
  } elsif (defined($field_name) && (!defined($j) || $j == -1)) {
    # get the last one; this access is commonly used and is quick
    $field_ind = $self->orig_header_fields->{$field_name};
  } elsif ($j >= 0) {  # top-down, 0,1,2,...
    if (!defined($field_name)) {  # directly addressed by a field index
      $field_ind = $j  if $j <= $#$all_fields;
    } else {
      my($ind) = 0; my($cnt) = 0; local($1);
      for my $f (@$all_fields) {
        if ($f =~ /^([^: \t]+)[ \t]*:/s && lc($1) eq $field_name) {
          if ($cnt++ == $j) { $field_ind = $ind; last }
        }
        $ind++;
      }
    }
  } else {  # bottom-up, -1,-2,-3,...
    if (!defined($field_name)) {  # directly addressed by a field index
      $j += @$all_fields;  # turn into an absolute index
      $field_ind = $j  if $j >= 0;
    } else {
      my($cnt) = 0; local($1); $j = -1 - $j;
      for (my $ind = $#$all_fields; $ind >= 0; $ind--) {
        my($f) = $all_fields->[$ind];
        if ($f =~ /^([^: \t]+)[ \t]*:/s && lc($1) eq $field_name) {
          if ($cnt++ == $j) { $field_ind = $ind; last }
        }
      }
    }
  }
  if (defined($field_ind) && wantarray) {
    $field = $all_fields->[$field_ind];
    $field_name = lc($1)  if $field =~ /^([^: \t]+)[ \t]*:/s;
  }
  !wantarray ? $field_ind : ($field_ind, $field_name, $field);
}

sub get_header_field_body {
  my($self,$field_name,$j) = @_;
  my($k);  my($f_i,$f_n,$f) = $self->get_header_field($field_name,$j);
  defined $f && ($k=index($f,':')) >= 0 ? substr($f,$k+1) : $f;
}

1;

#
package Amavis::Out::EditHeader;

# Accumulates instructions on what header fields need to be added
# to a header section, which deleted, or how to change existing ones.
# A call to write_header() then performs these edits on the fly.

use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&hdr);
  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));
}

# now a synonym for append_header_above_received()  (old semantics: prepend
# or append, depending on setting of $append_header_fields_to_bottom)
sub add_header($$$;$) {
  my($self, $field_name, $field_body, $structured) = @_;
  push(@{$self->{addrcvd}}, 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: a field name and a field body;
  # It should return a pair consisting of a replacement field body (no field
  # name and no colon, with or without a trailing NL), and a boolean 'verbatim'
  # (false in its absence). An undefined replacement field body indicates a
  # deletion of the entire header field. A value true in the second returned
  # element indicates that a verbatim replacement is desired (i.e. no other
  # changes are allowed on a replacement body such as folding or encoding).
  !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: multiple header edits: %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 append))
      { unshift(@{$self->{$_}}, @{$other_edits->{$_}})  if $other_edits->{$_} }
    if ($other_edits->{edit}) {
      for (keys %{$other_edits->{edit}})
        { $self->{edit}{$_} = [ @{$other_edits->{edit}{$_}} ] }  # copy list
    }
  }
}

# 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;
  local($1);
  if ($field_name =~ /^ (?: Subject\z | Comments\z |
                            X- (?! Envelope- (?:From|To)\z ) )/six &&
      $field_body !~ /^[\t\n\040-\176]*\z/  # not all printable (or TAB or LF)
  ) {  # encode according to RFC 2047
    # actually RFC 2047 also allows encoded-words in rfc822 extension
    # message header fields (now: optional header fields), within comments
    # in structured header fields, or within 'phrase' (e.g. in From, To, Cc);
    # we are being sloppy here!
    $field_body =~ s/\n(?=[ \t])//gs;  # unfold
    chomp($field_body);
    my($field_body_octets);
    my($chset) = c('hdr_encoding');  my($qb) = c('hdr_encoding_qb');
    if (!$unicode_aware) { $field_body_octets = $field_body }
    else {
      $field_body_octets = safe_encode($chset, $field_body);
#     do_log(5, "hdr - UTF-8 body:  %s", $field_body);
#     do_log(5, "hdr - body octets: %s", $field_body_octets);
    }
    my($encoder_func) = uc($qb) eq 'Q' ? \&q_encode
                                       : \&MIME::Words::encode_mimeword;
    $field_body = join("\n", map { /^[\001-\011\013\014\016-\177]*\z/ ? $_
                                     : &$encoder_func($_,$qb,$chset) }
                                 split(/\n/, $field_body_octets, -1));
  } 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 section to the supplied method (line by line) while adding,
# removing, or changing certain header fields as required, and append an
# empty line (header/body separator). Returns number of original 'Received:'
# header fields to make simple loop detection possible (as required
# by rfc5321 (ex rfc2821) section 6.3).
#
# Assumes input file is properly positioned, leaves it positioned
# at the beginning of a body.
#
sub write_header($$$$) {
  my($self, $msg, $out_fh, $noninitial_submission) = @_;
  my($fix_whitespace_lines) = 0; my($fix_long_header_lines) = 0;
  my($fix_bare_cr) = 0;
  if ($noninitial_submission && c('allow_fixing_improper_header')) {
    $fix_bare_cr = 1;
    $fix_long_header_lines = 1  if c('allow_fixing_long_header_lines');
    $fix_whitespace_lines  = 1  if 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 .= $_ }
  for (@{$self->{addrcvd}}) { $str .= $_ }
  if ($str ne '') { $out_fh->print($str) or die "sending mail header1: $!" }
  if (!defined($msg)) {
    # existing header section empty
  } else {
    local($1,$2); my($curr_head,$next_head); my($eof) = 0;
    my($ill_white_cnt) = 0; my($ill_long_cnt) = 0; my($ill_bare_cr) = 0;
    for (;;) {
      if ($eof) {
        $next_head = "\n";  # fake a missing header/body separator line
      } elsif ($is_mime) {
        if (@header) { $next_head = shift @header }
        else { $eof = 1; $next_head = "\n" }
      } else {
        $! = 0; $next_head = $msg->getline;
        if (!defined($next_head)) {
          $eof = 1; $next_head = "\n";
          $!==0  or die "Error reading mail header section: $!";
        }
      }
      if ($next_head =~ /^[ \t]/) {
        $curr_head .= $next_head;  # folded
      } else {  # new header field
        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 field, but we'll write it anyway
        } else {  # count, edit, or delete
          # obsolete rfc822 syntax allowed whitespace before colon
          my($field_name, $field_body) = ($1, $2);
          my($field_name_lc) = lc($field_name);
          $received_cnt++  if $field_name_lc eq 'received';
          if (exists($self->{edit}{$field_name_lc})) {
            chomp($field_body);
            ### $field_body =~ s/\n(?=[ \t])//gs;  # 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
              my($new_fbody,$verbatim) = &$e($field_name,$field_body);
              if (!defined($new_fbody)) { undef $curr_head; last }  # delete
              $curr_head = $verbatim ? ($field_name . ':' . $new_fbody)
                                     : hdr($field_name, $new_fbody, 0);
              chomp($curr_head); $curr_head .= "\n";
              $curr_head =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s;
              $field_body = $2; chomp($field_body);  # carry to next iteration
            }
          }
        }
        if (defined $curr_head) {
          if ($fix_bare_cr) { # sanitize header sect. by removing CR characters
            $curr_head =~ tr/\r//d  and $ill_bare_cr++;
          }
          if ($fix_whitespace_lines) {  # unfold illegal all-whitespace lines
            $curr_head =~ s/\n(?=[ \t]*\n)//g  and $ill_white_cnt++;
          }
          if ($fix_long_header_lines) {  # truncate long header lines to 998 ch
            $curr_head =~ s{^(.{995}).{4,}$}{$1...}mg  and $ill_long_cnt++;
          }
          $out_fh->print($curr_head) or die "sending mail header2: $!";
        }
        last  if $next_head eq "\n";   # header/body separator
        last  if $next_head =~ /^--/;  # mime separator (missing h/b separator)
        $curr_head = $next_head;
      }
    }
    do_log(0, "INFO: unfolded %d illegal all-whitespace ".
              "continuation lines", $ill_white_cnt)  if $ill_white_cnt;
    do_log(0, "INFO: truncated %d header line(s) longer than 998 characters",
              $ill_long_cnt)  if $ill_long_cnt;
    do_log(0, "INFO: removed bare CR from %d header line(s)",
              $ill_bare_cr)  if $ill_bare_cr;
  }
  $str = '';
  for (@{$self->{append}}) { $str .= $_ }
  $str .= "\n";  # end of header section - a 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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT = qw(&mail_dispatch);
  import Amavis::Conf qw(:platform :confvars c cr ca $relayhost_is_client);
  import Amavis::Util qw(ll do_log dynamic_destination);
}

sub mail_dispatch($$$$;$) {
  my($conn) = shift;
  my($msginfo,$initial_submission,$dsn_per_recip_capable,$filter) = @_;
  my($tmp_hdr_edits);
  my($saved_hdr_edits) = $msginfo->header_edits;
  if ($enable_dkim_signing) {  # add DKIM signatures
    my(@signatures) = Amavis::DKIM::dkim_make_signatures($msginfo,0);
    if (@signatures && !defined($tmp_hdr_edits)) {
      $tmp_hdr_edits = Amavis::Out::EditHeader->new;
      $tmp_hdr_edits->inherit_header_edits($msginfo->header_edits);
    }
    for my $signature (@signatures) {
      my($s) = $signature->as_string;
      local($1); $s =~ s{\015\012}{\n}gs; $s =~ s{\n+\z}{}gs;
      $s =~ s/^((?:DKIM|DomainKey)-Signature):[ \t]*//si;
      $tmp_hdr_edits->prepend_header($1, $s, 2);
    }
    $msginfo->header_edits($tmp_hdr_edits)  if defined $tmp_hdr_edits;
  }
  my($via) = $msginfo->delivery_method;
  if ($via =~ /^(?:smtp|lmtp):/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;
    # 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|lmtp):/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, @_);
      }
    }
  }
  # restore header edits if modified
  $msginfo->header_edits($saved_hdr_edits)  if defined $tmp_hdr_edits;
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&parse_ip_address_from_received &best_try_originator
                  &first_received_from);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Util qw(ll do_log unique_list);
  import Amavis::rfc2821_2822_Tools qw(
                   split_address parse_received fish_out_ip_from_received);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Lookup::IP qw(lookup_ip_acl);
}
use subs @EXPORT_OK;

# Obtain and parse the first entry (oldest) in the 'Received:' header field
# path trace - to be used as the value of a macro %t in customized messages
#
sub first_received_from($) {
  my($msginfo) = @_;
  my($first_received);
  my($fields_ref) =
    parse_received($msginfo->get_header_field_body('received'));  # last
  if (exists $fields_ref->{'from'}) {
    $first_received = join(' ', unique_list(grep { defined }
                                    @$fields_ref{qw(from from-tcp from-com)}));
    do_log(5, "first_received_from: %s", $first_received);
  }
  $first_received;
}


# Try to extract sender's IP address from the Received trace.
# When $search_top_down is true: search top-down, use first valid IP address;
# otherwise, search bottom-up, use the first *public* IP address from the trace
#
use vars qw(@nonhostlocalnetworks_maps @publicnetworks_maps);
sub parse_ip_address_from_received($;$) {
  my($msginfo,$search_top_down) = @_;
  $search_top_down = 0  if !defined $search_top_down;
  @publicnetworks_maps = (
    Amavis::Lookup::Label->new('publicnetworks'),
    Amavis::Lookup::IP->new(qw(
      !0.0.0.0/8 !127.0.0.0/8 !169.254.0.0/16 !:: !::1 !FE80::/10
      !172.16.0.0/12 !192.168.0.0/16 !10.0.0.0/8 !FEC0::/10
      !192.88.99.0/24 !240.0.0.0/4 !224.0.0.0/4 !FF00::/8
      ::FFFF:0:0/96 ::/0)) )  if !@publicnetworks_maps;  # rfc3330, rfc3513
  my($received_from_ip);
  my(@search_list) = $search_top_down ? (0,1)  # the topmost two Received flds
               : (-1,-2,-3,-4,-5,-6);  # bottom-up, first six chronologically
  for my $j (@search_list) {  # walk through a list of Received field indices
    my($r) = $msginfo->get_header_field_body('received',$j);
    last  if !defined $r;
    $received_from_ip = fish_out_ip_from_received($r);
    if ($received_from_ip ne '') {
      last  if $search_top_down;  # any valid address would do
      my($is_public,$fullkey,$err) =
        lookup_ip_acl($received_from_ip,@publicnetworks_maps);
      last  if (!defined($err) || $err eq '') && $is_public;
    }
  }
  do_log(5, "parse_ip_address_from_received: %s", $received_from_ip);
  $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) = @_;
  my($sender_contact,$sender_source);
  $sender_contact = $sender_source = $msginfo->sender;
  my($virusname_list) = $msginfo->virusnames;
  for my $vn (!defined($virusname_list) ? () : @$virusname_list) {
    my($result,$match) = lookup2(0,$vn, ca('viruses_that_fake_sender_maps'));
    if ($result) {  # is a virus known to fake a sender address
      do_log(2,"Virus %s matches %s, sender addr ignored",$vn,$match);
      undef $sender_contact; undef $sender_source;
      # at least try to get some info on sender source from his IP address
      my($first_rcvd_from_ip) = parse_ip_address_from_received($msginfo);
      if ($first_rcvd_from_ip ne '') {
      # $sender_source = '?@' . ip_addr_to_name($first_rcvd_from_ip);
        $sender_source = sprintf('?@[%s]', $first_rcvd_from_ip);
      }
      last;
    }
  }
  ($sender_contact, $sender_source);
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&consumed_bytes);
  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) = @_;
  if (ll(4)) {
    my($perc) = !$avail_quota ? '' : sprintf(", (%.0f%%)",
                  100 * ($avail_quota - ($rem_quota - $bytes)) / $avail_quota);
    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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  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, case sensitive
  { 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 report_type       # a string, e.g. 'delivery-status', rfc3462
  { my($self)=shift; !@_ ? $self->{rep_typ}  : ($self->{rep_typ}=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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @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 cannot 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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&check_header_validity &check_for_banned_names);
  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 lookup2);
}
use subs @EXPORT_OK;

sub check_header_validity($$) {
  my($conn, $msginfo) = @_;
  local($1,$2,$3); my(@bad); my($minor_badh_category) = 0;
  my(%field_head_counts);
  my($allowed_tests) = cr('allowed_header_tests');
  my(%t) = !ref($allowed_tests) ? () : %$allowed_tests;
  # minor category:  2: 8-bit char, 3: NUL/CR control, 4: empty line, 5: long,
  #                  6: syntax, 7: missing, 8: multiple
  for my $curr_head (@{$msginfo->orig_header}) {#array of hdr fields, not lines
    my($field_name,$msg1,$msg2); my($pre,$mid,$post);
    # obsolete rfc822 syntax allowed whitespace before colon
    $field_name = $1  if $curr_head =~ /^([!-9;-\176]+)[ \t]*:/s;
    $field_head_counts{lc($field_name)}++  if defined $field_name;
    if (!defined($field_name) || $field_name =~ /^--/) {
      if ($t{'syntax'}) {
        $msg1 = "Invalid header field syntax";
        $pre = ''; $mid = ''; $post = $curr_head;
        $minor_badh_category = max(6, $minor_badh_category);
      }
    } elsif ($t{'empty'} && $curr_head =~ /^(.*?)^([ \t]+)(?=\n|\z)/gms) {
      $msg1 ="Improper folded header field made up entirely of whitespace";
      $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head));
      # note: using //g and pos to avoid deep recursion in regexp
      $minor_badh_category = max(4, $minor_badh_category);
    } elsif ($t{'long'} &&
             $curr_head =~ /^(.*?)^([^\n]{999,})(?=\n|\z)/gms) {
      $msg1 = "Header line longer than 998 characters";
      $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head));
      $minor_badh_category = max(5, $minor_badh_category);
    } elsif ($t{'control'} && $curr_head =~ /^(.*?)([\000\015])/gs) {
      $msg1 = "Improper use of control character";
      $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head));
      $minor_badh_category = max(3, $minor_badh_category);
    } elsif ($t{'8bit'} && $curr_head =~ /^(.*?)([\200-\377])/gs) {
      $msg1 = "Non-encoded 8-bit data";
      $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head));
      $minor_badh_category = max(2, $minor_badh_category);
    } elsif ($t{'8bit'} && $curr_head =~ /^(.*?)([^\000-\377])/gs) {
      $msg1 = "Non-encoded Unicode character";  # should not happen
      $pre = $1; $mid = $2; $post = substr($curr_head,pos($curr_head));
      $minor_badh_category = max(2, $minor_badh_category);
    }
    if (defined $msg1) {
      chomp($post);
      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 @bad >= 100;         # some sanity limit
  }
  # rfc5322 (ex rfc2822), rfc2045, rfc2183
  for (qw(Date From Sender Reply-To To Cc Bcc Subject Message-ID References
          In-Reply-To MIME-Version Content-Type Content-Transfer-Encoding
          Content-ID Content-Description Content-Disposition Auto-Submitted)) {
    my($n) = $field_head_counts{lc($_)};
    if ($n < 1 && $t{'missing'} && /^(?:Date|From)\z/i) {
      push(@bad, "Missing required header field: \"$_\"");
      $minor_badh_category = max(7, $minor_badh_category);
    } elsif ($n > 1 && $t{'multiple'}) {
      if ($n == 2) {
        push(@bad, "Duplicate header field: \"$_\"");
      } else {
        push(@bad, sprintf('Header field occurs more than once: "%s" '.
                           'occurs %d times', $_, $n));
      }
      $minor_badh_category = max(8, $minor_badh_category);
    }
  }
  if (!@bad)
    { do_log(5,"check_header: %d, OK", $minor_badh_category) }
  elsif (ll(2))
    { do_log(2,"check_header: %d, %s", $minor_badh_category, $_)  for @bad }
  (\@bad, $minor_badh_category);
}

sub check_for_banned_names($) {
  my($msginfo) = @_;
  do_log(3, "Checking for banned types and filenames");
  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 (!$r->bypass_banned_checks) {  # not bypassed
      $any_not_bypassed = 1;
      my($t_ref,$m_ref) = lookup2(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 (?: " (?: \\. | [^"\\] ){0,999} "
                            | [^, ] )+ | [, ]+/gcsx);
            # in principle 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=1  if @tables;
  }
  my($bnpre) = cr('banned_namepath_re');
  $bnpre = $$bnpre  if ref($bnpre) eq 'REF';  # allow one level of indirection
  if (!$any_not_bypassed) {
    do_log(3,"skipping banned check: all recipients bypass banned checks");
  } elsif (!$any_table_in_recip_tables && !ref($bnpre)) {
    do_log(3,"skipping banned check: no applicable lookup tables");
  } else {
    do_log(4,"starting banned checks - traversing message structure tree");
    my($parts_root) = $msginfo->parts_root;
    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);
      # simplified result to be presented in a SMTP response and DSN
      my($simple_part_name) = join(',', @{$descr_trad[-1]});  # just leaf node
      # 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) =
              lookup2(0, [map {@$_} @descr_trad], # check all attribs in one go
                      [map { ref($_) eq 'ARRAY' ? @$_ : $_ } @$t_ref],
                      Label=>"check_bann:$recip");
            $t_ref_old = $t_ref;
          }
          @$e{'found','result','matchk','part_descr','part_name'} =
            (1,$result,$matchingkey,$key_val_trad_str,$simple_part_name)
            if defined $result;
        }
      }
      if (ref $bnpre && grep {!$_->{result}} @recip_tables) {  # any non-true?
        # try new style: banned_namepath_re; it is global, not per-recipient
        my($result,$matchingkey) = lookup2(0, join("\n",@descr), [$bnpre],
                                           Label=>'banned_namepath_re');
        if (defined $result) {
          for my $e (@recip_tables) {
            @$e{'found','result','matchk','part_descr','part_name'} =
              (1,$result,$matchingkey,$key_val_str,$simple_part_name)
              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,$part_name) =
          @$e{'r','recip','result','matchk','part_descr','part_name'};
        if (ll($ll)) {  # only bother with logging when needed
          local($1);
          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    || [];
          push(@$a,$part_descr);  $r->banned_parts($a);
          $a = $r->banning_rule_rhs || [];
          push(@$a,$result);      $r->banning_rule_rhs($a);
          $a = $r->banning_rule_key || [];
          $matchingkey = "$matchingkey";  # make a plain string out of a qr
          push(@$a,$matchingkey); $r->banning_rule_key($a);
          my(@comments) = $matchingkey =~ / \( \? \# \s* (.*?) \s* \) /gsx;
          $a = $r->banning_rule_comment || [];
          push(@$a, @comments ? join(' ',@comments) : $matchingkey);
          $r->banning_rule_comment($a);
          if (!defined($r->banning_reason_short)) {  # just the first
            my($s) = $part_name;
            $s =~ s/[ \t]{6,}/ ... /g;  # compact whitespace
            $s = join(' ',@comments) . ':' . $s  if @comments;
            $r->banning_reason_short($s);
          }
        }
      }
      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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&mime_decode);
  import Amavis::Conf qw(:platform c cr ca $MAXFILES);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(snmp_count untaint ll do_log);
  import Amavis::Unpackers::NewFilename qw(consumed_bytes);
}
use subs @EXPORT_OK;

use Errno qw(ENOENT EACCES);
use IO::File qw(O_CREAT O_EXCL O_WRONLY);
use MIME::Parser;
use MIME::Words;

# 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;
      # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
      $outpart->open($newpart, untaint(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==0;
      }
      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 (defined($size) && $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]);
    $part->attributes_add('U','C')  if $mt =~ m{/encrypted}i ||
                                       $et =~ m{/encrypted}i;
    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;
    $val = $head->mime_attr('content-type.report-type');
    $part->report_type($val)  if $val ne '';
  }
  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 a 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
  # if bounce killer is enabled, extract_nested_messages must be off,
  # otherwise we lose headers of attached message/rfc822 messages
  $parser->extract_nested_messages(0);
# $parser->extract_nested_messages("NEST");  # parse embedded message/rfc822
    # "NEST" complains with "part did not end with expected boundary" when
    # the outer message is message/partial and the inner message is chopped
  $parser->extract_uuencode(1);              # to enable or not to enable ???
  $parser->max_parts($MAXFILES)  if $MAXFILES > 0;
  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->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 '';
  } elsif (!defined($entity)) {
    $mime_err = "Unable to parse, perhaps message contains too many parts";
    do_log(1, "WARN: MIME::Parser %s", $mime_err);
    $entity = '';
  }
  mime_traverse($entity, $tempdir, $parent_obj, 0, '1')  if $entity;
  section_time('mime_decode');
  ($entity, $mime_err);
}

1;

#
package Amavis::MIME::Body::OnOpenFh;

# A body class that keeps data on an open file handle, read-only,
# while allowing to prepend a couple of lines when reading from it.
# $skip_bytes bytes at the beginning of a given open file are ignored.

use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter MIME::Body);  # subclass of MIME::Body
  import Amavis::Util qw(ll do_log);
}

sub init {
  my($self, $fh,$prefix_lines,$skip_bytes) = @_;
  $self->{MB_Am_fh} = $fh;
  $self->{MB_Am_prefix} = defined $prefix_lines ? join('',@$prefix_lines) : '';
  $self->{MB_Am_prefix_l} = length($self->{MB_Am_prefix});
  $self->{MB_Am_skip_bytes} = !defined $skip_bytes ? 0 : $skip_bytes;
  $self->is_encoded(1);
  $self;
}

sub open {
  my($self,$mode) = @_;
  $mode eq 'r' or die "Only offers read-only access, mode: $mode";
  my($fh) = $self->{MB_Am_fh}; my($skip) = $self->{MB_Am_skip_bytes};
  $fh->seek($skip,0) or die "Can't rewind mail file: $!";
  $self->{MB_Am_pos} = 0;
  bless { parent => $self };
}

sub close { 1 }

sub read {  # SCALAR,LENGTH,OFFSET
  my($self) = shift; my($len) = $_[1]; my($offset) = $_[2];
  my($parent) = $self->{parent}; my($pos) = $parent->{MB_Am_pos};
  my($str1) = ''; my($str2) = ''; my($nbytes) = 0;
  if ($len > 0 && $pos < $parent->{MB_Am_prefix_l}) {
    $str1 = substr($parent->{MB_Am_prefix}, $pos, $len);
    $nbytes += length($str1); $len -= $nbytes;
  }
  my($msg);  $! = 0;
  if ($len > 0) {
    my($nb) = $parent->{MB_Am_fh}->read($str2,$len);
    if (!defined $nb) {
      $msg = "Error reading: $!";
    } elsif ($nb < 1) {
      # read returns 0 at eof
    } else {
      $nbytes += $nb; $len -= $nb;
    }
  }
  if (defined $msg) {
    undef $nbytes;  # $! already set by a failed read
  } else {
    ($offset ? substr($_[0],$offset) : $_[0]) = $str1.$str2;
    $pos += $nbytes; $parent->{MB_Am_pos} = $pos;
  }
  $nbytes;   # eof: 0;  error: undef
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&delivery_status_notification &delivery_short_report
                  &build_mime_entity &defanged_mime_entity
                  &msg_from_quarantine &expand_variables);
  import Amavis::Util qw(ll do_log safe_encode sanitize_str
                         orcpt_decode xtext_decode ccat_split ccat_maj);
  import Amavis::Timing qw(section_time);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Out::EditHeader qw(hdr);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Expand qw(expand);
  import Amavis::rfc2821_2822_Tools;
}
use subs @EXPORT_OK;

use MIME::Entity;
use Time::HiRes ();
# use Encode;  # Perl 5.8  UTF-8 support

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

# Create a MIME::Entity object. If $mail_as_string_ref points to a string
# (multiline mail header with a plain text body) it is added as the first
# MIME part. Optionally attach a message header section from original mail,
# or attach a complete original message.
#
sub build_mime_entity($$$$$$) {
  my($mail_as_string_ref, $msginfo, $mime_type, $flat,
     $attach_orig_headers, $attach_orig_message) = @_;
  if (!defined $mime_type || $mime_type !~ m{^multipart(/|\z)}i) {
    my($multipart_cnt) = 0;
    $multipart_cnt++  if $mail_as_string_ref;
    $multipart_cnt++  if defined $msginfo &&
                        ($attach_orig_headers || $attach_orig_message);
    $mime_type = 'multipart/mixed'  if $multipart_cnt > 1;
  }
  my($entity,$m_hdr,$m_body);
  if (!$mail_as_string_ref) {
    # no plain text part
  } elsif (substr($$mail_as_string_ref, 0,1) eq "\n") { # empty header section?
    $m_hdr = ''; $m_body = substr($$mail_as_string_ref,1);
  } else {
    # calling index and substr is much faster than an equiv. split into $1,$2
    # by a regular expression: /^( (?!\n) .*? (?:\n|\z))? (?: \n (.*) )? \z/sx
    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 section 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)  if defined $m_body;
  # make sure _our_ source line number is reported in case of failure
  my($multipart_cnt) = 0;
  eval {
    my($nxmh) = c('notify_xmailer_header');
    $entity = MIME::Entity->build(
      defined $nxmh && $nxmh eq '' ? ()  # leave the MIME::Entity default
        : ('X-Mailer' => $nxmh),         # X-Mailer hdr or undef
      Type => defined $mime_type ? $mime_type : 'multipart/mixed',
      Encoding => '7bit',
    );  1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die $eval_stat;
  };
  if (defined $m_hdr) {  # insert header fields into MIME::Head entity
    # Mail::Header::modify allows all-or-nothing control over automatic header
    # fields 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.
    local($1,$2);
    my($head) = $entity->head;  $head->modify(0);
    $m_hdr =~ s/\r?\n(?=[ \t])//gs;  # unfold header fields in a template
    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, "build_mime_entity %s: %s", $fhead,$fbody);
        eval {  # make sure _our_ source line number is reported on failure
          $head->replace($fhead,$fbody);  1;
        } or do {
          $@ = "errno=$!"  if $@ eq '';  chomp $@;
          die $@  if $@ =~ /^timed out\b/;  # resignal timeout
          die sprintf("%s header field '%s: %s'",
                      ($@ eq '' ? "invalid" : "$@, "), $fhead,$fbody);
        };
      }
    }
  }
  my(@prefix_lines);
  if (defined $m_body) {
    if ($flat && $attach_orig_message) {
      my($pos,$j);  # split $m_body into lines, retaining each \n
      for ($pos=0; ($j=index($m_body,"\n",$pos)) >= 0; $pos = $j+1)
        { push(@prefix_lines, substr($m_body,$pos,$j-$pos+1)) }
      push(@prefix_lines, substr($m_body,$pos))  if $pos < length($m_body);
    } else {
      eval {  # make sure _our_ source line number is reported on failure
        $entity->attach(
          Type => 'text/plain', Data => $m_body,
          Encoding => '-SUGGEST', Charset => c('bdy_encoding'),
        );  $multipart_cnt++; 1;
      } or do {
        my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        die $eval_stat;
      };
    }
  }
  # prepend a Return-Path to make available the envelope sender address
  push(@prefix_lines, "\n")  if @prefix_lines;  # separates text from a message
  push(@prefix_lines, sprintf("Return-Path: %s\n",$msginfo->sender_smtp));
  if (defined($msginfo) && $attach_orig_message) {
    do_log(4, "build_mime_entity: attaching entire original message");
    my($orig_mail_as_body) =
      Amavis::MIME::Body::OnOpenFh->new($msginfo->mail_text,
                                        \@prefix_lines, $msginfo->skip_bytes);
    $orig_mail_as_body  or die "Can't create a MIME::Body object: $!";
    eval {  # make sure _our_ source line number is reported on failure
      my($att) = $entity->attach(  # rfc2046
        Type => $flat ? 'text/plain' : 'message/rfc822',
        Encoding => ($msginfo->header_8bit || $msginfo->body_8bit) ?
                     '8bit' : '7bit',
        Data => [],  # Path => $msginfo->mail_text_fn,
        $flat ? () : (Disposition => 'attachment', Filename => 'message',
                      Description => 'Original message'),
      );
      $att->bodyhandle($orig_mail_as_body);  # direct access to tempfile handle
      $multipart_cnt++; 1;
    } or do {
      my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      die $eval_stat;
    };
  } elsif (defined($msginfo) && $attach_orig_headers) {
    do_log(4, "build_mime_entity: attaching original header section");
    eval {  # make sure _our_ source line number is reported on failure
      $entity->attach(
        Type => $flat ? 'text/plain' : 'text/rfc822-headers',  # rfc3462
        Encoding => $msginfo->header_8bit ? '8bit' : '7bit',
        Data => [@prefix_lines, @{$msginfo->orig_header}],
        Disposition => 'inline',  Filename => 'header',
        Description => 'Message header section',
      );  $multipart_cnt++; 1;
    } or do {
      my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      die $eval_stat;
    };
  }
  $entity->make_singlepart  if $multipart_cnt < 2;
  $entity;  # return the constructed MIME::Entity
}

# If $msg_format is 'dsn' generate a delivery status notification according
# to rfc3462 (ex rfc1892), rfc3464 (ex rfc1894) and rfc3461 (ex rfc1891).
# If $msg_format is 'arf' generate a generate an abuse report according to
# draft-shafranovich-feedback-report-04 - "An Extensible Format for Email
# Feedback Reports". If $msg_format is 'attach', generate a report message
# and attach the original message. If $msg_format is 'plain', generate a
# simple (flat) mail with the only MIME part being the original message
# (abuse@yahoo.com can't currently handle attachments in reports).
# Returns a message object, or undef if DSN is requested but not needed.
#   $request_type:  dsn, release, requeue, report
#   $msg_format:    dsn, arf, attach, plain, resend
#   $feedback_type: abuse, fraud, miscategorized, not-spam, opt-out,
#                   opt-out-list, virus, other (according to ARF draft)
#
sub delivery_status_notification($$$$;$$$$) {  # ..._or_report
  my($conn,$msginfo,$dsn_per_recip_capable,$builtins_ref,
     $notif_recips,$request_type,$feedback_type,$msg_format) = @_;
  my($notification); my($suppressed) = 0;
  if (!defined($msg_format)) {
    $msg_format = $request_type eq 'dsn'    ? 'dsn'
                : $request_type eq 'report' ? c('report_format')
                                            : c('release_format');
  }
  my($is_arf) = 0; my($is_dsn) = 0; my($is_attach) = 0; my($is_plain) = 0;
  if    ($msg_format eq 'dsn')    { $is_dsn = 1 }
  elsif ($msg_format eq 'arf')    { $is_arf = 1 }
  elsif ($msg_format eq 'attach') { $is_attach = 1 }
  else                            { $is_plain = 1 }  # 'plain'
  my($dsn_time) = $msginfo->rx_time;  # time of dsn creation - same as message
    # use a reception time for consistency and to be resilient to clock jumps
  $dsn_time = Time::HiRes::time  if !defined($dsn_time) || $dsn_time==0;  # now
  my($rfc2822_dsn_time) = rfc2822_timestamp($dsn_time);
  my($sender) = $msginfo->sender;
  my($dsn_passed_on) = $msginfo->dsn_passed_on;  # NOTIFY=SUCCESS passed to MTA
  my($delivery_method) = $msginfo->delivery_method;
  my($per_recip_data) = $msginfo->per_recip_data;
  my($txt_recip) = '';   # per-recipient part of dsn text according to rfc3464
  my($all_rejected) = 0;
  if (@$per_recip_data) {
    $all_rejected = 1;
    for my $r (@$per_recip_data) {
      if ($r->recip_destiny != D_REJECT || $r->recip_smtp_response !~ /^5/)
        { $all_rejected = 0; last }
    }
  }
  my($spam_level) = $msginfo->spam_level;
  my($is_credible) = $msginfo->sender_credible || '';
  my($os_fingerprint) = $msginfo->client_os_fingerprint;
  my($cutoff_byrecip_maps, $cutoff_bysender_maps);
  my($dsn_cutoff_level_bysender, $dsn_cutoff_level);
  if ($is_dsn && $sender ne '') {
    # for null sender it doesn't matter, as DSN will not be sent regardless
    if ($is_credible) {
      do_log(3, "DSN: sender is credible (%s), SA: %.3f, <%s>",
                $is_credible,$spam_level,$sender);
      $cutoff_byrecip_maps  = ca('spam_crediblefrom_dsn_cutoff_level_maps');
      $cutoff_bysender_maps =
                     ca('spam_crediblefrom_dsn_cutoff_level_bysender_maps');
    } else {
      do_log(5, "DSN: sender NOT credible, SA: %.3f, <%s>",
                $spam_level,$sender);
      $cutoff_byrecip_maps  = ca('spam_dsn_cutoff_level_maps');
      $cutoff_bysender_maps = ca('spam_dsn_cutoff_level_bysender_maps');
    }
    $dsn_cutoff_level_bysender = lookup2(0,$sender,$cutoff_bysender_maps);
  }
  my($any_succ,$any_fail,$any_delayed) = (0,0,0); local($1);
  for my $r (!$is_dsn ? () : @$per_recip_data) {  # prepare per-recip fields
    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) = $r->setting_by_contents_category(\%ccat_display_names);
    $ccat_name = "NonBlocking:$ccat_name"  if !defined($r->blocking_ccat);
    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, mta_resp: \"%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, $smtp_resp);
    # 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) {
      $suppressed = 1;
      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) = $dest==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
      $suppressed = 1;
      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 ($dest==D_DISCARD) {  # requested by final_*_destiny
      $suppressed = 1;
      do_log(4, "DSN: FILTER %s %s %s, destiny=DISCARD: <%s> -> <%s>",
                $remote_or_local,$smtp_resp_code,$ccat_name,$sender,$recip);
    } elsif (defined $r->dsn_suppress_reason) {
      $suppressed = 1;
      do_log(3, "DSN: FILTER %s %s, %s <%s> -> <%s>",
                $smtp_resp_code,$ccat_name, $r->dsn_suppress_reason,
                $sender,$recip);
    } elsif (!defined($msginfo->sender_contact)) {  # faked sender most likely
      $suppressed = 1;
      do_log(3, "DSN: FILTER %s %s, %s <%s> -> <%s>",
                $smtp_resp_code,$ccat_name, '(faked?)', $sender,$recip);
    } elsif (defined($dsn_cutoff_level_bysender) &&
             ($spam_level+$boost >= $dsn_cutoff_level_bysender)) {
      $suppressed = 1;
      do_log(3, "DSN: FILTER %s %s, spam level %.3f exceeds cutoff %s%s, ".
                "<%s> -> <%s>", $smtp_resp_code, $ccat_name,
                $spam_level+$boost, $dsn_cutoff_level_bysender,
                !$is_credible ? '' : ", (credible: $is_credible)",
                $sender, $recip);
    } elsif (defined($cutoff_byrecip_maps) &&
             ( $dsn_cutoff_level=lookup2(0,$recip,$cutoff_byrecip_maps),
               defined($dsn_cutoff_level) &&
               ( $spam_level+$boost >= $dsn_cutoff_level ||
                 ( $r->recip_blacklisted_sender &&
                  !$r->recip_whitelisted_sender) )
              ) ) {
      $suppressed = 1;
      do_log(3, "DSN: FILTER %s %s, spam level %.3f exceeds ".
                "by-recipient cutoff %s%s, <%s> -> <%s>",
                $smtp_resp_code, $ccat_name,
                $spam_level+$boost, $dsn_cutoff_level,
                !$is_credible ? '' : ", (credible: $is_credible)",
                $sender, $recip);
    } elsif (defined($msginfo->is_bulk) &&
             ccat_maj($r->contents_category) > CC_CLEAN) {
      $suppressed = 1;
      do_log(3, "DSN: FILTER %s %s, suppressed, bulk mail (%s), <%s> -> <%s>",
                $smtp_resp_code,$ccat_name,$msginfo->is_bulk,$sender,$recip);
    } elsif ($os_fingerprint =~ /^Windows\b/ &&   # hard-coded limits!
             !$msginfo->dkim_envsender_sig   &&   # a hack
             $spam_level+$boost >=
               ($os_fingerprint=~/^Windows XP(?![^(]*\b2000 SP)/ ? 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) {
        my($addr_type,$orcpt) = orcpt_decode($dsn_orcpt);
        $txt_recip .= "Original-Recipient: " .
                      sanitize_str($addr_type.';'.$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=1 }
      elsif ($action eq 'delayed') { $any_delayed=1 } else { $any_succ=1 }
      $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(" 554 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_dsn_time\n";
      $txt_recip .= sprintf("Final-Log-ID: %s/%s\n",
                            $msginfo->log_id, $msginfo->mail_id);
      do_log(2, "DSN: NOTIFICATION: Action:%s, %s %s %s, spam level %.3f, ".
                "<%s> -> <%s>",  $action,
                $recip_done==2 && $action ne 'delayed' ? 'RELAYED' : 'LOCAL',
                $smtp_resp_code, $ccat_name, $spam_level+$boost,
                $sender, $recip);
    }
  }  # endfor per_recip_data
  if ( $is_arf || $is_plain || $is_attach ||
      ($is_dsn && ($any_succ || $any_fail || $any_delayed)) ) {
    my(@hdr_to) = defined $notif_recips ? qquote_rfc2821_local(@$notif_recips)
                                : map { $_->recip_addr_smtp } @$per_recip_data;
    my($hdr_from) = $msginfo->setting_by_contents_category(
                              $is_dsn ? cr('hdrfrom_notify_sender_by_ccat') :
            $request_type eq 'report' ? cr('hdrfrom_notify_report_by_ccat') :
                                        cr('hdrfrom_notify_release_by_ccat') );
    $hdr_from = expand_variables($hdr_from);
    # use the provided template text
    my(%mybuiltins) = %$builtins_ref;  # make a local copy
    # not really needed, these header fields are overridden later
    $mybuiltins{'f'} = $hdr_from;
    $mybuiltins{'T'} = \@hdr_to;
    $mybuiltins{'d'} = $rfc2822_dsn_time;
    $mybuiltins{'report_format'} = $msg_format;
    $mybuiltins{'feedback_type'} = $feedback_type;

    # rfc3461 section 6.2: "If a DSN contains no notifications of
    # delivery failure, the MTA SHOULD return only the header section."
    my($dsn_ret) = $msginfo->dsn_ret;
    my($attach_full_msg) =
      !$is_dsn ? 1 : (defined $dsn_ret && $dsn_ret eq 'FULL' && $any_fail);
    if ($attach_full_msg && $is_dsn) {
      # 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 a header section",
                $dsn_ret);
      $attach_full_msg = 0;  # override, just attach a header section
    }
    my($template_ref) = $msginfo->setting_by_contents_category(
                                $is_dsn ? cr('notify_sender_templ_by_ccat') :
              $request_type eq 'report' ? cr('notify_report_templ_by_ccat') :
                                          cr('notify_release_templ_by_ccat') );
    my($report_str_ref) = expand($template_ref, \%mybuiltins);
    my($report_entity) = build_mime_entity($report_str_ref,$msginfo,
      $is_dsn ? 'multipart/report; report-type=delivery-status' :
      $is_arf ? 'multipart/report; report-type=feedback-report' :
                'multipart/mixed',
      $is_plain, 1, $attach_full_msg);
    my($head) = $report_entity->head;
    # rfc3464: The From field of the message header section 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', $hdr_from); 1 }
      or do { chomp $@; die $@ };
    eval { $head->replace('To', join(', ',@hdr_to)); 1 }
      or do { chomp $@; die $@ };
    eval { $head->replace('Date', $rfc2822_dsn_time); 1 }
      or do { chomp $@; die $@ };

    my($dsn_envid) = $msginfo->dsn_envid;  # ENVID is encoded as xtext: rfc3461
    $dsn_envid = sanitize_str(xtext_decode($dsn_envid))  if defined $dsn_envid;
    my($txt_msg) = '';  # per-message part of a report
    if ($is_arf) {  # abuse report format
      # abuse, fraud, miscategorized, not-spam, opt-out, opt-out-list,
      # virus, other, dkim (draft-kucherawy-dkim-reporting)
      $txt_msg .= "Feedback-Type: $feedback_type\n";
      $txt_msg .= "Version: 0.1\n";
      $txt_msg .= "Reporting-MTA: dns; " . c('myhostname') . "\n";
      $txt_msg .= "User-Agent: $myproduct_name\n";
      $txt_msg .= "Arrival-Date: ". rfc2822_timestamp($msginfo->rx_time) ."\n";
      $txt_msg .= "Source-IP: " . $msginfo->client_addr . "\n"
        if defined $msginfo->client_addr;
      if ($enable_dkim_verification) {
        for my $h (Amavis::DKIM::generate_authentication_results($msginfo))
          { $txt_msg .= "Authentication-Results: $h\n" }
      }
      $txt_msg .= "Original-Envelope-Id: $dsn_envid\n"  if defined $dsn_envid;
      $txt_msg .= "Original-Mail-From: " . $msginfo->sender_smtp . "\n";
      for my $r (@$per_recip_data)
        { $txt_msg .= "Original-Rcpt-To: " . $r->recip_addr_smtp . "\n" }
#     draft-kucherawy-dkim-reporting: DKIM-Identity, DKIM-Selector,
#       DKIM-Canonicalized-Headers, DKIM-Canonicalized-Body,
#       DKIM-Failure: bodyhash, granularity, revoked, signature, ssp(adsp)
    } elsif ($is_dsn) {  # DSN - per-msg part of dsn text according to rfc3464
      my($from_mta) = $conn->smtp_helo;
      my($client_ip) = $conn->client_ip;
      $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";
      $txt_msg .= "Original-Envelope-Id: $dsn_envid\n"  if defined $dsn_envid;
    }
    if ($is_dsn || $is_arf) {  # attach a delivery-status or a feedback-report
      eval {  # make sure our source line number is reported in case of failure
        $report_entity->add_part(
          MIME::Entity->build(Top => 0,
            Type => $is_dsn ? 'message/delivery-status'
                            : 'message/feedback-report',
            Encoding => '7bit',  Disposition => 'inline',
            Filename => $is_arf ? 'arf_status' : 'dsn_status',
            Description => $is_arf      ? "\u$feedback_type report" :
                           $any_fail    ? 'Delivery error report' :
                           $any_delayed ? 'Delivery delay report' :
                                          'Delivery report',
            Data => $txt_msg.$txt_recip),
          1);  # insert as a second mime part (at offset 1)
        1;
      } or do {
        my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        die $eval_stat;
      };
    }
    my($mailfrom) = $is_dsn ? ''  # DSN envelope sender must be empty
                 : unquote_rfc2821_local( (parse_address_list($hdr_from))[0] );
    $notification = Amavis::In::Message->new;
    $notification->rx_time($dsn_time);
    $notification->log_id($msginfo->log_id);
    $notification->partition_tag($msginfo->partition_tag);
    $notification->conn_obj($msginfo->conn_obj);
    $notification->originating(1);
  # $notification->body_type('7BIT');
    $notification->mail_text($report_entity);
    $notification->delivery_method(c('notify_method'));
    $notification->sender($mailfrom);
    $notification->sender_smtp(qquote_rfc2821_local($mailfrom));
    $notification->auth_submitter('<>');
    $notification->auth_user(c('amavis_auth_user'));
    $notification->auth_pass(c('amavis_auth_pass'));
    if (defined $hdr_from) {
      my(@rfc2822_from) = map { unquote_rfc2821_local($_) }
                              parse_address_list($hdr_from);
      $notification->rfc2822_from($rfc2822_from[0]);
    }
    my($bcc) = $msginfo->setting_by_contents_category(cr('dsn_bcc_by_ccat'));
    $notification->recips([(defined $notif_recips ? @$notif_recips
                              : map { $_->recip_addr } @$per_recip_data),
                            defined $bcc && $bcc ne '' ? $bcc : () ], 1);
  }
  # $suppressed is true if DNS would be needed, but either the sender requested
  #   that DSN is not to be sent, or it is believed the bounce would not reach
  #   the correct sender (faked sender with viruses or spam);
  # $notification is undef if DSN is not needed
  ($notification,$suppressed);
}

# Return a triple of arrayrefs of quoted recipient addresses (the first lists
# recipients with successful delivery status, the second lists 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);
  eval {  # make sure _our_ source line number is reported in case of failure
    my($nxmh) = c('notify_xmailer_header');
    $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 {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die $eval_stat;
  };
  # 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 Organisation User-Agent X-Mailer
          DKIM-Signature DomainKey-Signature))
    { $desired_field{lc($_)} = 1 };
  local($1,$2);
  for my $curr_head (@{$msginfo->orig_header}) {  # array of header fields
    # 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;
      $field_body =~ s{^(.{995}).{4,}$}{$1...}mg;  # truncate lines to 998
      chomp($field_body);    # note that field body is already folded
      if (lc($field_name) eq 'subject') {
        # needs to be inserted directly into new header section so that it
        # can be subjected to header edits, like inserting ***UNCHECKED***
        eval { $new_entity->head->add($field_name,$field_body); 1 }
          or do {chomp $@; die $@};
      } else {
        $hdr_edits->append_header($field_name,$field_body,2);
      }
    }
  }
  eval {
    $new_entity->attach(
      Type => 'text/plain',
      Encoding => '-SUGGEST', Charset => c('bdy_encoding'),
      Data => $first_part);
    1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die $eval_stat;
  };
  # prepend a Return-Path to make available the envelope sender address
  my($rp) = sprintf("Return-Path: %s\n",$msginfo->sender_smtp);
  my($orig_mail_as_body) =
    Amavis::MIME::Body::OnOpenFh->new($msginfo->mail_text,
                                      [$rp], $msginfo->skip_bytes);
  $orig_mail_as_body  or die "Can't create a MIME::Body object: $!";
  eval {
    my($att) = $new_entity->attach(  # rfc2046
      Type => 'message/rfc822; x-spam-type=original',
      Encoding =>($msginfo->header_8bit || $msginfo->body_8bit) ?'8bit':'7bit',
      Data => [],  # Path => $msginfo->mail_text_fn,
      Description => 'Original message',
      Filename => 'message', Disposition => 'attachment',
    );
    $att->bodyhandle($orig_mail_as_body);  # direct access to tempfile handle
    1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die $eval_stat;
  };
  $new_entity;
}

# Fill-in message object information based on a quarantined mail.
# Expects $msginfo->mail_text to be a file handle (not a Mime::Entity object),
# leaves it positioned at the beginning of a mail body (not to be relied upon).
# If given a BSMTP file, expects that it contains a single message only.
#
sub msg_from_quarantine($$$$) {
  my($conn,$msginfo,$request_type,$feedback_type) = @_;
  my($fh) = $msginfo->mail_text;
  my($sender_override) = $msginfo->sender;
  my($recips_data_override) = $msginfo->per_recip_data;
  my($quarantine_id) = $msginfo->mail_id;
  my($reporting) = $request_type eq 'report';
  my($release_m);
  if ($request_type eq 'requeue') {
    $release_m = c('requeue_method');
    $release_m ne '' or die "requeue_method is unspecified";
  } else {  # 'release' or 'report'
    $release_m = c('release_method');
    $release_m = c('notify_method')  if $release_m eq '';
    $release_m ne '' or die "release_method and notify_method are unspecified";
  }
  $msginfo->originating(0);  # let's make it explicit; disables DKIM signing
  $msginfo->delivery_method($release_m);
  $msginfo->auth_submitter('<>');
  $msginfo->auth_user(c('amavis_auth_user'));
  $msginfo->auth_pass(c('amavis_auth_pass'));
  $fh->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!";
  my($bsmtp) = 0;  # message stored in a RFC2442 format?
  my($qid,$sender,@recips_all,@recips_blocked);
  my($have_recips_blocked) = 0; my($curr_head);
  my($ln); my($eof) = 0; my($position) = 0;
  my($offset_bytes) = 0;  # file position just past the prefixed header fields
  # extract envelope information from the quarantine file
  do_log(4, "msg_from_quarantine: releasing %s", $quarantine_id);
  for (;;) {
    if ($eof) { $ln = "\n" }
    else {
      $! = 0; $ln = $fh->getline;
      if (!defined($ln)) {
        $eof = 1; $ln = "\n";  # fake a missing header/body separator line
        $!==0  or die "Error reading file ".$msginfo->mail_text_fn.": $!";
      }
    }
    if ($ln =~ /^[ \t]/) { $curr_head .= $ln }
    else {
      my($next_head) = $ln; local($1,$2);
      local($_) = $curr_head;  chomp;  s/\n(?=[ \t])//gs;  # 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_all, unquote_rfc2821_local($1));
      } elsif ( $bsmtp && /^(DATA|NOOP)$/i) {
      } elsif ( $bsmtp && /^RSET$/i) {
        undef $sender; @recips_all = (); @recips_blocked = (); undef $qid;
      } elsif ( $bsmtp && /^QUIT$/i) { last;
      } elsif (!$bsmtp && /^Return-Path:[ \t]*(.*)$/si) {
      } elsif (!$bsmtp && /^Delivered-To:[ \t]*(.*)$/si) {
      } elsif (!$bsmtp && /^X-Envelope-From:[ \t]*(.*)$/si) {
        if (!defined $sender) {
          my(@addr_list) = parse_address_list($1);
          @addr_list >= 1  or die "Address missing in X-Envelope-From";
          @addr_list <= 1  or die "More than one address in X-Envelope-From";
          $sender = unquote_rfc2821_local($addr_list[0]);
        }
      } elsif (!$bsmtp && /^X-Envelope-To:[ \t]*(.*)$/si) {
        my(@addr_list) = parse_address_list($1);
        push(@recips_all, map { unquote_rfc2821_local($_) } @addr_list);
      } elsif (!$bsmtp && /^X-Envelope-To-Blocked:[ \t]*(.*)$/si) {
        my(@addr_list) = parse_address_list($1);
        push(@recips_blocked, map { unquote_rfc2821_local($_) } @addr_list);
        $have_recips_blocked = 1;
      } elsif (/^X-Quarantine-ID:[ \t]*(.*)$/si) {
        $qid = $1;   $qid = $1 if $qid =~ /^<(.*)>\z/s;
      } elsif (!$reporting &&
               /^X-Amavis-(?:Hold|Alert|Modified|PenPals|PolicyBank):/si) {
        # skip (but not X-Amavis-OS-Fingerprint or Authentication-Results)
      } elsif (!$reporting &&
               /^X-Spam- (?:
                 Flag|Score|Level|Status|Report|Tests|Checker-Version):/six) {
        # skip header fields inserted by us
      } else {
        last;  # end of known header fields, marked as 'skip_bytes'
      }
      last  if $next_head eq "\n";  # end-of-header-section reached
      $offset_bytes = $position;    # move past last processed header field
      $curr_head = $next_head;
    }
    $position += length($ln);
  }
  @recips_blocked = @recips_all  if !$have_recips_blocked; # pre-2.6.0 compatib
  my(@except);
  if (@recips_blocked < @recips_all) {
    for my $rec (@recips_all)
      { push(@except,$rec)  if !grep { $rec eq $_ } @recips_blocked }
  }
  my($sender_smtp) = qquote_rfc2821_local($sender);
  do_log(0,"Quarantined message %s (%s): %s %s -> %s%s",
           $request_type, $feedback_type, $quarantine_id, $sender_smtp,
           join(',', qquote_rfc2821_local(@recips_blocked)),
           !@except ? '' : (", (excluded: ".
                            join(',', qquote_rfc2821_local(@except)) . " )" ));
  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 or Return-Path'))
    if !defined $sender;
  push(@m, 'missing '.($bsmtp?'RCPT TO'  :'X-Envelope-To'))  if !@recips_all;
  do_log(0, "Quarantine %s %s: %s",
            $request_type, $quarantine_id, join("; ",@m))  if @m;
  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 de-stuffing not implemented)" }
  $msginfo->sender($sender); $msginfo->sender_smtp($sender_smtp);
  $msginfo->recips(\@recips_all);
  # mark a file location past prefixed header fields where orig message starts
  $msginfo->skip_bytes($offset_bytes);

  my($msg_format) = $request_type eq 'dsn'    ? 'dsn'
                  : $request_type eq 'report' ? c('report_format')
                                              : c('release_format');
  my($hdr_edits) = Amavis::Out::EditHeader->new;
  $msginfo->header_edits($hdr_edits);
  if ($msg_format ne 'resend') {
    # collect more information from a quarantined message, making it available
    # to a report generator and to macros during template expansion
    Amavis::get_body_digest($msginfo, 'MD5');
    Amavis::collect_some_info($msginfo);
    my($notification,$suppressed) = delivery_status_notification(
      $conn, $msginfo, 0, \%Amavis::builtins,
      !defined($recips_data_override) ? \@recips_blocked
        : [ map { $_->recip_addr } @$recips_data_override ],
      $request_type, $feedback_type, undef);
    # push original quarantined message into an attachment of a notification
    $msginfo = $notification;
  }
  if (defined $sender_override) {
    # sender specified in the request, overrides stored info
    do_log(5, "overriding sender %s by %s", $sender, $sender_override);
    $msginfo->sender($sender_override);
    $msginfo->sender_smtp(qquote_rfc2821_local($sender_override));
  }
  if (!defined($recips_data_override)) {
    $msginfo->recips(\@recips_blocked);  # override 'all' by 'blocked'
  } else {  # recipients specified in the request override stored info
    ll(5) && do_log(5, "overriding recips %s by %s",
                join(',', qquote_rfc2821_local(@recips_blocked)),
                join(',', map { $_->recip_addr_smtp } @$recips_data_override));
    $msginfo->per_recip_data($recips_data_override);
  }
  if ($msg_format eq 'resend') { # keep quarantined message at a top MIME level
    # 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->add_header('Resent-From', $hdrfrom_recip);
    } else {
      $hdr_edits->add_header('Resent-From',
                             qquote_rfc2821_local($msginfo->requested_by));
      $hdr_edits->add_header('Resent-Sender',
                             $hdrfrom_recip)  if $hdrfrom_recip ne '';
    }
    my($prd) = $msginfo->per_recip_data;
    $hdr_edits->add_header('Resent-To',
                           $prd && @$prd==1 ? $prd->[0]->recip_addr_smtp
                                            : 'undisclosed-recipients:;');
    $hdr_edits->add_header('Resent-Date', # time of the release
                  rfc2822_timestamp($msginfo->rx_time));
    $hdr_edits->add_header('Resent-Message-ID',
                  sprintf('<QRR%s@%s>', $msginfo->mail_id, c('myhostname')) );
  }
  $hdr_edits->add_header('Received',
            make_received_header_field($conn,$msginfo,$msginfo->mail_id,1), 1);
  my($bcc) = $msginfo->setting_by_contents_category(cr('always_bcc_by_ccat'));
  if (defined $bcc && $bcc ne '' && $request_type ne 'report') {
    my($recip_obj) = Amavis::In::Message::PerRecip->new;
    # leave recip_addr and recip_addr_smtp undefined!
    $recip_obj->recip_addr_modified($bcc);
    $recip_obj->recip_destiny(D_PASS);
    $recip_obj->dsn_notify(['NEVER']);
    $recip_obj->contents_category(CC_CLEAN);
    $msginfo->per_recip_data([@{$msginfo->per_recip_data}, $recip_obj]);
    do_log(2,"adding recipient - always_bcc: %s", $bcc);
  }
  $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 {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.2071';
  @ISA = qw(Exporter);
  import Amavis::Util qw(ll do_log freeze thaw);
}

# simple local memory-based cache
sub new {  # called by each child process
  my($class,$keysize) = @_;
  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) }

1;

#
package Amavis::Custom;
# MAIL PROCESSING SEQUENCE:
# child process initialization
# loop for each mail:
#  - receive mail, parse and make available some basic information
#  * custom hook: new() - may inspect info, may load policy banks
#  - mail checking and collecting results
#  * custom hook: checks() - may inspect or modify checking results
#  - deciding mail fate (lookup on *_lovers, thresholds, ...)
#  - quarantining
#  - sending notifications (to admin and recips)
#  * custom hook: before_send() - may send other notif, quarantine, modify mail
#  - forwarding (unless blocked)
#  * custom hook: after_send() - may suppress DSN, send reports, quarantine
#  - sending delivery status notification (if needed)
#  - issue main log entry, manage statistics (timing, counters, nanny)
#  * custom hook: mail_done() - may inspect results
# endloop after $max_requests or earlier

sub new         { my($class,$conn,$msginfo) = @_; undef }
sub checks      { my($self,$conn,$msginfo)  = @_; undef }
sub before_send { my($self,$conn,$msginfo)  = @_; undef }
sub after_send  { my($self,$conn,$msginfo)  = @_; undef }
sub mail_done   { my($self,$conn,$msginfo)  = @_; undef }

1;

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

BEGIN {
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.207';
  import Amavis::Conf qw(:platform :sa :confvars c cr ca);
  import Amavis::Util qw(untaint min max unique_list unique_ref
                         ll do_log sanitize_str debug_oneshot
                         am_id add_entropy generate_mail_id
                         prolong_timer waiting_for_client
                         switch_to_my_time switch_to_client_time
                         snmp_counters_init snmp_count dynamic_destination
                         ccat_split ccat_maj cmp_ccat cmp_ccat_maj
                         setting_by_given_contents_category_all
                         setting_by_given_contents_category orcpt_encode);
  import Amavis::ProcControl qw(exit_status_str proc_status_ok
                         cloexec run_command collect_results);
  import Amavis::Log qw(open_log close_log collect_log_stats);
  import Amavis::Timing qw(section_time get_time_so_far);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Lookup::IP qw(lookup_ip_acl);
  import Amavis::Out;
  import Amavis::Out::EditHeader;
  import Amavis::UnmangleSender qw(parse_ip_address_from_received
                                   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
                  build_mime_entity defanged_mime_entity expand_variables);
  import Amavis::In::Connection;
  import Amavis::In::Message;
}

use Errno qw(ENOENT EACCES EAGAIN ESRCH EBADF);
use POSIX qw(locale_h);
use IO::Handle;
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Time::HiRes ();
# body digest for caching, either MD5 or SHA1 (or perhaps SHA256)
#use Digest::SHA;
use Digest::MD5;
use Net::Server 0.87;  # need Net::Server::PreForkSimple::done
use MIME::Base64;

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_extprog
  $extra_code_antispam_spamc $extra_code_antispam_sa
  $extra_code_unpackers $extra_code_dkim $extra_code_tools);

use vars qw(%modules_basic %got_signals);
use vars qw($user_id_sql $user_policy_id_sql $wb_listed_sql);
use vars qw($implicit_maps_inserted);
use vars qw($db_env $snmp_db);
use vars qw($body_digest_cache);
use vars qw(%builtins);    # macros in customizable notification messages
use vars qw($last_task_completed_at);
use vars qw($child_invocation_count $child_task_count);
use vars qw($child_init_hook_was_called);
# $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);  # configuration files provided by -c or defaulted
use vars qw($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

sub new {
  my($class) = shift;
  # make Amavis a subclass of Net::Server::whatever
  @ISA = !$daemonize && $max_servers==1 ? 'Net::Server' # facilitates debugging
                 : defined $min_servers ? 'Net::Server::PreFork'
                                        : 'Net::Server::PreForkSimple';
# $class->SUPER::new(@_);  # available since Net::Server 0.91
  bless { server => $_[0] }, $class;  # works with all versions
}

# report process resource usage by calling system service getrusage(2)
sub report_rusage() {
  my($have_getrusage) = Unix::Getrusage->UNIVERSAL::can("getrusage");
  if ($have_getrusage) {
    my($usage) = Unix::Getrusage::getrusage();
    # ru_minflt   no. of page faults serviced without I/O activity
    # ru_majflt   no. of page faults that required I/O activity
    # ru_nswap    no. of times a process was swapped out
    # ru_inblock  no. of times a file system had to perform input
    # ru_oublock  no. of times a file system had to perform output
    # ru_msgsnd   no. of IPC messages sent
    # ru_msgrcv   no. of IPC messages received
    # ru_nsignals no. of signals delivered
    # ru_nvcsw    no. of voluntary context switches
    # ru_nivcsw   no. of involuntary context switches
    # ru_maxrss   [kB] maximum resident set size utilized
    # ru_ixrss    [kBtics] integral of mem used by the shared text segment
    # ru_idrss    [kBtics] integral of unshared mem in the data segment
    # ru_isrss    [kBtics] integral of unshared mem in the stack segment
    # ru_utime    [s] time spent executing in user mode
    # ru_stime    [s] time spent in the system on behalf of the process
    my(@order) = qw(minflt majflt nswap inblock oublock msgsnd msgrcv nsignals
                    nvcsw nivcsw maxrss ixrss idrss isrss utime stime);
    my(@result) = map { $_ . '=' . $usage->{'ru_'.$_} } @order;   # known
    delete $usage->{'ru_'.$_}  for @order;
    push(@result, map { $_ . '=' . $usage->{$_} } keys %$usage);  # any other?
    do_log(2,"RUSAGE: %s", join(', ',@result));
  }
}

# implements macros: T, and SA lookalikes: TESTS, TESTSSCORES
sub macro_tests {
  my($msginfo,$recip_index,$name,$sep) = @_;
  my(@s) = split(/,/, $msginfo->spam_status);
  my(@reported_boost);
  if (defined $recip_index) {  # return info on one particular recipient
    my($r) = $msginfo->per_recip_data->[$recip_index];
    my($boost) = $r->recip_score_boost;
    @reported_boost = ($boost)  if $boost;
  } else {
    @reported_boost = grep { defined($_) && abs($_) >= 0.0005 }
                      map  { $_->recip_score_boost }
                      @{$msginfo->per_recip_data};
  }
  # insert internally generated per-recipient score boosts as pseudo
  # spam test hits for logging purposes and insertion into X-Spam-Status
  if (@reported_boost == 1) {
    unshift(@s, 'AM:BOOST=' . (0+sprintf("%.3f",$reported_boost[0])));
  } elsif (@reported_boost > 1) {
    unshift(@s, sprintf("AM:BOOST=%s", join('', unique_list(
      map { my($s) = sprintf("%+.3f",$_); $s=~s/\.?0*\z//; $s }
          @reported_boost ))));
  }
  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: c, and SA lookalikes: SCORE(pad), STARS(*)
sub macro_score {
  my($msginfo,$recip_index,$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+min(@boost));
  } elsif (!defined($sl) && max(map {abs($_)} @boost) <= 1) { # quite arbitrary
    $result = '-';
  } else {
    $sl = 0  if !defined $sl;  # undef score treated as 0 when soft-w/b-listing
    @boost = unique_list(\@boost);
    if (!grep {abs($_) >= 0.0005} @boost) {# none, or no boost worth mentioning
      # fraction trimming assumes there is a dot in the formatted string!
      $result = sprintf($fmt,$sl);  $result =~ s/\.?0*\z//;  # trim fraction
    } elsif ($name eq 'SCORE') {  # users expect a single value
      $result = sprintf($fmt,$sl+min(@boost));  $result =~ s/\.?0*\z//;  # trim
    } else {  # format SA score +/- by-sender score boosts
      $sl = sprintf($fmt,$sl);  $sl =~ s/\.?0*\z//;  # trim trailing zeroes
      if (@boost <= 1) {
        $result = sprintf($fmts,$boost[0]); $result=~s/\.?0*\z//;  # with sign
      } else {
        $result = sprintf("+(%s)",
          join(',',map {my($s)=sprintf($fmt,$_); $s=~s/\.?0*\z//; $s} @boost));
      }
      $result = $sl . $result;
    }
  }
  $result;
};

# implements macro header_field, providing a named header field from a message
#
sub macro_header_field {
  my($msginfo,$name,$header_field_name,$limit) = @_;
  local($_) = $msginfo->get_header_field_body($header_field_name);
  if (defined $_) {  # unfold, trim, protect CR, LF, \000 and \200
    chomp; s/\n(?=[ \t])//gs; s/^[ \t]+//; s/[ \t\n]+\z//;
    if ($header_field_name =~
        /^(?:Message-ID|Resent-Message-ID|In-Reply-To|References)\z/i) {
      $_ = join(' ',parse_message_id($_))  if $_ ne '';  # strip CFWS
    }
    s{([\r\n\000\200])}{sprintf("\\%03o",ord($1))}eg;
  };
  !defined($limit) || $limit < 6 || length($_) <= $limit ? $_
    : substr($_,0,$limit-5) . '[...]';
};

sub dkim_test {
  my($name,$which) = @_;
  my($w) = lc($which);
  my($sigs_ref) = $MSGINFO->dkim_signatures_valid;
  !defined($sigs_ref) || !@$sigs_ref ? undef
  : $w eq 'any' || $w eq '' ? 1
  : $w eq 'author'     ? $MSGINFO->dkim_author_sig
  : $w eq 'sender'     ? $MSGINFO->dkim_sender_sig
  : $w eq 'thirdparty' ? $MSGINFO->dkim_thirdparty_sig
  : $w eq 'envsender'  ? $MSGINFO->dkim_envsender_sig
  : $w eq 'identity'   ? join(',', map { $_->identity } @$sigs_ref)
  : $w eq 'domain'     ? join(',', map { $_->domain   } @$sigs_ref)
  : dkim_acceptable_identity($MSGINFO,$which);
}

sub dkim_acceptable_identity($@) {
  my($msginfo,@acceptable_id) = @_;
  my($matches) = 0;
  my($sigs_ref) = $msginfo->dkim_signatures_valid;
  if (defined($sigs_ref) && @$sigs_ref) {
    for (@acceptable_id) {
      my($acceptable_id) = $_;
      $acceptable_id = ''  if !defined $acceptable_id;
      if ($acceptable_id eq '') {  # checking for author signature
        $matches = 1  if $msginfo->dkim_author_sig;
      } else {
        local($1,$2);
        $acceptable_id = '@'.$acceptable_id  if $acceptable_id !~ /\@/;
        $acceptable_id =~ /^ (.*?) \@ ([^\@]*) \z/xs;  # local part, domain
        my($acceptable_id_mbx, $acceptable_id_dom) = ($1,$2);
        for my $sig (@$sigs_ref) {
          my($identity) = $sig->identity;  # already QP-decoded since 0.32
          if ($acceptable_id_mbx ne '') {  # local part exists, check full id
            $matches = 1  if lc($identity) eq lc($acceptable_id);
          } else {  # only compare domains, exact domain match or a subdomain
            $identity =~ /^ (.*?) \@ ([^\@]*) \z/xs;  # local part, domain
            my($identity_mbx, $identity_dom) = ($1,$2);
            $matches = 1  if $identity_dom=~/(^|\.)\Q$acceptable_id_dom\E\z/si;
          }
          last if $matches;
        }
      }
      last if $matches;
    }
  }
  $matches;
};

# initialize the %builtins, which is an associative array of built-in macros
# to be used in notification message expansion and log templates
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 as 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
  # a 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",int($MSGINFO->rx_time))},# s since Unix epoch,UTC
    # equivalent, but with more descriptive macro names:
    date_unix_utc      => sub {sprintf("%010d",int($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)},
    week_iso8601       => sub {iso8601_week($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 {$MSGINFO->originating ? 1 : undef}, # our client (mynets/roaming)
    s => sub {$MSGINFO->sender_smtp}, # orig. unmodified env. sender addr 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($MSGINFO,'header','Message-ID')},
    r => sub {macro_header_field($MSGINFO,'header','Resent-Message-ID')},
    j => sub {macro_header_field($MSGINFO,'header','Subject')},
    rfc2822_sender => sub {my($s) = $MSGINFO->rfc2822_sender;
                           !defined($s) ? undef : qquote_rfc2821_local($s) },
    rfc2822_from   => sub {my($f) = $MSGINFO->rfc2822_from;
                           !defined($f) ? undef :
                                      qquote_rfc2821_local(ref $f ? @$f : $f)},
    rfc2822_resent_sender => sub {my($rs) = $MSGINFO->rfc2822_resent_sender;
                           !defined($rs) ? undef :
                             qquote_rfc2821_local(grep {defined $_} @$rs)},
    rfc2822_resent_from => sub {my($rf) = $MSGINFO->rfc2822_resent_from;
                           !defined($rf) ? undef :
                             qquote_rfc2821_local(grep {defined $_} @$rf)},
    'x-mailer' => sub {macro_header_field($MSGINFO,'header','X-Mailer')},
    header_field => sub {macro_header_field($MSGINFO,@_)},
    HEADER       => sub {macro_header_field($MSGINFO,@_)},
    useragent =>  # argument: 'name' or 'body', or empty to return entire field
      sub { my($macro_name,$which_part) = @_;  my($head,$body);
            $body = macro_header_field($MSGINFO,'header', $head='User-Agent');
            $body = macro_header_field($MSGINFO,'header', $head='X-Mailer')
              if !defined $body;
            !defined($body) ? undef
            : lc($which_part) eq 'name' ? $head
            : lc($which_part) eq 'body' ? $body : "$head: $body";
          },
    ccat =>
      sub {
        my($name,$attr,$which) = @_;
        $attr = lc($attr);    # name | major | minor | <empty>
                              # | is_blocking | is_nonblocking
                              # | is_blocked_by_nonmain
        $which = lc($which);  # main | blocking | auto
        my($result) = '';  my($blocking_ccat) = $MSGINFO->blocking_ccat;
        if ($attr eq 'is_blocking') {
          $result =  defined($blocking_ccat) ? 1 : '';
        } elsif ($attr eq 'is_nonblocking') {
          $result = !defined($blocking_ccat) ? 1 : '';
        } elsif ($attr eq 'is_blocked_by_nonmain') {
          if (defined($blocking_ccat)) {
            my($aref) = $MSGINFO->contents_category;
            $result = 1  if ref($aref) && @$aref > 0
                            && $blocking_ccat ne $aref->[0];
          }
        } elsif ($attr eq 'name') {
          $result =
            $which eq 'main' ?
              $MSGINFO->setting_by_main_contents_category(\%ccat_display_names)
          : $which eq 'blocking' ?
              $MSGINFO->setting_by_blocking_contents_category(
                                                         \%ccat_display_names)
          :   $MSGINFO->setting_by_contents_category(    \%ccat_display_names);
        } else {  # attr = major, minor, or anything else returns a pair
          my($maj,$min) = ccat_split(
                            ($which eq 'blocking' ||
                             $which ne 'main' && defined $blocking_ccat)
                             ? $blocking_ccat : $MSGINFO->contents_category);
          $result = $attr eq 'major' ? $maj
             : $attr eq 'minor' ? sprintf("%d",$min)
             : sprintf("(%d,%d)",$maj,$min);
        }
        $result;
      },
    ccat_maj =>   # deprecated, use [:ccat|major]
      sub { my($blocking_ccat) = $MSGINFO->blocking_ccat;
            (ccat_split(defined $blocking_ccat ? $blocking_ccat
                                            : $MSGINFO->contents_category))[0];
          },
    ccat_min =>   # deprecated, use [:ccat|minor]
      sub { my($blocking_ccat) = $MSGINFO->blocking_ccat;
            (ccat_split(defined $blocking_ccat ? $blocking_ccat
                                            : $MSGINFO->contents_category))[1];
          },
    ccat_name =>  # deprecated, use [:ccat|name]
      sub { $MSGINFO->setting_by_contents_category(\%ccat_display_names) },
    dsn_notify => sub {
      return 'NEVER'  if $MSGINFO->sender eq '';
      my(%merged);
      for my $r (@{$MSGINFO->per_recip_data}) {
        my($dn) = $r->dsn_notify;
        for ($dn ? @$dn : ('FAILURE')) { $merged{uc($_)} = 1 }
      }
      uc(join(',', sort keys %merged));
    },
    b => sub {$MSGINFO->body_digest},  # original message body digest
    n => sub {$MSGINFO->log_id},   # amavis internal task id (in log and nanny)
    i => sub {$MSGINFO->mail_id},  # long-term unique mail id on this system
    LOGID  => sub {$MSGINFO->log_id},  # synonym for %n (no equivalent in SA)
    MAILID => sub {$MSGINFO->mail_id}, # synonym for %i (no equivalent in SA)
    P => sub {$MSGINFO->partition_tag}, # SQL partition tag
    partition_tag => sub {$MSGINFO->partition_tag},  # synonym for %P
    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($vn) = $MSGINFO->virusnames;       # unique virus names
              !defined($vn) ? undef : unique_ref($vn)},
    F => sub { my($b);
               # first banned part name with a comment from a rule regexp
               for my $r (@{$MSGINFO->per_recip_data}) {
                 $b = $r->banning_reason_short;
                 last  if defined $b;
               }
               $b },
    banning_rule_key => sub {
               # regexp of a matching banning rules yielding a true rhs result
               unique_ref(map { my($v) = $_->banning_rule_key;
                                !defined($v) ? () : @$v }
                              @{$MSGINFO->per_recip_data});
             },
    banning_rule_comment => sub {
               # just a comment (or a whole regexp if it contains no comments)
               # from matching banning regexp rules yielding a true rhs result
               unique_ref(map { my($v) = $_->banning_rule_comment;
                                !defined($v) ? () : @$v }
                              @{$MSGINFO->per_recip_data});
             },
    banning_rule_rhs => sub {
               # right-hand-side of those matching banning rules yielding true
               # (a r.h.s. of a rule can be a string, is treated as a boolean,
               # but often it is just an implicit 0 or 1)
               unique_ref(map { my($v) = $_->banning_rule_rhs;
                                !defined($v) ? () : @$v }
                              @{$MSGINFO->per_recip_data});
             },
    banned_parts => sub {          # list of banned parts with their full paths
               my($b) = unique_ref(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 {split(/\n/,$_)} @{$MSGINFO->orig_header}]}, # arry of lines
    A       => sub {[split(/\r?\n/, $MSGINFO->spam_summary)]}, # SA report text
    SUMMARY => sub {$MSGINFO->spam_summary},
    REPORT  => sub {sanitize_str($MSGINFO->spam_report,1)}, #contains any octet
    TESTSSCORES => sub {macro_tests($MSGINFO,undef,@_)}, # tests with scores
    TESTS       => sub {macro_tests($MSGINFO,undef,@_)}, # tests without scores
    z => sub {$MSGINFO->msg_size}, # mail size as defined by rfc1870, or approx
    t => sub { # first entry in the Received trace
               sanitize_str(first_received_from($MSGINFO)) },
    e => sub { # first valid public IP in the Received trace
               sanitize_str(parse_ip_address_from_received($MSGINFO)) },
    a => sub {$MSGINFO->client_addr}, # original SMTP session client IP address
    g => sub { # original SMTP session client DNS name
               sanitize_str($MSGINFO->client_name) },
    remote_mta    => sub { unique_ref(map {$_->recip_remote_mta}
                                          @{$MSGINFO->per_recip_data}) },
    smtp_response => sub { unique_ref(map {$_->recip_smtp_response}
                                          @{$MSGINFO->per_recip_data}) },
    remote_mta_smtp_response =>
                     sub { unique_ref(map {$_->recip_remote_mta_smtp_response}
                                          @{$MSGINFO->per_recip_data}) },
    REMOTEHOSTADDR =>  # where the request was sent from
            sub { my($c) = $MSGINFO->conn_obj; !$c ? '' : $c->client_ip },
    REMOTEHOSTNAME =>
            sub { my($c) = $MSGINFO->conn_obj;
                  my($ip) = !$c ? '' : $c->client_ip;
                  $ip ne '' ? "[$ip]" : 'localhost' },
#   VERSION    => Mail::SpamAssassin->Version,       # SA version
#   SUBVERSION => $Mail::SpamAssassin::SUB_VERSION,  # SA sub-version/revision
    AUTOLEARN  => sub {$MSGINFO->supplementary_info('AUTOLEARN')},
    supplementary_info =>  # additional information from SA and other scanners
            sub { my($name,$key,$fmt)=@_;
                  my($info) = $MSGINFO->supplementary_info($key);
                  $info eq '' ? '' : $fmt eq '' ? $info : sprintf($fmt,$info);
                },
    REQD => sub { my($tag2_level);
                  for (@{$MSGINFO->per_recip_data}) {  # get minimal tag2_level
                    my($tag2_l) = lookup2(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);
                },
    '1'=> sub { # above tag level and not bypassed for any recipient?
                (grep { $_->is_in_contents_category(CC_CLEAN,1) }
                      @{$MSGINFO->per_recip_data}) ? 'Y' : '0' },
    '2'=> sub { # above tag2 level and not bypassed for any recipient?
                (grep { $_->is_in_contents_category(CC_SPAMMY) }
                      @{$MSGINFO->per_recip_data}) ? 'Y' : '0' },
    YESNO => sub { # like %2, but gives: Yes/No
                (grep { $_->is_in_contents_category(CC_SPAMMY) }
                      @{$MSGINFO->per_recip_data}) ? 'Yes' : 'No' },
    YESNOCAPS => sub { # like %2, but gives: YES/NO
                (grep { $_->is_in_contents_category(CC_SPAMMY) }
                      @{$MSGINFO->per_recip_data}) ? 'YES' : 'NO' },
    'k'=> sub { # above kill level and not bypassed for any recipient?
                (grep { $_->is_in_contents_category(CC_SPAM) }
                      @{$MSGINFO->per_recip_data}) ? 'Y' : '0' },
    score_boost => sub {0+sprintf("%.3f",min(map {$_->recip_score_boost}
                                                @{$MSGINFO->per_recip_data}))},
    c      => sub {macro_score($MSGINFO,undef,@_)},  # info on all recipients
    SCORE  => sub {macro_score($MSGINFO,undef,@_)},  # info on all recipients
    STARS  => sub {macro_score($MSGINFO,undef,@_)},  # info on all recipients
    dkim   => \&dkim_test,
    tls_in => sub {$MSGINFO->tls_cipher}, # currently only shows ciphers in use
    report_format => undef,  # notification message format, supplied elsewhere
    feedback_type => undef,  # (ARF) feedback type or empty, supplied elsewhere
    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"},
    min    => sub {my($name,@args) = @_; min(map {/^\s*\z/?undef:$_} @args)},
    max    => sub {my($name,@args) = @_; max(map {/^\s*\z/?undef:$_} @args)},
    sprintf=> sub {my($name,$fmt,@args) = @_; sprintf($fmt,@args)},
    join   => sub {my($name,$sep,@args) = @_; join($sep,@args)},
    limit  => sub {my($name,$lim,$s) = @_; $lim < 6 || length($s) <= $lim ? $s
                                              : substr($s,0,$lim-5).'[...]' },
    dquote => sub {my($nm)=shift; join('', map { s{"}{""}g; '"'.$_.'"' } @_)},
    uquote => sub {my($nm)=shift; join('', map { s{[ \t]+}{_}g; $_     } @_)},
    b64encode => sub {my($nm)=shift; join(' ', map {encode_base64($_,'')} @_)},
    # macros f, T, C, B will be defined for each notification as appropriate
    # (representing From:, To:, Cc:, and Bcc: respectively)
    # remaining free letters: wxEGIJKLMYZ
  );
}

# 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 = (
    'virus-quarantine'      => sub { ($QUARANTINEDIR, undef) },
    'banned-quarantine'     => sub { ($QUARANTINEDIR, undef) },
    'spam-quarantine'       => sub { ($QUARANTINEDIR, undef) },
    'bad-header-quarantine' => sub { ($QUARANTINEDIR, undef) },
    'clean-quarantine'      => sub { ($QUARANTINEDIR, undef) },
    'other-quarantine'      => sub { ($QUARANTINEDIR, undef) },
    'archive-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
#     },
  );
}

# tokenize templates (input to macro expansion), after dropping privileges
sub init_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
     notify_release_templ notify_report_templ notify_autoresp_templ);
  for my $bank_name (keys %policy_bank) {
    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;
    }
  }
}

# pre-parse IP lookup tables to speed up lookups, after dropping privileges
sub init_preparse_ip_lookups() {
  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}{'client_ipaddr_policy'};  # listref of pairs
    if (ref($r) eq 'ARRAY') {  # should be an array, test just to make sure
      my($odd) = 1;
      for my $table (@$r) {  # replace plain lists with Amavis::Lookup::IP obj.
        $table = Amavis::Lookup::IP->new(@$table)
          if $odd && ref($table) eq 'ARRAY';
        $odd = !$odd;
      }
    }
  }
}

# initialize some remaining global variables in a master process;
# invoked after chroot and after privileges have been dropped, before forking
sub after_chroot_init() {
  $child_invocation_count = $child_task_count = 0;
  %modules_basic = %INC;  # helps to track missing modules in chroot
  do_log(5,"after_chroot_init: EUID: %s (%s);  EGID: %s (%s)", $>,$<, $),$( );
  my(@msg);
  my($euid) = $>;   # effective UID
  $> = 0;           # try to become root
  POSIX::setuid(0)  if $> != 0;  # and try some more
  if ($> == 0 || $euid == 0) {   # succeded? panic!
    @msg = ("It is possible to change EUID from $euid to root, ABORTING!",
            "Please use a recent version of Net::Server",
            "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.
    my(@actual_c_f) = Amavis::Conf::get_config_files_read();
    do_log(2,"config files read: %s", join(", ",@actual_c_f));
    for my $config_file (@actual_c_f) {
      local($1);  # IO::Handle::_open_mode_string can taint $1 if mode is '+<'
      my($fh) = IO::File->new;
      my($errn) = stat($config_file) ? 0 : 0+$!;
      if ($errn) {  # not accessible, don't bother to test further
      } elsif ($fh->open($config_file,O_RDWR)) {
        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)';
        my($errn_cf_orig) = stat($config_file)          ? 0 : 0+$!;
        my($errn_cf_movd) = stat($config_file.'.moved') ? 0 : 0+$!;
        if ($errn_cf_orig==ENOENT && $errn_cf_movd!=ENOENT) {
          # try to rename back, ignoring status
          rename($config_file.'.moved', $config_file);
          $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
  }
  init_tokenize_templates();
  init_preparse_ip_lookups();

  # report versions of some (more interesting) 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
      Digest::MD5 Digest::SHA Digest::SHA1 Authen::SASL Crypt::OpenSSL::RSA
      Socket6 IO::Socket::INET6 IO::Socket::SSL Net::SSLeay Net::Server
      Mail::ClamAV Mail::SpamAssassin Mail::DKIM::Verifier Mail::DKIM::Signer
      Mail::SPF Mail::SPF::Query NetAddr::IP URI Razor2::Client::Version
      Net::LDAP DBI DBD::mysql DBD::Pg DBD::SQLite BerkeleyDB DB_File
      Net::DNS Unix::Syslog Time::HiRes SAVI Anomy::Sanitizer Unix::Getrusage);
    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-EXT code  %s loaded",
                                      $extra_code_antispam_extprog ?'':" NOT");
  do_log(0,"ANTI-SPAM-C code    %s loaded",
                                      $extra_code_antispam_spamc   ?'':" 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");
  do_log(0,"DKIM code           %s loaded", $extra_code_dkim       ?'':" NOT");
  do_log(0,"Tools code          %s loaded", $extra_code_tools      ?'':" 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}};  # copy base
    do_log(4,'loaded base policy bank');
  } else {
    my($cpbp) = c('policy_bank_path');  # currently loaded bank
    my($new_bank_ref) = $policy_bank{$policy_bank_name};
    my($do_log5) = ll(5);
    for my $k (keys %$new_bank_ref) {
      do_log(-1,'loading policy bank "%s": unknown field "%s"',
                $policy_bank_name,$k)  if !exists $current_policy_bank{$k};
      if (ref($new_bank_ref->{$k}) ne 'HASH' ||
          ref($current_policy_bank{$k}) ne 'HASH') {
        $current_policy_bank{$k} = $new_bank_ref->{$k};
      } else {  # new hash to be merged into an existing hash
        if ($new_bank_ref->{REPLACE}) {  # replace the entire hash
          $current_policy_bank{$k} = { %{$new_bank_ref->{$k}} };  # copy of new
          do_log(5,"loading policy bank %s, curr{%s} hash replaced",
                    $policy_bank_name, $k)  if $do_log5;
        } else { # merge field-by-field, old fields missing in new are retained
          $current_policy_bank{$k} = { %{$current_policy_bank{$k}} };  # copy
          my($key,$val);
          while (($key,$val) = each %{$new_bank_ref->{$k}}) {
            do_log(5,"loading policy bank %s, curr{%s}{%s} = %s, %s",
                     $policy_bank_name, $k, $key, $val,
                     !exists($current_policy_bank{$k}{$key}) ? 'new'
                                   : 'replaces '.$current_policy_bank{$k}{$key}
                  )  if $do_log5;
            $current_policy_bank{$k}{$key} = $val;
          }
        }
        delete $current_policy_bank{$k}{REPLACE};
      }
    }
    $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
### Occurs in the parent (master) process after (possibly) opening a log file,
### creating pid file, reopening STDIN/STDOUT to /dev/null and daemonizing;
### but before binding to sockets
sub post_configure_hook {
# umask(0007);  # affect protection of Unix sockets created by Net::Server
}

### Net::Server hook
### Occurs in the parent (master) process after binding to sockets,
### but before chrooting and dropping privileges
sub post_bind_hook {
  umask(0027);  # restore our preferred umask
}

### Net::Server hook
### This hook occurs in the parent (master) process after chroot,
### after change of user, and change of group has occured.
### It allows for preparation before forking and looping begins.
sub pre_loop_hook {
  my($self) = @_;
  local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered pre_loop_hook");
  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 $name inaccessible: $!" }
      elsif (!-d _) { die "db_home $name is not a directory" }
      elsif (!-w _) { die "db_home $name directory is not writable" }
    # Amavis::DB::init(1, 15+1+40);  # SHA-1 (160 bits)
      Amavis::DB::init(1, 15+1+32);  # MD5   (128 bits)
    }
    if (!defined($sql_quarantine_chunksize_max)) {
      die "Variable \$sql_quarantine_chunksize_max is undefined\n";
    } elsif ($sql_quarantine_chunksize_max < 1024) {
      die "Setting of \$sql_quarantine_chunksize_max is too small: ".
          "$sql_quarantine_chunksize_max bytes, it would be inefficient\n";
    } elsif ($sql_quarantine_chunksize_max > 1024*1024) {
      do_log(-1, "Setting of %s is quite large: %d kB, it unnecessarily ".
                 "wastes memory", '$sql_quarantine_chunksize_max',
                 $sql_quarantine_chunksize_max/1024);
    }
    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 $name inaccessible: $!" }
      elsif (-d _ && !-w _){ die "QUARANTINEDIR directory $name not writable"}
    }
    $spamcontrol_obj->init_pre_fork  if $spamcontrol_obj;
    my(@modules_extra) = grep {!exists $modules_basic{$_}} keys %INC;
    if (@modules_extra) {
      do_log(1, "extra modules loaded after daemonizing/chrooting: %s",
        join(", ", sort @modules_extra));
      %modules_basic = %INC;
    }
    do_log(0, "DKIM signature verification disabled, corresponding features ".
      "not available. If not intentional, consider enabling it by setting: ".
      "\$enable_dkim_verification to 1, or explicitly disable it by setting ".
      "it to 0 to quench down this warning."
    ) if !$enable_dkim_verification && !defined($enable_dkim_verification);
    1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    my($msg) = "TROUBLE in pre_loop_hook: $eval_stat";  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';
  $level = 0 if $level < 0;  $level = 4 if $level > 4;
# my($ll) = (-2,-1,0,1,3)[$level];  # 0=err, 1=warn, 2=notice, 3=info, 4=debug
  my($ll) = (-1, 0,1,3,4)[$level];  # 0=err, 1=warn, 2=notice, 3=info, 4=debug
  chomp($msg);  # just call Amavis' traditional logging
  ll($ll) && do_log($ll, "Net::Server: %s", $msg);
  1;
}

### user customizable Net::Server hook (Net::Server 0.88 or later),
### hook occurs in the master process !!!
sub run_n_children_hook {
# do_log(5, "entered 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,
### run by every child process during its startup
sub child_init_hook {
  my($self) = @_;
  local $SIG{CHLD} = 'DEFAULT';
  # reset log counters inherited from a master process
  collect_log_stats();
  do_log(5, "entered child_init_hook");
  $child_init_hook_was_called = 1;
  $my_pid = $$;  $0 = 'amavisd (virgin child)';
# my(@signames) = qw(HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV
#                    SYS PIPE ALRM TERM URG TSTP CONT TTIN TTOU IO
#                    XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2);
# my($h) = sub { my($s) = $_[0]; $got_signals{$s}++;
#                local($SIG{$s})='IGNORE'; kill($$,$s) };
# @SIG{@signames} = ($h) x @signames;
  my($inherited_entropy);
  eval {
#   if ($> == 0 || $< == 0) {  # last resort, in case Net::Server didn't do it
#     do_log(2, "child_init_hook: dropping privileges, user=%s, group=%s",
#                $daemon_user,$daemon_group);
#     drop_priv($daemon_user,$daemon_group);
#   }
    $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) {
      # Berkeley DB handles should not be shared across process forks,
      # each forked child should acquire its own Berkeley DB handles
      $db_env = Amavis::DB->new;  # get access to a bdb environment
      $snmp_db = Amavis::DB::SNMP->new($db_env);
      $snmp_db->register_proc(0,1,'')  if defined $snmp_db;  # alive and 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, 15+1+40);  # SHA-1 (160 b)
    $body_digest_cache = Amavis::Cache->new($db_env, 15+1+32);  # MD5   (128 b)
    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 (same or 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);
        if ($sql_dataset_conn_lookups) {
          do_log(2,"storage and lookups will use separate connections to SQL");
        } else {
          do_log(5,"only storage connections to SQL, no 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;
    $spamcontrol_obj->init_child  if $spamcontrol_obj;
    1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    do_log(-2, "TROUBLE in child_init_hook: %s", $eval_stat);
    die "Suicide in child_init_hook: $eval_stat\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';
# do_log(5, "entered post_accept_hook");
  if (!$child_init_hook_was_called) {
    # this can happen with base Net::Server (not PreFork nor PreForkSiple)
    do_log(5, "post_accept_hook: invoking child_init_hook which was skipped");
    $self->child_init_hook;
  }
  $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(1,1,'A')  if defined $snmp_db; # enter 'accept' state
  load_policy_bank('');    # start with a builtin baseline policy bank
}

### user customizable Net::Server hook, load a by-interface policy bank;
### 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';
# do_log(5, "entered allow_deny_hook");
  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 PEER 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';
# do_log(5, "entered process_request");
  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 cannot 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 is
  # fine 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!
  my($eval_stat);
  eval {
#   if ($] < 5.006)  # Perl older than 5.6.0 did not set FD_CLOEXEC on sockets
#     { cloexec($_,1,$_)  for @{$prop->{sock}} }
    switch_to_my_time('new request');  # 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_dsn_cutoff_level_maps,$lf->('amavisSpamDsnCutoffLevel','N-'));
      unshift(@Amavis::Conf::spam_quarantine_cutoff_level_maps,$lf->('amavisSpamQuarantineCutoffLevel','N-'));
      unshift(@Amavis::Conf::spam_subject_tag_maps,    $lf->('amavisSpamSubjectTag',     'S-'));
      unshift(@Amavis::Conf::spam_subject_tag2_maps,   $lf->('amavisSpamSubjectTag2',    'S-'));
      unshift(@Amavis::Conf::spam_modifies_subj_maps,  $lf->('amavisSpamModifiesSubj',   'B-'));
      unshift(@Amavis::Conf::message_size_limit_maps,  $lf->('amavisMessageSizeLimit',   'N-'));
      unshift(@Amavis::Conf::virus_quarantine_to_maps, $lf->('amavisVirusQuarantineTo',  'S-'));
      unshift(@Amavis::Conf::banned_quarantine_to_maps, $lf->('amavisBannedQuarantineTo','S-'));
      unshift(@Amavis::Conf::spam_quarantine_to_maps,  $lf->('amavisSpamQuarantineTo',   'S-'));
      unshift(@Amavis::Conf::bad_header_quarantine_to_maps, $lf->('amavisBadHeaderQuarantineTo', 'S-'));
      unshift(@Amavis::Conf::clean_quarantine_to_maps, $lf->('amavisCleanQuarantineTo',  'S-'));
      unshift(@Amavis::Conf::archive_quarantine_to_maps, $lf->('amavisArchiveQuarantineTo',  '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-'));
#     unshift(@Amavis::Conf::disclaimer_options_bysender_maps,
#                                                      $lf->('amavisDisclaimerOptions',  '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');
      $user_policy_id_sql = $nf->('policy_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::virus_quarantine_to_maps,  $nf->('virus_quarantine_to',  'S-'));
      unshift(@Amavis::Conf::banned_quarantine_to_maps, $nf->('banned_quarantine_to', 'S-'));
      unshift(@Amavis::Conf::spam_quarantine_to_maps,   $nf->('spam_quarantine_to',   'S-'));
      unshift(@Amavis::Conf::bad_header_quarantine_to_maps, $nf->('bad_header_quarantine_to','S-'));
      unshift(@Amavis::Conf::clean_quarantine_to_maps,  $nf->('clean_quarantine_to',  'S-'));
      unshift(@Amavis::Conf::archive_quarantine_to_maps,$nf->('archive_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-'));
#     unshift(@Amavis::Conf::disclaimer_options_bysender_maps,
#                                                       $nf->('disclaimer_options',   'S-'));
      section_time('sql-prepare');
    }
    Amavis::Conf::label_default_maps()  if !$implicit_maps_inserted;
    $implicit_maps_inserted = 1;

    my($conn) = Amavis::In::Connection->new;  # keeps info about connection
    $conn->socket_proto($sock->NS_proto);
    my($suggested_protocol) = c('protocol');  # suggested by the policy bank
    $suggested_protocol = ''  if !defined $suggested_protocol;
    ll(5) && do_log(5,"process_request: suggested_protocol=\"%s\" on %s",
                    $suggested_protocol,$sock->NS_proto);
  # $snmp_db->register_proc(2,0,'b')  if defined $snmp_db;  # begin protocol
    my($ns_proto) = $sock->NS_proto;
    if ($ns_proto eq 'TCP') {
      $conn->socket_ip($prop->{sockaddr});
      $conn->socket_port($prop->{sockport});
      $conn->client_ip($prop->{peeraddr});
    }
    if ($suggested_protocol eq 'SMTP' || $suggested_protocol eq 'LMTP' ||
        $suggested_protocol eq '' && $ns_proto eq 'TCP') {
      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);
    } elsif ($suggested_protocol eq 'AM.PDP') {
      # amavis policy delegation protocol (e.g. new milter or amavisd-release)
      $amcl_in_obj = Amavis::In::AMCL->new  if !$amcl_in_obj;
      $amcl_in_obj->process_policy_request($sock, $conn, \&check_mail, 0);
    } elsif ($suggested_protocol eq 'COURIER') {
      die "unavailable support for protocol: $suggested_protocol";
    } elsif ($suggested_protocol eq 'QMQPqq') {
      die "unavailable support for protocol: $suggested_protocol";
    } elsif ($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.CL' ||
             $suggested_protocol eq '' && $ns_proto eq 'UNIX') {
      # defaults 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);
    } else {
      die "unsupported protocol: $suggested_protocol, $ns_proto";
    }
    Amavis::Out::SMTP::Session::rundown_stale_sessions(0)
      if $extra_code_out_smtp;
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  alarm(0);  # stop the timer
  if (defined $eval_stat) {
    chomp $eval_stat; my($timed_out) = $eval_stat =~ /^timed out\b/;
    if ($timed_out) {
      my($msg) = "Requesting process rundown, task exceeded allowed time";
      $msg .= " during waiting for input from client"  if waiting_for_client();
      do_log(-1, $msg);
    } else {
      do_log(-2, "TROUBLE in process_request: %s", $eval_stat);
      $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 ($max_requests > 0 && $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
    my($have_sawampersand)=Devel::SawAmpersand->UNIVERSAL::can("sawampersand");
    do_log(2, "Requesting process rundown after %d tasks (and %s sessions)%s",
              $child_task_count, $child_invocation_count,
              !$have_sawampersand ? '' : Devel::SawAmpersand::sawampersand() ?
                ", SawAmpersand is TRUE!" : ", SawAmpersand is false");
    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));
  if (@modules_extra) {
    do_log(1, "extra modules loaded: %s", join(", ", sort @modules_extra));
    %modules_basic = %INC;
  }
  do_log(5, "exiting process_request");
}

### After processing of a request, but before client connection has been closed
### user customizable Net::Server hook
sub post_process_request_hook {
  my($self) = @_;
  my($prop) = $self->{server}; my($sock) = $prop->{client};
  local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered post_process_request_hook");
  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(1,0,'')  if defined $snmp_db;  # alive and idle again
  Amavis::Timing::go_idle('bye');
  if (ll(3)) {
    my($load_report) = Amavis::Timing::report_load();
    do_log(3,$load_report)  if defined $load_report;
  }
  # 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';
# do_log(5, "entered child_finish_hook");
# 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);
# }
  Amavis::Out::SMTP::Session::rundown_stale_sessions(1)
    if $extra_code_out_smtp;
  $spamcontrol_obj->rundown_child  if $spamcontrol_obj;
  report_rusage();
  $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(0,0,undef) } if defined $snmp_db; # unregister
  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(0,0,undef) } if defined $snmp_db; # unregister
  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; local($1);
    my($resp_code, $resp_msg) = (400, 'INTERNAL ERROR');
    if ($ln =~ /^get (.*?)\015?\012\z/si) {
      my($key) = tcp_lookup_decode($1);
      my($sl); $sl = lookup2(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
  undef $av_output; @detecting_scanners = ();
  @virusname = (); @bad_headers = ();
  $banned_filename_any = $banned_filename_all = 0;
  undef $MSGINFO;  # just in case
}

# Collects some information derived from the envelope and the message,
# do some common lookups, storing the information into a $msginfo object
# to make commonly used information quickly and readily avaliable to the
# rest of the program, e.g. avoiding a need for repeated lookups or parsing
# of the same attribute
#
sub collect_some_info($) {
  my($msginfo) = @_;

  my($partition_tag) = c('sql_partition_tag');
  $partition_tag = &$partition_tag($msginfo)  if ref $partition_tag eq 'CODE';
  $partition_tag = 0  if !defined $partition_tag;
  $msginfo->partition_tag($partition_tag);

  # obtain rfc2822 From and Sender from the mail header section, parsed/clean
  my($rfc2822_sender)     = $msginfo->get_header_field_body('sender');
  my($rfc2822_from_field) = $msginfo->get_header_field_body('from');
  my(@rfc2822_from);  # rfc5322 (ex rfc2822) allows multiple author's addresses
  if (defined $rfc2822_sender) {
    my(@sender_parsed) = map { unquote_rfc2821_local($_) }
                             parse_address_list($rfc2822_sender);
    $rfc2822_sender = !@sender_parsed ? '' : $sender_parsed[0]; # none or one
    $msginfo->rfc2822_sender($rfc2822_sender);
  }
  if (defined $rfc2822_from_field) {
    @rfc2822_from = map { unquote_rfc2821_local($_) }
                        parse_address_list($rfc2822_from_field);
    # rfc2822_from is a ref to a list when there are multiple author addresses!
    $msginfo->rfc2822_from(@rfc2822_from < 1 ? undef :
                           @rfc2822_from < 2 ?  $rfc2822_from[0]
                                             : \@rfc2822_from);
  }
  if (defined $msginfo->get_header_field('to')) {
    my($rfc2822_to) = $msginfo->get_header_field_body('to');
    my(@to_parsed) = map { unquote_rfc2821_local($_) }
                         parse_address_list($rfc2822_to);
    $msginfo->rfc2822_to(@to_parsed<2 ? $to_parsed[0] : \@to_parsed);
  }
  if (defined $msginfo->get_header_field('cc')) {
    my($rfc2822_cc) = $msginfo->get_header_field_body('cc');
    my(@cc_parsed) = map { unquote_rfc2821_local($_) }
                         parse_address_list($rfc2822_cc);
    $msginfo->rfc2822_cc(@cc_parsed<2 ? $cc_parsed[0] : \@cc_parsed);
  }
  my(@rfc2822_resent_from, @rfc2822_resent_sender);
  if (defined $msginfo->get_header_field('resent-from') ||
      defined $msginfo->get_header_field('resent-sender')) {  # triage
    # Each Resent block should have exactly one Resent-From, and none or one
    # Resent-Sender address.  A HACK: undef in each list is used to separate
    # addresses obtained from different resent blocks, for the benefit of
    # those interested in traversing them block by block (e.g. when choosing
    # a DKIM signing key). The rfc5322 section 3.6.6 says: All of the resent
    # fields corresponding to a particular resending of the message SHOULD be
    # grouped together.
    my(@r_from, @r_sender); local($1);
    for (my $j = 0;  ; $j++) {  # traverse header section by fields, top-down
      my($f_i,$f_n,$f) = $msginfo->get_header_field(undef,$j);
      if ( @r_from && (
             !defined($f) ||                # end of a header section
             $f !~ /^Resent-/si ||          # presumably end of a resent block
             $f =~ /^Resent-From\s*:/si ||  # another Resent-From encountered
             $f =~ /^Resent-Sender\s*:/si && @r_sender  # another Resent-Sender
           ) ) {  # ends of a current resent block
        # a hack: undef in a list is used to separate addresses
        # from different resent blocks
        push(@rfc2822_resent_from,   undef, @r_from);   @r_from = ();
        push(@rfc2822_resent_sender, undef, @r_sender); @r_sender = ();
      }
      last  if !defined $f;
      if ($f =~ /^Resent-From\s*:(.*)\z/si) {
        push(@r_from, map {unquote_rfc2821_local($_)} parse_address_list($1));
      } elsif ($f =~ /^Resent-Sender\s*:(.*)\z/si) {
        # multiple Resent-Sender in a block are illegal, store them all anyway
        push(@r_sender,map {unquote_rfc2821_local($_)} parse_address_list($1));
      }
    }
    if (@r_from || @r_sender) {  # any leftovers not forming a resent block?
      push(@rfc2822_resent_from,   undef, @r_from);
      push(@rfc2822_resent_sender, undef, @r_sender);
    }
    shift(@rfc2822_resent_from)   if @rfc2822_resent_from;    # remove undef
    shift(@rfc2822_resent_sender) if @rfc2822_resent_sender;  # remove undef
    # rfc2822_resent_from and rfc2822_resent_sender are listrefs (or undef)
    $msginfo->rfc2822_resent_from(\@rfc2822_resent_from)
      if @rfc2822_resent_from;
    $msginfo->rfc2822_resent_sender(\@rfc2822_resent_sender)
      if @rfc2822_resent_sender;
  }
  my($mail_size) = $msginfo->msg_size;  # use corrected ESMTP size if avail.
  if (!defined($mail_size) || $mail_size <= 0) {  # not yet known?
    $mail_size = $msginfo->orig_header_size + $msginfo->orig_body_size;
    $msginfo->msg_size($mail_size);     # store back
    do_log(4,"mail size unknown, size set to %d", $mail_size);
  }

  # check for mailing lists, bulk mail and auto-responses
  my($sender) = $msginfo->sender;
  my($is_mlist);  # mail from a mailing list
  my($is_auto);   # bounce, auto-response, challenge-reesponse, ...
  my($is_bulk);   # bulk mail or $is_mlist or $is_auto
  if (defined $msginfo->get_header_field('list-id')) {  # rfc2919
    $is_mlist = $msginfo->get_header_field_body('list-id');
  } elsif (defined $msginfo->get_header_field('list-post')) {
    $is_mlist = $msginfo->get_header_field_body('list-post');
  } elsif (defined $msginfo->get_header_field('list-unsubscribe')) {
    $is_mlist = $msginfo->get_header_field_body('list-unsubscribe');
  } elsif (defined $msginfo->get_header_field('mailing-list')) {
    $is_mlist = $msginfo->get_header_field_body('mailing-list');  # non-std.
  } elsif ($sender =~ /^ (?: [^\@]+ -(?:request|bounces|owner|admin) |
                             owner- [^\@]+ ) (?: \@ | \z )/xsi) {
    $is_mlist = 'sender=' . $sender;
  } elsif ($rfc2822_from[0] =~ /^ (?: [^\@]+ -(?:request|bounces|owner) |
                             owner- [^\@]+ ) (?: \@ | \z )/xsi) {
    $is_mlist = 'From:' . $rfc2822_from[0];
  }
  if (defined $is_mlist) {  # sanitize a bit
    local($1);  $is_mlist = $1 if $is_mlist =~ / < (.*) > [^>]* \z/xs;
    $is_mlist =~ s/\s+/ /g; $is_mlist =~ s/^ //; $is_mlist =~ s/ \z//;
    $is_mlist =~ s/^mailto://i;
    $is_mlist = 'ml:' . $is_mlist;
  }
  if (defined $msginfo->get_header_field('precedence')) {
    my($prec) = $msginfo->get_header_field_body('precedence');
    $prec =~ s/^[ \t]+//; local($1);
    $is_mlist = $1  if !defined($is_mlist) && $prec =~ /^(list)/si;
    $is_auto  = $1  if $prec =~ /^(auto.?reply)\b/si;
    $is_bulk  = $1  if $prec =~ /^(bulk|junk)\b/si;
  }
  if (defined $is_auto) {
    # already set
  } elsif (defined $msginfo->get_header_field('auto-submitted')) {
    my($auto) = $msginfo->get_header_field_body('auto-submitted');
    $auto =~ s/ \( [^)]* \) //gx; $auto =~ s/^[ \t]+//; $auto =~ s/[ \t]+\z//;
    $is_auto = 'Auto-Submitted:' . $auto  if lc($auto) ne 'no';
  } elsif ($sender eq '') {
    $is_auto = 'sender=<>';
  } elsif ($sender =~
           /^ (?: mailer-daemon|double-bounce|mailer|autoreply )
              (?: \@ | \z )/xsi) {
    # 'postmaster' is also common, but a bit risky
    $is_auto = 'sender=' . $sender;
  } elsif ($rfc2822_from[0] =~  # just checks the first author, good enough
           /^ (?: mailer-daemon|double-bounce|mailer|autoreply )
              (?: \@ | \z )/xsi) {
    $is_auto = 'From:' . $rfc2822_from[0];
  }
  if (defined $is_mlist) {
    $is_bulk = $is_mlist;
  } elsif (defined $is_auto) {
    $is_bulk = $is_auto;
  } elsif (defined $is_bulk) {
    # already set
  } elsif ($rfc2822_from[0] =~  # just checks the first author, good enough
             /^ (?: [^\@]+ -relay | postmaster | uucp ) (?: \@ | \z )/xsi) {
    $is_bulk = 'From:' . $rfc2822_from[0];
  }
  $is_mlist = 1  if defined $is_mlist && !$is_mlist;  # make sure it is true
  $is_auto  = 1  if defined $is_auto  && !$is_auto;   # make sure it is true
  $is_bulk  = 1  if defined $is_bulk  && !$is_bulk;   # make sure it is true
  $msginfo->is_mlist($is_mlist)  if defined $is_mlist;
  $msginfo->is_auto($is_auto)    if defined $is_auto;
  $msginfo->is_bulk($is_bulk)    if defined $is_bulk;

  # now that we have a parsed From, check if we have a valid author signature
  # and do other DKIM pre-processing
  my(@bank_names, %bank_names, %bn_auth_already_queried);
  my($atpbm) = ca('author_to_policy_bank_maps');
  my(@signatures_valid);
  my($sigs_ref) = $msginfo->dkim_signatures_all;
  my($sig_ind) = 0;  # index of a signature in a signature array
  for my $sig (!defined($sigs_ref) ? () : @$sigs_ref) {  # for each signature
    my($valid) = lc($sig->result) eq 'pass';
    my($expiration_time) = $sig->expiration;
    my($expired) =
      defined $expiration_time && $expiration_time =~ /^\d{1,12}\z/ &&
      $msginfo->rx_time > $expiration_time;
    my($timestamp_age); my($creation_time);
    if (!$sig->isa('Mail::DKIM::DkSignature')) {
      $creation_time = $sig->timestamp;  # method only implemented for DKIM sig
      $timestamp_age = $msginfo->rx_time - $creation_time
        if defined $creation_time && $creation_time =~ /^\d{1,12}\z/;
    }
    local($1,$2);
    my($identity) = $sig->identity;  # already QP-decoded since 0.32
    $identity = $1 . lc($2)  if defined $identity &&
                                $identity =~ /^(.*)(\@[^\@]*)\z/s;
    # See if a signature matches address in any of the sender/author fields.
    # In the absence of an explicit Sender header field, the first author
    # acts as the 'agent responsible for the transmission of the message'.
    my(@addr_list) = ($msginfo->sender,
                  defined $rfc2822_sender ? $rfc2822_sender : $rfc2822_from[0],
                  @rfc2822_from);
    for my $addr (@addr_list) {
      $addr = $1 . lc($2)  if defined $addr && $addr =~ /^(.*)(\@[^\@]*)\z/s;
    }
    # turn addresses in @addr_list into booleans, representing a match success
    # ADSP+RFC5321: localpart is case sensitive, domain is case insensitive
    if ($identity =~ /.\@[^\@]*\z/s) {  # identity has a localpart
      for (@addr_list) { if (defined) { $_ = $_ eq $identity } }
    } else {  # ignore localpart if identity doesn't have a localpart
      for (@addr_list) {
        if (defined) { /(\@[^\@]*)?\z/s; $_ = $1 eq $identity }
      }
    }
    # label which header fields are covered by each signature;
    # doesn't work for old DomainKeys signatures where h may be missing
    # and where recurring header fields may only be listed once
    my(@signed_header_field_names) = map { lc($_) } $sig->headerlist; # 'h' tag
    { my(%field_counts);
      $field_counts{$_}++  for @signed_header_field_names;
      for (my $j=-1;  ; $j--) {   # walk through header fields, bottom-up
        my($f_ind,$f_name,$fld) = $msginfo->get_header_field(undef,$j);
        last if !defined $f_ind;  # reached the top
        if ($field_counts{$f_name} > 0) { # header field is covered by this sig
          $msginfo->header_field_signed_by($f_ind,$sig_ind);  # store sig index
          $field_counts{$f_name}--;
        }
      }
    }
    if ($valid && !$expired) {
      push(@signatures_valid, $sig);
      my($sig_domain) = $sig->domain;
      $sig_domain = '?'  if !$sig_domain;  # make sure it is true as a boolean
      #
      # note that only the author signature (based on rfc2822.From) is a valid
      # concept in DKIM/ADSP; we are also using the same rules to match against
      # rfc2822.Sender and envelope sender address, but results are only of
      # informational/curiosity interest and deeper significance must not be
      # attributed to dkim_envsender_sig and dkim_sender_sig!
      #
      $msginfo->dkim_envsender_sig($sig_domain)  if $addr_list[0];
      $msginfo->dkim_sender_sig($sig_domain)     if $addr_list[1];
      $msginfo->dkim_author_sig($sig_domain)
        if grep { $_ } @addr_list[2..$#addr_list];  # identity matches addr
      $msginfo->dkim_thirdparty_sig($sig_domain) if !$msginfo->dkim_author_sig;
      if (@$atpbm) {  # any author to policy bank name mappings?
        for my $j (0..$#rfc2822_from) {  # for each author (usually only one)
          my($key) = $rfc2822_from[$j];
          # query key: as-is author address for author signatures, and
          # author address with '/@signer-domain' appended for 3rd party sign.
          # e.g.: 'user@example.com', 'user@sub.example.com/@example.org'
          for my $opt ( ($addr_list[$j+2] ? '' : ()), '/@'.lc($sig->domain) ) {
            next  if $bn_auth_already_queried{$key.$opt};
            my($result,$matchingkey) = lookup2(0,$key,$atpbm,
                       Label=>'AuthToPB', $opt eq '' ? () : (AppendStr=>$opt));
            $bn_auth_already_queried{$key.$opt} = 1;
            if ($result) {
              if ($result eq '1') {
                # a handy usability trick to supply a hardwired policy bank
                # name when acl-style lookup table is used, which can only
                # return a boolean (undef, 0, or 1)
                $result = 'AUTHOR_APPROVED';
              }
              # $result is a list of policy banks as a comma-separated string
              my(@pbn);  # collect list of newly encountered policy bank names
              for (map { s/^[ \t]+//; s/[ \t]+\z//; $_ } split(/,/,$result)) {
                next  if $_ eq '' || $bank_names{$_};
                push(@pbn,$_); $bank_names{$_} = 1;
              }
              if (@pbn) {
                push(@bank_names,@pbn);
                ll(2) && do_log(2, "dkim: policy bank %s by %s",
                                   join(',',@pbn), $matchingkey);
              }
            }
          }
        }
      }
    }
    if (ll(5)) {
      my($pubkey);
      # Mail::DKIM >=0.31 caches result;  it can die with "not available"
      eval { $pubkey = $sig->get_public_key };
      if (!$pubkey) {
        do_log(5, "dkim: no public key s=%s d=%s",$sig->selector,$sig->domain);
      } else {
        do_log(5, "dkim: public key s=%s d=%s (testing=%d) f=%s n=\"%s\"",
                  $sig->selector, $sig->domain,
                  $pubkey->testing, $pubkey->flags, $pubkey->notes);
      }
    }
    ll(2) && do_log(2, "dkim: %s%s%s %s signature by i=%s, From: %s, ".
                       "a=%s, c=%s, s=%s, d=%s%s%s%s",
      $valid  ? 'VALID' : 'FAILED',  $expired ? ', EXPIRED' : '',
      $timestamp_age >= -1 ? ''
        : ', IN_FUTURE:('.format_time_interval(-$timestamp_age).')',
      join('+', (map { $_ ? 'Author' : () } @addr_list[2..$#addr_list]),
                $addr_list[1] ? 'Sender'   : (),
                $addr_list[0] ? 'MailFrom' : (),
                !(grep {$_} @addr_list) ? 'third-party' : ()),
      $identity, join(", ", qquote_rfc2821_local(@rfc2822_from)),
      $sig->algorithm, scalar($sig->canonicalization),
      $sig->selector, $sig->domain,
      !$msginfo->originating ? ''
        : ', ORIG ['.$msginfo->client_addr.':'.$msginfo->client_port.']',
      !defined($msginfo->is_mlist) ? '' : ", m.list(".$msginfo->is_mlist.")",
      $valid ? '' : ', '.$sig->result_detail,
    );
    $sig_ind++;
  }
  if (@bank_names) {
    @bank_names = grep { defined $policy_bank{$_} } unique_list(\@bank_names);
    if (@bank_names) {
      Amavis::load_policy_bank($_)  for @bank_names;
      $msginfo->originating(c('originating'));  # may have changed
    }
  }
  $msginfo->dkim_signatures_valid(\@signatures_valid)  if @signatures_valid;
# if (ll(5) && $sig_ind > 0) {
#   # show which header fields are covered by which signature
#   for (my $j=0; ; $j++) {
#     my($f_ind,$f_name,$fld) = $msginfo->get_header_field(undef,$j);
#     last if !defined $f_ind;
#     my(@sig_ind) = $msginfo->header_field_signed_by($f_ind);
#     do_log(5, "dkim: %-5s %s.", !@sig_ind ? '' : '['.join(',',@sig_ind).']',
#               substr($fld,0,54));
#   }
# }
  if ($sender ne '') {  # provide some initial default for sender_credible
    my(@cred) = ( $msginfo->originating        ? 'orig' : (),
                  $msginfo->dkim_envsender_sig ? 'dkim' : () );
    $msginfo->sender_credible(join(",",@cred))  if @cred;
  }
}

# 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($which_section) = 'check_init';  my(%elapsed,$t0_sect);
  $elapsed{'TimeElapsedReceiving'} = Time::HiRes::time - $msginfo->rx_time;
  my($point_of_no_return) = 0;  # past the point where mail or DSN was sent
  my($am_id) = $msginfo->log_id;
  if (!defined($am_id)) { $am_id = am_id(); $msginfo->log_id($am_id) }
  $snmp_db->register_proc(1,0,'=',$am_id)  if defined $snmp_db;  # check begins
  my($smtp_resp, $exit_code, $preserve_evidence);
  my($mail_id, $custom_object);
  my($hold);     # set to some string causes 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.
  # 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
  if (defined $last_task_completed_at) {
    my($dt) = $msginfo->rx_time - $last_task_completed_at;
    do_log(3,"smtp connection cache, dt: %.1f, state: %d",
             $dt, $smtp_connection_cache_enable);
    if (!$smtp_connection_cache_on_demand) {}
    elsif (!$smtp_connection_cache_enable && $dt < 5) {
      do_log(3,"smtp connection cache, dt: %.1f -> enabling", $dt);
      $smtp_connection_cache_enable = 1;
    } elsif ($smtp_connection_cache_enable && $dt >= 15) {
      do_log(3,"smtp connection cache, dt: %.1f -> disabling", $dt);
      $smtp_connection_cache_enable = 0;
    }
  }

  # ugly - save in a global to make it accessible to %builtins
  $MSGINFO = $msginfo;
  eval {
    $msginfo->add_contents_category(CC_CLEAN,0);  # CC_CLEAN is always present
    $_->add_contents_category(CC_CLEAN,0)  for @{$msginfo->per_recip_data};
    $msginfo->header_edits(Amavis::Out::EditHeader->new);
    add_entropy(Time::HiRes::gettimeofday, $child_task_count, $am_id,
                $msginfo->queue_id, $msginfo->mail_text_fn, $msginfo->sender);
    section_time($which_section);

    $which_section = 'check_init2';
    # compute body digest, measure mail size, check for 8-bit data, add entropy
  # get_body_digest($msginfo, 'SHA-1');
    get_body_digest($msginfo, 'MD5');

    $which_section = 'check_init3';
    collect_some_info($msginfo);
    my($mail_size) = $msginfo->msg_size;  # use corrected ESMTP size
    if (!defined($msginfo->client_addr)) {  # fetch missing address from header
      my($ip) = parse_ip_address_from_received($msginfo,1);
      do_log(3,"client IP address unknown, fetching from Received: %s", $ip);
      $msginfo->client_addr($ip);
    }

    $which_section = 'check_init4';
    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 var
    my($parts_root) = Amavis::Unpackers::Part->new;
    $msginfo->parts_root($parts_root);
  # section_time($which_section);

    $which_section = 'gen_mail_id';
    $snmp_db->register_proc(2,0,'G',$am_id)  if defined $snmp_db; # gen mail_id
    # create unique mail_id and save preliminary info. to SQL (if enabled)
    for (my($attempt)=5;;) {  # 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 a long-term unique id to the msg
      if (!$sql_storage) {
        last;  # no need to store and no way to check for uniqueness
      } else {
        # attempt to save a 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");
          last;
        } else {
          snmp_count('GenMailIdRetries');
          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);

    $which_section = "custom-new";
    eval {
      my($old_orig) = c('originating');
      # may load policy banks
      $custom_object = Amavis::Custom->new($conn,$msginfo);
      my($new_orig) = c('originating');  # may have changed by a p.b.load
      $msginfo->originating($new_orig)  if ($old_orig?1:0) != ($new_orig?1:0);
      1;
    } or do {
      undef $custom_object;
      my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(-1,"custom new err: %s", $eval_stat);
    };
    if (ref $custom_object) {
      do_log(5,"Custom hooks enabled"); section_time($which_section);
    }

    my($cl_ip) = $msginfo->client_addr;
    my($os_fingerprint_obj,$os_fingerprint);
    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 {  # launch a query
      $which_section = "os_fingerprint";
      my($dst) = c('os_fingerprint_dst_ip_and_port');
      my($dst_ip,$dst_port); local($1,$2,$3);
      ($dst_ip,$dst_port) = ($1.$2, $3)  if defined($dst) &&
                      $dst =~ m{^(?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) }six;
      $os_fingerprint_obj = Amavis::OS_Fingerprint->new(
        dynamic_destination($os_fingerprint_method,$conn,0),
        0.050, $cl_ip, $msginfo->client_port, $dst_ip, $dst_port, $mail_id);
    }
    my($sender) = $msginfo->sender;
    my(@recips) = map { $_->recip_addr } @{$msginfo->per_recip_data};
    my($rfc2822_sender) = $msginfo->rfc2822_sender;
    my($fm) = $msginfo->rfc2822_from;
    my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
    $mail_size = $msginfo->msg_size;  # refresh after custom hook, just in case
    add_entropy("$cl_ip $mail_size $sender", \@recips);
    if (ll(1)) {
      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)) );
    }
    if (ll(3)) {
      my($envsender) = qquote_rfc2821_local($sender);
      my($hdrsender) = qquote_rfc2821_local($rfc2822_sender),
      my($hdrfrom)   = qquote_rfc2821_local(@rfc2822_from);
      do_log(3,"2822.From: %s%s%s", $hdrfrom,
               !defined($rfc2822_sender) ? '' : ", 2822.Sender: $hdrsender",
               defined $rfc2822_sender && $envsender eq $hdrsender ? ''
               : $envsender eq $hdrfrom ? '' : ", 2821.Mail_From: $envsender");
    }

    my($cnt_local) = 0; my($cnt_remote) = 0;
    for my $r (@{$msginfo->per_recip_data}) {
      my($recip) = $r->recip_addr;
      my($is_local) = lookup2(0,$recip, ca('local_domains_maps'));
      $is_local ? $cnt_local++ : $cnt_remote++;
      $r->recip_is_local($is_local);
      if (!defined($r->bypass_virus_checks)) {
        my($bypassed_v) = lookup2(0,$recip, ca('bypass_virus_checks_maps'));
        $r->bypass_virus_checks($bypassed_v);
      }
      if (!defined($r->bypass_banned_checks)) {
        my($bypassed_b) = lookup2(0,$recip, ca('bypass_banned_checks_maps'));
        $r->bypass_banned_checks($bypassed_b);
      }
      if (!defined($r->bypass_spam_checks)) {
        my($bypassed_s) = lookup2(0,$recip, ca('bypass_spam_checks_maps'));
        $r->bypass_spam_checks($bypassed_s);
      }
#     if (defined $user_id_sql) {   #(for future version)
#       my($user_id_ref,$mk_ref) =  # list of all id's that match
#         lookup2(1, $recip, [$user_id_sql], Label=>"users.id");
#       $r->user_id($user_id_ref)  if ref $user_id_ref;  # listref or undef
#     }
#     if (defined $user_policy_id_sql) {
#       my($user_policy_id) = lookup2(0, $recip, [$user_policy_id_sql],
#                                     Label=>"users.policy_id");
#       $r->user_policy_id($user_policy_id);  # just the first match
#     }
    }
    # update message count and mesage size snmp counters
    # orig local
    #   0   0  InMsgsOpenRelay
    #   0   1  InMsgsInbound
    #   0   x  (non-originating: inbound or open relay)
    #   1   0  InMsgsOutbound
    #   1   1  InMsgsInternal
    #   1   x  InMsgsOriginating (outbound or internal)
    #   x   0  (departing: outbound or open relay)
    #   x   1  (local: inbound or internal)
    #   x   x  InMsgs
    snmp_count('InMsgs');
    snmp_count('InMsgsBounceNullRPath')  if $sender eq '';
    snmp_count( ['InMsgsRecips', $cnt_local+$cnt_remote]); # recipients count
    snmp_count( ['InMsgsSize', $mail_size, 'C64'] );
    if ($msginfo->originating) {
      snmp_count('InMsgsOriginating');
      snmp_count( ['InMsgsRecipsOriginating', $cnt_local+$cnt_remote]);
      snmp_count( ['InMsgsSizeOriginating', $mail_size, 'C64'] );
    }
    if ($cnt_local > 0) {
      my($d) = $msginfo->originating ? 'Internal' : 'Inbound';
      snmp_count('InMsgs'.$d);
      snmp_count( ['InMsgsRecips'.$d,   $cnt_local]);
      snmp_count( ['InMsgsRecipsLocal', $cnt_local]);
      snmp_count( ['InMsgsSize'.$d, $mail_size, 'C64'] );
    }
    if ($cnt_remote > 0) {
      my($d) = $msginfo->originating ? 'Outbound' : 'OpenRelay';
      snmp_count('InMsgs'.$d);
      snmp_count( ['InMsgsRecips'.$d, $cnt_remote]);
      snmp_count( ['InMsgsSize'.$d, $mail_size, 'C64'] );
      if (!$msginfo->originating) {
        do_log(1,'Open relay? Nonlocal recips but not originating: %s',
                 join(', ',map { $_->recip_addr } grep { !$_->recip_is_local }
                               @{$msginfo->per_recip_data}));
      }
    }

    # mkdir can be 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($tempdir) = $msginfo->mail_tempdir;
      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 and is accessible
      chdir($tempdir) or die "Can't chdir to $tempdir: $!";
    }

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

    my($virus_presence_checked,$spam_presence_checked);
    my($virus_dejavu) = 0;

    # already in cache?
    $which_section = "cached";
    snmp_count('CacheAttempts');
    my($cache_entry); my($now) = Time::HiRes::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);
    my($body_digest) = $msginfo->body_digest;
    $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 a mail header section
      # too, not only by a 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'};
        my($spam_level,$spam_status,$spam_report,$spam_summary,
           $crm114_status,$crm114_cacheid) =
          @$cache_entry{'SL','SS','SR','SY','SCT','SCI'};
        $msginfo->spam_level($spam_level);
        $msginfo->spam_status($spam_status);
        $msginfo->spam_report($spam_report);
        $msginfo->spam_summary($spam_summary);
        $msginfo->supplementary_info('CRM114STATUS',
                                   $crm114_status)  if defined $crm114_status;
        $msginfo->supplementary_info('CRM114CACHEID',
                                   $crm114_cacheid) if defined $crm114_cacheid;
      }
      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 >= 5;  # 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'} );
    }  # end  if defined $cache_entry

    my($will_do_virus_scanning, $all_bypass_virus_checks);
    if ($extra_code_antivirus) {
      $all_bypass_virus_checks =
         !grep {!$_->bypass_virus_checks} @{$msginfo->per_recip_data};
      $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');

    my($bounce_header_fields_ref,$bounce_msgid,$bounce_type);

    if (c('bypass_decode_parts')) {
      do_log(5, "decoding bypassed");
    } elsif (!$will_do_virus_scanning && !$will_do_banned_checking &&
             c('bounce_killer_score') <= 0) {
      do_log(5, "decoding not needed");
    } else {
      # decoding parts can take a lot of time
      $which_section = "mime_decode-1";
      $snmp_db->register_proc(2,0,'D',$am_id)  if defined $snmp_db;  # decoding
      $t0_sect = Time::HiRes::time;
      $mime_err = ensure_mime_entity($msginfo)
        if !defined($msginfo->mime_entity);
      prolong_timer($which_section);

      if (c('bounce_killer_score') > 0) {
        $which_section = "dsn_parse";
        # analyze a bounce after MIME decoding but before further archive
        # decoding (which often replaces original MIME parts by decoded files)
        eval {  # just in case
          ($bounce_header_fields_ref,$bounce_type) =
            inspect_a_bounce_message($msginfo);
          1;
        } or do {
          my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
          do_log(-1, "inspect_a_bounce_message failed: %s", $eval_stat);
        };
        $bounce_msgid = $bounce_header_fields_ref->{'message-id'}
          if $bounce_header_fields_ref &&
             exists $bounce_header_fields_ref->{'message-id'};
        prolong_timer($which_section);
      }

      $which_section = "parts_decode_ext";
      snmp_count('OpsDec');
      ($hold,$any_undecipherable) =
        Amavis::Unpackers::decompose_mail($msginfo->mail_tempdir,
                                          $file_generator_object);
      if ($hold ne '' || $any_undecipherable) {
        $msginfo->add_contents_category(CC_UNCHECKED,0);
        for my $r (@{$msginfo->per_recip_data}) {
          $r->add_contents_category(CC_UNCHECKED,0)
            if !$r->bypass_virus_checks;
        }
      }
      $elapsed{'TimeElapsedDecoding'} = Time::HiRes::time - $t0_sect;
    }

    my($bphcm) = ca('bypass_header_checks_maps');
    if (grep {!lookup2(0,$_->recip_addr,$bphcm)} @{$msginfo->per_recip_data}) {
      $which_section = "check_header";
      my($allowed_tests) = cr('allowed_header_tests');
      my($allowed_mime_test) = $allowed_tests && $allowed_tests->{'mime'};
      # check for bad headers and for bad MIME subheaders / bad MIME structure
      if ($allowed_mime_test && 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) = lookup2(0,$r->recip_addr,$bphcm);
        if (!$bypassed && $allowed_mime_test &&
            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) }
      }
      section_time($which_section);
    }

    if ($will_do_banned_checking) {      # check for banned file contents
      $which_section = "check-banned";
      check_for_banned_names($msginfo);  # saves results in $msginfo
      $banned_filename_any = 0; $banned_filename_all = 1;
      for my $r (@{$msginfo->per_recip_data}) {
        next  if $r->bypass_banned_checks;
        my($a) = $r->banned_parts;
        if (!defined $a || !@$a) {
          $banned_filename_all = 0;
        } else {
          my($rhs) = $r->banning_rule_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 = 1;
          $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???") }
      $mime_err = ensure_mime_entity($msginfo)
        if !defined($msginfo->mime_entity) && !c('bypass_decode_parts');
      # special case to make available a complete mail file for inspection
      if ((defined($mime_err) && $mime_err ne '') ||
          !defined($msginfo->mime_entity) ||
          lookup2(0,'MAIL',\@keep_decoded_original_maps) ||
          $any_undecipherable && lookup2(0,'MAIL-UNDECIPHERABLE',
                                         \@keep_decoded_original_maps)) {
        # keep the email.txt by making a hard link to it in ./parts/
        $which_section = "linking-to-MAIL";
        my($tempdir) = $msginfo->mail_tempdir;
        my($newpart_obj) =
          Amavis::Unpackers::Part->new("$tempdir/parts",$parts_root,1);
        my($newpart) = $newpart_obj->full_name;
        do_log(3, "presenting 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');  # case sensitive
        $newpart_obj->type_declared('message/rfc822');
      }
      $which_section = "virus_scan";
      $snmp_db->register_proc(2,0,'V',$am_id) if defined $snmp_db; # virus scan
      my($av_ret);  $t0_sect = Time::HiRes::time;
      eval {
        my($vn, $ds);
        ($av_ret, $av_output, $vn, $ds) =
          Amavis::AV::virus_scan($conn,$msginfo, $child_task_count==1);
        @virusname = @$vn; @detecting_scanners = @$ds;  # copy
        1;
      } or do {
        $@ = "errno=$!"  if $@ eq '';  chomp $@;
        if ($@ =~ /^timed out\b/) {  # not supposed to happen
          @virusname = (); $av_ret = 0;  # assume not a virus!
          do_log(-1, "virus_scan TIMED OUT, ASSUME NOT A VIRUS !!!");
        } else {
          $hold = "AV: $@";          # request HOLD
          $av_ret = 0;               # pretend it was ok (msg should be held)
          die "$hold\n";             # die, TEMPFAIL is preferred to HOLD
        }
      };
      $elapsed{'TimeElapsedVirusCheck'} = Time::HiRes::time - $t0_sect;
      snmp_count('OpsVirusCheck');
      defined($av_ret) or die "All virus scanners failed!";
      @$cache_entry{'Vt','VO','VN','VD'} =
        (int($now), $av_output, \@virusname, \@detecting_scanners);
      if (defined($msginfo->spam_level)) { #also spam results if provided by av
        @$cache_entry{'St','SL','SS','SR','SY'} =
          (int($now), $msginfo->spam_level, $msginfo->spam_status,
           $msginfo->spam_report, $msginfo->spam_summary);
      }
      $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) {
      for my $r (@{$msginfo->per_recip_data}) {
        my($bypassed) = $r->bypass_virus_checks;
        $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;
    $msginfo->virusnames([@virusname])  if @virusname;  # copy names to object
    { my($sender_contact,$sender_source);
      if (!@virusname) { $sender_contact = $sender_source = $sender }
      else {
        ($sender_contact,$sender_source) = best_try_originator($msginfo);
        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 (c('policy_bank_path') =~ m{(^|/)MYNETS(/|\z)})
      # if ($msginfo->client_addr_mynets)
        if ($msginfo->originating)
          { $os_fingerprint = 'MYNETWORKS' }  # blank-out our smtp clients info
        $msginfo->client_os_fingerprint($os_fingerprint);  # store info
      }
    }
    chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";

    my($bypass_spam_checks_by_bounce_killer) = 0;
    if (!$bounce_header_fields_ref) {
      # not a bounce
    } elsif ($msginfo->originating) {
      # rescued by originating
    } elsif (defined($bounce_msgid) && $bounce_msgid =~ /(\@[^\@>]+)>?\z/ &&
             lookup2(0,$1, ca('local_domains_maps'))) {
      # rescued by a local domain in referenced Message-ID
    } elsif (c('bounce_killer_score') > 20) {
      $bypass_spam_checks_by_bounce_killer = 1;
    }

    # consider doing spam scanning
    if (!$extra_code_antispam) {
      do_log(5, "no anti-spam code loaded, skipping spam_scan");
    } elsif ($bypass_spam_checks_by_bounce_killer) {
      do_log(5, "bypassing of spam checks by a bounce killer");
    } elsif (!grep {!$_->bypass_spam_checks} @{$msginfo->per_recip_data}) {
      do_log(5, "bypassing of spam checks requested for all recips");
    } else {
      # preliminary test - would a message be allowed to pass for any recipient
      # based on evidence collected so far (virus, banned)
      my($any_pass) = 0; my($prelim_blocking_ccat);
      for my $r (@{$msginfo->per_recip_data}) {
        my($final_destiny) = D_PASS;
        my(@fd_tuples) = $r->setting_by_main_contents_category_all(
                       cr('final_destiny_by_ccat'), cr('lovers_maps_by_ccat'));
        for my $tuple (@fd_tuples) {
          my($cc, $fd, $lovers_map_ref) = @$tuple;
          if (!defined($fd) || $fd == D_PASS) {
          } elsif (defined($lovers_map_ref) &&
                   lookup2(0, $r->recip_addr, $lovers_map_ref,
                           Label=>'Lovers1')) {
          } else {
            $prelim_blocking_ccat = $cc; $final_destiny = $fd;
            last;
          }
        }
        $any_pass = 1  if $final_destiny == D_PASS;
      }
      if (!$any_pass) {
        do_log(5, "bypassing of spam checks, message will be blocked anyway ".
                  "due to %s", $prelim_blocking_ccat);
      } 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";
          $snmp_db->register_proc(2,0,'S',$am_id)  if defined $snmp_db;
          $t0_sect = Time::HiRes::time;
          # sets $msginfo->spam_level, spam_status,
          #      spam_report, spam_summary, supplementary_info
          $spamcontrol_obj->spam_scan($conn,$msginfo)  if $spamcontrol_obj;
          prolong_timer($which_section);
          $elapsed{'TimeElapsedSpamCheck'} = Time::HiRes::time - $t0_sect;
          snmp_count('OpsSpamCheck');
          @$cache_entry{'St','SL','SS','SR','SY','SCT','SCI'} =
            (int($now), $msginfo->spam_level, $msginfo->spam_status,
             $msginfo->spam_report, $msginfo->spam_summary,
             $msginfo->supplementary_info('CRM114STATUS'),
             $msginfo->supplementary_info('CRM114CACHEID'));
          $spam_presence_checked = 1;
        }
      }
    }

    if (ref $custom_object) {
      $which_section = "custom-checks";
      eval {
        $custom_object->checks($conn,$msginfo); 1;
      } or do {
        my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        do_log(-1,"custom checks error: %s", $eval_stat);
      };
      section_time($which_section);
    }
    # 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;

    my(@sa_tests,%sa_tests);
    { my($tests) = $msginfo->supplementary_info('TESTS');
      if (defined($tests) && $tests ne 'none') {
        @sa_tests = $tests =~ /([^=,;]+)(?==)/g;
        %sa_tests = map { ($_,1) } @sa_tests;
      }
    }

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

    Amavis::DKIM::adjust_score_by_signer_reputation($msginfo)
      if $enable_dkim_verification;

    $which_section = "penpals_check";
    my($pp_age);
    my($spam_level) = $msginfo->spam_level;
    if (defined $sql_storage && !$msginfo->is_in_contents_category(CC_VIRUS)) {
      my($pp_bonus) = c('penpals_bonus_score');  # score points
      my($pp_halflife) = c('penpals_halflife');  # seconds
      my(@boost_list);
      @boost_list = map {$_->recip_score_boost} @{$msginfo->per_recip_data}
        if $pp_bonus > 0 && $pp_halflife > 0 &&
           (defined $penpals_threshold_low || defined $penpals_threshold_high);
      if ($pp_bonus <= 0 || $pp_halflife <= 0) {
        # penpals disabled
      } elsif (defined($penpals_threshold_low)  && !defined($bounce_msgid) &&
               $spam_level + max(@boost_list) < $penpals_threshold_low) {
        # low score for all recipients, no need for aid
        do_log(5,"penpals: low score, no need for penpals aid");
      } elsif (defined($penpals_threshold_high) && !defined($bounce_msgid) &&
               $spam_level + min(@boost_list) - $pp_bonus
                                              > $penpals_threshold_high) {
        # spam, can't get below threshold_high even under best circumstances
        do_log(5,"penpals: high score, penpals won't help");
      } elsif ($sender ne '' && !$msginfo->originating &&
               lookup2(0,$sender, ca('local_domains_maps'))) {
        # no bonus to unauthent. senders from outside claiming a local domain
        do_log(5,"penpals: local sender from outside, ignored: %s", $sender);
      } else {
        $t0_sect = Time::HiRes::time;
        $snmp_db->register_proc(2,0,'P',$am_id) if defined $snmp_db;  # penpals
        my($sid) = $msginfo->sender_maddr_id;
        for my $r (@{$msginfo->per_recip_data}) {
          next  if $r->recip_done;  # already dealt with
          my($recip) = $r->recip_addr;
          my($rid) = $r->recip_maddr_id;
          if (defined($rid) && $sid ne $rid && $r->recip_is_local) {
            # inbound or internal_to_internal, except self_to_self
            my($refs_str) = $msginfo->get_header_field_body('in-reply-to') .
                            $msginfo->get_header_field_body('references');
            my(@refs) = $refs_str eq '' ? () : parse_message_id($refs_str);
            push(@refs,$bounce_msgid)  if defined $bounce_msgid &&
                                          $bounce_msgid ne '';
            do_log(4,"penpals: references: %s", join(", ",@refs))  if @refs;
            # NOTE: swap $rid and $sid as args here, as we are now checking
            # for a potential reply mail - whether the current recipient has
            # recently sent any mail to the sender of the current mail:
            my($pp_mail_id,$pp_subj);
            ($pp_age,$pp_mail_id,$pp_subj) =
              $sql_storage->penpals_find($rid,$sid,\@refs,$msginfo->rx_time);
            if (defined $pp_age) {  # found info about previous correspondence
              $r->recip_penpals_age($pp_age);  # save the information
              my($weight) = exp(-($pp_age/$pp_halflife) * log(2));
              # weight is a factor between 1 and 0, representing
              # exponential decay: weight(t) = 1 / 2^(t/halflife)
              # i.e. factors 1, 1/2, 1/4, 1/8... at age 0, hl, 2*hl, 3*hl...
              my($boost) = $r->recip_score_boost;
              my($adj) = $weight * $pp_bonus;  $boost -= $adj;
              $r->recip_score_boost($boost);  # save adjusted result to object
              $r->recip_penpals_score(-$adj);
              if (ll(2)) {
                do_log(2,"penpals: bonus %.3f, age %s (%d), ".
                       "SA score %.3f, <%s> replying to <%s>, ref mail_id: %s",
                       $adj, format_time_interval($pp_age), $pp_age,
                       $spam_level, $sender,$recip, $pp_mail_id);
                my($this_subj) = $msginfo->get_header_field_body('subject');
                $this_subj = $1  if $this_subj =~ /^\s*(.*?)\s*$/;
                do_log(2,"penpals: prev Subject: %s", $pp_subj);
                do_log(2,"penpals: this Subject: %s", $this_subj);
              }
            }
          }
        }
        section_time($which_section);
        $elapsed{'TimeElapsedPenPals'} = Time::HiRes::time - $t0_sect;
      }
    }

    $which_section = "bounce_killer";
    if ($bounce_header_fields_ref) {  # message looks like a DSN
      snmp_count('InMsgsBounce');
      my($bounce_rescued);
      if (defined $pp_age && $pp_age < 8*24*3600) {  # less than 8 days ago
        # found by pen pals by a Message-ID in attachment and recip. address;
        # is a bounce, refers to our previous outgoing message, treat it kindly
        snmp_count('InMsgsBounceRescuedByPenPals');
        $bounce_rescued = 'by penpals';
      } elsif ($msginfo->originating) {
        snmp_count('InMsgsBounceRescuedByOriginating');
        $bounce_rescued = 'by originating';
      } elsif (defined($bounce_msgid) && $bounce_msgid =~ /(\@[^\@>]+)>?\z/ &&
               lookup2(0,$1, ca('local_domains_maps'))) {
        # not in pen pals, but domain in Message-ID is a local domain;
        # it is only useful until spamers figure out the trick,
        # then it should be disabled
        snmp_count('InMsgsBounceRescuedByDomain');
        $bounce_rescued = 'by domain';
      } elsif (!defined($sql_storage) ||
               c('penpals_bonus_score') <= 0 || c('penpals_halflife') <= 0) {
        $bounce_rescued = 'by: pen pals disabled';
      }
      ll(2) && do_log(2, "bounce %s (%s), %s -> %s, %s",
                 defined $bounce_rescued ?'rescued '.$bounce_rescued :'killed',
                 $bounce_type, qquote_rfc2821_local($sender),
                 join(',', qquote_rfc2821_local(@recips)),
                 join(', ', map { $_ . ': ' . $bounce_header_fields_ref->{$_} }
                      sort( grep { /^(?:From|Return-Path|Message-ID|Date)\z/i }
                            keys %$bounce_header_fields_ref)) );
      if (!$bounce_rescued) {
        snmp_count('InMsgsBounceKilled');
        my($bounce_killer_score) = c('bounce_killer_score');
        for my $r (@{$msginfo->per_recip_data}) {
          my($boost) = $r->recip_score_boost || 0;
          $r->recip_score_boost($boost + $bounce_killer_score);
        }
      }
    } elsif ($msginfo->is_auto ||
             $sender          =~ /^postmaster(?:\@|\z)/si ||
             $rfc2822_from[0] =~ /^postmaster(?:\@|\z)/si ||
             $sa_tests{'ANY_BOUNCE_MESSAGE'} ) {
      # message could be some kind of non-standard bounce or autoresponse, but
      # lacks recognizable structure and a header section from original mail
      ll(2) && do_log(2, "bounce unverifiable%s, %s -> %s",
                         !$msginfo->originating ? '' : ', originating',
                         qquote_rfc2821_local($sender),
                         join(',', qquote_rfc2821_local(@recips)));
      snmp_count('InMsgsBounce'); snmp_count('InMsgsBounceUnverifiable');
    }

    $which_section = "decide_mail_destiny";
    $snmp_db->register_proc(2,0,'r',$am_id)  if defined $snmp_db;  # results...
    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 or CC_SPAMMY 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($tag_level,$tag2_level,$tag3_level,$kill_level);
      my($bypassed) = $r->bypass_spam_checks;
      if (!$bypassed) {
        $tag_level  = lookup2(0,$recip, ca('spam_tag_level_maps'));
        $tag2_level = lookup2(0,$recip, ca('spam_tag2_level_maps'));
        $tag3_level = lookup2(0,$recip, ca('spam_tag3_level_maps'));
        $kill_level = lookup2(0,$recip, ca('spam_kill_level_maps'));
      }
      my($blacklisted) = $r->recip_blacklisted_sender;
      my($whitelisted) = $r->recip_whitelisted_sender;
      my($boost)       = $r->recip_score_boost;
      $boost = 0  if !defined $boost;  # avoid uninitialized value warning
      # penpals_score is already accounted for in recip_score_boost,
      # it is provided here separately for informational/logging purposes
      my($penpals_score) = $r->recip_penpals_score;  # is zero or negative!
      my($do_tag) = !$bypassed && (
                     $blacklisted || !defined $tag_level || $tag_level eq '' ||
                    ($spam_level+$boost + ($whitelisted?-10:0) >= $tag_level));
      my($do_tag2,$do_tag3,$do_kill) =
        map { !$bypassed && !$whitelisted &&
              ($blacklisted || (defined($_) && $spam_level+$boost >= $_) ) }
            ($tag2_level,$tag3_level,$kill_level);
      $do_tag2 = $do_tag2 || $do_tag3;  # tag3 implies tag2, just in case

      if ($do_tag) {   # spaminess is at or above tag level
        $msginfo->add_contents_category(CC_CLEAN,1);
        $r->add_contents_category(CC_CLEAN,1)  if !$bypassed;
      }
      if ($do_tag2) {  # spaminess is at or above tag2 level
        $msginfo->add_contents_category(CC_SPAMMY);
        $r->add_contents_category(CC_SPAMMY)   if !$bypassed;
      }
      if ($do_tag3) {  # spaminess is at or above tag3 level
        $msginfo->add_contents_category(CC_SPAMMY,1);
        $r->add_contents_category(CC_SPAMMY,1) if !$bypassed;
      }
      if ($do_kill) {  # spaminess is at or above kill level
        $msginfo->add_contents_category(CC_SPAM,0);
        $r->add_contents_category(CC_SPAM,0)   if !$bypassed;
      }
      # consider adding CC_OVERSIZED to the contents_category list;
      if (@$mslm) {  # checking of mail size is needed?
        my($size_limit) = lookup2(0,$r->recip_addr,$mslm);
        if ($enforce_smtpd_message_size_limit_64kb_min &&
            $size_limit && $size_limit < 65536)
          { $size_limit = 65536 }  # rfc2821 requires at least 64k
        if ($size_limit && $mail_size > $size_limit) {
          do_log(1,"OVERSIZED from %s to %s: size %s B, limit %s B",
                   $msginfo->sender_smtp, $r->recip_addr_smtp,
                   $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);
        }
      }

      # determine true reason for blocking,considering lovers and final_destiny
      my($blocking_ccat); my($final_destiny) = D_PASS; my($to_be_mangled);
      my(@fd_tuples) = $r->setting_by_main_contents_category_all(
                        cr('final_destiny_by_ccat'), cr('lovers_maps_by_ccat'),
                        cr('defang_maps_by_ccat') );
      for my $tuple (@fd_tuples) {
        my($cc, $fd, $lovers_map_ref, $mangle_map_ref) = @$tuple;
        if (!defined($fd) || $fd == D_PASS) {
          do_log(5, "final_destiny (ccat=%s) is PASS, recip %s", $cc,$recip);
        } elsif (defined($lovers_map_ref) &&
                 lookup2(0,$recip,$lovers_map_ref, Label=>'Lovers2')) {
          do_log(5, "contents lover (ccat=%s) %s", $cc,$recip);
        } elsif ($fd == D_BOUNCE &&
                 ($sender eq '' || defined($msginfo->is_bulk)) &&
                 ccat_maj($cc) == CC_BADH) {
          # have mercy on bad header section in mail from mailing lists and
          # in DSN: since a bounce for such mail will be suppressed, it is
          # probably better to just let a mail with a bad header section pass,
          # it is rather innocent
          my($is_bulk) = $msginfo->is_bulk;
          do_log(1, "allow bad header section from %s<%s> -> <%s>: %s",
            !defined($is_bulk) ? '' : "($is_bulk) ",
            $sender, $recip, $bad_headers[0]);
        } else {
          $blocking_ccat = $cc;  $final_destiny = $fd;
          my($cc_main) = $r->contents_category;
          $cc_main = $cc_main->[0]  if $cc_main;
          if ($blocking_ccat eq $cc_main) {
            do_log(3, "blocking contents category is (%s) for %s",
                      $blocking_ccat,$recip);
          } else {
            do_log(3, "blocking ccat (%s) differs from ccat_maj=%s, %s",
                      $blocking_ccat,$cc_main,$recip);
          }
          last;  # first blocking wins, also skips turning on mangling
        }
        # topmost mangling reason wins
        if (!defined($to_be_mangled) && defined($mangle_map_ref)) {
          my($mangle_type) =
            !ref($mangle_map_ref) ? $mangle_map_ref  # compatibility
                       : lookup2(0,$recip,$mangle_map_ref, Label=>'Mangling1');
          $to_be_mangled = $mangle_type  if $mangle_type ne '';
        }
      }
      $r->recip_destiny($final_destiny);
      if (defined $blocking_ccat) {  # save a blocking contents category
        $r->blocking_ccat($blocking_ccat);
        # summarize per-recipient blocking_ccat to a message level
        my($msg_bl_ccat) = $msginfo->blocking_ccat;
        if (!defined($msg_bl_ccat) || cmp_ccat($blocking_ccat,$msg_bl_ccat)>0)
          { $msginfo->blocking_ccat($blocking_ccat) }
      } else {  # defanging/mangling only has effect on passed mail
        # defang_all serves mostly for testing purposes and compatibility
        $to_be_mangled = 1  if !$to_be_mangled && c('defang_all');
        if ($to_be_mangled) {
          my($orig_to_be_mangled) = $to_be_mangled;
          if ($to_be_mangled =~ /^(?:disclaimer|nulldisclaimer)\z/i) {
            # disclaimers can only go to mail originating from internal
            # networks - the 'allow_disclaimers' should (only) be enabled
            # by an appropriate policy bank, e.g. MYNETS and/or ORIGINATING
            if (!c('allow_disclaimers')) {
              $to_be_mangled = 0;  # not for remote or unauthorized clients
            } else {
              my($rf) = $msginfo->rfc2822_resent_from;
              my($rs) = $msginfo->rfc2822_resent_sender;
              # disclaimers should only go to mail with 2822.From or
              # 2822.Sender or 2822.Resent-From or 2822.Resent-Sender
              # or 2821.mail_from address matching local domains
              if (!grep { defined($_) && $_ ne '' &&
                          lookup2(0,$_, ca('local_domains_maps')) }
                      unique_list( (!$rf ? () : @$rf), (!$rs ? () : @$rs),
                                   @rfc2822_from, $rfc2822_sender, $sender)) {
                $to_be_mangled = 0;  # not for foreign 'Sender:' or 'From:'
                do_log(5,"will not add disclaimer, originator not local");
              }
            }
          } else {  # defanging (not disclaiming)
            # defanging and other mail mangling/munging only applies to
            # incoming mail, i.e. for recipients matching local_domains_maps
            $to_be_mangled = 0  if !$r->recip_is_local;
          }
          # store a boolean or a mangling name (defang, disclaimer, ...)
          $r->mail_body_mangle($to_be_mangled)  if $to_be_mangled;
          ll(2) && do_log(2, "mangling %s: %s (orig: %s), ".
            "discl_allowed=%d, <%s> -> <%s>", $to_be_mangled ? 'YES' : 'NO',
            $to_be_mangled, $orig_to_be_mangled, c('allow_disclaimers'),
            $sender, $recip);
        }
      }

      if ($penpals_score < 0) {
        # only for logging and statistics purposes
        my($do_tag2_nopp,$do_tag3_nopp,$do_kill_nopp) =
          map { !$whitelisted &&
                ($blacklisted ||
                 (defined($_) && $spam_level+$boost-$penpals_score >= $_) ) }
              ($tag2_level,$tag3_level,$kill_level);
        $do_tag2_nopp = $do_tag2_nopp || $do_tag3_nopp;
        my($which) = $do_kill_nopp && !$do_kill ? 'kill'
                   : $do_tag3_nopp && !$do_tag3 ? 'tag3'
                   : $do_tag2_nopp && !$do_tag2 ? 'tag2' : '';
        if ($which ne '') {
          snmp_count("PenPalsSavedFrom\u$which")  if $final_destiny==D_PASS;
          do_log(2, "PenPalsSavedFrom%s %.3f%.3f%s, <%s> -> <%s>", "\u$which",
                    $spam_level+$boost-$penpals_score, $penpals_score,
                    ($final_destiny==D_PASS ? '' : ', but mail still blocked'),
                    $sender, $recip);
        }
      }

      if ($final_destiny == D_PASS) {
        # recipient wants this message, malicious or not
        do_log(5, "final_destiny PASS, recip %s", $recip);
      } else {  # recipient does not want this content
        # supply RFC 3463 enhanced status codes
        my($status) = setting_by_given_contents_category(
          $blocking_ccat,
          { CC_VIRUS,       "554 5.7.0",
            CC_BANNED,      "554 5.7.0",
            CC_UNCHECKED,   "554 5.7.0",
            CC_SPAM,        "554 5.7.0",
            CC_SPAMMY,      "554 5.7.0",
            CC_BADH.",2",   "554 5.6.3",  # nonencoded 8-bit character
            CC_BADH,        "554 5.6.0",
            CC_OVERSIZED,   "552 5.3.4",
            CC_CATCHALL,    "554 5.7.0",
          });
        $final_destiny!=D_PASS or die "Assert failed: $final_destiny==pass";
        if ($final_destiny == D_DISCARD) {
          local($1,$2);
          $status =~ s{^5(\d\d) 5(\.\d\.\d)\z}{250 2$2};  # 5xx -> 250
        }
        # get the custom smtp response reason text
        my($smtp_reason) = setting_by_given_contents_category(
                             $blocking_ccat, cr('smtp_reason_by_ccat'));
        $smtp_reason = ''  if !defined $smtp_reason;
        if ($smtp_reason ne '') {
          my(%mybuiltins) = %builtins;  # make a local copy
          $smtp_reason = expand(\$smtp_reason, \%mybuiltins);
          $smtp_reason = !ref($smtp_reason) ? '' : $$smtp_reason;
          chomp($smtp_reason); $smtp_reason = sanitize_str($smtp_reason,1);
          $smtp_reason = substr($smtp_reason,0,100) . "..."
            if length($smtp_reason) > 100+3;
        }
        my($response) = sprintf("%s %s%s", $status,
          ($final_destiny == D_PASS ? "Ok" :
           $final_destiny == D_DISCARD ? "Ok, discarded" : "Reject"),
          $smtp_reason eq '' ? '' : ', '.$smtp_reason);
        ll(4) && do_log(4, "blocking ccat=%s, SMTP response: %s",
                           $blocking_ccat,$response);
        $r->recip_smtp_response($response);
        $r->recip_done(1); # fake a delivery (confirm delivery to a bit bucket)
        # note that 5xx status rejects may later be converted to bounces
      }
    }
    section_time($which_section);

    $which_section = "quar+notif";  $t0_sect = Time::HiRes::time;
    $snmp_db->register_proc(2,0,'Q',$am_id) if defined $snmp_db; # notify, quar
    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);
    $elapsed{'TimeElapsedQuarantineAndNotify'} = Time::HiRes::time - $t0_sect;

    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)

    { # update Content*Msgs* counters
      my($ccat_name) =
        $msginfo->setting_by_contents_category(\%ccat_display_names_major);
      my($counter_name) = 'Content'.$ccat_name.'Msgs';
      snmp_count($counter_name);
      if ($msginfo->originating) {
        snmp_count($counter_name.'Originating');
      }
      if ($cnt_local > 0) {
        my($d) = $msginfo->originating ? 'Internal' : 'Inbound';
        snmp_count($counter_name.$d);
      }
      if ($cnt_remote > 0) {
        my($d) = $msginfo->originating ? 'Outbound' : 'OpenRelay';
        snmp_count($counter_name.$d);
      }
    }
    if (ref $custom_object) {
      $which_section = "custom-before_send";
      eval {
        $custom_object->before_send($conn,$msginfo); 1;
      } or do {
        my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        do_log(-1,"custom before_send error: %s", $eval_stat);
      };
      section_time($which_section);
    }
    my($bcc)= $msginfo->setting_by_contents_category(cr('always_bcc_by_ccat'));
    if (defined $bcc && $bcc ne '') {
      my($recip_obj) = Amavis::In::Message::PerRecip->new;
      # leave recip_addr and recip_addr_smtp undefined!
      $recip_obj->recip_addr_modified($bcc);
      $recip_obj->recip_destiny(D_PASS);
      $recip_obj->dsn_notify(['NEVER']);
      $recip_obj->contents_category($msginfo->contents_category);
    # $recip_obj->contents_category(CC_CLEAN);
      $msginfo->per_recip_data([@{$msginfo->per_recip_data}, $recip_obj]);
      do_log(2,"adding recipient - always_bcc: %s", $bcc);
    }
    my($hdr_edits) = $msginfo->header_edits;
    if ($msginfo->delivery_method eq '') {   # AM.PDP or AM.CL (milter)
      $which_section = "AM.PDP headers";
      $hdr_edits = add_forwarding_header_edits_common(
        $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
        $virus_presence_checked, $spam_presence_checked);
      my($done_all);
      my($recip_cl);  # ref to a list of similar recip objects
      ($hdr_edits, $recip_cl, $done_all) =
        add_forwarding_header_edits_per_recip(
          $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
          $virus_presence_checked, $spam_presence_checked, undef);
      if ($enable_dkim_signing) {  # add DKIM signatures
        for my $signature (Amavis::DKIM::dkim_make_signatures($msginfo,0)) {
          my($s) = $signature->as_string;
          local($1); $s =~ s{\015\012}{\n}gs; $s =~ s{\n+\z}{}gs;
          $s =~ s/^((?:DKIM|DomainKey)-Signature):[ \t]*//si;
          $hdr_edits->prepend_header($1, $s, 2);
        }
      }
      $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";  $t0_sect = Time::HiRes::time;
      $snmp_db->register_proc(2,0,'F',$am_id)  if defined $snmp_db; # forwardng
      $hdr_edits = add_forwarding_header_edits_common(
        $conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
        $virus_presence_checked, $spam_presence_checked);
      for (;;) {  # do the delivery, in batches if necessary
        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 recip objects needing same mail edits

        # prepare header section edits, clusterize
        ($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, undef);
        last  if !@$recip_cl;
        $msginfo->header_edits($r_hdr_edits);  # store edits for this batch

        # preserve information that may be changed by prepare_modified_mail()
        my($m_t,$m_tfn) = ($msginfo->mail_text, $msginfo->mail_text_fn);
        my($m_dm) = $msginfo->delivery_method;
        # mail body mangling/defanging/sanitizing
        my($body_modified) = prepare_modified_mail($conn,$msginfo,
                                          $hold,$any_undecipherable,$recip_cl);
        # defanged_mime_entity have modifed header edits, refetch just in case
        $r_hdr_edits = $msginfo->header_edits;
        if ($body_modified) {
          my($resend_m) = c('resend_method');
          do_log(3, "mail body mangling in effect, %s", $resend_m);
          $msginfo->delivery_method($resend_m)  if $resend_m ne '';
        }
        mail_dispatch($conn, $msginfo, 0, $dsn_per_recip_capable,
                      sub { my($r) = @_; grep { $_ eq $r } @$recip_cl });
        $point_of_no_return = 1;  # now past the point where mail was sent
        # close and delete replacement file, if any
        my($tmp_fh) = $msginfo->mail_text;  # replacement file, to be removed
        if ($tmp_fh && !$tmp_fh->isa('MIME::Entity') && $tmp_fh ne $m_t) {
          $tmp_fh->close or do_log(-1,"Can't close replacement: %s", $!);
          if (debug_oneshot()) {
            do_log(5, "defanging+debug, preserving %s",$msginfo->mail_text_fn);
          } else {
            unlink($msginfo->mail_text_fn)
              or do_log(-1,"Can't remove %s: %s", $msginfo->mail_text_fn, $!);
          }
        }
        # restore temporarily modified settings
        $msginfo->mail_text($m_t); $msginfo->mail_text_fn($m_tfn);
        $msginfo->delivery_method($m_dm);
        last  if $done_all;
      }
      # turn on CC_MTA in case of MTA trouble (e.g, rejected by MTA on fwding)
      for my $r (@{$msginfo->per_recip_data}) {
        my($smtp_resp) = $r->recip_smtp_response;
        # skip successful deliveries and non- MTA-generated status codes
        next  if $smtp_resp =~ /^2/ || $r->recip_done != 2;
        my($min_ccat) = $smtp_resp =~ /^5/ ? 2 : $smtp_resp =~ /^4/ ? 1 : 0;
        $r->add_contents_category(CC_MTA,$min_ccat);
        $msginfo->add_contents_category(CC_MTA,$min_ccat);
        my($blocking_ccat) = sprintf("%d,%d", CC_MTA,$min_ccat);
        $r->blocking_ccat($blocking_ccat) if !defined($r->blocking_ccat);
        $msginfo->blocking_ccat($blocking_ccat)
                                          if !defined($msginfo->blocking_ccat);
      }
      $msginfo->header_edits($hdr_edits); # restore original edits just in case
      $elapsed{'TimeElapsedForwarding'} = Time::HiRes::time - $t0_sect;
    }
    prolong_timer($which_section);

    if (ref $custom_object) {
      $which_section = "custom-after_send";
      eval {
        $custom_object->after_send($conn,$msginfo); 1;
      } or do {
        my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        do_log(-1,"custom after_send error: %s", $eval_stat);
      };
      section_time($which_section);
    }

    $which_section = "delivery-notification";  $t0_sect = Time::HiRes::time;
    # generate a delivery status notification according to rfc3462 & rfc3464
    my($notification,$suppressed) = delivery_status_notification(
               $conn, $msginfo, $dsn_per_recip_capable, \%builtins,
               [$sender], 'dsn', undef, undef);
    my($ndn_needed);
    ($smtp_resp, $exit_code, $ndn_needed) =
      one_response_for_all($msginfo, $dsn_per_recip_capable,
                           $suppressed && !defined($notification) );
    do_log(4, "notif=%s, suppressed=%d, ndn_needed=%s, exit=%s, %s",
              defined $notification ? 'Y' : 'N',  $suppressed,
              $ndn_needed, $exit_code, $smtp_resp);
    section_time('prepare-dsn');
    if ($suppressed && !defined($notification)) {
      $msginfo->dsn_sent(2);  # would-be-bounced, but bounce was suppressed
    } elsif (defined $notification) {  # dsn needed, send delivery notification
      mail_dispatch($conn, $notification, 'Dsn', 0);
      my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
        one_response_for_all($notification, 0);      # check status
      if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) {  # 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/) {
        die sprintf("temporarily unable to send DSN to <%s>: %s",
                    $msginfo->sender, $n_smtp_resp);
      } else {
        do_log(-1,"NOTICE: UNABLE TO SEND DSN to <%s>: %s",
                  $sender, $n_smtp_resp);
#       # if dsn cannot be sent, try to send it to postmaster
#       $notification->recips(['postmaster']);
#       # attempt double bounce
#       mail_dispatch($conn, $notification, 'Notif', 0);
      }
    # $notification->purge;
    }

    { my($which_counter) = 'Unknown';
      if    ($smtp_resp =~ /^4/) { $which_counter = 'TempFailed' }
      elsif ($smtp_resp =~ /^5/) { $which_counter = 'Rejected' }
      elsif ($smtp_resp =~ /^2/) {
        if (!grep { $_->recip_destiny != D_DISCARD }
                  @{$msginfo->per_recip_data}) {  # all D_DISCARD
          $which_counter = 'Discarded';
        } elsif ($msginfo->dsn_sent) {
          $which_counter = $msginfo->dsn_sent==1 ? 'Bounced' : 'NoBounce';
        } else {
          $which_counter = $msginfo->delivery_method eq ''
                                                 ? 'Accepted' : 'Relayed';
        }
      }
      snmp_count('InMsgsStatus'.$which_counter)  if defined $which_counter;
    }

    prolong_timer($which_section);
    $elapsed{'TimeElapsedDSN'} = Time::HiRes::time - $t0_sect;

    # 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($ll) = 0;  # log level for the main log entry
    # $ll = 1  if !@$n;  # tame down the log level if all passed
      if (ll($ll)) {
        my($strr) = expand(cr('log_templ'), \%mybuiltins);
        for my $logline (split(/[ \t]*\n/, $$strr)) {
          do_log($ll, "%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{'.'} = sprintf("%d",$j);
        my($recip) = $r->recip_addr;
        my($qrecip_addr) = scalar(qquote_rfc2821_local($recip));
        my($remote_mta)  = $r->recip_remote_mta;
        my($smtp_resp)   = $r->recip_smtp_response;
        $mybuiltins{'remote_mta'} = $remote_mta;
        $mybuiltins{'smtp_response'} = $smtp_resp;
        $mybuiltins{'remote_mta_smtp_response'} =
                                            $r->recip_remote_mta_smtp_response;
        $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;
          $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{'banned_parts'} = \@b;         # list of banned parts
        $mybuiltins{'F'} = $r->banning_reason_short;  # just one name & comment
        $mybuiltins{'banning_rule_comment'} =
          !defined($r->banning_rule_comment) ? undef
                                        : unique_ref($r->banning_rule_comment);
        $mybuiltins{'banning_rule_rhs'} =
          !defined($r->banning_rule_rhs) ? undef
                                        : unique_ref($r->banning_rule_rhs);
        my($dn) = $r->dsn_notify;
        $mybuiltins{'dsn_notify'} =
          uc(join(',', $sender eq '' ? 'NEVER' : !$dn ? 'FAILURE' : @$dn));
        my($boost) = $r->recip_score_boost;
        $mybuiltins{'score_boost'} = 0+sprintf("%.3f",0+$boost);
        my($tag_level,$tag2_level,$kill_level);
        if (!$r->bypass_spam_checks) {
          $tag_level  = lookup2(0,$recip, ca('spam_tag_level_maps'));
          $tag2_level = lookup2(0,$recip, ca('spam_tag2_level_maps'));
          $kill_level = lookup2(0,$recip, ca('spam_kill_level_maps'));
        }
        my($is_local) = $r->recip_is_local;
        my($do_tag)   = $r->is_in_contents_category(CC_CLEAN,1);
        my($do_tag2)  = $r->is_in_contents_category(CC_SPAMMY);
        my($do_kill)  = $r->is_in_contents_category(CC_SPAM);
        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($msginfo, $j-1, @_) };  # info on one recipient
        $mybuiltins{'T'} = $mybuiltins{'TESTSSCORES'} = $mybuiltins{'TESTS'} =
          sub { macro_tests($msginfo, $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);

        $mybuiltins{'ccat'} =
          sub {
            my($name,$attr,$which) = @_;
            $attr = lc($attr);    # name | major | minor | <empty>
                                  # | is_blocking | is_nonblocking
                                  # | is_blocked_by_nonmain
            $which = lc($which);  # main | blocking | auto
            my($result) = '';  my($blocking_ccat) = $r->blocking_ccat;
            if ($attr eq 'is_blocking') {
              $result =  defined($blocking_ccat) ? 1 : '';
            } elsif ($attr eq 'is_nonblocking') {
              $result = !defined($blocking_ccat) ? 1 : '';
            } elsif ($attr eq 'is_blocked_by_nonmain') {
              if (defined($blocking_ccat)) {
                my($aref) = $r->contents_category;
                $result = 1  if ref($aref) && @$aref > 0
                                && $blocking_ccat ne $aref->[0];
              }
            } elsif ($attr eq 'name') {
              $result =
                $which eq 'main' ?
                  $r->setting_by_main_contents_category(\%ccat_display_names)
              : $which eq 'blocking' ?
                  $r->setting_by_blocking_contents_category(
                                                        \%ccat_display_names)
              :   $r->setting_by_contents_category(     \%ccat_display_names);
            } else {  # attr = major, minor, or anything else returns a pair
              my($maj,$min) = ccat_split(
                                ($which eq 'blocking' ||
                                 $which ne 'main' && defined $blocking_ccat)
                                 ? $blocking_ccat : $r->contents_category);
              $result = $attr eq 'major' ? $maj
                 : $attr eq 'minor' ? sprintf("%d",$min)
                 : sprintf("(%d,%d)",$maj,$min);
            }
            $result;
          };

        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);
    prolong_timer($which_section);

    if (defined $os_fingerprint) { # collect statistics on contents type vs. OS
      my($spam_ham_level) = 2.0;  # reasonable guesstimate
      local($1); my($os_short);   # extract operating system name when avail.
      $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_BANNED,'banned',
                    CC_SPAM,'spam', CC_SPAMMY,'spammy', CC_CATCHALL,'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(?![^(]*\b2000 SP)/;
        }
      }
    }
    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
        if ($sql_storage->save_info_final($conn,$msginfo,$ds)) {
          last;
        } elsif (--$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 (ll(2)) {  # log SpamAssassin timing report if available
      my($sa_tim) = $msginfo->supplementary_info('TIMING');
      do_log(2, "TIMING-SA %s", $sa_tim)  if defined($sa_tim) && $sa_tim ne '';
    }
    if (defined $snmp_db) {
      $which_section = 'update_snmp';
      my($log_lines, $log_entries_by_level_ref,
         $log_retries, $log_status_counts_ref) = collect_log_stats();
      snmp_count( ['LogLines', $log_lines, 'C64'] );
      my($log_entries_all_cnt) = 0;
      for my $level_str (keys %$log_entries_by_level_ref) {
        my($level) = 0+$level_str;
        my($cnt) = $log_entries_by_level_ref->{$level_str};
        $log_entries_all_cnt += $cnt;
      # snmp_count( ['LogEntriesEmerg',   $cnt, 'C64'] );  # not in use
      # snmp_count( ['LogEntriesAlert',   $cnt, 'C64'] );  # not in use
        snmp_count( ['LogEntriesCrit',    $cnt, 'C64'] )  if $level <= -3;
        snmp_count( ['LogEntriesErr',     $cnt, 'C64'] )  if $level <= -2;
        snmp_count( ['LogEntriesWarning', $cnt, 'C64'] )  if $level <= -1;
        snmp_count( ['LogEntriesNotice',  $cnt, 'C64'] )  if $level <=  0;
        snmp_count( ['LogEntriesInfo',    $cnt, 'C64'] )  if $level <=  1;
        snmp_count( ['LogEntriesDebug',   $cnt, 'C64'] );
        if    ($level < 0) { $level_str = "0" }
        elsif ($level > 5) { $level_str = "5" }
        snmp_count( ['LogEntriesLevel'.$level_str, $cnt, 'C64'] );
      }
      snmp_count( ['LogEntries', $log_entries_all_cnt, 'C64'] );
      if ($log_retries > 0) {
        snmp_count( ['LogRetries', $log_retries] );
        do_log(3,"Syslog retries: %d x %s", $log_status_counts_ref->{$_}, $_)
          for (keys %$log_status_counts_ref);
      }
      $elapsed{'TimeElapsedSending'} +=  # merge similar timing entries
        delete $elapsed{$_}  for ('TimeElapsedQuarantineAndNotify',
                                  'TimeElapsedForwarding', 'TimeElapsedDSN');
      snmp_count( ['entropy',0,'STR'] );
      $elapsed{'TimeElapsedTotal'} = Time::HiRes::time - $msginfo->rx_time;
      # Will end up as SNMPv2-TC TimeInterval (INTEGER), units of 0.01 seconds,
      # but we keep it in milliseconds in the bdb database!
      # Note also the use of C32 instead of INT, we want cumulative time.
      snmp_count([$_, int(1000*$elapsed{$_}+0.5), 'C32'])  for (keys %elapsed);
      $snmp_db->update_snmp_variables;
      section_time($which_section);
    }
    if (ref $custom_object) {
      $which_section = "custom-mail_done";
      eval {
        $custom_object->mail_done($conn,$msginfo); 1;
      } or do {
        my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        do_log(-1,"custom mail_done error: %s", $eval_stat);
      };
      section_time($which_section);
    }
    $which_section = 'finishing';
    1;
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    $preserve_evidence = 1;
    my($msg) = "$which_section FAILED: $eval_stat";
    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;
  }

  $snmp_db->register_proc(1,0,'.') if defined $snmp_db; # content checking done
  do_log(-1, "signal: %s", join(', ',keys %got_signals))  if %got_signals;
  undef $MSGINFO;  # release global references
  ($smtp_resp, $exit_code, $preserve_evidence);
}

# Ensure we have $msginfo->$entity defined when we expect we'll need it,
#
sub ensure_mime_entity($) {
  my($msginfo) = @_;
  my($ent,$mime_err);
  if (!defined($msginfo->mime_entity)) {
    ($ent,$mime_err) = mime_decode($msginfo->mail_text, $msginfo->mail_tempdir,
                                   $msginfo->parts_root);
    $msginfo->mime_entity($ent);
    prolong_timer('mime_decode');
  }
  $mime_err;
}

# Check if a message is a bounce, and if it is, try to obtain essential
# information from a header section of an attached original message,
# primarily the Message-ID.
#
sub inspect_a_bounce_message($) {
  my($msginfo) = @_;
  my(%header_field,$bounce_type); my($is_true_bounce) = 0;
  my($parts_root) = $msginfo->parts_root;
  if (!defined($parts_root)) {
    do_log(5, 'inspect_dsn: no parts root');
  } else {
    my($sender) = $msginfo->sender;
    my($structure_type) = '?';
    my($top_main); my($top) = $parts_root->children;
    for my $e (!defined $top ? () : @$top) {
      # take a main message component, ignoring preamble/epilogue MIME parts
      # and pseudo components such as a fabricated 'MAIL' (i.e. a copy of
      # entire message for the benefit of some virus scanners)
      my($name) = $e->name_declared;
      next if !defined($e->type_declared) && defined($name) &&
              ($name eq 'preamble' || $name eq 'epilogue');
      next if $e->type_short eq 'MAIL' &&
              lc($e->type_declared) eq 'message/rfc822';
      $top_main = $e; last;
    }
    my(@parts); my($fname_ind); my($plaintext) = 0;
    if (defined $top_main) {  # one level only
      my($ch) = $top_main->children;
      @parts = ($top_main, !defined $ch ? () : @$ch);
    }
    my(@t) =
      map { my($t)=$_->type_declared; lc(ref $t ? $t->[0] : $t) } @parts;
    ll(5) && do_log(5, "inspect_dsn: parts: %s", join(", ",@t));
    my($fm) = $msginfo->rfc2822_from;
    my(@rfc2822_from) = !defined $fm ? () : ref $fm ? @$fm : $fm;
    if (  @parts >= 2 && @parts <= 4  &&
          $t[0] eq 'multipart/report' &&
        ( $t[2] eq 'message/delivery-status' ||                  # rfc3464
          $t[2] eq 'message/global-delivery-status' ||           # rfc5337
          $t[2] eq 'message/disposition-notification' ||         # rfc3798
          $t[2] eq 'message/global-disposition-notification' ||  # rfc5337
          $t[2] eq 'message/feedback-report' ) && #shafranovich-feedback-report
          $t[2] eq 'message/'.lc($parts[0]->report_type) &&
        ( $t[3] eq 'text/rfc822-headers' || $t[3] eq 'message/rfc822' ||
          $t[3] eq 'message/rfc822-headers' )  # nonstandard
       )
    { # standard DSN or MDN or feedback-report
      $bounce_type = $t[2] eq 'message/disposition-notification'        ? 'MDN'
                   : $t[2] eq 'message/global-disposition-notification' ? 'MDN'
                   : $t[2] eq 'message/feedback-report' ? 'ARF' : 'DSN';
      $structure_type = 'standard ' . $bounce_type;
      $fname_ind = 3; $is_true_bounce = 1;
    } elsif (  @parts >= 2 && @parts <= 4  &&
          $t[0] eq 'multipart/report' &&
          $t[2] eq 'message/delivery-status' &&
          $t[2] eq 'message/'.lc($parts[0]->report_type) &&
          $t[3] eq 'text/plain' ) {
      # nonstandard DSN, missing header, unless it is stashed in text/plain
      $fname_ind = 3; $structure_type = 'nostandard DSN-plain';
      $plaintext = 1; $bounce_type = 'DSN';
    } elsif (@parts >= 3 && @parts <= 4 &&  # a root with 2 or 3 leaves
          $t[0] eq 'multipart/report' &&
          lc($parts[0]->report_type) eq 'delivery-status' &&
        ( $t[-1] eq 'text/rfc822-headers' || $t[-1] eq 'message/rfc822' )) {
      # not quite std. DSN (missing message/delivery-status), but recognizable
      $fname_ind = -1; $is_true_bounce = 1; $bounce_type = 'DSN';
      $structure_type = 'DSN, missing delivery-status part';
    } elsif (@parts >= 3 && @parts <= 5 &&
          $t[0] eq 'multipart/mixed' &&
        ( $t[-1] eq 'text/rfc822-headers' || $t[-1] eq 'message/rfc822' ||
          $t[-1] eq 'message/rfc822-headers') &&  # nonstandard - Gordano M.S.
        ( $msginfo->is_auto || $msginfo->is_mlist ||
          $msginfo->get_header_field_body('subject') =~
                                          /\bDelivery Failure Notification\b/
      #   || $sender          =~ /^postmaster(?:\@|\z)/si
      #   || $rfc2822_from[0] =~ /^postmaster(?:\@|\z)/si
        ) ) {
      # qmail, msn?, mailman, C/R
      $fname_ind = -1;
      $structure_type = 'multipart/mixed(' . $msginfo->is_bulk . ')';
    } elsif (@parts == 3 &&
          $t[0] eq 'multipart/mixed' &&
          $t[-1] eq 'application/octet-stream' &&
          $parts[-1]->name_declared =~ /\.eml\z/) {
      # MDaemon
      $fname_ind = -1;
      $structure_type = 'multipart/mixed with binary .eml';
    } elsif ( @parts == 1 && $t[0] ne 'multipart/report' &&
              ( $msginfo->is_auto ||
                $rfc2822_from[0] =~ /^postmaster(?:\@|\z)/si ) ) {
      # nonstructured, possibly a non-standard bounce (qmail, gmail.com, ...)
      $fname_ind = 0; $plaintext = 1;
      $structure_type = 'nonstructured(' . $msginfo->is_auto . ')';
    } elsif ( $msginfo->is_auto && @parts == 2 &&
              $t[0] eq 'multipart/mixed' && $t[1] eq 'text/plain' ) {
      # nonstructured, possibly a broken bounce
      $fname_ind = 1; $plaintext = 1;
      $structure_type = $t[0] .' with '. $t[1] .'(' . $msginfo->is_auto .')';
    } elsif ( $msginfo->is_auto && @parts == 3 &&
              $t[0] eq 'multipart/alternative' &&
              $t[1] eq 'text/plain' && $t[2] eq 'text/html' ) {
      # text/plain+text/html, possibly a challenge CR message
      $fname_ind = 1; $plaintext = 1;
      $structure_type = $t[0] .' with '. $t[1] .'(' . $msginfo->is_auto .')';
    }
    if (defined $fname_ind) {
      # we probably have a header section from original mail, scan it
      $fname_ind = $#parts  if $fname_ind == -1;
      my($fname) = $parts[$fname_ind]->full_name;
      ll(5) && do_log(5,'inspect_dsn: struct: "%s", basenm(%s): %s, fname: %s',
        $structure_type, $fname_ind, $parts[$fname_ind]->base_name, $fname);
      if (defined $fname) {
        my(%collectable_header_fields);
        $collectable_header_fields{lc($_)} = 1
          for qw(From To Return-Path Message-ID Date Received Subject
                 MIME-Version Content-Type);
        my($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;
        my($have_header_fields_cnt) = 0; my($nonheader_cnt) = 0;
        my($curr_head,$ln); my($nr) = 0; my($eof) = 0; local($1,$2);
        my($line_limit) = $plaintext ? 200 : 1000;
        for (;;) {
          if ($eof) {
            $ln = "\n";  # fake a missing header/body separator line
          } else {
            $! = 0; $ln = $fh->getline;
            if (!defined($ln)) {
              $eof = 1; $ln = "\n";
              $!==0  or                # returning EBADF at EOF is a perl bug
                $!==EBADF ? do_log(0,"Error reading mail header section: $!")
                          : die "Error reading mail header section: $!";
            }
          }
          last  if ++$nr > $line_limit;  # safety measure
          if ($ln =~ /^[ \t]/) {  # folded
            $curr_head .= $ln  if length($curr_head) < 2000;  # safety measure
          } else {  # a new header field, process previous if any
            if (defined $curr_head) {
              $curr_head =~ s/^[> ]+//  if $plaintext;
              # be more conservative on accepted h.f.name than rfc2822 allows
              # the '_' and '.' are quite rare, digits even rarer;
              # the longest non-X h.f.name is content-transfer-encoding (25)
              # the longest h.f.names in the wild are 59 chars, largest ever 77
              if ($curr_head !~ /^([a-zA-Z0-9._-]{1,60})[ \t]*:(.*)\z/s) {
                $nonheader_cnt++;
              } else {
                my($hfname) = lc($1);
                if ($collectable_header_fields{$hfname}) {
                  $have_header_fields_cnt++  if !exists $header_field{$hfname};
                  $header_field{$hfname} = $2;
                }
              }
            }
            $curr_head = $ln;
            if (!$plaintext) {
              last  if $ln eq "\n" || $ln =~ /^--/;
            } elsif ($ln =~ /^\s*$/ || $ln =~ /^--/) {
              if (exists $header_field{'from'} &&
                  $have_header_fields_cnt >= 4 && $nonheader_cnt <= 1) {
                last;
              } else {  # reset, hope for the next paragraph to be a header
                $have_header_fields_cnt = 0; $nonheader_cnt = 0;
                %header_field = (); undef $curr_head;
              }
            }
          }
        }
        defined $ln || $!==0  or    # returning EBADF at EOF is a perl bug
          $!==EBADF ? do_log(1,"Error reading from %s: %s", $fname,$!)
                    : die "Error reading from $fname: $!";
        $fh->close or die "Error closing $fname: $!";
        my($thd) = exists $header_field{'message-id'} ? 3 : 5;
        $is_true_bounce = 1  if exists $header_field{'from'} &&
                                $have_header_fields_cnt >= $thd;
        if ($is_true_bounce) {
          ll(5) && do_log(5, "inspect_dsn: plain=%s, got %d: %s",
                             $plaintext?"Y":"N", scalar(keys %header_field),
                             join(", ", sort keys %header_field));
          for (@header_field{keys %header_field})
            { s/\n(?=[ \t])//gs; s/^[ \t]+//; s/[ \t\n]+\z// }
          if (!defined($header_field{'message-id'}) &&
              $have_header_fields_cnt >= 5 && $nonheader_cnt <= 1) {
            $header_field{'message-id'} = '';  # fake: defined but empty
            do_log(5, "inspect_dsn: a header section with no Message-ID");
          } elsif (defined($header_field{'message-id'})) {
            $header_field{'message-id'} =
              (parse_message_id($header_field{'message-id'}))[0]
              if defined $header_field{'message-id'};
          }
        }
        section_time("inspect_dsn");
      }
    }
    $bounce_type = 'bounce'  if !defined $bounce_type;
    if ($is_true_bounce) {
      do_log(3, 'inspect_dsn: is a %s, struct: "%s", part(%s/%d), <%s>',
                $bounce_type, $structure_type,
                !defined($fname_ind) ? '-' : $fname_ind,  scalar(@parts),
                $sender)  if ll(3);
    } elsif ($msginfo->is_auto) {  # bounce likely, but contents unrecognizable
      do_log(3, 'inspect_dsn: possibly a %s, unrecognizable, '.
                'struct: "%s", parts(%s/%d): %s',
                $bounce_type, $structure_type,
                !defined($fname_ind) ? '-' : $fname_ind,  scalar(@parts),
                join(", ",@t))  if ll(3);
    } else {  # not a bounce
      do_log(3, 'inspect_dsn: not a bounce');
    }
  }
  undef $bounce_type  if !$is_true_bounce;
  !$is_true_bounce ? () : (\%header_field,$bounce_type);
}

sub add_forwarding_header_edits_common($$$$$$$) {
  my($conn, $msginfo, $hdr_edits, $hold, $any_undecipherable,
     $virus_presence_checked, $spam_presence_checked) = @_;
  my($allowed_hdrs) = cr('allowed_added_header_fields');
  if ($allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-Hold')}) {
    # 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);
    }
  }
  # RFC 5451: For security reasons, any MTA conforming to this specification
  # MUST delete any discovered instance of this header field that claims to
  # have been added within its trust boundary and that did not come from
  # another trusted MTA. [...] For simplicity and maximum security, a border
  # MTA MAY remove all instances of this header field on mail crossing into
  # its trust boundary.
  $hdr_edits->edit_header('Authentication-Results',
                 # delete header field if same host, keep unchanged otherwise;
                 # simpleminded parsing, better match too many than too few
                 sub { my($h,$b)=@_; my($lh)=c('myhostname');