File: amavisd

package info (click to toggle)
amavisd-new 1%3A2.11.0-6.1
links: PTS, VCS
area: main
in suites: buster
size: 12,432 kB
sloc: perl: 33,770; sh: 523; sql: 158; makefile: 8
file content (35408 lines) | stat: -rwxr-xr-x 1,566,555 bytes
#!/usr/bin/perl -T

### profiling:
### #!/usr/bin/perl -d:NYTProf
###   NYTPROF=start=no:addpid=1:forkdepth=1 amavisd -m 5 foreground

#------------------------------------------------------------------------------
# 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-2016 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 (from 2002-03) 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::JSON
#  Amavis::Log
#  Amavis::DbgLog
#  Amavis::Timing
#  Amavis::Util
#  Amavis::ProcControl
#  Amavis::rfc2821_2822_Tools
#  Amavis::Lookup::RE
#  Amavis::Lookup::IP
#  Amavis::Lookup::Opaque
#  Amavis::Lookup::OpaqueRef
#  Amavis::Lookup::Label
#  Amavis::Lookup::SQLfield (just the new() method declared here)
#  Amavis::Lookup::LDAPattr (just the new() method declared here)
#  Amavis::Lookup
#  Amavis::Expand
#  Amavis::TempDir
#  Amavis::IO::FileHandle
#  Amavis::IO::Zlib
#  Amavis::IO::RW
#  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::Custom
#  Amavis
#optionally compiled-in packages: ---------------------------------------------
#  Amavis::ZMQ
#  Amavis::DB::SNMP
#  Amavis::DB
#  Amavis::Lookup::SQLfield (the rest)
#  Amavis::Lookup::SQL
#  Amavis::LDAP::Connection
#  Amavis::Lookup::LDAP
#  Amavis::Lookup::LDAPattr (the rest)
#  Amavis::In::AMPDP
#  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::Redis
#  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::CustomSigner
#  Amavis::DKIM
#  Amavis::Tools
#------------------------------------------------------------------------------

use sigtrap qw(stack-trace BUS SEGV EMT FPE ILL SYS TRAP);  # ABRT

use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

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

BEGIN {
  if ($] <= 5.008) {  # deal with a glob() taint bug (perl 5.6.1, 5.8.0)
    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::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::LibIDN 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;
}

1;

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

# constants;  intentionally leave value -1 unassigned for compatibility
use constant D_TEMPFAIL => -4;
use constant D_REJECT   => -3;
use constant D_BOUNCE   => -2;
use constant D_DISCARD  =>  0;
use constant D_PASS     =>  1;

# major contents_category constants, in increasing order of importance
use constant CC_CATCHALL  => 0;
use constant CC_CLEAN     => 1;  # tag_level = "CC_CLEAN,1"
use constant CC_MTA       => 2;  # trouble passing mail back to MTA
use constant CC_OVERSIZED => 3;
use constant CC_BADH      => 4;
use constant CC_SPAMMY    => 5;  # tag2_level  (and: tag3_level = CC_SPAMMY,1)
use constant CC_SPAM      => 6;  # kill_level
use constant CC_UNCHECKED => 7;
use constant CC_BANNED    => 8;
use constant CC_VIRUS     => 9;
#
#  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.412';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = (
    'dynamic_confvars' =>  # per- policy bank settings
    [qw(
      $child_timeout $smtpd_timeout
      $policy_bank_name $protocol $haproxy_target_enabled @inet_acl
      $myhostname $myauthservid $snmp_contact $snmp_location
      $myprogram_name $syslog_ident $syslog_facility
      $log_level $log_templ $log_recip_templ $enable_log_capture_dump
      $forward_method $notify_method $resend_method $report_format
      $release_method $requeue_method $release_format
      $attachment_password $attachment_email_name $attachment_outer_name
      $mail_digest_algorithm $mail_part_digest_algorithm
      $os_fingerprint_method $os_fingerprint_dst_ip_and_port
      $originating @smtpd_discard_ehlo_keywords $soft_bounce
      $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 $virus_scanners_failure_is_fatal
      $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 $outbound_disclaimers_only
      $prepend_header_fields_hdridx
      $allow_fixing_improper_header
      $allow_fixing_improper_header_folding $allow_fixing_long_header_lines
      %allowed_added_header_fields %prefer_our_added_header_fields
      %allowed_header_tests
      $X_HEADER_TAG $X_HEADER_LINE
      $remove_existing_x_scanned_headers $remove_existing_spam_headers
      %sql_clause $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
      $enable_dkim_verification $enable_dkim_signing $dkim_signing_service
      $dkim_minimum_key_bits $enable_ldap $enable_ip_repu $redis_logging_key

      @local_domains_maps
      @mynetworks_maps @client_ipaddr_policy @ip_repu_ignore_maps
      @forward_method_maps @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_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 @debug_recipient_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 @virus_name_to_policy_bank_maps
      @remove_existing_spam_headers_maps
      @sa_userconf_maps @sa_username_maps

      %final_destiny_maps_by_ccat %forward_method_maps_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_zmq @zmq_sockets $mail_id_size_bits
      $daemon_user $daemon_group $daemon_chroot_dir $path
      $DEBUG %i_know_what_i_am_doing
      $do_syslog $logfile $allow_preserving_evidence $enable_log_capture
      $log_short_templ $log_verbose_templ $logline_maxlen
      $nanny_details_level $max_servers $max_requests
      $min_servers $min_spare_servers $max_spare_servers
      %current_policy_bank %policy_bank %interface_policy
      @listen_sockets $inet_socket_port $inet_socket_bind $listen_queue_size
      $smtpd_recipient_limit $unix_socketname $unix_socket_mode
      $smtp_connection_cache_on_demand $smtp_connection_cache_enable
      %smtp_tls_client_options %smtpd_tls_server_options
      $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
      $database_sessions_persistent $lookup_maps_imply_sql_and_ldap
      @lookup_sql_dsn @storage_sql_dsn @storage_redis_dsn
      $storage_redis_ttl $redis_logging_queue_size_limit
      $sql_schema_version $timestamp_fmt_mysql
      $sql_quarantine_chunksize_max $sql_allow_8bit_address
      $sql_lookups_no_at_means_domain $ldap_lookups_no_at_means_domain
      $sql_store_info_for_all_msgs $default_ldap
      $trim_trailing_space_in_lookup_result_fields
      @keep_decoded_original_maps @map_full_type_to_short_type_maps
      %banned_rules $penpals_threshold_low $penpals_threshold_high
      %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 $sa_num_instances
      $helpers_home $sa_configpath $sa_siteconfigpath $sa_userprefs_file
      $sa_local_tests_only $sa_timeout $sa_debug
      $dspam $sa_spawned
    )],
    'platform' => [qw(
      $profiling $can_truncate $my_pid
      $AF_INET6 $have_inet4 $have_inet6 $io_socket_module_name
      &D_TEMPFAIL &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_banned_destiny $final_unchecked_destiny
      $final_spam_destiny $final_bad_header_destiny
      @virus_lovers_maps @spam_lovers_maps @unchecked_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
      $warnbannedsender $warnbadhsender
      $defang_virus $defang_banned $defang_spam
      $defang_bad_header $defang_undecipherable $defang_all
      $virus_quarantine_method $banned_files_quarantine_method
      $unchecked_quarantine_method $spam_quarantine_method
      $bad_header_quarantine_method $clean_quarantine_method
      $archive_quarantine_method
      @virus_quarantine_to_maps @banned_quarantine_to_maps
      @unchecked_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 @spam_modifies_subj_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 backward compatibility
    [qw(
      %local_domains @local_domains_acl $local_domains_re
      @mynetworks @ip_repu_ignore_networks
      %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 $unchecked_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 $syslog_priority $append_header_fields_to_bottom
      $insert_received_line $notify_xmailer_header $relayhost_is_client
      $sa_spam_report_header $sa_auto_whitelist
      $warnvirussender $warnspamsender
      $enable_global_cache
      $virus_check_negative_ttl $virus_check_positive_ttl
      $spam_check_negative_ttl $spam_check_positive_ttl
    )],
  );
  Exporter::export_tags qw(dynamic_confvars confvars sa platform
                      hidden_confvars legacy_dynamic_confvars legacy_confvars);
  1;
} # 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 subroutines to config vars and keys
BEGIN { push(@EXPORT,qw(c cr ca dkim_key)) }

# access to dynamic config variables, returns a scalar config variable value;
# one level of indirection is allowed
#
sub c($) {
  my $var = $current_policy_bank{$_[0]};
  if (!defined $var) {
    my $name = $_[0];
    if (!exists $current_policy_bank{$name}) {
      Carp::croak(sprintf('No entry "%s" in policy bank "%s"',
                          $name, $current_policy_bank{'policy_bank_name'}));
    }
  }
  my $r = ref $var;
  !$r ? $var : $r eq 'SCALAR' || $r eq 'REF' ? $$var : $var;
}

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

# 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 $var = $current_policy_bank{$_[0]};
  if (!defined $var) {
    my $name = $_[0];
    if (!exists $current_policy_bank{$name}) {
      Carp::croak(sprintf('No entry "%s" in policy bank "%s"',
                          $name, $current_policy_bank{'policy_bank_name'}));
    }
  }
  ref $var ? $var : defined $var ? [$var] : [];
}

sub deprecate_var($$$) {
  my($data_type, $var_name, $init_value) = @_;
  my $code = <<'EOD';
    tie(%n, '%p', %v)  or die 'Tieing a variable %n failed';
    package %p;
    use strict; use Carp ();
    sub TIESCALAR { my($class,$val) = @_; bless \$val, $class }
    sub FETCH { my $self = shift; $$self }
    sub STORE { my($self,$newv) = @_; my $oldv = $$self;
      if ((defined $oldv || defined $newv) && (%t)) {
        Carp::carp('Variable %n was retired, changing its value has no effect.'
                   . " See release notes.\n");
      }
      $$self = $newv;
    }
    1;
EOD
  if ($data_type eq 'bool') {
    $code =~ s{%t}'($oldv ? 1 : 0) != ($newv ? 1 : 0)'g;
  } elsif ($data_type eq 'num') {
    $code =~ s{%t}'!defined $oldv || !defined $newv || $oldv != $newv'g;
  } elsif ($data_type eq 'str') {
    $code =~ s{%t}'!defined $oldv || !defined $newv || $oldv ne $newv'g;
  } else {
    die "Error deprecating a variable $var_name: bad type $data_type";
  }
  $code =~ s/%n/$var_name/g;
  $code =~ s/%v/\$init_value/g;
  my $barename = $var_name;
  $barename =~ s/^[\$\@%&]//; $code =~ s/%p/Amavis::Deprecate::$barename/g;
  eval $code
    or do { chomp $@; die "Error deprecating a variable $var_name: $@" };
}

# 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 could 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 6376.
# The subroutine is typically called from a configuration file, once for
# each signing key available.
#
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) {  # key already preprocessed and provided as an object
    push(@dkim_signing_keys_storage, [$key]);
    $key_storage_ind = $#dkim_signing_keys_storage;
  } else {  # assume a name of a file containing 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);  # soft-link friendly
    @stat_list or warn "Error accessing $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 a new entry
      $key = ''; Amavis::Util::read_file($pem_fh,\$key);
      my $key_fit = $key;  # shrink allocated storage size to actual size
      undef $key;  # release storage
      push(@dkim_signing_keys_storage, [$key_fit, $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
  }
  # possibly the $domain is a regexp
  $domain   = Amavis::Util::idn_to_ascii($domain)  if !ref $domain;
  $selector = Amavis::Util::idn_to_ascii($selector);
  $key_options{domain} = $domain; $key_options{selector} = $selector;
  $key_options{key_storage_ind} = $key_storage_ind;
  if (@dkim_signing_keys_list > 100) {
    # sorry, skip the test to avoid slow O(n^2) searches
  } else {
    !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 a list preserves 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, base policy bank
  $myprogram_name = $0;  # typically 'amavisd'
  local $1; $myprogram_name =~ s{([^/]*)\z}{$1}s;
  $myproduct_name = 'amavisd-new';
  $myversion_id = '2.11.0'; $myversion_date = '20160426';

  $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*))?)?(.*)$/s;
  $sql_schema_version = $myversion_id_numeric;

  $read_config_files_depth = 0;
  # 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/s) { 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
  1;
} # 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;

  # Is Devel::NYTProf profiler loaded?
  $profiling = 1  if DB->UNIVERSAL::can('enable_profile');

  # In case of trouble, allow preserving temporary files for forensics
  $allow_preserving_evidence = 1;

  # Cause Net::Server parameters 'background' and 'setsid' to be set,
  # resulting in the process 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;

  # Customizable notification messages, logging

  $syslog_ident = 'amavis';
  $syslog_facility = 'mail';

  $log_level = 0;

  # should be less than (1023 - prefix), i.e. 980,
  # to avoid syslog truncating lines; see sub write_log
  $logline_maxlen = 980;

  $nanny_details_level = 1;  # register_proc verbosity: 0, 1, 2

# $inner_sock_specs in amavis-services should match one of the sockets
# in the @zmq_sockets list
# @zmq_sockets = ( "ipc://$MYHOME/amavisd-zmq.sock" );  # after-default

# $enable_zmq = undef;  # load optional module Amavis::ZMQ
#                       #   (interface to 0MQ or Crossroads I/O)
# $enable_db = undef;   # load optional modules Amavis::DB & Amavis::DB::SNMP
# $enable_dkim_signing = undef;
# $enable_dkim_verification = undef;

  $enable_ip_repu = 1;  # ignored when @storage_redis_dsn is empty

  # a key (string) for a redis list serving as a queue of json events
  # for logstash / elasticsearch use;  undef or empty or '0' disables
  # logging of events to redis
  $redis_logging_key = undef;  # e.g. "amavis-log";

  # a limit on the length of a redis list - new log events will be dropped
  # while the queue size limit is exceeded; undef or 0 disables logging;
  # reasonable value: 100000, takes about 250 MB of memory in a redis server
  # when noone is pulling events from the list
  $redis_logging_queue_size_limit = undef;

  $reputation_factor = 0.2;  # DKIM reputation: a value between 0 and 1,
    # controlling the amount of 'bending' of a calculated spam score
    # towards a fixed score assigned to a signing domain (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

  # keep SQL, LDAP and Redis sessions open when idle
  $database_sessions_persistent = 1;

  $lookup_maps_imply_sql_and_ldap = 1;  # set to 0 to disable

  # Algorithm name for generating a mail header digest and a mail body digest:
  # either 'MD5' (will use Digest::MD5, fastest and smallest digest), or
  # anything else accepted by Digest::SHA->new(), e.g. 'SHA-1' or 'SHA-256'.
  # The generated digest may end up as part of a quarantine file name
  # or via macro %b in log or notification templates.
  #
  $mail_digest_algorithm = 'MD5';  # or 'SHA-1' or 'SHA-256', ...

  # Algorithm name for generating digests of decoded MIME parts of a message.
  # The value is an algorithm name as accepted by Digest::SHA->new(),
  # e.g. 'SHA-1' or 'SHA-256' or 'sha256', or a string 'MD5' which implies
  # the MD5 algorithm as implemented by a module Digest::MD5.
  # For compatibility with SpamAssassin the chosen algorithm should be SHA1,
  # otherwise bayes tokens won't match those generated by sa-learn.
  # Undefined value disables generating digests of MIME parts.
  #
  $mail_part_digest_algorithm = 'SHA1';

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

  # the length of mail_id in bits, must be an integral multiple of 24
  # (i.e. divisible by 6 and 8);  the mail_id is represented externally
  # as a base64url-encoded string of size $mail_id_size_bits / 6
  #
  $mail_id_size_bits = 72;  # 24, 48, 72, 96

  # redis data (penpals) expiration - time-to-live in seconds of stored items
  $storage_redis_ttl = 16*24*60*60;  # 16 days (only affects penpals data)

  $sql_store_info_for_all_msgs = 1;
  $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 Redis or 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 a 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';  # e.g. milter or release
  # $inet_socket_port = 10024;      # accept SMTP on this TCP port
  # $inet_socket_port = [10024,10026,10027];  # ...possibly on more than one

  $AF_INET6 = eval { require Socket;  Socket::AF_INET6()  } ||
              eval { require Socket6; Socket6::AF_INET6() };

  # prefer using module IO::Socket::IP if available,
  # otherwise fall back to IO::Socket::INET6 or to IO::Socket::INET
  #
  if (eval { require IO::Socket::IP }) {
    $io_socket_module_name = 'IO::Socket::IP';
  } elsif (eval { require IO::Socket::INET6 }) {
    $io_socket_module_name = 'IO::Socket::INET6';
  } elsif (eval { require IO::Socket::INET }) {
    $io_socket_module_name = 'IO::Socket::INET';
  }

  $have_inet4 =  # can we create a PF_INET socket?
    defined $io_socket_module_name && eval {
      my $sock =
        $io_socket_module_name->new(LocalAddr => '0.0.0.0', Proto => 'tcp');
      $sock->close or die "error closing socket: $!"  if $sock;
      $sock ? 1 : undef;
    };

  $have_inet6 =  # can we create a PF_INET6 socket?
    defined $io_socket_module_name &&
    $io_socket_module_name ne 'IO::Socket::INET' &&
    eval {
      my $sock =
        $io_socket_module_name->new(LocalAddr => '::', Proto => 'tcp');
      $sock->close or die "error closing socket: $!"  if $sock;
      $sock ? 1 : undef;
    };

# if (!$have_inet6 && $io_socket_module_name ne 'IO::Socket::INET') {
#   # ok, let's stay on proven grounds, use the IO::Socket::INET anyway
#   if (eval { require IO::Socket::INET }) {
#     $io_socket_module_name = 'IO::Socket::INET';
#   }
# }

  # bind socket to a loopback interface
  if (Net::Server->VERSION < 2) {
    $inet_socket_bind = '127.0.0.1';
  } else {  # requires Net::Server 2 or a patched 0.99 with IPv6 support)
    $inet_socket_bind = $have_inet4 && $have_inet6 ? ['127.0.0.1', '[::1]']
                      : $have_inet6 ? '[::1]' : '127.0.0.1';
  }
  @inet_acl   = qw( 127.0.0.1 [::1] );  # allow SMTP access only from localhost
  @mynetworks = qw( 127.0.0.0/8 [::1] 169.254.0.0/16 [fe80::]/10
                    10.0.0.0/8 172.16.0.0/12 192.168.0.0/16
                    [fc00::]/7 );  # consider also RFC 6598: 100.64.0.0/10
  $originating = 0;  # a boolean, initially reflects @mynetworks match,
                     # but may be modified later through a policy bank

  $forward_method = $have_inet6 && !$have_inet4 ? 'smtp:[::1]:10025'
                                                : 'smtp:[127.0.0.1]:10025';
  $notify_method = $forward_method;

  $resend_method  = undef; # overrides $forward_method on defanging if nonempty
  $release_method = undef; # overrides $notify_method on releasing
                           #   from quarantine if nonempty
  $requeue_method =        # requeuing release from a quarantine
    $have_inet6 && !$have_inet4 ? 'smtp:[::1]:25' : 'smtp:[127.0.0.1]:25';

  $release_format = 'resend';  # (dsn), (arf), attach,  plain,  resend
  $report_format  = 'arf';     # (dsn),  arf,  attach,  plain,  resend

  # when $release_format is 'attach', the following control the attachment:
  $attachment_password = ''; # '': no pwd; undef: PIN; code ref; or static str
  $attachment_email_name = 'msg-%m.eml';
  $attachment_outer_name = 'msg-%m.zip';

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

  $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 RFC 5322 ($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 = 'UTF-8';       # ... header field bodies
  $bdy_encoding = 'UTF-8';       # ... notification body text

  # encoding (encoding in MIME terminology)
  $hdr_encoding_qb = 'Q';        # quoted-printable (default)
# $hdr_encoding_qb = 'B';        # base64

  $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
  # (often just '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', ...

  # Server side certificate and key: $smtpd_tls_cert_file, $smtpd_tls_key_file.
  # These two settings are now deprecated, set fields 'SSL_key_file'
  # and 'SSL_cert_file' directly in %smtpd_tls_server_options instead.
  # For compatibility with 2.10 the values of $smtpd_tls_cert_file
  # and $smtpd_tls_key_file are fed into %smtpd_tls_server_options
  # if fields 'SSL_key_file' and 'SSL_cert_file' are not provided.
  #
  # $smtpd_tls_cert_file = undef;   # e.g. "$MYHOME/cert/amavisd-cert.pem"
  # $smtpd_tls_key_file  = undef;   # e.g. "$MYHOME/cert/amavisd-key.pem"

  # The following options are passed to IO::Socket::SSL::start_SSL() when
  # setting up a server side of a TLS session (from MTA). The only options
  # passed implicitly are SSL_server, SSL_hostname, and SSL_error_trap.
  # See IO::Socket::SSL documentation.
  #
  %smtpd_tls_server_options = (
    SSL_verifycn_scheme => 'smtp',
    SSL_session_cache => 2,
#   SSL_key_file    => $smtpd_tls_key_file,
#   SSL_cert_file   => $smtpd_tls_cert_file,
#   SSL_dh_file     => ... ,
#   SSL_ca_file     => ... ,
#   SSL_version     => '!SSLv2,!SSLv3',
#   SSL_cipher_list => 'HIGH:!MD5:!DSS:!aNULL',
#   SSL_passwd_cb => sub { 'example' },
#   ...
  );

  # The following options are passed to IO::Socket::SSL::start_SSL() when
  # setting up a client side of a TLS session back to MTA. The only options
  # passed implicitly are SSL_session_cache and SSL_error_trap.
  # See IO::Socket::SSL documentation.
  #
  %smtp_tls_client_options = (
    SSL_verifycn_scheme => 'smtp',
#   SSL_version     => '!SSLv2,!SSLv3',
#   SSL_cipher_list => 'HIGH:!MD5:!DSS:!aNULL',
#   SSL_client_ca_file => ... ,
  );

  $dkim_minimum_key_bits = 1024;    # min acceptable DKIM key size (in bits)
                                    # for whitelisting

  # 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';
  $unchecked_quarantine_to  = 'unchecked-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 $*_quarantine_to specifies direct local delivery)
  $QUARANTINEDIR = undef;  # no quarantine unless overridden by config

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

  # NOTE: all entries can accept mail_body_size_limit and score_factor options
  @spam_scanners = (
    ['SpamAssassin', 'Amavis::SpamControl::SpamAssassin' ],
  # ['SpamdClient',  'Amavis::SpamControl::SpamdClient',
  #   mail_body_size_limit => 65000, score_factor => 1.0,
  # ],
  # ['DSPAM', 'Amavis::SpamControl::ExtProg', $dspam,
  #   [ qw(--stdout --classify --deliver=innocent,spam
  #        --mode=toe --feature noise
  #        --user), $daemon_user ],
  #   mail_body_size_limit => 65000, score_factor => 1.0,
  # ],
  # ['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,
  #   lock_file => '/var/amavis/crm114.lock',
  #   lock_type => 'shared', learner_lock_type => 'exclusive',
  # ],
  # ['Bogofilter', 'Amavis::SpamControl::ExtProg', 'bogofilter',
  #   [ qw(-e -v)],  # -u
  #   mail_body_size_limit => 65000, score_factor => 1.0,
  # ],
  );

  $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_level_char = '*'; # character to be used in X-Spam-Level bar;
                             # empty or undef disables adding this header field
  $sa_num_instances = 1;  # number of SA instances,
                          # usually 1, memory-expensive, keep small
  $sa_local_tests_only = 0;
  $sa_debug = undef;
  $sa_timeout = 30;  # no longer used since 2.6.5

  $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
# $MIN_EXPANSION_QUOTA  = ...   # bytes, undef=not enforced
# $MAX_EXPANSION_QUOTA  = ...   # bytes, undef=not enforced

  # 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,                          MTA gets 250
  #   TempFail: temporary failure, client should retry,           MTA gets 4xx
  #
  # COMPATIBILITY NOTE: the separation of *_destiny values into
  #   D_BOUNCE, D_REJECT, D_DISCARD and D_PASS made settings $warn*sender 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, amavisd will
  #            return a 5xx status response. Depending on an MTA/amavisd setup
  #            this will result either in a reject status passed back to a
  #            connecting SMTP client (in a pre-queue setup: proxy or milter),
  #            or an MTA will generate a bounce in a post-queue setup.
  #            If not all recipients agree on rejecting a message (like when
  #            different recipients have different thresholds on bad mail
  #            contents and LMTP is not used) amavisd sends a bounce by itself
  #            (same as D_BOUNCE).
  #
  # D_TEMPFAIL indicates a temporary failure, mail will not be delivered to
  #            its recipients, sender should retry the operation later.
  #
  # 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 or other pre-queue filtering setups
  #   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;

  # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS, D_TEMPFAIL
  $final_virus_destiny      = D_DISCARD;
  $final_banned_destiny     = D_DISCARD;
  $final_unchecked_destiny  = D_PASS;
  $final_spam_destiny       = D_PASS;
  $final_bad_header_destiny = D_PASS;

  # If decided to pass viruses (or spam) to certain recipients
  # by %final_destiny_maps_by_ccat yielding a D_PASS, or %lovers_maps_by_ccat
  # yielding a true, 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 this variable undefined
  # or an empty string prevents appending address extension. Recipients
  # which do not match @local_domains_maps are not affected (i.e. non-local
  # recipients (=outbound mail) 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 an 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;

  # since 2.7.0: deprecated some old variables:
  #
  deprecate_var('bool', '$insert_received_line',  1);
  deprecate_var('bool', '$relayhost_is_client',   undef);
  deprecate_var('bool', '$warnvirussender',       undef);
  deprecate_var('bool', '$warnspamsender',        undef);
  deprecate_var('bool', '$sa_spam_report_header', undef);
  deprecate_var('bool', '$sa_spam_modifies_subj', 1);
  deprecate_var('bool', '$sa_auto_whitelist',     undef);
  deprecate_var('num',  '$sa_timeout',            30);
  deprecate_var('str',  '$syslog_priority',       'debug');
  deprecate_var('str',  '$SYSLOG_LEVEL',          'mail.debug');
  deprecate_var('str',  '$notify_xmailer_header', undef);
# deprecate_var('array','@spam_modifies_subj_maps');
  1;
} # 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 VBR-Info
    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
    X-Bogosity
  );
  $allowed_added_header_fields{lc('X-Spam-Report')} = 0;
  $allowed_added_header_fields{lc('X-Spam-Checker-Version')} = 0;
  # $allowed_added_header_fields{lc(c(lc $X_HEADER_TAG))}=1; #later:read_config

  # even though SpamAssassin does provide the following header fields, we
  # prefer to provide our own version (per-recipient scores, version hiding);
  # our own non-"X-Spam" header fields are always preferred and need not
  # be listed here
  $prefer_our_added_header_fields{lc($_)} = 1  for qw(
    X-Spam-Status X-Spam-Level X-Spam-Flag X-Spam-Score X-Spam-Report
    X-Spam-Checker-Version
    X-CRM114-Status X-CRM114-CacheID X-DSPAM-Result X-DSPAM-Signature
  );

  # 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 syntax empty long control 8bit utf8 missing multiple);
  $allowed_header_tests{'utf8'} = 0;  # turn this test off by default

  # RFC 6376 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 RFC 4021
  # and IANA registry "Permanent Message Header Field Names";
  # see RFC 3834 for Auto-Submitted; RFC 5518 for VBR-Info (Vouch By Reference)
  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 VBR-Info));
  # note that we are signing Received despite the advise in RFC 6376;
  # 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 Authentication-Results
  #   Keywords Comments Errors-To X-Virus-Scanned X-Archived-At X-No-Archive
  # Some MTAs are dropping Disposition-Notification-To, exclude:
  #   Disposition-Notification-To Disposition-Notification-Options
  # Some mail scanners are dropping Return-Receipt-To, exclude it.
  # 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 - conflicts with mailing lists which must replace a Sender
  # Off: To, Cc, Resent-To, Resent-Cc - too often get garbled by mailers
  $signed_header_fields{lc($_)} = 0  for qw(Sender To Cc Resent-To Resent-Cc);
  #
  # a value greater than 1 causes signing of one additional null instance of
  # a header field, thus prohibiting prepending additional occurrences 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_UNCHECKED.',1', 'UncheckedEncrypted',
    CC_UNCHECKED.',2', 'UncheckedOverLimits',
    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',
  );

  # $partition_tag is a user-specified SQL field value in tables maddr, msgs,
  # msgrcpt and quarantine, inserted into new records, but can be useful even
  # without SQL, accessible through a macro %P and in quarantine templates.
  # It is usually an integer, but depending on a schema may be of 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 $partition_tag may be a scalar
  # (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:
  #
  #  $partition_tag =
  #    sub { my($msginfo)=@_; iso8601_week($msginfo->rx_time) };
  #or:
  #  $partition_tag =
  #    sub { my($msginfo)=@_; iso8601_yearweek($msginfo->rx_time) };
  #
  #or based on a day of a week for short-term cycling (Mo=1, Tu=2,... Su=7):
  #  $partition_tag =
  #    sub { my($msginfo)=@_; iso8601_weekday($msginfo->rx_time) };
  #
  #  $spam_quarantine_method = 'local:W%P/spam/%m.gz';  # quar dir by week num

  # 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), %l by a full unmodified localpart, %u by
  # a lowercased username (a localpart without extension), %e by lowercased
  # addr extension (which includes a delimiter), and %d for lowercased domain.
  # 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 replaced by a comma-separated list of query addresses
  # for a sender (e.g. a full address, domain only, catchall), %a will be
  # replaced by an exact sender address (same as the first entry in %k,
  # suitable for pattern matching), %l by a full unmodified localpart, %u by
  # a lowercased username (a localpart without extension), %e by lowercased
  # addr extension (which includes a delimiter), and %d for lowercased domain.
  # 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 each %k, %a, %l, %u, %e, %d,
  # lookup keys will be replicated accordingly.
  # 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=?,'.
      ' originating=?'.
      ' WHERE partition_tag=? AND mail_id=?',
    'ins_rcp' =>
      'INSERT INTO msgrcpt (partition_tag, mail_id, rseqnum, rid, is_local,'.
      ' content, ds, rs, bl, wl, bspam_level, 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 partition_tag=? 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 list of message-id references
      "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 a current local time and
  # losing the cherishly preserved and prepared timestamp 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;
  # the 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 message [Ss]ignature\b/       => ['pgp','pgp.asc'] ],
    [qr/^PGP message.*[Ee]ncrypted\b/      => ['pgp','pgp.enc'] ],
    [qr/^PGP message\z/                    => ['pgp','pgp.enc'] ],
    [qr/^(?:PGP|GPG) encrypted data\b/     => ['pgp','pgp.enc'] ],
    [qr/^PGP public key\b/                 => ['pgp','pgp.asc'] ],
    [qr/^PGP armored data( signed)? message\b/ => ['pgp','pgp.asc'] ],
    [qr/^PGP armored\b/                    => ['pgp','pgp.asc'] ],
    [qr/^PGP\b/                            => 'pgp' ],

  ### '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/^SVG Scalable Vector Graphics image\b/ => ['image','svg'] ],

    [qr/^MP2\b/                            => ['audio','mpa','mp2'] ],
    [qr/^MP3\b/                            => ['audio','mpa','mp3'] ],
    [qr/\bMPEG ADTS, layer III\b/          => ['audio','mpa','mp3'] ],
    [qr/^ISO Media, MPEG v4 system, 3GPP\b/=> ['audio','mpa','3gpp'] ],
    [qr/^ISO Media, MPEG v4 system\b/      => ['audio','mpa','m4a','m4b'] ],
    [qr/^FLAC audio bitstream data\b/      => ['audio','flac'] ],
    [qr/^Ogg data, FLAC audio\b/           => ['audio','oga'] ],
    [qr/^Ogg data\b/                       => ['audio','ogg'] ],

    [qr/^MPEG video stream data\b/         => ['movie','mpv'] ],
    [qr/^MPEG system stream data\b/        => ['movie','mpg'] ],
    [qr/^MPEG\b/                           => ['movie','mpg'] ],
    [qr/^Matroska data\b/                  => ['movie','mkv'] ],
    [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 Word\b/i                => 'doc'],
    [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/^Compressed Google KML Document\b/ => 'kmz'],

    [qr/^frozen\b/                         => 'F'],
    [qr/^gzip compressed\b/                => 'gz'],
    [qr/^bzip compressed\b/                => 'bz'],
    [qr/^bzip2 compressed\b/               => 'bz2'],
    [qr/^xz compressed\b/                  => 'xz'],
    [qr/^lzma compressed\b/                => 'lzma'],
    [qr/^lrz compressed\b/                 => 'lrz'],  #***(untested)
    [qr/^lzop compressed\b/                => 'lzo'],
    [qr/^LZ4 compressed\b/                 => 'lz4'],
    [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'],
    [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'],  # std. Unix archive (ar)
    [qr/^current ar archive\b/i            => 'a'],    # std. 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/^ISO 9660 CD-ROM filesystem\b/i    => 'iso'],

    [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\b.* 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\b.*\bfor 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 a program path string (or a listref
  # of paths to be searched) or a reference to a variable containing such
  # 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],
#   [[qw(asc uue hqx ync)], \&Amavis::Unpackers::do_ascii],  # not safe
    ['F',    \&Amavis::Unpackers::do_uncompress, \$unfreeze],
             # ['unfreeze', 'freeze -d', 'melt', 'fcat'] ],
    ['Z',    \&Amavis::Unpackers::do_uncompress, \$uncompress],
             # ['uncompress', 'gzip -d', 'zcat'] ],
    ['gz',   \&Amavis::Unpackers::do_uncompress, \$gunzip],
    ['gz',   \&Amavis::Unpackers::do_gunzip],
    ['bz2',  \&Amavis::Unpackers::do_uncompress, \$bunzip2],
    ['xz',   \&Amavis::Unpackers::do_uncompress,
             ['xzdec', 'xz -dc', 'unxz -c', 'xzcat'] ],
    ['lzma', \&Amavis::Unpackers::do_uncompress,
             ['lzmadec', 'xz -dc --format=lzma',
              'lzma -dc', 'unlzma -c', 'lzcat', 'lzmadec'] ],
    ['lrz',  \&Amavis::Unpackers::do_uncompress,
             ['lrzip -q -k -d -o -', 'lrzcat -q -k'] ],
    ['lzo',  \&Amavis::Unpackers::do_uncompress, \$unlzop],
    ['lz4',  \&Amavis::Unpackers::do_uncompress, ['lz4c -d'] ],
    ['rpm',  \&Amavis::Unpackers::do_uncompress, \$rpm2cpio],
             # ['rpm2cpio.pl', 'rpm2cpio'] ],
    [['cpio','tar'], \&Amavis::Unpackers::do_pax_cpio, \$pax],
             # ['/usr/local/heirloom/usr/5bin/pax', 'pax', 'gcpio', '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
    ['rar',  \&Amavis::Unpackers::do_unrar, \$unrar],  # ['unrar', 'rar']
    ['arj',  \&Amavis::Unpackers::do_unarj, \$unarj],  # ['unarj', 'arj']
    ['arc',  \&Amavis::Unpackers::do_arc,   \$arc],    # ['nomarch', 'arc']
    ['zoo',  \&Amavis::Unpackers::do_zoo,   \$zoo],    # ['zoo', 'unzoo']
    ['doc',  \&Amavis::Unpackers::do_ole,   \$ripole],
    ['cab',  \&Amavis::Unpackers::do_cabextract, \$cabextract],
    ['tnef', \&Amavis::Unpackers::do_tnef_ext, \$tnef],
    ['tnef', \&Amavis::Unpackers::do_tnef],
#   ['lha',  \&Amavis::Unpackers::do_lha,   \$lha],  # not safe, use 7z instead
#   ['sit',  \&Amavis::Unpackers::do_unstuff, \$unstuff],  # not safe
    [['zip','kmz'], \&Amavis::Unpackers::do_7zip,  ['7za', '7z'] ],
    [['zip','kmz'], \&Amavis::Unpackers::do_unzip],
    ['7z',   \&Amavis::Unpackers::do_7zip,  ['7zr', '7za', '7z'] ],
    [[qw(gz bz2 Z tar)],
             \&Amavis::Unpackers::do_7zip,  ['7za', '7z'] ],
    [[qw(xz lzma jar cpio arj rar swf lha iso cab deb rpm)],
             \&Amavis::Unpackers::do_7zip,  '7z' ],
    ['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);
  @ip_repu_ignore_maps = (\@ip_repu_ignore_networks);

  @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);
# @unchecked_lovers_maps = ();  # empty, new setting, no need for backw compat.
  @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);
  @unchecked_quarantine_to_maps = (\$unchecked_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 above, but shorter
  @viruses_that_fake_sender_maps = (\$viruses_that_fake_sender_re, 1);
  @spam_tag_level_maps  = (\$sa_tag_level_deflt);     # CC_CLEAN,1
  @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_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 backward 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);
# @debug_recipient_maps = ();
  @remove_existing_spam_headers_maps = (\$remove_existing_spam_headers);

  # new variables, no backward compatibility needed, empty by default:
  # @score_sender_maps, @author_to_policy_bank_maps, @signer_reputation_maps,
  # @message_size_limit_maps

  # build backward-compatible settings hashes
  #
  %final_destiny_maps_by_ccat = (
    # value is normally a list of by-recipient lookup tables, but for compa-
    # tibility with old %final_destiny_by_ccat a value may also be a scalar
    CC_VIRUS,       sub { c('final_virus_destiny') },
    CC_BANNED,      sub { c('final_banned_destiny') },
    CC_UNCHECKED,   sub { c('final_unchecked_destiny') },
    CC_SPAM,        sub { c('final_spam_destiny') },
    CC_BADH,        sub { c('final_bad_header_destiny') },
    CC_MTA.',1',    D_TEMPFAIL,  # MTA response was 4xx
    CC_MTA.',2',    D_REJECT,    # MTA response was 5xx
    CC_MTA,         D_TEMPFAIL,
    CC_OVERSIZED,   D_BOUNCE,
    CC_CATCHALL,    D_PASS,
  );
  %forward_method_maps_by_ccat = (
    CC_CATCHALL,    sub { ca('forward_method_maps') },
  );
  %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.',1', 'id=%n - UNCHECKED: encrypted',
    CC_UNCHECKED.',2', 'id=%n - UNCHECKED: over limits',
    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 5322 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 next-hop 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_UNCHECKED,   sub { ca('unchecked_lovers_maps') },
    CC_SPAM,        sub { ca('spam_lovers_maps') },
    CC_SPAMMY,      sub { ca('spam_lovers_maps') },
    CC_BADH,        sub { ca('bad_header_lovers_maps') },
  );
  %defang_maps_by_ccat = (
    # compatible with legacy %defang_by_ccat: value may be a scalar
    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_UNCHECKED,   sub { c('unchecked_quarantine_method') },
    CC_SPAM,        sub { c('spam_quarantine_method') },
    CC_BADH,        sub { c('bad_header_quarantine_method') },
    CC_CLEAN,       sub { c('clean_quarantine_method') },
  );
  %quarantine_to_maps_by_ccat = (
    CC_VIRUS,       sub { ca('virus_quarantine_to_maps') },
    CC_BANNED,      sub { ca('banned_quarantine_to_maps') },
    CC_UNCHECKED,   sub { ca('unchecked_quarantine_to_maps') },
    CC_SPAM,        sub { ca('spam_quarantine_to_maps') },
    CC_BADH,        sub { ca('bad_header_quarantine_to_maps') },
    CC_CLEAN,       sub { ca('clean_quarantine_to_maps') },
  );
  %admin_maps_by_ccat = (
    CC_VIRUS,       sub { ca('virus_admin_maps') },
    CC_BANNED,      sub { ca('banned_admin_maps') },
    CC_UNCHECKED,   sub { ca('virus_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') },  #usually 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,       undef,
    CC_BANNED,      sub { c('warnbannedsender') },
    CC_SPAM,        undef,
    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 = ( );
  1;
} # 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;
*read_cidr       = \&Amavis::Util::read_cidr;
*idn_to_ascii    = \&Amavis::Util::idn_to_ascii;  # RFC 3490: ToASCII
*idn_to_utf8     = \&Amavis::Util::idn_to_utf8;   # RFC 3490: ToUnicode
*mail_idn_to_ascii = \&Amavis::Util::mail_addr_idn_to_ascii;
*dump_hash       = \&Amavis::Util::dump_hash;
*dump_array      = \&Amavis::Util::dump_array;
*ask_daemon      = \&Amavis::AV::ask_daemon;
*ask_clamav      = \&Amavis::AV::ask_clamav;  # deprecated, use ask_daemon
*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_yearweek      = \&Amavis::rfc2821_2822_Tools::iso8601_yearweek;
*iso8601_year_and_week = \&Amavis::rfc2821_2822_Tools::iso8601_year_and_week;
*iso8601_weekday       = \&Amavis::rfc2821_2822_Tools::iso8601_weekday;
*iso8601_timestamp     = \&Amavis::rfc2821_2822_Tools::iso8601_timestamp;
*iso8601_utc_timestamp = \&Amavis::rfc2821_2822_Tools::iso8601_utc_timestamp;

# a shorthand for creating a regexp-based lookup table
sub new_RE    { Amavis::Lookup::RE->new(@_) }

# shorthand: construct a query object for a DNSxL query on an IP address
sub q_dns_a   { Amavis::Lookup::DNSxL->new(@_) }  # dns zone, expect, resolver

# shorthand: construct a query object for an SQL field
sub q_sql_s   { Amavis::Lookup::SQLfield->new(undef, $_[0], 'S-') }  # string
sub q_sql_n   { Amavis::Lookup::SQLfield->new(undef, $_[0], 'N-') }  # numeric
sub q_sql_b   { Amavis::Lookup::SQLfield->new(undef, $_[0], 'B-') }  # boolean

# shorthand: construct a query object for an LDAP attribute
sub q_ldap_s  { Amavis::Lookup::LDAPattr->new(undef, $_[0], 'S-') }  # string
sub q_ldap_n  { Amavis::Lookup::LDAPattr->new(undef, $_[0], 'N-') }  # numeric
sub q_ldap_b  { Amavis::Lookup::LDAPattr->new(undef, $_[0], 'B-') }  # boolean

sub Opaque    { Amavis::Lookup::Opaque->new(@_) }
sub OpaqueRef { Amavis::Lookup::OpaqueRef->new(@_) }
#
# Opaque provides a wrapper to arbitrary data structures, allowing them to be
# treated as 'constant' pseudo-lookups, i.e. preventing arrays and hashes from
# being interpreted as lookup lists/tables. In case of $forward_method this
# allows for a listref of failover methods. Without the protection of Opaque
# the listref would be interpreted by a lookup() as an acl lookup type instead
# of a match-always data structure. The Opaque subroutine is not yet available
# during a BEGIN phase, so this assignment must come after compiling the rest
# of the code.
#
# This is the only case where both an array @*_maps as well as its default
# element are members of a policy bank. Use lazy evaluation through a sub
# to make this work as expected.
#
# @forward_method_maps = ( OpaqueRef(\$forward_method) );
@forward_method_maps = ( sub { Opaque(c('forward_method')) } );

# retain compatibility with old names
use vars qw(%final_destiny_by_ccat %defang_by_ccat
            $sql_partition_tag $DO_SYSLOG $LOGFILE);
*final_destiny_by_ccat = \%final_destiny_maps_by_ccat;
*defang_by_ccat = \%defang_maps_by_ccat;
*sql_partition_tag = \$partition_tag;
*DO_SYSLOG = \$do_syslog;
*LOGFILE = \$logfile;

@virus_name_to_spam_score_maps =
  (new_RE(  # the order matters, first match wins
    [ qr'^Structured\.(SSN|CreditCardNumber)\b'            => 0.1 ],
    [ qr'^(Heuristics\.)?Phishing\.'                       => 0.1 ],
    [ qr'^(Email|HTML)\.Phishing\.(?!.*Sanesecurity)'      => 0.1 ],
    [ qr'^Sanesecurity\.(Malware|Rogue|Trojan)\.' => undef ],# keep as infected
    [ qr'^Sanesecurity\.Foxhole\.Zip_exe'                  => 0.1 ], # F.P.
    [ qr'^Sanesecurity\.Foxhole\.'                => 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'^Doppelstern\.(Spam|Scam|Phishing|Junk|Lott|Loan)'=> 0.1 ],
    [ qr'^Bofhland\.Phishing'                              => 0.1 ],
    [ qr'^ScamNailer\.'                                    => 0.1 ],
    [ qr'^HTML/Bankish'                                    => 0.1 ],  # F-Prot
    [ qr'^PORCUPINE_JUNK'                                  => 0.1 ],
    [ qr'^PORCUPINE_PHISHING'                              => 0.1 ],
    [ qr'^Porcupine\.Junk'                                 => 0.1 ],
    [ qr'^PhishTank\.Phishing\.'                           => 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(
    @disclaimer_options_bysender_maps @dkim_signature_options_bysender_maps
    @local_domains_maps @mynetworks_maps @ip_repu_ignore_maps
    @forward_method_maps @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_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 @debug_recipient_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 @virus_name_to_policy_bank_maps
    @remove_existing_spam_headers_maps
    @sa_userconf_maps @sa_username_maps

    @keep_decoded_original_maps @map_full_type_to_short_type_maps
    @virus_lovers_maps @spam_lovers_maps @unchecked_lovers_maps
    @banned_files_lovers_maps @bad_header_lovers_maps
    @virus_quarantine_to_maps @banned_quarantine_to_maps
    @unchecked_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 @spam_modifies_subj_maps
    @warnvirusrecip_maps @warnbannedrecip_maps @warnbadhrecip_maps
    @addr_extension_virus_maps  @addr_extension_spam_maps
    @addr_extension_banned_maps @addr_extension_bad_header_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 (-S _ || -b _ || -c _) { $msg = "is not a regular file or pipe" }
    elsif (!$i_know_what_i_am_doing{no_conf_file_writable_check}) {
      if    ($> && -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
    }
    # avoid magic of searching @INC in do() and reporting unrelated errors
    $config_file = './'.$config_file  if $config_file !~ m{^\.{0,2}/};
    local($1,$2,$3,$4,$5,$6,$7,$8,$9);
    local $/ = $/;  # protect us from a potential change in a config file
    $! = 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;
  @zmq_sockets  = ( "ipc://$MYHOME/amavisd-zmq.sock" )  if !@zmq_sockets;
  $pid_file     = "$MYHOME/amavisd.pid"     if !defined $pid_file && $daemonize;
# just keep $lock_file undefined by default, a temp file (POSIX::tmpnam) will
# be provided by Net::Server for 'flock' serialization on a socket accept()
# $lock_file    = "$MYHOME/amavisd.lock"    if !defined $lock_file;
  local($1,$2);
  $X_HEADER_LINE = $myproduct_name . ' at ' .
    Amavis::Util::idn_to_ascii($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_utf8}"';
  $hdrfrom_notify_sender = $pname . ' <postmaster@${myhostname_ascii}>'
    if !defined $hdrfrom_notify_sender;
  $hdrfrom_notify_recip = $mailfrom_notify_recip eq ''
    ? $hdrfrom_notify_sender
    : sprintf("%s <%s>", $pname,
              Amavis::Util::mail_addr_idn_to_ascii($mailfrom_notify_recip))
    if !defined $hdrfrom_notify_recip;
  $hdrfrom_notify_admin = $mailfrom_notify_admin eq ''
    ? $hdrfrom_notify_sender
    : sprintf("%s <%s>", $pname,
              Amavis::Util::mail_addr_idn_to_ascii($mailfrom_notify_admin))
    if !defined $hdrfrom_notify_admin;
  $hdrfrom_notify_spamadmin = $mailfrom_notify_spamadmin eq ''
    ? $hdrfrom_notify_sender
    : sprintf("%s <%s>", $pname,
              Amavis::Util::mail_addr_idn_to_ascii($mailfrom_notify_spamadmin))
    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;

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

1;

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

# serialize a data structure to JSON, RFC 7159

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&boolean &numeric);
}
use subs @EXPORT_OK;

our %jesc = (  # JSON escaping
  "\x22" => '\\"', "\x5C" => '\\\\',
  "\x08" => '\\b', "\x09" => '\\t',
  "\x0A" => '\\n', "\x0C" => '\\f', "\x0D" => '\\r',
  "\x{2028}" => '\\u2028', "\x{2029}" => '\\u2029' );
  # escape also the Line Separator (U+2028) and Paragraph Separator (U+2029)
  # http://timelessrepo.com/json-isnt-a-javascript-subset

our($FALSE, $TRUE) = ('false', 'true');
sub boolean { bless($_[0] ? \$TRUE : \$FALSE) }
sub numeric { my $value = $_[0]; bless(\$value) }

# serialize a data structure to JSON, RFC 7159
# expects logical characters in scalars, returns a string of logical chars
#
sub encode($);  # prototype
sub encode($) {
  my $val = $_[0];
  my $ref = ref $val;
  local $1;
  if ($ref) {
    if ($ref eq 'ARRAY') {
      return '[' . join(',', map(encode($_), @$val)) . ']';
    } elsif ($ref eq 'HASH') {
      return '{' .
        join(',',
          map {
            my $k = $_;
            $k =~ s{ ([\x00-\x1F\x7F\x{2028}\x{2029}"\\]) }
                   { $jesc{$1} || sprintf('\\u%04X',ord($1)) }xgse;
            '"' . $k . '":' . encode($val->{$_});
          } sort keys %$val
        ) . '}';
    } elsif ($ref->isa('Amavis::JSON')) {  # numeric or boolean type
      return defined $$val ? $$val : 'null';
    }
    # fall through, encode other refs as strings, helps debugging
  }
  return 'null' if !defined $val;
  { # concession on a perl 5.20.0 bug [perl #122148] (fixed in 5.20.1)
    # - just warn, do not abort
    use warnings NONFATAL => qw(utf8);
    $val =~ s{ ([\x00-\x1F\x7F\x{2028}\x{2029}"\\]) }
             { $jesc{$1} || sprintf('\\u%04X',ord($1)) }xgse;
  };
  '"' . $val . '"';
}

1;

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

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

use POSIX qw(locale_h strftime);
use Fcntl qw(:flock F_GETFL F_SETFL FD_CLOEXEC);
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Unix::Syslog qw(:macros :subs);
use Time::HiRes ();

# since IO::File 1.10 (comes with perl 5.8.1):
#   If "IO::File::open" is given a mode that includes the ":" character,
#   it passes all the three arguments to a three-argument "open" operator.

use vars qw($loghandle);  # log file handle when logging to a file
use vars qw($log_to_stderr $log_to_syslog $logfile_name $within_write_log);
use vars qw($current_amavis_log_id);  # tracks am_id() / $msginfo->log_id
use vars qw($current_actual_syslog_ident $current_actual_syslog_facility);
use vars qw($log_lines $log_retries %log_entries_by_level %log_status_counts);
use vars qw($log_prio_debug $log_prio_info $log_prio_notice
            $log_prio_warning $log_prio_err $log_prio_crit);

BEGIN {  # saves a few ms by avoiding a subroutine call later
  $log_prio_debug   = LOG_DEBUG;
  $log_prio_info    = LOG_INFO;
  $log_prio_notice  = LOG_NOTICE;
  $log_prio_warning = LOG_WARNING;
  $log_prio_err     = LOG_ERR;
  $log_prio_crit    = LOG_CRIT;
  $log_to_stderr = 1;  # default until config files have been read
}

sub init($$) {
  ($log_to_syslog, $logfile_name) = @_;
  $log_lines = 0; %log_entries_by_level = ();
  $log_retries = 0; %log_status_counts = ();
  $log_to_stderr =
    $log_to_syslog || (defined $logfile_name && $logfile_name ne '') ? 0 : 1;
  open_log();
}

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

# task id as shown in the log, also known as am_id, tracks $msginfo->log_id
#
sub amavis_log_id(;$) {
  $current_amavis_log_id = $_[0]  if @_;
  $current_amavis_log_id;
}

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

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

sub open_log() {
  if ($log_to_syslog && !$log_to_stderr) {
    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";
    # man syslog(3) on Linux: The argument 'ident' in the call of openlog()
    # is probably stored as-is. Thus, if the string it points to is changed,
    # syslog() may start prepending the changed string, and if the string
    # it points to ceases to exist, the results are undefined. Most portable
    # is to use a string constant.  (we use a static variable here)
    $current_actual_syslog_ident = $id; $current_actual_syslog_facility = $fac;
    openlog($id, LOG_PID | LOG_NDELAY, $syslog_facility_num);

  } elsif ($log_to_stderr || $logfile_name eq '') {  # logging to STDERR
    STDERR->autoflush(1);  # just in case (should already be on by default)
    STDERR->fcntl(F_SETFL, O_APPEND)
      or warn "Error setting O_APPEND on STDERR: $!";

  } elsif ($logfile_name ne '') {
    $loghandle = IO::File->new;
    # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
    $loghandle->open($logfile_name,
                     Amavis::Util::untaint(O_CREAT|O_APPEND|O_WRONLY), 0640)
      or die "Failed to open log file $logfile_name: $!";
    binmode($loghandle,':bytes') or die "Can't cancel :utf8 mode: $!";
    $loghandle->autoflush(1);
    if (defined $daemon_user && $daemon_user ne '' && $> == 0) {
      local($1);
      my $uid = $daemon_user=~/^(\d+)$/ ? $1 : (getpwnam($daemon_user))[2];
      if ($uid) {
        chown($uid,-1,$logfile_name)
          or die "Can't chown logfile $logfile_name to $uid: $!";
      }
    }
  }
}

sub close_log() {
  if ($log_to_syslog) {
    closelog();
    $current_actual_syslog_ident = $current_actual_syslog_facility = undef;
  } elsif (defined($loghandle) && $logfile_name ne '') {
    $loghandle->close or die "Error closing log file $logfile_name: $!";
    undef $loghandle;
  }
}

# Log either to syslog or to a file
#
sub write_log($$) {
  my($level,$errmsg) = @_;
  return  if $within_write_log;
  $within_write_log++;
  my $am_id = !defined $current_amavis_log_id ? ''
                                              : "($current_amavis_log_id) ";
# my $old_locale = POSIX::setlocale(LC_TIME,'C');  # English dates required!
  my $alert_mark = $level >= 0 ? '' : $level >= -1 ? '(!)' : '(!!)';
# $alert_mark .= '*'  if $> == 0;
  $log_entries_by_level{"$level"}++;

  my $prio = $level >=  3 ? $log_prio_debug  # most frequent first
         # : $level >=  2 ? $log_prio_info
           : $level >=  1 ? $log_prio_info
           : $level >=  0 ? $log_prio_notice
           : $level >= -1 ? $log_prio_warning
           : $level >= -2 ? $log_prio_err
           :                $log_prio_crit;

  if ($log_to_syslog && !$log_to_stderr) {
    if ($Amavis::Util::current_config_syslog_ident
          ne $current_actual_syslog_ident ||
        $Amavis::Util::current_config_syslog_facility
          ne $current_actual_syslog_facility) {
      close_log()  if defined $current_actual_syslog_ident ||
                      defined $current_actual_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) . '...');
      Unix::Syslog::_isyslog($prio,
                             $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);
    Unix::Syslog::_isyslog($prio, $am_id . $pre . $errmsg);
    if ($! != 0) { $log_retries++; $log_status_counts{"$!"}++ }

  } elsif ($log_to_stderr || !defined $loghandle) {
    $log_lines++;
    my $prefix;
    if ($DEBUG) {
      my $now = Time::HiRes::time;  # timestamp with milliseconds
      $prefix = sprintf('%s:%06.3f %s %s[%s]: ',  # syslog-like prefix
        strftime('%b %e %H:%M',localtime($now)), $now-int($now/60)*60,
        Amavis::Util::idn_to_utf8(c('myhostname')), c('myprogram_name'), $$);
    } else {
      $prefix = "<$prio>";  # sd-daemon(3), SyslogLevelPrefix=true
    }
    # avoid multiple calls to write(2), join the string first!
    my $s = $prefix . $am_id . $alert_mark . $errmsg . "\n";
    #
    # IEEE Std 1003.1, 2013: Write requests to a pipe or FIFO shall be handled
    # in the same way as a regular file with the following exceptions: [...]
    # - There is no file offset associated with a pipe, hence each write
    # request shall append to the end of the pipe.
    # - Write requests of {PIPE_BUF} bytes or less shall not be interleaved
    # with data from other processes doing writes on the same pipe.
    # Writes of greater than {PIPE_BUF} bytes may have data interleaved, on
    # arbitrary boundaries, with writes by other processes, whether or not
    # the O_NONBLOCK flag of the file status flags is set.
    #
    # PIPE_BUF is 512 on *BSD, 4096 on Linux.
    print STDERR ($s)  or die "Error writing to STDERR: $!";

  } else {
    $log_lines++;
    my $now = Time::HiRes::time;
    my $prefix = sprintf('%s %s %s[%s]: ',  # prepare a syslog-like prefix
      strftime('%b %e %H:%M:%S',localtime($now)),
      Amavis::Util::idn_to_utf8(c('myhostname')), c('myprogram_name'), $$);
    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() seems redundant with O_APPEND:
    # IEEE Std 1003.1, 2013: If the O_APPEND flag of the file status flags is
    # set, the file offset shall be set to the end of the file prior to each
    # write and no intervening file modification operation shall occur between
    # changing the file offset and the write operation.
    seek($loghandle,0,2)   or die "Can't position log file to its tail: $!";
    $loghandle->print($s)  or die "Error writing to log file: $!";
    # we have autoflush on, so unlocking here is safe
    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::DbgLog;
use strict;
use re 'taint';

BEGIN {
  use vars qw(@ISA $VERSION);
  $VERSION = '2.412';
  import Amavis::Conf qw(:platform $TEMPBASE);
  import Amavis::Log qw(write_log);
}

use POSIX qw(locale_h strftime);
use IO::File ();
use Time::HiRes ();
# use File::Temp ();

sub new {
  my $class = $_[0];
  my($self,$fh);
# eval {  # calls croak() if an error occurs
#   $fh = File::Temp->new(DIR => $TEMPBASE, SUFFIX => '.log',
#                         TEMPLATE => sprintf('dbg-%05d-XXXXXXXX',$my_pid));
#   $fh  or warn "Can't create a temporary debug log file: $!";
#   1;
# } or do {
#   my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
#   warn "Can't create a temporary debug log file: $eval_stat";
# };
  $fh = IO::File->new_tmpfile;
  $fh  or warn "Can't create a temporary debug log file: $!";
  $self = bless { fh => $fh }, $class  if $fh;
  $self;
}

sub DESTROY {
  my $self = $_[0];
  undef $self->{fh};
};

sub flush {
  my $self = $_[0];
  my $fh = $self->{fh};
  !$fh ? 1 : $fh->flush;
}

sub reposition_to_end {
  my $self = $_[0];
  my $fh = $self->{fh};
  !$fh ? 1 : seek($fh,0,2);
}

# Log to a temporary file, to be retrieved later by dump_captured_log()
#
sub write_dbg_log {
  my($self, $level,$errmsg) = @_;
  my $fh = $self->{fh};
  # ignoring failures
  $fh->printf("%06.3f %d %s\n", Time::HiRes::time, $level, $errmsg)  if $fh;
  1;
}

sub dump_captured_log {
  my($self, $dump_log_level,$enable_log_capture_dump) = @_;
  my $fh = $self->{fh};
  if ($fh) {
    # copy the captured temporary log to a real log if requested
    if ($enable_log_capture_dump) {
      $fh->flush or die "Can't flush debug log file: $!";
      $fh->seek(0,0) or die "Can't rewind debug log file: $!";
      my($ln,$any_logged);
      for ($! = 0; defined($ln=<$fh>); $! = 0) {
        chomp($ln);
        my($timestamp,$level,$errmsg) = split(/ /,$ln,3);
        if (!$any_logged) {
          write_log($dump_log_level, 'CAPTURED DEBUG LOG DUMP BEGINS');
          $any_logged = 1;
        }
        write_log($dump_log_level,
                  sprintf('%s:%06.3f %s',
                          strftime('%H:%M', localtime($timestamp)),
                          $timestamp - int($timestamp/60)*60,  $errmsg));
      }
      defined $ln || $! == 0  or die "Error reading from debug log file: $!";
      write_log($dump_log_level, 'CAPTURED DEBUG LOG DUMP ENDS')
        if $any_logged;
    }
    # clear the temporary file, prepare it for re-use
    $fh->seek(0,0) or die "Can't rewind debug log file: $!";
    $fh->truncate(0) or die "Can't truncate debug log file: $!";
  }
  1;
}

1;

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

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

use Time::HiRes ();

sub get_rusage() {
  my($rusage_self, $rusage_children);
  $rusage_self = Unix::Getrusage::getrusage()
    if Unix::Getrusage->UNIVERSAL::can("getrusage");
  $rusage_children = Unix::Getrusage::getrusage_children()
    if $rusage_self && Unix::Getrusage->UNIVERSAL::can("getrusage_children");
  # 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
  ($rusage_self, $rusage_children);
}

# clear array @timing and enter start time
#
sub init() {
  @timing = (); section_time('init');
  ($rusage_self_initial, $rusage_children_initial) = get_rusage();
}

# enter current time reading into array @timing
#
sub section_time($) {
  push(@timing, $_[0], Time::HiRes::time);
}

# returns a string - a report of elapsed time by section
#
sub report() {
  my($rusage_self, $rusage_children);
  ($rusage_self, $rusage_children) = get_rusage()  if $rusage_self_initial;
  section_time('rundown');
  my($notneeded, $t0) = (shift(@timing), shift(@timing));
  my $total = $t0 <= 0 ? 0 : $timing[-1] - $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
    my $fmt = $dt >= 0.005 ? "%.0f" : "%.1f";
    push(@sections, sprintf("%s: $fmt (%.0f%%)%.0f",
                            $section, $dt*1000, $dtp, $dtp_c));
    $t0 = $t;
  }
  my $cpu_usage_sum;
  if ($rusage_self && $rusage_children) {
    $cpu_usage_sum =
      ($rusage_self->{ru_utime}     - $rusage_self_initial->{ru_utime}) +
      ($rusage_self->{ru_stime}     - $rusage_self_initial->{ru_stime}) +
      ($rusage_children->{ru_utime} - $rusage_children_initial->{ru_utime}) +
      ($rusage_children->{ru_stime} - $rusage_children_initial->{ru_stime});
  }
  !$cpu_usage_sum ?
    sprintf('TIMING [total %.0f ms] - %s', $total*1000, join(', ',@sections))
  : sprintf('TIMING [total %.0f ms, cpu %.0f ms] - %s',
            $total*1000, $cpu_usage_sum*1000, join(', ',@sections));
}

# returns a string - getrusage(2) counters deltas and gauges
#
sub rusage_report() {
  my($rusage_self, $rusage_children) = get_rusage();
  my(@msg);
  if ($rusage_self && $rusage_children) {
    my(@fields) = qw(minflt majflt nswap inblock oublock
                     msgsnd msgrcv nsignals nvcsw nivcsw
                     maxrss ixrss idrss isrss utime stime);
    for (@fields) {
      my $cn = 'ru_' . $_;
      my $f = '%d';
      if ($_ eq 'maxrss') {
        # this one is a gauge, not a counter
      } else {  # is a counter
        $rusage_self->{$cn} -= $rusage_self_initial->{$cn};
        $rusage_children->{$cn} -= $rusage_children_initial->{$cn};
        $f = '%.3f'  if /time\z/;
      }
      push(@msg, sprintf("%s=$f+$f", $_, $rusage_self->{$cn},
                                         $rusage_children->{$cn}));
    }
  }
  !@msg ? undef : join(', ',@msg);
}

# 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.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&untaint &untaint_inplace &min &max &minmax
                  &unique_list &unique_ref &format_time_interval
                  &is_valid_utf_8 &truncate_utf_8
                  &safe_encode &safe_encode_utf8 &safe_encode_utf8_inplace
                  &safe_decode &safe_decode_utf8 &safe_decode_latin1
                  &safe_decode_mime &q_encode &orcpt_encode &orcpt_decode
                  &xtext_encode &xtext_decode &proto_encode &proto_decode
                  &idn_to_ascii &idn_to_utf8 &clear_idn_cache
                  &mail_addr_decode &mail_addr_idn_to_ascii
                  &ll &do_log &do_log_safe &snmp_count &snmp_count64
                  &snmp_counters_init &snmp_counters_get &snmp_initial_oids
                  &debug_oneshot &update_current_log_level
                  &flush_captured_log &reposition_captured_log_to_end
                  &dump_captured_log &log_capture_enabled
                  &am_id &new_am_id &stir_random
                  &add_entropy &fetch_entropy_bytes
                  &generate_mail_id &make_password
                  &crunching_start_time &prolong_timer &get_deadline
                  &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_file &read_text &read_l10n_templates
                  &read_hash &read_array &dump_hash &dump_array
                  &dynamic_destination &collect_equal_delivery_recips);

  import Amavis::Conf qw(:platform $DEBUG c cr ca $mail_id_size_bits
                  $myversion $snmp_contact $snmp_location
                  $trim_trailing_space_in_lookup_result_fields);

  import Amavis::Log qw(amavis_log_id write_log);
  import Amavis::Timing qw(section_time);
}
use subs @EXPORT_OK;

use Errno qw(ENOENT EACCES EAGAIN ESRCH EBADF);
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Digest::MD5;  # 2.22 provides 'clone' method, no longer needed since 2.7.0
use MIME::Base64;
use Encode ();  # Perl 5.8  UTF-8 support
use Scalar::Util qw(tainted);
use Net::LibIDN ();

use vars qw($enc_ascii $enc_utf8 $enc_latin1 $enc_w1252 $enc_tainted
            $enc_taintsafe $enc_is_utf8_buggy);
BEGIN {
  $enc_ascii  = Encode::find_encoding('ascii');
  $enc_utf8   = Encode::find_encoding('UTF-8');  # same as utf-8-strict
  $enc_latin1 = Encode::find_encoding('ISO-8859-1');
  $enc_w1252  = Encode::find_encoding('Windows-1252');
  $enc_ascii  or die  "Amavis::Util: unknown encoding 'ascii'";
  $enc_utf8   or die  "Amavis::Util: unknown encoding 'UTF-8'";
  $enc_latin1 or die  "Amavis::Util: unknown encoding 'ISO-8859-1'";
  $enc_w1252  or warn "Amavis::Util: unknown encoding 'Windows-1252'";
  $enc_tainted = substr($ENV{PATH}.$ENV{HOME}, 0,0);  # tainted empty string
  $enc_taintsafe = 1;  # guessing
  if (!tainted($enc_tainted)) {
    warn "Amavis::Util: can't obtain a tainted string";
  } else {
    # NOTE: [rt.cpan.org #85489] - Encode::encode turns on the UTF8 flag
    # on a passed argument. Give it a copy to avoid turning $enc_tainted
    # or $enc_ps into a UTF-8 string!

    # Encode::is_utf8 is always false on tainted in Perl 5.8, Perl bug #32687
    my $enc_ps = "\x{2029}";  # Paragraph Separator, utf8 flag on
    if (!Encode::is_utf8("$enc_ps $enc_tainted")) {
      $enc_is_utf8_buggy = 1;
      warn "Amavis::Util, Encode::is_utf8() fails to detect utf8 on tainted";
    }
    # test for Encode taint laundering bug [rt.cpan.org #84879], fixed in 2.50
    if (!tainted($enc_ascii->encode("$enc_ps $enc_tainted"))) {
      $enc_taintsafe = 0;
      warn "Amavis::Util, Encode::encode() taint laundering bug, ".
           "fixed in Encode 2.50";
    } elsif (!tainted($enc_ascii->decode("xx $enc_tainted"))) {
      $enc_taintsafe = 0;
      warn "Amavis::Util, Encode::decode() taint laundering bug, ".
           "fixed in Encode 2.50";
    }
    utf8::is_utf8("$enc_ps $enc_tainted")
      or die "Amavis::Util, utf8::is_utf8() fails to detect utf8 on tainted";
    !utf8::is_utf8("\xA0   $enc_tainted")
      or die "Amavis::Util, utf8::is_utf8() claims utf8 on tainted";
    my $t = "$enc_ps $enc_tainted";
    utf8::encode($t);
    tainted($t)
      or die "Amavis::Util, utf8::encode() taint laundering bug";
    !utf8::is_utf8($t)
      or die "Amavis::Util, utf8::encode() failed to clear utf8 flag";
  }
  1;
}

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

sub untaint_inplace($) {
  return undef  if !defined $_[0];  # must return undef even in a list context!
  no re 'taint';
  local $1;  # avoid Perl taint bug: tainted global $1 propagates taintedness
  $_[0] =~ /^(.*)\z/s;
  $_[0] = $1;
}

# 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;  defined $_ && (!defined $m || $_ < $m) && ($m = $_)  for @$r;
  $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;  defined $_ && (!defined $m || $_ > $m) && ($m = $_)  for @$r;
  $m;
}

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

# 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] : \@_;  # accepts 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] : \@_;  # accepts list, or a list ref
  my %seen;  my(@result) = grep(defined($_) && !$seen{$_}++, @$r);
  \@result;
}

sub format_time_interval($) {
  my $t = $_[0];
  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));
}

# returns true if the provided string of octets represents a syntactically
# valid UTF-8 string, otherwise a false is returned
#
sub is_valid_utf_8($) {
# my $octets = $_[0];
  return undef if !defined $_[0];
  #
  # RFC 6532: UTF8-non-ascii = UTF8-2 / UTF8-3 / UTF8-4
  # RFC 3629 section 4: Syntax of UTF-8 Byte Sequences
  #   UTF8-char   = UTF8-1 / UTF8-2 / UTF8-3 / UTF8-4
  #   UTF8-1      = %x00-7F
  #   UTF8-2      = %xC2-DF UTF8-tail
  #   UTF8-3      = %xE0 %xA0-BF UTF8-tail /
  #                 %xE1-EC 2( UTF8-tail ) /
  #                 %xED %x80-9F UTF8-tail /
  #                   # U+D800..U+DFFF are utf16 surrogates, not legal utf8
  #                 %xEE-EF 2( UTF8-tail )
  #   UTF8-4      = %xF0 %x90-BF 2( UTF8-tail ) /
  #                 %xF1-F3 3( UTF8-tail ) /
  #                 %xF4 %x80-8F 2( UTF8-tail )
  #   UTF8-tail   = %x80-BF
  #
  # loose variant:
  #   [\x00-\x7F] |
  #   [\xC0-\xDF][\x80-\xBF] |
  #   [\xE0-\xEF][\x80-\xBF]{2} |
  #   [\xF0-\xF4][\x80-\xBF]{3}
  #
  $_[0] =~ /^ (?: [\x00-\x7F] |
                  [\xC2-\xDF] [\x80-\xBF] |
                  \xE0 [\xA0-\xBF] [\x80-\xBF] |
                  [\xE1-\xEC] [\x80-\xBF]{2} |
                  \xED [\x80-\x9F] [\x80-\xBF] |
                  [\xEE-\xEF] [\x80-\xBF]{2} |
                  \xF0 [\x90-\xBF] [\x80-\xBF]{2} |
                  [\xF1-\xF3] [\x80-\xBF]{3} |
                  \xF4 [\x80-\x8F] [\x80-\xBF]{2} )* \z/xs ? 1 : 0;
}

# cleanly chop a UTF-8 byte sequence to $max_len or less, RFC 3629;
# if $max_len is undefined just chop off any partial last character
#
sub truncate_utf_8($;$) {
  my($octets, $max_len) = @_;
  return $octets if !defined $octets;
  return ''      if defined $max_len && $max_len <= 0;
  substr($octets,$max_len) = ''
                 if defined $max_len && length($octets) > $max_len;
  # missing one or more UTF8-tail octets? chop the entire last partial char
  if ($octets =~ tr/\x00-\x7F//c) {  # triage - is non-ASCII
    $octets =~      s/[\xC0-\xDF]\z//s
      or $octets =~ s/[\xE0-\xEF][\x80-\xBF]{0,1}\z//s
      or $octets =~ s/[\xF0-\xF7][\x80-\xBF]{0,2}\z//s
      or $octets =~ s/[\xF8-\xFB][\x80-\xBF]{0,3}\z//s   # not strictly valid
      or $octets =~ s/[\xFC-\xFD][\x80-\xBF]{0,4}\z//s   # not strictly valid
      or $octets =~ s/ \xFE      [\x80-\xBF]{0,5}\z//sx; # not strictly valid
  }
  $octets;
}

# 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.
# Also works around a CPAN bug #64642 in module Encode:
#   Tainted values have the taint flag cleared when encoded or decoded.
#   https://rt.cpan.org/Public/Bug/Display.html?id=64642
# Fixed in Encode 2.50 [rt.cpan.org #84879].
#
sub safe_encode($$;$) {
# my($encoding,$str,$check) = @_;
  my $encoding = shift;
  return undef  if !defined $_[0];  # must return undef even in a list context!
  my $enc = Encode::find_encoding($encoding);
  $enc  or die "safe_encode: unknown encoding '$encoding'";
  # the resulting UTF8 flag is always off
  return $enc->encode(@_)  if $enc_taintsafe || !tainted($_[0]);
  # Work around a taint laundering bug in Encode [rt.cpan.org #84879].
  # Propagate taintedness across taint-related bugs in module Encode
  # ( Encode::encode in Perl 5.8.0 fills up all available memory
  #   when given a tainted string with a non-encodeable character. )
  $enc_tainted . $enc->encode(untaint($_[0]), $_[1]);
}

# Encodes logical characters to UTF-8 octets, or returns a string of octets
# (with utf8 flag off) unchanged. Ensures the result is always a string of
# octets (utf8 flag off). Unlike safe_encode(), a non-ASCII string with
# utf8 flag off will be returned unchanged, so the result may not be a
# valid UTF-8 string!
#
sub safe_encode_utf8($) {
  my $str = $_[0];
  return undef  if !defined $str;  # must return undef even in a list context!
  utf8::encode($str)  if utf8::is_utf8($str);
  $str;
}

sub safe_encode_utf8_inplace($) {
  return undef  if !defined $_[0];  # must return undef even in a list context!
  utf8::encode($_[0])  if utf8::is_utf8($_[0]);
}

sub safe_decode_latin1($) {
  my $str = $_[0];
  return undef  if !defined $str;  # must return undef even in a list context!
  #
  # ->  http://en.wikipedia.org/wiki/Windows-1252
  # Windows-1252 character encoding is a superset of ISO 8859-1, but differs
  # from the IANA's ISO-8859-1 by using displayable characters rather than
  # control characters in the 80 to 9F (hex) range. [...]
  # It is very common to mislabel Windows-1252 text with the charset label
  # ISO-8859-1. A common result was that all the quotes and apostrophes
  # (produced by "smart quotes" in word-processing software) were replaced
  # with question marks or boxes on non-Windows operating systems, making
  # text difficult to read. Most modern web browsers and e-mail clients
  # treat the MIME charset ISO-8859-1 as Windows-1252 to accommodate
  # such mislabeling. This is now standard behavior in the draft HTML 5
  # specification, which requires that documents advertised as ISO-8859-1
  # actually be parsed with the Windows-1252 encoding.
  #
  if ($enc_taintsafe || !tainted($str)) {
    return ($enc_w1252||$enc_latin1)->decode($str);
  } else {  # work around bugs in Encode
    untaint_inplace($str);
    return $enc_tainted . ($enc_w1252||$enc_latin1)->decode($str);
  }
}

sub safe_decode_utf8($;$) {
  my($str,$check) = @_;
  return undef  if !defined $str;  # must return undef even in a list context!
  if ($enc_taintsafe || !tainted($str)) {
    return utf8::is_utf8($str) ? $str : $enc_utf8->decode($str,$check);
  } else {
    # Work around a taint laundering bug in Encode [rt.cpan.org #84879].
    # Propagate taintedness across taint-related bugs in module Encode.
    untaint_inplace($str);
    return $enc_tainted .
           (utf8::is_utf8($str) ? $str : $enc_utf8->decode($str,$check));
  }
}

sub safe_decode($$;$) {
# my($encoding,$str,$check) = @_;
  my $encoding = shift;
  return undef  if !defined $_[0];  # must return undef even in a list context!
  my $enc = Encode::find_encoding($encoding);
  return $_[0]  if !$enc;
  return $enc->decode(@_)  if $enc_taintsafe || !tainted($_[0]);
  # Work around a taint laundering bug in Encode [rt.cpan.org #84879].
  # Propagate taintedness across taint-related bugs in module Encode.
  $enc_tainted . $enc->decode(untaint($_[0]), $_[1]);
}

# Handle Internationalized Domain Names according to IDNA: RFC 5890, RFC 5891.
# Similar to ToASCII (RFC 3490), but does not fail on garbage.
# Takes a domain name (possibly with utf8 flag on) consisting of U-labels
# or A-labels or NR-LDH labels, converting each label to A-label, lowercased.
# Non- IDNA-valid strings are only encoded to UTF-8 octets but are otherwise
# unchanged. Result is in octets regardless of input, taintedness of the
# argument is propagated to the result.
#
my %idn_encode_cache;
sub clear_idn_cache() { %idn_encode_cache = () }
sub idn_to_ascii($) {
  # propagate taintedness of the argument, but not its utf8 flag
  return tainted($_[0]) ? $idn_encode_cache{$_[0]} . $enc_tainted
                        : $idn_encode_cache{$_[0]}
    if exists $idn_encode_cache{$_[0]};
  my $s = $_[0];
  my $t = tainted($s);  # taintedness of the argument
  return undef  if !defined $s;
  untaint_inplace($s)  if $t;
  # to octets if needed, not necessarily valid UTF-8
  utf8::encode($s)  if utf8::is_utf8($s);
  if ($s !~ tr/\x00-\x7F//c) {  # is all-ASCII (including IP address literal)
    $s = lc $s;
  } else {
    # Net::LibIDN does not like a leading dot (or '@') in a valid domain name,
    # but we need it (e.g. in lookups, meaning subdomains are included), so
    # we have to carry a prefix across the call to Net::LibIDN::idn_to_ascii().
    my $prefix; local($1);
    $prefix = $1  if $s =~ s/^([.\@])//s;  # strip a leading dot or '@'
    # to ASCII-compatible encoding (ACE)
    my $sa = Net::LibIDN::idn_to_ascii($s, 'UTF-8');
    $s = lc $sa  if defined $sa;
    $s = $prefix.$s  if $prefix;
  }
  $idn_encode_cache{$_[0]} = $s;
  $t ? $s.$enc_tainted : $s;  # propagate taintedness of the argument
}

# Handle Internationalized Domain Names according to IDNA: RFC 5890, RFC 5891.
# Implements ToUnicode (RFC 3490). ToUnicode always succeeds, because it just
# returns the original string if decoding fails. In particular, this means that
# ToUnicode has no effect on a label that does not begin with the ACE prefix.
# Takes a domain name (as a string of octets or logical characters)
# of "Internationalized labels" (A-labels, U-labels, or NR-LDH labels),
# converting each label to U-label. Result is a string of octets encoded
# as UTF-8 if input was valid.
#
sub idn_to_utf8($) {
  my $s = $_[0];
  return undef  if !defined $s;
  safe_encode_utf8_inplace($s);  # to octets (if not already)
  if ($s =~ /(?: ^  | \. ) xn-- [\x00-\x2D\x2F-\xFF]{0,58} [\x00-\x2C\x2F-\xFF]
             (?: \z | \. )/xsi) {  # contains XN-label
    my $su = Net::LibIDN::idn_to_unicode(lc $s, 'UTF-8');
    return $su  if defined $su;
  }
  $s;
}

# decode octets found in a mail header field body to a logical chars string
#
sub safe_decode_mime($) {
  my $str = $_[0];  # octets
  return undef  if !defined $str;
  my $chars;  # logical characters

  if ($str !~ tr/\x00-\x7F//c) {  # is all-ASCII
    # test for any RFC 2047 encoded-words
    # encoded-text: Any printable ASCII character other than "?" or SPACE
    # permissive: SPACE and other characters can be observed in Q encoded-word
    if ($str !~ m{ =\? [^?]* \? (?: [Bb] \? [A-Za-z0-9+/=]*? |
                                    [Qq] \? .*? ) \?= }xs) {
      return $str;  # good, keep as-is, all-ASCII with no encoded-words
    }
    # normal, all-ASCII with some encoded-words, try to decode encoded-words
    # using Encode::MIME::Header
    eval { $chars = safe_decode('MIME-Header',$str); 1 }  # RFC 2047
      and return $chars;
    # give up, is all-ASCII but not MIME, just return as-is
    return $str;
  }

  # contains at least some non-ASCII

  if ($str =~ m{ =\? [^?]* \? (?: [Bb] \? [A-Za-z0-9+/=]* |
                                  [Qq] \? [\x20-\x3E\x40-\x7F]* ) \?= }xs) {
    # strange/rare, non-ASCII, but also contains RFC 2047 encoded-words !?
    # decode any RFC 2047 encoded-words, attempt to decode the rest
    # as UTF-8 if valid, or as Windows-1252 (or ISO-8859-1) otherwise
    local($1);
    $str =~ s{ ( =\? [^?]* \? (?: [Bb] \? [A-Za-z0-9+/=]* |
                                  [Qq] \? [\x20-\x3E\x40-\x7F]* ) \?= ) |
               ( [^=]* | . )
             }{ my $s;
                if (defined $1) {
                  $s = $1;  # using Encode::MIME::Header
                  eval { $s = safe_decode('MIME-Header',$s) };
                } else {
                  $s = $2;
                  eval { $s = safe_decode_utf8($s, 1|8); 1 }
                  or do { $s = safe_decode_latin1($s) };
                }
                $s;
             }xgse;
    return $str;
  }

  # contains at least some non-ASCII and no RFC 2047 encoded-words

  # non-MIME-encoded KOI8 seems to be pretty common, attempt some guesswork
  if (length($str) >= 4 &&
      $str !~ tr/\x80-\xA2\xA5\xA8-\xAC\xAE-\xB2\xB5\xB8-\xBC\xBE-\xBF//) {
    # does *not* contain UTF8-tail octets (sans KOI8-U letters in that range)
    my $koi8_cyr_lett_cnt =  # count cyrillic letters
      $str =~ tr/\xA3\xA4\xA6\xA7\xAD\xB3\xB4\xB6\xB7\xBD\xC0-\xFF//;
    if ($koi8_cyr_lett_cnt >= length($str)*2/3 &&  # mostly cyrillic letters
        ($str =~ tr/A-Za-z//) <= 5 &&  # not many ASCII letters
        !is_valid_utf_8($str) ) {
      # try decoding as KOI8-U (like KOI8-R but with 8 extra letters)
      eval { $chars = safe_decode('KOI8-U',$str,1|8); 1; }
        and return $chars;  # hopefully the result makes sense
    }
  }

  # contains at least some non-ASCII, no RFC 2047 encoded-words, not KOI8

  if ($enc_taintsafe || !tainted($str)) {
    # FB_CROAK | LEAVE_SRC
    eval { $chars = $enc_utf8->decode($str,1|8); 1; }  # try strict UTF-8
      and return $chars;
    # fallback, assume Windows-1252 or ISO-8859-1
    # note that Windows-1252 is a proper superset of ISO-8859-1
    return ($enc_w1252||$enc_latin1)->decode($str);
  } else {  # work around bugs in Encode
    untaint_inplace($str);
    eval { $chars = $enc_utf8->decode($str,1|8); 1; }  # try strict UTF-8
      and return $enc_tainted . $chars;
    return $enc_tainted . ($enc_w1252||$enc_latin1)->decode($str);
  }
}

# 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/xs;
  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))}gse;
  $rest =~ tr/ /_/;   # turn spaces into _ (RFC 2047 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/xs;
    $s .= $prefix.$1.$suffix; $rest = $2;
  }
  $s.$tail;
}

# encode "+", "=" and any character outside the range "!" (33) .. "~" (126)
#
sub xtext_encode($) {  # RFC 3461
  my $str = $_[0]; local($1);
  safe_encode_utf8_inplace($str);  # to octets (if not already)
  $str =~ s/([^\041-\052\054-\074\076-\176])/sprintf('+%02X',ord($1))/gse;
  $str;
}

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

sub proto_encode($@) {
  my($attribute_name,@strings) = @_; local($1);
  for ($attribute_name,@strings) {
    # just in case, handle non-octet characters:
    s/([^\000-\377])/sprintf('\\x{%04x}',ord($1))/gse and
      do_log(-1,'proto_encode: non-octet character encountered: %s', $_);
  }
  $attribute_name =~    # encode all but alfanumerics, . _ + -
    s/([^0-9a-zA-Z._+-])/sprintf('%%%02x',ord($1))/gse;
  for (@strings) {      # encode % and nonprintables
    s/([^\041-\044\046-\176])/sprintf('%%%02x',ord($1))/gse;
  }
  $attribute_name . '=' . join(' ',@strings);
}

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

# Expects an e-mail address as a string of octets, where a local part
# may be encoded as UTF-8, and the domain part may be an international
# domain name (IDN) consisting either of U-labels or A-labels or NR-LDH
# labels. Decodes A-labels to U-labels in domain name. If $result_as_octets
# is false decodes the resulting UTF-8 octets from previous step and returns
# a string of characters. If $result_as_octets is true the subroutine skips
# decoding of UTF-8 octets, the result will be a string of octets, only valid
# as UTF-8 if the provided $addr was a valid UTF-8 (garbage-in/garbage-out).
#
sub mail_addr_decode($;$) {
  my($addr, $result_as_octets) = @_;
  return undef  if !defined $addr;
  safe_encode_utf8_inplace($addr);  # to octets (if not already)
  local($1); my $domain;
  my $bracketed = $addr =~ s/^<(.*)>\z/$1/s;
  if ($addr =~ s{ \@ ( [^\@]* ) \z}{}xs) {
    $domain = $1;
    $domain = idn_to_utf8($domain)  if $domain =~ /(?:^|\.)xn--/si;
    if ($domain !~ tr/\x00-\x7F//c) {  # all-ASCII
      $domain = lc $domain;
    } elsif (!$result_as_octets) {  # non-ASCII, attempt decoding UTF-8
      # attempt decoding as strict UTF-8, otherwise fall back to Latin1
      # Not lowercased.
      eval { $domain = safe_decode_utf8($domain, 1|8); 1 }
      or do { $domain = safe_decode_latin1($domain) };
    }
  }
  # deal with localpart
  if (!$result_as_octets && $addr =~ tr/\x00-\x7F//c) {  # non-ASCII
    # attempt decoding as strict UTF-8, otherwise fall back to Latin1
    eval { $addr = safe_decode_utf8($addr, 1|8); 1 }
    or do { $addr = safe_decode_latin1($addr) };
  }
  $addr .= '@'.$domain  if defined $domain;  # put back the domain part
  $bracketed ? '<'.$addr.'>' : $addr;
}

# Expects an e-mail address as a string of octets or as logical characters
# (with utf8 flag on), where a local part may be encoded as UTF-8, and the
# domain part may be an international domain name (IDN) consisting either
# of U-labels or A-labels or NR-LDH. Leaves the localpart unchanged, encodes
# the domain name to ASCII-compatible encoding (ACE) if it is non-ASCII.
# The result is always in octets (UTF-8), domain part is lowercased.
#
sub mail_addr_idn_to_ascii($) {
  my $addr = $_[0];
  return undef  if !defined $addr;
  safe_encode_utf8_inplace($addr);  # to octets (if not already)
  local($1);
  my $bracketed = $addr =~ s/^<(.*)>\z/$1/s;
  $addr =~ s{ (\@ [^\@]*) \z }{ idn_to_ascii($1) }xse;
  $bracketed ? '<'.$addr.'>' : $addr;
}

# RFC 6533: encode an ORCPT mail address (as obtained from orcpt_decode,
# logical characters (utf8 flag may be on)) into one of the forms:
# utf-8-address, utf-8-addr-unitext, utf-8-addr-xtext, or as a legacy
# xtext (RFC 3461), returning a string of octets
#
sub orcpt_encode($;$$) {
  my($str, $smtputf8, $encode_for_smtp) = @_;
  return (undef,undef)  if !defined $str;

  # "Original-Recipient" ":" address-type ";" generic-address
  # address-type = atom
  # atom = [CFWS] 1*atext [CFWS]

  # RFC 3461: 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 $addr_type = '';  # expected 'rfc822' or 'utf-8', possibly empty
  local($1);  # get address-type (atom, up to a semicolon) and remove it
  if ($str =~ s{^[ \t]*([0-9A-Za-z!\#\$%&'*/=?^_`{|}~+-]*)[ \t]*;[ \t]*}{}s) {
    $addr_type = lc $1;
  }
  ll(5) && do_log(5, 'orcpt_encode %s, %s%s%s%s',
                  $addr_type, $str,
                  $smtputf8 ? ', smtputf8' : '',
                  $encode_for_smtp ? ', encode_for_smtp' : '',
                  utf8::is_utf8($str) ? ', is_utf8' : '');
  $str = $1  if $str =~ /^<(.*)>\z/s;

  if ($smtputf8 && utf8::is_utf8($str) &&
      ($addr_type eq 'utf-8' || $str =~ tr/\x00-\x7F//c)) {
    # for use in SMTPUTF8 (RCPT TO) or in message/global-delivery-status
    if ($encode_for_smtp && $str =~ tr{\x00-\x20+=\\}{}) {
      # contains +,=,\,SP,ctrl -> encode as utf-8-addr-unitext
      # HEXPOINT in EmbeddedUnicodeChar is 2 to 6 hexadecimal digits.
      $str =~ s{ ( [^\x21-\x2A\x2C-\x3C\x3E-\x5B\x5D-\x7E\x80-\xF4] ) }
               { sprintf('\\x{%02X}', ord($1)) }xgse;  # 2..6 uppercase hex!
    } else {
      # no restricted characters or not for SMTP -> keep as utf-8-address
      #
      # The utf-8-address form MAY be used in the ORCPT parameter when the
      # SMTP server also advertises support for SMTPUTF8 and the address
      # doesn't contain any ASCII characters not permitted in the ORCPT
      # parameter.  It SHOULD be used in a message/global-delivery-status
      # "Original-Recipient:" or "Final-Recipient:" DSN field, or in an
      # "Original-Recipient:" header field [RFC3798] if the message is a
      # SMTPUTF8 message.
    }
    safe_encode_utf8_inplace($str);  # to octets (if not already)
    $addr_type = 'utf-8';

  } else {
    # RFC 6533: utf-8-addr-xtext MUST be used in the ORCPT parameter
    # when the SMTP server doesn't advertise support for SMTPUTF8
    if ($str =~ tr/\x00-\x7F//c && utf8::is_utf8($str)) {
      # non-ASCII UTF-8, encode as utf-8-addr-xtext
      # RFC 6533: QCHAR = %x21-2a / %x2c-3c / %x3e-5b / %x5d-7e
      # HEXPOINT in EmbeddedUnicodeChar is 2 to 6 hexadecimal digits.
      $str =~ s{ ( [^\x21-\x2A\x2C-\x3C\x3E-\x5B\x5D-\x7E] ) }
               { sprintf('\\x{%02X}', ord($1)) }xgse;  # 2..6 uppercase hex!
      safe_encode_utf8_inplace($str);  # to octets (if not already)
      $addr_type = 'utf-8';
    } else {  # encode as legacy RFC 3461 xtext
      # encode +, =, \, SP, controls
      safe_encode_utf8_inplace($str);  # encode to octets first!
      $str =~ s{ ( [^\x21-\x2A\x2C-\x3C\x3E-\x5B\x5D-\x7E] ) }
               { sprintf('+%02X', ord($1)) }xgse;  # exactly two uppercase hex
      $addr_type = 'rfc822';
    }
  }
  ($addr_type, $str);
}

# Decode an encoded ORCPT e-mail address (a string of octets, encoded as
# xtext, utf-8-addr-xtext, utf-8-addr-unitext, or utf-8-address) as per
# RFC 3461 and RFC 6533. Result is presumably an RFC 5322 -encoded mail
# address, possibly as utf8-flagged characters string (if valid UTF-8),
# no angle brackets.
#
sub orcpt_decode($;$) {
  my($str, $smtputf8) = @_;
  return (undef,undef)  if !defined $str;

  my $addr_type = ''; local($1);
  # get address-type (atom, up to a semicolon) and remove it
  if ($str =~ s{^[ \t]*([0-9A-Za-z!\#\$%&'*/=?^_`{|}~+-]*)[ \t]*;[ \t]*}{}s) {
    $addr_type = lc $1;
  }

  if ($addr_type eq '') {
    # assumed not encoded (e.g. internally generated)
    if ($str =~ tr/\x00-\x7F//c && is_valid_utf_8($str) &&
        eval { $str = safe_decode_utf8($str, 1|8); 1 }) {
      $addr_type = 'utf-8';
    } else {
      $addr_type = 'rfc822';
    }

  } elsif ($addr_type ne 'utf-8') {  # presumably 'rfc822'
    # decode xtext-encoded string as per RFC 3461,
    # hexchar = ASCII "+" immediately followed by two UPPER CASE hex digits
    $str =~ s{ \+ ( [0-9A-F]{2} ) }{ pack('C',hex($1)) }xgse;
    # now have a string of octets, possibly with (invalid) 8bit characters

    # we may have a legacy encoding which should really be a utf-8 addr_type
    if ($smtputf8 && lc $addr_type eq 'rfc822' &&
        $str =~ tr/\x00-\x7F//c && is_valid_utf_8($str) &&
        eval { $str = safe_decode_utf8($str, 1|8); 1 }) {
      $addr_type = 'utf-8';
    }

  } elsif ($str !~ tr/\x00-\x7F//c) {  # address-type is 'utf-8', is all-ASCII
    # Looks like utf-8-addr-xtext or utf-8-addr-unitext.
    # Permissive decoding of EmbeddedUnicodeChar, as well as a legacy xtext:
    # RFC 6533: UTF-8 address type has 3 forms:
    #   utf-8-addr-xtext, utf-8-addr-unitext, and utf-8-address.
    $str =~ s{ \\ x \{ ( [0-9A-Fa-f]{2,6} ) \} |
               \+      ( [0-9A-F]{2} ) }
               { pack('U', hex(defined $1 ? $1 : $2)) }xgse;
    # RFC 6533 prohibits <NUL> and surrogates in EmbeddedUnicodeChar,
    # as well as encoded printable ASCII chars except xtext-specials +, =, \

  } elsif (is_valid_utf_8($str) &&
           eval { $str = safe_decode_utf8($str, 1|8); 1 }) {
    # Looks like a utf-8-address. Successfully decoded UTF-8 octets to chars.
    # permissive decoding of EmbeddedUnicodeChar, as well as a legacy xtext
    $str =~ s{ \\ x \{ ( [0-9A-Fa-f]{2,6} ) \} |
               \+      ( [0-9A-F]{2} ) }
               { pack('U', hex(defined $1 ? $1 : $2)) }xgse;

  } else {  # address-type is 'utf-8', non-ASCII, invalid UTF-8 string
    # RFC 6533: if an address is labeled with the UTF-8 address type
    # but does not conform to utf-8 syntax, then it MUST be copied into
    # the message/global-delivery-status field without alteration.
    # --> just leave $str unchanged as octets
  }

  # result in $str is presumably an RFC 5322 -encoded addr,
  # possibly as utf8-flagged characters, no angle brackets
  ($addr_type, $str);
}

# Mostly for debugging and reporting purposes:
# Convert nonprintable characters in the argument
# to \[rnftbe], or hex code, ( and '\' to '\\' ???),
# and Unicode characters to UTF-8, returning a sanitized string.
#
use vars qw(%quote_controls_map);
BEGIN {
  %quote_controls_map =
    ("\r" => '\\r', "\n" => '\\n', "\t" => '\\t', "\\" => '\\\\');

# leave out the <FF>, <BS> and <ESC>, these are too confusing in the log,
# better to just hand them over to hex quoting ( \xHH )
#   ("\r" => '\\r', "\n" => '\\n', "\f" => '\\f', "\t" => '\\t',
#    "\b" => '\\b', "\e" => '\\e', "\\" => '\\\\');

}
sub sanitize_str {
  my($str, $keep_eol) = @_;
  return ''  if !defined $str;
  safe_encode_utf8_inplace($str);  # to octets (if not already)
  # $str is now in octets, UTF8 flag is off
  local($1);
  if ($keep_eol) {
    # controls except LF, DEL, backslash
    $str =~ s/([\x00-\x09\x0B-\x1F\x7F\\])/
              $quote_controls_map{$1} || sprintf('\\x%02X', ord($1))/gse;
  } else {
    # controls, DEL, backslash
    $str =~ s/([\x00-\x1F\x7F\\])/
              $quote_controls_map{$1} || sprintf('\\x%02X', ord($1))/gse;
  }
  $str;
}

# Set or get Amavis internal task id (also called: log 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 is present
    $amavis_task_id = $_[0];
    amavis_log_id($amavis_task_id);
    $0 = c('myprogram_name') .
         (!defined $amavis_task_id ? '' : " ($amavis_task_id)");
  }
  $amavis_task_id;  # return current value
}

sub new_am_id($;$$) {
  my($str, $cnt, $seq) = @_;
  my $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' ? @$_ : $_), @_));
  utf8::encode($s)  if utf8::is_utf8($s);
# do_log(5,'add_entropy: %s',$s);
  $entropy->add($s);
}

sub fetch_entropy_bytes($) {
  my $n = $_[0];  # number of bytes to collect
  my $result = '';
  for (; $n > 0; $n--) {
    # collect as few bits per MD5 iteration as possible (RFC 4086 sect 6.2.1)
    # let's settle for 8 bits for practical reasons; fewer would be better
    my $digest = $entropy->digest;  # 16 bytes; also destroys accumulator
    $result .= substr($digest,0,1);  # take 1 byte
    $entropy->reset; $entropy->add($digest);  # cycle it back
  }
# ll(5) && do_log(5,'fetch_entropy_bytes %s',
#                  join(' ', map(sprintf('%02x',$_), unpack('C*',$result))));
  $result;
}

# read number of bytes from a /dev/urandom device
#
sub read_random_bytes($$) {
  # my($buff,$required_bytes) = @_;
  $_[0] = '';
  my $required_bytes = $_[1];
  my $fname = '/dev/urandom';  # nonblocking device!
  if ($required_bytes > 0) {
    my $fh = IO::File->new;
    $fh->open($fname,O_RDONLY)  # does a sysopen()
      or die "Can't open $fname: $!";
    $fh->binmode or die "Can't set $fname to binmode: $!";
    my $nbytes = $fh->sysread($_[0], $required_bytes);
    defined $nbytes  or die "Error reading from $fname: $!";
    $nbytes >= $required_bytes  or die "Less data read than requested: $!";
    $fh->close or die "Error closing $fname: $!";
  }
  undef;
}

# stir/initialize perl's random generator and our entropy pool;
# to be called at startup of the main process and each child processes
#
sub stir_random() {
  my $random_bytes;
  eval {
    read_random_bytes($random_bytes,16);  1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    do_log(0, 'read_random_bytes error: %s', $eval_stat);
    undef $random_bytes;
  };
  srand();  # let perl give it a try first, then stir-in some additional bits
  add_entropy($random_bytes, Time::HiRes::gettimeofday, $$, rand());
  #
  # must prevent all child processes working with the same inherited random
  # seed, otherwise modules like File::Temp will step on each other's toes
  my $r = unpack('L', fetch_entropy_bytes(4)) ^ int(rand(0xffffffff));
  srand($r & 0x7fffffff);
}

# generate a reasonably unique (long-term) id based on collected entropy.
# The result is a pair of a (mostly public) mail_id, and a secret id,
# where mail_id == b64(md5(secret_bin)). The secret id could be used to
# authorize releasing quarantined mail. Both the mail_id and secret id are
# strings of characters [A-Za-z0-9-_], with an additional restriction
# for mail_id which must begin and end with an alphanumeric character.
# The number of bits in a mail_id is configurable through $mail_id_size_bits
# and defaults to 72, yielding a 12-character base64url-encoded string.
# The number of bits must be an integral multiple of 24, so that no base64
# trailing padding characters '=' are needed (RFC 4648).
# Note the difference in base64-like encodings:
#   amavisd almost-base64: 62 +, 63 -   (old, no longer used since 2.7.0)
#   RFC 4648 base64:       62 +, 63 /   (not used here)
#   RFC 4648 base64url:    62 -, 63 _
# Generally, RFC 5322 controls, SP and specials must be avoided: ()<>[]:;@\,."
# With version 2.7.0 of amavisd we switched from almost-base64 to base64url
# to avoid having to quote a '+' in regular expressions and in URL.
#
sub generate_mail_id() {
  my($id_b64, $secret_bin);
  # 72 bits =  9 bytes = 12 b64 chars
  # 96 bits = 12 bytes = 16 b64 chars
  $mail_id_size_bits > 0 &&
  $mail_id_size_bits == int $mail_id_size_bits &&
  $mail_id_size_bits % 24 == 0
    or die "\$mail_id_size_bits ($mail_id_size_bits) must be a multiple of 24";
  for (my $j=0; $j<100; $j++) {  # provide some sanity loop limit just in case
    $secret_bin = fetch_entropy_bytes($mail_id_size_bits/8);
    # mail_id is computed as md5(secret), rely on unidirectionality of md5
    $id_b64 = Digest::MD5->new->add($secret_bin)->b64digest;  # b64(md5(sec))
    add_entropy($id_b64,$j);  # fold it back into accumulator
    substr($id_b64, $mail_id_size_bits/6) = '';  # b64, crop to size
    # done if it starts and ends with an alfanumeric character
    last  if $id_b64 =~ /^[A-Za-z0-9].*[A-Za-z0-9]\z/s;
    # retry on less than 7% of cases
    do_log(5,'generate_mail_id retry: %s', $id_b64);
  }
  $id_b64 =~ tr{+/}{-_};  # base64 -> RFC 4648 base64url [A-Za-z0-9-_]
  if (!wantarray) {  # not interested in secret
    $secret_bin = 'X' x length($secret_bin);  # can't hurt to wipe out
    return $id_b64;
  }
  my $secret_b64 = encode_base64($secret_bin,''); # $mail_id_size_bits/6 chars
  $secret_bin = 'X' x length($secret_bin);  # can't hurt to wipe out
  $secret_b64 =~ tr{+/}{-_};  # base64 -> RFC 4648 base64url [A-Za-z0-9-_]
# do_log(5,'generate_mail_id: %s %s', $id_b64, $secret_b64);
  ($id_b64, $secret_b64);
}

# Returns a password that may be used for scrambling of a message being
# released from a quarantine or mangled, with intention of preventing an
# automatic or undesired implicit opening of a potentially dangerous message.
# The first argument may be: a plain string, which is simply passed on
# to the result, or: a code reference (to be evaluated in a scalar context),
# allowing for lazy evaluation of a supplied password generating code,
# or: undef, which causes a generation of a simple 4-digit PIN-like random
# password. The second argument is just passed on unchanged to the supplied
# subroutine and is expected to be a $msginfo object.
#
sub make_password($$) {
  my($password,$msginfo) = @_;
  if (ref $password eq 'CODE') {
    eval {
      $password = &$password($msginfo);
      chomp $password; $password =~ s/^[ \t]+//; $password =~ s/[ \t]+\z//;
      untaint_inplace($password)  if $password =~ /^[A-Za-z0-9:._=+-]*\z/;
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(-1, 'password generating subroutine failed, '.
                 'supplying a default: %s', $@);
      $password = undef;
    };
  }
  if (!defined $password) {  # create a 4-digit random string
    my $r;
    do {
      $r = unpack('S',fetch_entropy_bytes(2));  # 0 .. 65535
      # ditch useless samples beyond 60000
    } until $r < 65536 - (65536 % 10000);
    $password = sprintf('%04d', $r % 10000);
    $r = 0;  # clear the IV field of a scalar (the undef() doesn't do so)
  }
  $password;
}

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, TIM or OID
sub snmp_counters_init() { @counter_names = () }
sub snmp_count(@) { push(@counter_names, @_) }
sub snmp_count64(@) { push(@counter_names, map(ref $_ ?$_ :[$_,1,'C64'], @_)) }
sub snmp_counters_get() { \@counter_names }

sub snmp_initial_oids() {
  return [
    ['sysDescr',    'STR', $myversion],                       # 0..255 octets
    ['sysObjectID', 'OID', '1.3.6.1.4.1.15312.2'],
  # iso.org.dod.internet.private.enterprise.ijs.amavisd-new
    ['sysUpTime',   'INT', int(time)],  # to be converted to TIM
  # later it must be converted to timeticks (10ms units since start)
    ['sysContact',  'STR', safe_encode_utf8($snmp_contact)],  # 0..255 octets
  # Network Unicode format (Net-Unicode) RFC 5198, instead of NVT ASCII
    ['sysName',     'STR', idn_to_utf8(c('myhostname'))],     # 0..255 octets
    ['sysLocation', 'STR', safe_encode_utf8($snmp_location)], # 0..255 octets
    ['sysServices', 'INT', 64],  # application
  ];
}

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

use vars qw($dbg_log);
sub log_capture_enabled(;$) {
  if (@_) {
    my $new_state = $_[0];
    if (!$dbg_log && $new_state) {
      $dbg_log = Amavis::DbgLog->new;
    } elsif ($dbg_log && !$new_state) {
      undef $dbg_log;  # calls its destructor
    }
  }
  $dbg_log ? 1 : 0;
}

use vars qw($current_config_log_level
            $current_config_syslog_ident
            $current_config_syslog_facility);
# keeping current settings avoids the most frequent calls to c()
sub update_current_log_level() {
  $current_config_log_level       = c('log_level') || 0;
  $current_config_syslog_ident    = c('syslog_ident');
  $current_config_syslog_facility = c('syslog_facility');
}

# is message log level below the current log level (i.e. eligible for logging)?
#
sub ll($) {
  (($DEBUG || $debug_oneshot) && $_[0] > 0 ? 0 : $_[0])
     <= $current_config_log_level
  || $dbg_log;
}

# write a log entry (optimized, called often)
#
sub do_log($$;@) {
# my($level,$errmsg,@args) = @_;
  my $level = $_[0];
# if (ll($level)) {  # inlined and reorderd the ll() call for speed
  if ( $level <= $current_config_log_level ||
       ( ($DEBUG || $debug_oneshot) && $level > 0
         && 0 <= $current_config_log_level ) ||
       $dbg_log ) {
    my $errmsg;  # the $_[1] is expected to be ASCII or UTF-8 octets (not char)
    if (@_ <= 2) {  # no arguments to sprintf
      $errmsg = $_[1];
    } elsif (@_ == 3) {  # a single argument to sprintf, optimized common case
      if (utf8::is_utf8($_[2])) {
        my $arg1 = $_[2]; utf8::encode($arg1);
        $errmsg = sprintf($_[1], $arg1);
      } else {
        $errmsg = sprintf($_[1], $_[2]);
      }
    } else {
      # treat $errmsg as sprintf format string if additional args are provided;
      # encode arguments individually to avoid mojibake when UTF8-flagged and
      # non- UTF8-flagged strings are concatenated;
      my @args = @_[2..$#_];
      for (@args) { utf8::encode($_) if utf8::is_utf8($_) }
      $errmsg = sprintf($_[1], @args);
    }
    local($1);
    # protect controls, DEL, and backslash; make sure to leave UTF-8 untouched
    $errmsg =~ s/([\x00-\x1F\x7F\\])/
                 $quote_controls_map{$1} || sprintf('\\x%02X', ord($1))/gse;
    $dbg_log->write_dbg_log($level,$errmsg)  if $dbg_log;
    $level = 0  if ($DEBUG || $debug_oneshot) && $level > 0;
    if ($level <= $current_config_log_level) {
      write_log($level,$errmsg);
###   $Amavis::zmq_obj->write_log($level,$errmsg)  if $Amavis::zmq_obj;
    }
  }
  1;
}

# equivalent to do_log, but protected by eval so that it can't bail out
#
sub do_log_safe($$;@) {
  # ignore failures while keeping perlcritic happy
  eval { do_log(shift,shift,@_) } or 1;
  1;
}

sub flush_captured_log() {
  $dbg_log->flush
    or die "Can't flush debug log file: $!"  if $dbg_log;
}

sub reposition_captured_log_to_end() {
  $dbg_log->reposition_to_end
    or die "Can't reposition debug log file to its end: $!"  if $dbg_log;
}

sub dump_captured_log($$) {
  my($dump_log_level, $enable_log_capture_dump) = @_;
  $dbg_log->dump_captured_log($dump_log_level,
                 $enable_log_capture_dump && ll($dump_log_level))  if $dbg_log;
}

# $timestamp_of_last_reception: a Unix time stamp when an MTA client send the
# last command to us, the most important of which is the reception of a final
# dot in SMTP session, which is a time when a client started to wait for our
# response;  this timestamp, along with a c('child_timeout'), make a deadline
# time for our processing
#
# $waiting_for_client: which timeout is running:
#   false: processing is in our courtyard,  true: waiting for a client
#
use vars qw($timestamp_of_last_reception $waiting_for_client);

sub waiting_for_client(;$) {
  $waiting_for_client = $_[0]  if @_;
  $waiting_for_client;
}

sub get_deadline(@) {
  my($which_section, $allowed_share, $reserve, $max_time) = @_;
  # $allowed_share ... factor between 0 and 1 of the remaining time till a
  #                    deadline, to be allocated to the task that follows
  # $reserve  ... try finishing up $reserve seconds before the deadline;
  # $max_time ... upper limit in seconds for the timer interval
  my($timer_interval, $timer_deadline, $time_to_deadline);
  my $child_t_o = c('child_timeout');
  if (!$child_t_o) {
    do_log(2, 'get_deadline %s - ignored, child_timeout not set',
              $which_section);
  } elsif (!defined $timestamp_of_last_reception) {
    do_log(2, 'get_deadline %s - ignored, master deadline not known',
              $which_section);
  } else {
    my $now = Time::HiRes::time;
    $time_to_deadline = $timestamp_of_last_reception + $child_t_o - $now;
    $timer_interval = $time_to_deadline;
    if (!defined $allowed_share) {
      $allowed_share = 0.6;
      $timer_interval *= $allowed_share;
    } elsif ($allowed_share <= 0) {
      $timer_interval = 0;
    } elsif ($allowed_share >= 1) {
      # leave it unchanged
    } else {
      $timer_interval *= $allowed_share;
    }
    $reserve = 4  if !defined $reserve;
    if ($reserve > 0 && $timer_interval > $time_to_deadline - $reserve) {
      $timer_interval = $time_to_deadline - $reserve;
    }
    if ($timer_interval < 8) {  # be generous, allow at least 6 seconds
      $timer_interval = max(6, min(8,$time_to_deadline));
    }
    my $j = int($timer_interval);
    $timer_interval = $timer_interval > $j ? $j+1 : $j;  # ceiling
    if (defined $max_time && $max_time > 0 && $timer_interval > $max_time) {
      $timer_interval = $max_time;
    }
    ll(5) && do_log(5,'get_deadline %s - deadline in %.1f s, set to %.3f s',
                      $which_section, $time_to_deadline, $timer_interval);
    $timer_deadline = $now + $timer_interval;
  }
  !wantarray ? $timer_interval
             : ($timer_interval, $timer_deadline, $time_to_deadline);
}

sub prolong_timer($;$$$) {
  my($which_section, $allowed_share, $reserve, $max_time) = @_;
  my($timer_interval, $timer_deadline, $time_to_deadline) = get_deadline(@_);
  if (defined $timer_interval) {
    my $prev_timer = alarm($timer_interval);  # restart/prolong the timer
    ll(5) && do_log(5,'prolong_timer %s: timer %d, was %d, deadline in %.1f s',
              $which_section, $timer_interval, $prev_timer, $time_to_deadline);
  }
  !wantarray ? $timer_interval
             : ($timer_interval, $timer_deadline, $time_to_deadline);
}

sub switch_to_my_time($) {      # processing is in our courtyard
  my $msg = $_[0];
  $waiting_for_client = 0;
  $timestamp_of_last_reception = Time::HiRes::time;
  my $child_t_o = c('child_timeout');
  if (!$child_t_o) {
    alarm(0);
  } else {
    prolong_timer( 'switch_to_my_time(' . $msg . ')' );
  }
}

sub switch_to_client_time($) {  # processing is now in client's hands
  my $msg = $_[0];
  my $interval = c('smtpd_timeout');
  $interval = 5  if $interval < 5;
  ll(5) && do_log(5, 'switch_to_client_time %d s, %s', $interval,$msg);
  undef $timestamp_of_last_reception;
  alarm($interval); $waiting_for_client = 1;
}

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

# used by freeze: protect % and ~, as well as NUL and \200 for good measure
#
sub st_encode($) {
  my $str = $_[0]; local($1);
  { # concession on a perl 5.20.0 bug [perl #122148] (fixed in 5.20.1)
    # - just warn, do not abort
    use warnings NONFATAL => qw(utf8);
    $str =~ s/([%~\000\200])/sprintf('%%%02X',ord($1))/gse;
  };
  $str;
}

# simple Storable::freeze lookalike
#
sub freeze($);  # prototype
sub freeze($) {
  my $obj = $_[0]; 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 = $_[0];
  return undef  if !defined $str;  # must return undef even in a list context!
  my($ty,@val) = split(/~/,$str,-1);
  s/%([0-9a-fA-F]{2})/pack('C',hex($1))/gse  for @val;
  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 = $_[0]; my $major; my $minor;
  $ccat = $ccat->[0]  if ref $ccat;  # pick the first element if given 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 = $_[0]; my $major; my $minor;
  $ccat = $ccat->[0]  if ref $ccat;  # pick the first element if given 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 category
#
sub cmp_ccat($$) {
  my($a_maj,$a_min) = split(/,/, $_[0], -1);
  my($b_maj,$b_min) = split(/,/, $_[1], -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(/,/, $_[0], -1);
  my($b_maj,$b_min) = split(/,/, $_[1], -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) {
    for my $e ((!defined $ccat ? () : ref $ccat ?@$ccat :$ccat), CC_CATCHALL) {
      if (grep(defined($_) && exists($_->{$e}), @settings_href_list)) {
        # supports lazy evaluation (a 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) {
    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
#
# The readdir() is entitled to fail if the directory changes underneath,
# so do the deletions by chunks: read a limited set of filenames into
# memory, close directory, delete these files, and repeat.
# The current working directory must not be within directories which are
# to be deleted, otherwise rmdir can fail with 'Invalid argument' (e.g.
# on Solaris 10).
#
sub rmdir_recursively($;$);  # prototype
sub rmdir_recursively($;$) {
  my($dir, $exclude_itself) = @_;
  ll(4) && do_log(4, 'rmdir_recursively: %s, excl=%s', $dir,$exclude_itself);
  my($f, @rmfiles, @rmdirs);  my $more = 1;  my $dir_chmoded = 0;
  while ($more) {
    local(*DIR);  $more = 0;
    my $errn = opendir(DIR,$dir) ? 0 : 0+$!;
    if ($errn == EACCES && !$dir_chmoded) {
      # relax protection on directory, then try again
      do_log(3,'rmdir_recursively: enabling read access to directory %s',$dir);
      chmod(0750,$dir)
        or do_log(-1, "Can't change protection-1 on dir %s: %s", $dir, $!);
      $dir_chmoded = 1;
      $errn = opendir(DIR,$dir) ? 0 : 0+$!;  # try again
    }
    if ($errn) { die "Can't open directory $dir: $!" }
    my $cnt = 0;
    # avoid slurping the whole directory contents into memory
    while (defined($f = readdir(DIR))) {
      next  if $f eq '.' || $f eq '..';
      my $fname = $dir . '/' . $f;
      $errn = lstat($fname) ? 0 : 0+$!;
      if ($errn == EACCES && !$dir_chmoded) {
        # relax protection on the directory and retry
        do_log(3,'rmdir_recursively: enabling access to files in dir %s',$dir);
        chmod(0750,$dir)
          or do_log(-1, "Can't change protection-2 on dir %s: %s", $dir, $!);
        $dir_chmoded = 1;
        $errn = lstat($fname) ? 0 : 0+$!;  # try again
      }
      if ($errn) { do_log(-1, "Can't access file \"%s\": $!", $fname,$!) }
      if (-d _) { push(@rmdirs,$f) } else { push(@rmfiles,$f) }
      $cnt++;
      if ($cnt >= 1000) {
        do_log(3,'rmdir_recursively: doing %d files and %d dirs for now in %s',
                 scalar(@rmfiles), scalar(@rmdirs), $dir);
        $more = 1;
        last;
      }
    }
    # fixed by perl5.20: readdir() now only sets $! on error.  $! is no longer
    # set to EBADF when then terminating undef is read from the directory
    # unless the system call sets $!. [perl #118651]
    closedir(DIR) or die "Error closing directory $dir: $!";
    my $cntf = scalar(@rmfiles);
    for my $f (@rmfiles) {
      my $fname = $dir . '/' . untaint($f);
      if (unlink($fname)) {
        # ok
      } elsif ($! == EACCES && !$dir_chmoded) {
        # 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 do_log(-1, "Can't change protection-3 on dir %s: %s", $dir, $!);
        $dir_chmoded = 1;
        unlink($fname) or die "Can't remove $what $fname: $!";
      }
    }
    undef @rmfiles;
    section_time("unlink-$cntf-files")  if $cntf > 0;
    for my $d (@rmdirs) {
      rmdir_recursively($dir . '/' . untaint($d));
    }
    undef @rmdirs;
  }
  if (!$exclude_itself) {
    rmdir($dir) or die "rmdir_recursively: Can't remove directory $dir: $!";
    section_time('rmdir');
  }
  1;
}

# efficiently read a file (in binmode) into a provided string;
# either an open file handle may be given, or a filename
#
sub read_file($$) {
  my($fname,$strref) = @_;
  my($fh, $file_size, $nbytes);
  if (ref $fname) {
    $fh = $fname;  # assume a file handle was given
  } else {  # a filename
    $fh = IO::File->new;
    $fh->open($fname,O_RDONLY)  # does a sysopen
      or die "Can't open file $fname for reading: $!";
    $fh->binmode or die "Can't set file $fname to binmode: $!";
  }
  my(@stat_list) = stat($fh);
  @stat_list or die "Failed to access file: $!";
  $file_size = -s _  if -f _;
  if ($file_size) {
    # preallocate exact storage size, avoids realloc/copying while growing
    $$strref = ''; vec($$strref, $file_size + 32768, 8) = 0;
  }
  $$strref = '';
#*** handle EINTR
  while ( $nbytes=sysread($fh, $$strref, 32768, length $$strref) ) { }
  defined $nbytes or die "Error reading from $fname: $!";
  if (!ref $fname) { $fh->close or die "Error closing $fname: $!" }
  $strref;
}

# read a text file, returning its contents as a string - suitable for
# calling from amavisd.conf
#
sub read_text($;$) {
  my($fname, $encoding) = @_;
  my $fh = IO::File->new;
  $fh->open($fname,'<') or die "Can't open file $fname for reading: $!";
  if (defined($encoding) && $encoding ne '') {
    binmode($fh, ":encoding($encoding)")
      or die "Can't set :encoding($encoding) on file $fname: $!";
  }
  my $nbytes; my $str = '';
  while (($nbytes = $fh->read($str, 16384, length($str))) > 0) { }
  defined $nbytes or die "Error reading from $fname: $!";
  $fh->close or die "Error closing $fname: $!";
  my $result = $str; undef $str;  # shrink allocated storage to actual size
  $result;
}

# 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 = $_[0];
  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);
}

# # attempt to read a list of config files to use instead of the default one,
# # using an external helper script. Used by the Debian/Ubuntu distribution.
# sub find_config_files(@) {
#   my(@dirs) = @_;
#   local $ENV{PATH} = '/bin:/usr/bin';
#   my(@config_files) = map { `run-parts --list "$_"` } @dirs;
#   chomp(@config_files);
#   # untaint - this data is secure as we check the files themselves later
#   map { untaint($_) } @config_files;
# }

# attempt to read a list of config files to use instead of the default
# one, through an external help script. Used by the Debian distribution.
sub find_config_files(@) {
  my(@dirs) = @_;
  my(@config_files);

# my($old_path) = $ENV{PATH};
# $ENV{PATH} = "/bin:/usr/bin";
  foreach my $dir (@dirs) {
    push(@config_files, `run-parts --list "$dir"`);
  }
# $ENV{PATH} = $old_path;

  # untaint and chomp.  This data is secure as we check the files
  # themselves later
  chomp(@config_files);
  map { untaint($_) } @config_files;
}

#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 an associative array (=Perl hash) (as used in lookups) 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 RFC 5321
# 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 RFC 5321 -quoted form
# into internal (raw) form and inserted as keys into a given hash.
# International domain names (IDN) in UTF-8 are encoded to ASCII.
# NOTE: the format is partly compatible with Postfix maps (not aliases):
#   no continuation lines are honoured, Postfix maps do not allow
#   RFC 5321 -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]+ | . )/xgs) {
      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 . idn_to_ascii($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]+ | . )/xgs) {
      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;
}

# The read_cidr() reads a Postfix style CIDR file, (see cidr_table(5) man
# page), with postfix-style interpretation of comments and line continuations,
# returning a ref to an array or a ref to a hash (associative array ref).
#
# Empty or whitespace-only lines are ignored, as are lines whose first
# non-whitespace character is a '#'. A logical line starts with non-whitespace
# text. A line that starts with whitespace continues a logical line.
# The general form is:  network_address/network_mask  result
# where 'network_address' is an IPv4 address in a dot-quad form, or an IPv6
# address optionally enclosed in square brackets. The 'network_mask' along
# with a preceding slash is optional, as is the 'result' argument.
#
# If a network mask is omitted, a host address (not a network address)
# is assumed (i.e. a mask defaults to /32 for an IPv4 address, and
# to /128 for an IPv6 address).
#
# The read_cidr() returns a ref to an array or a ref to an hash (associative
# array) of network specifications, directly suitable for use as a lookup
# table in @client_ipaddr_policy and @mynetworks_maps, or for copying the
# array into @inet_acl or @mynetworks.
#
# When returned as an array the 'result' arguments are ignored, just the
# presence of a network specification matters. A '!' may precede the network
# specification, which will be interpreted as by lookup_ip_acl() as a negation,
# i.e. a match on such entry will return a false.
#
# When returned as a hash, the network specification is lowercased and used
# as a key, and the 'result' is stored as a value of a hash entry. A missing
# 'result' is replaced by 1.
#
# See also the lookup_ip_acl() for details on allowed IP address syntax
# and on the interpretation of array and hash type IP lookup tables.
#
sub read_cidr($;$) {
  my($filename, $result) = @_;
  # the $result arg may be a ref to an existing array or hash, in which case
  # data will be added there - either as key/value pairs, or as array elements;
  $result = [] if !defined $result;  # missing $results arg yields an array
  my $have_arry = ref $result eq 'ARRAY';
  my $inp = IO::File->new;
  $inp->open($filename,'<') or die "Can't open file $filename for reading: $!";
  my($ln, $curr_line);
  for ($! = 0; defined($ln=$inp->getline); $! = 0) {
    next  if $ln =~ /^ [ \t]* (?: \# | $ )/xs;
    chomp($ln);
    if ($ln =~ /^[ \t]/) {  # a continuation line
      $curr_line = ''  if !defined $curr_line;  # first line a continuation??
      $curr_line .= $ln;
    } else {  # a new logical line starts
      if (defined $curr_line) {  # deal with the previous logical line
        my($key,$val) = split(' ',$curr_line,2);
        # $val is always defined, it is an empty string if missing
        if ($have_arry) { push(@$result,$key) }
        else { $result->{lc $key} = $val eq '' ? 1 : $val }
      }
      $curr_line = $ln;
    }
  }
  if (defined $curr_line) {  # deal with the last logical line
    my($key,$val) = split(' ',$curr_line,2);
    if ($have_arry) { push(@$result,$key) }
    else { $result->{lc $key} = $val eq '' ? 1 : $val }
  }
  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: $!";
  $result;
}

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

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

# use Devel::Symdump;
# sub dump_subs() {
#   my $obj = Devel::Symdump->rnew;
#   # list of all subroutine names and their memory addresses
#   my @a = map([$_, \&$_], $obj->functions, $obj->scalars,
#                           $obj->arrays, $obj->hashes);
#   open(SUBLIST, ">/tmp/1.log") or die "Can't create a file: $!";
#   for my $s (sort { $a->[1] <=> $b->[1] } @a) {  # sorted by memory address
#     printf SUBLIST ("%s %s\n", $s->[1], $s->[0]);
#   }
#   close(SUBLIST) or die "Can't close a file: $!";
# }

# (deprecated, only still used with Amavis::OS_Fingerprint)
sub dynamic_destination($$) {
  my($method,$conn) = @_;
  if ($method =~ /^(?:[a-z][a-z0-9.+-]*)?:/si) {
    my(@list); $list[0] = ''; my $j = 0;
    for ($method =~ /\G \[ (?: \\. | [^\]\\] )* \] | " (?: \\. | [^"\\] )* "
                        | : | [ \t]+ | [^:"\[ \t]+ | . /xgs) {  # 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;
      if ($relayhost eq '*') {
        my $client_ip;  $client_ip = $conn->client_ip if $conn;
        $relayhost = "[$client_ip]"  if defined $client_ip && $client_ip ne '';
      }
      if ($relayport eq '*') {
        my $socket_port;  $socket_port = $conn->socket_port if $conn;
        $relayport = $socket_port + 1
          if defined $socket_port && $socket_port ne '';
      }
      if ($relayhost eq '*' || $relayport eq '*') {
        do_log(0,'dynamic destination expected, no client addr/port info: %s',
                  $method);
      }
      $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;
}

# collect unfinished recipients matching a $filter sub and a delivery
# method regexp;  assumes all list elements of a delivery_method list
# use the same protocol name, hence only the first one is inspected
#
sub collect_equal_delivery_recips($$$) {
  my($msginfo, $filter, $deliv_meth_regexp) = @_;
  my(@per_recip_data_subset, $proto_sockname);

  my(@per_recip_data) =
    grep(!$_->recip_done && (!$filter || &$filter($_)) &&
         grep(/$deliv_meth_regexp/,
              (ref $_->delivery_method ? $_->delivery_method->[0]
                                       : $_->delivery_method)),
         @{$msginfo->per_recip_data});
  if (@per_recip_data) {
    # take the first remaining recipient as a model
    $proto_sockname = $per_recip_data[0]->delivery_method;
    defined $proto_sockname  or die "undefined recipient's delivery_method";
    my $proto_sockname_key = !ref $proto_sockname ? $proto_sockname
                                                : join("\n", @$proto_sockname);
    # collect recipients with the same delivery method as the first one
    $per_recip_data_subset[0] = shift(@per_recip_data);  # always equals self
    push(@per_recip_data_subset,
         grep((ref $_->delivery_method ? join("\n", @{$_->delivery_method})
                                       : $_->delivery_method)
               eq $proto_sockname_key,  @per_recip_data) );
  }
  # return a ref to a filtered list of still-to-be-delivered recipient objects
  # and a single string or a ref to a list of delivery methods common to
  # these recipients
  (\@per_recip_data_subset, $proto_sockname);
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @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 c cr ca);
  import Amavis::Util qw(ll do_log do_log_safe prolong_timer untaint
                         flush_captured_log reposition_captured_log_to_end);
  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 message (dual-valued errno or a string or a number),
# returning the resulting string
#
sub exit_status_str($;$) {
  my($stat,$errno) = @_; my $str;
  if (!defined($stat)) {
    $str = '(no status)';
  } elsif (WIFEXITED($stat)) {
    $str = sprintf('exit %d', WEXITSTATUS($stat));
  } elsif (WIFSTOPPED($stat)) {
    $str = sprintf('stopped, signal %d', WSTOPSIG($stat));
  } else {  # WIFSIGNALED($stat)
    my $sig = WTERMSIG($stat);
    $str = sprintf('%s, signal %d (%04x)',
             $sig == 1 ? 'HANGUP' : $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 spawned 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 order 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,'terminating 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 (SIGKILL)',
              $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($;$$) {  # supposedly 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_safe(5, "open_on_specific_fd: target fd%s closing, to become %s %s",
                $fd_target, $flags_displayed, $fname)
                if $logging_safe && ll(5);
    # 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 ($flags,$mode): $!";
    $fd_got = 0 + $fd_got;  # turn into numeric, avoid: "0 but true"
  }
  if ($fd_got != $fd_target) {  # dup, ensuring we get a requested descriptor
    # we may have been left without a log file descriptor, must not die
    do_log_safe(5, "open_on_specific_fd: target fd%s dup2 from fd%s %s %s",
                $fd_target, $fd_got, $flags_displayed, $fname)
                if $logging_safe && ll(5);
    # 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" : '';
      # we may have been left without a log file descriptor, don't die
      do_log_safe(5, "open_on_specific_fd: source fd%s closed%s",
                  $fd_got,$err)  if $logging_safe && ll(5);
    }
  }
  $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;
  $Amavis::zmq_obj->inactivate
    if $Amavis::zmq_obj;
# undef $Amavis::sql_dataset_conn_lookups;
# undef $Amavis::sql_dataset_conn_storage;
# 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 !defined $stdin_from || $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: $!";
  flush_captured_log();
  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;
    my $err;
    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;
#     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);
#       }
#     }
      eval { release_parent_resources() };
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
      my $opt_rdonly = untaint(&POSIX::O_RDONLY);
      my $opt_wronly = untaint(&POSIX::O_WRONLY | &POSIX::O_CREAT);
      open_on_specific_fd(0, $stdin_from, $opt_rdonly, 0);
      open_on_specific_fd(1, '&='.fileno($child_out_fh), $opt_wronly, 0);
      open_on_specific_fd(2, $stderr_to, $opt_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: $!";
      0;  # paranoia
    } or do {
      $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_safe(-1,"run_command: child process [%s]: %s", $$,$err);
    } or 1;  # ignore failures, make perlcritic happy
    { # no warnings;
      POSIX::_exit(3);  # SIGQUIT, avoid END and destructor processing
    # POSIX::_exit(6);  # SIGABRT, 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 OFF !
# If $stderr_to is undef or is 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 !defined $stdout_to || $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: $!";
  flush_captured_log();
  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;
    my $err;
    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;
      eval { release_parent_resources() };
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
      my $opt_rdonly = untaint(&POSIX::O_RDONLY);
      my $opt_wronly = untaint(&POSIX::O_WRONLY | &POSIX::O_CREAT);
      open_on_specific_fd(0, '&='.fileno($child_in_fh), $opt_rdonly, 0);
      open_on_specific_fd(1, $stdout_to, $opt_wronly, 0);
      open_on_specific_fd(2, $stderr_to, $opt_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: $!";
      0;  # paranoia
    } or do {
      $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_safe(-1,"run_command_consumer: child process [%s]: %s", $$,$err);
    } or 1;  # ignore failures, make perlcritic happy
    { # no warnings;
      POSIX::_exit(3);  # SIGQUIT, avoid END and destructor processing
    # POSIX::_exit(6);  # SIGABRT, 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(0);  # turn it off here, must call ->flush when needed
  ($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) = @_;
  alarm(0);  # 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: $!";
  flush_captured_log();
  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
    my $myownpid = $$;  # fetching $$ is a syscall
    $0 = 'sub-' . c('myprogram_name');  # 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;
      eval { release_parent_resources() };
      $proc_fh->close or die "Child can't close parent side of a pipe: $!";
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      prolong_timer("child[$myownpid]");  # restart the timer
      binmode($child_out_fh) or die "Can't set pipe to binmode: $!";
      # 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: $!";
      #*** should re-establish ZMQ sockets here without clobbering parent
      ll(5) && do_log(5,'[%s] run_as_subprocess: running as child, '.
                        'stdin=%s, stdout=%s, pipe=%s',  $myownpid,
                        fileno(STDIN), fileno(STDOUT), fileno($child_out_fh));
      @result = &$code(@args);  # invoke a 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',
                             $myownpid, $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: $!";
      flush_captured_log();
      close STDOUT or die "Child can't close its STDOUT: $!";
      POSIX::_exit(0); # normal completion, avoid END and destructor processing
    } or 1;  # ignore failures, make perlcritic happy
    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_safe($ll, 'run_as_subprocess: child process [%s]: %s',
                       $myownpid, $eval2_stat);
    } or 1;  # ignore failures, make perlcritic happy
    POSIX::_exit(3);  # SIGQUIT, avoid END and destructor processing
  # POSIX::_exit(6);  # SIGABRT, avoid END and destructor processing
  }
  # 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');  # 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 (defined($results_max_size) && $results_max_size > 0 &&
      length($result) > $results_max_size) {
    substr($result, $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
  $eval_stat = undef;
  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 a 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";
  };
  reposition_captured_log_to_end();
  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);
  $result_ref = Amavis::Util::thaw($$result_ref);
  @result = @$result_ref  if $result_ref;
  @result
    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.412';
  @ISA = qw(Exporter);
  @EXPORT = qw(
    &rfc2822_timestamp &rfc2822_utc_timestamp
    &iso8601_timestamp &iso8601_utc_timestamp
    &iso8601_week &iso8601_yearweek &iso8601_year_and_week &iso8601_weekday
    &make_received_header_field &parse_received
    &fish_out_ip_from_received &parse_message_id
    &split_address &split_localpart &replace_addr_fields
    &clear_query_keys_cache &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_ref unique_list
                         safe_encode_utf8_inplace
                         idn_to_ascii idn_to_utf8 mail_addr_idn_to_ascii);
}
use subs @EXPORT;

use POSIX qw(locale_h strftime);

BEGIN {
  # try to use the installed version
  eval { require 'sysexits.ph' } or 1;  # ignore failure, make perlcritic happy
  # 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 5322 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 = int($_[0]);
  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 5322
# (local time), to be used in header fields such as 'Date:' and 'Received:'
# See also RFC 3339.
#
sub rfc2822_timestamp($) {
  my $t = $_[0];
  my(@lt) = localtime(int($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 time, provide date-time timestamp as specified in RFC 5322
# in a UTC time zone. See also RFC 3339 and RFC 6692.
#
sub rfc2822_utc_timestamp($) {
  my $t = $_[0];
  strftime("%a, %e %b %Y %H:%M:%S +0000 (UTC)", gmtime(int($t)));
}

# Given a Unix numeric time (seconds since 1970-01-01T00:00Z),
# provide date-time timestamp (local time) as specified in ISO 8601 (EN 28601)
# RFC 3339 is a subset of ISO 8601 and requires field separators "-" and ":".
#
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(int($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, $with_fraction) = @_;
  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(int($t)));
  $s .= sprintf(".%03d", int(1000*($t-int($t))+0.5)) if $with_fraction;
  $s .= 'Z'  unless $suppress_zone;
  $s;
}

# Does the given year have 53 weeks?  Using a formula by Simon Cassidy.
#
sub iso8601_year_is_long($) {
  my $y = $_[0];
  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 }
}

# 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_year_and_week($) {
  my $unix_time = $_[0];
  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) { $y--; $wn = iso8601_year_is_long($y) ? 53 : 52 }
  elsif ($wn == 53 && !iso8601_year_is_long($y)) { $y++; $wn = 1 }
  ($y,$wn);
}

sub iso8601_week($) {  # 1..53
  my($y,$wn) = iso8601_year_and_week($_[0]);  $wn;
}

sub iso8601_yearweek($) {
  my($y,$wn) = iso8601_year_and_week($_[0]);  $y*100+$wn;
}

# Given a Unix numeric time (seconds since 1970-01-01T00:00Z), provide a
# weekday number (based on local time): a number from 1 through 7, beginning
# with Monday and ending with Sunday, as specified in ISO 8601 (EN 28601)
#
sub iso8601_weekday($) {  # 1..7, Mo=1
  my $unix_time = $_[0]; ((localtime($unix_time))[6] + 6) % 7 + 1;
}

sub make_received_header_field($$) {
  my($msginfo, $folded) = @_;
  my $conn = $msginfo->conn_obj;
  my $id = $msginfo->mail_id;
  my($smtp_proto, $recips) = ($conn->appl_proto, $msginfo->recips);
  my($client_ip, $socket_ip) = ($conn->client_ip, $conn->socket_ip);
  for ($client_ip, $socket_ip) {
    $_ = '' if !defined($_);
    # RFC 5321 (ex RFC 2821), section 4.1.3
    $_ = 'IPv6:'.$_  if /:[0-9a-f]*:/i && !/^IPv6:/is;
  }
  my $myhost = c('myhostname');      # my FQDN (DNS) name, UTF-8 octets
  my $myhelo = c('localhost_name');  # my EHLO/HELO/LHLO name, UTF-8 octets
  $myhelo = 'localhost'  if $myhelo eq '';
  if ($msginfo->smtputf8) {
    $myhost = idn_to_utf8($myhost);  $myhelo = idn_to_utf8($myhelo);
  } else {
    $myhost = idn_to_ascii($myhost); $myhelo = idn_to_ascii($myhelo);
  }
  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)",
    $myhelo,
    $socket_ip eq '' ? '' : sprintf(" (%s [%s])", $myhost, $socket_ip),
    $myproduct_name,
    $conn->socket_port eq '' ? 'unix socket' : "port ".$conn->socket_port);
  # RFC 3848, RFC 6531
  # http://www.iana.org/assignments/mail-parameters/mail-parameters.xhtml
  $s .= "\n with $smtp_proto"
    if $smtp_proto =~ /^ (?: SMTP | (?: ES|L|UTF8S|UTF8L) MTP S? A? ) \z/xsi;
  $s .= "\n id $id"  if defined $id && $id ne '';
  if (@$recips == 1) {  # do not disclose recipients if more than one
    my $recip = $recips->[0];
    $recip = mail_addr_idn_to_ascii($recip)  if !$msginfo->smtputf8;
    $s .= "\n for " . qquote_rfc2821_local($recip);
  }
  $s .= ";\n " . rfc2822_timestamp($msginfo->rx_time);
  $s =~ s/\n//g  if !$folded;
  $s;
}

# parse Received header field according to RFC 5321, somewhat loosened 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: RFC 5322 section 3.2.2)
    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, contains at least two colons
           /\[ (?: IPv6: )?  [0-9a-f]{0,4}
               (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,9}
               (?: % [A-Z0-9_-]+ )?
            \] /xi) {}
  # elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /x) {}
    elsif (/^(?: localhost |
                 (?: [\x{80}-\x{F4}a-zA-Z0-9_\/+-]{1,63} \. )+
                 [\x{80}-\x{F4}a-zA-Z0-9-]{2,} ) \b/xs) {}
    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]+// }
  delete $fld{""}  if exists $fld{""} && $fld{""} eq "";
# for my $f (sort {$fld{$a} cmp $fld{$b}} keys %fld)
#   { do_log(5, "RECVD: %-8s -> /%s/", $f,$fld{$f}) }
  \%fld;
}

sub fish_out_ip_from_received($;$) {
  my($received,$fields_ref) = @_;
  $fields_ref = parse_received($received)  if !defined $fields_ref;
  my $ip; local($1);
  for (@$fields_ref{qw(from-tcp from from-com)}) {
    next  if !defined($_);
    if (/ \[ (\d{1,3} (?: \. \d{1,3}){3}) (?: \. \d{4,5} )? \] /xs) {
      $ip = $1;
    } elsif (/:.*:/) {  # triage - IPv6 address contain at least two colons
      if (tr/././ == 3) {  # triage - alternative form contains three dots
        $ip = $1  if / \[ ( (?: IPv6: )?
                            [0-9a-f]{0,4}  (?: : [0-9a-f]{0,4} ){1,5}
                            : \d{1,3} (?: \. \d{1,3} ){3}
                            (?: % [A-Z0-9_-]+ )?
                          ) \] /xsi;
      } else {
        $ip = $1  if / \[ ( (?: IPv6: )?
                            [0-9a-f]{0,4}  (?: : [0-9a-f]{0,4} ){2,7}
                            (?: % [A-Z0-9_-]+ )?
                           ) \] /xsi;
      }
    } elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /xs) {
      $ip = $1;
    }
    last if defined $ip;
  }
  if (!defined $ip) {
    do_log(5, "ip_from_received: no IP address in: %s", $received);
    # must return undef even in a list context!
  } else {
    do_log(5, "ip_from_received: %s", $ip);
    $ip =~ s/^IPv6://i;  # discard 'IPv6:' prefix if any
  }
  $ip;
}

# 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 RFC 5322.
# Does not handle explicit route paths, use parse_quoted_rfc2821 for that.
#
sub split_address($) {
  my $mailbox = $_[0];  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 (index($delimiter,'-') >= 0 && $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 (defined $delim && $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 RFC 5322 (RFC 2822) syntax extracting
# all message IDs while ignoring comments, and return them as a list
# Note: currently does not handle nested comments.
# See also: RFC 2392 - Content-ID and Message-ID Uniform Resource Locators
#
sub parse_message_id($) {
  my $str = $_[0];
  $str =~ tr/\n//d; my(@message_id); my $garbage = 0;
  $str =~ s/[ \t]+/ /g;  # compress whitespace as a band aid for regexp trouble
  for my $t ( $str =~ /\G ( [ \t]+ | \( (?: \\. | [^()\\] ){0,999} \) |
                             <  (?:  "  (?: \\. | [^"\\>] ){0,999} "  |
                                     \[ (?: \\. | [^\]\\>]){0,999} \] |
                                     [^"<>\[\]\\]+ )*  >  |
                             [^<( \t]+ | . )/xgs ) {
    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, no ToASCII)
#   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
#   (@).
# Another example with EAI and international domain names (IDN):
#   Pingüino@Pájaro.Niño.exAMPLE.COM  (as-is, no lowercasing, no ToASCII)
#   pingüino@xn--pjaro-xqa.xn--nio-8ma.example.com
#   pingüino(@)                       (only if $include_bare_user)
#   (@)xn--pjaro-xqa.xn--nio-8ma.example.com
#   (@).xn--pjaro-xqa.xn--nio-8ma.example.com
#   (@).xn--pjaro-xqa.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 and IDN converted to ASCII in all but
# the first item in the resulting list; the localpart is lowercased
# iff $localpart_is_case_sensitive is true. The $addr may be a string
# of octets (assumed to be UTF-8 encoded), or a string of characters.
#
my %query_keys_cache;
sub clear_query_keys_cache() { %query_keys_cache = () }
sub make_query_keys($$$;$) {
  my($addr, $at_with_user, $include_bare_user, $append_string) = @_;
  safe_encode_utf8_inplace($addr);  # to octets (if not already)
  my $query_keys_slot = join("\x00",
                             $at_with_user?1:0, $include_bare_user?1:0,
                             $append_string, $addr);
  if (exists $query_keys_cache{$query_keys_slot}) {
    do_log(5,'query_keys: cached '.$addr);  # concat, knowing it's in octets
    return @{$query_keys_cache{$query_keys_slot}};  # ($keys_ref, $rhs)
  }
  my($localpart, $domain) = split_address($addr);
  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;
  $domain = idn_to_ascii($domain)  if $domain ne '';  # lowercase, ToASCII
  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 : '';
    }
    @dkeys = @dkeys[$#dkeys-19 .. $#dkeys]  if @dkeys > 20;  # sanity limit
    push(@keys, @dkeys);
  }
  if (defined $append_string && $append_string ne '') {
    $_ .= $append_string  for @keys;
  }
  my $keys_ref = unique_ref(\@keys);  # remove duplicates
  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  (lc if localpart_is_case_sensitive)
    $extension,             # $4 = +foo  (lc if localpart_is_case_sensitive)
    $domain,                # $5 = sub.example.com (lowercase, ToASCII)
  ];
  $query_keys_cache{$query_keys_slot} = [$keys_ref, $rhs];
  ($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 RFC 5321 (ex RFC 2821).
#
# 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 RFC 5321 and RFC 6531.
#
sub quote_rfc2821_local($) {
  my $mailbox = $_[0];
  # RFC 5321/RFC 5322: atext: any character except controls, SP, and specials
  # RFC 6531 section 3.3: The definition of <atext> is extended to permit
  # both the RFC 5321 definition and a UTF-8 string.  That string MUST NOT
  # contain any of the ASCII graphics or control characters.
  # RFC 6531: atext     =/ UTF8-non-ascii
  #           qtextSMTP =/ UTF8-non-ascii
  # RFC 6532: UTF8-non-ascii = UTF8-2 / UTF8-3 / UTF8-4
  # RFC 3629 section 4: Syntax of UTF-8 Byte Sequences
  # non-atext: [\x00-\x20"(),.:;<>@\[\]\\\x7F]
  my $atext = "a-zA-Z0-9!\#\$%&'*/=?^_`{|}~+-";
  # my $specials = '()<>\[\]\\\\@:;,."';
  # HTML5 - 4.10.5.1.5 E-mail state (type=email):
  #   email = 1*( atext / "." ) "@" label *( "." label )
  #   i.e. localpart is: [a-zA-Z0-9.!#$%&'*+/=?^_`{|}~-]+
  my($localpart,$domain) = split_address($mailbox);
  if ($localpart =~ /^[$atext]+(?:\.[$atext]+)*\z/so) {
    # plain RFC 5321 dot-atom, no need for quoting
  } elsif ($localpart =~ /[\x80-\xBF\xC2-\xF4]/s &&  # triage, RFC 3629
           $localpart =~ /^ ( [$atext] |
                              [\xC2-\xDF][\x80-\xBF]{1} |
                              [\xE0-\xEF][\x80-\xBF]{2} |
                              [\xF0-\xF4][\x80-\xBF]{3}
                            )+
                            ( \. ( [$atext] |
                                   [\xC2-\xDF][\x80-\xBF]{1} |
                                   [\xE0-\xEF][\x80-\xBF]{2} |
                                   [\xF0-\xF4][\x80-\xBF]{3}
                                 )+
                            )* \z/xso) {
    # Extended RFC 6531 UTF-8 atext / dot-atom, no need for quoting.
    # The \xC0 and \xC1 could only be used for overlong encoding of basic
    # ASCII characters. Tolerate other non-shortest UTF-8 encodings here.
    # UTF-8 is restricted by RFC 3629 to end at U+10FFFF, this removed
    # all 5- and 6-byte sequences, and about half of the 4-byte sequences.
    # The RFC 5198 also prohibits "C1 Controls" (U+0080 through U+009F)
    # (i.e. in UTF-8: C2 80 .. C2 9F) for Net-Unicode.
  } else {  # needs quoting or is invalid
    local($1);  # qcontent = qtext / quoted-pair
    $localpart =~ s{ ( ["\\] ) }{\\$1}xgs;
    $localpart = '"'.$localpart.'"';  # non-qtext, 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 5321: 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]* \@ (?: [\x{80}-\x{F4}A-Za-z0-9.!\#\$%&*/^{}=_+-]* |
                              \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \t]*
                (?: ,[ \t]* \@ (?: [\x{80}-\x{F4}A-Za-z0-9.!\#\$%&*/^{}=_+-]* |
                              \[ (?: \\. | [^\]\\] ){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/xgs  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 RFC 5321 (ex RFC 2821).
# 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 = $_[0];
  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 an rfc2822.address-list, returning a list of RFC 5322 (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, (and since RFC 6854 also:) From and Sender.
#
# RFC 6854 relaxed the syntax on 'From' and 'Sender', where the group syntax
# is now allowed. Prior to RFC 6854 the 'From' accepted a 'mailbox-list'
# syntax (does not allow groups), and 'Sender' accepted 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, $in_qcontent, $in_literal,
     $in_group, $in_angle, $after_at) = (0) x 6;
  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: RFC 5322 section 3.2.2)
    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]+ )/xgs)
    { $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 preceding line if it would otherwise be too long. This is appropriate
# and required for wrapping of mail header 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] )/xgs;
  }
  # 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 an SMTP response at each \n char according to RFC 5321 (ex RFC 2821),
# returning resulting lines as a listref
#
sub wrap_smtp_resp($) {
  my $resp = $_[0];
  # RFC 5321 section 4.5.3.1.5: 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,$more,$enhanced,$tail) = ($1,$2,$3,$4);
  my $lead_len = length($resp_code) + 1 + length($enhanced);
  while (length($tail) > $max_len-$lead_len || $tail =~ /\n/) {
    # RFC 2034: 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) = @_;
  do_log(5, 'one_response_for_all, per_recip_capable: %s, suppressed: %s',
            $dsn_per_recip_capable?'Y':'N', $suppressed?'Y':'N');
  my($smtp_resp, $exit_code, $ndn_needed);
  my $am_id          = $msginfo->log_id;
  my $sender         = $msginfo->sender;
  my $per_recip_data = $msginfo->per_recip_data;
  my $any_not_done   = scalar(grep(!$_->recip_done, @$per_recip_data));
  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) {
      my $fwd_m = $r->delivery_method;
      if (!defined $fwd_m) {
        die "one_response_for_all: delivery_method not defined";
      } elsif ($fwd_m ne '' && $any_not_done) {
        die "Explicit forwarding, but not all recips done";
      }
    }
    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) { $smtp_resp = undef }
    if (defined $smtp_resp) {
      $exit_code = 99;  # helper program will interpret 99 as discard
      do_log(5, "one_response_for_all <%s>: all DISCARD, '%s'",
                $sender,$smtp_resp);
    }
  }
  if (!defined $smtp_resp) {
    # destiny for _all_ recipients is Discard or Reject, give 5xx
    # (and there is at least one Reject)
    my($notall, $done_level);
    my $bounce_cnt = 0;
    for my $r (@$per_recip_data) {
      my($dest, $resp) = ($r->recip_destiny, $r->recip_smtp_response);
      if ($dest == D_DISCARD) {
        # ok, this one is a 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 a Pass or Bounce, nogood
      }
    }
    if ($notall) { $smtp_resp = undef }
    if (defined $smtp_resp) {
      $exit_code = EX_UNAVAILABLE;
      do_log(5, "one_response_for_all <%s>: REJECTs, '%s'",$sender,$smtp_resp);
    }
  }
  if (!defined $smtp_resp) {
    # mixed destiny => 2xx, but generate dsn for bounces and rejects
    my($rej_cnt, $bounce_cnt, $drop_cnt) = (0,0,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.412';
  @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 own 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 a 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 $ when they are not introducing a variable name.
#
# 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 defined $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);
    }
    # braindamaged Perl: empty string implies the last successfully
    # matched regular expression; we must avoid this:
    $key = qr{(?:)}  if !defined $key || $key eq '';
    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 (defined($r) && !ref($r) && index($r,'$') >= 0) {  # triage
        my $any = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                         { my $j=$2+$3+$4; $j<1 ? '' : $rhs[$j-1] }xgse;
        # 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
    if (!$get_all) {  # first match wins
      do_log(5, 'lookup_re(%s) matches key "%s", result=%s',
                fmt_struct($addr), $matchingkey[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',
                                   $matchingkey[$_], 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 $have_patricia);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&lookup_ip_acl &ip_to_vec &normalize_ip_addr);
  import Amavis::Util qw(ll do_log);
}
use subs @EXPORT_OK;

BEGIN {
  eval {
    require Net::Patricia;
    Net::Patricia->VERSION(1.015);  # need AF_INET6 support
    import Net::Patricia;
    $have_patricia = 1;
  } or do {
    undef $have_patricia;
  };
}

# ip_to_vec() takes an IPv6 or IPv4 address with optional prefix length
# (or an 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 RFC 4291 (ex RFC 3513).
# 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 an IPv6 address
# as specified by RFC 5321 (ex RFC 2821). Brackets enclosing the address
# are optional, 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 an 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 quadruple is returned:
#  - an 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)
#  - zone_id, e.g. an interface scope for link-local addresses,
#      undef if not specified (implies a default zone_id 0, RFC 4007 sect. 11)
#
sub ip_to_vec($;$) {
  my($ip,$allow_mask) = @_;
  my($ip_len, @ip_fields, $scope);
  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}xs;
  $ipa = $1  if $ipa =~ m{^ \[ (.*) \] \z}xs;  # discard optional brackets
  my $have_ipv6;
  if    ($ipa =~ s/^IPv6://i)    { $have_ipv6 = 1 }
  elsif ($ipa =~ /:[0-9a-f]*:/i) { $have_ipv6 = 1 }

  # RFC 4007: IPv6 Scoped Address Architecture, sect 11: textual representation
  # RFC 6874  A <zone_id> SHOULD contain only ASCII characters
  #   classified as "unreserved" for use in URIs [RFC 3986]
  # RFC 3986: unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
  $scope = $1  if $ipa =~ s/ ( % [A-Z0-9._~-]* ) \z//xsi;  # scoped address

  if ($have_ipv6 &&
      $ipa =~ m{^(.*:) (\d{1,3}) \. (\d{1,3}) \. (\d{1,3}) \. (\d{1,3})\z}xsi){
    # IPv6 alternative form x:x:x:x:x:x:d.d.d.d
    my(@d) = ($2,$3,$4,$5);
    !grep($_ > 255, @d)
      or die "Invalid decimal field value in IPv6 address: [$ip]\n";
    $ipa = $1 . sprintf('%02x%02x:%02x%02x', @d);
  } elsif (!$have_ipv6 &&
           $ipa =~ m{^ \d{1,3} (?: \. \d{1,3}){0,3} \z}xs) {  # IPv4
    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/) {
      my(@d) = ($1,$2,$3,$4);
      !grep($_ > 255, @d)
        or die "Illegal field value in IPv4 mask: [$ip]\n";
      my $mask1 = pack('C4', @d);           # /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 a 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
  }
  # 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($before,$after) = ($1,$2);
    my(@bfr) = split(/:/,$before,-1); my(@aft) = split(/:/,$after,-1);
    my $missing_cnt = 8-(@bfr+@aft);  $missing_cnt = 1  if $missing_cnt<1;
    @ip_fields = (@bfr, ('0') x $missing_cnt, @aft);
  }
  @ip_fields >= 8  or die "IPv6 address [$ip] contains fewer than 8 fields\n";
  @ip_fields <= 8  or die "IPv6 address [$ip] contains more than 8 fields\n";
  !grep(!/^[0-9a-fA-F]{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",     # unpack('B*',$vec)
#           $ip, join(':',unpack('(H4)*',$vec)), $ip_len);
  ($vec, $mask, $ip_len, $scope);
}

use vars qw($ip_mapd_vec $ip_mapd_mask  $ip_xlat_vec $ip_xlat_mask
            $ip_6to4_vec $ip_6to4_mask  $ip_nat64_vec $ip_nat64_mask);
BEGIN {
  # RFC 4291: IPv4-mapped
  ($ip_mapd_vec, $ip_mapd_mask) = ip_to_vec('::ffff:0:0/96',1);  # IPv4-mapped
  # RFC 2765 (SIIT): IPv4-translated
  ($ip_xlat_vec, $ip_xlat_mask) = ip_to_vec('::ffff:0:0:0/96',1); # IPv4-xlat
  # RFC 3056 (6to4)
  ($ip_6to4_vec, $ip_6to4_mask) = ip_to_vec('2002::/16',1);      # 6to4
  # RFC 6052, RFC 6146 (NAT64)
  ($ip_nat64_vec, $ip_nat64_mask) = ip_to_vec('64:ff9b::/96',1); # NAT64
  # check, just in case
  $ip_mapd_vec  = $ip_mapd_vec  & $ip_mapd_mask;
  $ip_xlat_vec  = $ip_xlat_vec  & $ip_xlat_mask;
  $ip_6to4_vec  = $ip_6to4_vec  & $ip_6to4_mask;
  $ip_nat64_vec = $ip_nat64_vec & $ip_nat64_mask;
}

# strip an optional 'IPv6:' prefix, lowercase hex digits,
# convert an IPv4-mapped IPv6 address into a plain IPv4 dot-quad form;
# leave unchanged if syntactically incorrect
#
sub normalize_ip_addr($) {
  my $ip = $_[0];
  my($have_ipv6, $scope);
  if    ($ip =~ s/^IPv6://i)    { $have_ipv6 = 1 }
  elsif ($ip =~ /:[0-9a-f]*:/i) { $have_ipv6 = 1 }
  if ($have_ipv6) {
    local($1);
    $scope = $1  if $ip =~ s/ % ( [A-Z0-9._~-]* ) \z//xsi;  # scoped address
    if ($ip !~ /^[0:]+:ffff:/i) {  # triage for IPv4-mapped
      $ip = lc $ip;  # lowercase: RFC 5952
    } else {  # looks like an IPv4-mapped address
      my($ip_vec,$ip_mask);
      if (!eval { ($ip_vec,$ip_mask) = ip_to_vec($ip,0); 1 }) {
        do_log(3, "normalize_ip_addr: bad IP address: %s", $_[0]);
      } elsif (($ip_vec & $ip_mapd_mask) ne $ip_mapd_vec) {
        $ip = lc $ip;  # lowercase: RFC 5952
        # RFC 5952 - Recommendation for IPv6 Text Representation
        # TODO: apply suppression of leading zeroes, zero compression
      } else {  # IPv4-mapped address
        my $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4)));  # 32 bits
        do_log(5, "IPv4-mapped: %s -> %s", $ip, $ip_dq);
        $ip = $ip_dq;
      }
    }
  }
  $ip .= '%'.$scope  if $scope;  # defined, nonempty and nonzero
  $ip;
}

# 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.
# Interface zone_id (e.g. scope for link-local addresses) is ignored.
#
# 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 a false (undef).
#
# For lookup tables which are a ref to a an array (a traditional ACL),
# the presence of a character '!' prepended to a list member decides
# whether the result will be true (without a '!') or false (with a '!')
# 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 RFC 4291 forms are allowed
# and the /k specifies a prefix length. 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 RFC 1918 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 a 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 cannot match any hash entry.
#
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,$lookup_type); 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)"; $lookup_type = 'const';
      $found=1  if defined $result;
    } elsif (ref($t) eq 'HASH') {
      $lookup_type = 'hash';
      if (!defined $ip_vec) {  # syntactically invalid IP address
        $fullkey = undef; $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 a canonical form: x:x:x:x:x:x:x:x
        $ip_c = join(':', map(sprintf('%04x',$_), unpack('n8',$ip_vec)));
        if (($ip_vec & $ip_mapd_mask) ne $ip_mapd_vec) {
          do_log(5, 'lookup_ip_acl keys: "%s"', $ip_c);
        } else {  # is an IPv4-mapped addr
          my $ip_dq;  # IPv4 in dotted-quad form
          $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4)));  # 32 bits
          # try dot-quad, stripping off trailing bytes repeatedly
          do_log(5, 'lookup_ip_acl keys: "%s", "%s"', $ip_dq, $ip_c);
          for (my(@f)=split(/\./,$ip_dq); @f && !$found; $#f--) {
            $fullkey = join('.',@f); $result = $t->{$fullkey};
            $found=1  if defined $result;
          }
        }
      # test for 6to4 too? not now
      # if ($ip_vec & $ip_6to4_mask) eq $ip_6to4_vec) {
      #   # yields an IPv4 address of a client's 6to4 router
      #   $ip_dq = join('.', unpack('C4',substr($ip_vec,2,4)));
      # }
        if (!$found) {  # try the 'preferred IPv6 form', lowercase hex letters
          $fullkey = lc $ip_c; $result = $t->{$fullkey};
          $found=1  if defined $result;
        }
      }
    } elsif (ref($t) eq 'ARRAY') {
      $lookup_type = '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('Net::Patricia::AF_INET6')) {  # Patricia Trie
      $lookup_type = 'patricia';
      local($1,$2,$3,$4); local($_) = $ip;
      $_ = $1  if /^ \[ ( [^\]]* ) \] \z/xs;  # discard optional brackets
      s/%[A-Z0-9:._-]+\z//si;           # discard interface specification
      if (m{^ (\d+) \. (\d+) \. (\d+) \. (\d+) \z}x) {
        $_ = sprintf('::ffff:%d.%d.%d.%d', $1,$2,$3,$4);
      } else {
        s/^IPv6://i;  # discard optional 'IPv6:' prefix
      }
      eval { $result = $t->match_string($_); 1 }  or $result=undef;
      if (defined $result) {
        $fullkey = $result;
        if ($fullkey =~ s/^!//) { $result = 0 }
        else { $result = 1; $found = 1 }
      }
    } elsif ($t->isa('Amavis::Lookup::IP')) {  # pre-parsed IP lookup array obj
      $lookup_type = 'arr.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::DNSxL')) {  # DNSxL lookup obj, RFC 5782
      $lookup_type = 'dns';
      ($result, $fullkey) = $t->lookup_ip($ip);
      $found = $result;
    } 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 %s: key="%s"%s',
                     $label, $lookup_type, $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.
# Interface zone_id (e.g. scope for link-local addresses) is ignored.
#
sub new($@) {
  my($class,@nets) = @_;
  my $build_patricia_trie = $have_patricia && (@nets > 20);
  if (!$build_patricia_trie) {
    # build a traditional pre-parsed search list for a small number of entries
    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]);
    }
    return bless(\@list, $class);
  } else {
    # build a patricia trie, it offers more efficient searching in large sets
    my $pt = Net::Patricia->new(&AF_INET6);
    do_log(5, "building a patricia trie out of %d nets", scalar(@nets));
    for my $net (@nets) {
      local $_ = $net;
      local($1,$2,$3,$4); my $masklen;
      if (s{ / ([0-9.]+) \z }{}x) {
        $masklen = $1;
        $masklen =~ /^\d{1,3}\z/
          or die "Network mask not supported, use a CIDR syntax: $net";
      }
      s/^!//;  # strip a negation from a key, it will be retained in data
      $_ = $1  if /^ \[ ( [^\]]* ) \] \z/xs;  # discard optional brackets
      s/%[A-Z0-9:._-]+\z//si;                 # discard interface specification
      if (/^ \d+ (?: \. | \z) /x) {  # triage for an IPv4 network address
        if (/^ (\d+) \. (\d+) \. (\d+) \. (\d+) \z/x) {
          $_ = sprintf('::ffff:%d.%d.%d.%d', $1,$2,$3,$4);
          $masklen = 32  if !defined $masklen;
        } elsif (/^ (\d+) \. (\d+) \. (\d+) \.? \z/x) {
          $_ = sprintf('::ffff:%d.%d.%d.0', $1,$2,$3);
          $masklen = 24  if !defined $masklen;
        } elsif (/^ (\d+) \. (\d+) \.? \z/x) {
          $_ = sprintf('::ffff:%d.%d.0.0', $1,$2);
          $masklen = 16  if !defined $masklen;
        } elsif (/^ (\d+) \.? \z/x) {
          $_ = sprintf('::ffff:%d.0.0.0', $1);
          $masklen = 8  if !defined $masklen;
        }
        $masklen += 96  if defined $masklen;
      } else {  # looks like an IPv6 network
        s/^IPv6://i;  # discard optional 'IPv6:' prefix
      }
      $masklen = 128  if !defined $masklen;
      $_ .= '/' . $masklen;
      eval { $pt->add_string($_, $net); 1 }
        or die "Adding a network $net to a patricia trie failed: $@";
    }
  # ll(5) && $pt->climb(sub { do_log(5,"patricia trie, node $_[0]") });
    return $pt;  # a Net::Patricia::AF_INET6 object
  }
}

1;

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

# Make an object out of the supplied argument, pretocting it
# from being interpreted as an acl- or a hash- type lookup.
#
sub new($$) { my($class,$obj) = @_; bless \$obj, $class }
sub get($) { ${$_[0]} }

1;

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

# Make an object out of the supplied argument, pretocting it
# from being interpreted as an acl- or a hash- type lookup.
# The argument to new() is expected to be a ref to a variable,
# which will be dereferenced by a method get().
#
sub new($$) { my($class,$obj) = @_; bless \$obj, $class }
sub get($) { ${${$_[0]}} }

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,$str) = @_; bless \$str, $class }
sub display($) { ${$_[0]} }

1;

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

sub new($$$;$$) {
  my($class, $sql_query, $fieldname, $fieldtype, $implied_args) = @_;
  my $self =
    bless { fieldname => $fieldname, fieldtype => $fieldtype }, $class;
  $self->{sql_query} = $sql_query  if defined $sql_query;
  $self->{args} = ref($implied_args) eq 'ARRAY' ? [@$implied_args]  # copy
                  : [$implied_args]  if defined $implied_args;
  $self;
}

1;

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

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

1;

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

BEGIN {
  import Amavis::Conf qw(:platform);
  import Amavis::Util qw(ll do_log);
  use vars qw($dns_resolver);  # implicit persistent Net::DNS::Resolver object
}

sub new {
  my($class, $zone, $expected, $resolver) = @_;
  # $zone is either a DNSxL zone name, or a template where an %a is a
  # place-holder for the IP address to be queried.
  # The result of a type-A DNS query is matched against $expected, which is
  # either a scalar string, or a ref to an array of strings, or a regexp obj.
  require NetAddr::IP or die "Can't load module NetAddr::IP";
  NetAddr::IP->VERSION(4.010);  # need a method full6()
  if ($resolver) {
    # DNS resolver object provided by a caller, use that
  } elsif ($dns_resolver) {
    # reuse previously created internal resolver object
    $resolver = $dns_resolver;
  } else {  # create a new internal resolver object with some sensible defaults
    require Net::DNS or die "Can't load module Net::DNS";
    $dns_resolver = Net::DNS::Resolver->new(
      config_file => '/etc/resolv.conf', force_v4 => !$have_inet6,
      defnames => 0, retry => 1, persistent_udp => 1,
      tcp_timeout => 2, udp_timeout => 2, retrans => 1);  # seconds
    $dns_resolver or die "Failed to create a Net::DNS::Resolver object";
    $dns_resolver->udppacketsize(1220);
    $resolver = $dns_resolver;
  }
  defined $zone && $zone ne ''
    or die "DNS zone name must not be empty, in Amavis::Lookup::DNSxL";
  $expected = '127.0.0.2'  if !defined $expected;  # an RFC 5782 convention
  my $self = {
    zone => $zone,          # DNSxL zone name (a base DNS domain name)
    resolver => $resolver,  # a Net::DNS::Resolver object or equivalent
    expected => $expected,  # a set of replies that qualify as a match
  };
  bless $self, $class;
}

# Query a DNSxL list given an IPv4 or IPv6 address, according to RFC 5782.
# Returns an IPv4 address in the 127.0.0.0/8 subnet as returned by a DNS
# type-A query when the result matches the provided expected value, or a
# zero when a query succeeded (NOERROR or NXDOMAIN) but there was no match.
# The argument $expected may be a string, a ref to array, or a regexp object.
# Returns undef on DNS failures (like a timeout, or no Net::DNS module).
#
sub lookup_ip {
  my($self, $ipaddr) = @_;
  my $result;   # result of a DNS query, undef indicates a lookup failure
  my $fullkey;  # matching (expected) key
  return ($result,$fullkey)  if !$self->{resolver};
  my $revip;
  local($1,$2,$3,$4);
  if ($ipaddr =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/) {
    $revip = "$4.$3.$2.$1";
  } elsif ($ipaddr =~ /:[0-9a-f]*:/i) {  # triage
    # looks like an IPv6 address, let NetAddr::IP check the details
    my $ip_obj = NetAddr::IP->new6($ipaddr);
    if (defined $ip_obj) {  # a valid IPv6 address, apply RFC 5782 section 2.4
      $revip = lc $ip_obj->network->full6;  # string in a canonical form
      $revip =~ s/://gs;  $revip = join('.', reverse split(//,$revip));
    }
  }
  if (!defined $revip) {
    do_log(4,'invalid IP address for a DNSxL query: %s', $ipaddr);
    return ($result,$fullkey);
  }
  my $query = $self->{zone};
  $query =~ s/%a/$revip/gs  or  ($query = $revip . '.' .$query);
  my $pkt = $self->{resolver}->send($query, 'A');

  my $ll5 = ll(5);
  $result = 0;  # defined but false
  if (!$pkt || !$pkt->header) {
    undef $result;
    $ll5 && do_log(5,'DNSxL query %s, no result', $query);
  } elsif ($pkt->header->rcode eq 'NXDOMAIN') {
    $ll5 && do_log(5,'DNSxL query %s, domain does not exist', $query);
  } elsif ($pkt->header->rcode ne 'NOERROR') {
    $ll5 && do_log(5,'DNSxL query %s, rcode %s', $query, $pkt->header->rcode);
  } elsif ($pkt->header->ancount) {
    my $expected = $self->{expected};
    $expected = [ $expected ]  if !ref $expected;
    for my $rr ($pkt->answer) {
      next if $rr->type ne 'A';
      my $returned_addr = $rr->address;
      $ll5 && do_log(5,'DNSxL query %s, DNS answer: %s',$query,$returned_addr);
      # RFC 5782 section 2.3: values SHOULD be in the 127.0.0.0/8 range
      next if $returned_addr !~ /^127\.\d{1,3}\.\d{1,3}\.\d{1,3}\z/s;
      if (ref $expected eq 'ARRAY') {
        # $expected is an array of strings: IPv4 addresses in dotted-quad
        # form, with bytes possibly omitted from the left
        for (@$expected) {
          if ( ( /^\d+\z/           ? "127.0.0.$_"
               : /^\d+\.\d+\z/      ? "127.0.$_"
               : /^\d+\.\d+\.\d+\z/ ? "127.$_" : $_) eq $returned_addr) {
            $fullkey = $_; $result = $returned_addr;
            last;
          }
        }
        last if defined $result;
      } elsif (ref $expected eq 'Regexp') {
        # $expected is a regular expresion
        if ($returned_addr =~ /$expected/s) {
          $fullkey = "$expected";  # stringified regexp object
          $result = $returned_addr; last;
        }
      }
    }
  }
  do_log(5,'DNSxL result: %s, matches %s',$result,$fullkey) if $ll5 && $result;
  ($result, $fullkey);
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&lookup &lookup2 &lookup_hash &lookup_acl);
  import Amavis::Util qw(ll do_log fmt_struct unique_list idn_to_ascii
                         safe_encode_utf8_inplace);
  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.
#
# The $addr may be a string of octets (assumed to be UTF-8 encoded)
# or a string of characters which gets first encoded to UTF-8 octets.
# International domain name (IDN) in $addr will be converted to ACE and
# lowercased. Keys of a hash table are expected to be in octets (utf8 flag
# off) and their international domain names encoded in ASCII-compatible
# encoding (ACE).
#
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 defined $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) {  # $r is just an alias to array elements
    if (defined($r) && !ref($r) && index($r,'$') >= 0) { # plain string with $
      my $any = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                       { my $j = $2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }xgse;
      # 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 $addr may be a string of octets (assumed to be UTF-8 encoded)
# or a string of characters which gets first encoded to UTF-8 octets.
# International domain name (IDN) in $addr will be converted to ACE
# and lowercased. Array elements are expected to be in octets (utf8
# flag off) and their international domain names encoded in
# ASCII-compatible encoding (ACE).
#
# 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  if !@$acl_ref;  # empty list can't match anything
  safe_encode_utf8_inplace($addr);  # to octets (if not already)
  my $lpcs = c('localpart_is_case_sensitive');
  my($localpart,$domain) = split_address($addr);
  $localpart = lc $localpart  if !$lpcs;
  local($1,$2);
  # chop off leading '@' and trailing dots
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  $domain = idn_to_ascii($domain) if $domain ne '';  # lowercase, ToASCII
  $domain .= $options{AppendStr}  if defined $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;
  ll(5) && 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, deprecated
#
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
    my $reft = ref($t);
    if ($reft eq 'CODE') {  # lazy evaluation
      $t = &$t($addr,$get_all,%options);
      $reft = ref($t);
    }
    if (!$reft || $reft eq 'SCALAR') {  # a scalar always matches
      my $r = $reft ? $$t : $t;  # allow direct or indirect reference
      if (defined $r) {
        ll(5) && do_log(5, 'lookup: (scalar) matches, result="%s"', $r);
        push(@result,$r); push(@matchingkey,"(constant:$r)");
      }
    } elsif ($reft eq 'HASH') {
      my($r,$mk);
      ($r,$mk) = lookup_hash($addr,$t,$get_all,%options)  if %$t;
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($reft eq 'ARRAY') {
      my($r,$mk);
      ($r,$mk) = lookup_acl($addr,$t,%options)  if @$t;
      if (defined $r)   { push(@result,$r);  push(@matchingkey,$mk)  }
    } elsif ($t->isa('Amavis::Lookup::Label')) {  # logging label
      # just a convenience for logging purposes, not a real lookup method
      $label = $t->display;  # grab the name, and proceed with the next table
    } elsif ($t->isa('Amavis::Lookup::Opaque') ||     # a structured constant
             $t->isa('Amavis::Lookup::OpaqueRef')) {  # ref to structured const
      my $r = $t->get;  # behaves like a constant pseudo-lookup
      if (defined $r) {
        ll(5) && do_log(5, 'lookup: (opaque) matches, result="%s"', $r);
        push(@result,$r); push(@matchingkey,"(opaque:$r)");
      }
    } elsif ($t->isa('Amavis::Lookup::RE')) {
      my($r,$mk);
      ($r,$mk) = $t->lookup_re($addr,$get_all,%options)  if @$t;
      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')) {
      if ($Amavis::sql_lookups) {  # triage
        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')) {
      if ($Amavis::ldap_lookups && c('enable_ldap')) {  # triage
        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')) {
      if ($Amavis::ldap_lookups && c('enable_ldap')) {  # triage
        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: " . $reft;
    }
    last  if @result && !$get_all;
  }
  # pretty logging
  if (ll(4)) {  # only bother preparing log report which will be printed
    my $opt_label = $options{Label};
    my(@lbl) = grep(defined $_ && $_ ne '', ($opt_label,$label));
    $label = ' [' . join(',',unique_list(\@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.412';
  @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 they contain "\n" tokens
  1;
}

# 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 \_
    : $_ eq '%%' ? '%'                    # %% -> %
    : /^(%\#?.)\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/xs ? \"$1"  # SpamAssassin-compatible
    : $_ }
    $$str_ref =~ /\G \# | \[ [?~\@:="]? | "\] | \] | \| | % \#? . | \\ [^0-7] |
                  \\ [0-7]{1,3} | _ [A-Z]+ (?: \( [^)]* \) )? _ |
                  [^\[\]\\|%\n#"_]+ | [^\n]+? | \n /xgs;
  $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 eq '')               { $sel = 0 }  # quick
    elsif ($sel =~ /^\s*\z/)         { $sel = 0 }
    elsif ($sel =~ /^\s*(\d+)\s*\z/) { $sel = 0+$1 }  # decimal to 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
      if ($regexp eq '') {
        # braindamaged Perl: empty string implies the last successfully
        # matched regular expression; we must avoid this
        $match = 1;
      } else {
        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 (UNIVERSAL::isa($s,'Amavis::Expand')) {  # 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 (UNIVERSAL::isa($s,'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,$builtins_href) = @_;
  # $str_ref       ... a ref to a source string to be macro expanded;
  # $builtins_href ... 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 $whereto; local($1,$2);
  # preallocate some storage
  my $output_str = ''; vec($output_str,2048,8) = 0; $output_str = '';
  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 && substr($$t,0,1) eq '[') {
      # 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 (substr($$t,0,1) eq '[') {
      # $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/xs) {
      # 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 = ();  # clear memory
  \$output_str;
}

1;

#
package Amavis::TempDir;

# Handles creation and cleanup of a persistent temporary directory,
# a file 'email.txt' therein, and a subdirectory 'parts'

use strict;
use re 'taint';

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

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

sub new {
  my $class = $_[0];
  my $self = bless {}, $class;
  $self->{tempdir_path} = undef;
  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
  @_<2 ? shift->{tempdir_path} : ($_[0]->{tempdir_path} = $_[1])
}
sub fh {        # email.txt file handle
  @_<2 ? shift->{fh_pers} : ($_[0]->{fh_pers} = $_[1]);
}
sub empty {     # whether the directory is empty
  @_<2 ? shift->{empty} : ($_[0]->{empty} = $_[1])
}
sub preserve {  # whether to preserve directory when current task is done
  @_<2 ? shift->{preserve} : ($_[0]->{preserve} = $_[1]);
}

# Clean up the tempdir on shutdown
#
sub DESTROY {
  my $self = $_[0];
  local($@,$!,$_); my $myactualpid = $$;
  if (defined($my_pid) && $myactualpid != $my_pid) {
    do_log_safe(5,"TempDir::DESTROY skip, clone [%s] (born as [%s])",
                  $myactualpid, $my_pid);
  } else {
    do_log_safe(5,"TempDir::DESTROY called");
    eval {
      # must step out of the directory which is about to be deleted,
      # otherwise rmdir can fail (e.g. on Solaris)
      chdir($TEMPBASE)
        or do_log(-1,"TempDir::DESTROY can't chdir to %s: %s", $TEMPBASE, $!);
      if ($self->{fh_pers}) {
        $self->{fh_pers}->close
          or do_log(-1,"Error closing temp file: %s", $!);
      }
      undef $self->{fh_pers};
      my $dname = $self->{tempdir_path};
      my $errn = !defined($dname) || $dname eq '' ? ENOENT
                 : lstat($dname) ? 0 : 0+$!;
      if (defined($dname) && $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", $dname);
        } else {
          do_log(3, "TempDir removal: %s is being removed: %s%s",
                    $self->{empty} ? 'empty tempdir' : 'tempdir',  $dname,
                    $self->{preserve} ? ', nothing to preserve' : '');
          rmdir_recursively($dname);
        }
      };
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log_safe(1,"TempDir removal: %s",$eval_stat);
    };
  }
}

# Creates a temporary directory, or checks that inode did not change on reuse
#
sub prepare_dir {
  my $self = $_[0];
  my(@stat_list); my $errn; my $reuse = 0;
  my $dname = $self->{tempdir_path};
  if (defined $dname) {  # hope to reuse existing directory
    @stat_list = lstat($dname);  $errn = @stat_list ? 0 : 0+$!;
    if ($errn != ENOENT) {
      $reuse = 1;  # good, it exists, try reusing it
    } else {
      do_log(2,"TempDir::prepare_dir: directory %s no longer exists", $dname);
      $self->{tempdir_path} = $dname = undef; $self->{empty} = 1;
    }
  }
  if (!defined $dname) {
    # invent a name of a temporary directory for this child
    my $dirtemplate = sprintf("amavis-%s-%05d-XXXXXXXX",
                              iso8601_timestamp(time,1), $my_pid);
    $dname = File::Temp::tempdir($dirtemplate, DIR => $TEMPBASE);
    defined $dname && $dname ne ''
      or die "Can't create a temporary directory $TEMPBASE/$dirtemplate: $!";
    do_log(4,"TempDir::prepare_dir: created directory %s", $dname);
    chmod(0750,$dname)
      or die "Can't change protection on directory $dname: $!";
    @stat_list = lstat($dname);
    @stat_list or die "Failed to access directory $dname: $!";
    $self->{tempdir_path} = $dname;
    ($self->{tempdir_dev}, $self->{tempdir_ino}) = @stat_list;
    $self->{empty} = 1; add_entropy($dname, @stat_list);
    section_time('mkdir tempdir');
  }
  $errn = @stat_list ? 0 : 0+$!;
  if ($errn != 0) {
    die "TempDir::prepare_dir: Can't access temporary directory $dname: $!";
  } elsif (! -d _) {  # exists, but is not a directory !?
    die "TempDir::prepare_dir: $dname is not a directory!!!";
  } elsif ($reuse) {  # existing directory
    my($dev,$ino,$mode,$nlink) = @stat_list;
    if ($dev != $self->{tempdir_dev} || $ino != $self->{tempdir_ino}) {
      do_log(-1,"TempDir::prepare_dir: %s is no longer the same directory!",
                $dname);
      ($self->{tempdir_dev}, $self->{tempdir_ino}) = ($dev, $ino);
    }
    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_dir: directory %s has %d subdirectories",
                $dname, $nlink-2);
    }
  }
}

# Prepares the email.txt temporary file for writing (and reading later)
#
sub prepare_file {
  my $self = $_[0];
  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,"TempDir::prepare_file: %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,"TempDir::prepare_file: %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,"TempDir::prepare_file: 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}->flush or die "Can't flush mail 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,"TempDir::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: $!";
    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 = $_[0];
  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}; $self->{tempdir_path} = undef; $self->{empty} = 1;
  }
  # cleanup, but leave directory (and file handle if possible) for reuse
  if ($self->{fh_pers} && !$can_truncate) {
    # truncate is not standard across all Unix variants,
    # it is not Posix, but is XPG4-UNIX.
    # So if we can't truncate a file and leave it open,
    # we have to create it anew later, at some cost.
    #
    $self->{fh_pers}->close or die "Error closing mail file: $!";
    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 = $_[0];
  my $dname = $self->{tempdir_path};
  do_log(4, "TempDir::strip: %s", $dname);
  # must step out of the directory which is about to be deleted,
  # otherwise rmdir can fail (e.g. on Solaris)
  chdir($TEMPBASE) or die "TempDir::strip: can't chdir to $TEMPBASE: $!";
  my(@stat_list) = lstat($dname);
  my $errn = @stat_list ? 0 : 0+$!;
  if ($errn == ENOENT) {
    do_log(-1,"TempDir::strip: directory %s no longer exists", $dname);
    $self->{tempdir_path} = $dname = undef; $self->{empty} = 1;
  } elsif ($errn != 0) {
    die "TempDir::strip: error accessing directory $dname: $!";
  } else {
    my($dev,$ino) = @stat_list;
    if ($dev != $self->{tempdir_dev} || $ino != $self->{tempdir_ino}) {
      do_log(-1,"TempDir::strip: %s is no longer the same directory!",
                $dname);
      ($self->{tempdir_dev}, $self->{tempdir_ino}) = ($dev, $ino);
    }
    # now deal with the 'parts' subdirectory
    my $errn = lstat("$dname/parts") ? 0 : 0+$!;
    if ($errn == ENOENT) {}  # fine, no such directory
    elsif ($errn!=0) { die "TempDir::strip: error accessing $dname/parts: $!" }
    elsif ( -l _) { die "TempDir::strip: $dname/parts is a symbolic link" }
    elsif (!-d _) { die "TempDir::strip: $dname/parts is not a directory" }
    else { rmdir_recursively("$dname/parts", 1) }
    $self->check;  # check for any remains in the top directory just in case
  }
  1;
}

# Checks tempdir after being cleaned.
# It may only contain subdirectory 'parts' and file email.txt, nothing else.
#
sub check {
  my $self = $_[0];
  my $eval_stat; my $dname = $self->{tempdir_path};
  local(*DIR); opendir(DIR,$dname) or die "Can't open directory $dname: $!";
  eval {
    # avoid slurping the whole directory contents into memory
    $! = 0; my $f;
    while (defined($f = readdir(DIR))) {
      next  if $f eq '.' || $f eq '..';
      my $fname = $dname . '/' . $f;
      my(@stat_list) = lstat($fname);
      my $errn = @stat_list ? 0 : 0+$!;
      if ($errn) {
        die "Inaccessible $fname: $!";
      } elsif (-f _) {
        warn "Unexpected file $fname"  if $f ne 'email.txt';
      } elsif (-l _) {
        die "Unexpected link $fname";
      } elsif (-d _) {
        my $nlink = $stat_list[3];
        if ($f ne 'parts') {
          die "Unexpected directory $fname";
        } elsif ($nlink > 2) {  # number of hard links
          # 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::check: directory %s has %d subdirectories",
                    $dname, $nlink-2);
        }
      } else {
        die "Unexpected non-regular file $fname";
      }
    }
    # checking status on directory read ops doesn't work as expected, Perl bug
    # $! == 0 or die "Error reading directory $dname: $!";
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  closedir(DIR) or die "Error closing directory $dname: $!";
  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';
use Errno qw(EAGAIN);

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

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

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

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

sub BINMODE { 1 }
sub FILENO { my $self = $_[0]; $self->{'fileno'} }
sub CLOSE  { my $self = $_[0]; undef $self->{'fileno'}; 1 }
sub EOF    { my $self = $_[0]; 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 byte limit
  if (ref $prefix_lines_ref) {
    my $len = 0;
    $len += length($_) for @$prefix_lines_ref;
    $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;
  } elsif (defined $size_limit && $pos >= $size_limit) {
    $self->{'eof'} = 1;
    return;
  } 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 {  # take size limit into account
      my(@array);
      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) {  # truncate at NL past limit
          $#array = $j; last;
        }
      }
      my $nread = 0;
      if ($pos < $size_limit) {
        my($inbuf,$carry); my $beyond_limit = 0;
        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);
            substr($inbuf, $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]; $carry=undef }
          $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) {
        undef @array;
        # errno should still be in $!, caller should be checking it
        # die "error reading: $!";
      }
      return @array;
    }
  } else {  # read one line
    if ($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 }  # errno in $!
      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 ? 0 : $size_limit - $pos;
    $beyond_limit = 1;
  }
  if ($len > 0 && $pos < $self->{'prefix_l'}) {
    # not 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;
  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.412';
  @ISA = qw(Exporter);
}
use Errno qw(EIO);
use Compress::Zlib;

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

sub close {
  my $self = $_[0];
  my $status; my $eval_stat; local($1,$2);
  eval { $status = $self->{fh}->gzclose; 1 }
    or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  delete $self->{fh};
  if (defined $eval_stat) {
    chomp $eval_stat;
    die $eval_stat  if $eval_stat =~ /^timed out\b/;   # resignal timeout
    # can't stash arbitrary text into $!
    die "gzclose error: $eval_stat, $gzerrno";
    $! = EIO; return;  # not reached
  } elsif ($status != Z_OK) {
    die "gzclose error: $gzerrno";  # can't stash arbitrary text into $!
    $! = EIO; return;  # not reached
  }
  1;
}

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  # ignore failure, make perlcritic happy
  if ($self && $self->{fh}) { eval { $self->close } or 1 }
}

sub open {
  my($self,$fname,$mode) = @_;
  # ignore failure, make perlcritic happy
  if (exists($self->{fh})) { eval { $self->close } or 1; 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
  } else {
    $self->{pos} += $nbytes;
  }
  $nbytes;   # eof: 0;  error: undef
}

sub getline {
  my $self = $_[0];  my($nbytes,$line);
  $nbytes = $self->{fh}->gzreadline($line);
  if ($nbytes <= 0) {  # eof (0) or error (-1)
    $! = 0; $line = undef;
    if ($nbytes < 0 && $gzerrno != Z_STREAM_END) {
      die "gzreadline error: $gzerrno";  # can't stash arbitrary text into $!
      $! = EIO;  # not reached
    }
  } else {
    $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::IO::RW;
use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform);
  import Amavis::Util qw(ll do_log min max minmax idn_to_ascii);
}

use Errno qw(EIO EINTR EAGAIN EPIPE ENOTCONN ECONNRESET);
use Time::HiRes ();
use IO::Socket;
use IO::Socket::UNIX;
#use IO::Socket::SSL;

# Connect to one of the specified sockets. The $socket_specs may be a
# simple string ([inet-host]:port, [inet6-host]:port, or a unix socket name),
# optionally prefixed by a protocol name (scheme) and a colon (the prefix is
# ignored here, just avoids a need for parsing by a caller);  or it can be
# a ref to a list of such socket specifications, which are tried one after
# another until a connection is successful. In case of a listref, it leaves
# a good socket as the first entry in the list so that it will be tried first
# on a next call.
# The 'Timeout' argument controls both the connect timeout as well as the
# timeout of a select() call in rw_loop() - but may be changed through a
# timeout() method.
#
sub new {
  my($class, $socket_specs, %arg) = @_;
  my $self = bless {}, $class;
  $self->timeout($arg{Timeout});
  $self->{eol_str} = !defined $arg{Eol} ? "\n" : $arg{Eol};
  $self->{inp_sane_size} = !$arg{InpSaneSize} ? 500000 : $arg{InpSaneSize};
  $self->{last_event_time} = 0; $self->{last_event_tx_time} = 0;
  $self->{inp} = ''; $self->{out} = '';
  $self->{inpeof} = 0; $self->{ssl_active} = 0;
  $socket_specs = [ $socket_specs ]  if !ref $socket_specs;
  my($protocol,$socketname,$sock,$eval_stat);
  my $attempts = 0; my(@failures);
  my $n_candidates = scalar @$socket_specs;
  $n_candidates > 0  or die "Can't connect, no sockets specified!?";  # sanity
  for (;;) {
    if ($n_candidates > 1) {  # pick one at random, put it to head of the list
      my $j = int(rand($n_candidates));
      ll(5) && do_log(5, "picking candidate #%d (of %d) in %s",
                         $j+1, $n_candidates, join(', ',@$socket_specs));
      @$socket_specs[0,$j] = @$socket_specs[$j,0]  if $j != 0;
    }
    $socketname = $socket_specs->[0];  # try the first on the list
    local($1);
    $socketname =~ s/^([a-z][a-z0-9.+-]*)?://si;  # strip protocol name
    $protocol = lc($1);  # kept for the benefit of a caller
    $self->{socketname} = undef;
    $attempts++;
    eval {
      $sock = $self->connect_attempt($socketname, %arg);
      $sock  or die "Error connecting to socket $socketname\n";
      1;
    } or do {
      $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      undef $sock;
    };
    if ($sock) {  # mission accomplished
      if (!@failures) {
        do_log(5, "connected to %s successfully", $self->{socketname});
      } else {
        do_log(1, "connected to %s successfully after %d failures on: %s",
                 $self->{socketname}, scalar(@failures), join(', ',@failures));
      }
      last;
    } else {  # failure, prepare for a retry with a next entry if any
      $n_candidates--;
      my $ll = $attempts > 1 || $n_candidates <= 0 ? -1 : 1;
      ll($ll) && do_log($ll, "connect to %s failed, attempt #%d: %s%s",
                   $socketname, $attempts, $eval_stat,
                   $n_candidates <= 0 ? '' : ', trying next');
      push(@failures, $socketname);
      # circular shift left, move a bad candidate to the end of the list
      push(@$socket_specs, shift @$socket_specs)  if @$socket_specs > 1;
      last if $n_candidates <= 0;
    }
  }
  $sock  or die("All attempts ($attempts) failed connecting to ".
                join(', ',@$socket_specs) . "\n");
  $self->{socket} = $sock;
  $self->{protocol} = $protocol;
  $self;
}

sub connect_attempt {
  my($self, $socketname, %arg) = @_;
  my $sock;
  my($localaddr, $localport) = ($arg{LocalAddr}, $arg{LocalPort});
  my $blocking = 1;  # blocking mode defaults to on
  $blocking = 0  if defined $arg{Blocking} && !$arg{Blocking};
  my $timeout = $self->timeout;
  my $timeout_displ = !defined $timeout ? 'undef'
                      : int($timeout) == $timeout ? "$timeout"
                      : sprintf("%.3f",$timeout);
  my($peeraddress, $peerport, $is_inet); local($1,$2,$3);
  if ($socketname =~ m{^/}) {  # simpleminded: unix vs. inet
    $is_inet = 0;
  } elsif ($socketname =~ /^(?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*)/xs) {
    # ignore possible further fields after the "proto:addr:port:..." last colon
    $peeraddress = defined $1 ? $1 : $2;  $peerport = $3;  $is_inet = 1;
  } elsif ($socketname =~ /^(?: \[ ([^\]]*) \] | ([0-9a-fA-F.:]+) ) \z/xs) {
    $peeraddress = defined $1 ? $1 : $2;  $is_inet = 1;
  } else {  # probably a syntax error, but let's assume it is a Unix socket
    $is_inet = 0;
  }
  if ($is_inet) {
    if (defined $peeraddress && $peeraddress eq '*') {
      $peeraddress = $arg{WildcardImpliedHost};
      defined $peeraddress
        or die "Wildcarded host, but client's address not known: $socketname";
    }
    if (!defined $peeraddress || $peeraddress eq '') {
      die "Empty/unknown host address in socket specification: $socketname";
    }
    $peerport = $arg{Port}  if !defined $peerport || $peerport eq '';
    if (defined $peerport && $peerport eq '*') {
      $peerport = $arg{WildcardImpliedPort};
      defined $peerport
        or die "Wildcarded port, but client's port not known: $socketname";
    }
    if (!defined $peerport || $peerport eq '') {
      die "Empty/unknown port number in socket specification: $socketname";
    } elsif ($peerport !~ /^\d{1,5}\z/ || $peerport < 1 || $peerport > 65535) {
      die "Invalid port number in socket specification: $socketname";
    }
  }

  $self->{last_event_time} = $self->{last_event_tx_time} = Time::HiRes::time;

  if (!$is_inet) {
    # unix socket
    ll(3) && do_log(3, "new socket by IO::Socket::UNIX to %s, ".
                       "timeout set to %s", $socketname, $timeout_displ);
    $sock = IO::Socket::UNIX->new(
      # Domain => AF_UNIX,
      Type => SOCK_STREAM, Timeout => $timeout);
    $sock or die "Can't create UNIX socket: $!\n";
    $sock->connect( pack_sockaddr_un($socketname) )
      or die "Can't connect to a UNIX socket $socketname: $!\n";
    $self->{last_event} = 'new-unix';

  } else {  # inet or inet6
    defined $io_socket_module_name
      or die "No INET or INET6 socket module is available";
    my $local_sock_displ = '';
    $peeraddress = idn_to_ascii($peeraddress);
    my(%args) = (Type => SOCK_STREAM, Proto => 'tcp', Blocking => $blocking,
                 PeerAddr => $peeraddress, PeerPort => $peerport);
               # Timeout => $timeout,  # produces: Invalid argument
    if (defined $localaddr && $localaddr ne '') {
      $args{LocalAddr} = $localaddr;
      $local_sock_displ .= '[' . $localaddr . ']';
    }
    if (defined $localport && $localport ne '') {
      $args{LocalPort} = $localport;
      $local_sock_displ .= ':' . $localport;
    }
    ll(3) && do_log(3,"new socket using %s to [%s]:%s, timeout %s%s%s",
                      $io_socket_module_name, $peeraddress, $peerport,
                      $timeout_displ, $blocking ? '' : ', nonblocking',
                      $local_sock_displ eq '' ? ''
                                              : ', local '.$local_sock_displ);
    $sock = $io_socket_module_name->new(%args);
    if (!$sock) {
      # note: the IO::Socket::IP constructor provides an error message in $@
      die sprintf("Can't connect to socket %s using module %s: %s\n",
                  $socketname, $io_socket_module_name,
                  $io_socket_module_name eq 'IO::Socket::IP' ? $@ : $!);
    }
    $self->{last_event} = 'new-' . $io_socket_module_name;
  }
  if ($sock) {
    $self->{socketname} = $is_inet ? "[$peeraddress]:$peerport" : $socketname;
  }
  $sock;
}

sub internal_close {
  my($self, $destroying) = @_;
  my $sock = $self->{socket};
  my $status = 1;  # ok
  if (!defined($sock)) {
    # nothing to do
  } elsif (!defined fileno($sock)) {  # not really open
    $sock->close;  # ignoring errors
  } else {
    my $flush_status = 1;  # ok
    eval {  # don't let errors during flush prevent us from closing a socket
      $flush_status = $self->flush;
    } or do {
      undef $flush_status;  # false, indicates a signalled failure
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log($destroying ? 5 : 1,
             "closing: Error flushing socket in Amavis::IO::RW::%s: %s",
             $destroying?'DESTROY':'close', $eval_stat);
    };
    $self->{last_event} = 'close';
    $self->{last_event_time} = $self->{last_event_tx_time} = Time::HiRes::time;
    $! = 0; $status = $sock->close;
    $status or do_log($destroying ? 5 : 1,
                     "closing: Error closing socket in Amavis::IO::RW::%s: %s",
                      $destroying?'DESTROY':'close',
                      !$self->{ssl_active} ? $! : $sock->errstr.", $!" );
    $status = $flush_status  if $status && !$flush_status;
  }
  $status;
}

sub close {
  my $self = $_[0];
  $self->internal_close(0);
}

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  # ignore failure, make perlcritic happy
  eval { $self->internal_close(1) } or 1;
}

sub rw_loop {
  my($self,$needline,$flushoutput) = @_;
#
# RFC 2920: Client SMTP implementations MAY elect to operate in a nonblocking
# fashion, processing server responses immediately upon receipt, even if
# there is still data pending transmission from the client's previous TCP
# send operation. If nonblocking operation is not supported, however, client
# SMTP implementations MUST also check the TCP window size and make sure that
# each group of commands fits entirely within the window. The window size
# is usually, but not always, 4K octets.  Failure to perform this check can
# lead to deadlock conditions.
#
# We choose to operate in a nonblocking mode. Responses are read as soon as
# they become available and stored for later, but not immediately processed
# as they come in. This requires some sanity limiting against rogue servers.
#
  my $sock = $self->{socket};
  my $fd_sock = fileno($sock);
  my $timeout = $self->timeout;
  my $timeout_displ = !defined $timeout ? 'undef'
                      : int($timeout) == $timeout ? "$timeout"
                      : sprintf("%.3f",$timeout);
  my $eol_str = $self->{eol_str};
  my $idle_cnt = 0; my $failed_write_attempts = 0;
  local $SIG{PIPE} = 'IGNORE';  # don't signal on a write to a widowed pipe
  for (;;) {
    $idle_cnt++;
    my($rout,$wout,$eout,$rin,$win,$ein); $rin=$win=$ein='';
    my $want_to_write = $self->{out} ne '' && ($flushoutput || $needline);
    ll(5) && do_log(5, 'rw_loop: needline=%d, flush=%s, wr=%d, timeout=%s',
                      $needline, $flushoutput, $want_to_write, $timeout_displ);
    if (!defined($fd_sock)) {
      do_log(3, 'rw_loop read: got a closed socket');
      $self->{inpeof} = 1; last;
    }
    vec($rin,$fd_sock,1) = 1;
    vec($win,$fd_sock,1) = $want_to_write ? 1 : 0;
    $ein = $rin | $win;
    $self->{last_event} = 'select';
    $self->{last_event_time} = Time::HiRes::time;
    my($nfound,$timeleft) =
      select($rout=$rin, $wout=$win, $eout=$ein, $timeout);
    defined $nfound && $nfound >= 0
      or die "Select failed: ".
             (!$self->{ssl_active} ? $! : $sock->errstr.", $!");
    if (vec($rout,$fd_sock,1)) {
      ll(5) && do_log(5, 'rw_loop: receiving');
      my $inbuf = ''; $! = 0;
      my $nread = sysread($sock,$inbuf,16384);
      if ($nread) {  # successful read
        $self->{last_event} = 'read-ok';
        $self->{inpeof} = 0;
        ll(5) && do_log(5,'rw_loop read %d chars< %s', length($inbuf),$inbuf);
        $self->{inp} .= $inbuf; $idle_cnt = 0;
        length($self->{inp}) < $self->{inp_sane_size}
          or die "rw_loop: Aborting on a runaway server, inp_len=" .
                 length($self->{inp});
      } elsif (defined $nread) {  # defined but zero, sysread returns 0 at eof
        $self->{last_event} = 'read-eof';
        $self->{inpeof} = 1;  do_log(3, 'rw_loop read: got eof');
      } elsif ($! == EAGAIN || $! == EINTR) {
        $self->{last_event} = 'read-intr'.(0+$!);
        $idle_cnt = 0;
        do_log(2, 'rw_loop read interrupted: %s',
                  !$self->{ssl_active} ? $! : $sock->errstr.", $!");
        Time::HiRes::sleep(0.1);  # slow down, just in case
        # retry
      } else {
        $self->{last_event} = 'read-fail';
        $self->{inpeof} = 1;
        die "Error reading from socket: ".
             (!$self->{ssl_active} ? $! : $sock->errstr.", $!");
      }
      $self->{last_event_time} = Time::HiRes::time;
    }
    if (vec($wout,$fd_sock,1)) {
      my $out_l = length($self->{out});
      ll(5) && do_log(5,'rw_loop: sending %d chars', $out_l);
      my $nwrite = syswrite($sock, $self->{out});
      if (!defined($nwrite)) {
        if ($! == EAGAIN || $! == EINTR) {
          $self->{last_event} = 'write-intr'.(0+$!);
          $idle_cnt = 0; $failed_write_attempts++;
          do_log(2, 'rw_loop writing %d bytes interrupted: %s', $out_l,
                    !$self->{ssl_active} ? $! : $sock->errstr.", $!");
          Time::HiRes::sleep(0.1);   # slow down, just in case
        } else {
          $self->{last_event} = 'write-fail';
          die sprintf('Error writing %d bytes to socket: %s', $out_l,
                      !$self->{ssl_active} ? $! : $sock->errstr.", $!");
        }
      } else {  # successful write
        $self->{last_event} = 'write-ok';
        my $ll = $nwrite != $out_l ? 4 : 5;
        if (ll($ll)) {
          my $msg = $nwrite==$out_l ? sprintf("%d", $nwrite)
                                    : sprintf("%d (of %d)", $nwrite,$out_l);
          my $nlog = min(200,$nwrite);
          do_log($ll, 'rw_loop sent %s> %s%s',
                $msg, substr($self->{out},0,$nlog), $nlog<$nwrite?' [...]':'');
        };
        $idle_cnt = 0;
        if ($nwrite <= 0) { $failed_write_attempts++ }
        elsif ($nwrite < $out_l) { substr($self->{out},0,$nwrite) = '' }
        else { $self->{out} = '' }
      }
      $self->{last_event_time} = $self->{last_event_tx_time} =
        Time::HiRes::time;
    }
    if ( ( !$needline || !defined($eol_str) || $eol_str eq '' ||
           index($self->{inp},$eol_str) >= 0 ) &&
         ( !$flushoutput || $self->{out} eq '' ) ) {
      last;
    }
    if ($self->{inpeof}) {
      if ($self->{out} ne '') {
        do_log(2, 'rw_loop: EOF on input, output buffer not yet empty');
      }
      last;
    }
    if ($idle_cnt > 0) {  # probably exceeded timeout in select
      do_log(-1, 'rw_loop: leaving rw loop, no progress, '.
                 'last event (%s) %.3f s ago', $self->{last_event},
             Time::HiRes::time - $self->{last_event_time});
      last;
    }
    $failed_write_attempts < 100  or die "rw_loop: Aborting stalled sending";
  }
}

sub socketname
  { @_<2 ? shift->{socketname} : ($_[0]->{socketname} = $_[1]) }
sub protocol
  { @_<2 ? shift->{protocol}   : ($_[0]->{protocol} = $_[1]) }
sub timeout
  { @_<2 ? shift->{timeout}    : ($_[0]->{timeout} = $_[1]) }
sub ssl_active
  { @_<2 ? shift->{ssl_active} : ($_[0]->{ssl_active} = $_[1]) }
sub eof
  { @_<2 ? shift->{client_ip}  : ($_[0]->{client_ip} = $_[1]) }

sub last_io_event_timestamp
  { my($self,$keyword) = @_; $self->{last_event_time} }

sub last_io_event_tx_timestamp
  { my($self,$keyword) = @_; $self->{last_event_tx_time} }

sub flush
  { my $self = $_[0]; $self->rw_loop(0,1) if $self->{out} ne ''; 1 }

sub discard_pending_output
  { my $self = $_[0]; my $len = length $self->{out}; $self->{out} = ''; $len }

sub out_buff_large
  { my $self = $_[0]; length $self->{out} > 40000 }

sub print {
  my $self = shift;
  $self->{out} .= $_  for @_;
# $self->out_buff_large ? $self->flush : 1;
  length $self->{out} > 40000 ? $self->flush : 1;  # inlined out_buff_large()
}

sub at_line_boundary {
  my $self = $_[0];
  my $eol_str = $self->{eol_str};
  my $eol_str_l = !defined($eol_str) ? 0 : length($eol_str);
  !$eol_str_l ? 1
    : substr($self->{out}, -$eol_str_l, $eol_str_l) eq $eol_str ? 1 : 0;
}

# returns true if there is any full line (or last incomplete line)
# in the buffer waiting to be read, 0 otherwise, undef on eof or error
#
sub response_line_available {
  my $self = $_[0];
  my $eol_str = $self->{eol_str};
  if (!defined $eol_str || $eol_str eq '') {
    return length($self->{inp});
  } elsif (index($self->{inp},$eol_str) >= 0) {
    return 1;
  } elsif ($self->{inpeof} && $self->{inp} eq '') {
    return;  # undef on end-of-file
  } elsif ($self->{inpeof}) {  # partial last line
    return length($self->{inp});
  }
}

# get one full text line, or last partial line, or undef on eof/error/timeout
#
sub get_response_line {
  my $self = $_[0];
  my $ind; my $attempts = 0;
  my $eol_str = $self->{eol_str};
  my $eol_str_l = !defined($eol_str) ? 0 : length($eol_str);
  for (;;) {
    if (!$eol_str_l) {
      my $str = $self->{inp}; $self->{inp} = ''; return $str;
    } elsif (($ind=index($self->{inp},$eol_str)) >= 0) {
      return substr($self->{inp},0,$ind+$eol_str_l,'');
    } elsif ($self->{inpeof} && $self->{inp} eq '') {
      $! = 0; return;  # undef on end-of-file
    } elsif ($self->{inpeof}) {  # return partial last line
      my $str = $self->{inp}; $self->{inp} = ''; return $str;
    } elsif ($attempts > 0) {
      $! = EIO; return;  # timeout or error
    }
    # try reading some more input, one attempt only
    $self->rw_loop(1,0); $attempts++;
  }
}

# read whatever is available, up to LENGTH bytes
#
sub read {  # SCALAR,LENGTH,OFFSET
  my $self = shift; my $len = $_[1]; my $offset = $_[2];
  defined $len  or die "Amavis::IO::RW::read: length argument undefined";
  $len >= 0     or die "Amavis::IO::RW::read: length argument negative";
  $self->rw_loop(0,0);
  my $nbytes = length($self->{inp});
  $nbytes = $len  if $len < $nbytes;
  if (!defined($offset) || $offset == 0) {
    $_[0] = substr($self->{inp}, 0, $len, '');
  } else {
    substr($_[0],$offset) = substr($self->{inp}, 0, $len, '');
  }
  $nbytes;   # eof: 0;  error: undef
}

use vars qw($ssl_cache);
sub ssl_upgrade {
  my($self, %tls_options) = @_;
  $self->flush;
  IO::Socket::SSL->VERSION(1.05);  # required minimal version
  $ssl_cache = IO::Socket::SSL::Session_Cache->new(2)  if !defined $ssl_cache;
  my $sock = $self->{socket};
  IO::Socket::SSL->start_SSL($sock,
    SSL_session_cache => $ssl_cache,
    SSL_error_trap => sub {
      my($sock,$msg) = @_;
      do_log(-2,"Upgrading socket to TLS failed (in ssl_upgrade): %s", $msg);
    },
    %tls_options,
  ) or die "Error upgrading output socket to TLS: ".IO::Socket::SSL::errstr();
  $self->{last_event} = 'ssl-upgrade';
  $self->{last_event_time} = $self->{last_event_tx_time} = Time::HiRes::time;
  $self->{ssl_active} = 1;
  ll(3) && do_log(3,"TLS cipher: %s", $sock->get_cipher);
  ll(5) && do_log(5,"TLS certif: %s", $sock->dump_peer_certificate);
  1;
}

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.412';
  @ISA = qw(Exporter);
}

sub new
  { my $class = $_[0]; bless {}, $class }

sub client_ip      # client IP address (immediate SMTP client, i.e. our MTA)
  { @_<2 ? shift->{client_ip}   : ($_[0]->{client_ip} = $_[1]) }
sub client_port    # TCP source port number (immediate SMTP client)
  { @_<2 ? shift->{client_port} : ($_[0]->{client_port} = $_[1]) }
sub socket_ip      # IP address of our interface that received connection
  { @_<2 ? shift->{socket_ip}   : ($_[0]->{socket_ip} = $_[1]) }
sub socket_port    # TCP port of our interface that received connection
  { @_<2 ? shift->{socket_port} : ($_[0]->{socket_port} = $_[1]) }
sub socket_proto   # TCP/UNIX
  { @_<2 ? shift->{socket_proto}: ($_[0]->{socket_proto} = $_[1])}
sub socket_path    # socket path, UNIX sockets only
  { @_<2 ? shift->{socket_path} : ($_[0]->{socket_path} = $_[1])}
# RFC 3848
sub appl_proto     # SMTP/ESMTP(A|S|SA)/LMTP(A|S|SA) / AM.PDP/AM.CL/QMQP/QMQPqq
  { @_<2 ? shift->{appl_proto}  : ($_[0]->{appl_proto} = $_[1]) }
sub smtp_helo      # (E)SMTP HELO/EHLO parameter
  { @_<2 ? shift->{smtp_helo}   : ($_[0]->{smtp_helo} = $_[1]) }

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.412';
  @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, not a hash
  { my $class = $_[0]; bless [(undef) x 42], $class }

# subs to set or access individual elements of a n-tuple by name
sub recip_addr       # unquoted recipient envelope e-mail address
  { @_<2 ? shift->[0] : ($_[0]->[0] = $_[1]) }
sub recip_addr_smtp  # SMTP-encoded recipient envelope e-mail address in <>
  { @_<2 ? shift->[1] : ($_[0]->[1] = $_[1]) }
sub recip_addr_modified  # recip. addr. with possible addr. extension inserted
  { @_<2 ? shift->[2] : ($_[0]->[2] = $_[1]) }
sub recip_is_local   # recip_addr matches @local_domains_maps
  { @_<2 ? shift->[3] : ($_[0]->[3] = $_[1]) }
sub recip_maddr_id   # maddr.id field from SQL corresponding to recip_addr_smtp
  { @_<2 ? shift->[4] : ($_[0]->[4] = $_[1]) }
sub recip_maddr_id_orig # maddr.id field from SQL corresponding to dsn_orcpt
  { @_<2 ? shift->[5] : ($_[0]->[5] = $_[1]) }
sub recip_penpals_related  # mail_id of a previous correspondence
  { @_<2 ? shift->[6] : ($_[0]->[6] = $_[1]) }
sub recip_penpals_age # penpals age in seconds if SQL or Redis is enabled
  { @_<2 ? shift->[7] : ($_[0]->[7] = $_[1]) }
sub recip_penpals_score # penpals score (info, also added to spam_level)
  { @_<2 ? shift->[8] : ($_[0]->[8] = $_[1]) }
sub dsn_notify       # ESMTP RCPT command NOTIFY option (DSN-RFC 3461, listref)
  { @_<2 ? shift->[9] : ($_[0]->[9] = $_[1]) }
sub dsn_orcpt  # ESMTP RCPT command ORCPT option (decoded: RFC 3461, RFC 6533)
  { @_<2 ? shift->[10] : ($_[0]->[10] = $_[1]) }
sub dsn_suppress_reason  # if defined disable sending DSN and supply a reason
  { @_<2 ? shift->[11] : ($_[0]->[11] = $_[1]) }
sub recip_destiny    # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
  { @_<2 ? shift->[12] : ($_[0]->[12] = $_[1]) }
sub recip_done       # false: not done, true: done (1: faked, 2: truly sent)
  { @_<2 ? shift->[13] : ($_[0]->[13] = $_[1]) }
sub recip_smtp_response # RFC 5321 response (3-digit + enhanced resp + text)
  { @_<2 ? shift->[14] : ($_[0]->[14] = $_[1]) }
sub recip_remote_mta_smtp_response  # smtp response as issued by remote MTA
  { @_<2 ? shift->[15] : ($_[0]->[15] = $_[1]) }
sub recip_remote_mta # remote MTA that issued the smtp response
  { @_<2 ? shift->[16] : ($_[0]->[16] = $_[1]) }
sub recip_tagged # message was tagged by address extension or Subject or X-Spam
  { @_<2 ? shift->[17] : ($_[0]->[17] = $_[1]) }
sub recip_mbxname    # mailbox name or file when known (local:, bsmtp: or sql:)
  { @_<2 ? shift->[18] : ($_[0]->[18] = $_[1]) }
sub recip_whitelisted_sender  # recip considers this sender whitelisted
  { @_<2 ? shift->[19] : ($_[0]->[19] = $_[1]) }
sub recip_blacklisted_sender  # recip considers this sender blacklisted
  { @_<2 ? shift->[20] : ($_[0]->[20] = $_[1]) }
sub bypass_virus_checks # boolean: virus checks to be bypassed for this recip
  { @_<2 ? shift->[21] : ($_[0]->[21] = $_[1]) }
sub bypass_banned_checks # bool: ban checks are to be bypassed for this recip
  { @_<2 ? shift->[22] : ($_[0]->[22] = $_[1]) }
sub bypass_spam_checks # boolean: spam checks are to be bypassed for this recip
  { @_<2 ? shift->[23] : ($_[0]->[23] = $_[1]) }
sub banned_parts     # banned part descriptions (ref to a list of banned parts)
  { @_<2 ? shift->[24] : ($_[0]->[24] = $_[1]) }
sub banned_parts_as_attr  # banned part descriptions - newer syntax (listref)
  { @_<2 ? shift->[25] : ($_[0]->[25] = $_[1]) }
sub banning_rule_key  # matching banned rules (lookup table keys) (ref to list)
  { @_<2 ? shift->[26] : ($_[0]->[26] = $_[1]) }
sub banning_rule_comment #comments (or whole expr) from banning_rule_key regexp
  { @_<2 ? shift->[27] : ($_[0]->[27] = $_[1]) }
sub banning_reason_short  # just one banned part leaf name with a rule comment
  { @_<2 ? shift->[28] : ($_[0]->[28] = $_[1]) }
sub banning_rule_rhs  # a right-hand side of matching rules (a ref to a list)
  { @_<2 ? shift->[29] : ($_[0]->[29] = $_[1]) }
sub mail_body_mangle  # mail body is being modified (and how) (e.g. defanged)
  { @_<2 ? shift->[30] : ($_[0]->[30] = $_[1]) }
sub contents_category # sorted listref of "major,minor" strings(category types)
  { @_<2 ? shift->[31] : ($_[0]->[31] = $_[1]) }
sub blocking_ccat   # category type most responsible for blocking msg, or undef
  { @_<2 ? shift->[32] : ($_[0]->[32] = $_[1]) }
sub user_id   # listref of recipient IDs from a lookup, e.g. SQL field users.id
  { @_<2 ? shift->[33] : ($_[0]->[33] = $_[1]) }
sub user_policy_id  # recipient's policy ID, e.g. SQL field users.policy_id
  { @_<2 ? shift->[34] : ($_[0]->[34] = $_[1]) }
sub courier_control_file # path to control file containing this recipient
  { @_<2 ? shift->[35] : ($_[0]->[35] = $_[1]) }
sub courier_recip_index # index of recipient within control file
  { @_<2 ? shift->[36] : ($_[0]->[36] = $_[1]) }
sub delivery_method # delivery method, or empty for implicit delivery (milter)
  { @_<2 ? shift->[37] : ($_[0]->[37] = $_[1]) }
sub spam_level  # spam score as returned by spam scanners, ham near 0, spam 5
  { @_<2 ? shift->[38] : ($_[0]->[38] = $_[1]) }
sub spam_tests      # a listref of r/o stringrefs, each: t1=score1,t2=score2,..
  { @_<2 ? shift->[39] : ($_[0]->[39] = $_[1]) }
# per-recipient spam info - when undefined consult a per-message counterpart
sub spam_report     # SA terse report of tests hit (for header section reports)
  { @_<2 ? shift->[40] : ($_[0]->[40] = $_[1]) }
sub spam_summary    # SA summary of tests hit for standard body reports
  { @_<2 ? shift->[41] : ($_[0]->[41] = $_[1]) }

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, $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, $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, @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, @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, @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, @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.412';
  @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(ll do_log orcpt_decode);
  import Amavis::In::Message::PerRecip;
}

sub new
  { my $class = $_[0];
    my $self = bless({},$class); $self->skip_bytes(0); $self }

sub conn_obj        # ref to a connection object Amavis::In::Connection
  { @_<2 ? shift->{conn}       : ($_[0]->{conn} = $_[1]) }
sub rx_time         # Unix time (s since epoch) of message reception by amavisd
  { @_<2 ? shift->{rx_time}    : ($_[0]->{rx_time} = $_[1]) }
sub partition_tag   # SQL partition tag (e.g. an ISO week number 1..53, or 0)
  { @_<2 ? shift->{partition}  : ($_[0]->{partition} = $_[1]) }
sub client_proto    # orig. client protocol, obtained from XFORWARD or milter
  { @_<2 ? shift->{cli_proto}  : ($_[0]->{cli_proto} = $_[1]) }
sub client_addr     # original client IP addr, obtained from XFORWARD or milter
  { @_<2 ? shift->{cli_ip}     : ($_[0]->{cli_ip} = $_[1]) }
sub client_name     # orig. client DNS name, obtained from XFORWARD or milter
  { @_<2 ? shift->{cli_name}   : (shift->{cli_name} = $_[1]) }
sub client_port    # orig client src port num, obtained from XFORWARD or milter
  { @_<2 ? shift->{cli_port}   : ($_[0]->{cli_port} = $_[1]) }
sub client_source   # LOCAL/REMOTE/undef, local_header_rewrite_clients/XFORWARD
  { @_<2 ? shift->{cli_source} : ($_[0]->{cli_source} = $_[1]) }
sub client_helo     # orig. client EHLO name, obtained from XFORWARD or milter
  { @_<2 ? shift->{cli_helo}   : ($_[0]->{cli_helo} = $_[1]) }
sub client_os_fingerprint  # SMTP client's OS fingerprint, obtained from p0f
  { @_<2 ? shift->{cli_p0f}    : ($_[0]->{cli_p0f} = $_[1]) }
sub originating     # originating from our users, copied from c('originating')
  { @_<2 ? shift->{originating}: ($_[0]->{originating} = $_[1]) }
sub queue_id # MTA queue ID of message if known (Courier, milter/AM.PDP, XFORW)
  { @_<2 ? shift->{queue_id}   : ($_[0]->{queue_id} = $_[1]) }
sub log_id          # task id as shown in the log, also known as am_id
  { @_<2 ? shift->{log_id}     : ($_[0]->{log_id} = $_[1]) }
sub mail_id         # long-term unique id of the message on this system
  { @_<2 ? shift->{mail_id}    : ($_[0]->{mail_id} = $_[1]) }
sub secret_id       # secret string to grant access to a message with mail_id
  { @_<2 ? $_[0]->{secret_id}  : ($_[0]->{secret_id} = $_[1]) }
sub parent_mail_id  # original mail_id for msgs generated by amavis (DSN,notif)
  { @_<2 ? shift->{parent_mail_id} : ($_[0]->{parent_mail_id} = $_[1]) }
sub attachment_password # scrambles a potentially dangerous released mail
  { @_<2 ? shift->{release_pwd}: ($_[0]->{release_pwd} = $_[1]) }
sub msg_size        # ESMTP SIZE value, later corrected to actual size,RFC 1870
  { @_<2 ? shift->{msg_size}   : ($_[0]->{msg_size} = $_[1]) }
sub auth_user       # ESMTP AUTH username
  { @_<2 ? shift->{auth_user}  : ($_[0]->{auth_user} = $_[1]) }
sub auth_pass       # ESMTP AUTH password
  { @_<2 ? shift->{auth_pass}  : ($_[0]->{auth_pass} = $_[1]) }
sub auth_submitter  # ESMTP MAIL command AUTH option value (addr-spec or "<>")
  { @_<2 ? shift->{auth_subm}  : (shift->{auth_subm} = $_[1]) }
sub tls_cipher      # defined if TLS was on, e.g. contains cipher alg.,RFC 3207
  { @_<2 ? shift->{auth_tlscif}: ($_[0]->{auth_tlscif} = $_[1]) }
sub dsn_ret         # ESMTP MAIL command RET option   (DSN-RFC 3461)
  { @_<2 ? shift->{dsn_ret}    : ($_[0]->{dsn_ret} = $_[1]) }
sub dsn_envid       # ESMTP MAIL command ENVID option (DSN-RFC 3461) xtext enc.
  { @_<2 ? shift->{dsn_envid}  : ($_[0]->{dsn_envid} = $_[1]) }
sub dsn_passed_on   # obligation to send notification on SUCCESS was relayed
  { @_<2 ? shift->{dsn_pass_on}: ($_[0]->{dsn_pass_on} = $_[1]) }
sub requested_by    # Resent-From addr who requested release from a quarantine
  { @_<2 ? shift->{requested_by}:($_[0]->{requested_by} = $_[1])}
sub body_type       # ESMTP BODY param (RFC 6152: 7BIT, 8BITMIME) or BINARYMIME
  { @_<2 ? shift->{body_type}  : ($_[0]->{body_type} = $_[1]) }
sub smtputf8        # ESMTP SMTPUTF8 param, boolean (RFC 6531)
  { @_<2 ? shift->{smtputf8}   : ($_[0]->{smtputf8} = $_[1]) }
sub header_8bit     # true if header contains non-ASCII characters
  { @_<2 ? shift->{header_8bit}: ($_[0]->{header_8bit} = $_[1]) }
sub body_8bit       # true if body contains non-ASCII characters
  { @_<2 ? shift->{body_8bit}  : ($_[0]->{body_8bit} = $_[1]) }
sub sender          # envelope sender, internal form, e.g.: j doe@example.com
  { @_<2 ? $_[0]->{sender}     : ($_[0]->{sender} = $_[1]) }
sub sender_smtp     # env sender, SMTP form in <>, e.g.: <"j doe"@example.com>
  { @_<2 ? shift->{sender_smtp}: ($_[0]->{sender_smtp} = $_[1]) }
sub sender_credible # envelope sender is believed to be valid
  { @_<2 ? shift->{sender_cred}: ($_[0]->{sender_cred} = $_[1]) }
sub sender_source   # unmangled sender addr. or info from the trace (log/notif)
  { @_<2 ? shift->{sender_src} : ($_[0]->{sender_src} = $_[1]) }
sub sender_maddr_id # maddr.id field from SQL if logging to SQL is enabled
  { @_<2 ? shift->{maddr_id}   : ($_[0]->{maddr_id} = $_[1]) }
sub mime_entity     # MIME::Parser entity holding the parsed message
  { @_<2 ? shift->{mime_entity}: (shift->{mime_entity} = $_[1])}
sub parts_root      # Amavis::Unpackers::Part root object
  { @_<2 ? shift->{parts_root} : ($_[0]->{parts_root} = $_[1])}
sub skip_bytes      # file offset where mail starts, useful for quar. release
  { @_<2 ? shift->{file_ofs}   : ($_[0]->{file_ofs} = $_[1]) }
sub mail_text       # RFC 5322 msg: open file handle, or MIME::Entity object
  { @_<2 ? shift->{mail_text}  : ($_[0]->{mail_text} = $_[1]) }
sub mail_text_str   # RFC 5322 msg: small messages as a stringref, else undef
  { @_<2 ? shift->{mailtextstr}: ($_[0]->{mailtextstr} = $_[1]) }
sub mail_text_fn    # orig. mail filename or undef, e.g. mail_tempdir/email.txt
  { @_<2 ? shift->{mailtextfn} : ($_[0]->{mailtextfn} = $_[1]) }
sub mail_tempdir    # work directory, under $TEMPBASE or supplied by client
  { @_<2 ? shift->{mailtempdir}: ($_[0]->{mailtempdir} = $_[1])}
sub mail_tempdir_obj # Amavis::TempDir obj when non-persistent (quar.release)
  { @_<2 ? shift->{tempdirobj}: ($_[0]->{tempdirobj} = $_[1])}
sub header_edits    # Amavis::Out::EditHeader object or undef
  { @_<2 ? shift->{hdr_edits}  : ($_[0]->{hdr_edits} = $_[1]) }
sub rfc2822_from #author addresses list (rfc allows one or more), parsed 'From'
  { @_<2 ? $_[0]->{hdr_from}   : ($_[0]->{hdr_from} = $_[1]) }
sub rfc2822_sender  # sender address (rfc allows none or one), parsed 'Sender'
  { @_<2 ? shift->{hdr_sender} : ($_[0]->{hdr_sender} = $_[1]) }
sub rfc2822_resent_from # resending author addresses list, parsed 'Resent-From'
  { @_<2 ? shift->{hdr_rfrom}  : ($_[0]->{hdr_rfrom} = $_[1]) }
sub rfc2822_resent_sender  # resending sender addresses, parsed 'Resent-Sender'
  { @_<2 ? shift->{hdr_rsender}: ($_[0]->{hdr_rsender} = $_[1]) }
sub rfc2822_to      # parsed 'To' header field: a list of recipients
  { @_<2 ? shift->{hdr_to}     : ($_[0]->{hdr_to} = $_[1]) }
sub rfc2822_cc      # parsed 'Cc' header field: a list of Cc recipients
  { @_<2 ? shift->{hdr_cc}     : (shift->{hdr_cc} = $_[1]) }
sub orig_header_fields # header field indices by h.f. name, hashref of arrays
  { @_<2 ? shift->{orig_hdr_f} : ($_[0]->{orig_hdr_f} = $_[1]) }
sub orig_header # orig.h.sect, arrayref of h.fields, with folding & trailing LF
  { @_<2 ? shift->{orig_header}: ($_[0]->{orig_header} = $_[1]) }
sub orig_header_size # size of original header, incl. a separator line,RFC 1870
  { @_<2 ? shift->{orig_hdr_s} : ($_[0]->{orig_hdr_s} = $_[1]) }
sub references  # References & In-Reply-To message IDs, array
  { @_<2 ? shift->{refs}       : ($_[0]->{refs} = $_[1]) }
sub orig_body_size  # size of original body (in bytes), RFC 1870
  { @_<2 ? shift->{orig_bdy_s} : ($_[0]->{orig_bdy_s} = $_[1]) }
sub body_start_pos  # byte offset into a msg where mail body starts (if known)
  { @_<2 ? shift->{body_pos}: ($_[0]->{body_pos} = $_[1]) }
sub body_digest     # digest of a message body (e.g. MD5, SHA1, SHA256), hex
  { @_<2 ? shift->{body_digest}: ($_[0]->{body_digest} = $_[1]) }
sub trace  # info from Received header fields, top-down, array of hashrefs
  { @_<2 ? shift->{trace}      : ($_[0]->{trace} = $_[1]) }
sub ip_addr_trace_public  # public IP addresses in 'Received from' hdr flds
  { @_<2 ? shift->{iptracepub} : ($_[0]->{iptracepub} = $_[1]) }
sub is_mlist        # mail is from a mailing list (boolean/string)
  { @_<2 ? shift->{is_mlist}   : ($_[0]->{is_mlist} = $_[1]) }
sub is_auto         # mail is an auto-response (boolean/string)
  { @_<2 ? shift->{is_auto}    : ($_[0]->{is_auto} = $_[1]) }
sub is_bulk         # mail from a m.list or bulk or auto-response (bool/string)
  { @_<2 ? $_[0]->{is_bulk}    : ($_[0]->{is_bulk} = $_[1]) }
sub dkim_signatures_all # a ref to a list of DKIM signature objects, or undef
  { @_<2 ? shift->{dkim_sall}  : ($_[0]->{dkim_sall} = $_[1]) }
sub dkim_signatures_valid # a ref to a list of valid DKIM signature objects
  { @_<2 ? shift->{dkim_sval}  : ($_[0]->{dkim_sval} = $_[1]) }
sub dkim_author_sig # author domain signature present and valid (bool/domain)
  { @_<2 ? shift->{dkim_auth_s}: ($_[0]->{dkim_auth_s} = $_[1]) }
sub dkim_thirdparty_sig # third-party signature present and valid (bool/domain)
  { @_<2 ? shift->{dkim_3rdp_s}: ($_[0]->{dkim_3rdp_s} = $_[1]) }
sub dkim_sender_sig # a sender signature is present and is valid (bool/domain)
  { @_<2 ? shift->{dkim_sndr_s}: (shift->{dkim_sndr_s} = $_[1]) }
sub dkim_envsender_sig # boolean: envelope sender signature present and valid
  { @_<2 ? shift->{dkim_envs_s}: ($_[0]->{dkim_envs_s} = $_[1]) }
sub dkim_signatures_new # ref to a list of DKIM signature objects, our signing
  { @_<2 ? shift->{dkim_snew}  : ($_[0]->{dkim_snew} = $_[1]) }
sub dkim_signwith_sd # ref to a pair [selector,domain] to force signing with
  { @_<2 ? shift->{dkim_signsd}: ($_[0]->{dkim_signsd} = $_[1]) }
sub quarantined_to  # list of quar mailbox names or addresses if quarantined
  { @_<2 ? shift->{quarantine} : ($_[0]->{quarantine} = $_[1]) }
sub quar_type  # list of quar types: F/Z/B/Q/M (file/zipfile/bsmtp/sql/mailbox)
  { @_<2 ? shift->{quar_type}  : ($_[0]->{quar_type} = $_[1]) }
sub dsn_sent        # delivery status notification was sent(1) or suppressed(2)
  { @_<2 ? shift->{dsn_sent}   : ($_[0]->{dsn_sent} = $_[1]) }
sub client_delete   # don't delete the tempdir, it is a client's responsibility
  { @_<2 ? shift->{client_del} :($_[0]->{client_del} = $_[1])}
sub contents_category # sorted arrayref CC_VIRUS/CC_BANNED/CC_SPAM../CC_CLEAN
  { @_<2 ? shift->{category}   : ($_[0]->{category} = $_[1]) }
sub blocking_ccat   # category type most responsible for blocking msg, or undef
  { @_<2 ? $_[0]->{bl_ccat}    : ($_[0]->{bl_ccat} = $_[1]) }
sub checks_performed  # a hashref of checks done on a msg (for statistics/log)
  { @_<2 ? shift->{checks_perf}: ($_[0]->{checks_perf} = $_[1]) }
sub actions_performed  # listref, summarized actions & SMTP status, for logging
  { @_<2 ? shift->{act_perf}   : ($_[0]->{act_perf} = $_[1]) }
sub virusnames      # a ref to a list of virus names detected, or undef
  { @_<2 ? shift->{virusnames} : ($_[0]->{virusnames} = $_[1]) }
sub spam_report     # SA terse report of tests hit (for header section reports)
  { @_<2 ? shift->{spam_report}   : ($_[0]->{spam_report} = $_[1])}
sub spam_summary    # SA summary of tests hit for standard body reports
  { @_<2 ? shift->{spam_summary}  :($_[0]->{spam_summary} = $_[1])}
sub ip_repu_score   # IP reputation score (info, also added to spam_level)
  { @_<2 ? shift->{ip_repu_score} :($_[0]->{ip_repu_score} = $_[1])}
sub time_elapsed    # elapsed times by section - associative array ref
  { @_<2 ? shift->{elapsed}       : ($_[0]->{elapsed} = $_[1])}

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

{ no warnings 'once';
# 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 precaution)! This is vital
# to be able to produce correct per-recipient responses to an 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(
        join(';', orcpt_decode(';'.$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) = @_;
  my $h = $self->{hdr_sig_ind};  my $hf;
  if (@_ > 2) {
    $self->{hdr_sig_ind} = $h = []  if !$h;
    $hf = $h->[$header_field_index];
    $h->[$header_field_index] = $hf = []  if !$hf;
    # store signature index(es) at a given header position
    shift; shift; push(@$hf, @_);
  }
  $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
# in 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, ...)
#
sub get_header_field2 {
  my($self, $field_name, $j) = @_;
  my $orig_hfields = $self->orig_header_fields;
  return if !$orig_hfields;
  my($field_ind, $field, $all_fields, $hfield_indices);
  # arrayref of header field indices for a given h.field name
  $hfield_indices = $orig_hfields->{lc $field_name}  if defined $field_name;
  $all_fields = $self->orig_header;
  if (defined $field_name) {
    if (!defined $hfield_indices) {
      # no header field with such name
    } elsif (ref $hfield_indices) {
      # $hfield_indices is an arrayref
      $j = 0  if !defined $j;
      $field_ind = $hfield_indices->[$j];
    } else {
      # optimized: $hfield_indices is a scalar - the only element
      $field_ind = $hfield_indices  if !defined($j) || $j == 0 || $j == -1;
    }
  } elsif (!ref $all_fields) {
    # no header section
  } elsif ($j >= 0) {  # top-down, 0,1,2,...
    $field_ind = $j  if $j <= $#$all_fields;
  } else {  # bottom-up, -1,-2,-3,...
    $j += @$all_fields;  # turn into an absolute index
    $field_ind = $j  if $j >= 0;
  }
  return $field_ind  if !wantarray;
  ($field_ind, !defined $field_ind ? undef : $all_fields->[$field_ind]);
}

# compatibility wrapper for pre-2.8.0 custom code
#
sub get_header_field {
  my($self, $field_name, $j) = @_;
  my($field_ind, $field) = $self->get_header_field2($field_name,$j);
  if (defined($field_ind) && wantarray) {
    local $1;
    $field_name = lc($1)  if $field =~ /^([^:]*?)[ \t]*:/s;
  }
  !wantarray ? $field_ind : ($field_ind, $field_name, $field);
}

sub get_header_field_body {
  my($self, $field_name, $j) = @_;
  my $k;  my($field_ind, $f) = $self->get_header_field2($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.412';
  @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 min max q_encode
                         safe_encode safe_encode_utf8_inplace);
}
use Errno qw(EBADF);
use Encode ();
use MIME::Words;

sub new {
  my $class = $_[0];
  bless { prepend=>[], append=>[], addrcvd=>[], edit=>{} }, $class;
}

sub prepend_header {
  my $self = shift;
  unshift(@{$self->{prepend}}, hdr(@_));
}

sub append_header {
  my $self = shift;
  push(@{$self->{append}}, hdr(@_));
}

sub append_header_above_received {
  my $self = shift;
  push(@{$self->{addrcvd}}, hdr(@_));
}

# 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 = shift;
  push(@{$self->{addrcvd}}, hdr(@_));
}

# delete all header fields with a $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) = @_;
  # $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(5, "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->{$_};
    }
    my $o_edit = $other_edits->{edit};
    if ($o_edit) {
      for my $fn (keys %$o_edit) {
        if (!exists($self->{edit}{$fn})) {
          $self->{edit}{$fn} = [ @{$o_edit->{$fn}} ];  # copy list
        } else {
          unshift(@{$self->{edit}{$fn}}, @{$o_edit->{$fn}});
        }
      }
    }
  }
}

# Conditioning of a header field to be added.
# Insert space after colon if not present, RFC 2047 -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 lines with only
# spaces are not allowed. (RFC 5322: Each line of characters MUST be no more
# than 998 octets(!) (RFC 6532), and SHOULD be no more than 78 characters(!)
# (RFC 6532), 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, $smtputf8) = @_;
  $wrap_char = "\t"  if !defined $wrap_char;
  safe_encode_utf8_inplace($field_name);  # to octets (if not already)
  $field_name =~ tr/\x21-\x39\x3B-\x7E/?/c;  # printable ASCII except ':'
  my $field_body_is_utf8 = utf8::is_utf8($field_body);
  local($1);
  if ($field_body !~ tr/\x00-\x7F//c) {  # is all-ASCII
    # no encoding necessary, just clear the utf8 flag if set
    if ($field_body_is_utf8) {
      do_log(5,'header encoded (utf8:Y) (all-ASCII): %s: %s',
               $field_name, $field_body);
      safe_encode_utf8_inplace($field_body);  # to octets (if not already)
    } else {
      do_log(5,'header encoded (all-ASCII): %s: %s', $field_name, $field_body);
    }
  } elsif ($smtputf8) {  # UTF-8 in header field bodies is allowed
    safe_encode_utf8_inplace($field_body)  if $field_body_is_utf8;
    ll(5) && do_log(5,'header encoded (utf8:%s) to UTF-8 (SMTPUTF8): %s: %s',
                      $field_body_is_utf8?'Y':'N', $field_name, $field_body);
  } elsif ($field_name =~ /^(?: Subject | Comments |
                            (?:Resent-)? (?: From|Sender|To|Cc ) )\z/six &&
           $field_body !~ /^[\t\n\x20-\x7F]*\z/  # but printable or HT or LF
       # consider also:  | X- (?! Envelope- (?:From|To)\z )
  ) {  # 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 $chset = c('hdr_encoding');
    my $field_body_octets = safe_encode($chset, $field_body);
    ll(5) && do_log(5,'header encoded (utf8:%s) to %s, %s: %s -> %s',
                      $field_body_is_utf8?'Y':'N', $chset,
                      $field_name, $field_body, $field_body_octets);
    my $qb = c('hdr_encoding_qb');
    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 {  # should have been all-ASCII, or UTF-8 with SMTPUTF8 - but anyway:
    safe_encode_utf8_inplace($field_body)  if $field_body_is_utf8;
    ll(5) && do_log(5,'header encoded (utf8:%s) to UTF-8: %s: %s',
                      $field_body_is_utf8?'Y':'N', $field_name, $field_body);
  }
  my $str = $field_name . ':';
  $str .= ' '  if $field_body =~ /^[^ \t]/;  # insert space, looks nicer
  $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($_,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 =~ s{\n*\z}{\n}s;  # ensure a single final NL
  ll(5) && do_log(5, 'header: %s', $str);
  $str;
}

# Copy mail header section to the supplied method while adding, removing,
# or changing certain header fields as required, and append an empty line
# (header/body separator). Returns a number of original 'Received:'
# header fields to make a simple loop detection possible (as required
# by RFC 5321 (ex RFC 2821) section 6.3).
# Leaves input file positioned at the beginning of a body.
#
sub write_header($$$$) {
  my($self, $msginfo, $out_fh, $noninitial_submission) = @_;
  my $received_cnt = 0;
  my($fix_whitespace_lines, $fix_long_header_lines, $fix_bare_cr) = (0,0,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(@header); my $pos = 0; my $header_in_array = 0;
  my $msg = $msginfo->mail_text;
  my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
  $msg = $msg_str_ref  if ref $msg_str_ref;
  if (!defined $msg) {
    # empty mail
    $header_in_array = 1;
  } elsif (ref $msg eq 'SCALAR') {
    $header_in_array = 1;
    $pos = min($msginfo->skip_bytes, length($$msg));
    if ($pos >= length($$msg)) {  # empty message
      $pos = length($$msg);
    } elsif (substr($$msg,$pos,1) eq "\n") {  # empty header section
      $pos++;
    } else {
      my $ind = index($$msg, "\n\n", $pos);  # find header/body separator
      if ($ind < 0) {  # no body
        @header = split(/^/m, substr($$msg, $pos));
        $pos = length($$msg);
      } else {  # normal, nonempty header section and nonempty body
        @header = split(/^/m, substr($$msg, $pos, $ind+1-$pos));
        $pos = $ind+2;
      }
    }
    # $pos now points to the first byte of a body
  } elsif ($msg->isa('MIME::Entity')) {
    $header_in_array = 1;
    $fix_whitespace_lines = 1;  # fix MIME::Entity artifacts
    @header = @{$msg->header};
  } else {  # a file handle assumed
    $pos = $msginfo->skip_bytes;
    $msg->seek($pos,0)  or die "Can't rewind mail file: $!";
  }
  ll(5) && do_log(5, 'write_header: %s, %s', $header_in_array, $out_fh);
  # preallocate some storage
  my $str = ''; vec($str,8192,8) = 0; $str = '';
  $str .= $_  for @{$self->{prepend}};
  $str .= $_  for @{$self->{addrcvd}};
  my($ill_white_cnt, $ill_long_cnt, $ill_bare_cr) = (0,0,0);
  local($1,$2); my $curr_head; my $next_head; my $eof = 0;
  for (;;) {
    if ($eof) {
      $next_head = "\n";  # fake a missing header/body separator line
    } elsif ($header_in_array) {
      for (;;) {  # get next nonempty line or eof
        if (!@header) { $eof = 1; $next_head = "\n"; last }
        $next_head = shift @header;
        # ensure NL at end, faster than m/\n\z/
        $next_head .= "\n"  if substr($next_head,-1,1) ne "\n";
        last  if !$fix_whitespace_lines || $next_head !~ /^[ \t]*\n\z/s;
        $ill_white_cnt++;
      }
    } else {
      $! = 0; $next_head = $msg->getline;
      if (defined $next_head) {
        $pos += length($next_head);
      } else {
        $eof = 1; $next_head = "\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: $!";
      }
    }
    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 the first hdr 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 RFC 822 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
            my($new_fbody,$verbatim);
            ($new_fbody,$verbatim) =
              &$e($field_name,$field_body)  if defined $e;
            if (!defined($new_fbody)) {
              ll(5) && do_log(5, 'deleted: %s:%s', $field_name, $field_body);
              $curr_head = undef; last;
            }
            $curr_head = $verbatim ? ($field_name . ':' . $new_fbody)
                                   : hdr($field_name, $new_fbody, 0, undef,
                                         $msginfo->smtputf8);
            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...}gm  and $ill_long_cnt++;
        }
        # use buffering to reduce number of calls to datasend()
        if (length($str) > 16384) {
          $out_fh->print($str) or die "sending mail header: $!";
          $str = '';
        }
        $str .= $curr_head;
      }
      last  if $next_head eq "\n";   # header/body separator
      last  if substr($next_head,0,2) eq '--';  # mime sep. (missing h/b sep.)
      $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 .= "\n";  # end of header section - a separator line
  $out_fh->print($str) or die "sending mail header final: $!";
  section_time('write-header');
  ($received_cnt, $pos);
}
1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT = qw(&mail_dispatch);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll do_log);
}

sub mail_dispatch($$$;$) {
  my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;

  my $tmp_hdr_edits;
  my $saved_hdr_edits = $msginfo->header_edits;
  if (!c('enable_dkim_signing')) {
    # no signing
  } elsif ($initial_submission && $initial_submission eq 'Quar') {
    # do not attempt to sign messages on their way to a quarantine
  } else {
    # generate and add DKIM signatures
    my(@signatures) = Amavis::DKIM::dkim_make_signatures($msginfo,0);
    if (@signatures) {
      $msginfo->dkim_signatures_new(\@signatures);
      if (!defined($tmp_hdr_edits)) {
        $tmp_hdr_edits = Amavis::Out::EditHeader->new;
        $tmp_hdr_edits->inherit_header_edits($saved_hdr_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)://si;
        $tmp_hdr_edits->prepend_header($1, $s, 2);
      }
      if (c('enable_dkim_verification') &&
          grep($_->recip_is_local, @{$msginfo->per_recip_data})) {
        # it is too late to split a message now, add the A-R header field
        # if at least one recipient is local
        my $allowed_hdrs = cr('allowed_added_header_fields');
        if ($allowed_hdrs && $allowed_hdrs->{lc('Authentication-Results')}) {
          for my $h (Amavis::DKIM::generate_authentication_results(
                                                $msginfo, 0, \@signatures)) {
            $tmp_hdr_edits->prepend_header('Authentication-Results', $h, 1);
          }
        }
      }
    }
    $msginfo->header_edits($tmp_hdr_edits)  if defined $tmp_hdr_edits;
  }

  my $any_deliveries = 0;
  my $per_recip_data = $msginfo->per_recip_data;
  my $num_recips_notdone =
    scalar(grep(!$_->recip_done && (!$filter || &$filter($_)),
                @$per_recip_data));
  while ($num_recips_notdone > 0) {
    # a delivery method may be a scalar of a form protocol:socket_specs, or
    # a listref of such elements; if a list is provided, it is expected that
    # each entry will be using the same protocol name, otherwise behaviour
    # is unspecified - so just obtain the protocol name from the first entry
    #
    my(%protocols, $any_tempfail);
    for my $r (@$per_recip_data) {
      if (!$dsn_per_recip_capable) {
        my $recip_smtp_response = $r->recip_smtp_response;  # any 4xx code ?
        if (defined($recip_smtp_response) && $recip_smtp_response =~ /^4/) {
          $any_tempfail = $recip_smtp_response . ' (' . $r->recip_addr . ')';
        }
      }
      if (!$r->recip_done && (!$filter || &$filter($r))) {
        my $proto_sockname = $r->delivery_method;
        defined $proto_sockname
          or die "mail_dispatch: undefined delivery_method";
        !ref $proto_sockname || ref $proto_sockname eq 'ARRAY'
          or die "mail_dispatch: not a scalar or array ref: $proto_sockname";
        for (ref $proto_sockname ? @$proto_sockname : $proto_sockname) {
          local($1);
          if (/^([a-z][a-z0-9.+-]*):/si) { $protocols{lc($1)} = 1 }
          else { die "mail_dispatch: no recognized protocol name: $_" }
        }
      }
    }
    my(@unknown) =
      grep(!/^(?:smtp|lmtp|pipe|bsmtp|sql|local)\z/i, keys %protocols);
    !@unknown  or die "mail_dispatch: unknown protocol: ".join(', ',@unknown);

    if (!$dsn_per_recip_capable && defined $any_tempfail) {
      do_log(0, "temporary failures, giving up further deliveries: %s",
                $any_tempfail);
      my $smtp_resp =
        "451 4.5.0 Giving up due to previous temporary failures, id=" .
        $msginfo->log_id;
      # flag the remaining undelivered recipients as temporary failures
      for my $r (@$per_recip_data) {
        next if $r->recip_done;
        $r->recip_smtp_response($smtp_resp); $r->recip_done(1);
      }
      last;
    }

    # do one protocol per iteration only, so that we can bail out
    # as soon as some 4xx temporary failure is detected, avoiding
    # further deliveries which would lead to duplicate deliveries
    #
    if ($protocols{'smtp'} || $protocols{'lmtp'}) {
      Amavis::Out::SMTP::mail_via_smtp(@_);
      $any_deliveries = 1;  # approximation, will do for the time being
    } elsif ($protocols{'local'}) {
      Amavis::Out::Local::mail_to_local_mailbox(@_);
      $any_deliveries = 1;  # approximation, will do for the time being
    } elsif ($protocols{'pipe'}) {
      Amavis::Out::Pipe::mail_via_pipe(@_);
      $any_deliveries = 1;  # approximation, will do for the time being
    } elsif ($protocols{'bsmtp'}) {
      Amavis::Out::BSMTP::mail_via_bsmtp(@_);
      $any_deliveries = 1;  # approximation, will do for the time being
    } elsif ($protocols{'sql'}) {
      $Amavis::extra_code_sql_quar && $Amavis::sql_storage
        or die "SQL quarantine code not enabled (1)";
      Amavis::Out::SQL::Quarantine::mail_via_sql(
                                        $Amavis::sql_dataset_conn_storage, @_);
      $any_deliveries = 1;  # approximation, will do for the time being
    }

    # are we done yet?
    my $num_recips_notdone_after =
      scalar(grep(!$_->recip_done && (!$filter || &$filter($_)),
                  @$per_recip_data));
    if ($num_recips_notdone_after >= $num_recips_notdone) {
      do_log(-2, "TROUBLE: Number of recipients (%d) not reduced, ".
                 "abandoning effort, proto: %s",
                 $num_recips_notdone_after, join(', ', keys %protocols) );
      last;
    }
    if ($num_recips_notdone_after > 0) {
      do_log(3, "Sent to %s recipients, %s still to go",
                $num_recips_notdone - $num_recips_notdone_after,
                $num_recips_notdone_after);
    }
    $num_recips_notdone = $num_recips_notdone_after;
  }
  # restore header edits if modified
  $msginfo->header_edits($saved_hdr_edits)  if defined $tmp_hdr_edits;

  $any_deliveries;  # (estimate) were any successful deliveries actually done?
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&first_received_from &oldest_public_ip_addr_from_received);
  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(normalize_ip_addr);
}
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 = $_[0];
  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.
# Search bottom-up, use the first public IP address from the trace.
#
sub oldest_public_ip_addr_from_received($) {
  my($msginfo) = @_;
  my $received_from_ip;
  my $ip_trace_ref = $msginfo->ip_addr_trace_public;  # top-down trace
  $received_from_ip = $ip_trace_ref->[-1]  if $ip_trace_ref;  # last is oldest
  do_log(5, "oldest_public_ip_addr_from_received: %s", $received_from_ip)
    if defined $received_from_ip;
  $received_from_ip;
}

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.412';
  @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 minmax);
}

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));
  ll(4) && do_log(4,'Original mail size: %d; quota set to: %d bytes '.
                    '(fmin=%s, fmax=%s, qmin=%s, qmax=%s)',
                    $mail_size, $avail_quota,
                    map(defined $_ ? "$_" : 'UNDEF',
                        $MIN_EXPANSION_FACTOR, $MAX_EXPANSION_FACTOR,
                        $MIN_EXPANSION_QUOTA, $MAX_EXPANSION_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 = $_[0];
  $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 = $_[0];
  $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) = @_;
  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.412';
  @ISA = qw(Exporter);
  import Amavis::Util qw(ll do_log);
}

use vars qw($file_generator_object);
sub init($) { $file_generator_object = $_[0] }

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
  { @_<2 ? shift->{number}   : ($_[0]->{number} = $_[1]) };
sub dir_name
  { @_<2 ? shift->{dir_name} : ($_[0]->{dir_name} = $_[1]) };
sub parent
  { @_<2 ? shift->{parent}   : ($_[0]->{parent} = $_[1]) };
sub children
  { @_<2 ? shift->{children}||[] : ($_[0]->{children} = $_[1]) };
sub mime_placement    # part location within a MIME tree, e.g. "1/1/3"
  { @_<2 ? shift->{place}    : ($_[0]->{place} = $_[1]) };
sub type_short        # string or a ref to a list of strings, case sensitive
  { @_<2 ? shift->{ty_short} : ($_[0]->{ty_short} = $_[1]) };
sub type_long
  { @_<2 ? shift->{ty_long}  : ($_[0]->{ty_long} = $_[1]) };
sub type_declared
  { @_<2 ? shift->{ty_decl}  : ($_[0]->{ty_decl} = $_[1]) };
sub name_declared     # string or a ref to a list of strings
  { @_<2 ? shift->{nm_decl}  : ($_[0]->{nm_decl} = $_[1]) };
sub report_type       # a string, e.g. 'delivery-status', RFC 6522
  { @_<2 ? shift->{rep_typ}  : ($_[0]->{rep_typ} = $_[1]) };
sub size              # size in bytes
  { @_<2 ? shift->{size}     : ($_[0]->{size} = $_[1]) };
sub digest            # digest of a mime part contents (typically SHA1, hex)
  { @_<2 ? shift->{digest}   : ($_[0]->{digest} = $_[1]) };
sub exists
  { @_<2 ? shift->{exists}   : ($_[0]->{exists} = $_[1]) };
sub attributes        # a string of characters representing attributes
  { @_<2 ? shift->{attr}     : ($_[0]->{attr} = $_[1]) };

sub attributes_add {  # U=undecodable, C=crypted, D=directory,S=special,L=link
  my $self = shift; my $a = $self->{attr}; $a = '' if !defined $a;
  for my $arg (@_) { $a .= $arg  if $arg ne '' && index($a,$arg) < 0 }
  $self->{attr} = $a;
};

sub base_name { my $self = $_[0]; sprintf("p%03d",$self->number) }

sub full_name {
  my $self = $_[0]; 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 = $_[0];
  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.412';
  @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.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&check_header_validity &check_for_banned_names);
  import Amavis::Util qw(ll do_log min max minmax untaint untaint_inplace
                         is_valid_utf_8 truncate_utf_8);
  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 $msginfo = $_[0];
  my(%field_head_counts, @bad);
  my $minor_badh_category = 0;
  my $allowed_tests = cr('allowed_header_tests');
  my($t_syntax, $t_empty, $t_long, $t_control, $t_8bit, $t_utf8,
     $t_missing, $t_multiple) =
    !$allowed_tests ? () : @$allowed_tests{qw(syntax empty long control
                                              8bit utf8 missing multiple)};
  # minor category:  2: 8-bit char, 3: NUL/CR control, 4: empty line, 5: long,
  #                  6: syntax, 7: missing, 8: multiple
  local($1,$2,$3);
  for my $curr_head (@{$msginfo->orig_header}) {#array of hdr fields, not lines
    my($field_name,$msg1,$msg2,$pre,$mid,$post);
    # obsolete RFC 822 syntax allowed whitespace before colon
    $field_name = $1  if $curr_head =~ /^([!-9;-\x7E\x80-\xFF]+)[ \t]*:/s;
    $field_head_counts{lc($field_name)}++  if defined $field_name;
    if (!defined($field_name) || substr($field_name,0,2) eq '--') {
      if ($t_syntax) {
        $msg1 = "Invalid header field syntax"; $msg2 = $curr_head;
        $minor_badh_category = max(6, $minor_badh_category);
      }
    } elsif ($t_syntax && $field_name =~ /([^\x00-\x7F])/gs) {
      $mid = $1; $msg1 = "Invalid header field name, contains non-ASCII char";
      $minor_badh_category = max(6, $minor_badh_category);
    } elsif ($t_empty && $curr_head =~ /^([ \t]+)(?=\n|\z)/gms) {
      $mid = $1;
      $msg1 ="Improper folded header field made up entirely of whitespace";
      # 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"; $msg2 = $1;
      substr($msg2, 50) = '[...]'  if length($msg2) > 55;
      $minor_badh_category = max(5, $minor_badh_category);
    } elsif ($t_control && $curr_head =~ /([\000\015])/gs) {
      $mid = $1; $msg1 = "Improper use of control character";
      $minor_badh_category = max(3, $minor_badh_category);
    } elsif ($t_8bit && $curr_head =~ /([^\x00-\x7F])/gs) {  # non-ASCII
      $mid = $1;
      if (!is_valid_utf_8($curr_head)) {
        $msg1 = 'Non-encoded non-ASCII data (and not UTF-8)';
      } elsif ($curr_head =~ /^([\x00-\x08\x0B-\x1F\x7F])/xgs) { # but TAB,NL
        $mid = $1; $msg1 = 'UTF-8 string contains C0 Controls';
      } elsif ($curr_head =~
          /( (?: \xC2 | \xE0 \x82 | \xF0 \x80 \x82 ) [\x80-\x9F] )/xgs) {
        # RFC 5198 prohibits "C1 Controls" (U+0080..U+009F) for Net-Unicode
        $mid = $1; $msg1 = 'UTF-8 string contains C1 Controls';
      } elsif ($msginfo->smtputf8) {
        # UTF-8 header bodies (but not field names) are valid with SMTPUTF8
      } elsif ($t_utf8) {
        $msg1 = 'Non-encoded UTF-8 string in non-EAI mail';
        if ($curr_head =~ /( [\xC0-\xDF][\x80-\xBF] |
                             [\xE0-\xEF][\x80-\xBF]{2} |
                             [\xF0-\xF4][\x80-\xBF]{3} )/xgs ) {
          $mid = $1;  # capture the entire first non-ASCII UTF-8 character
        }
      }
      $minor_badh_category = max(2, $minor_badh_category)  if defined $msg1;
    }
    if (defined $msg1) {
      $mid = ''  if !defined $mid;
      if (!defined $msg2) {
        $pre = substr($curr_head, 0, pos($curr_head)-length($mid))
          if !defined $pre;
        $post = substr($curr_head,pos($curr_head))  if !defined $post;
        chomp($post);
        $mid  = truncate_utf_8($mid, 15).'[...]'  if length($mid)  > 20;
        $post = truncate_utf_8($post,15).'[...]'  if length($post) > 20;
        if (length($pre)-length($field_name)-2 > 50-length($post)) {
          $pre = $field_name . ': ...'
                 . substr($pre, length($pre) - (45-length($post)));
        }
        $msg2 = $pre . $mid . $post;
      }
      if ($mid ne '' && length($mid) <= 4) {
        $msg1 .= " (char ";
        $msg1 .= join(' ', map(sprintf('%02X',ord($_)), split(//,$mid)));
        $msg1 .= " hex)";
      }
      push(@bad, "$msg1: $msg2");
      last  if @bad >= 100;  # some sanity limit
    }
  }
  # RFC 5322 (ex RFC 2822), RFC 2045, RFC 2183
  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 && $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);
    }
  }
  for (@bad) {  # sanitize C0 controls and non-ASCII
    s{ ( [^\x20-\x7E] | \\ (?= x \{ ) ) }
     { sprintf('\\x{%02X}', ord($1)) }xgse  if tr/\x00-\x7F//c;
  }
  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 = $_[0];
  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} "
                                              | [^, ] )+ | [, ]+/xgs));
            # 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;
        if (defined $n && $n ne '') { push(@k,"A=$_") for split(/ */,$n) }
        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 an 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);
      for my $e (@recip_tables) {
        @$e{qw(found result matchk part_descr_attr part_descr_trad part_name)}
          = (0, undef, undef, undef, undef, undef);
      }
      my($result, $matchingkey, $t_ref_old);
      for my $e (@recip_tables) {  # for each recipient and his tables
        my($found,$recip,$t_ref) = @$e{qw(found recip tables)};
        if ($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;
          }
          if (defined $result) {
            @$e{qw(found result matchk
                   part_descr_attr part_descr_trad part_name)} =
              (1, $result, $matchingkey,
               $key_val_str, $key_val_trad_str, $simple_part_name);
          }
        }
      }
      if (ref $bnpre && grep(!$_->{result}, @recip_tables)) {  # any non-true?
        # try new style: banned_namepath_re; it is global, not per-recipient
        my $descr_str = join("\n",@descr);
        if ($] < 5.012003) {
          # avoid a [perl #62048] bug in lookup_re():
          #   Unwarranted "Malformed UTF-8 character" on tainted variable
          untaint_inplace($descr_str);
        }
        my($result,$matchingkey) = lookup2(0, $descr_str, [$bnpre],
                                           Label=>'banned_namepath_re');
        if (defined $result) {
          for my $e (@recip_tables) {
            if (!$e->{found}) {
              @$e{qw(found result matchk
                     part_descr_attr part_descr_trad part_name)} =
                (1, $result, $matchingkey,
                 $key_val_str, $key_val_trad_str, $simple_part_name);
            }
          }
        }
      }
      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_attr, $part_descr_trad, $part_name) =
          @$e{qw(r recip result matchk
                 part_descr_attr part_descr_trad 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 }xgse;
          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_trad);  $r->banned_parts($a);
          $a = $r->banned_parts_as_attr || [];
          push(@$a,$part_descr_attr);  $r->banned_parts_as_attr($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* \) /xgs;
          $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.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&mime_decode);
  import Amavis::Conf qw(:platform c cr ca $TEMPBASE $MAXFILES);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(snmp_count untaint ll do_log
                         safe_decode safe_decode_latin1
                         safe_encode safe_encode_utf8_inplace);
  import Amavis::Unpackers::NewFilename qw(consumed_bytes);
}
use subs @EXPORT_OK;

use Errno qw(ENOENT EACCES);
use IO::File qw(O_RDONLY O_WRONLY O_CREAT O_EXCL);
use MIME::Parser;
use MIME::Words;
use Digest::MD5;
use Digest::SHA;
# use Scalar::Util qw(tainted);

# 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: $!";
      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)
    # base64 encoding represents line-endings in a canonical CRLF form, so it
    # must be converted to a local representation for text parts when decoding;
    # RFC 2045 explicitly prohibits encoding CR and LF of a canonical CRLF pair
    # in quoted-printable encoding of textual parts, but some mail generating
    # software ignores this requirement, so we have to normalize line endings
    # (turn CRLF to \n) for both the base64 and the quoted-printable encodings
    my $encoding = $head->mime_encoding;
    my $normalize_line_endings =
      $mt =~ m{^(?:text|message)(?:/|\z)}i &&
      ($encoding eq 'base64' || $encoding eq 'quoted-printable');

    my $digest_ctx;  # body-part digester context object, or undef
    # choose a message digest: MD5: 128 bits, SHA family: 160..512 bits
    # Use SHA1 for SpamAssassin bayes compatibility!
    my $digest_algorithm = c('mail_part_digest_algorithm');
    if (defined $digest_algorithm) {
      $digest_ctx = uc $digest_algorithm eq 'MD5' ? Digest::MD5->new
                      : Digest::SHA->new($digest_algorithm);
    }
    my $size;
    my $fn = $body->path;
    if (!defined $fn) {
      # body part resides in memory only
      if (!$digest_ctx) {
        $size = length($body->as_string);
      } else {
        my $buff = $body->as_string;
        $size = length $buff;
        $buff =~ s{\015(?=\012|\z)}{}gs  if $normalize_line_endings;
        $digest_ctx->add($buff);
      }
    } else {
      # body part resides on a file
      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 _;
        if ($size == 0) {
          do_log(4,"mime_traverse: file %s is empty", $fn);
        } elsif ($digest_ctx) {
          my $fh = IO::File->new;
          $fh->open($fn,O_RDONLY)  # does a sysopen
            or die "Can't open file $fn for reading: $!";
          $fh->binmode or die "Can't set file $fn to binmode: $!";
          my($nbytes,$buff);
          while ($nbytes=sysread($fh,$buff,32768)) {
            $buff =~ s{\015(?=\012|\z)}{}gs  if $normalize_line_endings;
            $digest_ctx->add($buff);
          }
          defined $nbytes or die "Error reading file $fn: $!";
        }
      }
      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');
      }
      my $digest;
      if ($digest_ctx) {
        $digest = $digest_ctx->hexdigest;
        # store as a hex digest, followed by Content-Type
        $part->digest($digest . ':' . lc($mt||''));
      }
      if (ll(2)) {  # pretty logging
        my $filename = $head->recommended_filename;
        $encoding = 'QP'  if $encoding eq 'quoted-printable';
        do_log(2, "%s %s Content-Type: %s, %s, size: %d%s%s",
                  $part->base_name, $placement, $mt, $encoding, $size,
                  defined $digest ? ", $digest_algorithm digest: $digest" : '',
                  defined $filename ? ", name: $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}si ||
                                       $et =~ m{/.*encrypted}si;
    my %rn_seen;
    my @rn;  # recommended file names, both raw and RFC 2047 / RFC 2231 decoded
    for my $attr_name ('content-disposition.filename', 'content-type.name') {
      my $val_raw = $head->mime_attr($attr_name);
      next  if !defined $val_raw || $val_raw eq '';
      my $val_dec = '';  # decoded, represented as native Perl characters
      eval {
        my(@chunks) = MIME::Words::decode_mimewords($val_raw);
        for my $pair (@chunks) {
          my($data,$encoding) = @$pair;
          if (!defined $encoding || $encoding eq '') {
            $val_dec .= safe_decode_latin1($data);  # assumes ISO-8859-1
          } else {
            $encoding =~ s/\*[^*]*\z//s;  # strip RFC 2231 language suffix
            $val_dec .= safe_decode($encoding,$data);
          }
        }
        1;
      } or do {
        do_log(3, "mime_traverse: decoding MIME words failed: %s", $@);
      };
      if ($val_dec ne '' && !$rn_seen{$val_dec}) {
        push(@rn,$val_dec); $rn_seen{$val_dec} = 1;
      }
      if (!$rn_seen{$val_raw}) {
        push(@rn,$val_raw); $rn_seen{$val_raw} = 1;
      }
    }
    $part->name_declared(@rn==1 ? $rn[0] : \@rn)  if @rn;
    my $val = $head->mime_attr('content-type.report-type');
    safe_encode_utf8_inplace($val);
    $part->report_type($val)  if defined $val && $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($msg, $tempdir, $parent_obj) = @_;
  # $msg may be an open file handle, or a file name, or a string ref

  my $parser = MIME::Parser->new;
  # File::Temp->new defaults to /tmp or a current directory, ignoring TMPDIR
  $parser->tmp_dir($TEMPBASE)  if $parser->UNIVERSAL::can('tmp_dir');
  $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 or message/global
  $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 defined $MAXFILES && $MAXFILES > 0 &&
                                    $parser->UNIVERSAL::can('max_parts');
  snmp_count('OpsDecByMimeParser');
  my $entity;
  { local($1,$2,$3,$4,$5,$6);  # avoid Perl 5.8.* bug, $1 can get tainted !
    if (!defined $msg) {
      $entity = $parser->parse_data('');
    } elsif (!ref $msg) {  # assume $msg is a file name
      do_log(4, "Extracting mime components from file %s", $msg);
      $entity = $parser->parse_open("$tempdir/parts/$msg");
    } elsif (ref $msg eq 'SCALAR') {
      do_log(4, "Extracting mime components from a string");
      # parse_data() should be avoided with IO::File 1.09 or older:
      # it uses a mode '>:' to force a three-argument open(), but a mode
      # with a colon is only recognized starting with IO::File 1.10,
      # which comes with perl 5.8.1
      IO::File->VERSION(1.10);  # required minimal version
      $entity = $parser->parse_data($msg);  # takes a ref to a string
    } elsif (ref $msg) {  # assume an open file handle
      do_log(4, "Extracting mime components from a file");
      $msg->seek(0,0) or die "Can't rewind mail file: $!";
      $entity = $parser->parse($msg);
    }
  }
  my $mime_err;
  my(@mime_errors) = $parser->results->errors;  # a list!
  if (@mime_errors) {
  # $mime_err = $mime_errors[0];  # only show the first error
    $mime_err = join('; ',@mime_errors);  # show all errors
  }
  if (defined $mime_err) {
    $mime_err=~s/\s+\z//; $mime_err=~s/[ \t\r]*\n+/; /g; $mime_err=~s/\s+/ /g;
    substr($mime_err,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.412';
  @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) = @_;
  $self->close;  # ignoring status
  $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 };   #** One-argument "bless" warning
}

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;
  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.412';
  @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 sanitize_str min max minmax
                  untaint untaint_inplace
                  idn_to_ascii idn_to_utf8 mail_addr_idn_to_ascii
                  is_valid_utf_8 safe_decode_utf8
                  safe_encode safe_encode_utf8 safe_encode_utf8_inplace
                  orcpt_encode orcpt_decode xtext_decode safe_decode_mime
                  make_password ccat_split ccat_maj generate_mail_id);
  import Amavis::Timing qw(section_time);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::ProcControl qw(exit_status_str proc_status_ok
                                run_command collect_results);
  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 IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use MIME::Entity;
use Time::HiRes ();

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

# wrap a mail message into a ZIP archive
#
sub wrap_message_into_archive($$) {
  my($msginfo,$prefix_lines_ref) = @_;

  # a file with a copy of a mail msg as retrieved from a quarantine:
  my $attachment_email_name = c('attachment_email_name');  # 'msg-%m.eml'
  # an archive file (will contain a retrieved message) to be attached:
  my $attachment_outer_name = c('attachment_outer_name');  # 'msg-%m.zip'

  my($email_fh, $arch_size);
  my $mail_id = $msginfo->mail_id;
  if (!defined $mail_id || $mail_id eq '') {
    $mail_id = '';
  } else {
    $mail_id =~ /^[A-Za-z0-9_-]*\z/  or die "unsafe mail_id: $mail_id";
    untaint_inplace($mail_id);
  }
  for ($attachment_email_name, $attachment_outer_name) {
    local $1;
    s{%(.)}{  $1 eq 'b' ? $msginfo->body_digest
            : $1 eq 'P' ? $msginfo->partition_tag
            : $1 eq 'm' ? $mail_id
            : $1 eq 'n' ? $msginfo->log_id
            : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1)  #,'-')
            : $1 eq '%' ? '%' : '%'.$1 }gse;
    $_ = $msginfo->mail_tempdir . '/' . $_;
  }
  my $eval_stat;
  eval {
    # copy a retrieved message to a file
    $email_fh = IO::File->new;
    $email_fh->open($attachment_email_name, O_CREAT|O_EXCL|O_RDWR, 0640)
      or die "Can't create file $attachment_email_name: $!";
    binmode($email_fh,':bytes') or die "Can't cancel :utf8 mode: $!";
    for (@$prefix_lines_ref) {
      $email_fh->print($_)
        or die "Error writing to $attachment_email_name: $!";
    }
    my $msg = $msginfo->mail_text;
    my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
    $msg = $msg_str_ref  if ref $msg_str_ref;
    # copy quarantined mail starting at skip_bytes to $attachment_email_name
    my $file_position = $msginfo->skip_bytes;
    if (!defined $msg) {
      # empty mail
    } elsif (ref $msg eq 'SCALAR') {
      # do it in chunks, saves memory, cache friendly
      while ($file_position < length($$msg)) {
        $email_fh->print(substr($$msg,$file_position,16384))
          or die "Error writing to $attachment_email_name: $!";
        $file_position += 16384;  # may overshoot, no problem
      }
    } elsif ($msg->isa('MIME::Entity')) {
      die "wrapping a MIME::Entity object is not implemented";
    } else {
      $msg->seek($file_position,0) or die "Can't rewind mail file: $!";
      my($nbytes,$buff);
      while (($nbytes = $msg->read($buff,16384)) > 0) {
        $email_fh->print($buff)
          or die "Error writing to $attachment_email_name: $!";
      }
      defined $nbytes or die "Error reading mail file: $!";
      undef $buff;  # release storage
    }
    $email_fh->close or die "Can't close file $attachment_email_name: $!";
    undef $email_fh;

    # create a password-protected archive containing the just prepared file;
    # no need to shell-protect arguments, as this does not invoke a shell
    my $password = $msginfo->attachment_password;
    my(@command) = ( qw(zip -q -j -l),
                     $password eq '' ? () : ('-P', $password),
                     $attachment_outer_name, $attachment_email_name );
    # supplying a password on a command line is lame as it shows in ps(1),
    # but an option -e would require a pseudo terminal, which is really
    # an overweight cannon unnecessary here: the password is used as a
    # scrambler only, protecting against accidental opening of a file,
    # so there is no security issue here
    $password = 'X' x length($password);  # can't hurt to wipe out
    my($proc_fh,$pid) = run_command(undef,undef,@command);
    my($r,$status) = collect_results($proc_fh,$pid,'zip',16384,[0]);
    undef $proc_fh; undef $pid;
    do_log(2,'archiver said: %s',$$r)  if ref $r && $$r ne '';
    $status == 0 or die "Error creating an archive: $status, $$r";
    my $errn = lstat($attachment_outer_name) ? 0 : 0+$!;
    if ($errn) { die "Archive $attachment_outer_name is inaccessible: $!" }
    else { $arch_size = 0 + (-s _) }
    1;
  } or do {
    $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
  };
  if ($eval_stat ne '' || !$arch_size) {  # handle failure
    my $msg = $eval_stat ne '' ? $eval_stat
                               : sprintf("archive size %d", $arch_size);
    do_log(-1,'Preparing an archive from a quarantined message failed: %s',
              $msg);
    if (defined $email_fh && $email_fh->fileno) {
      $email_fh->close
        or do_log(-1,"Can't close %s: %s", $attachment_email_name, $!);
    }
    undef $email_fh;
    if (-e $attachment_email_name) {
      unlink($attachment_email_name)
        or do_log(-1,"Can't remove %s: %s", $attachment_email_name, $!);
    }
    if (-e $attachment_outer_name) {
      unlink($attachment_outer_name)
        or do_log(-1,"Can't remove %s: %s", $attachment_outer_name, $!);
    }
    die "Preparing an archive from a quarantined message failed: $msg\n";
  }
  $attachment_outer_name;
}

# 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, $msg_format, $flat,
     $attach_orig_headers, $attach_orig_message) = @_;

  $msg_format = ''  if !defined $msg_format;
  if (!defined $mime_type || $mime_type !~ m{^ multipart (?: / | \z)}xsi) {
    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 ($$mail_as_string_ref eq '') {
    $m_hdr = $m_body = '';
  } 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/xs
    my $ind = index($$mail_as_string_ref,"\n\n");  # find header/body separator
    if ($ind < 0) {  # no body
      $m_hdr = $$mail_as_string_ref; $m_body = '';
    } else {  # normal mail, 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);
    }
  }
  safe_encode_utf8_inplace($m_hdr);
  $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;
  $mime_type = 'multipart/mixed'  if !defined $mime_type;
  eval {
    # RFC 6522: 7bit should always be adequate for multipart/report encoding
    $entity = MIME::Entity->build(
      Type => $mime_type, Encoding => '8bit',
      'X-Mailer' => undef);
    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]*:[ \t]*(.*)\z/s) {
        my($fhead,$fbody) = ($1,$2);
        $fbody = safe_decode_mime($fbody);  # to logical characters
        # encode, wrap, ...
        my $str = hdr($fhead, $fbody, 0, ' ', $msginfo->smtputf8);
        # 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 {
      my $cnt_8bit = $m_body =~ tr/\x00-\x7F//c;
      eval {  # make sure _our_ source line number is reported on failure
        $entity->attach(
          Type => 'text/plain', Data => $m_body,
          Charset  => !$cnt_8bit ? 'us-ascii' : c('bdy_encoding'),
          Encoding => !$cnt_8bit ? '7bit'
                    : $cnt_8bit < 0.2 * length($m_body) ? 'quoted-printable'
                                                        : 'base64',
        );
        $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_headers && !$attach_orig_message) {
    # attach a header section only
    my $hdr_8bit =
      $msginfo->header_8bit || grep(tr/\x00-\x7F//c, @prefix_lines);
    my $hdr_utf8 = 1;
    if ($hdr_8bit) {
      for (@prefix_lines, @{$msginfo->orig_header}) {
        if (tr/\x00-\x7F//c && !is_valid_utf_8($_)) { $hdr_utf8 = 0; last }
      }
    }

    # RFC 6522 Encoding considerations for text/rfc822-headers:
    # 7-bit is sufficient for normal mail headers, however, if the
    # headers are broken or extended and require encoding to make them
    # legal 7-bit content, they MAY be encoded with quoted-printable
    # as defined in [MIME].

    # RFC 6532 section 3.5: allows newly defined MIME types to permit
    # content-transfer-encoding, and it allows content-transfer-encoding
    # for message/global.

    # RFC 6533: Note that [RFC6532] relaxed a restriction from MIME [RFC2046]
    # regarding the use of Content-Transfer-Encoding in new "message"
    # subtypes. This specification (RFC 6533) explicitly allows the use
    # of Content-Transfer-Encoding in message/global-headers and
    # message/global-delivery-status.

    my $headers_mime_type =
      $flat ? 'text/plain' :
      $hdr_8bit && $hdr_utf8 ? 'message/global-headers'  # RFC 6533
                             : 'text/rfc822-headers';    # RFC 6522

    # [rt.cpan.org #98737] MIME::Tools 5.505 prohibits quoted-printable
    # for message/global-headers. Fixed by a later release.
    # my $headers_mime_encoding =
    #   !$hdr_8bit ? '7bit' :
    #   $headers_mime_type =~ m{^text/}i || MIME::Entity->VERSION > 5.505
    #     ? 'quoted-printable' : '8bit';

    my $headers_mime_encoding = $hdr_8bit ? '8bit' : '7bit';

    ll(4) && do_log(4,"build_mime_entity: attaching original ".
                      "header section, MIME type: %s, encoding: %s",
                      $headers_mime_type, $headers_mime_encoding);

    # RFC 6533 section 6.3. Interoperability considerations:
    # It is important that message/global-headers media type is not
    # converted to a charset other than UTF-8.  As a result, implementations
    # MUST NOT include a charset parameter with this media type.

    eval {  # make sure _our_ source line number is reported on failure
      $entity->attach(
        Data => [@prefix_lines, @{$msginfo->orig_header}],
        Type     => $headers_mime_type,
        Encoding => $headers_mime_encoding,
        Filename => $headers_mime_type eq 'message/global-headers' ?
                      'header.u8hdr' : 'header.hdr',
        Disposition => 'inline',
        Description => 'Message header section',
      );
      $multipart_cnt++; 1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      die $eval_stat;
    };

  } elsif (defined $msginfo && $attach_orig_message) {
    # attach a complete message
    my $password;
    if ($msg_format eq 'attach') {   # not 'arf' and not 'dsn'
      $password = $msginfo->attachment_password;  # already have it?
      if (!defined $password) {  # make one, and store it for later
        $password = make_password(c('attachment_password'), $msginfo);
        $msginfo->attachment_password($password);
      }
    }
    if ($msg_format eq 'attach' &&   # not 'arf' and not 'dsn'
        defined $password && $password ne '') {
      # attach as a ZIP archive
      $password = 'X' x length($password);  # can't hurt to wipe out
      do_log(4, "build_mime_entity: attaching entire original message as zip");
      my $archive_fn = wrap_message_into_archive($msginfo,\@prefix_lines);
      local($1); $archive_fn =~ m{([^/]*)\z}; my $att_filename = $1;
      eval {  # make sure _our_ source line number is reported on failure
        my $att = $entity->attach(  # RFC 2046
          Type => 'application/zip', Filename => $att_filename,
          Path => $archive_fn, Encoding => 'base64',
          Disposition => 'attachment', Description => 'Original message',
        );
        $multipart_cnt++; 1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        die $eval_stat;
      };

    } else {
      # attach as a normal message
      do_log(4, "build_mime_entity: attaching entire original message, plain");
      my $orig_mail_as_body;
      my $msg = $msginfo->mail_text;
      my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
      $msg = $msg_str_ref  if ref $msg_str_ref;
      if (!defined $msg) {
        # empty mail
      } elsif (ref $msg eq 'SCALAR') {
        # will be handled by ->attach
      } elsif ($msg->isa('MIME::Entity')) {
        die "attaching a MIME::Entity object is not implemented";
      } else {
        $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 Amavis::MIME::Body object: $!";
      }

      # RFC 6532 section 3.7: Internationalized messages in message/global
      # format MUST only be transmitted as authorized by [RFC6531]
      # or within a non-SMTP environment that supports these messages.
      my $message_mime_type =
        $flat ? 'text/plain' :
        $msginfo->smtputf8 && $msginfo->header_8bit
          ? 'message/global'  # RFC 6532
          : 'message/rfc822';

      # [rt.cpan.org #98737] MIME::Tools 5.505 prohibits quoted-printable
      # for message/global. Fixed by a later release.
      my $message_mime_encoding =
        !$msginfo->header_8bit && !$msginfo->body_8bit ? '7bit' :
        $message_mime_type =~ m{^text/}i || MIME::Entity->VERSION > 5.505
          ? 'quoted-printable' : '8bit';

      eval {  # make sure _our_ source line number is reported on failure
        my $att = $entity->attach(  # RFC 2046, RFC 6532
          Type => $message_mime_type,
          Encoding => $message_mime_encoding,
          Data => defined $orig_mail_as_body ? []
                : !$msginfo->skip_bytes ? $msg
                : substr($$msg, $msginfo->skip_bytes),
        # Path => $msginfo->mail_text_fn,
          $flat ? () : (Disposition => 'attachment', Filename => 'message',
                        Description => 'Original message'),
          # RFC 6532: File extension ".u8msg" is suggested for message/global
        );
        # direct access to tempfile handle
        $att->bodyhandle($orig_mail_as_body)  if defined $orig_mail_as_body;
        $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 RFC 6522 (ex RFC 3462, RFC 1892), RFC 3464 (ex RFC 1894) and RFC 3461
# (ex RFC 1891).
# If $msg_format is 'arf' generate an abuse report according to RFC 5965
# - "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, dkim, fraud, miscategorized, not-spam,
#                   opt-out, virus, other
#
sub delivery_status_notification($$$;$$$$) {  # ..._or_report
  my($msginfo,$dsn_per_recip_capable,$builtins_ref,
     $notif_recips,$request_type,$feedback_type,$msg_format) = @_;
  my $notification; my $suppressed = 0;
  my $is_smtputf8 = $msginfo->smtputf8;  # UTF-8 allowed
  if (!defined($msg_format)) {
    $msg_format = $request_type eq 'dsn'    ? 'dsn'
                : $request_type eq 'report' ? c('report_format')
                                            : c('release_format');
  }
  my($is_arf,$is_dsn,$is_attach,$is_plain) = (0) x 4;
  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 !$dsn_time;  # now, if missing
  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 $per_recip_data = $msginfo->per_recip_data;
  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($min_spam_level, $max_spam_level) =
    minmax(map($_->spam_level, @{$msginfo->per_recip_data}));
  $min_spam_level = 0  if !defined $min_spam_level;
  $max_spam_level = 0  if !defined $max_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, $max_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>",
                $max_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 $txt_recip = '';  # per-recipient part of dsn text according to RFC 3464
  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 $spam_level = $r->spam_level;
    if (!$recip_done) {
      my $fwd_m = $r->delivery_method;
      if (!defined $fwd_m) {
        do_log(-2,"TROUBLE: recipient not done, undefined delivery_method: ".
                  "<%s> %s", $recip,$smtp_resp);
      } elsif ($fwd_m 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 relic 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, ".
              "destiny=%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, $dest, $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, not to 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, RFC 3461 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, suppress reason: %s, <%s> -> <%s>",
                $smtp_resp_code, $ccat_name, $r->dsn_suppress_reason,
                $sender,$recip);
    } elsif (defined $dsn_cutoff_level_bysender &&
             $spam_level >= $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, $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 >= $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, $dsn_cutoff_level,
                !$is_credible ? '' : ", (credible: $is_credible)",
                $sender, $recip);
    } elsif ($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 >=
               ($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, $sender,$recip);
    } else {
      # RFC 3461, 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) {
        # RFC 6533: systems generating a message/global-delivery-status
        # body part SHOULD use the utf-8-address form of the UTF-8 address
        # type for all addresses containing characters outside the ASCII
        # repertoire. These systems SHOULD upconvert the utf-8-addr-xtext
        # or the utf-8-addr-unitext form of a UTF-8 address type in the
        # ORCPT parameter to the utf-8-address form of a UTF-8 address type
        # in the "Original-Recipient:" field.
        my($addr_type, $addr) = orcpt_encode($dsn_orcpt, $is_smtputf8);
        $txt_recip .= "Original-Recipient: $addr_type;$addr\n";  # as octets
      }
      my $remote_mta = $r->recip_remote_mta;
      my $final_recip_encoded;
      { # normalize recipient address (like UTF-8 decoding)
        my($addr_type, $addr) = orcpt_decode(';'.quote_rfc2821_local($recip));
        ($addr_type, $addr) = orcpt_encode($addr_type.';'.$addr, $is_smtputf8);
        $final_recip_encoded = $addr_type.';'.$addr;
      }
      if (defined $dsn_orcpt || $remote_mta eq '' ||
          $r->recip_final_addr eq $recip) {
        $txt_recip .= "Final-Recipient: $final_recip_encoded\n";
      } else {
        $txt_recip .= "X-NextToLast-Final-Recipient: $final_recip_encoded\n";
        # normalize final recipient address (e.g. UTF-8 decoding)
        my($addr_type, $addr) =
          orcpt_decode(';'.quote_rfc2821_local($r->recip_final_addr));
        ($addr_type, $addr) = orcpt_encode($addr_type.';'.$addr, $is_smtputf8);
        $txt_recip .= "Final-Recipient: $addr_type;$addr\n";
      }
      my($smtp_resp_code, $smtp_resp_enhcode, $smtp_resp_msg);
      local($1,$2,$3);
      if ($smtp_resp =~ /^ (\d{3}) [ \t-] [ \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) {
        # a faked delivery to bit bucket or to a 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, $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 RFC 3461 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";
      # RFC 6533 adds optional field Localized-Diagnostic
      $txt_recip .= "Last-Attempt-Date: $rfc2822_dsn_time\n";
      my $final_log_id = $msginfo->log_id;
      $final_log_id .= '/' . $msginfo->mail_id  if defined $msginfo->mail_id;
      $txt_recip .= sprintf("Final-Log-ID: %s\n", $final_log_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, $sender, $recip);
    }
  }  # endfor per_recip_data

  # prepare a per-message part of a report
  my $txt_msg = '';
  my $myhost = c('myhostname');  # my FQDN (DNS) name, UTF-8 octets
  $myhost = $is_smtputf8 ? idn_to_utf8($myhost) : idn_to_ascii($myhost);
  my $dsn_envid = $msginfo->dsn_envid;  # ENVID is encoded as xtext: RFC 3461

  if ($is_dsn) {  # DSN - per-msg part of dsn text according to RFC 3464
    my $conn = $msginfo->conn_obj;
    my $from_mta = $conn->smtp_helo;
    my $client_ip = $conn->client_ip;
    $txt_msg .= "Reporting-MTA: dns; $myhost\n";
    $txt_msg .= "Received-From-MTA: dns; $from_mta ([$client_ip])\n"
      if $from_mta ne '';
    $txt_msg .= "Arrival-Date: ". rfc2822_timestamp($msginfo->rx_time) ."\n";
    my $dsn_envid = $msginfo->dsn_envid;  # ENVID is encoded as xtext: RFC 3461
    if (defined $dsn_envid) {
      $dsn_envid = sanitize_str(xtext_decode($dsn_envid));
      $txt_msg .= "Original-Envelope-Id: $dsn_envid\n";
    }

  } elsif ($is_arf) {  # abuse report format - RFC 5965
    # abuse, dkim, fraud, miscategorized, not-spam, opt-out, virus, other
    $txt_msg .= "Version: 1\n";                     # required
    $txt_msg .= "Feedback-Type: $feedback_type\n";  # required
    # User-Agent must comply with RFC 2616, section 14.43
    my $ua_version = "$myproduct_name/$myversion_id ($myversion_date)";
    $txt_msg .= "User-Agent: $ua_version\n";        # required
    $txt_msg .= "Reporting-MTA: dns; $myhost\n";
    # optional fields:

    # RFC 6692: Report generators that include an Arrival-Date report field
    # MAY choose to express the value of that date in Universal Coordinated
    # Time (UTC) to enable simpler correlation with local records at sites
    # that are following the provisions of RFC 6302.
    $txt_msg .= 'Arrival-Date: ';
    $txt_msg .= rfc2822_utc_timestamp($msginfo->rx_time) . "\n";
  # $txt_msg .= rfc2822_timestamp($msginfo->rx_time) . "\n";

    my $cl_ip_addr = $msginfo->client_addr;
    if (defined $cl_ip_addr) {
      $cl_ip_addr = 'IPv6:'.$cl_ip_addr  if $cl_ip_addr =~ /:[0-9a-f]*:/i &&
                                            $cl_ip_addr !~ /^IPv6:/i;
      $txt_msg .= "Source-IP: $cl_ip_addr\n";
    }
    # RFC 6692 (was: draft-kucherawy-marf-source-ports):
    my $cl_ip_port = $msginfo->client_port;
    $txt_msg .= "Source-Port: $cl_ip_port\n" if defined $cl_ip_port;
    my $dsn_envid = $msginfo->dsn_envid;  # ENVID is encoded as xtext: RFC 3461
    if (defined $dsn_envid) {
      $dsn_envid = sanitize_str(xtext_decode($dsn_envid));
      $txt_msg .= "Original-Envelope-Id: $dsn_envid\n";
    }
    $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";
    }
    my $sigs_ref = $msginfo->dkim_signatures_valid;
    if ($sigs_ref) {
      for my $sig (@$sigs_ref) {
        my $type = $sig->isa('Mail::DKIM::DkSignature') ? 'DK' : 'DKIM';
        $txt_msg .= sprintf("Reported-Domain: %s (valid %s signature by)\n",
                            $sig->domain, $type);
      }
    }
    if (c('enable_dkim_verification')) {
      for (Amavis::DKIM::generate_authentication_results($msginfo,0)) {
        my $h = $_;  $h =~ tr/\n//d;  # remove potential folding points
        $txt_msg .= "Authentication-Results: $h\n";
      }
    }
    $txt_msg .= "Incidents: 1\n";
    # Reported-URI
  }

  my($txt_8bit, $txt_utf8);
  my($delivery_status_mime_type, $delivery_status_mime_subtype);
  if ($is_dsn || $is_arf) {
    $txt_8bit = ($txt_msg=~tr/\x00-\x7F//c) + ($txt_recip=~tr/\x00-\x7F//c);
    $txt_utf8 = !$txt_8bit ||
                (is_valid_utf_8($txt_msg) && is_valid_utf_8($txt_recip));
    $delivery_status_mime_subtype =
        $is_arf ? 'feedback-report'
      : $txt_utf8 && ($is_smtputf8 || $txt_8bit) ? 'global-delivery-status'
                                                 : 'delivery-status';
    $delivery_status_mime_type = 'message/' . $delivery_status_mime_subtype;
  }

  if ( $is_arf || $is_plain || $is_attach ||
      ($is_dsn && ($any_succ || $any_fail || $any_delayed)) ) {
    my(@hdr_to) = $notif_recips ? qquote_rfc2821_local(@$notif_recips)
                                : map($_->recip_addr_smtp, @$per_recip_data);
    $_ = mail_addr_idn_to_ascii($_)  for @hdr_to;
    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') );
    # make sure it's in octets
    $hdr_from = expand_variables(safe_encode_utf8($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'} = safe_decode_utf8($hdr_from);
    $mybuiltins{'T'} = \@hdr_to;
    $mybuiltins{'d'} = $rfc2822_dsn_time;
    $mybuiltins{'report_format'} = $msg_format;
    $mybuiltins{'feedback_type'} = $feedback_type;

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

    # 'multipart/report' MIME type is defined in RFC 6522. The report-type
    # parameter identifies the type of report. The parameter is the MIME
    # subtype of the second body part of the multipart/report.
    my $report_entity = build_mime_entity($report_str_ref, $msginfo,
       !$is_dsn && !$is_arf ? 'multipart/mixed'
         : "multipart/report; report-type=$delivery_status_mime_subtype",
       $msg_format, $is_plain, 1, $attach_full_msg);

    my $head = $report_entity->head;
    # RFC 3464: 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 $@ };

    if ($is_dsn || $is_arf) {  # attach a delivery-status or a feedback-report
      ll(4) && do_log(4,"dsn: creating mime part %s, %s",
                        $delivery_status_mime_type,
                        !$txt_8bit ? 'us-ascii' : $txt_utf8 ? 'valid UTF-8'
                          : '8bit but *not* UTF-8');
      eval {  # make sure our source line number is reported in case of failure
        # RFC 6533: Note that [RFC6532] relaxed a restriction from MIME
        # [RFC2046] regarding the use of Content-Transfer-Encoding in new
        # "message" subtypes.  This specification explicitly allows the
        # use of Content-Transfer-Encoding in message/global-headers and
        # message/global-delivery-status.
        # RFC 5965: Encoding considerations for message/feedback-report:
        # "7bit" encoding is sufficient and MUST be used to maintain
        # readability when viewed by non-MIME mail readers.
        $report_entity->add_part(
          MIME::Entity->build(
            Top => 0,
            Type => $delivery_status_mime_type,
            Data => $txt_msg . $txt_recip,
            $delivery_status_mime_subtype ne 'global-delivery-status' ? ()
              : (Charset => 'UTF-8'),
            Encoding    => $txt_8bit ? '8bit' : '7bit',
            Disposition => 'inline',
            Filename    => $is_arf ? 'arf_status'
                         : $delivery_status_mime_subtype eq
                             'global-delivery-status' ? 'dsn_status.u8dsn'
                                                      : 'dsn_status.dsn',
            Description => $is_arf      ? "\u$feedback_type report"
                         : $any_fail    ? 'Delivery error report'
                         : $any_delayed ? 'Delivery delay report'
                         :                'Delivery report',
          ), 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
              : mail_addr_idn_to_ascii(
                  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->parent_mail_id($msginfo->mail_id);
    $notification->mail_id(scalar generate_mail_id());
    $notification->conn_obj($msginfo->conn_obj);
    $notification->originating(
      ($request_type eq 'dsn' || $request_type eq 'report') ? 1 : 0);
    $notification->mail_text($report_entity);
    $notification->body_type($txt_8bit ? '8BITMIME' : '7BIT');
    $notification->add_contents_category(CC_CLEAN,0);
    my(@recips) = $notif_recips ? @$notif_recips
                                : map($_->recip_addr, @$per_recip_data);
    if ($request_type eq 'dsn' || $request_type eq 'report') {
      my $bcc = $msginfo->setting_by_contents_category(cr('dsn_bcc_by_ccat'));
      push(@recips, $bcc)  if defined $bcc && $bcc ne '';
    }
    if (grep( / [^\x00-\x7F] .*? \@ [^@]* \z/sx && is_valid_utf_8($_),
              ($mailfrom, @recips) )) {
      # localpart is non-ASCII UTF-8, we must use SMTPUTF8
      do_log(2, 'DSN notification requires SMTPUTF8');
      $notification->smtputf8(1);
    } else {
      $_ = mail_addr_idn_to_ascii($_)  for ($mailfrom, @recips);
    }
    $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'));
    $notification->recips(\@recips, 1);
    if (defined $hdr_from) {
      my(@rfc2822_from) =
        map(unquote_rfc2821_local($_), parse_address_list($hdr_from));
      $notification->rfc2822_from($rfc2822_from[0]);
    }
    my $notif_m = c('notify_method');
    $_->delivery_method($notif_m)  for @{$notification->per_recip_data};
  }
  do_log(5, 'delivery_status_notification: notif %d bytes, suppressed: %s',
            length($notification), $suppressed ? 'yes' : 'no');
  # $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 = $_[0];
  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' or
# 'message/global'. Text in $first_part becomes the first MIME part
# of type 'text/plain', $first_part may be a scalar string or a ref
# to a list of lines
#
sub defanged_mime_entity($$) {
  my($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
    $new_entity = MIME::Entity->build(
                    Type => 'multipart/mixed', 'X-Mailer' => 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 RFC 822 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 \377
      $field_body =~ s{ ( [^\001-\014\016-\377] ) }
                      { sprintf(ord($1)>255 ? '\\x{%04x}' : '\\x{%02x}',
                                ord($1)) }xgse;
      # protect NL in illegal all-whitespace continuation lines
      $field_body =~ s{\n([ \t]*)(?=\n)}{\\012$1}gs;
      $field_body =~ s{^(.{995}).{4,}$}{$1...}gm;  # 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 {
    my $cnt_8bit = $first_part =~ tr/\x00-\x7F//c;
    $new_entity->attach(
      Type => 'text/plain', Data => $first_part,
      Charset => c('bdy_encoding'),
      Encoding => !$cnt_8bit ? '7bit'
                : $cnt_8bit > 0.2 * length($first_part) ? 'base64'
                : 'quoted-printable',
    );
    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;
  my $msg = $msginfo->mail_text;
  my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
  $msg = $msg_str_ref  if ref $msg_str_ref;
  if (!defined $msg) {
    # empty mail
  } elsif (ref $msg eq 'SCALAR') {
    # will be handled by ->attach
  } elsif ($msg->isa('MIME::Entity')) {
    die "attaching a MIME::Entity object is not implemented";
  } else {
    $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 Amavis::MIME::Body object: $!";
  }
  eval {
    my $att = $new_entity->attach(  # RFC 2046
      Type => ($msginfo->smtputf8 && $msginfo->header_8bit ? 'message/global'
                 : 'message/rfc822') . '; x-spam-type=original',
      Encoding => $msginfo->header_8bit || $msginfo->body_8bit ? '8bit':'7bit',
      Data => defined $orig_mail_as_body ? []
            : !$msginfo->skip_bytes ? $msg
            : substr($$msg, $msginfo->skip_bytes),
    # Path => $msginfo->mail_text_fn,
      Description => 'Original message',
      Filename => 'message', Disposition => 'attachment',
    );
    # direct access to tempfile handle
    $att->bodyhandle($orig_mail_as_body)  if defined $orig_mail_as_body;
    1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die $eval_stat;
  };
  $new_entity;
}

# Fill-in a message object with 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($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->parent_mail_id;
  $quarantine_id = ''  if !defined $quarantine_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 !defined $release_m || $release_m eq '';
    $release_m ne '' or die "release_method and notify_method are unspecified";
  }
  $msginfo->originating(1);  # (also enables DKIM signing)
  $msginfo->add_contents_category(CC_CLEAN,0);
  $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 an RFC 2442 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) {
        $sender = undef; @recips_all = (); @recips_blocked = (); $qid = undef;
      } elsif ( $bsmtp && /^QUIT$/i) { last;
      } elsif (!$bsmtp && /^Delivered-To:/si) {
      } elsif (!$bsmtp && /^(Return-Path|X-Envelope-From):[ \t]*(.*)$/si) {
        if (!defined $sender) {
          my(@addr_list) = parse_address_list($2);
          @addr_list >= 1  or die "Address missing in $1";
          @addr_list <= 1  or die "More than one address in $1";
          $sender =
            mail_addr_idn_to_ascii(unquote_rfc2821_local($addr_list[0]));
        }
      } elsif (!$bsmtp && /^X-Envelope-To:[ \t]*(.*)$/si) {
        my(@addr_list) = parse_address_list($1);
        push(@recips_all,
             map(mail_addr_idn_to_ascii(unquote_rfc2821_local($_)),
                 @addr_list));
      } elsif (!$bsmtp && /^X-Envelope-To-Blocked:[ \t]*(.*)$/si) {
        my(@addr_list) = parse_address_list($1);
        push(@recips_blocked,
             map(mail_addr_idn_to_ascii(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|OS-Fingerprint):/xsi) {
        # skip
      } elsif (!$reporting && /^(?:X-Spam|X-CRM114)-.+:/si) {
        # skip header fields inserted by us
      } else {
        last;  # end of known header fields, to be 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);
  $_->delivery_method($release_m)  for @{$msginfo->per_recip_data};
  # 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 eq 'resend') {
    if (!defined($recips_data_override)) {
      $msginfo->recips(\@recips_blocked);  # override 'all' by 'blocked' recips
    } 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);
    }
    $_->delivery_method($release_m)  for @{$msginfo->per_recip_data};
  } else {
    # 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, c('mail_digest_algorithm'));
    Amavis::collect_some_info($msginfo);
    if (defined($recips_data_override) && ll(5)) {
      do_log(5, 'overriding recips %s by %s',
                join(',', qquote_rfc2821_local(@recips_blocked)),
                join(',', map($_->recip_addr_smtp, @$recips_data_override)));
    }
    my($notification,$suppressed) = delivery_status_notification(
      $msginfo, 0, \%Amavis::builtins,
      !defined($recips_data_override) ? \@recips_blocked
        : [ map($_->recip_addr, @$recips_data_override) ],
      $request_type, $feedback_type, undef);
    # pushes 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 ($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'));
    # make sure it's in octets
    $hdrfrom_recip = expand_variables(safe_encode_utf8($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));
    my $myhost = c('myhostname');  # my FQDN (DNS) name, UTF-8 octets
    $myhost = $msginfo->smtputf8 ? idn_to_utf8($myhost) :idn_to_ascii($myhost);
    $hdr_edits->add_header('Resent-Message-ID',
               sprintf('<%s-%s@%s>',
                       $msginfo->parent_mail_id||'', $msginfo->mail_id||'',
                       $myhost) );
  }
  $hdr_edits->add_header('Received', make_received_header_field($msginfo,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;
    $recip_obj->recip_addr_modified($bcc);

    # leave recip_addr and recip_addr_smtp undefined to hide it from the log?
    $recip_obj->recip_addr($bcc);
    $recip_obj->recip_addr_smtp(qquote_rfc2821_local($bcc));  #****

    $recip_obj->recip_is_local(
      lookup2(0, $bcc, ca('local_domains_maps')) ? 1 : 0);
    $recip_obj->recip_destiny(D_PASS);
    $recip_obj->dsn_notify(['NEVER']);
    $recip_obj->delivery_method(c('notify_method'));
    $recip_obj->add_contents_category(CC_CLEAN,0);
    $msginfo->per_recip_data([@{$msginfo->per_recip_data}, $recip_obj]);
    do_log(2,"adding recipient - always_bcc: %s, delivery method %s",
             $bcc, $recip_obj->delivery_method);
  }
  $msginfo;
}

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

use strict;
use re 'taint';

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 regexp
require 5.008;     # need basic Unicode support
require 5.008001;  # need utf8::is_utf8()
use strict;
use re 'taint';

BEGIN {
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  import Amavis::Conf qw(:platform :sa :confvars c cr ca);
  import Amavis::Util qw(untaint untaint_inplace
                         min max minmax unique_list unique_ref
                         ll do_log do_log_safe update_current_log_level
                         dump_captured_log log_capture_enabled am_id
                         sanitize_str debug_oneshot proto_decode
                         truncate_utf_8 is_valid_utf_8 safe_decode_mime
                         safe_encode safe_encode_utf8 safe_encode_utf8_inplace
                         safe_decode safe_decode_utf8 safe_decode_latin1
                         clear_idn_cache idn_to_utf8 idn_to_ascii
                         mail_addr_idn_to_ascii mail_addr_decode
                         orcpt_encode orcpt_decode
                         format_time_interval add_entropy stir_random
                         generate_mail_id make_password
                         prolong_timer get_deadline 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);
  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
                         get_rusage rusage_report);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Lookup::IP qw(lookup_ip_acl normalize_ip_addr);
  import Amavis::Out;
  import Amavis::Out::EditHeader;
  import Amavis::UnmangleSender qw(oldest_public_ip_addr_from_received
                         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 EINVAL);
use POSIX qw(locale_h);
use Fcntl qw(:flock F_GETFL F_SETFL FD_CLOEXEC);
use IO::Handle;
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use IO::Socket::UNIX;
use Time::HiRes ();
# body digest, either MD5 or SHA-1 (or perhaps SHA-256)
use Digest::MD5;
use Digest::SHA;
use Net::Server 0.87;  # need Net::Server::PreForkSimple::done
use MIME::Base64;

use vars qw(
  $extra_code_zmq $extra_code_db $extra_code_redis
  $extra_code_sql_base $extra_code_sql_log $extra_code_sql_quar
  $extra_code_sql_lookup $extra_code_ldap
  $extra_code_in_ampdp $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 $maps_have_been_labeled);
use vars qw($db_env $snmp_db $zmq_obj @zmq_sockets);
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 $report_ref);
use vars qw($av_output @virusname @detecting_scanners @av_scanners_results
            $banned_filename_any $banned_filename_all @bad_headers);

# Amavis::In::AMPDP, Amavis::In::SMTP and In::Courier objects
use vars qw($ampdp_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_lookups $sql_wblist);  # Amavis::Lookup::SQL objects
use vars qw($ldap_connection);          # Amavis::LDAP::Connection object
use vars qw($ldap_lookups);             # Amavis::Lookup::LDAP object
use vars qw($redis_storage);            # Amavis::Redis object: penpals & repu
use vars qw($dns_resolver);             # a reusable Net::DNS::Resolver object
use vars qw($warm_restart);       # 1: warm (reload),  0: cold start (restart)
use vars qw(@public_networks_maps);

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
}

sub macro_rusage {
  my($msginfo,$recip_index,$name,$arg) = @_;
  my($rusage_self, $rusage_children) = get_rusage();
  !$rusage_self || !$rusage_children || !defined($rusage_self->{$arg}) ? ''
    : $rusage_self->{$arg} + $rusage_children->{$arg};
}

# implements macros: T, and SA lookalikes: TESTS, TESTSSCORES
#
sub macro_tests {
  my($msginfo,$recip_index,$name,$sep) = @_;
  my(@s);  my $per_recip_data = $msginfo->per_recip_data;
  if (defined $recip_index) {  # return info on one particular recipient
    my $r;
    $r = $per_recip_data->[$recip_index]  if $recip_index >= 0;
    if (defined $r) {
      my $spam_tests = $r->spam_tests;
      @s = split(/,/, join(',',map($$_,@$spam_tests)))  if $spam_tests;
    }
  } else {
    my(%all_spam_tests);
    for my $r (@$per_recip_data) {
      my $spam_tests = $r->spam_tests;
      if ($spam_tests) {
        $all_spam_tests{$_} = 1 for split(/,/,join(',',map($$_,@$spam_tests)));
      }
    }
    @s = sort keys %all_spam_tests;
  }
  if (@s > 50) { $#s = 50-1; push(@s,"...") }   # sanity limit
  @s = map { my($tn,$ts) = split(/=/,$_,2); $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 $per_recip_data = $msginfo->per_recip_data;
  my($result, $sl_min, $sl_max, $w); $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;
    $r = $per_recip_data->[$recip_index]  if $recip_index >= 0;
    $sl_min = $sl_max = $r->spam_level  if defined $r;
  } else {
    ($sl_min,$sl_max) = minmax(map($_->spam_level, @$per_recip_data));
  }
  if ($name eq 'STARS') {
    my $slc = $arg ne '' ? $arg : c('sa_spam_level_char');
    $result = !defined $slc || $slc eq '' || !defined $sl_min || $sl_min<1 ? ''
              : $slc x min(50, int $sl_min);
  } elsif (!defined $sl_min) {
    $result = '-';
# } elsif ($name eq 'SCORE' || abs($sl_min-$sl_max) < 0.1) {
  } elsif (abs($sl_min-$sl_max) < 0.1) {
    # users expect a single value, or not worth reporting a small difference
    $result = sprintf($fmt,$sl_min);  $result =~ s/\.?0*\z//;  # trim fraction
  } else {  # format SA score as min..max
    $sl_min = sprintf($fmt,$sl_min);  $sl_min =~ s/\.?0*\z//;
    $sl_max = sprintf($fmt,$sl_max);  $sl_max =~ s/\.?0*\z//;
    $result = $sl_min . '..' . $sl_max;
  }
  $result;
};

# implements macro 'header_field', providing a requested header field
# from a message; attempts decoding UTF-8 to logical characters
# unless a macro name is 'header_field_octets'; non-decodable UTF-8
# is left unchanged as octets
#
sub macro_header_field {
  my($msginfo,$name,$header_field_name,$limit,$hf_index) = @_;
  undef $hf_index  if $hf_index !~ /^[+-]?\d+\z/;  # defaults to last
  my $s = $msginfo->get_header_field_body($header_field_name, $hf_index);
  return undef  if !defined($s);
  # unfold, trim, protect any leftover CR and LF
  chomp($s); $s=~s/\n(?=[ \t])//gs; $s=~s/^[ \t]+//; $s=~s/[ \t\n]+\z//;
  if ($header_field_name =~
      /^(?:Message-ID|Resent-Message-ID|In-Reply-To|References)\z/i) {
    $s = join(' ',parse_message_id($s))  if $s ne '';  # strip CFWS
  }
  if ($name ne 'header_field_octets' &&
      $s =~ tr/\x00-\x7F//c && is_valid_utf_8($s)) {
    eval { $s = safe_decode_utf8($s, 1|8); 1 }
  }
  if (defined($limit) && $limit !~ /^\s+\z/ &&
      $limit > 5 && length($s) > $limit) {
    substr($s,$limit-5) = '';  $s .= '[...]';
  }
  $s =~ s{ ( [\r\n] ) }{ sprintf('\\x{%02X}',ord($1)) }xgse;
  $s;
};

sub dkim_test {
  my($name,$which) = @_;
  my $w = lc $which;
  my $sigs_ref = $MSGINFO->dkim_signatures_valid;
  $sigs_ref = []  if !$sigs_ref;
  $w eq 'any' || $w eq '' ? (!@$sigs_ref ? undef : scalar(@$sigs_ref))
: $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 'selector'  ? join(',', map($_->selector, @$sigs_ref))
: $w eq 'domain'    ? join(',', map($_->domain,   @$sigs_ref))
: $w eq 'sig_sd'    ? join(',', unique_list(map($_->selector.':'.$_->domain,
                                                @$sigs_ref)))
: $w eq 'newsig_sd' ? join(',', unique_list(map($_->selector.':'.$_->domain,
                                        @{$MSGINFO->dkim_signatures_new||[]})))
: dkim_acceptable_signing_domain($MSGINFO,$which);
}

sub dkim_acceptable_signing_domain($@) {
  my($msginfo,@acceptable_sdid) = @_;
  my $matches = 0;
  my $sigs_ref = $msginfo->dkim_signatures_valid;
  if ($sigs_ref && @$sigs_ref) {
    for my $sig (@$sigs_ref) {
      my $sdid_ace = idn_to_ascii($sig->domain);
      for (@acceptable_sdid) {
        my $ad = !defined $_ ? '' : $_;
        local($1);
        $ad = $1  if $ad =~ /\@([^\@]*)\z/;  # compatibility with pre-2.6.5
        if ($ad eq '') {  # checking for author domain signature
          $matches = 1  if $msginfo->dkim_author_sig;
        } elsif ($ad =~ /^\.(.*)\z/s) {  # domain itself or its subdomain
          my $d = idn_to_ascii($1);
          if ($sdid_ace eq $d || $sdid_ace =~ /\.\Q$d\E\z/s) {
            $matches = 1; last;
          }
        } else {
          if ($sdid_ace eq idn_to_ascii($ad)) { $matches = 1; last }
        }
      }
      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 an SMTP transaction):
    DATE => sub {rfc2822_timestamp($MSGINFO->rx_time)},
    d    => sub {rfc2822_timestamp($MSGINFO->rx_time)},  # RFC 5322 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)},
    weekday            => sub {iso8601_weekday($MSGINFO->rx_time)},
    y => sub {sprintf("%.0f", 1000*get_time_so_far())},  # elapsed time in ms
    h => sub { $MSGINFO->smtputf8
                 ? safe_decode_utf8(idn_to_utf8(c('myhostname')))
                 : idn_to_ascii(c('myhostname')) },
    HOSTNAME => sub {safe_decode_utf8(idn_to_utf8(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 {$MSGINFO->sender_smtp}, # kept for compatibility, avoid!
    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
    actions_performed => sub {join(',',@{$MSGINFO->actions_performed||[]})},
    Q => sub {$MSGINFO->queue_id},  # MTA queue ID of the message if known
    m => sub {my $m_id = $MSGINFO->get_header_field_body('message-id');
              defined $m_id ? (parse_message_id($m_id))[0] : undef },
    r => sub {my $m_id = $MSGINFO->get_header_field_body('resent-message-id');
              defined $m_id ? (parse_message_id($m_id))[0] : undef },
    j => sub {macro_header_field($MSGINFO,'header','Subject')},
    log_domains => sub {
      my %domains;
    # $domains{'ORIG'} = 1  if $MSGINFO->originating;
      for my $r (@{$MSGINFO->per_recip_data}) {
        if (!$r->recip_is_local) {
          $domains{'EXT'} = 1;
        } else {
          my($localpart,$domain) = split_address($r->recip_addr);
          $domain =~ s/^\@//;  $domains{lc($domain)} = 1;
        }
      }
      join(',', sort {$a cmp $b} keys %domains);
    },
    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))},
    header_field_octets => sub {macro_header_field($MSGINFO,@_)}, # as octets
    header_field => sub {macro_header_field($MSGINFO,@_)}, # as characters
    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 {  # somewhat expensive! #**
        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));
    },
    attachment_password => sub {
      my $password = $MSGINFO->attachment_password;  # already have it?
      if (!defined $password) {  # make one, and store it for later
        $password = make_password(c('attachment_password'), $MSGINFO);
        $MSGINFO->attachment_password($password);
      }
      $password;
    },
    b => sub {$MSGINFO->body_digest},  # original message body digest, hex enc
    body_digest => sub {  # original message body digest, raw bytes (binary!)
      my $bd = $MSGINFO->body_digest;  # hex digits, high nybble first
      !defined $bd ? '' : pack('H*',$bd);
    },
    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
    secret_id => sub {$MSGINFO->secret_id}, # mail_id's counterpart, base64url
    mail_id => sub {$MSGINFO->mail_id}, # synonym for %i, base64url (RFC 4648)
    parent_mail_id => sub {$MSGINFO->parent_mail_id},
    log_id => sub {$MSGINFO->log_id},   # synonym for %n
    MAILID => sub {$MSGINFO->mail_id},  # synonym for %i (no equivalent in SA)
    LOGID  => sub {$MSGINFO->log_id},   # synonym for %n (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;
               $q && [map { my $m=$_; $m=~s{^\Q$QUARANTINEDIR\E/}{}; $m } @$q];
             },  # list of quarantine mailboxes
    v => sub { !defined $av_output ? undef     # anti-virus scanner output
                 : [split(/[ \t]*\r?\n/, $av_output)]},
    V => sub { my $vn = $MSGINFO->virusnames;  # unique virus names
               $vn && unique_ref($vn) },
    W => sub { my($name,@args) = @_;  # detecting scanners & their virus names
               # with no args: return a list of av scanners detecting a virus
               return \@detecting_scanners  if !@args;
               # otherwise provide a per-scanner report of virus names found
               join('; ', map { my($av, $status, @virus_names) = @$_;
                                my $scanner_name = $av && $av->[0];
                                for ($scanner_name) {  # aliasing to $_
                                  if (!/^[^:" \t]+\z/)
                                    { tr/"/'/;  $_ = '"'.$_.'"' }
                                }
                                $scanner_name . ':' .
                                  (!$status ? '-'
                                            : '['.join(',',@virus_names).']');
                              } @av_scanners_results);
             },
    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 },
    banned_parts_as_attr => sub {  # list of banned parts with their full paths
               my $b = unique_ref(map(@{$_->banned_parts_as_attr},
                 grep(defined($_->banned_parts_as_attr),
                      @{$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},
    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 RFC 1870, or approx
    ip_trace_all => sub {  # all IP addresses in the Received trace, top-down
               my $trace = $MSGINFO->trace; return if !$trace;
               [ map(defined $_ ? sanitize_str($_) : 'x',
                     map($_->{ip}, @$trace)) ];
             },
    ip_trace_public => sub {  # all public IP addresses in the Received trace
               my $ip_trace = $MSGINFO->ip_addr_trace_public;
               return if !$ip_trace;
               [ map(defined $_ ? sanitize_str($_) : 'x',  @$ip_trace) ];
             },
    ip_proto_trace_all => sub {  # from a Received trace
               # protocol type from the WITH clause and an IP address
               my $trace_ref = $MSGINFO->trace; return if !$trace_ref;
               my(@trace) = @$trace_ref;
               shift(@trace);  # chop off the last hop (MTA -> amavisd)
               [ map(sanitize_str( (!$_->{with} ? '' : $_->{with}.'://') .
                                   (!$_->{ip} ? 'x' : !$_->{port} ? $_->{ip}
                                     : '['.$_->{ip}.']:'.$_->{port})),@trace)];
             },
    ip_proto_trace_public => sub {  # from a Received trace
               # protocol type from the WITH clause and an IP address
               my $trace_ref = $MSGINFO->trace; return if !$trace_ref;
               my(@trace) = @$trace_ref;
               shift(@trace);  # chop off the last hop (MTA -> amavisd)
               [ map(sanitize_str( (!$_->{with} ? '' : $_->{with}.'://') .
                                   (!$_->{ip} ? 'x' : !$_->{port} ? $_->{ip}
                                     : '['.$_->{ip}.']:'.$_->{port}) ),
                     grep($_->{public}, @trace)) ];
             },
    protocol =>  # "WITH protocol type" as seen by amavisd (the last hop)
      sub { my $c = $MSGINFO->conn_obj; !$c ? '' : $c->appl_proto },
    t => sub { # first (oldest) entry in the Received trace
               sanitize_str(first_received_from($MSGINFO)) },
    e => sub { # first (oldest) valid public IP in the Received trace,
               # same as the last entry in ip_trace_public
               sanitize_str(oldest_public_ip_addr_from_received($MSGINFO)) },
    a => sub { $MSGINFO->client_addr }, # original SMTP session client IP addr
    client_addr => sub { $MSGINFO->client_addr },  # synonym with 'a'
    client_port => sub { $MSGINFO->client_port },
    client_addr_port => sub { # original SMTP session client IP addr & port no.
      my($a,$p) = ($MSGINFO->client_addr, $MSGINFO->client_port);
      !defined $a || $a eq '' ? undef : ('[' . $a . ']' . ($p ? ":$p" : ''));
    },
    g => sub { # original SMTP session client DNS name
               sanitize_str($MSGINFO->client_name) },
    client_helo => sub { # original SMTP session EHLO/HELO name
                         sanitize_str($MSGINFO->client_helo) },
    client_protocol => sub { $MSGINFO->client_proto }, # XFORWARD PROTO, AM.PDP
    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 came 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' },
    AUTOLEARN       => sub {$MSGINFO->supplementary_info('AUTOLEARN')},
    ADDEDHEADERHAM  => sub {$MSGINFO->supplementary_info('ADDEDHEADERHAM')},
    ADDEDHEADERSPAM => sub {$MSGINFO->supplementary_info('ADDEDHEADERSPAM')},
    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);
                },
    rusage => sub { macro_rusage($MSGINFO,undef,@_) }, # resource usage
    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 { my($arg_spam, $arg_ham) = @_;  # like %2, but gives: Yes/No
                   grep($_->is_in_contents_category(CC_SPAMMY),
                        @{$MSGINFO->per_recip_data})
                     ? (defined $arg_spam ? $arg_spam : 'Yes')
                     : (defined $arg_ham  ? $arg_ham  : 'No') },
    YESNOCAPS =>
             sub { my($arg_spam, $arg_ham) = @_;  # like %2, but gives: YES/NO
                   grep($_->is_in_contents_category(CC_SPAMMY),
                        @{$MSGINFO->per_recip_data})
                     ? (defined $arg_spam ? $arg_spam : 'YES')
                     : (defined $arg_ham  ? $arg_ham  : '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 => 0,  # legacy
    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 { my $s=$_; $s=~s{"}{""}g; '"'.$s.'"' } @_)},
    uquote => sub {my $nm=shift;
                   join('', map { my $s=$_; $s=~s{[ \t]+}{_}g; $s     } @_)},
    rot13  => sub {my($name,$s) = @_;  # obfuscation (Caesar cipher)
                   $s=~tr/a-zA-Z/n-za-mN-ZA-M/; $s },
    hexenc    => sub {my $nm=shift; join('',  map(unpack('H*',$_), @_))},
    b64encode => sub {my $nm=shift; join(' ', map(encode_base64($_,''),@_))},
    b64enc    => sub {my $nm=shift;  # preferred over b64encode
                      join('', map { my $s=encode_base64($_,'');
                                     $s=~s/=+\z//; $s } @_)},
    b64urlenc => sub {my $nm=shift;
                      join('', map { my $s=encode_base64($_,'');
                                     $s=~s/=+\z//; $s=~tr{+/}{-_}; $s } @_)},
    mail_addr_decode => sub {my($nm,$addr) = @_; mail_addr_decode($addr,0)},
    mail_addr_decode_octets =>
                        sub {my($nm,$addr) = @_; mail_addr_decode($addr,1)},
    mime_decode => sub {
      # convert RFC 2047 encoded-words or UTF-8 octets to logical characters,
      # truncate to $max_len characters if limit is provded
      my($nm,$str,$max_len,$both_if_diff) = @_;
      return '' if  !defined $str || $str eq '';
      my $chars = safe_decode_mime($str);  # octets to logical characters
      if (!defined $max_len || $max_len <= 0) {  # no size limit
        return $chars  if !$both_if_diff;
        $chars .= ' (raw: ' . $str . ')'  if $chars ne $str;
      } else {  # truncate characters string at $max_len
        substr($chars,$max_len) = '' if length($chars) > $max_len;
        return $chars  if !$both_if_diff;
        # only compare the visible part
        my $octets = safe_encode_utf8($chars);
        substr($str,length($octets)) = '' if length($str) > length($octets);
        $chars .= ' (raw: ' . $str . ')'  if $str ne $chars;
      }
      $chars;
    },
    mime2utf8 => sub {
      # convert RFC 2047 encoded-words or UTF-8 to UTF-8 octets,
      # truncate to $max_len characters if limit is provded
      my($nm,$str,$max_len,$both_if_diff) = @_;
      return '' if !defined $str || $str eq '';
      my $chars  = safe_decode_mime($str);    # to logical characters
      my $octets = safe_encode_utf8($chars);  # to bytes, UTF-8 encoded
      $octets = truncate_utf_8($octets,$max_len);
      return $octets  if !$both_if_diff;
      # only compare the visible part
      if (defined $max_len && $max_len > 0 && length($str) > $max_len) {
        substr($str,$max_len) = '';
      }
      $str = $octets . ' (raw: ' . $str . ')'  if $octets ne $str;
      $str;
    },
    report_json => sub {
      return if !$report_ref;  # ugly globals
      structured_report_update_time($report_ref);
      return Amavis::JSON::encode($report_ref);  # as a string of characters
    },
    report_json => sub {
      return if !$report_ref;  # ugly globals
      structured_report_update_time($report_ref);
      my $macro_name = shift;
      if (!@_) {  # all fields, no filtering
        return Amavis::JSON::encode($report_ref);  # as a string of characters
      } else {  # filtering by field names
        my @keys = @_ == 1 ? split(' ',$_[0]) : @_;   # whitespace-separated?
        my(@negated_keys) = map(/^!(.*)\z/s ? $1 : (), @keys);
        my %filtered;
        if (@negated_keys) {  # take all but negated fields
          %filtered = %$report_ref;
          delete @filtered{@negated_keys};
        } else {  # take only listed fields
          %filtered =
            map(exists $report_ref->{$_} ? ($_,$report_ref->{$_}) : (), @keys);
        }
        return Amavis::JSON::encode(\%filtered);  # as a string of characters
      }
    },
    # 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) },
    'unchecked-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;
            substr($s,100) = '...'  if length($s) > 100+3;
            $s =~ tr/a-zA-Z0-9@._+-/=/c; $s =~ s/\@/_at_/g;
            untaint_inplace($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_lookups,'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;
#         untaint_inplace($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';
      if (defined $s) {
        # encode log templates to UTF-8, leave the rest as character strings
        safe_encode_utf8_inplace($s) if $n eq 'log_templ' || 'log_recip_templ';
        $policy_bank{$bank_name}{$n} = tokenize(\$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 an IP lookup table
      $policy_bank{$bank_name}{'inet_acl'} = Amavis::Lookup::IP->new(@$r);
    }
    $r = $policy_bank{$bank_name}{'ip_repu_ignore_maps'};  # listref of tables
    if (ref($r) eq 'ARRAY') {  # should be an array, test just to make sure
      for my $table (@$r) {  # replace plain lists with pre-parsed objects
        $table = Amavis::Lookup::IP->new(@$table)  if ref($table) eq 'ARRAY';
      }
    }
    $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 pre-parsed objects
        $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 ($euid == 0) {
    @msg = ('Running as EUID 0 (root), ABORTING!',
            'Please start as non-root, e.g. by su(1) or using option -u user,',
            'or configure the $daemon_user setting.');
  } elsif ($> == 0) {   # succeeded? panic!
    @msg = ("It is possible to change EUID from $euid to root, ABORTING!",
            'Please start as non-root, e.g. by su(1) or using option -u user,',
            'or configure the $daemon_user setting.');
  } 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 ($i_know_what_i_am_doing{no_conf_file_writable_check}) {
        # skip checking
      } 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 { my $s = $_; $s =~ s/\.pm\z//; $s =~ s{/}{::}g; $s }
               grep(/\.pm\z/, keys %INC)) {
    next  if !grep($_ eq $m, qw(Amavis::Conf
      Archive::Tar Archive::Zip Compress::Zlib Compress::Raw::Zlib
      Convert::TNEF Convert::UUlib File::LibMagic
      MIME::Entity MIME::Parser MIME::Tools Mail::Header Mail::Internet
      Digest::MD5 Digest::SHA Digest::SHA1 Crypt::OpenSSL::RSA
      Authen::SASL Authen::SASL::XS Authen::SASL::Cyrus Authen::SASL::Perl
      Encode Scalar::Util Time::HiRes File::Temp Unix::Syslog Unix::Getrusage
      Socket Socket6 IO::Socket::INET6 IO::Socket::IP IO::Socket::SSL
      Net::Server NetAddr::IP Net::DNS Net::LibIDN Net::SSLeay Net::Patricia
      Net::LDAP Mail::SpamAssassin Mail::DKIM::Verifier Mail::DKIM::Signer
      Mail::ClamAV Mail::SPF Mail::SPF::Query URI Razor2::Client::Version
      DBI DBD::mysql DBD::Pg DBD::SQLite BerkeleyDB DB_File
      ZMQ ZMQ::LibZMQ2 ZMQ::LibZMQ3 ZeroMQ SAVI Anomy::Sanitizer));
    do_log(1, "Module %-19s %s", $m, eval{$m->VERSION} || '?');
  }
  do_log(1,"Amavis::ZMQ code    %s loaded", $extra_code_zmq        ?'':" NOT");
  do_log(1,"Amavis::DB code     %s loaded", $extra_code_db         ?'':" NOT");
  do_log(1,"SQL base code       %s loaded", $extra_code_sql_base   ?'':" NOT");
  do_log(1,"SQL::Log code       %s loaded", $extra_code_sql_log    ?'':" NOT");
  do_log(1,"SQL::Quarantine     %s loaded", $extra_code_sql_quar   ?'':" NOT");
  do_log(1,"Lookup::SQL code    %s loaded", $extra_code_sql_lookup ?'':" NOT");
  do_log(1,"Lookup::LDAP code   %s loaded", $extra_code_ldap       ?'':" NOT");
  do_log(1,"AM.PDP-in proto code%s loaded", $extra_code_in_ampdp   ?'':" NOT");
  do_log(1,"SMTP-in proto code  %s loaded", $extra_code_in_smtp    ?'':" NOT");
  do_log(1,"Courier proto code  %s loaded", $extra_code_in_courier ?'':" NOT");
  do_log(1,"SMTP-out proto code %s loaded", $extra_code_out_smtp   ?'':" NOT");
  do_log(1,"Pipe-out proto code %s loaded", $extra_code_out_pipe   ?'':" NOT");
  do_log(1,"BSMTP-out proto code%s loaded", $extra_code_out_bsmtp  ?'':" NOT");
  do_log(1,"Local-out proto code%s loaded", $extra_code_out_local  ?'':" NOT");
  do_log(1,"OS_Fingerprint code %s loaded", $extra_code_p0f        ?'':" NOT");
  do_log(1,"ANTI-VIRUS code     %s loaded", $extra_code_antivirus  ?'':" NOT");
  do_log(1,"ANTI-SPAM code      %s loaded", $extra_code_antispam   ?'':" NOT");
  do_log(1,"ANTI-SPAM-EXT code  %s loaded",
                                      $extra_code_antispam_extprog ?'':" NOT");
  do_log(1,"ANTI-SPAM-C code    %s loaded",
                                      $extra_code_antispam_spamc   ?'':" NOT");
  do_log(1,"ANTI-SPAM-SA code   %s loaded", $extra_code_antispam_sa?'':" NOT");
  do_log(1,"Unpackers code      %s loaded", $extra_code_unpackers  ?'':" NOT");
  do_log(1,"DKIM code           %s loaded", $extra_code_dkim       ?'':" NOT");
  do_log(1,"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, $msginfo) = @_;
  if (!defined $policy_bank_name) {
    # silently ignore
  } elsif (!exists $policy_bank{$policy_bank_name}) {
    do_log(5,'policy bank "%s" does not exist, ignored', $policy_bank_name);
  } elsif ($policy_bank_name eq '') {  # special case
    %current_policy_bank = %{$policy_bank{$policy_bank_name}};  # copy base
    update_current_log_level();
    do_log(4,'loaded base policy bank');
  } elsif ($policy_bank_name eq c('policy_bank_name')) {
    do_log(5,'policy bank "%s" just loaded, ignored', $policy_bank_name);
  } else {
    # compatibility: policy bank MYNETS implicitly pre-sets 'originating' flag
    $current_policy_bank{'originating'} = 1  if $policy_bank_name eq 'MYNETS';
    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) {
      if ($k eq 'ACTION') {
        if (ref $new_bank_ref->{$k} eq 'CODE') {
          do_log(5,'invoking user ACTION on loading a policy bank %s',
                   $policy_bank_name);
          eval {
            # $msginfo may be undef when a policy bank load takes place early
            &{$new_bank_ref->{$k}}($msginfo,$policy_bank_name); 1;
          } or do {
            my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
            do_log(-1,'failed ACTION on loading a policy bank %s: %s',
                      $policy_bank_name, $eval_stat);
          };
        }
      } elsif (!exists $current_policy_bank{$k}) {
        do_log(-1,'loading policy bank "%s": unknown field "%s"',
                  $policy_bank_name,$k);
      } elsif (ref($new_bank_ref->{$k}) ne 'HASH' ||
          ref($current_policy_bank{$k}) ne 'HASH') {
        $current_policy_bank{$k} = $new_bank_ref->{$k};
      # do_log(5,'loading policy bank %s, curr{%s} replaced by %s',
      #           $policy_bank_name, $k, $current_policy_bank{$k}) if $do_log5;
      } else {  # new hash to be merged into or replacing an existing hash
        if ($new_bank_ref->{$k}{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
          while (my($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;
    ll(3) && do_log(3,'loaded policy bank "%s"%s', $policy_bank_name,
                      $cpbp eq '' ? '' : " over \"$cpbp\"");
    # update global settings which may have changed
    update_current_log_level();
    $msginfo->originating(c('originating')) if $msginfo;
  }
}

# systemd notifier
#
sub sd_notify($@) {
# my($unset_environment, @messages) = @_;
  my $unset_environment = shift;
  my $result;  # undef=failure, 0=nothing to do, 1=success
  my $socket_name = $ENV{NOTIFY_SOCKET};
  if (!@_) {  # no messages
    $result = 0;
  } elsif (!defined $socket_name || $socket_name eq '') {
    $result = 0;
    ll(2) && do_log(2, "sd_notify (no socket): %s", join("\n",@_));
  } elsif ($socket_name !~ m{^[/@].}s) {
    # must be an absolute path or an abstract socket
    do_log(0, "sd_notify: NOTIFY_SOCKET env.var '%s' must be ".
              "an absolute path or an abstract socket", $socket_name);
    $! = EINVAL;
  } else {
    ll(1) && do_log(1, "sd_notify (%s): %s", $socket_name, join("\n",@_));
    $socket_name =~ s{^\@}{\x{00}}s;  # abstract socket (Linux specific)
    eval {
      my $sock = IO::Socket::UNIX->new(Type => SOCK_DGRAM);
      $sock or die "Can't create a socket object of type AF_LOCAL: $!";
      # should also send credentials, e.g. using IO::Handle::Record module
      #  FreeBSD: struct cmsgcred; send a SCM_CREDS message
      #  OpenBSD: struct sockpeercred; SO_PASSCRED
      #  Linux: struct ucred; send a SCM_CREDENTIALS msg; SO_PEERCRED; unix(7)
      $sock->connect( pack_sockaddr_un(untaint($socket_name)) )
        or die "Can't connect to NOTIFY_SOCKET $socket_name: $!";
      defined $sock->send(join("\n",@_), MSG_NOSIGNAL)
        or die "Error sending to NOTIFY_SOCKET $socket_name: $!";
      $sock->close or die "Error closing NOTIFY_SOCKET: $!";
      $result = 1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(-1, "sd_notify: %s", $eval_stat);
    };
  }
  undef $ENV{NOTIFY_SOCKET}  if $unset_environment;
  $result;
}

sub sd_notifyf($$;@) {
  my($unset_environment, $message, @args) = @_;
  sd_notify($unset_environment, @args ? sprintf($message,@args) : $message);
}

### 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 {
  if ($warm_restart) {
    sd_notify(0, "STATUS=Preparing to re-bind sockets.");
  } elsif (!$daemonize) {
    sd_notify(0, "STATUS=Preparing to bind sockets.");
  } else {
    sd_notify(0, "MAINPID=$$","STATUS=Daemonized, preparing to bind sockets.");
  }
# umask(0007);  # affects protection of Unix sockets created by Net::Server
}

sub set_sockets_access() {
  if (defined $unix_socket_mode && $unix_socket_mode ne '') {
    for my $s (@listen_sockets) {
      local($1);
      if ($s =~ m{^(/.+)\|unix\z}si) {
        my $path = $1;
        chmod($unix_socket_mode,$path)
          or do_log(-1, "Error setting mode 0%03o on a socket %s: %s",
                        $unix_socket_mode, $path, $!);
      }
    }
  }
}

### 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
  set_sockets_access()  if defined $warm_restart && !$warm_restart;
  sd_notify(0, "STATUS=Sockets bound, checking user and group.");
}

### Net::Server hook
### This hook occurs in the parent (master) process after chroot,
### after change of user, and change of group has occurred.
### It allows for preparation before forking and looping begins.
#
sub pre_loop_hook {
  my $self = $_[0];
  local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered pre_loop_hook");
  eval {
    sd_notify(0, "STATUS=The rest of pre-fork init, finding helper programs.");
    after_chroot_init();  # the rest of the top-level initialization

    # this needs to be done 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_db && $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, !$warm_restart);
    }
    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 KiB, 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;
    }
    if (!grep { my $v = $policy_bank{$_}{'enable_dkim_verification'};
                defined(!ref $v ? $v : $$v) } keys %policy_bank)
    { 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 mute this warning.');
    }
    # systemd, Type=notify
    sd_notify(0, "READY=1", "STATUS=Initialization done.");
    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);
    sd_notify(0, "STOPPING=1", "STATUS=$msg");
    die("Suicide (" . am_id() . ") " . $msg . "\n");
  };
  1;
}

# (!)_DIE: Unable to create sub named "" at /usr/local/sbin/amavisd line 9947.
# The line 9947 was in sub write_to_log_hook: local $SIG{CHLD} = 'DEFAULT';
# perl #60360: local $SIG{FOO} = sub {...}; sets signal handler to SIG_DFL
# # http://www.perlmonks.org/?node_id=721692
# # non-atomic, clears to SIG_DFL, then sets: local $SIG{ALRM} = sub {...};
# use Sub::ScopeFinalizer qw( scope_finalizer );
# my $sentry = local_sassign $SIG{ALRM}, \&alarm_handler;
# sub local_sassign {
#   my $r = \($_[0]);
#   my $sentry = scope_finalizer { $$r = $_[0] } { args => [ $$r ] };
#   $$r = $_[1]; return $sentry;
# }
# or use:
#   use POSIX qw(:signal_h) ;
#   my $sigset   = POSIX::SigSet->new ;
#   my $blockset = POSIX::SigSet->new( SIGALRM ) ;
#   sigprocmask(SIG_BLOCK, $blockset, $sigset );
#   local $SIG{ALRM} = sub .... ;
#   sigprocmask(SIG_SETMASK, $sigset );

### 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 accustomed 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),
### This hook occurs in the master process at the top of run_n_children
### which is called each time the server goes to start more child processes.
#
sub run_n_children_hook {
# do_log(5, "entered run_n_children_hook");
  sd_notify(0, "STATUS=Starting child process(es), ready for work.");
  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 = $_[0]; $self->run_n_children_hook }

### user customizable Net::Server hook,
### run by every child process during its startup
#
sub child_init_hook {
  my $self = $_[0];
  local $SIG{CHLD} = 'DEFAULT';
  $child_init_hook_was_called = 1;
  do_log(5, "entered child_init_hook");
  $my_pid = $$;  $0 = c('myprogram_name') . ' (virgin child)';
# DB::enable_profile(sprintf("/tmp/nytprof-amavis-%s-%d.out",
#                            $my_pid, int rand 1000000)) if $profiling;
  stir_random();
  log_capture_enabled(1)  if $enable_log_capture;
  # reset log counters inherited from a master process
  collect_log_stats();
# 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($my_pid,$s) };
# @SIG{@signames} = ($h) x @signames;
  my $inherited_entropy;
  eval {
#   if (defined $daemon_user && $daemon_user ne '' && ($> == 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);
#   }
    undef $db_env; undef $snmp_db;  # just in case
    Amavis::Timing::init(); snmp_counters_init();
    close_log(); open_log();  # reopen syslog or log file to get per-process fd
    if ($enable_zmq && $extra_code_zmq && @zmq_sockets) {
      do_log(5, "child_init_hook: zmq socket: %s", join(', ',@zmq_sockets));
      $zmq_obj = Amavis::ZMQ->new(@zmq_sockets);
      if ($zmq_obj) {
        sleep 1;  # a crude way to avoid a "slow joiner" syndrome  #***
        $zmq_obj->register_proc(0,1,'');
      }
    }
    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 $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 ($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");
      }
    }
    # create 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_lookups = Amavis::Lookup::SQL->new($sql_dataset_conn_lookups,
                                   'sel_policy')  if $sql_dataset_conn_lookups;
    $sql_wblist = Amavis::Lookup::SQL->new($sql_dataset_conn_lookups,
                                   'sel_wblist')  if $sql_dataset_conn_lookups;

    if ($extra_code_redis && @storage_redis_dsn) {
      $redis_storage = Amavis::Redis->new(@storage_redis_dsn);
    }
    $spamcontrol_obj->init_child  if $spamcontrol_obj;
  # Amavis::Util::dump_subs();
    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($inherited_entropy, Time::HiRes::gettimeofday, rand());
  Amavis::Timing::go_idle('vir');
# DB::disable_profile() if $profiling;
}

### user customizable Net::Server hook
#
sub post_accept_hook {
  my $self = $_[0];
  local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered post_accept_hook");
  DB::enable_profile(sprintf("/tmp/nytprof-amavis-%s-%d.out",
                             $my_pid, int rand 1000000)) if $profiling;
  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("%s (ch%d-accept)",
               c('myprogram_name'), $child_invocation_count);
  Amavis::Util::am_id(undef);
  Amavis::Timing::go_busy('hi ');
  # establish initial time right after 'accept'
  Amavis::Timing::init(); snmp_counters_init();
  $zmq_obj->register_proc(1,1,'A')  if $zmq_obj;  # enter 'accept' state
  $snmp_db->register_proc(1,1,'A')  if $snmp_db;
  if ($child_invocation_count % 13 == 0)  # every now and then
    { clear_idn_cache(); clear_query_keys_cache() }
  load_policy_bank('');    # start with a builtin baseline policy bank
}

# load policy banks according to my socket (destination),
# then check for allowed access from the peer (client/source)
#
sub access_is_allowed($;$$$$) {
  my($unix_socket_path, $src_addr, $src_port, $dst_addr, $dst_port) = @_;
  my(@bank_names);
  if (defined $unix_socket_path) {
    push(@bank_names, $interface_policy{"SOCK"});
    push(@bank_names, $interface_policy{$unix_socket_path});
  } elsif (defined $dst_addr && defined $dst_port) {
    $dst_addr = '['.lc($dst_addr).']' if $dst_addr =~ /:[0-9a-f]*:/i;  # IPv6?
    push(@bank_names, $interface_policy{$dst_port});
    push(@bank_names, $interface_policy{"$dst_addr:$dst_port"});
  }
  load_policy_bank($_) for @bank_names;
  # note that the new policy bank may have replaced the inet_acl access table
  if (defined $unix_socket_path) {
    # always permit access - unix sockets are immune to this check
  } elsif (defined $src_addr) {
    my($permit,$fullkey,$err) = lookup_ip_acl($src_addr,
                       Amavis::Lookup::Label->new('inet_acl'), ca('inet_acl'));
    if ($err) {
      do_log(-1, "DENIED ACCESS due to INVALID PEER IP ADDRESS %s: %s",
                 $src_addr, $err);
      return 0;
    } elsif (!$permit) {
      do_log(-1, "DENIED ACCESS from IP %s, policy bank '%s'%s",
                 $src_addr, c('policy_bank_path'),
                 !defined $fullkey ? '' : ", blocked by rule $fullkey");
      return 0;
    }
  }
  1;
}

### 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 = $_[0];
  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 $is_ux = $sock && $sock->UNIVERSAL::can('NS_proto') &&
              $sock->NS_proto eq 'UNIX';
  if ($is_ux) {
    my $unix_socket_path = Net::Server->VERSION >= 2 ? $sock->NS_port
                                                     : $sock->NS_unix_path;
    $unix_socket_path = 'UNKNOWN'  if !defined $unix_socket_path;
    return access_is_allowed($unix_socket_path);
  } else {
    return access_is_allowed(undef,
                             $prop->{peeraddr}, $prop->{peerport},
                             $prop->{sockaddr}, $prop->{sockport});
  }
}

### The heart of the program
### user customizable Net::Server hook
#
sub process_request {
  my $self = $_[0];
  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.
  if (ref($sock) !~ /^(?:IO::Socket::SSL|Net::Server::Proto::SSL)\z/) {
    # binmode not implemented in IO::Socket::SSL and returns false
    binmode($sock) or die "Can't set socket $sock 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 && !$ldap_lookups) {
      # make LDAP lookup object
      $ldap_connection = Amavis::LDAP::Connection->new($default_ldap);
      $ldap_lookups = Amavis::Lookup::LDAP->new($default_ldap,$ldap_connection)
        if $ldap_connection;
    }
    if ($ldap_lookups &&
        $lookup_maps_imply_sql_and_ldap && !$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_lookups,@_)};

      unshift(@Amavis::Conf::local_domains_maps,       $lf->('amavisLocal',              'B1'));

      unshift(@Amavis::Conf::virus_lovers_maps,        $lf->('amavisVirusLover',         'B-'));
      unshift(@Amavis::Conf::spam_lovers_maps,         $lf->('amavisSpamLover',          'B-'));
      unshift(@Amavis::Conf::unchecked_lovers_maps,    $lf->('amavisUncheckedLover',     '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_tag3_level_maps,     $lf->('amavisSpamTag3Level',      '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_subject_tag3_maps,   $lf->('amavisSpamSubjectTag3',    'S-'));

      unshift(@Amavis::Conf::virus_quarantine_to_maps, $lf->('amavisVirusQuarantineTo',  'S-'));
      unshift(@Amavis::Conf::spam_quarantine_to_maps,  $lf->('amavisSpamQuarantineTo',   'S-'));
      unshift(@Amavis::Conf::banned_quarantine_to_maps, $lf->('amavisBannedQuarantineTo','S-'));
      unshift(@Amavis::Conf::unchecked_quarantine_to_maps, $lf->('amavisUncheckedQuarantineTo','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::message_size_limit_maps,  $lf->('amavisMessageSizeLimit',   'N-'));

      unshift(@Amavis::Conf::addr_extension_virus_maps, $lf->('amavisAddrExtensionVirus', 'S-'));
      unshift(@Amavis::Conf::addr_extension_spam_maps,  $lf->('amavisAddrExtensionSpam',  'S-'));
      unshift(@Amavis::Conf::addr_extension_banned_maps, $lf->('amavisAddrExtensionBanned','S-'));
      unshift(@Amavis::Conf::addr_extension_bad_header_maps, $lf->('amavisAddrExtensionBadHeader','S-'));

      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::newvirus_admin_maps,      $lf->('amavisNewVirusAdmin',      'S-'));
      unshift(@Amavis::Conf::virus_admin_maps,         $lf->('amavisVirusAdmin',         '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-'));
      unshift(@Amavis::Conf::forward_method_maps,      $lf->('amavisForwardMethod',      'S-'));
      unshift(@Amavis::Conf::sa_userconf_maps,         $lf->('amavisSaUserConf',         'S-'));
      unshift(@Amavis::Conf::sa_username_maps,         $lf->('amavisSaUserName',         'S-'));

      section_time('ldap-prepare');
    }
    if ($sql_lookups &&
        $lookup_maps_imply_sql_and_ldap && !$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_lookups,@_)}; # 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::unchecked_lovers_maps,     $nf->('unchecked_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_tag3_level_maps,      $nf->('spam_tag3_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_subject_tag_maps,     $nf->('spam_subject_tag',     'S-'));
      unshift(@Amavis::Conf::spam_subject_tag2_maps,    $nf->('spam_subject_tag2',    'S-'));
      unshift(@Amavis::Conf::spam_subject_tag3_maps,    $nf->('spam_subject_tag3',    'S-'));

      unshift(@Amavis::Conf::virus_quarantine_to_maps,  $nf->('virus_quarantine_to',  'S-'));
      unshift(@Amavis::Conf::spam_quarantine_to_maps,   $nf->('spam_quarantine_to',   'S-'));
      unshift(@Amavis::Conf::banned_quarantine_to_maps, $nf->('banned_quarantine_to', 'S-'));
      unshift(@Amavis::Conf::unchecked_quarantine_to_maps, $nf->('unchecked_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::spam_admin_maps,       $nf->('spam_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::banned_filename_maps,  $nf->('banned_rulenames', 'S-'));
      unshift(@Amavis::Conf::disclaimer_options_bysender_maps,
                                                    $nf->('disclaimer_options', 'S-'));
      unshift(@Amavis::Conf::forward_method_maps,   $nf->('forward_method',   'S-'));
      unshift(@Amavis::Conf::sa_userconf_maps,      $nf->('sa_userconf',      'S-'));
      unshift(@Amavis::Conf::sa_username_maps,      $nf->('sa_username',      'S-'));

      section_time('sql-prepare');
    }

    $implicit_maps_inserted = 1;
    if (!$maps_have_been_labeled)
      { Amavis::Conf::label_default_maps(); $maps_have_been_labeled = 1 }

    my $ns_proto = $sock->NS_proto;  # Net::Server::Proto submodules
    my $conn = Amavis::In::Connection->new;  # keeps info about connection
    $conn->socket_proto($ns_proto);
    my $suggested_protocol = c('protocol');  # suggested by the policy bank
    $suggested_protocol = ''  if !defined $suggested_protocol;
    do_log(5,"process_request: suggested_protocol=\"%s\" on a %s socket",
             $suggested_protocol, $ns_proto);
    $zmq_obj->register_proc(2,0,'b')  if $zmq_obj;  # begin protocol
  # $snmp_db->register_proc(2,0,'b')  if $snmp_db;
    if ($ns_proto eq 'UNIX') {
      my $path = Net::Server->VERSION >= 2 ? $sock->NS_port
                                           : $sock->NS_unix_path;
      $conn->socket_path($path);
      # how to test:  $ socat stdio unix-connect:/var/amavis/amavisd.sock,crnl
    } else {  # TCP, UDP, UNIXDGRAM, SSLEAY, SSL (Net::Server::Proto modules)
      my $sock_addr = $prop->{sockaddr};
      my $peer_addr = $prop->{peeraddr};
      if ($sock_addr eq $peer_addr) {  # common, small optimization
        $peer_addr = $sock_addr = normalize_ip_addr($sock_addr);
      } else {
        $sock_addr = normalize_ip_addr($sock_addr);
        $peer_addr = normalize_ip_addr($peer_addr);
      }
      # untaint IP addresses and port numbers, just in case
      $conn->socket_port(untaint($prop->{sockport}));
      $conn->client_port(untaint($prop->{peerport}));
      $conn->socket_ip(untaint($sock_addr));
      $conn->client_ip(untaint($peer_addr));
    }
    if ($suggested_protocol eq 'SMTP' || $suggested_protocol eq 'LMTP' ||
        ($suggested_protocol eq '' && $ns_proto =~ /^(?:TCP|SSLEAY|SSL)\z/)) {
      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)
      $ampdp_in_obj = Amavis::In::AMPDP->new  if !$ampdp_in_obj;
      $ampdp_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') {
#     # defaults to old amavis helper program protocol
#     $ampdp_in_obj = Amavis::In::AMPDP->new  if !$ampdp_in_obj;
#     $ampdp_in_obj->process_policy_request($sock, $conn, \&check_mail, 1);
    } elsif ($suggested_protocol eq '') {
      die "protocol not specified, $ns_proto";
    } 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 $ampdp_in_obj; undef $courier_in_obj;
    $self->done(1);
  } elsif (defined $max_requests && $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
    do_log(2, "Requesting process rundown after %d tasks (and %s sessions)",
              $child_task_count, $child_invocation_count);
    undef $smtp_in_obj; undef $ampdp_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 $ampdp_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;
  }
  ll(5) && do_log(5, 'exiting process_request');
}

sub child_goes_idle($) {
  my $where = $_[0];
  do_log(5, 'child_goes_idle (%s)', $where);
  my(@disconnected_what);
# $extra_code_out_smtp && eval {
#   Amavis::Out::SMTP::Session::rundown_stale_sessions(1) &&
#     push(@disconnected_what,'SMTP');
# };
  $sql_dataset_conn_storage && eval {
    $sql_dataset_conn_storage->disconnect_from_sql &&
      push(@disconnected_what,'SQL-storage');
  };
  $sql_dataset_conn_lookups && eval {
    # $sql_dataset_conn_lookups possibly the same as $sql_dataset_conn_storage,
    # attempting to disconnect twice does no harm
    $sql_dataset_conn_lookups->disconnect_from_sql &&
      push(@disconnected_what,'SQL-lookup');
  };
  $ldap_connection && eval {
    $ldap_connection->disconnect_from_ldap &&
      push(@disconnected_what,'LDAP');
  };
  do_log(5, 'child_goes_idle: disconnected %s (%s)',
            !@disconnected_what ? 'none' : join(', ',@disconnected_what),
            $where);
}

### After processing of a request, but before client connection has been closed
### user customizable Net::Server hook
#
sub post_process_request_hook {
  my $self = $_[0];
  my $prop = $self->{server}; my $sock = $prop->{client};
  local $SIG{CHLD} = 'DEFAULT';
# do_log(5, "entered post_process_request_hook");
  alarm(0);  # stop the timer
  child_goes_idle('post_process_request')  if !$database_sessions_persistent;
  debug_oneshot(0);
  $0 = sprintf("%s (ch%d-avail)",
               c('myprogram_name'), $child_invocation_count);
  $zmq_obj->register_proc(1,0,'')  if $zmq_obj;  # alive and idle again
  $snmp_db->register_proc(1,0,'')  if $snmp_db;
  Amavis::Timing::go_idle('bye');
  if (ll(3)) {
    my $load_report = Amavis::Timing::report_load();
    do_log(3,$load_report)  if defined $load_report;
  }
  dump_captured_log(1, c('enable_log_capture_dump'));
  # workaround: Net::Server 0.91 forgets to disconnect session
  if (Net::Server->VERSION == 0.91) { close STDIN; close STDOUT }
# DB::disable_profile() if $profiling;
  DB::finish_profile() if $profiling;
}

### Child is about to be terminated
### user customizable Net::Server hook
#
sub child_finish_hook {
  my $self = $_[0];
  local $SIG{CHLD} = 'DEFAULT';
# do_log_safe(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));
# }
  child_goes_idle('child finishing');
  $spamcontrol_obj->rundown_child  if $spamcontrol_obj;
  $0 = sprintf("%s (ch%d-finish)",
               c('myprogram_name'), $child_invocation_count);
  do_log_safe(5,"child_finish_hook: invoking DESTROY methods");
  undef $smtp_in_obj; undef $ampdp_in_obj; undef $courier_in_obj;
  undef $sql_storage; undef $sql_wblist; undef $sql_lookups;
  undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage;
  undef $ldap_lookups; undef $ldap_connection; undef $redis_storage;
  # unregister our process
  if ($zmq_obj) {
    eval { $zmq_obj->register_proc(0,0,undef); 1; }
      or do_log_safe(-1, "child_finish_hook: ZMQ unregistering failed: %s",$@);
  }
  if ($snmp_db) {
    eval { $snmp_db->register_proc(0,0,undef); 1; }
      or do_log_safe(-1, "child_finish_hook: DB unregistering failed: %s",$@);
  }
  undef $snmp_db; undef $db_env; undef $zmq_obj;
  log_capture_enabled(0);
}

### user customizable Net::Server hook,
### hook occurs in the main process before the server begins shutting down
#
sub pre_server_close_hook {
  sd_notify(0, "STOPPING=1",
               "STATUS=Server rundown, notifying child processes.");
}

### user customizable Net::Server hook,
### hook occurs in the main process after child proceses have been shut down
#
sub post_child_cleanup_hook {
  sd_notify(0, "STATUS=Child processes have been stopped.");
}

### user customizable Net::Server hook,
### hook occurs in the main process if a server has received a HUP signal.
### It occurs just before restarting the server via exec.
#
sub restart_close_hook {
  sd_notify(0, "RELOADING=1",
               "STATUS=Reloading server, about to re-exec the program.");
}

### user customizable Net::Server hook,
### hook occurs in the main process if a server has been restarted via the HUP
### signal and re-exec'd.  It occurs just before reopening to the filenos of
### the sockets that were already opened.
#
sub restart_open_hook {
  sd_notify(0, "STATUS=Warm restart, re-binding sockets.");
}

sub END {                # runs before exiting the module
  local($@,$!);
# do_log_safe(5,"at the END handler: invoking DESTROY methods");
  undef $smtp_in_obj; undef $ampdp_in_obj; undef $courier_in_obj;
  undef $sql_storage; undef $sql_wblist; undef $sql_lookups;
  undef $sql_dataset_conn_lookups; undef $sql_dataset_conn_storage;
  undef $ldap_lookups; undef $ldap_connection; undef $redis_storage;
  # unregister our process
  if ($zmq_obj) {
    eval { $zmq_obj->register_proc(0,0,undef); 1; }
      or do_log_safe(-1, "Amavis::END: ZMQ unregistering failed: %s", $@);
  }
  if ($snmp_db) {
    eval { $snmp_db->register_proc(0,0,undef); 1; }
      or do_log_safe(-1, "Amavis::END: DB unregistering failed: %s", $@);
  }
  undef $snmp_db; undef $db_env; undef $zmq_obj;
  log_capture_enabled(0);
}

# 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 = proto_decode($1);
      my $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 = $_[0]; local($1);
  $str =~ s/([^\041-\044\046-\176])/sprintf("%%%02x",ord($1))/gse;
  $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_wblist->clear_cache    if $sql_wblist;
  $sql_lookups->clear_cache   if $sql_lookups;
  $ldap_lookups->clear_cache  if $ldap_lookups;

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

# create a mail_id unique to a database and save preliminary info to SQL;
# if SQL is not enabled, just call a plain generate_mail_id() once
#
sub generate_unique_mail_id($) {
  my $msginfo = $_[0];
  my($mail_id,$secret_id);
  for (my $attempt = 5; ;) {  # sanity limit on retries
    ($mail_id,$secret_id) = generate_mail_id();
    $msginfo->secret_id($secret_id);
    $secret_id = 'X' x length($secret_id);  # can't hurt to wipe out
    $msginfo->mail_id($mail_id);  # assign a long-term unique id to the msg

    my $is_unique = 1;
    # don't bother to save info on incoming messages - saves Redis storage
    # while still offering necessary data for a penpals function
    if ($redis_storage && $msginfo->originating) {
      # attempt to save a message placeholder to Redis, ensuring it is unique
      eval {
        $redis_storage->save_info_preliminary($msginfo) or ($is_unique=0);
        1;
      } or do {
        chomp $@;
        do_log(-1, 'storing preliminary info to redis failed: %s', $@);
      };
    }
    if ($is_unique && $sql_storage) {
      # attempt to save a message placeholder to SQL, ensuring it is unique
      $sql_storage->save_info_preliminary($msginfo) or ($is_unique=0);
    }
    last if $is_unique;

    if (--$attempt <= 0) {
      do_log(-2,'too many retries on storing preliminary, info not saved');
      last;
    } else {
      snmp_count('GenMailIdRetries');
      do_log(2,'retrying storing preliminary, %d attempts remain', $attempt);
      sleep(int(1+rand(3)));
      add_entropy(Time::HiRes::gettimeofday, $attempt);
    }
  }
  $mail_id;
}

sub extract_info_from_received_trace($) {
  my($msginfo) = @_;
  my(@trace);
  for (my $j=0;  ; $j++) {  # walk through Received header fields, top-down
    my $r = $msginfo->get_header_field_body('received',$j);
    last  if !defined $r;
    my $fields_ref = parse_received($r);
    my $ip = fish_out_ip_from_received($r,$fields_ref);  # possibly undef
    $ip = normalize_ip_addr($ip)  if defined $ip;
    push(@trace, { ip => $ip, %$fields_ref });
  }
  \@trace;
}

# 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 available 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 = $_[0];

  my $partition_tag = c('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);

  my $sender = $msginfo->sender;
  $msginfo->sender_source($sender);

  # obtain RFC 5322 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);  # RFC 5322 (ex RFC 2822) allows multiple author's addr
  local($1);
  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    ? undef :
                           @rfc2822_from < 2 ?  $rfc2822_from[0]
                                             : \@rfc2822_from);
  }
  my $rfc2822_to = $msginfo->get_header_field_body('to');
  if (defined $rfc2822_to) {
    my(@to_parsed) = map(unquote_rfc2821_local($_),
                         parse_address_list($rfc2822_to));
    $msginfo->rfc2822_to(@to_parsed<2 ? $to_parsed[0] : \@to_parsed);
  }
  my $rfc2822_cc = $msginfo->get_header_field_body('cc');
  if (defined $rfc2822_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_field2('resent-from') ||
      defined $msginfo->get_header_field2('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 RFC 5322 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) = $msginfo->get_header_field2(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
           ) ) {  # end 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 $refs_in_reply_to = $msginfo->get_header_field_body('in-reply-to');
  my $refs_references  = $msginfo->get_header_field_body('references');
  my(@refs) = grep(defined $_, $refs_in_reply_to, $refs_references);
  @refs = parse_message_id(join(' ',@refs))  if @refs;
  do_log(4, 'references: %s', join(', ',@refs))  if @refs;
  $msginfo->references(\@refs);

  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,"message size unknown, size set to %d", $mail_size);
  }

  my $trace_ref = extract_info_from_received_trace($msginfo);
  my $cl_ip = $msginfo->client_addr;
  if (defined $cl_ip) {
    my $last_hop = $trace_ref->[0];
    my $last_hop_ip = $last_hop && $last_hop->{ip};
    if (!defined $last_hop_ip || lc($cl_ip) ne lc($last_hop_ip)) {  # milter?
      do_log(5,"prepending client's IP address to trace: %s", $cl_ip);
      unshift(@$trace_ref, {
        ip   => $msginfo->client_addr,
        port => $msginfo->client_port,
        with => $msginfo->client_proto,
      });
    } elsif ($last_hop->{ip} && !$last_hop->{port}) {
      # add a missing information, not available in a Received trace
      $last_hop->{port} = $msginfo->client_port;
    }
  }
  { # add the last hop (ours, currently underway) to the trace
    my $conn = $msginfo->conn_obj;  # the connection between MTA and amavisd
    my $recips = $msginfo->recips;
    my $myhelo = c('localhost_name');  # my EHLO/HELO/LHLO name, UTF-8 octets
    $myhelo = 'localhost'  if $myhelo eq '';
    $myhelo = $msginfo->smtputf8 ? idn_to_utf8($myhelo) : idn_to_ascii($myhelo);
    unshift(@$trace_ref, {
      ip   => $conn->client_ip,
      port => $conn->client_port,
      from => $conn->smtp_helo,
      by   => $myhelo,
      with => $conn->appl_proto,
      # id => $msginfo->mail_id,  # not yet known
      $recips && @$recips==1 ? (for => qquote_rfc2821_local(@$recips)) : (),
      # ";"  => rfc2822_timestamp($msginfo->rx_time),  # not needed
    });
  }

  my(@ip_trace_public);
  for my $hop (@$trace_ref) {
    next if !$hop;
    my $ip = $hop->{ip};
    if ($ip) {
      my($public,$key,$err) = lookup_ip_acl($ip, @public_networks_maps);
      if ($public && !$err) { $hop->{public} = 1; push(@ip_trace_public,$ip) }
    }
    my $with = $hop->{with};
    $hop->{with} = $with  if defined $with && $with =~ tr/A-Za-z0-9.+-/_/c;
  }
  $msginfo->trace($trace_ref);
  $msginfo->ip_addr_trace_public(\@ip_trace_public);
# ll(5) && do_log(5, "trace: %s", Amavis::JSON::encode($trace_ref));
  ll(3) && do_log(3, "trace: %s",
    join(' < ', map( (!$_->{with} ? '' : $_->{with}.'://') .
                     (!$_->{ip} ? 'x' : !$_->{port} ? $_->{ip}
                        : '['.$_->{ip}.']:'.$_->{port}), @$trace_ref ) ));
  # check for mailing lists, bulk mail and auto-responses
  my $is_mlist;  # mail from a mailing list
  my $is_auto;   # bounce, auto-response, challenge-response, ...
  my $is_bulk;   # bulk mail or $is_mlist or $is_auto
  if (defined $msginfo->get_header_field2('list-id')) {  # RFC 2919
    $is_mlist = $msginfo->get_header_field_body('list-id');
  } elsif (defined $msginfo->get_header_field2('list-post')) {
    $is_mlist = $msginfo->get_header_field_body('list-post');
  } elsif (defined $msginfo->get_header_field2('list-unsubscribe')) {
    $is_mlist = $msginfo->get_header_field_body('list-unsubscribe');
  } elsif (defined $msginfo->get_header_field2('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_field2('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_field2('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 $is_mlist;
  $msginfo->is_auto($is_auto)    if $is_auto;
  $msginfo->is_bulk($is_bulk)    if $is_bulk;

  # now that we have a parsed From, check if we have a valid
  # author domain signature and do other DKIM pre-processing
  if (c('enable_dkim_verification')) {
    Amavis::DKIM::collect_some_dkim_info($msginfo);
  }
  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.
# Alternatively, the $msginfo->mail_text can be a ref to a string
# containing an entire message - suitable for short messages.
#
sub check_mail($$) {
  my($msginfo, $dsn_per_recip_capable) = @_;

  my $which_section = 'check_init';
  my $t0_sect;
  my $elapsed = {}; $msginfo->time_elapsed($elapsed);
  $elapsed->{'TimeElapsedReceiving'} = Time::HiRes::time - $msginfo->rx_time;
  my $point_of_no_return = 0;  # past the point where mail or DSN was sent
  my $mail_id = $msginfo->mail_id;  # typically undef at this stage
  my $am_id = $msginfo->log_id;
  my $conn = $msginfo->conn_obj;
  if (!defined($am_id)) { $am_id = am_id(); $msginfo->log_id($am_id) }
  $zmq_obj->register_proc(1,0,'=',$am_id)  if $zmq_obj;  # check begins
  $snmp_db->register_proc(1,0,'=',$am_id)  if $snmp_db;
  my($smtp_resp, $exit_code, $preserve_evidence);
  my $custom_object;
  my $hold;      # set to some string causes the message to be placed on hold
                 # (frozen) by MTA (if configured to understand the inserted
                 # header field). 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->checks_performed({})  if !$msginfo->checks_performed;
    $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';
    { my $cwd = $msginfo->mail_tempdir;
      if (!defined $cwd || $cwd eq '') { $cwd = $TEMPBASE }
      chdir($cwd) or die "Can't chdir to $cwd: $!";
    }
    # compute body digest, measure mail size, check for 8-bit data, get entropy
    get_body_digest($msginfo, c('mail_digest_algorithm'));

    $which_section = 'collect_info';
    collect_some_info($msginfo);

    if (!defined($msginfo->client_addr)) {  # fetch missing IP addr from header
      my $trace_ref = $msginfo->trace;  # 'Received' trace info, top-down
      for my $hop ($trace_ref ? @$trace_ref : ()) {
        my $ip = $hop && $hop->{ip};
        if (defined $ip && $ip ne '') {
          do_log(3,"client IP address unknown, fetched from Received: %s",$ip);
          $msginfo->client_addr($ip); last;
        }
      }
    }
    section_time($which_section);

    $which_section = 'check_init4';
    my $mail_size = $msginfo->msg_size;  # use corrected ESMTP size
    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);

    if (!defined $mail_id && ($sql_store_info_for_all_msgs || !$sql_storage)) {
      $which_section = 'reg_proc';
      $zmq_obj->register_proc(2,0,'G',$am_id)  if $zmq_obj;
      $snmp_db->register_proc(2,0,'G',$am_id)  if $snmp_db;
    # section_time($which_section);
      $which_section = 'gen_mail_id';
      # create a mail_id unique to a database and save preliminary info to SQL
      generate_unique_mail_id($msginfo);
      $mail_id = $msginfo->mail_id;
      section_time($which_section)  if $sql_storage;  # || $redis_storage
    }

    $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 pol. bank load
      $msginfo->originating($new_orig)  if ($old_orig?1:0) != ($new_orig?1:0);
      update_current_log_level();  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);
    }

    if ($redis_storage && c('enable_ip_repu')) {
      $which_section = 'redis_ip_repu';
      my($score, $worst_ip) =
        $redis_storage->query_and_update_ip_reputation($msginfo);
      if ($score && $score >= 0.5) {
        $msginfo->ip_repu_score($score);
        my $spam_test = sprintf('AM.IP_BAD_%s=%.1f', $worst_ip, $score);
        for my $r (@{$msginfo->per_recip_data}) {
          $r->spam_level( ($r->spam_level || 0) + $score);
          $r->spam_tests([])  if !$r->spam_tests;
          unshift(@{$r->spam_tests}, \$spam_test);
        }
      }
      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(
        untaint(dynamic_destination($os_fingerprint_method,$conn)),
        0.050, $cl_ip, $msginfo->client_port, $dst_ip, $dst_port,
        defined $mail_id ? $mail_id : sprintf("%08x",rand(0x7fffffff)) );
    }

    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');
      ll(1) && 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",
               @rfc2822_from==1 ? $hdrfrom
                 : sprintf("%d:[%s]", scalar @rfc2822_from, $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 ? 1 : 0);  # canonical boolean, untainted
      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) {
        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 message 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 on some traditional file systems (no spam checking)
    $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
    }

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

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

    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";
      $zmq_obj->register_proc(2,0,'D',$am_id)  if $zmq_obj;  # decoding
      $snmp_db->register_proc(2,0,'D',$am_id)  if $snmp_db;
      $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);
        };
        if ($bounce_header_fields_ref &&
            exists $bounce_header_fields_ref->{'message-id'}) {
          $bounce_msgid = $bounce_header_fields_ref->{'message-id'};
          if (defined $bounce_msgid && $bounce_msgid ne '') {
            my $refs = $msginfo->references;
            if (!$refs) { $refs = []; $msginfo->references($refs) }
            push(@$refs, $bounce_msgid);
          }
        }
        prolong_timer($which_section);
      }

      $which_section = "parts_decode_ext";
      snmp_count('OpsDec');
      my($any_encrypted,$over_levels);
      ($hold, $any_undecipherable, $any_encrypted, $over_levels) =
        Amavis::Unpackers::decompose_mail($msginfo->mail_tempdir,
                                          $file_generator_object);
      $any_undecipherable ||= ($any_encrypted || $over_levels);
      if ($any_undecipherable) {
        $msginfo->add_contents_category(CC_UNCHECKED,0);
        $msginfo->add_contents_category(CC_UNCHECKED,1) if $any_encrypted;
        $msginfo->add_contents_category(CC_UNCHECKED,2) if $over_levels;
        for my $r (@{$msginfo->per_recip_data}) {
          next if $r->bypass_virus_checks;
          $r->add_contents_category(CC_UNCHECKED,0);
          $r->add_contents_category(CC_UNCHECKED,1) if $any_encrypted;
          $r->add_contents_category(CC_UNCHECKED,2) if $over_levels;
        }
      }
      $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($badh_ref,$minor_badh_cc);
      if ($allowed_tests && %$allowed_tests) {  # any test enabled?
        ($badh_ref,$minor_badh_cc) = check_header_validity($msginfo);
        $msginfo->checks_performed->{H} = 1;
        if (@$badh_ref) {
          push(@bad_headers, @$badh_ref);
          $msginfo->add_contents_category(CC_BADH,$minor_badh_cc);
        }
      }
      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);
      }
      for my $r (@{$msginfo->per_recip_data}) {
        my $bypassed = lookup2(0,$r->recip_addr,$bphcm);
        if (!$bypassed && @$badh_ref) {
          $r->add_contents_category(CC_BADH,$minor_badh_cc);
        }
        if (!$bypassed && $allowed_mime_test &&
            defined $mime_err && $mime_err ne '') {
          $r->add_contents_category(CC_BADH,1);  # CC_BADH min: 1=broken mime
        }
      }
      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
      $msginfo->checks_performed->{B} = 1;
      $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}));
    }

    my $virus_checking_failed = 0;
    if (!$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)) {
        if (!defined($msginfo->mail_text_fn)) {
          do_log(5,"can't present full original message to scanners, no file");
        } else {
          # 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;
          ll(3) && do_log(3,'presenting full original message to scanners '.
                            'as %s%s%s%s',
            $newpart,
            !$any_undecipherable ? '' : ", $any_undecipherable undecipherable",
            defined $msginfo->mime_entity ? '' : ', MIME not decoded',
            !defined $mime_err || $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
          if ($msginfo->smtputf8 && $msginfo->header_8bit) {
            # RFC 6532 section 3.7
            $newpart_obj->type_declared('message/global');
            $newpart_obj->name_declared('message.u8msg');
          } else {
            $newpart_obj->type_declared('message/rfc822');
            $newpart_obj->name_declared('message.msg');
          }
        }
      }

      $which_section = "virus_scan";
      $zmq_obj->register_proc(2,0,'V',$am_id)  if $zmq_obj;  # virus scan
      $snmp_db->register_proc(2,0,'V',$am_id)  if $snmp_db;
      my $av_ret;  $t0_sect = Time::HiRes::time;
      $virus_checking_failed = 1;
      eval {
        my($vn, $ds, $avsr);
        ($av_ret, $av_output, $vn, $ds, $avsr) =
          Amavis::AV::virus_scan($msginfo, $child_task_count==1);
        @virusname = @$vn; @detecting_scanners = @$ds;  # copy
        @av_scanners_results = @$avsr;
        if (defined $av_ret) {
          $virus_presence_checked = 1; $virus_checking_failed = 0;
          $msginfo->checks_performed->{V} = 1;
        }
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        do_log(-2, "AV: %s", $eval_stat);
        $virus_checking_failed = $eval_stat;
        $virus_checking_failed = 1  if !$virus_checking_failed;
      };
      $elapsed->{'TimeElapsedVirusCheck'} = Time::HiRes::time - $t0_sect;
      snmp_count('OpsVirusCheck');

      if ($virus_presence_checked && @virusname && $snmp_db) {
        $which_section = "read_snmp_variables";
        # true if none found with a counter value of zero or undef
        $virus_dejavu = 1  if !grep(!defined($_) || $_ == 0,
                                    @{$snmp_db->read_snmp_variables(
                                      map("virus.byname.$_", @virusname))});
        section_time($which_section);
      }
    }

    if ($virus_checking_failed) {
      $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;
      }
      if (c('virus_scanners_failure_is_fatal')) {
        $hold = 'AV: ' . $virus_checking_failed;
        die "$hold\n";  # TEMPFAIL
      }
    }

    $which_section = "post_virus_scan";
    if (@virusname) {
      my $virus_suppress_reason;
      my($ccat_maj,$ccat_min) = (CC_VIRUS,0);
      my $vtfsm = ca('viruses_that_fake_sender_maps');
      if (@$vtfsm) {
        for my $vn (@virusname) {
          my($result,$matchingkey) = lookup2(0,$vn,$vtfsm);
          if ($result) {  # is a virus known to fake a sender address
            do_log(3,"Virus %s matches %s, sender addr ignored",
                     $vn,$matchingkey);
            # try to get some info on sender source from his IP address
            my $first_rcvd_from_ip =
              oldest_public_ip_addr_from_received($msginfo);
            if (defined $first_rcvd_from_ip && $first_rcvd_from_ip ne '') {
              $msginfo->sender_source(sprintf('?@[%s]', $first_rcvd_from_ip));
            } else {
              $msginfo->sender_source(undef);
            }
            $virus_suppress_reason = 'INFECTED';
          # $ccat_min = 1;
            last;
          }
        }
      }
      $msginfo->add_contents_category($ccat_maj,$ccat_min);
      for my $r (@{$msginfo->per_recip_data}) {
        $r->add_contents_category(
                           $ccat_maj,$ccat_min)  if !$r->bypass_virus_checks;
        if (defined $virus_suppress_reason) {
          $r->dsn_suppress_reason($virus_suppress_reason .
                    (!defined $_ ? '' : ", $_"))  for $r->dsn_suppress_reason;
        }
      }
      $msginfo->virusnames([@virusname]);  # save a copy of virus names

      my $vntpbm = ca('virus_name_to_policy_bank_maps');
      if (@$vntpbm) {
        my(@bank_names);
        for my $vn (@virusname) {
          my($result,$matchingkey) = lookup2(0,$vn,$vntpbm);
          next 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 = 'VIRUS';
          }
          # $result is a list of policy bank names as a comma-separated string
          local $1;
          my(@pbn) = map(/^\s*(\S.*?)\s*\z/s ? $1 : (), split(/,/, $result));
          if (@pbn) {
            push(@bank_names, @pbn);
            ll(2) && do_log(2, "virus %s loads policy bank(s) %s, match: %s",
                               $vn, join(',',@pbn), $matchingkey);
          }
        }
        load_policy_bank($_) for @bank_names;
      }
    }

    if (defined($os_fingerprint_obj)) {
      $which_section = "fingerprint_collect";
      $os_fingerprint = $os_fingerprint_obj->collect_response;
      if (defined $os_fingerprint && $os_fingerprint ne '') {
        $msginfo->checks_performed->{F} = 1;
        if ($msginfo->originating)
          { $os_fingerprint = 'MYNETWORKS' }  # blank-out our smtp clients info
        $msginfo->client_os_fingerprint($os_fingerprint);  # store info
      }
    }

    my($bypass_spam_checks_by_bounce_killer);
    if (!$bounce_header_fields_ref) {
      # not a bounce
    } elsif ($msginfo->originating) {
      # will be rescued from bounce killing by the originating flag
    } elsif (defined($bounce_msgid) &&
             $bounce_msgid =~ /(\@[^\@>() \t][^\@>]*?)[ \t]*>?\z/ &&
             lookup2(0,$1, ca('local_domains_maps'))) {
      # will be rescued from bounce killing by a local domain
      # in referenced Message-ID
    } elsif (!defined($sql_storage) || !$sql_store_info_for_all_msgs ||
             c('penpals_bonus_score') <= 0 || c('penpals_halflife') <= 0) {
      # will be rescued from bounce killing by pen pals disabled
    } elsif (c('bounce_killer_score') > 20) {
      # is a bounce and is eligible to bounce killing, no need for spam scan
      $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 $recip = $r->recip_addr;
        my(@fd_tuples) = $r->setting_by_main_contents_category_all(
                           cr('final_destiny_maps_by_ccat'),
                           cr('lovers_maps_by_ccat'));
        for my $tuple (@fd_tuples) {
          my($cc, $fd_map_ref, $lovers_map_ref) = @$tuple;
          my $fd = !ref $fd_map_ref ? $fd_map_ref  # compatibility
                                    : lookup2(0, $recip, $fd_map_ref,
                                              Label => 'Destiny1');
          if (!defined $fd || $fd == D_PASS) {
            $fd = D_PASS;  # keep D_PASS
          } elsif (defined($lovers_map_ref) &&
                   lookup2(0, $recip, $lovers_map_ref, Label => 'Lovers1')) {
            $fd = D_PASS;  # D_PASS for content lovers
          } elsif ($fd == D_BOUNCE && ($sender eq '' || $msginfo->is_bulk) &&
                   ccat_maj($cc) == CC_BADH) {
            # have mercy on bad header section from mailing lists and in DSN
            $fd = D_PASS;  # change D_BOUNCE to D_PASS for CC_BADH
          } else {  # $fd != D_PASS, blocked
            $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(
                           $msginfo, $sql_wblist, $user_id_sql, $ldap_lookups);
        section_time($which_section);
        if ($all_wbl) {
          do_log(5, "sender white/blacklisted, skipping spam_scan");
        } elsif (!$spamcontrol_obj) {
          do_log(5, "spam scanning disabled, no spamcontrol_obj");
        } else {
          $which_section = "spam_scan";
          $zmq_obj->register_proc(2,0,'S',$am_id)  if $zmq_obj;
          $snmp_db->register_proc(2,0,'S',$am_id)  if $snmp_db;
          $t0_sect = Time::HiRes::time;
          # sets $msginfo->spam_level, spam_status,
          #      spam_report, spam_summary, supplementary_info
          $spamcontrol_obj->spam_scan($msginfo);
          eval {  # treat any failures there as non-fatal, just in case
            $spamcontrol_obj->auto_learn($msginfo); 1;
          } or do {
            my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
            do_log(-1, "Auto-learn failed: %s", $eval_stat);
          };
          $msginfo->checks_performed->{S} = 1;
          prolong_timer($which_section);
          $elapsed->{'TimeElapsedSpamCheck'} = Time::HiRes::time - $t0_sect;
          snmp_count('OpsSpamCheck');
          $spam_presence_checked = 1;
        }
      }
    }

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

    my($min_spam_level, $max_spam_level) =
      minmax(map($_->spam_level, @{$msginfo->per_recip_data}));
    $min_spam_level = 0  if !defined $min_spam_level;
    $max_spam_level = 0  if !defined $max_spam_level;

    $which_section = "penpals_check";
    my $pp_age;

    if (!$redis_storage &&
        !(defined $sql_storage && $sql_store_info_for_all_msgs)) {
      # pen pals disabled - data on past mail transactions unavailable
    } elsif ($msginfo->is_in_contents_category(CC_VIRUS)) {
      # pen pals disabled, not needed for infected messages
    } else {
      my $pp_bonus = c('penpals_bonus_score');  # score points
      my $pp_halflife = c('penpals_halflife');  # seconds
      if ($pp_bonus <= 0 || $pp_halflife <= 0) {
        # penpals disabled
      } elsif (defined($penpals_threshold_low) && !defined($bounce_msgid) &&
               $max_spam_level < $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) &&
               $min_spam_level - $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;
        $zmq_obj->register_proc(2,0,'P',$am_id)  if $zmq_obj;  # penpals
        $snmp_db->register_proc(2,0,'P',$am_id)  if $snmp_db;
        my $refs = $msginfo->references;
        my $sid = $msginfo->sender_maddr_id;
        section_time("pre-penpals");

        if ($redis_storage) {
          # does all recipient queries in one go
          my $ok = eval { $redis_storage->penpals_find($msginfo, $refs) };
          section_time("penpals-redis")  if $ok;
        }

        for my $r (@{$msginfo->per_recip_data}) {
          next  if $r->recip_done;  # already dealt with
          my $recip = $r->recip_addr;
          if ($r->recip_is_local && lc($sender) ne lc($recip)) {
            # inbound or internal_to_internal, except self_to_self

            my $pp_mail_id = $r->recip_penpals_related;
            my $pp_age = $r->recip_penpals_age;
            my $pp_subj;
            my $rid = $r->recip_maddr_id;
            if ($sql_storage && defined $sid && defined $rid) {
              # NOTE: swap $rid and $sid as args in a query 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_age_sql, $pp_mail_id_sql, $pp_subj_sql) =
                $sql_storage->penpals_find($rid, $sid, $refs, $msginfo);
              if (defined $pp_age_sql) {
                if (!defined $pp_age || $pp_age_sql < $pp_age) {
                  $pp_age = $pp_age_sql; $pp_mail_id = $pp_mail_id_sql;
                  $r->recip_penpals_age($pp_age);
                  $r->recip_penpals_related($pp_mail_id);
                }
                $pp_subj = $pp_subj_sql;
              }
              section_time("penpals-sql");
            }

            $msginfo->checks_performed->{P} = 1;
            if (defined $pp_age) {  # found info about previous correspondence
              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 $adj = - $weight * $pp_bonus;
              $r->recip_penpals_score($adj);
              $r->spam_level( ($r->spam_level || 0) + $adj);
              { my $spam_tests = 'AM.PENPAL=' . (0+sprintf("%.3f",$adj));
                if (!$r->spam_tests) {
                  $r->spam_tests([ \$spam_tests ]);
                } else {
                  unshift(@{$r->spam_tests}, \$spam_tests);
                }
              }
              if (ll(2)) {
                do_log(2,"penpals: adj.bonus %.3f, age %s (%d), ".
                       "SA score %.3f, <%s> replying to <%s>, ref mail_id: %s",
                       -$adj, format_time_interval($pp_age), $pp_age,
                       $r->spam_level, $sender, $recip, $pp_mail_id);
                if (defined $pp_subj) {
                  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 (= bounce)
      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 =~ /(\@[^\@>() \t][^\@>]*?)[ \t]*>?\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 spammers 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}) {
          $r->spam_level( ($r->spam_level || 0) + $bounce_killer_score);
          my $spam_tests = 'AM.BOUNCE=' . $bounce_killer_score;
          if (!$r->spam_tests) {
            $r->spam_tests([ \$spam_tests ]);
          } else {
            unshift(@{$r->spam_tests}, \$spam_tests);
          }
        }
      }

    # else: not a recognizable bounce
    } 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 a non-standard bounce or autoresponse,
      # but lacks recognizable structure and a header section from orig. 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";
    $zmq_obj->register_proc(2,0,'r',$am_id)  if $zmq_obj;  # results...
    $snmp_db->register_proc(2,0,'r',$am_id)  if $snmp_db;
    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;
      my $spam_level = $r->spam_level;

      # 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 criterion
      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 $do_tag = !$bypassed && (
                    $blacklisted || !defined $tag_level || $tag_level eq '' ||
                   ($spam_level + ($whitelisted?-10:0) >= $tag_level));
      my($do_tag2,$do_tag3,$do_kill) =
        map { !$bypassed && !$whitelisted &&
              ($blacklisted || (defined($_) && $spam_level >= $_) ) }
            ($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 }  # RFC 5321 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_maps_by_ccat'),
                         cr('lovers_maps_by_ccat'),
                         cr('defang_maps_by_ccat') );
      for my $tuple (@fd_tuples) {
        my($cc, $fd_map_ref, $lovers_map_ref, $mangle_map_ref) = @$tuple;
        my $fd = !ref $fd_map_ref ? $fd_map_ref  # compatibility
                                  : lookup2(0, $recip, $fd_map_ref,
                                            Label => 'Destiny2');
        if (!defined $fd || $fd == D_PASS) {
          ll(5) && do_log(5, 'final_destiny (ccat=%s) is PASS, recip %s',
                             $cc, $recip);
          $fd = D_PASS;  # keep D_PASS
        } elsif (defined($lovers_map_ref) &&
                 lookup2(0, $recip, $lovers_map_ref, Label => 'Lovers2')) {
          ll(5) && do_log(5, 'contents lover (ccat=%s), '.
                             'changing final_destiny %d to PASS, recip %s',
                             $cc, $fd, $recip);
          $fd = D_PASS;  # change to D_PASS for content lovers
        } elsif ($fd == D_BOUNCE && ($sender eq '' || $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, '.
                    'changing final_destiny %d to PASS',
            !$is_bulk ? '' : "($is_bulk) ",
            $sender, $recip, $bad_headers[0], $fd);
          $fd = D_PASS;  # change D_BOUNCE to D_PASS for CC_BADH
        } else {  # $fd != D_PASS, blocked
          $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, '.
                      'final_destiny %d',
                      $blocking_ccat, $recip, $fd);
          } else {
            do_log(3, 'blocking ccat (%s) differs from ccat_maj=%s, %s, '.
                      'final_destiny %d',
                      $blocking_ccat, $cc_main, $recip, $fd);
          }
          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
              do_log(5,"will not add disclaimer, allow_disclaimers is false");
            } 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, sender not local");
              } elsif (c('outbound_disclaimers_only') && $r->recip_is_local) {
                $to_be_mangled = 0;
                do_log(5, "will not add disclaimer, recipient is 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 (was: %s), ".
            "discl_allowed=%d, <%s> -> <%s>", $to_be_mangled ? 'YES' : 'NO',
            $to_be_mangled, $orig_to_be_mangled, c('allow_disclaimers'),
            $sender, $recip);
        }
      }

      # penpals_score is already accounted for in spam_level
      my $penpals_score = $r->recip_penpals_score;  # is zero or negative!
      if ($penpals_score && $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-$penpals_score >= $_) ) }
              ($tag2_level, $tag3_level, $kill_level);
        $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' : undef;
        if (defined $which) {
          snmp_count("PenPalsSavedFrom\u$which")  if $final_destiny==D_PASS;
          do_log(2, "penpals: PenPalsSavedFrom%s %.3f%.3f%s, <%s> -> <%s>",
                    "\u$which", $spam_level-$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
        do_log(5, "final_destiny %s, recip %s", $final_destiny, $recip);
        # supply RFC 3463 enhanced status codes, see also RFC 5248
        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_MTA,         "550 5.3.5",
            CC_CATCHALL,    "554 5.7.0",
          });
        my($statoverride,$softfailed); $softfailed = '';
        if ($status =~ /^[24]/) {  # just in case
          # keep unchanged
        } elsif ($final_destiny == D_TEMPFAIL) {
          $statoverride = '450';  # 5xx -> 450
        } elsif (c('soft_bounce')) {
          $statoverride = '450';  # 5xx -> 450
          $softfailed = ' (soft_bounce)';
          ll(5) && do_log(5, "soft_bounce: %s %s -> %s",
                            $final_destiny == D_DISCARD ? 'discard' : 'bounce',
                            $status, $statoverride);
        } elsif ($final_destiny == D_DISCARD) {
          $statoverride = '250';  # 5xx -> 250
        }
        if (defined $statoverride) {
          my $code = substr($statoverride,0,1); local($1,$2);
          $status =~ s{^\d(\d\d) \d(\.\d\.\d)}{$statoverride $code$2};
        }
        # 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);
          # coarsely chop to a sane size, wrap_smtp_resp() will finely adjust
          substr($smtp_reason,450) = '...'  if length($smtp_reason) > 450+3;
        }
        my $response = sprintf("%s %s%s%s", $status,
          ($final_destiny == D_PASS     ? "Ok" :
           $final_destiny == D_DISCARD  ? "Ok, discarded" :
           $final_destiny == D_REJECT   ? "Reject" :
           $final_destiny == D_BOUNCE   ? "Bounce" :
           $final_destiny == D_TEMPFAIL ? "Temporary failure" :
                                          "Not ok ($final_destiny)" ),
          $softfailed,
          $smtp_reason eq '' ? '' : ', '.$smtp_reason);
        # the wrap_smtp_resp() will enforce the requirement in
        # RFC 5321 section 4.5.3.1.5 on a length of a reply line
        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;
    $zmq_obj->register_proc(2,0,'Q',$am_id)  if $zmq_obj;  # notify, quar
    $snmp_db->register_proc(2,0,'Q',$am_id)  if $snmp_db;
    do_notify_and_quarantine($msginfo, $virus_dejavu);
#   $which_section = "aux_quarantine";
#   do_quarantine($msginfo, undef, ['archive-files'], 'local:archive/%m');
#   do_quarantine($msginfo, undef, ['archive@localhost'], 'local:all-%m');
#   do_quarantine($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);
      }
    }

    # set $r->delivery_method according to forward_method_maps_by_ccat lookup
    # or defaults
    for my $r (@{$msginfo->per_recip_data}) {
      next  if defined($r->delivery_method);
      my $fwd_map = $r->setting_by_contents_category(
                                            cr('forward_method_maps_by_ccat'));
      my $fwd_m;
      $fwd_m = lookup2(0, $r->recip_addr, $fwd_map,
                       Label=>"forward_method")  if ref $fwd_map;
      $fwd_m = ''  if !defined $fwd_m;
      $r->delivery_method($fwd_m);
    }
    # a custom hook may change $r->delivery_method
    if (ref $custom_object) {
      $which_section = "custom-before_send";
      eval {
        $custom_object->before_send($conn,$msginfo);
        update_current_log_level();  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);
    }
    if (ll(3)) {  # log delivery method by recipients
      my(%fwd_m_displ_log);
      for my $r (@{$msginfo->per_recip_data}) {
        my $fwd_m = $r->delivery_method;
        my $fwd_m_displ =
          !defined $fwd_m ? "undefined, mail will not be forwarded"
                   : map(ref eq 'ARRAY' ? '('.join(', ',@$_).')' : $_, $fwd_m);
        if (!$fwd_m_displ_log{$fwd_m_displ}) {
          $fwd_m_displ_log{$fwd_m_displ} = [ $r ];
        } else {
          push(@{$fwd_m_displ_log{$fwd_m_displ}}, $r);
        }
      }
      for my $log_msg (sort keys %fwd_m_displ_log) {
        do_log(3, "delivery method is %s, recips: %s", $log_msg,
          join(', ', map($_->recip_addr, @{$fwd_m_displ_log{$log_msg}})));
      }
    }
    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;
      $recip_obj->recip_addr_modified($bcc);

      # leave recip_addr and recip_addr_smtp undefined to hide it from the log?
      $recip_obj->recip_addr($bcc);
      $recip_obj->recip_addr_smtp(qquote_rfc2821_local($bcc));  #****

      $recip_obj->recip_is_local(
        lookup2(0, $bcc, ca('local_domains_maps')) ? 1 : 0);
      $recip_obj->recip_destiny(D_PASS);
      $recip_obj->dsn_notify(['NEVER']);
      $recip_obj->delivery_method(c('notify_method'));
      $recip_obj->contents_category($msginfo->contents_category);
    # $recip_obj->add_contents_category(CC_CLEAN,0);
      $msginfo->per_recip_data([@{$msginfo->per_recip_data}, $recip_obj]);
      do_log(2,"adding recipient - always_bcc: %s, delivery method %s",
               $bcc, $recip_obj->delivery_method);
    }
    my $hdr_edits = $msginfo->header_edits;

    # to be delivered explicitly (not by an AM.PDP client)
    if (grep(!$_->recip_done && $_->delivery_method ne '',
             @{$msginfo->per_recip_data})) {  # forwarding is needed
      $which_section = "forwarding";  $t0_sect = Time::HiRes::time;
      $zmq_obj->register_proc(2,0,'F',$am_id)  if $zmq_obj;  # forwarding
      $snmp_db->register_proc(2,0,'F',$am_id)  if $snmp_db;
      $hdr_edits = add_forwarding_header_edits_common(
        $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(
            $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,$m_ofs) =
          ($msginfo->mail_text, $msginfo->mail_text_fn, $msginfo->skip_bytes);
        my(@m_dm) = map($_->delivery_method, @{$msginfo->per_recip_data});
        # mail body mangling/defanging/sanitizing
        my $body_modified =
          prepare_modified_mail($msginfo,$hold,$any_undecipherable,$recip_cl);
        # defanged_mime_entity have modified header edits, refetch just in case
        $r_hdr_edits = $msginfo->header_edits;
        if ($body_modified) {
          my $resend_m = c('resend_method');
          if (defined $resend_m && $resend_m ne '') {
            $_->delivery_method($resend_m)  for @{$msginfo->per_recip_data};
            do_log(3,"mail body mangling in effect, resend_m: %s", $resend_m);
          } else {
            do_log(3,"mail body mangling in effect");
          }
        }
        if (mail_dispatch($msginfo, 0, $dsn_per_recip_capable,
                          sub { my $r = $_[0]; 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->skip_bytes($m_ofs);
        $msginfo->mail_text_str(undef); $msginfo->body_start_pos(undef);
        $_->delivery_method(shift @m_dm)  for @{$msginfo->per_recip_data};
        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);
        $msginfo->blocking_ccat($blocking_ccat)
                                          if !defined($msginfo->blocking_ccat);
        my $fd_map_ref =
          $r->setting_by_contents_category(cr('final_destiny_maps_by_ccat'));
        my $final_destiny =
          !ref $fd_map_ref ? $fd_map_ref  # compatibility
                : lookup2(0, $r->recip_addr, $fd_map_ref, Label => 'Destiny3');
        $final_destiny = D_PASS  if !defined $final_destiny;
        if ($final_destiny == D_PASS) {
          # impossible to pass, change to tempfail or reject
          $final_destiny = $smtp_resp =~ /^5/ ? D_REJECT : D_TEMPFAIL;
        }
        $r->recip_destiny($final_destiny);
        local($1,$2);
        if ($smtp_resp !~ /^5/) {
          # keep unchanged
        } elsif ($final_destiny == D_DISCARD) {
          $smtp_resp =~ s{^\d(\d\d) \d(\.\d\.\d)}{250 2$2};  # 5xx -> 250
        } elsif (c('soft_bounce')) {
          do_log(5, "soft_bounce: (mta) %s -> 450", $smtp_resp);
          $smtp_resp =~ s{^\d(\d\d) \d(\.\d\.\d)}{450 4$2};  # 5xx -> 450
        }
        my $smtp_reason =  # get the custom smtp response reason text
          $r->setting_by_contents_category(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);
          # coarsely chop to a sane size, wrap_smtp_resp() will finely adjust
          substr($smtp_reason,450) = '...'  if length($smtp_reason) > 450+3;
        }
        $smtp_resp =~ /^(\d\d\d(?: \d\.\d\.\d)?)\s*(.*)\z/s;
        my $dis = $final_destiny == D_DISCARD ? ' Discarded' : '';
        # the wrap_smtp_resp() will enforce the requirement in
        # RFC 5321 section 4.5.3.1.5 on a length of a reply line
        $r->recip_smtp_response("$1$dis $smtp_reason, $2");
        $r->recip_done(1); # fake a delivery (confirm delivery to a bit bucket)
        # note that 5xx status rejects may later be converted to bounces
      }
      $msginfo->header_edits($hdr_edits); # restore original edits just in case
      $elapsed->{'TimeElapsedForwarding'} = Time::HiRes::time - $t0_sect;
    }

    # AM.PDP or AM.CL (milter)
    if (grep(!$_->recip_done && $_->delivery_method eq '',
             @{$msginfo->per_recip_data})) {
      $which_section = "AM.PDP headers";
      $hdr_edits = add_forwarding_header_edits_common(
        $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(
          $msginfo, $hdr_edits, $hold, $any_undecipherable,
          $virus_presence_checked, $spam_presence_checked, undef);
      if (c('enable_dkim_signing')) {  # add DKIM signatures
        my(@signatures) = Amavis::DKIM::dkim_make_signatures($msginfo,0);
        $msginfo->dkim_signatures_new(\@signatures)  if @signatures;
        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;
          $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: RECIPIENTS REQUIRE DIFFERENT HEADERS");
      };
    }
    prolong_timer($which_section);

    if (ref $custom_object) {
      $which_section = "custom-after_send";
      eval {
        $custom_object->after_send($conn,$msginfo);
        update_current_log_level();  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 RFC 6522 & RFC 3464
    my($notification,$suppressed) = delivery_status_notification(
               $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($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
        build_and_save_structured_report($notification,'DSN');
      } 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($notification, 'Notif', 0);
      }
    # $notification->purge;
    }
    prolong_timer($which_section);
    $elapsed->{'TimeElapsedDSN'} = Time::HiRes::time - $t0_sect;

    $which_section = "snmp-counters";  $t0_sect = Time::HiRes::time;
    { # increment appropriate InMsgsStatus* SNMP counters and do some sanity
      # checking along the way;  also sets $msginfo->actions_performed
      #
      my($err, %which_counts);
      my $orig = $msginfo->originating;
      my $dsn_sent = $msginfo->dsn_sent;  # 1=bounced, 2=suppressed
      for my $r (@{$msginfo->per_recip_data}) {
        my $which;
        my $done = $r->recip_done;   # 2=relayed to MTA, 1=faked deliv/quarant
        my $dest = $r->recip_destiny;
        my $resp_code = $smtp_resp;  # per-msg status (one_response_for_all)
        $resp_code = $r->recip_smtp_response  if $dsn_per_recip_capable;
        my $resp_class = substr($resp_code||'0', 0, 1);
        if (!$done) {
          $which = 'Accepted';
          my $fwd_m = $r->delivery_method;  # double-checking our sanity
          if (defined $fwd_m && $fwd_m ne '') {
            $err = "Recip not done, nonempty delivery method: $fwd_m";
          }
        } elsif ($resp_class !~ /^[245]\z/) {
          $err = "Bad response code: $resp_code";
        } elsif ($resp_class eq '4') {
          $which = 'TempFailed';
        } elsif ($resp_class eq '5' && $dest == D_REJECT) {
          $which = 'Rejected';
        } else {  # $resp_class eq '2' || $resp_class eq '5' && $dest!=D_REJECT
          # 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
          if ($done == 2) {  # successful genuine forwarding
            $which = $r->recip_tagged ? 'RelayedTagged' : 'RelayedUntagged';
            $err = "Forwarded, but destiny not D_PASS? ($dest)"
              if $dest != D_PASS;
            $err = "Forwarded, but status not 2xx? ($resp_code)"
              if $resp_class ne '2';
          } elsif ($dest == D_DISCARD) {  # forwarded to a bit bucket
            $which = 'Discarded';
          } elsif ( $dest == D_BOUNCE ||
                   ($dest == D_REJECT && $resp_class eq '2') ) {
            if ($dsn_sent && $dsn_sent == 1) {
              $which = 'Bounced';  # genuine bounce (DSN) sent
            } elsif ($dsn_sent) {
              $which = 'NoBounce';  # bounce suppressed
            } else {  # sanity check
              $err = "To be bounced, but DSN was neither sent nor suppressed?";
            }
          } elsif ($dest == D_REJECT) {
            $which = 'Rejected';
            $err = "Rejected, but status not 5xx? ($resp_code)"
              if $resp_class ne '5';
          } else {  # sanity check
            $err = "Recip forwarding suppressed but not DISCARD?";
          }
        }
        $which = 'Unknown'  if !defined $which;
        $which_counts{$which}++;  # counts status without a direction
        $which_counts{'Relayed'}++  if $which eq 'RelayedTagged' ||
                                       $which eq 'RelayedUntagged';
        my $islocal = $r->recip_is_local;
        if ($orig) {
          if ($islocal) { $which_counts{$which.'Internal'}++ }
          else          { $which_counts{$which.'Outbound'}++ }
          $which_counts{$which.'Originating'}++;
        } else {
          if ($islocal) { $which_counts{$which.'Inbound'}++ }
          else          { $which_counts{$which.'OpenRelay'}++ }
        }
        do_log(0, "unexpected status/result, please verify: %s, %s",
                   $err, $r->recip_addr_smtp)  if defined $err;
      }
      my @which_list = sort keys %which_counts;

      # prefer this status in the list first, before a 'Quarantined' entry;
      # ignore a plain status name without mail direction to reduce clutter;
      # ignore Originating, as it is always paired with Internal or Outbound
      $msginfo->actions_performed([])  if !$msginfo->actions_performed;
      unshift(@{$msginfo->actions_performed},
              map(/^RelayedUntagged(.*)/ ? "Relayed$1" : $_,  # short log name
              grep(/(?:Inbound|Internal|Outbound|OpenRelay)\z/, @which_list)));

      snmp_count('InMsgsStatus'.$_)  for @which_list;
      ll(3) && do_log(3, 'status counters: InMsgsStatus{%s}',
                         join(',', @which_list));
    }
    prolong_timer($which_section);

    # merge similar timing entries
    $elapsed->{'TimeElapsedSending'} = 0;
    $elapsed->{'TimeElapsedSending'} +=
      delete $elapsed->{$_}  for ('TimeElapsedQuarantineAndNotify',
                                  'TimeElapsedForwarding', 'TimeElapsedDSN');

    $which_section = 'report';
    eval {  # protect the new code just in case
      # structured_report returns a string as perl characters (not octets)
      $report_ref = structured_report($msginfo); 1;
    } or do {
      chomp $@; do_log(-1,"structured_report failed: %s", $@);
    };
    section_time($which_section);

    # generate customized log report at log level 0 - this is usually the
    # only log entry interesting to administrators during normal operation
    $which_section = 'main_log_entry';
    my(%mybuiltins) = %builtins;  # make a local copy
    { # do a per-message log entry
      # macro %T has overloaded semantics, ugly
      $mybuiltins{'T'} = $mybuiltins{'TESTSSCORES'};
      my($y,$n,$f) = delivery_short_report($msginfo);
      @mybuiltins{'D','O','N'} = ($y,$n,$f);
      if (ll(0)) {
        my $strr = expand(cr('log_templ'), \%mybuiltins);
        for my $logline (split(/[ \t]*\n/, $$strr)) {
          do_log(0, '%s', $logline)  if $logline ne '';
        }
      }
    }
    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($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 && $os_fingerprint ne '') {
      $which_section = 'log_p0f';
      # log and collect statistics on contents type vs. OS
      my $spam_ham_thd = 2.0;   # reasonable threshold 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/;
      my $snmp_counter_name;
      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;
        $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 = $max_spam_level <= $spam_ham_thd ?'ham' : undef;
        }
        if (defined $snmp_counter_name) {
          snmp_count("$snmp_counter_name.byOS.$os_short");
          if ($snmp_counter_name eq 'ham' &&
              $os_fingerprint =~ /^Windows XP(?![^(]*\b2000 SP)/) {
            do_log(3, 'Ham from Windows XP? Most weird! %s [%s] score=%.3f',
                      $mail_id||'', $cl_ip, $max_spam_level);
          }
        }
      }
      do_log(2, "OS_fingerprint: %s %s %s.%s - %s",
                $msginfo->client_addr, $max_spam_level,
                defined $snmp_counter_name ? $snmp_counter_name : 'x',
                $os_short, $os_fingerprint);
    }

    if ($redis_storage && defined $msginfo->mail_id) {
      $which_section = 'redis-update';
      # save final information to Redis
      eval {
        $redis_storage->save_info_final($msginfo,$report_ref); 1;
      } or do {
        chomp $@; do_log(-1, 'save_info_final failed, Redis error: %s', $@);
      };
      section_time($which_section);
    }

    if ($sql_storage && defined $msginfo->mail_id) {
      # save final information to SQL (if enabled)
      $which_section = 'sql-update';
      for (my $attempt=5; $attempt>0; ) {  # sanity limit on retries
        if ($sql_storage->save_info_final($msginfo,$report_ref)) {
          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');
      if (defined $sa_tim && $sa_tim ne '') {
        my $sa_rusage = $msginfo->supplementary_info('RUSAGE-SA');
        if ($sa_rusage && @$sa_rusage) {
          local $1; my $sa_cpu_sum = 0; $sa_cpu_sum += $_ for @$sa_rusage;
          $sa_tim =~ s{^(total [0-9.]+ ms)}
                      {sprintf("[%s, cpu %.0f ms]", $1, $sa_cpu_sum*1000)}se;
        }
        do_log(2, "TIMING-SA %s", $sa_tim);
      }
    }

    if ($snmp_db || $zmq_obj) {
      $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, 'C64'] );
        do_log(3,"Syslog retries: %d x %s", $log_status_counts_ref->{$_}, $_)
          for (keys %$log_status_counts_ref);
      }
      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  if $snmp_db;
      $zmq_obj->update_snmp_variables  if $zmq_obj;
      section_time($which_section);
    }
    if (ref $custom_object) {
      $which_section = "custom-mail_done";
      eval {
        $custom_object->mail_done($conn,$msginfo);
        update_current_log_level();  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  if $allow_preserving_evidence;
    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);
      undef $smtp_resp;  # to be provided below
    }
    if (!defined($smtp_resp)) {
      $smtp_resp = "451 4.5.0 Error in processing, id=$am_id, $msg";
      $exit_code = EX_TEMPFAIL;
      for my $r (@{$msginfo->per_recip_data}) {
        next if $r->recip_done;
        $r->recip_smtp_response($smtp_resp); $r->recip_done(1);
      }
    }
  };

# if (defined $hold && $hold ne '') {
#   do_log(-1, "NOTICE: Evidence is to be preserved: %s", $hold);
#   $preserve_evidence = 1  if $allow_preserving_evidence;
# }
  if (!$preserve_evidence && debug_oneshot()) {
    do_log(0, "DEBUG_ONESHOT CAUSES EVIDENCE TO BE PRESERVED");
    $preserve_evidence = 1;  # regardless of $allow_preserving_evidence
  }
  if ($redis_storage &&
      $redis_logging_queue_size_limit && c('redis_logging_key') ) {
    if ($report_ref) {  # already have it
      # last-minute update of the "elapsed" field
      structured_report_update_time($report_ref);
    } else {  # prepare the log report
      eval {  # protect the new code just in case
        # structured_report returns a string as perl characters (not octets)
        $report_ref = structured_report($msginfo); 1;
      } or do {
        chomp $@; do_log(-1, 'structured_report failed: %s', $@);
      };
    }
    eval {
      $redis_storage->save_structured_report($report_ref,
        c('redis_logging_key'), $redis_logging_queue_size_limit); 1;
    } or do {
      chomp $@; do_log(-1, 'save_structured_report failed: %s', $@);
    };
  }
  $zmq_obj->register_proc(1,0,'.')  if $zmq_obj;  # content checking done
  $snmp_db->register_proc(1,0,'.')  if $snmp_db;
  do_log(-1, "signal: %s", join(', ',keys %got_signals))  if %got_signals;
  undef $MSGINFO;  # release global reference
  ($smtp_resp, $exit_code, $preserve_evidence);
} # end check_mail

# ROT13 obfuscation (Caesar cipher)
#   (possibly useful as a weak privacy measure when analyzing logs)
#
sub rot13 {
  my $str = $_[0];
  $str =~ tr/a-zA-Z/n-za-mN-ZA-M/;
  $str;
}

# Assemble a structured report, suitable for JSON serialization, useful
# in save_info_final(). Resulting string is in Perl logical characters
# (not necessarily with UTF8 flag set if all-ASCII).
#
sub structured_report($;$) {
  my($msginfo, $notification_type) = @_;

  my(@recipients);      # per-recipient records
  my(@queued_as_list);  # list of unique MTA queue IDs of forwarded mail
  my(@smtp_status_code_list);  # list of unique SMTP responses
  my(@destiny_list);    # list of destiny names
  my(@mail_id_related); # list of related mail_id's according to penpals
  my(%spam_test_names);
  my $true = Amavis::JSON::boolean(1);
  local($1,$2);

  my $sender_smtp = $msginfo->sender_smtp;
  $sender_smtp =~ s/^<(.*)>\z/$1/s;
  my(@rcpt_smtp) = map($_->recip_addr_smtp, @{$msginfo->per_recip_data});
  s/^<(.*)>\z/$1/s  for @rcpt_smtp;

  my $h_sender = $msginfo->rfc2822_sender; # undef or scalar
  my $h_from   = $msginfo->rfc2822_from;   # undef, scalar or listref
  my $h_to     = $msginfo->rfc2822_to;     # undef, scalar or listref
  my $h_cc     = $msginfo->rfc2822_cc;     # undef, scalar or listref
  my(@arr_h_from, @arr_h_to, @arr_h_cc);
  @arr_h_from = ref $h_from ? @$h_from : $h_from  if defined $h_from;
  @arr_h_to   = ref $h_to   ? @$h_to   : $h_to    if defined $h_to;
  @arr_h_cc   = ref $h_cc   ? @$h_cc   : $h_cc    if defined $h_cc;

  # Message-ID can contain an international domain name with A-labels
  my(@arr_m_id, @arr_refs);
  my $m_id = $msginfo->get_header_field_body('message-id');
  @arr_m_id = parse_message_id($m_id)  if defined $m_id && $m_id ne '';
  my $h_refs = $msginfo->references;
  @arr_refs = @$h_refs  if $h_refs;
  $_ = mail_addr_decode($_)  for (@arr_m_id, @arr_refs,
                                  $sender_smtp, @rcpt_smtp, $h_sender,
                                  @arr_h_from, @arr_h_to, @arr_h_cc);
  my $j = 0;
  for my $r (@{$msginfo->per_recip_data}) {
    my $recip_smtp = $rcpt_smtp[$j++];  # already processed for UTF-8
    my $orig_rcpt = $r->dsn_orcpt;  # RCPT command ORCPT option, RFC 3461
    if (defined $orig_rcpt) {
      my($addr_type, $addr) = orcpt_encode($orig_rcpt,1);  # to octets
      # is orcpt redundant?
      $orig_rcpt = defined $recip_smtp && $addr eq $recip_smtp ? undef
                     : safe_decode_utf8($addr);  # to characters
    }
    my $dest = $r->recip_destiny;
    my $resp = $r->recip_smtp_response;
    my $rem_smtp_resp = $r->recip_remote_mta_smtp_response;
    my($queued_as, $resp_code, $resp_code_enh);
    $queued_as = $1  if defined $rem_smtp_resp &&
                        $rem_smtp_resp =~ /\bqueued as ([0-9A-Za-z]+)$/;
    ($resp_code, $resp_code_enh) = ($1,$2)
      if $resp =~ /^(\d{3}) (?: [ \t]+ ([245] \. \d{1,3} \. \d{1,3}) \b)? /xs;
    my $d = $resp=~/^4/ ? 'TEMPFAIL'
         : ($dest==D_BOUNCE && $resp=~/^5/) ? 'BOUNCE'
         : ($dest!=D_BOUNCE && $resp=~/^5/) ? 'REJECT'
         : ($dest==D_DISCARD) ? 'DISCARD'
         : ($dest==D_PASS && ($resp=~/^2/ || !$r->recip_done))
             ? ($notification_type ? $notification_type : 'PASS') : '?';
    push(@destiny_list, $d);
    push(@smtp_status_code_list, $resp_code);
    push(@queued_as_list, $queued_as)  if defined $queued_as;
    my $rid = $r->recip_maddr_id;  # may be undefined
    my $o_rid = $r->recip_maddr_id_orig;  # may be undefined
    my $banning_reason_short = $r->banning_reason_short;
    my $spam_level = $r->spam_level;
    my $user_policy_id = $r->user_policy_id;
    my $ccat_blk_name =
      $r->setting_by_blocking_contents_category(\%ccat_display_names);
    my $ccat_main_name =
      $r->setting_by_main_contents_category(\%ccat_display_names);
    if (!defined $ccat_main_name ||
      # ($ccat_main_name =~ /^(?:Clean|CatchAll)\z/s) ||
        (defined $ccat_blk_name && $ccat_main_name eq $ccat_blk_name)) {
      # not worth reporting main ccat if the same as blocking ccat (or clean?)
      undef $ccat_main_name;
    }
    my $spam_tests = $r->spam_tests;  # arrayref of scalar refs
    if ($spam_tests) {
      for my $test_name_val (split(/,/,join(',',map($$_,@$spam_tests)))) {
        my($tname, $tscore) = split(/=/, $test_name_val, 2);
        $spam_test_names{$tname} = max($tscore, $spam_test_names{$tname});
      }
    }
    my $penpals_age = $r->recip_penpals_age; # penpals age in seconds, or undef
    my $penpals_related = $r->recip_penpals_related;
    push(@mail_id_related, $penpals_related) if defined $penpals_related;

    my(%recip) = (
      rcpt_to => $recip_smtp,
      defined $orig_rcpt ? (rcpt_to_orig => $orig_rcpt) : (),
      defined $rid   ? (rid => $rid) : (),
      defined $o_rid ? (rid_orig => Amavis::JSON::numeric($o_rid)) : (),
      rcpt_is_local => Amavis::JSON::boolean($r->recip_is_local),
      defined $user_policy_id ? (sql_user_policy_id => $user_policy_id) : (),
      action => $d,  # i.e. destiny
      defined $resp          ? (smtp_response => $resp)  : (),
      defined $resp_code     ? (smtp_code => $resp_code) : (),
    # defined $resp_code_enh ? (smtp_code_enh => $resp_code_enh) : (),
      defined $queued_as     ? (queued_as => $queued_as) : (),
      !defined $spam_level ? ()
        : (spam_score => Amavis::JSON::numeric(sprintf("%.3f",$spam_level))),
      $r->recip_blacklisted_sender ? (blacklisted => $true) : (),
      $r->recip_whitelisted_sender ? (whitelisted => $true) : (),
      $r->bypass_virus_checks  ? (bypass_virus_checks  => $true) : (),
      $r->bypass_banned_checks ? (bypass_banned_checks => $true) : (),
      $r->bypass_spam_checks   ? (bypass_spam_checks   => $true) : (),
      defined $ccat_blk_name   ? (ccat_blocking => $ccat_blk_name) : (),
      defined $ccat_main_name  ? (ccat_main => $ccat_main_name) : (),
      $banning_reason_short ? (banning_reason => $banning_reason_short) : (),
      defined $penpals_related ? (mail_id_related => $penpals_related) : (),
      !defined $penpals_age ? ()
        : (penpals_age => Amavis::JSON::numeric(int($penpals_age))),
      # recip_tagged  # was tagged by address extension or Subject or X-Spam
    );
    push(@recipients, \%recip);
  }

  my $q_type = $msginfo->quar_type;
  # only keep the first quarantine type used (e.g. ignore archival quar.)
  $q_type = $q_type->[0]  if ref $q_type;

  my $q_to = $msginfo->quarantined_to;  # ref to a list of quar. locations
  if (!$q_to || !@$q_to) { undef $q_to }
  else {
    $q_to = $q_to->[0];  # keep only the first quarantine location
    $q_to =~ s{^\Q$QUARANTINEDIR\E/}{};  # strip directory name
  }

  my($min_spam_level, $max_spam_level) =
    minmax(map($_->spam_level, @{$msginfo->per_recip_data}));

  my(@test_names_spam_topdown) =
    sort { $spam_test_names{$b} <=> $spam_test_names{$a} }
    grep($spam_test_names{$_} > 0, keys %spam_test_names);

  my(@test_names_ham_bottomup) =
    sort { $spam_test_names{$a} <=> $spam_test_names{$b} }
    grep($spam_test_names{$_} < 0, keys %spam_test_names);

  my $useragent = $msginfo->get_header_field_body('user-agent');
  $useragent = $msginfo->get_header_field_body('x-mailer')  if !$useragent;
  $useragent =~ s/^\s*(.*?)\s*\z/$1/s  if $useragent;
  my $subj = $msginfo->get_header_field_body('subject');
  my $from = $msginfo->get_header_field_body('from');  # raw full field
  for ($subj,$from) {  # character set decoding, unfolding
    chomp; s/\n(?=[ \t])//gs; s/^[ \t]+//s; s/[ \t]+\z//s;  # unfold, trim
    $_ = safe_decode_mime($_);  # to logical characters
  }

  my($conn, $src_ip, $dst_ip, $dst_port, $appl_proto);
  $conn = $msginfo->conn_obj;
  if ($conn) {  # MTA -> amavisd
    $src_ip = $conn->client_ip;      # immediate client IP addr, i.e. our MTA
    $dst_ip = $conn->socket_ip;      # IP address of our receiving socket
    $dst_port = $conn->socket_port;  # port number of our receiving socket
    $appl_proto = $conn->appl_proto; # protocol - the 'WITH' field
  }
  my $client_addr = $msginfo->client_addr;  # SMTP client -> MTA
  my $client_port = $msginfo->client_port;  # SMTP client -> MTA
  my $trace_ref = $msginfo->trace;  # "Received" trace entries (hashrefs)
  my $ip_trace_public = $msginfo->ip_addr_trace_public;  # "Received" IP trace
  my $checks_performed = $msginfo->checks_performed;
  $checks_performed = join(' ', grep($checks_performed->{$_},
                                     qw(V S H B F P D))) if $checks_performed;
  my $actions_performed = $msginfo->actions_performed;
  $actions_performed = join(' ', @$actions_performed) if $actions_performed;
  @destiny_list = unique_list(\@destiny_list);
  my $partition_tag = $msginfo->partition_tag;
  my $sid = $msginfo->sender_maddr_id;
  my $policy_bank_path = c('policy_bank_path');
  my $is_mlist = $msginfo->is_mlist;
  $is_mlist =~ s/^ml:(?=.)//s  if $is_mlist;  # strip ml: prefix
  my $os_fp = $msginfo->client_os_fingerprint;
  my $dsn_sent = $msginfo->dsn_sent;
  my $queue_id = $msginfo->queue_id;
  @queued_as_list = unique_list(\@queued_as_list);
  @smtp_status_code_list = unique_list(\@smtp_status_code_list);

  my $dkim_author_sig = $msginfo->dkim_author_sig;
  my $dkim_sigs_new_ref = $msginfo->dkim_signatures_new;
  my $dkim_sigs_ref = $msginfo->dkim_signatures_valid;
  my(@dkim_sigs_valid, @dkim_sigs_new);  # domain names, IDN-decoded
  @dkim_sigs_valid = unique_list(map(idn_to_utf8($_->domain),
                                   @$dkim_sigs_ref)) if $dkim_sigs_ref;
  @dkim_sigs_new = unique_list(map(idn_to_utf8($_->domain),
                                   @$dkim_sigs_new_ref)) if $dkim_sigs_new_ref;

  my $vn = $msginfo->virusnames;
  undef $vn  if $vn && !@$vn;
  my(%scanners_report);  # per-scanner report of virus names found
  if ($vn) {
    for (@av_scanners_results) {
      my($av, $status, @virus_names) = @$_;
      my $scanner = $av && $av->[0];
      if ($status && defined $scanner) {
        $scanner =~ tr/"/'/;  # sanitize scanner name for json
        $scanner =~ tr/\x00-\x1F\x7F\x80-\x9F\\/ /;
        $scanners_report{$scanner} = \@virus_names;
      }
    }
  }

  my $rx_time = $msginfo->rx_time;
  my $mjd = $rx_time/86400 + 40587;  # Modified Julian Day, float
  my($iso8601_year, $iso8601_wn) = iso8601_year_and_week($rx_time);

  my(%elapsed);
  if (!$notification_type) {
    my $elapsed_ref = $msginfo->time_elapsed;
    if ($elapsed_ref) {
      while (my($k,$v) = each(%$elapsed_ref)) {
        next if $k eq 'TimeElapsedPenPals';  # quick, don't bother
        $k =~ s/^TimeElapsed//;
        $elapsed{$k} = $v;  # cast to numeric later down
      }
    }
  }

  my(%result) = (
    type => 'amavis',
    host => safe_decode_utf8(idn_to_utf8(c('myhostname'))),
    log_id => $msginfo->log_id,
  # secret_id => $msginfo->secret_id,
    mail_id => $msginfo->mail_id,
    !defined $msginfo->parent_mail_id ? () :
      (mail_id_parent => $msginfo->parent_mail_id),
    @mail_id_related ? (mail_id_related => \@mail_id_related) : (),
    defined $src_ip  ? (src_ip => $src_ip) : (),
    defined $dst_ip  ? (dst_ip => $dst_ip) : (),
    $dst_port ? (dst_port => Amavis::JSON::numeric($dst_port)) : (),
    defined $client_addr ? (client_ip => $client_addr) : (),
    $client_port ? (client_port => Amavis::JSON::numeric($client_port)) : (),
    defined $partition_tag ? (partition => $partition_tag) : (),
    defined $queue_id && $queue_id ne '' ? (queue_id => $queue_id) : (),
    defined $sid ? (sid => $sid) : (),
    defined $appl_proto ? (protocol => $appl_proto) : (),

    # addresses from SMTP envelope:
    mail_from => $sender_smtp,
    rcpt_to  => \@rcpt_smtp,  # list of recipient addresses
    rcpt_num => Amavis::JSON::numeric(scalar @rcpt_smtp),  # num. of recips
    recipients => \@recipients,  # list of hashes

    # addresses from mail header:
    !defined $h_sender ? () : (sender => $h_sender),
    $h_from       ? (author  => \@arr_h_from) : (),
    $h_to         ? (to_addr => \@arr_h_to) : (),
    $h_cc         ? (cc_addr => \@arr_h_cc) : (),
  # defined $from ? (from_raw => $from) : (),
    defined $subj ? (subject  => $subj) : (),
    defined $subj ? (subject_rot13 => rot13($subj)) : (),

    defined $m_id ? (message_id => join(' ',@arr_m_id)) : (),
    @arr_refs     ? (references => \@arr_refs) : (),

    defined $useragent ? (user_agent => $useragent) : (),
    !defined $policy_bank_path ? ()
                : (policy_banks => [ split(m{/}, $policy_bank_path) ]),
    $ip_trace_public ? (ip_trace => [ @$ip_trace_public ]) : (),
    !$trace_ref || !@$trace_ref ? ()
      : (ip_proto_trace => [ map( (!$_->{with} ? '' : $_->{with}.'://') .
                                  (!$_->{ip} ? 'x' : !$_->{port} ? $_->{ip}
                                     : '['.$_->{ip}.']:'.$_->{port}),
                                  @$trace_ref) ]),
    !$msginfo->msg_size ? ()
      : (size => Amavis::JSON::numeric(0+$msginfo->msg_size)),
    !$msginfo->body_digest ? ()
      : (digest_body => $msginfo->body_digest),
    content_type =>  # blocking ccat if blocked, main ccat otherwise
      $msginfo->setting_by_contents_category(\%ccat_display_names),
    defined $q_to   ? (quarantine => $q_to)   : (),
    defined $q_type ? (quar_type  => $q_type) : (),
    !defined $max_spam_level ? ()
      : (spam_score => Amavis::JSON::numeric(sprintf("%.3f",$max_spam_level))),
    $notification_type ? () : (dsn_sent => Amavis::JSON::boolean($dsn_sent==1)),
    originating => Amavis::JSON::boolean($msginfo->originating),
    defined $os_fp && $os_fp ne '' ? (os_fp => $os_fp) : (),
    defined $actions_performed ? (actions_performed => $actions_performed): (),
    defined $checks_performed  ? (checks_performed  => $checks_performed) : (),
    $vn ? (virusnames => unique_ref($vn)) : (),
    $vn ? (av_scan => \%scanners_report) : (),
  # %spam_test_names  ? (tests => { %spam_test_names }) : (),
    !%spam_test_names ? () : (
       tests => [ sort keys %spam_test_names ],  # alphabetically
       tests_spam => \@test_names_spam_topdown,  # > 0, largest first
       tests_ham  => \@test_names_ham_bottomup,  # < 0, smallest first
    ),
    $msginfo->is_auto ? (is_auto_resp => $true) : (), # is an auto-response
    $msginfo->is_mlist? (is_mlist => $true) : (), # is a mailing list
    $msginfo->is_bulk ? (is_bulk  => $true) : (), # bulk or m.list or auto-resp
    @dkim_sigs_valid  ? (dkim_valid_sig => \@dkim_sigs_valid) : (),
    @dkim_sigs_new    ? (dkim_new_sig   => \@dkim_sigs_new)   : (),
    defined $dkim_author_sig ? (dkim_author_sig => $dkim_author_sig) : (),
    !@smtp_status_code_list ? () : (smtp_code => \@smtp_status_code_list),
    !@queued_as_list        ? () : (queued_as => \@queued_as_list),
    action => \@destiny_list,
    message =>  # a brief report
      sprintf("%s %s %s %s -> %s",
              $msginfo->log_id,  join(',', @destiny_list),
              $msginfo->setting_by_contents_category(\%ccat_display_names),
              $sender_smtp, join(',', @rcpt_smtp)),
    time_unix =>  # UNIX time to millisecond precision
      Amavis::JSON::numeric(sprintf("%.3f", $rx_time)),
  # time_mjd =>   # Modified Julian Day to millisecond precision
  #   Amavis::JSON::numeric(sprintf("%14.8f", $mjd)),
    '@timestamp' => iso8601_utc_timestamp($rx_time,undef,undef,1,1),
    time_iso_week_date => sprintf("%04d-W%02d-%d",
                            $iso8601_year,  # ISO week-numbering year
                            $iso8601_wn,    # ISO week number 1..53
                            iso8601_weekday($rx_time)), # 1..7, Mo=1, localtime
    !%elapsed ? () : (elapsed => \%elapsed),
  );
  if (%elapsed) {
    # last-minute update of total elapsed time, cast to numeric
    my $el = $result{elapsed};
    $el->{Total} = get_time_so_far();
    $el->{Amavis} = $el->{Total}-($el->{SpamCheck}||0)-($el->{VirusCheck}||0);
    $el->{$_} = Amavis::JSON::numeric(sprintf("%.3f",$el->{$_})) for keys %$el;
  }
  \%result;
}

# Last-minute update of total elapsed time
#
sub structured_report_update_time($) {
  my $report_ref = $_[0];
  if ($report_ref->{elapsed}) {
    # just Total, does not adjust $report_ref->{elapsed}{Amavis}
    $report_ref->{elapsed}{Total} =
      Amavis::JSON::numeric(sprintf("%.3f", get_time_so_far()));
  }
  $report_ref;
}

sub build_and_save_structured_report($$) {
  my($msginfo, $notification_type) = @_;
  if ($redis_storage &&
      $redis_logging_queue_size_limit && c('redis_logging_key') ) {
    do_log(5,'build_and_save_structured_report on %s', $notification_type);
    eval {  # protect the new code just in case
      $redis_storage->save_structured_report(
        structured_report($msginfo, $notification_type),
        c('redis_logging_key'), $redis_logging_queue_size_limit);
      1;
    } or do {
      chomp $@; do_log(-1, 'save_structured_report failed: %s', $@);
    };
  }
}

# Ensure we have $msginfo->$entity defined when we expect we'll need it,
#
sub ensure_mime_entity($) {
  my $msginfo = $_[0];
  my($ent,$mime_err);
  if (!defined($msginfo->mime_entity)) {
    my $msg = $msginfo->mail_text;
    if (IO::File->VERSION >= 1.10) {  # see mime_decode() for explanation
      my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
      $msg = $msg_str_ref  if ref $msg_str_ref;
    }
    ($ent,$mime_err) = mime_decode($msg, $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 = $_[0];
  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 (!$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, $type) = ($e->name_declared, $e->type_declared);
      next if !defined $type && defined $name &&
              ($name eq 'preamble' || $name eq 'epilogue');
      next if $e->type_short eq 'MAIL' && defined $type &&
              $type =~ m{^message/(?:rfc822|global)\z}si;
      $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, !$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;
    my $p0_report_type;
    $p0_report_type = $parts[0]->report_type  if @parts;
    $p0_report_type = lc $p0_report_type  if defined $p0_report_type;

    if (  @parts >= 2 && @parts <= 4  &&
          $t[0] eq 'multipart/report' &&                         # RFC 6522
        ( $t[2] eq 'message/delivery-status' ||                  # RFC 3464
          $t[2] eq 'message/global-delivery-status' ||           # RFC 6533
          $t[2] eq 'message/disposition-notification' ||         # RFC 3798
          $t[2] eq 'message/global-disposition-notification' ||  # RFC 6533
          $t[2] eq 'message/feedback-report'                     # RFC 5965
        ) &&
          defined $p0_report_type && $t[2] eq 'message/'.$p0_report_type &&
          $t[3] =~ m{^ (?: text/rfc822-headers |                 # RFC 6522
                           message/(?: rfc822-headers | global-headers |
                                       rfc822 | global | partial )) \z}xs
          # message/rfc822-headers and message/partial are 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 = $#parts; $is_true_bounce = 1;

    } elsif ( @parts == 5 &&
          $t[0]  eq 'multipart/report' &&
          $t[-2] eq 'message/delivery-status' &&
          defined $p0_report_type && $t[-2] eq 'message/'.$p0_report_type &&
          $t[-1] =~ m{^ (?: text/rfc822-headers |
                            message/(?: global-headers|rfc822|global )) \z}xs
       ) {  # almost standard DSN, has two leading plain text parts
      $bounce_type = 'DSN';  # BorderWare Security Platform
      $structure_type = 'standard ' . $bounce_type;
      $fname_ind = $#parts; $is_true_bounce = 1;

    } elsif (  @parts >= 2 && @parts <= 4  &&
          $t[0] eq 'multipart/report' &&
          $t[2] eq 'message/delivery-status' &&
          defined $p0_report_type && $t[2] eq 'message/'.$p0_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' &&
          defined $p0_report_type && $p0_report_type eq 'delivery-status' &&
          $t[-1] =~ m{^ (?: text/rfc822-headers |
                            message/(?: global-headers|rfc822|global )) \z}xs)
    { # 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] =~ m{^ (?: text/rfc822-headers |
                            message/(?: global-headers|rfc822|global|
                                        rfc822-headers )) \z}xs &&
        ( $rfc2822_from[0] =~ /^MAILER-DAEMON(?:\@|\z)/si ||
          $msginfo->get_header_field_body('subject') =~
                        /\b(?:Delivery Failure Notification|failure notice)\b/
        ) ) {
      # qmail, msn?, mailman, C/R
      $fname_ind = -1;
      $structure_type = 'multipart/mixed(' . $msginfo->is_bulk . ')';

    } elsif ( $msginfo->is_auto && $sender eq '' &&
                                # notify@yahoogroups.com notify@yahoogroupes.fr
              $rfc2822_from[0] =~ /^notify\@yahoo/si &&
              @parts >= 3 && @parts <= 5 &&
              $t[0] eq 'multipart/mixed' &&
              $t[-1] =~ m{^ (?: text/rfc822-headers |
                                message/(?: global-headers|rfc822|global ))
                          \z}xs ) {
      $fname_ind = -1;
      $structure_type = 'multipart/mixed(yahoogroups)';

    } elsif ( $msginfo->is_auto && $sender eq '' &&
              @parts == 1 && $t[0] ne 'multipart/report' &&
              $rfc2822_from[0] =~ /^(?:MAILER-DAEMON|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 && $sender eq '' &&
#             ( grep($_->recip_addr eq 'xxx@example.com',  # victim
#                    @{$msginfo->per_recip_data}) ) ) {
#     # nonstructured, possibly a non-standard bounce
#     $fname_ind = 0; $plaintext = 1; $is_true_bounce = 1;
#     $structure_type = 'nonstructured, unknown';
#     $bounce_type = 'INFO';

#   } elsif (@parts == 3 &&
#         $t[0] eq 'multipart/mixed' &&
#         $t[-1] eq 'application/octet-stream' &&
#         $parts[-1]->name_declared =~ /\.eml\z/) {
#     # MDaemon;  too permissive! test for postmaster or mailer-daemon ?
#     $fname_ind = -1;
#     $structure_type = 'multipart/mixed with binary .eml';
#   } 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 && defined $parts[$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: $!";
        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(1,"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 RFC 5322 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" || substr($ln,0,2) eq '--';
            } elsif ($ln =~ /^\s*$/ || substr($ln,0,2) eq '--') {
              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 = (); $curr_head = undef;
              }
            }
          }
        }
        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');
    }
  }
  $bounce_type = undef  if !$is_true_bounce;
  !$is_true_bounce ? () : (\%header_field,$bounce_type);
}

# obtain authserv-id from an Authentication-Results header field
#
sub parse_authentication_results($) {
  local($_) = $_[0];
  tr/\n//d; local($1); my $comm_lvl = 0; my $authservid;
  while (!/\G \z/gcsx) {
    if (                    /\G \( /gcsx) { $comm_lvl++ }
    elsif ($comm_lvl > 0 && /\G \) /gcsx) { $comm_lvl-- }
    elsif ($comm_lvl > 0 && /\G(?: \\ . | [^()\\]+ )/gcsx) {}
    elsif (!$comm_lvl && /\G [ \t]+ /gcsx) {}
    elsif (!$comm_lvl && m{\G ( [^\x00-\x20\x7F()<>,;:"/?=\[\]\@\\]+ ) }gcsx)
      { $authservid = $1; last }  # token
    elsif (!$comm_lvl && m{\G " ( (?: \\ [\t\x20-\x7E] |
                                      [\t\x20\x21\x23-\x5B\x5D-\x7E] |
                                      [\xC0-\xF4][\x80-\xBF]{1,3}
                                  )* ) " }gcsx)  # qcontent (relaxed for UTF-8)
      { $authservid = $1; $authservid =~ s{\\(.)}{$1}gsx; last }
    else { last };  # syntax error
  }
  $authservid;
}

sub add_forwarding_header_edits_common($$$$$$) {
  my($msginfo, $hdr_edits, $hold, $any_undecipherable,
     $virus_presence_checked, $spam_presence_checked) = @_;
  my $use_our_hdrs = cr('prefer_our_added_header_fields');
  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 (defined $hold && $hold ne '') {
      $hdr_edits->add_header('X-Amavis-Hold', $hold);
      do_log(0, "Inserting header field: X-Amavis-Hold: %s", $hold);
    }
  }
  if (c('enable_dkim_verification') &&
      $allowed_hdrs && $allowed_hdrs->{lc('Authentication-Results')}) {

    # RFC 7601: For security reasons, any MTA conforming to this specification
    # MUST delete any discovered instance of this header field that claims,
    # by virtue of its authentication service identifier, to have been added
    # within its trust boundary but that did not come directly from another
    # trusted MTA. [...] For simplicity and maximum security, a border MTA
    # could remove all instances of this header field on mail crossing into
    # its trust boundary. [...] (Hmmm...!?) However, an MTA MUST remove such
    # a header field if the [SMTP] connection relaying the message is not from
    # a trusted internal MTA.
    my $authservid = c('myauthservid');
    $authservid = c('myhostname') if !defined $authservid || $authservid eq '';
    $authservid = idn_to_ascii($authservid);
    # delete header field if its authserv-id matches ours or is unparseable
    $hdr_edits->edit_header('Authentication-Results',
      sub { my($h,$b) = @_;
            my $aid = parse_authentication_results($b);
            if (defined $aid) { $aid =~ s{/.*}{}s; $authservid =~ s{/.*}{}s };
            !defined $aid || lc($aid) eq lc($authservid) ? (undef,0) : ($b,1);
           } );
    # [...] For simplicity and maximum security, a border MTA could remove all
    # instances of this header field on mail crossing into its trust boundary.
    # $hdr_edits->delete_header('Authentication-Results');
  }

  # example on how to remove subject tag inserted by some other MTA:
  # $hdr_edits->edit_header('Subject',
  #          sub { my($h,$s)=@_; $s=~s/^\s*\*\*\* Spam \*\*\*(.*)/$1/si; $s });
  if ($extra_code_antivirus) {
  # $hdr_edits->delete_header('X-Amavis-Alert');  # it does not hurt to keep it
    my $am_hdr_fld_head = c('X_HEADER_TAG');
    my $am_hdr_fld_body = c('X_HEADER_LINE');
    $hdr_edits->delete_header($am_hdr_fld_head)
      if c('remove_existing_x_scanned_headers') &&
         defined $am_hdr_fld_body && $am_hdr_fld_body ne '' &&
         defined $am_hdr_fld_head && $am_hdr_fld_head =~ /^[!-9;-\176]+\z/;
  }
  my $myhost = c('myhostname');
  $myhost = $msginfo->smtputf8 ? idn_to_utf8($myhost) : idn_to_ascii($myhost);
  for ('X-Spam-Checker-Version') {
    if ($extra_code_antispam_sa &&
        $allowed_hdrs && $allowed_hdrs->{lc $_} &&
        $use_our_hdrs && $use_our_hdrs->{lc $_}) {
      no warnings 'once';
      $hdr_edits->add_header($_,
        sprintf("SpamAssassin %s (%s) on %s",
                Mail::SpamAssassin::Version(),
                $Mail::SpamAssassin::SUB_VERSION, $myhost));
    }
  }
  $hdr_edits;
}

# Prepare header edits for the first not-yet-done recipient.
# Inspect remaining recipients, returning the list of recipient objects
# that are receiving the same set of header edits (so the message may be
# delivered to them in one SMTP transaction).
#
sub add_forwarding_header_edits_per_recip($$$$$$$) {
  my($msginfo, $hdr_edits, $hold, $any_undecipherable,
     $virus_presence_checked, $spam_presence_checked, $filter) = @_;
  my(@recip_cluster);
  my(@per_recip_data) = grep(!$_->recip_done && (!$filter || &$filter($_)),
                             @{$msginfo->per_recip_data});
  my $per_recip_data_len = scalar(@per_recip_data);
  my $first = 1; my $cluster_key; my $cluster_full_spam_status;
  my $use_our_hdrs = cr('prefer_our_added_header_fields');
  my $allowed_hdrs = cr('allowed_added_header_fields');
  my $x_header_tag = c('X_HEADER_TAG');
  my $adding_x_header_tag =
    $x_header_tag =~ /^[!-9;-\176]+\z/ && c('X_HEADER_LINE') ne '' &&
    $allowed_hdrs && $allowed_hdrs->{lc($x_header_tag)};
  my $mail_id = $msginfo->mail_id;
  my $os_fp = $msginfo->client_os_fingerprint;
  if (defined($os_fp) && $os_fp ne '' && $msginfo->client_addr ne '')
    { $os_fp .= ', ['. $msginfo->client_addr . ']:' . $msginfo->client_port }
  my(@headers_to_be_removed);  # header fields that may need to be removed
  if ($extra_code_antispam) {
    @headers_to_be_removed = qw(
        X-Spam-Status X-Spam-Level X-Spam-Flag X-Spam-Score
        X-Spam-Report X-Spam-Checker-Version X-Spam-Tests);
    @headers_to_be_removed =
      grep(defined $msginfo->get_header_field2($_), @headers_to_be_removed);
  }

  my $header_tagged = 0;
  for my $r (@per_recip_data) {
    my $spam_level    = $r->spam_level;
    my $recip         = $r->recip_addr;
    my $is_local      = $r->recip_is_local;
    my $blacklisted   = $r->recip_blacklisted_sender;
    my $whitelisted   = $r->recip_whitelisted_sender;
    my $bypassed      = $r->bypass_spam_checks;
    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);
    my $do_tag_badh   = $r->is_in_contents_category(CC_BADH);
    my $do_tag_banned = $r->is_in_contents_category(CC_BANNED);
    my $do_tag_virus  = $r->is_in_contents_category(CC_VIRUS);
    my $mail_mangle   = $r->mail_body_mangle;
    my $do_tag_virus_checked =
                        $adding_x_header_tag && !$r->bypass_virus_checks;
    my $do_rem_hdr = @headers_to_be_removed &&
                     lookup2(0,$recip,ca('remove_existing_spam_headers_maps'));
    my $do_p0f = $is_local && defined($os_fp) && $os_fp ne '' &&
               $allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-OS-Fingerprint')};
    my $pp_age;
    if ($allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-PenPals')}) {
      $pp_age = $r->recip_penpals_age;
      $pp_age = format_time_interval($pp_age)  if defined $pp_age;
    }
    my($tag_level,$tag2_level,$subject_tag);
    if ($extra_code_antispam && !$bypassed) {
      $tag_level  = lookup2(0,$recip, ca('spam_tag_level_maps'));
      $tag2_level = lookup2(0,$recip, ca('spam_tag2_level_maps'));
    }
    if ($is_local) {   #  || c('warn_offsite')
      my(@subj_maps_pairs) = $r->setting_by_main_contents_category_all(
                                               cr('subject_tag_maps_by_ccat'));
      for my $pair (@subj_maps_pairs) {
        my($cc,$map_ref) = @$pair;
        next  if !ref($map_ref);
        $subject_tag = lookup2(0,$recip,$map_ref);
        # take the first nonempty string
        last  if defined $subject_tag && $subject_tag ne '';
      }
    }
    my $myhost = c('myhostname');
    $myhost = $msginfo->smtputf8 ? idn_to_utf8($myhost) :idn_to_ascii($myhost);
    $subject_tag = ''  if !defined $subject_tag;
    if ($subject_tag ne '') {  # expand subject template
      # just implement a small subset of macro-lookalikes, not true macro calls
      # btw, the '0+' is there to trim trailing zeroes
      $subject_tag =~
       s{_(SCORE|REQD|YESNO|YESNOCAPS|HOSTNAME|DATE|U|LOGID|MAILID)_}
        {  $1 eq 'SCORE'     ? (0+sprintf("%.3f",$spam_level))
         : $1 eq 'REQD'      ? (!defined($tag2_level) ? '-' :
                                0+sprintf("%.3f",$tag2_level))
         : $1 eq 'YESNO'     ? ($do_tag2 ? 'Yes' : 'No')
         : $1 eq 'YESNOCAPS' ? ($do_tag2 ? 'YES' : 'NO')
         : $1 eq 'HOSTNAME'  ? $myhost   #** characters or octets?
         : $1 eq 'DATE'      ? rfc2822_timestamp($msginfo->rx_time)
         : $1 eq 'U'         ? iso8601_utc_timestamp($msginfo->rx_time)
         : $1 eq 'LOGID'     ? $msginfo->log_id
         : $1 eq 'MAILID'    ? $mail_id||''
         : '_'.$1.'_' }xgse;
    }

    # normalize
    $_ = $_?1:0  for ($do_tag_virus_checked, $do_tag_virus, $do_tag_banned,
                      $do_tag_badh, $do_tag, $do_tag2, $do_p0f, $do_rem_hdr,
                      $is_local);
    my($spam_level_bar, $full_spam_status);
    if ($is_local && ($do_tag || $do_tag2)) {  # prepare status and level bar
      # spam-related header fields should _not_ be inserted for:
      #  - nonlocal recipients (outgoing mail), as a matter of courtesy
      #    to our users;
      #  - recipients matching bypass_spam_checks: even though spam checking
      #    may have been done for other reasons, these recipients do not expect
      #    such header fields, so let's pretend the check has not been done
      #    and not insert spam-related header fields for them;
      #  - everyone when the spam level is below the tag level
      #    or the sender was whitelisted and tag level is below -10
      #    (undefined tag level is treated as lower than any spam score).
      my $autolearn_status = $msginfo->supplementary_info('AUTOLEARN');
      my $slc = c('sa_spam_level_char');
      if (defined $slc && $slc ne '') {
        my $bar_len = $whitelisted || $bypassed ? 0 : $blacklisted ? 64
                    : !defined $spam_level ? 0
                    : $spam_level > 64 ? 64 : $spam_level;
        $spam_level_bar = $bar_len < 1 ? '' : $slc x int $bar_len;
      }
      my $spam_tests = $r->spam_tests;
      $spam_tests = !$spam_tests ? '' : join(',',map($$_,@$spam_tests));
      # allow header field wrapping at any comma
      my $s = $spam_tests;  $s =~ s/,/,\n /g;
      $full_spam_status = sprintf(
        "%s,\n score=%s\n %s%s%stests=[%s]\n autolearn=%s",
        $do_tag2 ? 'Yes' : 'No',
        !defined $spam_level ? 'x' : 0+sprintf("%.3f",$spam_level),
        !defined $tag_level || $tag_level eq '' ? ''
                                   : sprintf("tagged_above=%s\n ",$tag_level),
        !defined $tag2_level  ? '' : sprintf("required=%s\n ",  $tag2_level),
        join('', $blacklisted ? "BLACKLISTED\n " : (),
                 $whitelisted ? "WHITELISTED\n " : ()),
        $s, $autolearn_status||'unavailable');
    }

    my $key = join("\000", map {defined $_ ? $_ : ''} (
      $do_tag_virus_checked, $do_tag_virus, $do_tag_banned, $do_tag_badh,
      $do_tag && $is_local, $do_tag2 && $is_local, $subject_tag, $do_rem_hdr,
      $spam_level_bar, $full_spam_status, $mail_mangle, $do_p0f, $pp_age) );
    if ($first) {
      if (ll(4)) {
        my $sl = !defined($spam_level) ? 'x'
                   : 0+sprintf("%.3f",$spam_level);  # trim fraction
        do_log(4, "headers CLUSTERING: NEW CLUSTER <%s>: score=%s, ".
          "tag=%s, tag2=%s, local=%s, bl=%s, s=%s, mangle=%s",  $recip,
          $sl, $do_tag, $do_tag2, $is_local, $blacklisted, $subject_tag,
          $mail_mangle);
      }
      $cluster_key = $key; $cluster_full_spam_status = $full_spam_status;
    } elsif ($key eq $cluster_key) {
      do_log(5,"headers CLUSTERING: <%s> joining cluster", $recip);
    } else {
      do_log(5,"headers CLUSTERING: skipping <%s> (t=%s, t2=%s, r=%s, l=%s)",
               $recip,$do_tag,$do_tag2,$do_rem_hdr,$is_local);
      next;  # this recipient will be handled in some later pass
    }

    if ($first) {  # insert header fields required for the new cluster
      my(%header_field_provided);  # mainly applies to spam header fields
      if ($do_rem_hdr) {
        $hdr_edits->delete_header($_)  for @headers_to_be_removed;
      }
      if ($is_local && defined $msginfo->quarantined_to && defined $mail_id) {
        $hdr_edits->add_header('X-Quarantine-ID', '<'.$mail_id.'>')
          if $allowed_hdrs && $allowed_hdrs->{lc('X-Quarantine-ID')};
      }
      if ($mail_mangle) {  # mail body modified, invalidates DKIM signatures
        if ($allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-Modified')}) {
          $hdr_edits->add_header('X-Amavis-Modified',
                sprintf("Mail body modified (%s) - %s",
                  length($mail_mangle) > 1 ? "using $mail_mangle" : "defanged",
                  $myhost ));
        }
      }
      if ($do_tag_virus_checked) {
        $hdr_edits->add_header(c('X_HEADER_TAG'), c('X_HEADER_LINE'));
      }
      if ($allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-Alert')}) {
        if ($do_tag_virus) {
          my $virusname_list = $msginfo->virusnames;
          $hdr_edits->add_header('X-Amavis-Alert',
            "INFECTED, message contains virus: " .
            (!$virusname_list ? '' : join(", ",@$virusname_list)) );
          $header_tagged = 1;
        }
        if ($do_tag_banned) {
          $hdr_edits->add_header('X-Amavis-Alert',
                       'BANNED, message contains ' . $r->banning_reason_short);
          $header_tagged = 1;
        }
        if ($do_tag_badh) {
          $hdr_edits->add_header('X-Amavis-Alert',
                       'BAD HEADER SECTION, ' . $bad_headers[0]);
        # $header_tagged = 1;  # not this one, it is mostly harmless
        }
      }

      if ($is_local && $allowed_hdrs && $use_our_hdrs) {
        for ('X-Spam-Checker-Version') {
          if ($extra_code_antispam_sa &&
              $allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
            # a hack instead of making %header_field_provided global:
            # just mark it as already provided, this header field was
            # already inserted by add_forwarding_header_edits_common()
            $header_field_provided{lc $_} = 1;
          }
        }
        for ('X-Spam-Flag') {
          if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
            $hdr_edits->add_header($_, $do_tag2 ? 'YES' : 'NO')  if $do_tag;
            $header_field_provided{lc $_} = 1;
            $header_tagged = 1  if $do_tag2;  # SPAMMY
          }
        }
        for ('X-Spam-Score') {
          if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
            if ($do_tag) {
              my $score = 0+$spam_level;
              $score = max(64,$score)  if $blacklisted;  # not below 64 if bl
              $score = min( 0,$score)  if $whitelisted;  # not above  0 if wl
              $hdr_edits->add_header($_, 0+sprintf("%.3f",$score));
            }
            $header_field_provided{lc $_} = 1;
          }
        }
        for ('X-Spam-Level') {
          if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
            if ($do_tag && defined $spam_level_bar) {
              $hdr_edits->add_header($_, $spam_level_bar);
            }
            $header_field_provided{lc $_} = 1;
          }
        }
        for ('X-Spam-Status') {
          if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
            $hdr_edits->add_header($_, $full_spam_status, 1)  if $do_tag;
            $header_field_provided{lc $_} = 1;
          }
        }
        for ('X-Spam-Report') {
          # SA reports may contain any octet, i.e. 8-bit data from a mail
          # that is reported by a matching rule; no charset is associated, so
          # it doesn't make sense to RFC 2047 -encode it, so just sanitize it
          if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
            if ($do_tag2) {
              my $report = $r->spam_report;
              $report = $msginfo->spam_report  if !defined $report;
              if (defined $report && $report ne '') {
                $hdr_edits->add_header($_, "\n".sanitize_str($report,1), 2);
              }
            }
            $header_field_provided{lc $_} = 1;
          }
        }
      }

      if ($is_local && $allowed_hdrs) {
        # add remaining header fields as provided by spam scanners
        my $sa_header = $msginfo->supplementary_info(
                          $do_tag2 ? 'ADDEDHEADERSPAM' : 'ADDEDHEADERHAM');
        if (defined $sa_header && $sa_header ne '') {
          for my $hf (split(/^(?![ \t])/m, $sa_header, -1)) {
            local($1,$2);
            if ($hf =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s) {
              my($hf_name,$hf_body) = ($1,$2);
              my $hf_name_lc = lc $hf_name; chomp($hf_body);
              if ($header_field_provided{$hf_name_lc}) {
                do_log(5,'fwd: scanner provided a header field %s, but we '.
                         'preferred our own', $hf_name);
              } elsif (!$allowed_hdrs->{$hf_name_lc}) {
                do_log(5,'fwd: scanner provided a header field %s, inhibited '.
                         'by %%allowed_added_header_fields', $hf_name);
              } else {
                do_log(5,'fwd: scanner provided a header field %s, inserting',
                         $hf_name);
                $hdr_edits->add_header($hf_name, $hf_body, 2);
              }
            }
          }
        }
        for my $pair ( ['DSPAMRESULT',    'X-DSPAM-Result'],
                       ['DSPAMSIGNATURE', 'X-DSPAM-Signature'],
                       ['CRM114STATUS',   'X-CRM114-Status'],
                       ['CRM114CACHEID',  'X-CRM114-CacheID'] ) {
          my($suppl_attr_name, $hf_name) = @$pair;
          my $suppl_attr_val = $msginfo->supplementary_info($suppl_attr_name);
          if (defined $suppl_attr_val && $suppl_attr_val ne '') {
            if (!$allowed_hdrs->{lc $hf_name}) {
              do_log(5,'fwd: scanner provided a tag/field %s, '.
                       'inhibited by %%allowed_added_header_fields', $hf_name);
            } else {
              do_log(5,'fwd: scanner provided a tag/field %s, '.
                       'inserting', $hf_name);
              $hdr_edits->add_header($hf_name,
                                     sanitize_str($suppl_attr_val), 2);
            }
          }
        }
      }

      $hdr_edits->add_header('X-Amavis-OS-Fingerprint',
                             sanitize_str($os_fp))  if $do_p0f;
      $hdr_edits->add_header('X-Amavis-PenPals',
                             'age '.$pp_age)  if defined $pp_age;
      if ($is_local && c('enable_dkim_verification') &&
          $allowed_hdrs && $allowed_hdrs->{lc('Authentication-Results')}) {
        for my $h (Amavis::DKIM::generate_authentication_results($msginfo,0)) {
          $hdr_edits->add_header('Authentication-Results', $h, 1);
        }
      }
      if ($subject_tag ne '') {
        if (defined $msginfo->get_header_field2('subject')) {
          $hdr_edits->edit_header('Subject',
                        sub { local($1,$2);
                              $_[1] =~ /^([ \t]?)(.*)\z/s; my $subj = $2;
                              $subj = safe_decode_mime($subj);  # to characters
                              $subj =~ s/\Q$subject_tag\E//sg
                                if length($subject_tag) >= 3;  # precaution
                              safe_decode_utf8(
                                ' ' . safe_encode_utf8($subject_tag) .
                                      safe_encode_utf8($subj));
                            } );
        } else {  # no Subject header field present, insert one
          $subject_tag =~ s/[ \t]+\z//;  # trim
          $hdr_edits->add_header('Subject', $subject_tag);
          do_log(0,"INFO: no existing header field 'Subject', inserting it");
        }
        $header_tagged = 1;
      }
      if ($allowed_hdrs && $allowed_hdrs->{lc('Received')} &&
          grep($_->delivery_method ne '', @{$msginfo->per_recip_data})) {
        $hdr_edits->add_header('Received',
                               make_received_header_field($msginfo,1), 1);
      }
    }  # if $first
    push(@recip_cluster,$r);  $first = 0;
    $r->recip_tagged(1)  if $header_tagged;

    my $delim = c('recipient_delimiter');
    if ($is_local) {
      # rewrite/replace recipient addresses, possibly with multiple recipients
      my $rewrite_map = $r->setting_by_contents_category(
                                              cr('addr_rewrite_maps_by_ccat'));
      my $rewrite = !ref $rewrite_map ? undef : lookup2(0,$recip,$rewrite_map);
      if ($rewrite ne '') {
        my(@replacements) =
          map(/^\s*(\S.*?)\s*\z/s ? $1 : (), split(/,/, $rewrite));
        if (@replacements) {
          my $repl_addr = shift @replacements;
          my $modif_addr = replace_addr_fields($recip,$repl_addr,$delim);
          ll(5) && do_log(5,"addr_rewrite_maps: replacing <%s> by <%s>",
                            $recip,$modif_addr);
          $r->recip_addr_modified($modif_addr);
          for my $bcc (@replacements) {  # remaining addresses are extra Bcc
            my $new_addr = replace_addr_fields($recip,$bcc,$delim);
            ll(5) && do_log(5,"addr_rewrite_maps: recip <%s>, adding <%s>",
                              $recip,$new_addr);
            # my $clone = $r->clone;
            # $clone->recip_addr_modified($new_addr);
          }
        }
        $r->dsn_orcpt(join(';', orcpt_decode(';'.$r->recip_addr_smtp)))
          if !defined $r->dsn_orcpt;
      }
    }
    if ($is_local && defined $delim && $delim ne '') {
      # append address extensions to mailbox names if desired
      my $ext_map = $r->setting_by_contents_category(
                                            cr('addr_extension_maps_by_ccat'));
      my $ext = !ref($ext_map) ? undef : lookup2(0,$recip,$ext_map);
      if ($ext ne '') {
        $ext = substr($delim,0,1) . $ext;
        my $orig_extension;  my($localpart,$domain) = split_address($recip);
        ($localpart,$orig_extension) = split_localpart($localpart,$delim)
          if c('replace_existing_extension');  # strip existing extension
        my $new_addr = $localpart.$ext.$domain;
        if (ll(5)) {
          if (!defined($orig_extension)) {
            do_log(5, "appending addr ext '%s', giving '%s'", $ext,$new_addr);
          } else {
            do_log(5, "replacing addr ext '%s' by '%s', giving '%s'",
                       $orig_extension,$ext,$new_addr);
          }
        }
        # RFC 3461: If no ORCPT parameter was present in the RCPT command when
        # the message was received, an ORCPT parameter MAY be added to the
        # RCPT command when the message is relayed. If an ORCPT parameter is
        # added by the relaying MTA, it MUST contain the recipient address
        # from the RCPT command used when the message was received by that MTA.
        $r->dsn_orcpt(join(';', orcpt_decode(';'.$r->recip_addr_smtp)))
          if !defined $r->dsn_orcpt;
        $r->recip_addr_modified($new_addr);
        $r->recip_tagged(1);
      }
    }
  }
  my $done_all;
  if (@recip_cluster == $per_recip_data_len) {
    do_log(5,"headers CLUSTERING: done all %d recips in one go",
             $per_recip_data_len);
    $done_all = 1;
  } else {
    ll(4) && do_log(4, "headers CLUSTERING: got %d recips out of %d: %s",
                       scalar(@recip_cluster), $per_recip_data_len,
                       join(', ', map($_->recip_addr_smtp, @recip_cluster)));
  }
  if (ll(2) && defined($cluster_full_spam_status) && @recip_cluster) {
    my $s = $cluster_full_spam_status; $s =~ s/\n[ \t]/ /g;
    do_log(2, "spam-tag, %s -> %s, %s", $msginfo->sender_smtp,
              join(',', map($_->recip_addr_smtp, @recip_cluster)), $s);
  }
  ($hdr_edits, \@recip_cluster, $done_all);
}

# Mail body mangling (defanging, sanitizing or adding disclaimers);
# Prepare mail body replacement for the first recipient
# in the @$per_recip_data list (which contains a subset of recipients
# with the same mail edits, to be dispatched next as one message)
#
sub prepare_modified_mail($$$$) {
  my($msginfo, $hold, $any_undecipherable, $per_recip_data) = @_;
  my $body_modified = 0;
  for my $r (@$per_recip_data) {  # a subset of recipients!
    my $recip = $r->recip_addr;
    my $mail_mangle = $r->mail_body_mangle;
    my $actual_mail_mangle;
    if (!$mail_mangle) {
      # skip
    } elsif ($mail_mangle =~ /^(?:null|nulldisclaimer)\z/i) {  # for testing
      $body_modified = 1; # pretend mail was modified while actually it was not
      $msginfo->mail_text_str(undef);
      section_time('mangle-'.$mail_mangle);
    } elsif (( lc $mail_mangle ne 'attach' &&
               ($enable_anomy_sanitizer || $altermime ne '') )
             || $mail_mangle =~ /^(?:anomy|altermime|disclaimer)\z/i) {
      do_log(2,"mangling by: %s, <%s>", $mail_mangle,$recip);
      my $orig_fn = $msginfo->mail_text_fn;
      my $repl_fn = $msginfo->mail_tempdir . '/email-repl.txt';
      my $file_position = $msginfo->skip_bytes;
      my $out_fh; my $repl_size; my $eval_stat;
      eval {
        $out_fh = IO::File->new;
        $out_fh->open($repl_fn, O_CREAT|O_EXCL|O_WRONLY, 0640)
          or die "Can't create file $repl_fn: $!";
        binmode($out_fh,':bytes') or die "Can't cancel :utf8 mode: $!";
        if (lc $mail_mangle eq 'anomy' && !$enable_anomy_sanitizer) {
          die 'Anomy requested, but $enable_anomy_sanitizer is false';
        } elsif ($enable_anomy_sanitizer &&
                 $mail_mangle !~ /^(?:altermime|disclaimer)\z/i) {
          $actual_mail_mangle = 'anomy';
          my $inp_fh = $msginfo->mail_text;
          $inp_fh->seek($file_position, 0) or die "Can't rewind mail file: $!";
          $enable_anomy_sanitizer  or die "Anomy disabled: $mail_mangle";
          my(@scanner_conf); my $e; my $engine = Anomy::Sanitizer->new;
          if ($e = $engine->error) { die $e }
          $engine->configure(@scanner_conf, @{ca('anomy_sanitizer_args')});
          if ($e = $engine->error) { die $e }
          my $ret = $engine->sanitize($inp_fh, $out_fh);
          if ($e = $engine->error) { die $e }
          # close flushes buffers, makes it possible to check file size below
          $out_fh->close or die "Can't close file $repl_fn: $!";
          # re-open as read-only
          $out_fh = IO::File->new;
          $out_fh->open($repl_fn,'<') or die "Can't open file $repl_fn: $!";
          binmode($out_fh,':bytes') or die "Can't cancel :utf8 mode: $!";
        } else {  # use altermime for adding disclaimers or defanging
          $actual_mail_mangle = 'altermime';
          $altermime ne ''  or die "altermime not available: $mail_mangle";
          # prepare arguments to altermime
          my(@altermime_args); my $disclaimer_options;
          if (lc($mail_mangle) ne 'disclaimer') {  # defang: no by-sender opts.
            @altermime_args = @{ca('altermime_args_defang')};
          } else {  # disclaimer
            @altermime_args = @{ca('altermime_args_disclaimer')};
            my $opt_maps = ca('disclaimer_options_bysender_maps');
            if ($opt_maps && @$opt_maps &&  # by sender options?
                grep(/_OPTION_/,@altermime_args))
            { # determine whose by-sender options to use
              my $fm = $msginfo->rfc2822_from;
              my $rf = $msginfo->rfc2822_resent_from;
              my $rs = $msginfo->rfc2822_resent_sender;
              my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
              my(@rfc2822_resent_from, @rfc2822_resent_sender);
              @rfc2822_resent_from   = @$rf  if defined $rf;
              @rfc2822_resent_sender = @$rs  if defined $rs;
              # see comments in dkim_make_signatures
              my(@search_list);  # collects candidate originator addresses
              # author addresses go first
              push(@search_list, map([$_,'2822.From'], @rfc2822_from));
              # merge Resent-From and Resent-Sender addresses by resent blocks
              while (@rfc2822_resent_from || @rfc2822_resent_sender) {
                while (@rfc2822_resent_from) {
                  my $addr = shift(@rfc2822_resent_from);
                  last  if !defined $addr;  # undef delimits resent blocks
                  push(@search_list, [$addr, '2822.Resent-From']);
                }
                while (@rfc2822_resent_sender) {
                  my $addr = shift(@rfc2822_resent_sender);
                  last  if !defined $addr;  # undef delimits resent blocks
                  push(@search_list, [$addr, '2822.Resent-Sender']);
                }
              }
              push(@search_list, [$msginfo->rfc2822_sender, '2822.Sender']);
              push(@search_list, [$msginfo->sender,         '2821.mail_from']);
              #
              # find disclaimer options pertaining to the
              # most appropriate originator address
              my(%addr_seen);
              for my $pair (@search_list) {
                my($addr,$addr_src) = @$pair;
                next if !defined($addr) || $addr eq '';
                next if $addr_seen{$addr}++;
                do_log(5,"disclaimer options lookup (%s) %s", $addr_src,$addr);
                next if !lookup2(0,$addr, ca('local_domains_maps'));
                my($opt,$matchingkey) = lookup2(0,$addr,$opt_maps);
                if (defined $opt) {
                  $disclaimer_options = $opt;
                  do_log(3,"disclaimer options pertaining to (%s) %s: %s",
                            $addr_src, $addr, $disclaimer_options);
                  last;
                }
              }
              $disclaimer_options = ''  if !defined $disclaimer_options;
              s/_OPTION_/$disclaimer_options/gs  for @altermime_args;
            }
          }
          my $msg = $msginfo->mail_text;
          my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
          $msg = $msg_str_ref  if ref $msg_str_ref;
          # copy original mail to $repl_fn, altermime can't handle stdin well
          if (!defined $msg) {
            # empty mail
          } elsif (ref $msg eq 'SCALAR') {
            # do it in chunks, saves memory, cache friendly
            while ($file_position < length($$msg)) {
              $out_fh->print(substr($$msg,$file_position,16384))
                or die "Error writing to $repl_fn: $!";
              $file_position += 16384;  # may overshoot, no problem
            }
          } elsif ($msg->isa('MIME::Entity')) {
            die "sanitizing a MIME::Entity object is not implemented";
          } else {
            $msg->seek($file_position,0) or die "Can't rewind mail file: $!";
            my($nbytes,$buff);
            while (($nbytes = $msg->read($buff,16384)) > 0) {
              $out_fh->print($buff) or die "Error writing to $repl_fn: $!";
            }
            defined $nbytes or die "Error reading mail file: $!";
            undef $buff;  # release storage
          }
          $out_fh->close or die "Can't close file $repl_fn: $!";
          undef $out_fh;
          my($proc_fh,$pid) = run_command(undef, '&1', $altermime,
                                          "--input=$repl_fn", @altermime_args);
          my($r,$status) = collect_results($proc_fh,$pid,$altermime,16384,[0]);
          undef $proc_fh; undef $pid;
          do_log(2,"program %s said: %s",
                   $altermime, $$r)  if ref $r && $$r ne '';
          $status == 0 or die "Program $altermime failed: $status, $$r";
          $out_fh = IO::File->new;
          $out_fh->open($repl_fn,'<') or die "Can't open file $repl_fn: $!";
          binmode($out_fh,':bytes') or die "Can't cancel :utf8 mode: $!";
        }
        my $errn = lstat($repl_fn) ? 0 : 0+$!;
        if ($errn) { die "Replacement $repl_fn inaccessible: $!" }
        else { $repl_size = 0 + (-s _) }
        1;
      } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat };
      if (defined $eval_stat || !defined $repl_size || $repl_size <= 0) {
        # handle failure
        my $msg = defined $eval_stat ? $eval_stat
                                  : sprintf("replacement size %d", $repl_size);
        do_log(-1,"mangling by %s failed: %s, mail will pass unmodified",
                  $actual_mail_mangle, $msg);
        if (defined $out_fh) {
          $out_fh->close or do_log(-1,"Can't close %s: %s", $repl_fn,$!);
          undef $out_fh;
        }
        unlink($repl_fn) or do_log(-1,"Can't remove %s: %s", $repl_fn,$!);
        if ($actual_mail_mangle eq 'altermime') {  # check for leftover files
          my $repl_tmp_fn = $repl_fn . '.tmp';  # altermime's temporary file
          my $errn = lstat($repl_tmp_fn) ? 0 : 0+$!;
          if ($errn == ENOENT) {}  # fine, does not exist
          elsif ($errn) {
            do_log(-1,"Temporary file %s is inaccessible: %s",$repl_tmp_fn,$!);
          } else {  # cleanup after failing altermime
            unlink($repl_tmp_fn)
              or do_log(-1,"Can't remove %s: %s",$repl_tmp_fn,$!);
          }
        }
      } else {
        do_log(1,"mangling by %s (%s) done, new size: %d, orig %d bytes",
                 $actual_mail_mangle, $mail_mangle,
                 $repl_size, $msginfo->msg_size);
        # don't close or delete the original file, we'll still need it
        $msginfo->mail_text($out_fh); $msginfo->mail_text_fn($repl_fn);
        $msginfo->mail_text_str(undef); $msginfo->body_start_pos(undef);
        $msginfo->skip_bytes(0);
        $body_modified = 1;
      }
      section_time('mangle-'.$actual_mail_mangle);

    } else {  # 'attach' (default) - poor-man's defanging of dangerous contents
      do_log(2,"mangling by built-in defanger: %s, <%s>", $mail_mangle,$recip);
      $actual_mail_mangle = 'attach';
      my(@explanation); my $spam_summary_inserted = 0;
      my(@df_pairs) =
        $r->setting_by_main_contents_category_all(cr('defang_maps_by_ccat'));
      for my $pair (@df_pairs) {  # collect all defanging reasons that apply
        my($cc,$mangle_map_ref) = @$pair;
        my $df = !defined($mangle_map_ref) ? undef
                 : !ref($mangle_map_ref) ? $mangle_map_ref  # compatibility
                 : lookup2(0,$recip,$mangle_map_ref, Label=>'Mangling2');
        # the $r->mail_body_mangle happens to be the first noteworthy $df
        do_log(4,'defang? ccat "%s": %s', $cc,$df);
        next  if !$df;
        my $ccm = ccat_maj($cc);
        if ($ccm==CC_VIRUS) {
          my $virusname_list = $msginfo->virusnames;
          push(@explanation, 'WARNING: contains virus ' .
               (!$virusname_list ? '' : join(", ",@$virusname_list)));
        }
        if ($ccm==CC_BANNED) {
          push(@explanation,
               "WARNING: banning rules detected suspect part(s),\n".
               "do not open unless you know what you are doing");
        }
        if ($ccm==CC_UNCHECKED) {
          if (defined $hold && $hold ne '') {
            push(@explanation,
                 "WARNING: NOT CHECKED FOR VIRUSES (mail bomb?):\n  $hold");
          } elsif ($any_undecipherable) {
            push(@explanation, "WARNING: contains undecipherable part");
          }
        }
        if ($ccm==CC_BADH) {
          my $bad = join(' ',@bad_headers);
          substr($bad,1000) = '...'  if length($bad) > 1000;
          push(@explanation, split(/\n/,
                     wrap_string('WARNING: bad headers - '.$bad, 78,'',' ') ));
        }
        push(@explanation, 'WARNING: oversized')  if $ccm==CC_OVERSIZED;
        if (!$spam_summary_inserted &&  # can be both CC_SPAMMY and CC_SPAM
            ($ccm==CC_SPAM || $ccm==CC_SPAMMY)) {
          push(@explanation, split(/\n/, $msginfo->spam_summary));
          $spam_summary_inserted = 1;
        }
      }
      my $s = join(' ',@explanation);
      do_log(1, "DEFANGING MAIL: %s",
                length($s) <= 150 ? $s : substr($s,0,150-3).'[...]');
      for (@explanation) { substr($_,100-3) = '...'  if length($_) > 100 }
      $_ .= "\n"  for (@explanation); # append newlines
      my $d = defanged_mime_entity($msginfo,\@explanation);
      $msginfo->mail_text($d);  # substitute mail with a rewritten version
      $msginfo->mail_text_fn(undef);  # remove filename information
      $msginfo->mail_text_str(undef); $msginfo->body_start_pos(undef);
      $msginfo->skip_bytes(0);
      $body_modified = 1; section_time('defang');
    }
    # actually the 'for' loop is bogus and runs only once, all recipients
    # listed in the argument are known to be using the same setting for
    # $r->mail_body_mangle, ensured by add_forwarding_header_edits_per_recip;
    # just exit the loop
    last;
  }
  $body_modified;
}

sub do_quarantine($$$$;@) {
  shift(@_)  if $_[0]->isa('Amavis::In::Connection');  # for compatibility
  my($msginfo, $hdr_edits_inherited, $recips_ref,
     $quarantine_method, @snmp_id) = @_;
  if ($quarantine_method eq '') {
    do_log(5, 'quarantine disabled');
  } else {
    local($1);
    my $quar_m_protocol = !ref $quarantine_method ? $quarantine_method
                                                  : $quarantine_method->[0];
    $quar_m_protocol = lc $1  if $quar_m_protocol =~ /^([a-z][a-z0-9.+-]*):/si;
    my $quar_msg = Amavis::In::Message->new;
    $quar_msg->rx_time($msginfo->rx_time);      # copy the reception time
    $quar_msg->log_id($msginfo->log_id);        # use the same log_id
    $quar_msg->partition_tag($msginfo->partition_tag);  # same partition_tag
    $quar_msg->parent_mail_id($msginfo->mail_id);
    $quar_msg->mail_id(scalar generate_mail_id());
    $quar_msg->conn_obj($msginfo->conn_obj);
    $quar_msg->mail_id($msginfo->mail_id);      # use the same mail_id
    $quar_msg->body_type($msginfo->body_type);  # use the same BODY= type
    $quar_msg->header_8bit($msginfo->header_8bit);
    $quar_msg->body_8bit($msginfo->body_8bit);
    $quar_msg->msg_size($msginfo->msg_size);
    $quar_msg->body_digest($msginfo->body_digest);  # copy original digest
    $quar_msg->dsn_ret($msginfo->dsn_ret);
    $quar_msg->dsn_envid($msginfo->dsn_envid);
    $quar_msg->smtputf8($msginfo->smtputf8);
    $quar_msg->auth_submitter($msginfo->sender_smtp);
    $quar_msg->auth_user(c('amavis_auth_user'));
    $quar_msg->auth_pass(c('amavis_auth_pass'));
    $quar_msg->originating(0);  # disables DKIM signing

    my($orig_env_sender_retained, $orig_env_recips_retained);
    my $mftq = c('mailfrom_to_quarantine');
    if (!defined $mftq || $quar_m_protocol =~ /^(?:bsmtp|sql)\z/) {
      # we keep the original envelope sender address if replacement sender
      # is not provided, or with quarantine methods which store to fixed
      # locations which do not depend on envelope
      $quar_msg->sender($msginfo->sender);  # original sender
      $quar_msg->sender_smtp($msginfo->sender_smtp);
      $orig_env_sender_retained = 1;
    } elsif (defined $mftq) {
      # have a replacement, and protocol is smtp, lmtp, pipe, local
      $quar_msg->sender($mftq);
      $mftq = qquote_rfc2821_local($mftq);
      $quar_msg->sender_smtp($mftq);
      $quar_msg->auth_submitter($mftq);
    }
    my(@recips);
    if (!$recips_ref || $quar_m_protocol =~ /^(?:bsmtp|sql)\z/) {
      # we keep the original envelope recipients if replacement recipients
      # are not provided, or with quarantine methods which store to fixed
      # locations which do not depend on envelope information
      for my $r (@{$msginfo->per_recip_data}) {
        my $recip_obj = Amavis::In::Message::PerRecip->new;
        # copy original recipient addresses and DSN info
        $recip_obj->recip_addr($r->recip_addr);
        $recip_obj->recip_addr_smtp($r->recip_addr_smtp);
        $recip_obj->dsn_orcpt($r->dsn_orcpt);
        $recip_obj->recip_destiny(D_PASS);
        $recip_obj->dsn_notify(['NEVER'])  if $orig_env_sender_retained;
        $recip_obj->delivery_method($quarantine_method);
        push(@recips,$recip_obj);
      }
      $orig_env_recips_retained = 1;
    } else {  # have a replacement, and protocol is smtp, lmtp, pipe, local
      # with these quarantine methods the envelope information is used to
      # determine where and how to store a quarantined message, and may not
      # reflect original envelope sender and recipients addresses
      for my $rec (@$recips_ref) {  # use recipients provided by a caller
        my $recip_obj = Amavis::In::Message::PerRecip->new;
        $recip_obj->recip_addr($rec);
        $recip_obj->recip_addr_smtp(qquote_rfc2821_local($rec));
        $recip_obj->recip_destiny(D_PASS);
        $recip_obj->dsn_notify(['NEVER'])  if $orig_env_sender_retained;
        $recip_obj->delivery_method($quarantine_method);
        push(@recips,$recip_obj);
      }
    }
    $quar_msg->per_recip_data(\@recips);
    my $hdr_edits = Amavis::Out::EditHeader->new;
    $hdr_edits->inherit_header_edits($hdr_edits_inherited);
    if (defined $msginfo->mail_id) {
      $hdr_edits->prepend_header('X-Quarantine-ID', '<'.$msginfo->mail_id.'>');
    }
    if ($quar_m_protocol ne 'bsmtp') {
      # NOTE: RFC 2821 mentions possible header flds X-SMTP-MAIL & X-SMTP-RCPT
      # Exim uses: Envelope-To,  Sendmail uses X-Envelope-To;
      # No need with bsmtp, which preserves the envelope.
      my(@blocked_recips) = map($_->recip_addr_smtp,
                            grep($_->recip_done, @{$msginfo->per_recip_data}));
      $hdr_edits->prepend_header('X-Envelope-To-Blocked',
        join(",\n ", @blocked_recips), 1);
      $hdr_edits->prepend_header('X-Envelope-To',
        join(",\n ", map($_->recip_addr_smtp, @{$msginfo->per_recip_data})),1);
    }
    # X-Envelope-* could be redundant with $orig_env_sender_retained, but
    # let's provide this information unconditionally (for the benefit of SQL)
    $hdr_edits->prepend_header('X-Envelope-From', $msginfo->sender_smtp);
    $hdr_edits->add_header('Received',
                           make_received_header_field($msginfo,1), 1);
    $quar_msg->header_edits($hdr_edits);
    $quar_msg->mail_text($msginfo->mail_text);  # use the same mail contents
    $quar_msg->mail_text_str($msginfo->mail_text_str);
    $quar_msg->body_start_pos($msginfo->body_start_pos);
    $quar_msg->skip_bytes($msginfo->skip_bytes);
    if (ll(5)) {
      my $quar_m_displ = !ref $quarantine_method ? $quarantine_method
                           : '(' . join(', ',@$quarantine_method) . ')';
      do_log(5,"DO_QUARANTINE, %s, %s -> %s",
               $quar_m_displ, $quar_msg->sender_smtp,
               join(', ', map($_->recip_addr_smtp,
                              @{$quar_msg->per_recip_data})) );
    }
    snmp_count('QuarMsgs');
    snmp_count( ['QuarMsgsSize', $quar_msg->msg_size, 'C64'] );
    mail_dispatch($quar_msg, 'Quar', 0);
    my($n_smtp_resp, $n_exit_code, $n_dsn_needed) =
      one_response_for_all($quar_msg, 0);  # check status
    if ($n_smtp_resp =~ /^2/ && !$n_dsn_needed) {  # ok
      @snmp_id = ('Other')  if !@snmp_id;
      for (unique_list(\@snmp_id)) {
        snmp_count('QuarMsgs'.$_);
        snmp_count( ['QuarMsgsSize'.$_, $quar_msg->msg_size, 'C64'] );
      }
      my $any_arch    = grep($_ eq 'Arch', @snmp_id);
      my $any_nonarch = grep($_ ne 'Arch', @snmp_id);
      my $act_perf = $msginfo->actions_performed;
      $msginfo->actions_performed($act_perf=[])  if !$act_perf;
      if ($any_nonarch && !grep($_ eq 'Quarantined', @$act_perf)) {
        push(@$act_perf, 'Quarantined');
      }
      if ($any_arch && !grep($_ eq 'Archived', @$act_perf)) {
        push(@$act_perf, 'Archived');
      }
    } elsif ($n_smtp_resp =~ /^4/) {
      snmp_count('QuarAttemptTempFails');
      die "temporarily unable to quarantine: $n_smtp_resp";
    } else {  # abort if quarantining not successful
      snmp_count('QuarAttemptFails');
      die "Can't quarantine: $n_smtp_resp";
    }
    my($q_ty, $q_to, @quar_type, @quar_to);
    $q_ty = $msginfo->quar_type;
    $q_to = $msginfo->quarantined_to;
    @quar_type = ref $q_ty ? @$q_ty : ( $q_ty )  if defined $q_ty;
    @quar_to   = ref $q_to ? @$q_to : ( $q_to )  if defined $q_to;
    my(%seen_q_ty);  $seen_q_ty{$_}=1 for @quar_type;
    my(%seen_q_to);  $seen_q_to{$_}=1 for @quar_to;
    for my $r (@{$quar_msg->per_recip_data}) {
      my $mbxname = $r->recip_mbxname;
      next if !defined $mbxname || $mbxname eq '';
      my $p = $quar_m_protocol;
      $p = $p eq 'smtp'  ? 'M' : $p eq 'lmtp' ? 'L' :
           $p eq 'bsmtp' ? 'B' : $p eq 'sql'  ? 'Q' :
           $p eq 'local' ? ($mbxname =~ /\@/  ? 'M' :
                            $mbxname =~ /\.gz\z/ ? 'Z' : 'F')
                         : '?';
      push(@quar_type,$p)     if !$seen_q_ty{$p}++;
      push(@quar_to,$mbxname) if !$seen_q_to{$mbxname}++;
    }
    # remember quarantine methods/protocols and locations (quarantined_to)
    $msginfo->quar_type(\@quar_type)  if @quar_type;
    $msginfo->quarantined_to(\@quar_to) if @quar_to;
    ll(5) && do_log(5, 'quar_types: %s, quar_to: %s',
                       join(',', @quar_type), join(', ', @quar_to));
    do_log(4, 'DO_QUARANTINE done');
  }
}

# prepare header edits for the quarantined message
#
sub prepare_header_edits_for_quarantine($) {
  my $msginfo = $_[0];

  my($blacklisted_any,$whitelisted_any) = (0,0);
  my($do_tag_any,$do_tag2_any,$do_kill_any) = (0,0,0);
  my($tag_level_min,$tag2_level_min,$kill_level_min);
  my(%all_spam_tests);
  my($min_spam_level, $max_spam_level) =
    minmax(map($_->spam_level, @{$msginfo->per_recip_data}));
  for my $r (@{$msginfo->per_recip_data}) {
    my $rec = $r->recip_addr;
    my $spam_level = $r->spam_level;
    if (ll(2)) {
      my $blocking_ccat = $r->blocking_ccat;
      my($rec_ccat_maj,$rec_ccat_min) = ccat_split(
              defined $blocking_ccat ? $blocking_ccat : $r->contents_category);
      my($ccat,$ccat_min) = ccat_split($msginfo->contents_category);
      do_log(2,"header_edits_for_quar: rec_bl_ccat=(%d,%d), ccat=(%d,%d) %s",
               $rec_ccat_maj, $rec_ccat_min, $ccat, $ccat_min, $rec)
               if $rec_ccat_maj != $ccat || $rec_ccat_min != $ccat_min;
    }
    my($tag_level,$tag2_level,$kill_level,$do_tag,$do_tag2,$do_kill);
    $do_tag  = $r->is_in_contents_category(CC_CLEAN,1);
    $do_tag2 = $r->is_in_contents_category(CC_SPAMMY);
    $do_kill = $r->is_in_contents_category(CC_SPAM);
    if (!$r->bypass_spam_checks && ($do_tag || $do_tag2 || $do_kill)) {
      # do the more expensive lookups only when needed
      $tag_level  = lookup2(0,$rec, ca('spam_tag_level_maps'));
      $tag2_level = lookup2(0,$rec, ca('spam_tag2_level_maps'));
      $kill_level = lookup2(0,$rec, ca('spam_kill_level_maps'));
    }
    # summarize
    $blacklisted_any = 1  if $r->recip_blacklisted_sender;
    $whitelisted_any = 1  if $r->recip_whitelisted_sender;
    $tag_level_min = $tag_level  if defined($tag_level) && $tag_level ne '' &&
                  (!defined($tag_level_min) || $tag_level < $tag_level_min);
    $tag2_level_min = $tag2_level  if defined($tag2_level) &&
                  (!defined($tag2_level_min) || $tag2_level < $tag2_level_min);
    $kill_level_min = $kill_level  if defined($kill_level) &&
                  (!defined($kill_level_min) || $kill_level < $kill_level_min);
    $do_tag_any  = 1  if $do_tag;
    $do_tag2_any = 1  if $do_tag2;
    $do_kill_any = 1  if $do_kill;
    my $spam_tests = $r->spam_tests;
    if ($spam_tests) {
      $all_spam_tests{$_} = 1  for split(/,/, join(',',map($$_,@$spam_tests)));
    }
  }

  my(%header_field_provided);  # mainly applies to spam header fields
  my $use_our_hdrs = cr('prefer_our_added_header_fields');
  my $allowed_hdrs = cr('allowed_added_header_fields');
  my $hdr_edits = Amavis::Out::EditHeader->new;

  if ($allowed_hdrs && $allowed_hdrs->{lc('X-Amavis-Alert')}) {
    if ($msginfo->is_in_contents_category(CC_VIRUS)) {
      my $virusname_list = $msginfo->virusnames;
      $hdr_edits->add_header('X-Amavis-Alert',
        "INFECTED, message contains virus: " .
        (!$virusname_list ? '' : join(", ",@$virusname_list)) );
    }
    if ($msginfo->is_in_contents_category(CC_BANNED)) {
      for my $r (@{$msginfo->per_recip_data}) {
        if (defined($r->banning_reason_short)) {
          $hdr_edits->add_header('X-Amavis-Alert',
                       'BANNED, message contains ' . $r->banning_reason_short);
          last;  # fudge: only the first recipient's banned hit will be shown
        }
      }
    }
    if ($msginfo->is_in_contents_category(CC_BADH)) {
      $hdr_edits->add_header('X-Amavis-Alert',
                             'BAD HEADER SECTION, '.$bad_headers[0]);
    }
  }

  if ($allowed_hdrs) {
    for ('X-Amavis-OS-Fingerprint') {
      my $p0f = $msginfo->client_os_fingerprint;
      if (defined($p0f) && $p0f ne '' && $allowed_hdrs->{lc $_}) {
        $hdr_edits->add_header($_, sanitize_str($p0f));
      }
    }
  }

  if ($allowed_hdrs && $use_our_hdrs) {
    my $spam_level_bar; my $slc = c('sa_spam_level_char');
    if (defined $slc && $slc ne '') {
      my $bar_len = $whitelisted_any ? 0 : $blacklisted_any ? 64
                  : !defined $max_spam_level ? 0
                  : $max_spam_level > 64 ? 64 : $max_spam_level;
      $spam_level_bar = $bar_len < 1 ? '' : $slc x int $bar_len;
    }
    # allow header field wrapping at any comma
    my $s = join(",\n ", sort keys %all_spam_tests);
    my $sl = 'x';
    if (defined $min_spam_level) {
      my $minsl = 0+sprintf("%.3f",$min_spam_level);
      my $maxsl = 0+sprintf("%.3f",$max_spam_level);
      $sl = $minsl eq $maxsl ? $minsl : "$minsl..$maxsl";
    }
    my $autolearn_status = $msginfo->supplementary_info('AUTOLEARN');
    my $full_spam_status = sprintf(
      "%s,\n score=%s\n tag=%s\n tag2=%s\n kill=%s\n ".
      "%stests=[%s]\n autolearn=%s",
      $do_tag2_any||$do_kill_any ? 'Yes' : 'No',  $sl,
      (map { !defined $_ ? 'x' : 0+sprintf("%.3f",$_) }
        ($tag_level_min, $tag2_level_min, $kill_level_min)),
      join('', $blacklisted_any ? "BLACKLISTED\n " : (),
               $whitelisted_any ? "WHITELISTED\n " : ()),
      $s, $autolearn_status||'unavailable');
    if (ll(2)) {
      # log entry semi-compatible with older log parsers
      my $s = $full_spam_status; $s =~ s/\n[ \t]/ /g;
      do_log(2,"header_edits_for_quar: %s -> %s, %s",  $msginfo->sender_smtp,
               join(',', qquote_rfc2821_local(@{$msginfo->recips})),  $s);
    }

    for ('X-Spam-Flag') {
      if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
        $hdr_edits->add_header($_, $do_tag2_any ? 'YES' : 'NO');
        $header_field_provided{lc $_} = 1;
      }
    }
    for ('X-Spam-Score') {
      if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
        my $score = 0+$max_spam_level;
        $score = max(64,$score)  if $blacklisted_any;  # not below 64 if bl
        $score = min( 0,$score)  if $whitelisted_any;  # not above  0 if wl
        $hdr_edits->add_header($_, 0+sprintf("%.3f",$score));
        $header_field_provided{lc $_} = 1;
      }
    }
    for ('X-Spam-Level') {
      if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
        $hdr_edits->add_header($_, $spam_level_bar) if defined $spam_level_bar;
        $header_field_provided{lc $_} = 1;
      }
    }
    for ('X-Spam-Status') {
      if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
        $hdr_edits->add_header($_, $full_spam_status, 1);
        $header_field_provided{lc $_} = 1;
      }
    }
    for ('X-Spam-Report') {
      if ($allowed_hdrs->{lc $_} && $use_our_hdrs->{lc $_}) {
        my $report = $msginfo->spam_report;
        if (defined $report && $report ne '') {
          $hdr_edits->add_header($_, "\n".sanitize_str($report,1), 2);
        }
        $header_field_provided{lc $_} = 1;
      }
    }
  }

  if ($allowed_hdrs) {
    # add remaining header fields as provided by spam scanners
    my $sa_header = $msginfo->supplementary_info(
                      $do_tag2_any ? 'ADDEDHEADERSPAM' : 'ADDEDHEADERHAM');
    if (defined $sa_header && $sa_header ne '') {
      for my $hf (split(/^(?![ \t])/m, $sa_header, -1)) {
        local($1,$2);
        if ($hf =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s) {
          my($hf_name,$hf_body) = ($1,$2);
          my $hf_name_lc = lc $hf_name; chomp($hf_body);
          if ($header_field_provided{$hf_name_lc}) {
            do_log(5,'quar: scanner provided a header field %s, but we '.
                     'preferred our own', $hf_name);
          } elsif (!$allowed_hdrs->{$hf_name_lc}) {
            do_log(5,'quar: scanner provided a header field %s, '.
                     'inhibited by %%allowed_added_header_fields', $hf_name);
          } else {
            do_log(5,'quar: scanner provided a header field %s, inserting',
                     $hf_name);
            $hdr_edits->add_header($hf_name, $hf_body, 2);
          }
        }
      }
    }
    for my $pair ( ['DSPAMRESULT',    'X-DSPAM-Result'],
                   ['DSPAMSIGNATURE', 'X-DSPAM-Signature'],
                   ['CRM114STATUS',   'X-CRM114-Status'],
                   ['CRM114CACHEID',  'X-CRM114-CacheID'] ) {
      my($suppl_attr_name, $hf_name) = @$pair;
      my $suppl_attr_val = $msginfo->supplementary_info($suppl_attr_name);
      if (defined $suppl_attr_val && $suppl_attr_val ne '') {
        if (!$allowed_hdrs->{lc $hf_name}) {
          do_log(5,'quar: scanner provided a tag/field %s, '.
                   'inhibited by %%allowed_added_header_fields', $hf_name);
        } else {
          do_log(5,'quar: scanner provided a tag/field %s, inserting',
                   $hf_name);
          $hdr_edits->add_header($hf_name,
                                 sanitize_str($suppl_attr_val), 2);
        }
      }
    }
  }

  if (c('enable_dkim_verification') &&
      $allowed_hdrs && $allowed_hdrs->{lc('Authentication-Results')}) {
    for my $h (Amavis::DKIM::generate_authentication_results($msginfo,0)) {
      $hdr_edits->add_header('Authentication-Results', $h, 1);
    }
  }

  section_time('quar-hdrs');
  $hdr_edits;
}

# Quarantine according to contents and send admin & recip notif. as needed
# (this subroutine replaces the former subroutines do_virus and do_spam)
#
sub do_notify_and_quarantine($$) {
  my($msginfo, $virus_dejavu) = @_;
  my($mailfrom_admin, $hdrfrom_admin, $notify_admin_templ_ref) =
    map(scalar $msginfo->setting_by_contents_category(cr($_)),
        qw(mailfrom_notify_admin_by_ccat hdrfrom_notify_admin_by_ccat
           notify_admin_templ_by_ccat));
  safe_encode_utf8_inplace($mailfrom_admin); # to octets (if not already)
  safe_encode_utf8_inplace($hdrfrom_admin);  # to octets (if not already)
  my $qar_method = c('archive_quarantine_method');
  my(@ccat_names_pairs) =
    $msginfo->setting_by_main_contents_category_all(\%ccat_display_names);
  my($ccat,$ccat_min) = ccat_split($msginfo->contents_category);
  if (ll(3)) {
    my $ccat_name = ref $ccat_names_pairs[0] ? $ccat_names_pairs[0][1] :undef;
    do_log(3,"do_notify_and_quar: ccat=%s (%d,%d) (%s) ccat_block=(%s)".
             ", qar_mth=%s", $ccat_name, $ccat, $ccat_min,
             join(', ', map(sprintf('"%s":%s', $_->[0], $_->[1]),
                            @ccat_names_pairs)),
             $msginfo->blocking_ccat, $qar_method);
  }
  my $virusname_list = $msginfo->virusnames;
  my $newvirus_admin_maps_ref =
     $virusname_list && @$virusname_list && !$virus_dejavu ?
       ca('newvirus_admin_maps') : undef;

  my $archive_any = 0;  my $archive_transparent = 1;
  if (defined $qar_method && $qar_method ne '') {  # archiving quarantine
    # test if @archive_quarantine_to_maps for all recipients yields
    # a magic placeholder '%a', indicating we want transparent archiving
    # which retains unmodified envelope recipient addresses
    my $aqtm = ca('archive_quarantine_to_maps');
    for my $r (@{$msginfo->per_recip_data}) {
      my $q = lookup2(0, $r->recip_addr, $aqtm);
      $archive_any = 1          if  defined $q && $q ne '';
      $archive_transparent = 0  if !defined $q || $q ne '%a';
      last if $archive_any && !$archive_transparent;
    }
  }
  my(@q_tuples, @a_addr);  # per-recip quarantine address(es) and admins
  for my $r (@{$msginfo->per_recip_data}) {
    my $rec = $r->recip_addr;
    my $blacklisted = $r->recip_blacklisted_sender;
    my $whitelisted = $r->recip_whitelisted_sender;
    my $spam_level  = $r->spam_level;

#   an alternative approach to determining which quarantine and notif. to take
#   my(@qmqta_tuples) = $r->setting_by_main_contents_category_all(
#     cr('quarantine_method_by_ccat'), cr('quarantine_to_maps_by_ccat'),
#     cr('admin_maps_by_ccat') );
#   my $qq;  # quarantine (pseudo) address associated with the recipient
#   my $quarantining_reason_ccat;
#   for my $tuple (@qmqta_tuples) {
#     my($cc, $q_method, $quarantine_to_maps_ref, $admin_maps_ref) = @$tuple;
#     if (defined($q_method) && $q_method ne '' && $quarantine_to_maps_ref) {
#       my $q = lookup2(0,$rec,$quarantine_to_maps_ref);
#       if (defined $q && $q ne '')
#         { $qq = $q; $quarantining_reason_ccat = $cc; last }
#     }
#   }
#   my $aa;  # administrator's e-mail address
#   my $admin_notif_reason_ccat;
#   for my $tuple (@qmqta_tuples) {
#     my($cc, $q_method, $quarantine_to_maps_ref, $admin_maps_ref) = @$tuple;
#     if ($admin_maps_ref) {
#       my $a = lookup2(0,$rec,$admin_maps_ref);
#       if (defined $a && $a ne '')
#         { $aa = $a; $admin_notif_reason_ccat = $cc; last }
#     }
#   }
#   ($rec_ccat_maj,$rec_ccat_min) = ccat_split($quarantining_reason_ccat);

    my $blocking_ccat = $r->blocking_ccat;
    my($rec_ccat_maj,$rec_ccat_min) = ccat_split(
              defined $blocking_ccat ? $blocking_ccat : $r->contents_category);
    my $q_method =
      $r->setting_by_contents_category(cr('quarantine_method_by_ccat'));
    my $quarantine_to_maps_ref =
      $r->setting_by_contents_category(cr('quarantine_to_maps_by_ccat'));
    # get per-recipient quarantine address(es) and admins
    if (!defined($q_method) || $q_method eq '') {
      do_log(5,"do_notify_and_quarantine: not quarantining, q_method off");
    } elsif (!$quarantine_to_maps_ref) {
      do_log(5,"do_notify_and_quarantine: not quarantining, null q_to maps");
    } else {
      my $q;  # quarantine (pseudo) address associated with the recipient
      $q = lookup2(0,$rec,$quarantine_to_maps_ref);
      if (defined $q && $q ne '' &&
          ($rec_ccat_maj==CC_SPAM || $rec_ccat_maj==CC_SPAMMY)) {
        # consider suppressing spam quarantine
        my $cutoff = lookup2(0,$rec, ca('spam_quarantine_cutoff_level_maps'));
        if (!defined $cutoff || $cutoff eq '') {
          # no cutoff, quarantining all
        } elsif ($blacklisted && !$whitelisted) {
          do_log(2,"do_notify_and_quarantine: cutoff, blacklisted");
          $q = '';  # disable quarantine on behalf of this recipient
        } elsif (($spam_level||0) >= $cutoff) {
          do_log(2,"do_notify_and_quarantine: spam level exceeds ".
                   "quarantine cutoff level %s", $cutoff);
          $q = '';  # disable quarantine on behalf of this recipient
        }
      }
      # keep original recipient when q_to is '%a' or with BSMTP;  some day
      # we may end up doing %k, %a, %l, %u, %e, %d placeholder replacements
      $q = $rec  if defined $q && $q ne '' &&
                    ($q eq '%a' || $q_method =~ /^bsmtp:/i);
      if (!defined($q) || $q eq '') {
        do_log(5,"do_notify_and_quarantine: not quarantining, q_to off");
      } else {
        my $ccat_name_major =
          $r->setting_by_contents_category(\%ccat_display_names_major);
        push(@q_tuples, [$q_method, $q, $ccat_name_major]);
      }
    }
    my $admin_maps_ref =
      $r->setting_by_contents_category(cr('admin_maps_by_ccat'));
    my $a;  # administrator's e-mail address
    $a = lookup2(0,$rec,$admin_maps_ref)  if $admin_maps_ref;
    if (defined $a && $a ne '' &&
        ($rec_ccat_maj==CC_SPAM || $rec_ccat_maj==CC_SPAMMY)) {
      # consider suppressing spam admin notifications
      my $cutoff = lookup2(0,$rec, ca('spam_notifyadmin_cutoff_level_maps'));
      if (!defined $cutoff || $cutoff eq '') {
        # no cutoff, sending administrator notifications
      } elsif ($blacklisted && !$whitelisted) {
        do_log(2,"do_notify_and_quarantine: spam admin cutoff, blacklisted");
        $a = '';  # disable admin notification on behalf of this recipient
      } elsif (($spam_level||0) >= $cutoff) {
        do_log(2,"do_notify_and_quarantine: spam level exceeds ".
                 "spam admin cutoff level %s", $cutoff);
        $a = '';  # disable admin notification on behalf of this recipient
      }
    }
    push(@a_addr, $a)  if defined $a && $a ne '' && !grep($_ eq $a, @a_addr);
    if (ccat_maj($r->contents_category)==CC_VIRUS && $newvirus_admin_maps_ref){
      $a = lookup2(0,$rec,$newvirus_admin_maps_ref);
      push(@a_addr, $a)  if defined $a && $a ne '' && !grep($_ eq $a, @a_addr);
    }
    if ($archive_any && !$archive_transparent) {  # archiving quarantine
      my $q = lookup2(0,$rec, ca('archive_quarantine_to_maps'));
      # keep original recipient when q_to is '%a' or with BSMTP
      $q = $rec  if defined $q && $q ne '' &&
                    ($q eq '%a' || $qar_method =~ /^bsmtp:/i);
      push(@q_tuples, [$qar_method, $q, 'Arch'])  if defined $q && $q ne '';
    }
  }  # endfor per_recip_data

  if ($ccat == CC_SPAM) {
    my $sqbsm = ca('spam_quarantine_bysender_to_maps');
    if (@$sqbsm) {  # by-sender spam quarantine (hardly useful, rarely used)
      my $q = lookup2(0,$msginfo->sender, $sqbsm);
      if (defined $q && $q ne '') {
        my $msg_q_method = $msginfo->setting_by_contents_category(
                                              cr('quarantine_method_by_ccat'));
        push(@q_tuples, [$msg_q_method, $q, 'Spam'])
          if defined $msg_q_method && $msg_q_method ne '';
      }
    }
  }

  section_time('notif-quar');
  if (@q_tuples || $archive_any) {
    if (!defined($msginfo->mail_id) && grep($_->[2] ne 'Arch', @q_tuples)) {
      # delayed mail_id generation - now we really need it
      $zmq_obj->register_proc(2,0,'G',$msginfo->log_id) if $zmq_obj; # generate
      $snmp_db->register_proc(2,0,'G',$msginfo->log_id) if $snmp_db;
      # create a mail_id unique to a database and save preliminary info to SQL
      generate_unique_mail_id($msginfo);
      section_time('gen_mail_id')  if $sql_storage;
    }
    # compatibility: replace quarantine method 'local:xxx'
    # with $notify_method when quarantine_to looks like an e-mail address
    my $notif_m = c('notify_method');
    for my $tuple (@q_tuples) {
      my($q_method,$q_to,$ccat_name) = @$tuple;
      $tuple->[0] = $notif_m  if $q_method =~ /^local:/i && $q_to =~ /\@/;
    }
    my $hdr_edits = prepare_header_edits_for_quarantine($msginfo);
    if (@q_tuples) {
      do_log(4,"do_notify_and_quarantine: quarantine %s",
               join(',', map($_->[1], @q_tuples)));
      my(@q_tuples_tmp) = @q_tuples;
      while (@q_tuples_tmp) {
        my($q_method,$q_to,$ccat_name) = @{$q_tuples_tmp[0]};
        my(@same_method_tuples) = grep($_->[0] eq $q_method, @q_tuples_tmp);
        @q_tuples_tmp =           grep($_->[0] ne $q_method, @q_tuples_tmp);
        my(@q_to) =    unique_list(map($_->[1], @same_method_tuples));
        # per-recipient blocking ccat names select snmp counter names
        my(@snmp_id) = unique_list(map($_->[2], @same_method_tuples));
        do_quarantine($msginfo, $hdr_edits, \@q_to, $q_method, @snmp_id);
      }
    }
    if ($archive_any && $archive_transparent) {
      # transparent archiving retains envelope recipient addresses
      do_log(4,"do_notify_and_quarantine: transparent archiving");
      do_quarantine($msginfo, $hdr_edits, undef, $qar_method, 'Arch');
    }
  }
  if (!@a_addr) {
    do_log(4,"skip admin notification, no administrators");
  } elsif (!ref($notify_admin_templ_ref) ||
           (ref($notify_admin_templ_ref) eq 'ARRAY' ?
              !@$notify_admin_templ_ref : $$notify_admin_templ_ref eq '')) {
    do_log(5,"skip admin notifications - empty template");
  } else {   # notify per-recipient administrators
    ll(5) && do_log(5, "Admin notifications to %s; sender: %s",
                       join(',',qquote_rfc2821_local(@a_addr)),
                       $msginfo->sender_smtp);
    $hdrfrom_admin = expand_variables($hdrfrom_admin);
    if (!defined $mailfrom_admin) {
      # defaults to email address in hdrfrom_notify_admin
      $mailfrom_admin =
        unquote_rfc2821_local( (parse_address_list($hdrfrom_admin))[0] );
    }
    my $notification = Amavis::In::Message->new;
    $notification->rx_time($msginfo->rx_time);  # copy the reception time
    $notification->log_id($msginfo->log_id);    # copy log id
    $notification->partition_tag($msginfo->partition_tag); # same partition_tag
    $notification->parent_mail_id($msginfo->mail_id);
    $notification->mail_id(scalar generate_mail_id());
    $notification->conn_obj($msginfo->conn_obj);
    $notification->originating(1);
    $notification->add_contents_category(CC_CLEAN,0);
    safe_encode_utf8_inplace($_) for @a_addr;  # make sure addrs are in octets
    if (grep( / [^\x00-\x7F] .*? \@ [^@]* \z/sx && is_valid_utf_8($_),
              ($mailfrom_admin, @a_addr) )) {
      # localpart is non-ASCII UTF-8, we must use SMTPUTF8
      $notification->smtputf8(1);
      do_log(2, 'admin notification requires SMTPUTF8');
    } else {
      $_ = mail_addr_idn_to_ascii($_)  for ($mailfrom_admin, @a_addr);
    }
    $notification->sender($mailfrom_admin);
    $notification->sender_smtp(qquote_rfc2821_local($mailfrom_admin));
    $notification->auth_submitter($notification->sender_smtp);
    $notification->auth_user(c('amavis_auth_user'));
    $notification->auth_pass(c('amavis_auth_pass'));
    $notification->recips([@a_addr]);
    my $notif_m = c('notify_method');
    $_->delivery_method($notif_m)  for @{$notification->per_recip_data};
    my(@rfc2822_from_admin) =
      map(unquote_rfc2821_local($_), parse_address_list($hdrfrom_admin));
    $notification->rfc2822_from($rfc2822_from_admin[0]);
#   if ($mailfrom_admin ne '')
#     { $_->dsn_notify(['NEVER'])  for @{$notification->per_recip_data} }
    my(%mybuiltins) = %builtins;  # make a local copy
    $mybuiltins{'f'} = safe_decode_utf8($hdrfrom_admin);  # From:
    $mybuiltins{'T'} =                                    # To:
      [ map(mail_addr_idn_to_ascii(qquote_rfc2821_local($_)), @a_addr) ];
    $notification->mail_text(
      build_mime_entity(expand($notify_admin_templ_ref,\%mybuiltins),
                        $msginfo, undef,undef,0, 1,0) );
#   $notification->body_type('7BIT');  # '8BITMIME'
    my $hdr_edits = Amavis::Out::EditHeader->new;
    $notification->header_edits($hdr_edits);
    mail_dispatch($notification, 'Notif', 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) {  # ok
      build_and_save_structured_report($notification,'NOTIF');
    } elsif ($n_smtp_resp =~ /^4/) {
      die "temporarily unable to notify admin: $n_smtp_resp";
    } else {
      do_log(-1, "FAILED to notify admin: %s", $n_smtp_resp);
    }
    # $notification->purge;
  }
  # recipient notifications
  my $wrmbc = cr('warnrecip_maps_by_ccat');
  for my $r (@{$msginfo->per_recip_data}) {
    my $rec = $r->recip_addr;
  # if ($r->is_in_contents_category(CC_SPAM)) {
  #   if ($wrmbc->{&CC_VIRUS}) {
  #     $wrmbc = { %$wrmbc };  # copy
  #     delete $wrmbc->{&CC_VIRUS};
  #     do_log(5,"disabling virus recipient notifications for infected spam");
  #   }
  # }
    my $warnrecip_maps_ref = $r->setting_by_contents_category($wrmbc);
    my $wr; my $notify_recips_templ_ref;
    $wr = lookup2(0,$rec,$warnrecip_maps_ref)  if $warnrecip_maps_ref;
    if ($wr) {
      $notify_recips_templ_ref =
        $r->setting_by_contents_category(cr('notify_recips_templ_by_ccat'));
      if (!ref($notify_recips_templ_ref) ||
               (ref($notify_recips_templ_ref) eq 'ARRAY' ?
                !@$notify_recips_templ_ref : $$notify_recips_templ_ref eq '')){
        do_log(5,"skip recipient notifications - empty template");
        $wr = 0;  # do not send empty notifications
      } elsif (!c('warn_offsite') && !$r->recip_is_local) {
        do_log(5,"skip recipient notifications - nonlocal recipient");
        $wr = 0;  # do not notify foreign recipients
#     } elsif ($r->recip_destiny == D_PASS) {
#       do_log(5,"skip recipient notifications - mail will be delivered");
#       $wr = 0;  # do not notify recips which will be getting a message anyway
#     } elsif ($msginfo->sender eq '') {  # (not general enough)
#       do_log(5,"skip recipient notifications for null sender");
#       $wr = 0;
      }
    }
    if ($wr) {  # warn recipient
      my $mailfrom_recip =
        $r->setting_by_contents_category(cr('mailfrom_notify_recip_by_ccat'));
      my $hdrfrom_recip =
        $r->setting_by_contents_category(cr('hdrfrom_notify_recip_by_ccat'));
      # make sure it's in octets
      safe_encode_utf8_inplace($mailfrom_recip); # to octets (if not already)
      safe_encode_utf8_inplace($hdrfrom_recip);  # to octets (if not already)
      $hdrfrom_recip = expand_variables($hdrfrom_recip);
      if (!defined $mailfrom_recip) {
        # defaults to email address in hdrfrom_notify_recip
        $mailfrom_recip =
          unquote_rfc2821_local( (parse_address_list($hdrfrom_recip))[0] );
      }
      my $notification = Amavis::In::Message->new;
      $notification->rx_time($msginfo->rx_time);  # copy the reception time
      $notification->log_id($msginfo->log_id);    # copy log id
      $notification->partition_tag($msginfo->partition_tag); # same partition
      $notification->parent_mail_id($msginfo->mail_id);
      $notification->mail_id(scalar generate_mail_id());
      $notification->conn_obj($msginfo->conn_obj);
      $notification->originating(1);
      $notification->add_contents_category(CC_CLEAN,0);
      if (grep( / [^\x00-\x7F] .*? \@ [^@]* \z/sx && is_valid_utf_8($_),
                ($mailfrom_recip, $rec) )) {
        # localpart is non-ASCII UTF-8, we must use SMTPUTF8
        do_log(2, 'recipient notification requires SMTPUTF8');
        $notification->smtputf8(1);
      } else {
        $_ = mail_addr_idn_to_ascii($_)  for ($mailfrom_recip, $rec);
      }
      $notification->sender($mailfrom_recip);
      $notification->sender_smtp(qquote_rfc2821_local($mailfrom_recip));
      $notification->auth_submitter($notification->sender_smtp);
      $notification->auth_user(c('amavis_auth_user'));
      $notification->auth_pass(c('amavis_auth_pass'));
      $notification->recips([$rec]);
      my $notif_m = c('notify_method');
      $_->delivery_method($notif_m)  for @{$notification->per_recip_data};
      my(@rfc2822_from_recip) =
        map(unquote_rfc2821_local($_), parse_address_list($hdrfrom_recip));
      $notification->rfc2822_from($rfc2822_from_recip[0]);
#     if ($mailfrom_recip ne '')
#       { $_->dsn_notify(['NEVER'])  for @{$notification->per_recip_data} }

      my(@b);  @b = @{$r->banned_parts}  if defined $r->banned_parts;
      my $b_chopped = @b > 2;  @b = (@b[0,1],'...')  if $b_chopped;
      s/[ \t]{6,}/ ... /g  for @b;
      my(%mybuiltins) = %builtins;  # make a local copy
      $mybuiltins{'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);
      $mybuiltins{'f'} = safe_decode_utf8($hdrfrom_recip);  # From:
      $mybuiltins{'T'} = mail_addr_idn_to_ascii(qquote_rfc2821_local($rec));
      $notification->mail_text(
        build_mime_entity(expand($notify_recips_templ_ref,\%mybuiltins),
                          $msginfo, undef,undef,0, 0,0) );
#     $notification->body_type('7BIT');  # '8BITMIME'
      my $hdr_edits = Amavis::Out::EditHeader->new;
      $notification->header_edits($hdr_edits);
      mail_dispatch($notification, 'Notif', 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) {  # ok
        build_and_save_structured_report($notification,'NOTIF');
      } elsif ($n_smtp_resp =~ /^4/) {
        die "temporarily unable to notify recipient rec: $n_smtp_resp";
      } else {
        do_log(-1, "FAILED to notify recipient %s: %s", $rec,$n_smtp_resp);
      }
      # $notification->purge;
    }
  }
  do_log(5, "do_notify_and_quarantine - done");
}

# Calculate a message body digest;
# While at it, also get message size, verify DKIM signatures, check for 8-bit
# data, collect entropy, and store original header section since we need it
# for the %H macro, and MIME::Tools may modify its copy.
#
sub get_body_digest($$) {
  my($msginfo, $alg) = @_;
  my($remaining_time, $dkim_deadline) =   # sanity limit for DKIM verification
    get_deadline('get_body_digest', 0.5, 8, 30);
  prolong_timer('digest_pre');  # restart the timer
  my($hctx,$bctx);
  # choose a message digest: MD5: 128 bits (32 hex), SHA family: 160..512 bits
  if (uc $alg eq 'MD5') { $hctx = Digest::MD5->new; $bctx = Digest::MD5->new }
  else { $hctx = Digest::SHA->new($alg); $bctx = Digest::SHA->new($alg) }
  my $dkim_verifier;
  if (c('enable_dkim_verification')) {
    if (!defined $dns_resolver && Mail::DKIM::Verifier->VERSION >= 0.40) {
      # Create a persistent DNS resolver object for the benefit
      # of Mail::DKIM::Verifier; this avoids repeating initializations
      # with each request, and allows us to turn on EDNS.
      # The controversial need for 'config_file' option was debated in
      # [rt.cpan.org #96608] https://rt.cpan.org/Ticket/Display.html?id=96608
      # With Net::DNS 1.03 the semantics of a "retry" option has changed:
      # [rt.cpan.org #109183] https://rt.cpan.org/Ticket/Display.html?id=109183
      $dns_resolver = Net::DNS::Resolver->new(
        config_file => '/etc/resolv.conf',
        defnames => 0, force_v4 => !$have_inet6,
        retry => 2,  # number of times to try the query (not REtries)
        persistent_udp => 1,
        tcp_timeout => 3, udp_timeout => 3, retrans => 2,  # seconds
      );
      if (!$dns_resolver) {
        do_log(-1, "Failed to create a Net::DNS::Resolver object");
        $dns_resolver = 0;  # defined but false
      } else {
        # RFC 2460 (for IPv6) requires that a minimal MTU is 1280 bytes,
        # taking away 40 bytes for a basic IP header gives 1240;
        # RFC 3226: minimum of 1220 for RFC 2535 compliant servers
        # RFC 6891: choosing between 1280 and 1410 bytes for IP (v4 or v6)
        # over Ethernet would be reasonable.
        my $payload_size = 1220;  # a conservative default
        # RFC 6891 (ex RFC 2671) - EDNS0, set requestor's UDP payload size
        $dns_resolver->udppacketsize($payload_size)  if $payload_size > 512;
        ll(5) && do_log(5, "DNS resolver created, UDP payload size %s, NS: %s",
                           $dns_resolver->udppacketsize,
                           join(', ',$dns_resolver->nameservers) );
        Mail::DKIM::DNS::resolver($dns_resolver);
      }
    }
    $dkim_verifier = Mail::DKIM::Verifier->new;
  }
# section_time('digest_init');

  my($header_size, $body_size, $h_8bit, $b_8bit) = (0) x 4;
  my $orig_header = [];  # array of header fields, with folding and trailing NL
  my $orig_header_fields = {};
  my $sanity_limit =   4*1024*1024;  #   4 MiB header size sanity limit
  my $dkim_sanity_limit = 256*1024;  # 256 KiB header size sanity limit

  my $msg = $msginfo->mail_text;
  my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
  $msg = $msg_str_ref  if ref $msg_str_ref;
  my $pos = 0;

  if (!defined $msg) {
    # empty mail
    $msginfo->body_start_pos(0);

  } elsif (ref $msg eq 'SCALAR') {
    do_log(5, "get_body_digest: reading header section from memory");
    my $header;
    $pos = min($msginfo->skip_bytes, length($$msg));
    if ($pos >= length($$msg)) {  # empty message
      $header = ''; $pos = length($$msg);
    } elsif (substr($$msg,$pos,1) eq "\n") {  # empty header section
      $header = ''; $pos++;
    } else {
      my $ind = index($$msg, "\n\n", $pos);  # find header/body separator
      $header = $ind < 0 ? substr($$msg, $pos)
                         : substr($$msg, $pos, $ind+1-$pos);
      $h_8bit = 1  if $header =~ tr/\x00-\x7F//c;
      $hctx->add($header);
      $pos = $ind < 0 ? length($$msg) : $ind+2;
    }
    # $pos now points to the first byte of a body
    $msginfo->body_start_pos($pos);
    local($1); my($j,$k,$ln);
    for ($j = 0; $j < length($header); $j = $k+1) {
      $k = index($header, "\n", $j);
      $ln = $k < 0 ? substr($header, $j) : substr($header, $j, $k-$j+1);
      if ($ln =~ /^[ \t]/) {  # header field continuation
        $$orig_header[-1] .= $ln;  # includes NL
      } else {  # starts a new header field
        push(@$orig_header, $ln);  # includes NL
        if ($ln =~ /^([^: \t]+)[ \t]*:/) {
          # remember array index of each occurrence of a header field, top down
          my $curr_entry = $orig_header_fields->{lc($1)};
          if (!defined $curr_entry) {
            # optimized: if there is only one element, it is stored as itself
            $orig_header_fields->{lc($1)} = $#$orig_header;
          } elsif (ref $curr_entry) {  # already an arrayref, append
            push(@{$orig_header_fields->{lc($1)}}, $#$orig_header);
          } else {  # was a single element as a scalar, now there are two
            $orig_header_fields->{lc($1)} = [ $curr_entry, $#$orig_header ];
          }
        }
      }
      last if $k < 0;
    }

    $header =~ s{\n}{\015\012}gs;    # needed for DKIM and for size
    $header_size = length($header);  # size includes CRLF (RFC 1870)
    if (defined $dkim_verifier) {
      do_log(5, "get_body_digest: feeding header section to DKIM verifier");
      eval {
        $dkim_verifier->PRINT($header)
          or die "Error writing mail header to DKIM: $!";
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        do_log(-1,"Error feeding header to DKIM verifier: %s",$eval_stat);
        undef $dkim_verifier;
      };
    }

  } elsif ($msg->isa('MIME::Entity')) {
    die "get_body_digest: reading from a MIME::Entity object not implemented";

  } else {  # a file handle assumed
    do_log(5, "get_body_digest: reading header section from a file");
    $pos = $msginfo->skip_bytes;  # should be 0, but anyway...
    $msg->seek($pos,0)  or die "Can't rewind mail file: $!";

    # read mail header section
    local($1); my $ln;
    for ($! = 0; defined($ln=$msg->getline); $! = 0) {
      $pos += length($ln);
      last  if $ln eq "\n";
      $hctx->add($ln);
      $h_8bit = 1  if !$h_8bit && ($ln =~ tr/\x00-\x7F//c);
      if ($ln =~ /^[ \t]/) {  # header field continuation
        $$orig_header[-1] .= $ln; # including NL
      } else {  # starts a new header field
        push(@$orig_header,$ln);  # including NL
        if ($ln =~ /^([^: \t]+)[ \t]*:/) {
          # remember array index of each occurrence of a header field, top down
          my $curr_entry = $orig_header_fields->{lc($1)};
          if (!defined $curr_entry) {
            # optimized: if there is only one element, it is stored as itself
            $orig_header_fields->{lc($1)} = $#$orig_header;
          } elsif (ref $curr_entry) {  # already an arrayref, append
            push(@{$orig_header_fields->{lc($1)}}, $#$orig_header);
          } else {  # was a single element as a scalar, now there are two
            $orig_header_fields->{lc($1)} = [ $curr_entry, $#$orig_header ];
          }
        }
      }
      chomp($ln);
      if (!defined $dkim_verifier) {
        # don't bother
      } elsif ($header_size > $dkim_sanity_limit) {
        do_log(-1,"Stopped feeding header to DKIM verifier: ".
                   "%.0f KiB sanity limit exceeded", $dkim_sanity_limit/1024);
        undef $dkim_verifier;
      } elsif (Time::HiRes::time > $dkim_deadline) {
        do_log(-1,"Stopped feeding header to DKIM verifier: deadline exceeded");
        undef $dkim_verifier;
      } else {
        eval {
          $dkim_verifier->PRINT($ln."\015\012")
            or die "Error writing mail header to DKIM: $!";
          1;
        } or do {
          my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
          do_log(-1,"Error feeding header line to DKIM verifier: %s",
                    $eval_stat);
          undef $dkim_verifier;
        };
      }
      $header_size += length($ln)+2;  # size includes CRLF (RFC 1870)
      # exceeded $sanity_limit will break DKIM signatures, too bad...
      last  if $header_size > $sanity_limit;
    }
    defined $ln || $! == 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: $!";
    $msginfo->body_start_pos($pos);
  }
  add_entropy($hctx->digest);

  if (defined $dkim_verifier) {
    do_log(5, "get_body_digest: sending h/b separator to DKIM");
    eval {
      # h/b separator will trigger signature pre-processing in DKIM module
      $dkim_verifier->PRINT("\015\012")
        or die "Error writing h/b separator to DKIM: $!";
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(-1,"Error feeding h/b separ to DKIM verifier: %s", $eval_stat);
      undef $dkim_verifier;
    };
  }

  $header_size += 2;  # include a separator CRLF line in a header section size
  untaint_inplace($header_size);  # length(tainted) stays tainted too
  section_time('digest_hdr');
  # a DNS lookup in Mail::DKIM older than 0.30 stops the timer!
  # The lookup is performed at a header/body separator line or at CLOSE, at
  # which point signatures become available through the $dkim_verifier object.
  prolong_timer('digest_hdr');  # restart timer if stopped

  my(@dkim_signatures);
  @dkim_signatures = $dkim_verifier->signatures  if defined $dkim_verifier;
  # don't bother feeding body to DKIM if there are no signature header fields
  my $feed_dkim = @dkim_signatures > 0;
  if ($feed_dkim) {
    $msginfo->checks_performed({})  if !$msginfo->checks_performed;
    $msginfo->checks_performed->{D} = 1;
  }

  if (!defined $msg) {
    # empty mail

  } elsif (ref $msg eq 'SCALAR') {
    ll(5) && do_log(5, "get_body_digest: reading mail body from memory, ".
                       "%d DKIM signatures", scalar @dkim_signatures);
    my($buff, $buff_l);
    while ($pos < length($$msg)) {
      # do it in chunks to avoid unnecessarily large memory use
      # for temporary variables
      $buff = substr($$msg,$pos,32768); $buff_l = length($buff);
      $pos += $buff_l;
      $bctx->add($buff);
      $b_8bit = 1  if !$b_8bit && ($buff =~ tr/\x00-\x7F//c);
      if (!$feed_dkim) {
        # count \n, compensating for CRLF (RFC 1870)
        $body_size += $buff_l + ($buff =~ tr/\n//);
      } else {
        $buff =~ s{\n}{\015\012}gs;
        $body_size += length($buff);
        eval {
          $dkim_verifier->PRINT($buff)
            or die "Error writing mail body to DKIM: $!";
          1;
        } or do {
          my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
          do_log(-1,"Error feeding body to DKIM verifier: %s",$eval_stat);
          undef $dkim_verifier;
        };
      }
    }

  } elsif ($msg->isa('MIME::Entity')) {
    die "get_body_digest: reading from MIME::Entity is not implemented";

  } else {
    #*** # only read further if not already at end-of-file
    ll(5) && do_log(5, "get_body_digest: reading mail body from a file, ".
                       "%d DKIM signatures", scalar @dkim_signatures);
    my($buff, $buff_l);
    while (($buff_l = $msg->read($buff,65536)) > 0) {
      $bctx->add($buff);
      $b_8bit = 1  if !$b_8bit && ($buff =~ tr/\x00-\x7F//c);
      if (!$feed_dkim) {
        # count \n, compensating for CRLF (RFC 1870)
        $body_size += $buff_l + ($buff =~ tr/\n//);
      } else {
        $buff =~ s{\n}{\015\012}gs;
        $body_size += length($buff);
        eval {
          $dkim_verifier->PRINT($buff)
            or die "Error writing mail body to DKIM: $!";
          1;
        } or do {
          my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
          do_log(-1,"Error feeding body to DKIM verifier: %s",$eval_stat);
          undef $dkim_verifier;
        };
      }
    }
    defined $buff_l  or die "Error reading mail body: $!";
  }
  if (defined $dkim_verifier) {
    eval {
      # this will trigger signature verification in the DKIM module
      $dkim_verifier->CLOSE or die "Can't close dkim_verifier: $!";
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(-1,"Error closing DKIM verifier: %s",$eval_stat);
      undef $dkim_verifier;
    };
    @dkim_signatures = $dkim_verifier->signatures  if defined $dkim_verifier;
  }
  prolong_timer('digest_body');  # restart timer if stopped

  my $body_digest = untaint($bctx->digest);
  add_entropy($body_digest);

  # store information obtained
  if (@dkim_signatures) {
    if (@dkim_signatures > 50) {  # sanity
      do_log(-1, "Too many DKIM or DK signatures (%d), truncating to 50",
                 scalar(@dkim_signatures));
      $#dkim_signatures = 49;
    }
    $msginfo->dkim_signatures_all(\@dkim_signatures);
  }

  if (ll(5)) {
    my $mail_size_old = $msginfo->msg_size;
    my $mail_size_new = $header_size + $body_size;
    if (defined($mail_size_old) && $mail_size_new != $mail_size_old) {
      # copy_smtp_data() provides a message size which is not adjusted for
      # dot-destuffing - for speed.  We finely adjust the message size here,
      # now that we have the necessary information available.
      do_log(5, "get_body_digest: message size adjusted %d -> %d, ".
                "header+sep %d, body %d",
                $mail_size_old, $mail_size_new, $header_size, $body_size);
    } else {
      do_log(5, "get_body_digest: message size %d, header+sep %d, body %d",
                $mail_size_new, $header_size, $body_size);
    }
  }
  $msginfo->msg_size($header_size + $body_size);
  $msginfo->orig_header_fields($orig_header_fields);  # stores just indices
  $msginfo->orig_header($orig_header); # header section, without separator line
  $msginfo->orig_header_size($header_size);  # size includes a separator line!
  $msginfo->orig_body_size($body_size);
  my $body_digest_hex = unpack('H*', $body_digest);  # high nybble first
  # store hex-encoded to retain backward compatibility with pre-2.8.0
  $msginfo->body_digest($body_digest_hex);
  $msginfo->header_8bit($h_8bit ? 1 : 0);
  $msginfo->body_8bit($b_8bit ? 1 : 0);
  # check for 8-bit characters and adjust body type if necessary (RFC 6152)
  my $bt_orig = $msginfo->body_type;
  $bt_orig = defined $bt_orig ? uc $bt_orig : '';
  if ($h_8bit || $b_8bit) {
    # just keep original label whatever it is (garbage-in - garbage-out);
    # keeping 8-bit mail unlabeled might avoid breaking DKIM in transport
    # (labeling as 8-bit may invoke 8>7 downgrades in MTA, breaking signatures)
  } elsif ($bt_orig eq '') {  # unlabeled on reception
    $msginfo->body_type('7BIT');  # safe to label as all-ASCII
  } elsif ($bt_orig eq '8BITMIME') {  # redundant (quite common)
    $msginfo->body_type('7BIT');  # turn a redundant 8BITMIME into 7BIT
  }
  if (ll(4)) {
    my $remark =
      ($bt_orig eq ''         &&              $b_8bit)  ? ", but 8-bit body"
    : ($bt_orig eq ''         &&              $h_8bit)  ? ", but 8-bit header"
    : ($bt_orig eq '7BIT'     &&  ($h_8bit || $b_8bit)) ? " inappropriately"
    : ($bt_orig eq '8BITMIME' && !($h_8bit || $b_8bit)) ? " unnecessarily"
    : ", good";
    do_log(4, "body type (8bit-MIMEtransport): %s%s (h=%s, b=%s)",
           $bt_orig eq '' ? 'unlabeled' : "labeled $bt_orig",
           $remark, $h_8bit, $b_8bit);
  }
  do_log(3, "body hash: %s", $body_digest_hex);
  section_time(defined $dkim_verifier ? 'digest_body_dkim' : 'digest_body');
  $body_digest_hex;
}

sub find_program_path($$) {
  my($fv_list, $path_list_ref) = @_;
  $fv_list = [$fv_list]  if !ref $fv_list;
  my $found;
  for my $fv (@$fv_list) {  # search through alternatives
    my(@fv_cmd) = split(' ',$fv);
    my $cmd = $fv_cmd[0];
    if (!@fv_cmd) {
      # empty, not available
    } elsif ($cmd =~ m{^/}s) {  # absolute path
      my $errn = stat($cmd) ? 0 : 0+$!;
      if ($errn == ENOENT) {
        # file does not exist
      } elsif ($errn) {
        do_log(-1, "find_program_path: %s inaccessible: %s", $cmd,$!);
      } elsif (-d _) {
        do_log(0, "find_program_path: %s is a directory", $cmd);
      } elsif (!-x _) {
        do_log(0, "find_program_path: %s is not executable", $cmd);
      } else {
        $found = join(' ', @fv_cmd);
      }
    } elsif ($cmd =~ m{/}s) {  # relative path
      die "find_program_path: relative paths not implemented: @fv_cmd\n";
    } else {                   # walk through the specified PATH
      for my $p (@$path_list_ref) {
        my $errn = stat("$p/$cmd") ? 0 : 0+$!;
        if ($errn == ENOENT) {
          # file does not exist
        } elsif ($errn) {
          do_log(-1, "find_program_path: %s/%s inaccessible: %s", $p,$cmd,$!);
        } elsif (-d _) {
          do_log(0, "find_program_path: %s/%s is a directory", $p,$cmd);
        } elsif (!-x _) {
          do_log(0, "find_program_path: %s/%s is not executable", $p,$cmd);
        } else {
          $found = $p . '/' . join(' ', @fv_cmd);
          last;
        }
      }
    }
    last  if defined $found;
  }
  $found;
}

sub find_external_programs($) {
  my $path_list_ref = $_[0];
  for my $f (qw($file $altermime)) {
    my $g = $f;  $g =~ s/\$/Amavis::Conf::/;  my $fv_list = eval('$' . $g);
    my $found = find_program_path($fv_list, $path_list_ref);
    { no strict 'refs'; $$g = $found }  # NOTE: a symbolic reference
    if (!defined $found) { do_log(0,"No %-19s not using it", "$f,") }
    else {
      do_log(1, "Found %-16s at %s%s", $f,
             $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '',
             $found);
    }
  }
  # map program name path hints to full paths for decoders
  my(%any_st);
  for my $f (@{ca('decoders')}) {
    next  if !defined $f || !ref $f;  # empty, skip
    my $short_types = $f->[0];
    if (!defined $short_types || (ref $short_types && !@$short_types)) {
      undef $f; next;
    }
    my(@tried,@found);  my $any = 0;
    for my $d (@$f[2..$#$f]) {  # all but the first two elements are programs
      # find the program, allow one level of indirection
      my $dd = (ref $d eq 'SCALAR' || ref $d eq 'REF') ? $$d : $d;
      my $found = find_program_path($dd, $path_list_ref);
      if (defined $found) {
        $any = 1; $d = $dd = $found; push(@found,$dd);
      } else {
        push(@tried, !ref($dd) ? $dd : join(", ",@$dd))  if $dd ne '';
        undef $d;
      }
    }
    my $any_in_use;
    for my $short_type (ref $short_types ? @$short_types : $short_types) {
      my $is_a_backup = $any_st{$short_type};
      my($ll,$tier) = !$is_a_backup ? (1,'') : (2,' (backup, not used)');
      if (@$f <= 2) {  # no external programs specified
        if (!$is_a_backup) { $any_in_use = 1; $any_st{$short_type} = 1 }
        do_log($ll, "Internal decoder for .%-4s%s", $short_type,$tier);
      } elsif (!$any) {  # external programs specified but none found
        do_log(0, "No ext program for   .%s, tried: %s",
          $short_type, join('; ',@tried))  if @tried && !$is_a_backup;
      } else {
        if (!$is_a_backup) { $any_in_use = 1; $any_st{$short_type} = 1 }
        do_log($ll, "Found decoder for    .%-4s at %s%s%s", $short_type,
            $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '',
            join('; ',@found), $tier);
      }
      # defined but false, collect a list of tried short types as hash keys
      $any_st{$short_type} = 0  if !defined $any_st{$short_type};
    }
    if (!$any_in_use) {
      undef $f;  # discard a backup entry
    } else {
      # turn array (in the first element) into a hash
      $f->[0] = { map(($_,1), @$short_types) }  if ref $short_types;
    }
  }
  for my $short_type (sort grep(!$any_st{$_}, keys %any_st)) {
    do_log(0, "No decoder for       .%-4s",  $short_type);
  }
  # map program name hints to full paths - av scanners
  my $tier = 'primary';  # primary, secondary, ...   av scanners
  for my $f (@{ca('av_scanners')}, "\000", @{ca('av_scanners_backup')}) {
    if ($f eq "\000") {   # next tier
      $tier = 'secondary';
    } elsif (!defined $f || !ref $f) {
      # empty, skip
    } elsif (ref($f->[1]) eq 'CODE') {
      do_log(0, "Using %s internal av scanner code for %s", $tier,$f->[0]);
    } else {
      my $found = $f->[1] = find_program_path($f->[1], $path_list_ref);
      if (!defined $found) {
        do_log(3, "No %s av scanner: %s", $tier, $f->[0]);
        undef $f;  # release its storage
      } else {
        do_log(0, "Found %s av scanner %-11s at %s%s", $tier, $f->[0],
              $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '',
              $found);
      }
    }
  }
  for my $f (@{ca('spam_scanners')}) {
    if (!defined $f || !ref $f) {
      # empty, skip
    } elsif ($f->[1] ne 'Amavis::SpamControl::ExtProg') {
      do_log(5, "Using internal spam scanner code for %s", $f->[0]);
    } else {  # using the Amavis::SpamControl::ExtProg interface module
      my $found = $f->[2] = find_program_path($f->[2], $path_list_ref);
      if (!defined $found) {
        do_log(3, "No spam scanner:   %s", $f->[0]);
        undef $f;  # release its storage
      } else {
        do_log(0, "Found spam scanner %-11s at %s%s", $f->[0],
              $daemon_chroot_dir ne '' ? "(chroot: $daemon_chroot_dir/) " : '',
              $found);
      }
    }
  }
}

# Fetch remaining modules, all must be loaded before chroot and fork occurs
#
sub fetch_modules_extra() {
  my(@modules,@optmodules);
  if ($extra_code_sql_base) {
    push(@modules, 'DBI');
    push(@optmodules, 'DBI::Const::GetInfoType', 'DBI::Const::GetInfo::ANSI');
    for (@lookup_sql_dsn, @storage_sql_dsn) {
      my(@dsn) = split(/:/, $_->[0], -1);
      push(@modules, 'DBD::'.$dsn[1])  if uc($dsn[0]) eq 'DBI';
    }
  }
  push(@modules, qw(Net::LDAP Net::LDAP::Util Net::LDAP::Search
                    Net::LDAP::Bind Net::LDAP::Extension)) if $extra_code_ldap;
  if ($extra_code_dkim ||
      c('tls_security_level_in') || c('tls_security_level_out')) {
    push(@modules, qw(Crypt::OpenSSL::RSA));
  }
  if (c('tls_security_level_in') || c('tls_security_level_out')) {
    push(@modules, qw(IO::Socket::SSL
                      Net::SSLeay auto::Net::SSLeay::ssl_write_all
                      auto::Net::SSLeay::ssl_read_until
                      auto::Net::SSLeay::dump_peer_certificate));
  }
  push(@modules, qw(Net::DNS::RR::TXT Text::ParseWords
         auto::Crypt::OpenSSL::RSA::new_public_key))  if $extra_code_dkim;
  push(@modules, 'Anomy::Sanitizer')  if $enable_anomy_sanitizer;
  Amavis::Boot::fetch_modules('REQUIRED ADDITIONAL MODULES', 1, @modules);

  push(@optmodules, qw(
    bytes bytes_heavy.pl utf8 utf8_heavy.pl
    Encode Encode::Byte Encode::MIME::Header Encode::Unicode::UTF7
    Encode::CN Encode::TW Encode::KR Encode::JP
    unicore::To::Lower.pl unicore::To::Upper.pl
    unicore::To::Fold.pl unicore::To::Title.pl unicore::To::Digit.pl
    unicore::lib::Perl::Alnum.pl unicore::lib::Perl::SpacePer.pl
    unicore::lib::Perl::Word.pl
    unicore::lib::Alpha::Y.pl unicore::lib::Nt::De.pl
  ));

  if (@Amavis::Conf::decoders &&
      grep { exists $policy_bank{$_}{'bypass_decode_parts'} &&
             !do { my $v = $policy_bank{$_}{'bypass_decode_parts'};
                   !ref $v ? $v : $$v } } keys %policy_bank)
  { # at least one bypass_decode_parts is explicitly false
    push(@modules, qw(Archive::Zip));
  # push(@modules, qw(Convert::TNEF Convert::UUlib Archive::Tar));
  }

  push(@optmodules, $] >= 5.012000 ? qw(unicore::Heavy.pl)
         : qw(unicore::Canonical.pl unicore::Exact.pl unicore::PVA.pl));
  # unicore::lib::Perl::Word.pl unicore::lib::Perl::SpacePer.pl
  # unicore::lib::Perl::Alnum.pl unicore::lib::Alpha::Y.pl
  # unicore::lib::Nt::De.pl unicore::lib::Hex::Y.pl

  push(@optmodules, qw(Unix::Getrusage));
  push(@optmodules, 'Authen::SASL')  if $extra_code_ldap &&
                                        !grep($_ eq 'Authen::SASL', @modules);
  push(@optmodules, defined($min_servers) ? 'Net::Server::PreFork'
                                       : 'Net::Server::PreForkSimple');
  push(@optmodules, @additional_perl_modules);
  my $missing;
  $missing = Amavis::Boot::fetch_modules('PRE-COMPILE OPTIONAL MODULES', 0,
                                         @optmodules)  if @optmodules;
  do_log(2, 'INFO: no optional modules: %s', join(' ',@$missing))
    if ref $missing && @$missing;
  # require minimal version 0.32, Net::LDAP::Util::escape_filter_value() needed
  Net::LDAP->VERSION(0.32)  if $extra_code_ldap;
  # needed a working last_insert_id in the past, no longer so but nevertheless:
  DBI->VERSION(1.43)  if $extra_code_sql_base;
  MIME::Entity->VERSION != 5.419
    or die "MIME::Entity 5.419 breaks quoted-printable encoding, ".
           "please upgrade to 5.420 or later (or use 5.418)";
  # load optional modules SAVI and Mail::ClamAV if available and requested
  if ($extra_code_antivirus) {
    my $clamav_module_ok;
    for my $entry (@{ca('av_scanners')}, @{ca('av_scanners_backup')}) {
      if (ref($entry) ne 'ARRAY') {
        # none
      } elsif ($entry->[0] eq 'Sophos SAVI') {
        if (defined(eval { require SAVI }) && SAVI->VERSION(0.30) &&
            Amavis::AV::sophos_savi_init(@$entry)) {}  # ok, loaded
        else { undef $entry->[1] }  # disable entry
      } elsif ($entry->[0] =~ /^Mail::ClamAV/) {
        if (!defined($clamav_module_ok)) {
          $clamav_module_ok = eval { require Mail::ClamAV };
          $clamav_module_ok = 0  if !defined $clamav_module_ok;
        }
        undef $entry->[1]  if !$clamav_module_ok;  # disable entry
      }
    }
  }
}

sub usage() {
  my $myprogram_name = c('myprogram_name');
  return <<"EOD";
Usage:
  $myprogram_name
    [-u user] [-g group]
    [-i instance_name] {-c config_file}
    [-d log_level,area,...] [-X magic1,magic2,...]
    [-m max_servers] {-p listen_port_or_socket}
    [-L lock_file] [-P pid_file] [-H home_dir]
    [-D db_home_dir | -D ''] [-Q quarantine_dir | -Q '']
    [-R chroot_dir | -R ''] [-S helpers_home_dir] [-T tempbase_dir]
    ( [start] | stop | reload | restart | debug | debug-sa | foreground |
      showkeys {domains} | testkeys {domains} | genrsa file_name [nbits]
      convert_keysfile file_name )
  where area is a SpamAssassin debug area, e.g. all,util,rules,plugin,dkim,dcc
or:
  $myprogram_name (-h | -V)  ... show help or version, then exit
EOD
}

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

#
# Main program starts here
#

stir_random();
add_entropy($], @INC, %ENV);
delete @ENV{'PATH', 'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

STDERR->autoflush(1);
STDERR->fcntl(F_SETFL, O_APPEND)
  or warn "Error setting O_APPEND on STDERR: $!";

umask(0027);  # set our preferred umask
POSIX::setlocale(LC_TIME,'C');  # English dates required in syslog and RFC 5322

# using Net::Server internal mechanism for a restart on HUP
$warm_restart = defined $ENV{BOUND_SOCKETS} && $ENV{BOUND_SOCKETS} ne '' ?1:0;

update_current_log_level();

# Read dynamic source code, and logging and notification message templates
# from the end of this file (pseudo file handle DATA)
#
$Amavis::Conf::notify_spam_admin_templ  = '';  # not used
$Amavis::Conf::notify_spam_recips_templ = '';  # not used
do {
  local($/) = "__DATA__\n";   # set line terminator to this string
  for (
    $extra_code_zmq, $extra_code_db,
    $extra_code_sql_lookup, $extra_code_ldap,
    $extra_code_in_ampdp, $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_redis,
    $extra_code_sql_base, $extra_code_sql_log, $extra_code_sql_quar,
    $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)
  { $_ = <Amavis::DATA>;
    defined($_) or die "Error reading optional code from the source file: $!";
    chomp($_);
  }
  binmode(\*Amavis::DATA, ':encoding(UTF-8)')
    or die "Can't set \*DATA encoding to UTF-8: $!";
  for (
    $Amavis::Conf::log_short_templ,
    $Amavis::Conf::log_verbose_templ,
    $Amavis::Conf::log_recip_templ,
    $Amavis::Conf::notify_sender_templ,
    $Amavis::Conf::notify_virus_sender_templ,
    $Amavis::Conf::notify_virus_admin_templ,
    $Amavis::Conf::notify_virus_recips_templ,
    $Amavis::Conf::notify_spam_sender_templ,
    $Amavis::Conf::notify_spam_admin_templ,
    $Amavis::Conf::notify_release_templ,
    $Amavis::Conf::notify_report_templ,
    $Amavis::Conf::notify_autoresp_templ)
  { $_ = <Amavis::DATA>;
    defined($_) or die "Error reading templates from the source file: $!";
    chomp($_);
  }
}; # restore line terminator
close(\*Amavis::DATA) or die "Error closing *Amavis::DATA: $!";
# close(STDIN)        or die "Error closing STDIN: $!";
# note: don't close STDIN just yet to prevent some other file taking up fd 0

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

# Consider dropping privileges early, before reading a config file.
# This is only possible if running under chroot will not be needed.
#
my $desired_group;                      # defaults to $desired_user's group
my $desired_user;                       # username or UID
if ($> != 0) { $desired_user = $> }     # use effective UID if not root

# Use a default, guaranteed safe path during startup, before loading
# an user-supplied one from the config file
$ENV{PATH} = "/bin:/usr/bin";

# collect and parse command line options
my($log_level_override, $max_servers_override);
my($myhome_override, $tempbase_override, $helpers_home_override);
my($quarantinedir_override, $db_home_override, $daemon_chroot_dir_override);
my($lock_file_override, $pid_file_override);
my(@listen_sockets_override, $listen_sockets_overridden);
my(@argv) = @ARGV;  # preserve @ARGV, may modify @argv
while (@argv >= 2 && $argv[0] =~ /^-[ugdimcpDHLPQRSTX]\z/ ||
       @argv >= 1 && $argv[0] =~ /^-/) {
  my($opt,$val);
  $opt = shift @argv;
  $val = shift @argv  if $opt !~ /^-[hV-]\z/;  # these take no arguments
  if ($opt eq '--') {
    last;
  } elsif ($opt eq '-h') {  # -h  (help)
    die "$myversion\n\n" . usage();
  } elsif ($opt eq '-V') {  # -V  (version)
    die "$myversion\n";
  } elsif ($opt eq '-X') {  # -X  (magic options: debugging, testing, ...)
    $i_know_what_i_am_doing{$_} = 1  for split(/\s*,\s*/, $val);
  } elsif ($opt eq '-u') {  # -u username
    if ($> == 0) { $desired_user = $val }
    else { print STDERR "Ignoring option -u when not running as root\n" }
  } elsif ($opt eq '-g') {  # -g group
    print STDERR "NOTICE: Option -g may not achieve desired result when ".
                 "running as non-root\n"  if $> != 0 && $val ne $desired_group;
    $desired_group = $val;
  } elsif ($opt eq '-i') {  # -i instance_name, may be of use to a .conf file
    $val =~ /^[a-z0-9._+-]*\z/i  or die "Special chars in option -i $val\n";
    $instance_name = untaint($val);  # not used by amavisd directly
  } elsif ($opt eq '-d') {  # -d log_level or -d SAdbg1,SAdbg2,..,SAdbg3
    $log_level_override = untaint($val);
  } elsif ($opt eq '-m') {  # -m max_servers
    $val =~ /^\+?\d+\z/  or die "Option -m requires a numeric argument\n";
    $max_servers_override = untaint($val);
  } elsif ($opt eq '-c') {  # -c config_file
    push(@config_files, untaint($val))  if $val ne '';
  } elsif ($opt eq '-p') {  # -p port_or_socket
    $listen_sockets_overridden = 1;  # may disable all sockets by -p ''
    push(@listen_sockets_override, untaint($val))  if $val ne '';
  } elsif ($opt eq '-D') {  # -D db_home_dir, empty string turns off db use
    $db_home_override = untaint($val);
  } elsif ($opt eq '-H') {  # -H home_dir
    $myhome_override = untaint($val)  if $val ne '';
  } elsif ($opt eq '-L') {  # -L lock_file
    $lock_file_override = untaint($val) if $val ne '';
  } elsif ($opt eq '-P') {  # -P pid_file
    $pid_file_override = untaint($val);  # empty disables pid_file
  } elsif ($opt eq '-Q') {  # -Q quarantine_dir, empty string disables quarant.
    $quarantinedir_override = untaint($val);
  } elsif ($opt eq '-R') {  # -R chroot_dir, empty string or '/' avoids chroot
    $daemon_chroot_dir_override = $val eq '/' ? '' : untaint($val);
  } elsif ($opt eq '-S') {  # -S helpers_home_dir for SA
    $helpers_home_override = untaint($val)  if $val ne '';
  } elsif ($opt eq '-T') {  # -T tempbase_dir
    $tempbase_override = untaint($val)  if $val ne '';
  } else {
    die "Error in parsing command line options: $opt\n\n" . usage();
  }
}
my $cmd = lc(shift @argv);
if ($cmd !~ /^(?:start|debug|debug-sa|foreground|reload|restart|stop|
                 showkeys?|testkeys?|genrsa|convert_keysfile)?\z/xs) {
  die "$myversion:\n  Unknown command line parameter: $cmd\n\n" . usage();
} elsif (@argv > 0 &&
         $cmd !~ /^(:?showkeys?|testkeys?|genrsa|convert_keysfile)/xs) {
  die sprintf("%s:\n  Only one command line parameter allowed: %s\n\n%s\n",
              $myversion, join(' ',@argv), usage());
}

if (grep($_, values %i_know_what_i_am_doing)) {
  my(@known, @unknown);
  push(@{/^no_conf_file_writable_check\z/ ? \@known : \@unknown}, $_)
    for grep($i_know_what_i_am_doing{$_}, keys %i_know_what_i_am_doing);
  $unknown[0] = 'unknown: ' . $unknown[0]  if @unknown;
  warn sprintf("I know what I'm doing: %s\n", join(', ',@known,@unknown));
}

# deal with debugging early, based on a command line arg
if ($cmd =~ /^(?:start|debug|debug-sa|foreground)?\z/) {
  $daemonize=0                  if $cmd eq 'foreground';
  $daemonize=0, $DEBUG=1        if $cmd eq 'debug';
  $daemonize=0, $sa_debug='all' if $cmd eq 'debug-sa';
}

if (!defined($desired_user)) {
  # early dropping of privileges not requested
} elsif ($> != 0 && $< != 0) {
  # early dropping of privileges not needed
} elsif (defined $daemon_chroot_dir_override &&
         $daemon_chroot_dir_override ne '') {
  # early dropping of privs would prevent later chroot and is to be skipped
} else {
  # drop privileges early if a uid was specified on a command line, option -u
  drop_priv($desired_user,$desired_group);
}

if ($cmd eq 'genrsa') {
  eval $extra_code_tools or die "Problem in Amavis::Tools code: $@";
  $extra_code_tools = 1; Amavis::Tools::generate_dkim_private_key(@argv);
  exit(0);
}
if ($cmd eq 'convert_keysfile') {
  eval $extra_code_tools or die "Problem in Amavis::Tools code: $@";
  $extra_code_tools = 1; Amavis::Tools::convert_dkim_keys_file(@argv);
  exit(0);
}

# these settings must be overridden before and after read_config
# because some other settings in a config file may be derived from them
$Amavis::Conf::MYHOME   = $myhome_override    if defined $myhome_override;
$Amavis::Conf::TEMPBASE = $tempbase_override  if defined $tempbase_override;
$Amavis::Conf::QUARANTINEDIR = $quarantinedir_override
                                        if defined $quarantinedir_override;
$Amavis::Conf::helpers_home = $helpers_home   if defined $helpers_home;
$Amavis::Conf::daemon_chroot_dir = $daemon_chroot_dir_override
                                        if defined $daemon_chroot_dir_override;

# some remaining initialization, possibly after dropping privileges by -u,
# but before reading configuration file
init_local_delivery_aliases();
init_builtin_macros();
$instance_name = ''  if !defined $instance_name;

# convert arrayref to Amavis::Lookup::RE object, the Amavis::Lookup::RE module
# was not yet available during BEGIN phase
$Amavis::Conf::map_full_type_to_short_type_re =
  Amavis::Lookup::RE->new(@$Amavis::Conf::map_full_type_to_short_type_re);

# default location of the config file if none specified
if (!@config_files) {
  # Debian/Ubuntu specific:
  @config_files = Amavis::Util::find_config_files('/usr/share/amavis/conf.d',
    '/etc/amavis/conf.d');
}

# Read and evaluate config files, which may override default settings
Amavis::Conf::include_config_files(@config_files);
Amavis::Conf::supply_after_defaults();
update_current_log_level();
add_entropy($Amavis::Conf::myhostname, $Amavis::Conf::myversion_date);

# not needed any longer, reclaim storage
undef $Amavis::Conf::log_short_templ;
undef $Amavis::Conf::log_verbose_templ;

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

if ($> != 0 && $< != 0) {
  # dropping of privs is not needed
} elsif (defined $daemon_chroot_dir && $daemon_chroot_dir ne '') {
  # dropping of privs now would prevent later chroot and is to be skipped
} elsif (defined $daemon_user && $daemon_user ne '') {
  # drop privileges, unless needed for chrooting
  drop_priv($daemon_user,$daemon_group);
}

# override certain config file options by command line arguments
$sa_debug='all'  if $cmd eq 'debug-sa';
my(@sa_debug_fac);  # list of SA debug facilities
if (defined $log_level_override) {
  for my $item (split(/[ \t]*,[ \t]*/, $log_level_override, -1)) {
    if ($item =~ /^[+-]?\d+\z/) { $Amavis::Conf::log_level = $item }
    elsif ($item =~ /^[A-Za-z0-9_-]+\z/) { push(@sa_debug_fac,$item) }
  }
  update_current_log_level();
}
$Amavis::Conf::MYHOME    = $myhome_override     if defined $myhome_override;
$Amavis::Conf::TEMPBASE  = $tempbase_override   if defined $tempbase_override;
$Amavis::Conf::QUARANTINEDIR = $quarantinedir_override
                                       if defined $quarantinedir_override;
$Amavis::Conf::helpers_home = $helpers_home     if defined $helpers_home;
$Amavis::Conf::daemon_chroot_dir = $daemon_chroot_dir_override
                                       if defined $daemon_chroot_dir_override;
if (defined $db_home_override) {
  if ($db_home_override =~ /^\s*\z/) { $enable_db = 0 }
  else { $Amavis::Conf::db_home = $db_home_override }
}
if (defined $max_servers_override && $max_servers_override ne '') {
  $Amavis::Conf::max_servers = $max_servers_override;
}

if ($cmd =~ /^(?:showkeys?|testkeys?)\z/) {
  # useful for preparing DNS zone files and testing public keys in DNS
  eval $extra_code_dkim or die "Problem in Amavis::DKIM code: $@";
  $extra_code_dkim = 1; Amavis::DKIM::dkim_key_postprocess();
  eval $extra_code_tools or die "Problem in Amavis::Tools code: $@";
  $extra_code_tools = 1;  # release memory occupied by the source code
  Amavis::Tools::show_or_test_dkim_public_keys($cmd,\@argv);
  exit(0);
}
undef $extra_code_tools;  # no longer needed

for ($unix_socketname, $inet_socket_port) {
  push(@listen_sockets, ref $_ ? @$_ : $_)  if defined $_ && $_ ne '';
}
@listen_sockets = @listen_sockets_override  if $listen_sockets_overridden;
for my $s (@listen_sockets) {
  # convert to a Net::Server::Proto syntax
  local($1);
  if    ($s =~ m{^unix:(/\S+)\z}s) { $s = "$1|unix" }
  elsif ($s =~ m{^inet:(.*)\z}s)   { $s = "$1/tcp" }
  elsif ($s =~ m{^inet6:(.*)\z}s)  { $s = "$1/tcp" }
  elsif ($s =~ m{^/\S+}s)          { $s = "$s|unix" }
  elsif ($s =~ m{^\d+\z}s)         { $s = "$s/tcp" }  # port number
  elsif ($s =~ m{^[^/|]+\z}s)      { $s = "$s/tcp" }  # almost anything goes
  elsif ($s =~ m{^.+\z}s)          { $s = "$s" }      # anything goes
  else { die "Socket specification syntax error: $s\n" }
}
@listen_sockets > 0  or die "No listen sockets or ports specified\n";

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

# NOTE: when releasing memory occupied by the source code, keep in mind:
# use undef(), see: http://www.perlmonks.org/?node_id=803515

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

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

{ my $any_dkim_verification =
    scalar(grep { my $v = $policy_bank{$_}{'enable_dkim_verification'};
                  !ref $v ? $v : $$v } keys %policy_bank);
  my $any_dkim_signing =
    scalar(grep { my $v = $policy_bank{$_}{'enable_dkim_signing'};
                  !ref $v ? $v : $$v } keys %policy_bank);
  if (!$any_dkim_verification && !$any_dkim_signing) {
    undef $extra_code_dkim;
  } else {
    eval $extra_code_dkim or die "Problem in Amavis::DKIM code: $@";
    # release memory occupied by the source code
    undef $extra_code_dkim; $extra_code_dkim = 1;
  }
  if ($any_dkim_signing) {
    Amavis::DKIM::dkim_key_postprocess();
  } else {  # release storage
    undef %dkim_signing_keys_by_domain;
    undef @dkim_signing_keys_list; undef @dkim_signing_keys_storage;
  }
}

{ my(%needed_protocols_in);
  for my $bank_name (keys %policy_bank) {
    my $var = $policy_bank{$bank_name}{'protocol'};
    $var = $$var  if ref($var) eq 'SCALAR';  # allow one level of indirection
    $needed_protocols_in{$var} = 1  if defined $var;
  }
  # compatibility with older config files unaware of $protocol config variable
# $needed_protocols_in{'AM.CL'} = 1   # AM.CL is no longer supported
#   if grep(m{\|unix\z}i, @listen_sockets) &&
#     !grep($needed_protocols_in{$_}, qw(AM.PDP COURIER));
  $needed_protocols_in{'SMTP'} = 1
    if grep(m{/(?:tcp|ssleay|ssl)\z}i, @listen_sockets) &&
      !grep($needed_protocols_in{$_}, qw(SMTP LMTP QMQPqq));
  if ($needed_protocols_in{'AM.PDP'} || $needed_protocols_in{'AM.CL'}) {
    eval $extra_code_in_ampdp or die "Problem in the In::AMPDP code: $@";
    # release memory occupied by the source code
    undef $extra_code_in_ampdp; $extra_code_in_ampdp = 1;
  } else {
    undef $extra_code_in_ampdp;
  }
  if ($needed_protocols_in{'SMTP'} || $needed_protocols_in{'LMTP'}) {
    eval $extra_code_in_smtp or die "Problem in the In::SMTP code: $@";
    # release memory occupied by the source code
    undef $extra_code_in_smtp; $extra_code_in_smtp = 1;
  } else {
    undef $extra_code_in_smtp;
  }
  if ($needed_protocols_in{'COURIER'}) {
    eval $extra_code_in_courier or die "Problem in the In::Courier code: $@";
    # release memory occupied by the source code
    undef $extra_code_in_courier; $extra_code_in_courier = 1;
  } else {
    undef $extra_code_in_courier;
  }
  if ($needed_protocols_in{'QMQPqq'})  { die "In::QMQPqq code not available" }
}

if (!@lookup_sql_dsn) { undef $extra_code_sql_lookup }
if (!@storage_sql_dsn) { undef $extra_code_sql_log }
if (!@storage_redis_dsn) { undef $extra_code_redis }
# sql quarantine depends on sql log
undef $extra_code_sql_quar  if !defined $extra_code_sql_log;

{ my(%needed_protocols_out); local($1);
  for my $bank_name (keys %policy_bank) {
    for my $method_name (qw(
         forward_method notify_method resend_method
         release_method requeue_method
         os_fingerprint_method virus_quarantine_method
         banned_files_quarantine_method unchecked_quarantine_method
         spam_quarantine_method bad_header_quarantine_method
         clean_quarantine_method archive_quarantine_method )) {
      local($1); my $var = $policy_bank{$bank_name}{$method_name};
      $var = $$var  if ref($var) eq 'SCALAR';  # allow one level of indirection
      $needed_protocols_out{uc($1)} = 1  if $var =~ /^([a-z][a-z0-9.+-]*):/si;
    }
  }
  if (!$needed_protocols_out{'SMTP'} &&
      !$needed_protocols_out{'LMTP'}) { undef $extra_code_out_smtp }
  else {
    eval $extra_code_out_smtp or die "Problem in Amavis::Out::SMTP code: $@";
    # release memory occupied by the source code
    undef $extra_code_out_smtp; $extra_code_out_smtp = 1;
  }
  if (!$needed_protocols_out{'PIPE'}) { undef $extra_code_out_pipe }
  else {
    eval $extra_code_out_pipe or die "Problem in Amavis::Out::Pipe code: $@";
    # release memory occupied by the source code
    undef $extra_code_out_pipe; $extra_code_out_pipe = 1;
  }
  if (!$needed_protocols_out{'BSMTP'}) { undef $extra_code_out_bsmtp }
  else {
    eval $extra_code_out_bsmtp or die "Problem in Amavis::Out::BSMTP code: $@";
    # release memory occupied by the source code
    undef $extra_code_out_bsmtp; $extra_code_out_bsmtp = 1;
  }
  if (!$needed_protocols_out{'LOCAL'}) { undef $extra_code_out_local }
  else {
    eval $extra_code_out_local or die "Problem in Amavis::Out::Local code: $@";
    # release memory occupied by the source code
    undef $extra_code_out_local; $extra_code_out_local = 1;
  }
  if (!$needed_protocols_out{'SQL'}) { undef $extra_code_sql_quar }
  else {
    # deal with it in the next section
  }
  if (!$needed_protocols_out{'P0F'}) { undef $extra_code_p0f }
  else {
    eval $extra_code_p0f or die "Problem in OS_Fingerprint code: $@";
    # release memory occupied by the source code
    undef $extra_code_p0f; $extra_code_p0f = 1;
  }
}

if (defined $extra_code_redis) {
  eval $extra_code_redis or die "Problem in Amavis Redis code: $@";
  # release memory occupied by the source code
  undef $extra_code_redis; $extra_code_redis = 1;
}

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

if (!grep { my $v = $policy_bank{$_}{'enable_ldap'};
            !ref $v ? $v : $$v } keys %policy_bank) {
  undef $extra_code_ldap;
} else {  # at least one enable_ldap is true
  eval $extra_code_ldap or die "Problem in Lookup::LDAP code: $@";
  # release memory occupied by the source code
  undef $extra_code_ldap; $extra_code_ldap = 1;
}

my $bpvcm = ca('bypass_virus_checks_maps');
if (!@{ca('av_scanners')} && !@{ca('av_scanners_backup')}) {
  undef $extra_code_antivirus;
} elsif (@$bpvcm && !ref($bpvcm->[0]) && $bpvcm->[0]) {
  # do a simple-minded test to make it easy to turn off virus checks
  undef $extra_code_antivirus;
} else {
  eval $extra_code_antivirus or die "Problem in antivirus code: $@";
  # release memory occupied by the source code
  undef $extra_code_antivirus; $extra_code_antivirus = 1;
}
if (!$extra_code_antivirus) {  # release storage
  undef @Amavis::Conf::av_scanners; undef @Amavis::Conf::av_scanners_backup;
}

my(%spam_scanners_used);
my $bpscm = ca('bypass_spam_checks_maps');
if (!@{ca('spam_scanners')}) {
  undef $extra_code_antispam;
} elsif (@$bpscm && !ref($bpscm->[0]) && $bpscm->[0]) {  # simple-minded
  undef $extra_code_antispam;
} else {
  eval $extra_code_antispam or die "Problem in antispam code: $@";
  # release memory occupied by the source code
  undef $extra_code_antispam; $extra_code_antispam = 1;
  for my $as (@{ca('spam_scanners')}) {
    next  if !ref $as || !defined $as->[1];
    my($scanner_name,$module) = @$as; $spam_scanners_used{$module} = 1;
  }
}
if (!$extra_code_antispam) { undef @Amavis::Conf::spam_scanners }

# load required built-in spam scanning modules
if ($spam_scanners_used{'Amavis::SpamControl::ExtProg'}) {
  eval $extra_code_antispam_extprog or die "Problem in ExtProg code: $@";
  # release memory occupied by source code
  undef $extra_code_antispam_extprog; $extra_code_antispam_extprog = 1;
} else {
  undef $extra_code_antispam_extprog;
}
if ($spam_scanners_used{'Amavis::SpamControl::SpamdClient'}) {
  eval $extra_code_antispam_spamc or die "Problem in spamd client code: $@";
  # release memory occupied by source code
  undef $extra_code_antispam_spamc; $extra_code_antispam_spamc = 1;
} else {
  undef $extra_code_antispam_spamc;
}
if ($spam_scanners_used{'Amavis::SpamControl::SpamAssassin'}) {
  eval $extra_code_antispam_sa or die "Problem in antispam SA code: $@";
  # release memory occupied by the source code
  undef $extra_code_antispam_sa; $extra_code_antispam_sa = 1;
} else {
  undef $extra_code_antispam_sa;
}

if (!grep { exists $policy_bank{$_}{'bypass_decode_parts'} &&
            !do { my $v = $policy_bank{$_}{'bypass_decode_parts'};
                  !ref $v ? $v : $$v } } keys %policy_bank) {
  undef $extra_code_unpackers;
} else {  # at least one bypass_decode_parts is explicitly false
  eval $extra_code_unpackers or die "Problem in Amavis::Unpackers code: $@";
  # release memory occupied by the source code
  undef $extra_code_unpackers; $extra_code_unpackers = 1;
}

if ($enable_zmq && $extra_code_zmq && @zmq_sockets) {
  # better to catch and report potential ZMQ problems early before forking
  $zmq_obj = Amavis::ZMQ->new(@zmq_sockets);
  if ($zmq_obj && !$warm_restart && $cmd !~ /^(?:reload|stop)\z/) {
    sleep 1;  # a crude way to avoid a "slow joiner" syndrome  #***
    $zmq_obj->put_initial_snmp_data('FLUSH');
    $zmq_obj->register_proc(1,1,'FLUSH');
  }
}

Amavis::Log::init($do_syslog, $logfile);  # initialize logging
Amavis::Log::log_to_stderr($cmd eq 'debug' || $cmd eq 'debug-sa' ? 1 : 0);
do_log(1, 'logging initialized, log level %s, %s%s', c('log_level'),
  $do_syslog ? sprintf("syslog: %s.%s",c('syslog_ident'),c('syslog_facility')):
    $logfile ne '' ? "logfile: $logfile" : "STDERR",
  !$enable_log_capture ? '' : ', log capture enabled');
do_log(2, 'ZMQ enabled: %s', Amavis::ZMQ::zmq_version())  if $zmq_obj;
sd_notify(0, "STATUS=Config files have been read, modules loaded.");

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

$mail_id_size_bits > 0 &&
$mail_id_size_bits == int $mail_id_size_bits &&
$mail_id_size_bits % 24 == 0
  or die "\$mail_id_size_bits ($mail_id_size_bits) must be a multiple of 24\n";

my $amavisd_pid;  # PID of the currently running amavisd daemon (not our pid)
my $amavisd_pid_by_mainpid;  # is $amavisd_pid provided by $ENV{MAINPID} ?
eval {  # is amavisd daemon already running?
  if (defined $ENV{MAINPID}) {  # provided by systemd.exec(5) ?
    local($1);
    if ($ENV{MAINPID} =~ /^\s* ( [0-9]{1,10} ) \s*\z/xs && $1 > 0) {
      $amavisd_pid = untaint($1);
      $amavisd_pid_by_mainpid = 1;
    }
  }
  my $pidf = defined $pid_file_override ? $pid_file_override : $pid_file;
  if (defined $amavisd_pid) {
    if (defined $pidf && $pidf ne '') {
      do_log(2, 'Master PID [%s] provided by the MAINPID env.var, '.
                'not checking $pid_file', $amavisd_pid);
    } else {
      do_log(2, 'Master PID [%s] provided by the MAINPID env.var, '.
                'no $pid_file', $amavisd_pid);
    }
  } elsif (!defined $pidf || $pidf eq '') {
    do_log(2, 'no $pid_file configured, not checking it');
  } elsif ($warm_restart) {
    # skip pid file checking, let Net::Server handle it
  } else {
    my(@stat_list) = lstat($pidf);
    my $errn = @stat_list ? 0 : 0+$!;
    if ($errn == ENOENT) {
      die "The amavisd daemon is apparently not running, no PID file $pidf\n"
        if $cmd =~ /^(?:reload|restart|stop)\z/;
    } elsif ($errn != 0) {
      die "PID file $pidf is inaccessible: $!\n";
    } elsif (!-f _) {
      die "PID file $pidf is not a regular file\n";
    } else {  # find and validate PID of the currently running amavisd daemon
      my $ln; my $lcnt = 0; my $pidf_h = IO::File->new;
      $pidf_h->open($pidf,'<') or die "Can't open PID file $pidf: $!";
      for ($! = 0; defined($ln=$pidf_h->getline); $! = 0) {
        chomp($ln); $lcnt++; last if $lcnt > 100;
        $amavisd_pid = $ln  if $lcnt == 1 && $ln =~ /^\d{1,10}\z/;
      }
      defined $ln || $! == 0  or die "Error reading from file $pidf: $!";
      $pidf_h->close or die "Error closing file $pidf: $!";
      if ($lcnt <= 1 && !defined $amavisd_pid) {
        # empty or junk one-line pid file treated the same as nonexisting file
        die "The amavisd daemon is apparently not running, ".
            "empty PID file $pidf\n"  if $cmd =~ /^(?:reload|restart|stop)\z/;
        # prevent Net::Server from seeing this crippled file
        do_log(-1, "removing empty or crippled PID file %s", $pidf);
        unlink($pidf) or die "Can't remove PID file $pidf: $!";
        undef $amavisd_pid;
      } else {
        $lcnt <= 1           or die "More than one line in file $pidf";
        defined $amavisd_pid or die "Missing process ID in file $pidf";
        $amavisd_pid >= 1    or die "Invalid PID in file $pidf: [$amavisd_pid]";
          # note that amavisd under Docker may run as PID #1
      }
      my $mtime = $stat_list[9];
      if (defined $amavisd_pid && defined $mtime) {  # got a PID from a file
        # Is pid file older than system uptime? If so, it should be disregarded,
        # it must not prevent starting up amavisd after unclean shutdown.
        my $now = int(time); my($uptime,$uptime_fmt);  # sys uptime in seconds
        my(@prog_args); my(@progs) = ('/usr/bin/uptime','uptime');
        if (lc($^O) eq 'freebsd')
          { @progs = ('/sbin/sysctl','sysctl'); @prog_args = 'kern.boottime' }
        my $prog = find_program_path(\@progs, [split(/:/,$path,-1)] );
        if (!defined($prog)) {
          do_log(1,'No programs: %s',join(", ",@progs));
        } else {  # obtain system uptime
          my($proc_fh,$uppid);
          eval {
            ($proc_fh,$uppid) = run_command(undef,'/dev/null',$prog,@prog_args);
            for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
              local($1,$2,$3,$4); chomp($ln);
              if (defined $uptime) {}
              elsif ($ln =~ /{[^}]*\bsec\s*=\s*(\d+)[^}]*}/) {
                $uptime = $now - $1;
              # amazingly broken reports from uptime(1) soon after boot!
              } elsif ($ln =~ /\b up \s+ (?: (\d{1,4}) \s* days? )? [,\s]*
                           (\d{1,2}) : (\d{1,2}) (?: : (\d{1,2}))? (?! \d ) /ix
                  || $ln =~ /\b up (?:   \s*  \b (\d{1,4}) \s* days? )?
                                   (?: [,\s]* \b (\d{1,2}) \s* hrs?  )?
                                   (?: [,\s]* \b (\d{1,2}) \s* mins? )?
                                   (?: [,\s]* \b (\d{1,2}) \s* secs? )? /ix ) {
                $uptime = (($1*24 + $2)*60 + $3)*60 + $4;
              } elsif ($ln =~ /\b (\d{1,2}) \s* secs?/ix) {
                $uptime = $1;  # OpenBSD
              }
              $uptime_fmt = format_time_interval($uptime);
              do_log(5,"system uptime %s: %s", $uptime_fmt,$ln);
            }
            defined $ln || $! == 0  or die "Reading uptime: $!";
            my $err=0; $proc_fh->close or $err = $!;
            my $child_stat = defined $uppid && waitpid($uppid,0)>0 ? $? : undef;
            undef $proc_fh; undef $uppid;
            proc_status_ok($child_stat,$err)
              or die "Error running $prog: " .
                     exit_status_str($child_stat,$err) . "\n";
          } or do {
            my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
            do_log(1,"uptime: %s", $eval_stat);
          };
          if (defined $proc_fh) { $proc_fh->close }  # ignoring status
          if (defined $uppid) { waitpid($uppid,0) }  # ignoring status
        }
        if (!defined $uptime) {
          do_log(1,'Unable to determine system uptime, will trust PID file %s',
                   $pidf);
        } elsif ($now-$mtime <= $uptime+70) {
          do_log(1,'Valid PID file %s (younger than sys uptime %s)',
                   $pidf, $uptime_fmt);
        } else {  # must not kill an unrelated process which happens to have the
                  # same pid as amavisd had before a system shutdown or crash
          undef $amavisd_pid;
          do_log(1,'Ignoring stale PID file %s, older than system uptime %s',
                   $pidf, $uptime_fmt);
        }
      }
    }
  }
  if (defined $amavisd_pid) {
    untaint_inplace($amavisd_pid);
    if (!kill(0,$amavisd_pid)) {  # does a process exist?
      $! == ESRCH  or die "Can't send SIG 0 to process [$amavisd_pid]: $!";
      do_log(2, 'No such process [%s], supposedly the current amavisd '.
                'master process', $amavisd_pid);
      undef $amavisd_pid;  # process does not exist
    };
  }

  if ($warm_restart) {
    # a semi-documented Net::Server mechanism for a restart on HUP;
    # assume we have just been reincarnated by exec as a result of a HUP,
    # so just ignore the command parameter and let Net::Server do the rest
  } elsif ($cmd =~ /^(?:start|debug|debug-sa|foreground)?\z/) {
    !defined($amavisd_pid)
      or die "The amavisd daemon is already running, PID: [$amavisd_pid]\n";
  } elsif ($cmd eq 'reload') {  # reload: send a HUP signal to a running daemon
    my $pidf = defined $pid_file_override ? $pid_file_override : $pid_file;
    if (!defined $amavisd_pid && (!defined $pidf || $pidf eq '')) {
      die "No PID file, cannot determine a process ID of a running daemon.\n" .
          "To reload an existing amavisd daemon send it a SIGHUP signal.\n";
    } elsif (!defined $amavisd_pid) {
      die "The amavisd daemon is apparently not running, cannot reload it.\n";
    } else {
      kill('HUP',$amavisd_pid) or $! == ESRCH
        or die "Can't SIGHUP amavisd[$amavisd_pid]: $!";
      my $msg = "Signalling a SIGHUP to a running daemon [$amavisd_pid]";
      do_log(2,"%s",$msg);
    # print STDOUT "$msg\n";
      exit(0);
    }
  } elsif ($cmd =~ /^(?:restart|stop)\z/) {  # stop or restart
    my $pidf = defined $pid_file_override ? $pid_file_override : $pid_file;
    if (!defined $amavisd_pid && (!defined $pidf || $pidf eq '')) {
      die "No PID file, cannot determine a process ID of a running daemon.\n" .
          "To stop an existing amavisd daemon send it a SIGTERM signal.\n";
    } elsif (!defined $amavisd_pid) {
      die "The amavisd daemon is apparently not running, cannot stop it.\n";
    } else {
      my($kill_sig_used, $killed_amavisd_pid);
      eval {  # first stop a running daemon
        $kill_sig_used = 'TERM';
        kill($kill_sig_used,$amavisd_pid) or $! == ESRCH
          or die "Can't SIG$kill_sig_used amavisd[$amavisd_pid]: $!";
        my $waited = 0; my $sigkill_sent = 0; my $delay = 1;  # seconds
        for (;;) {  # wait for the old running daemon to go away
          sleep($delay); $waited += $delay; $delay = 5;
          if (!kill(0,$amavisd_pid)) {  # is the old daemon still there?
            $! == ESRCH or die "Can't send SIG 0 to amavisd[$amavisd_pid]: $!";
            $killed_amavisd_pid = $amavisd_pid;    # old process is gone, done
            last;
          }
          if ($waited < 60 || $sigkill_sent) {
            do_log(2,"Waiting for the process [%s] to terminate",$amavisd_pid);
            print STDOUT
              "Waiting for the process [$amavisd_pid] to terminate\n";
          } else {  # use stronger hammer
            do_log(2,"Sending SIGKILL to amavisd[%s]",$amavisd_pid);
            print STDERR "Sending SIGKILL to amavisd[$amavisd_pid]\n";
            $kill_sig_used = 'KILL';
            kill($kill_sig_used,$amavisd_pid) or $! == ESRCH
              or warn "Can't SIGKILL amavisd[$amavisd_pid]: $!";
            $sigkill_sent = 1;
          }
        }
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        die "$eval_stat, can't $cmd the process\n";
      };
      my $msg = !defined($killed_amavisd_pid) ? undef :
                "Daemon [$killed_amavisd_pid] terminated by SIG$kill_sig_used";
      if ($cmd eq 'stop') {
        if (defined $msg) { do_log(2,"%s",$msg); print STDOUT "$msg\n" }
        exit(0);
      }
      if (defined $killed_amavisd_pid) {
        print STDOUT "$msg, waiting for dust to settle...\n";
        sleep 5;  # wait for TCP sockets to be released
      }
      print STDOUT "becoming a new daemon...\n";
    }
  } else {
    die "$myversion: Unknown command line parameter: $cmd\n\n" . usage();
  }
  1;
} or do {
  my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
  do_log(2,"%s", $eval_stat);
  die "$eval_stat\n";
};
$daemonize = 0  if $DEBUG;  # in case $DEBUG came from a config file

# Set path, home and term explicitly.  Don't trust environment
$ENV{PATH} = $path          if defined $path && $path ne '';
$ENV{HOME} = $helpers_home  if defined $helpers_home && $helpers_home ne '';
$ENV{TERM} = 'dumb'; $ENV{COLUMNS} = '80'; $ENV{LINES} = '100';
{ my $msg = '';
  $msg .= ", instance=$instance_name" if $instance_name ne '';
  $msg .= ", nl=".sprintf('\\x%02X',ord("\n"))  if "\n" ne "\012";
  $msg .= ", Unicode aware";          # ensured by 'require 5.008'
  for (qw(PERLIO LC_ALL LC_TYPE LC_CTYPE LANG))
    { $msg .= sprintf(', %s="%s"', $_,$ENV{$_})  if $ENV{$_} ne '' }
  do_log(0,"starting.%s %s at %s %s%s",
         !$warm_restart?'':' (warm)', $0,
         idn_to_utf8(c('myhostname')), $myversion, $msg);
}
# report version of Perl and process UID/GID
do_log(1, "perl=%s, user=%s, EUID: %s (%s);  group=%s, EGID: %s (%s)",
          $], $desired_user, $>, $<, $desired_group, $), $();
if ($warm_restart) {
  # a semi-documented Net::Server mechanism to let a restarted process
  # re-acquire sockets from its predecessor on a HUP
  my $str = $ENV{BOUND_SOCKETS};  $str =~ s/\n/, /gs;
  do_log(1,"warm restart on HUP [%s]: '%s', sockets: %s",
           $$, join(' ',$0,@ARGV), $str);
}

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

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

# log warnings and uncaught errors
$SIG{'__DIE__' } =
  sub { return if $^S || !defined $^S;
        my $m = $_[0]; chomp($m); do_log(-1,"_DIE: %s", $m);
      };
$SIG{'__WARN__'} =
  sub { my $m = $_[0]; chomp($m); do_log(2,"_WARN: %s", $m) };
# use Data::Dumper;
# my $m2 = Carp::longmess(); do_log(2,"%s",Dumper($m2));

if (!defined $io_socket_module_name) {
  do_log(-1,"no INET or INET6 socket modules available");
} else {
  do_log(2,"socket module %s, protocol families available: %s",
           $io_socket_module_name,
           join(', ', !$have_inet4 ? () :'INET', !$have_inet6 ? () :'INET6'));
}

# matches global unicast addresses
# (i.e. valid addresses except: local, private or multicast addresses)
# RFC 5735 (ex RFC 3330), RFC 3513 (IPv6), RFC 4193 (ULA), RFC 6598 (CGN)
@public_networks_maps = (
  Amavis::Lookup::Label->new('public_nets'),
  Amavis::Lookup::IP->new(qw(
    !127.0.0.0/8 !::1 !0.0.0.0/8 !:: !169.254.0.0/16 !fe80::/10
    !10.0.0.0/8 !172.16.0.0/12 !192.168.0.0/16 !fc00::/7 !100.64.0.0/10
    !240.0.0.0/4 !224.0.0.0/4 !ff00::/8
    ::ffff:0:0/96 ::/0 )) );

# set up Net::Server configuration
my(@bind_to);
{ # merge port numbers, unix sockets and default binding host address into
  # a unified list @listen_sockets, which will be passed on to Net::Server
  #
  local($1);
  @bind_to = ref $inet_socket_bind ? @$inet_socket_bind : $inet_socket_bind;
  $_ = !defined $_ || $_ eq '' ? '*' : /^\[(.*)\]\z/s ? $1 : $_  for @bind_to;
  @bind_to = ( '*' )  if !@bind_to;
  my(@merged_listen_sockets, @ignored);
  for (@listen_sockets) {
    # roughly mimic the Net::Server::Proto and Net::Server::Proto::TCP parsing
    if (m{^/} || m{[/|]unix\z}si) {
      push(@merged_listen_sockets, $_);  # looks like a Unix socket
    } elsif (m{^ \[ [^\]]* \] : }xs || m{^ [^/|:]* : }xs) {
      push(@merged_listen_sockets, $_);  # explicit host & port specified
    } else {  # assume port (or service) specification only, supply bind addr
      for my $bind_addr (@bind_to) {  # Cartesian product: bind_addr x port
        # need brackets around an IPv6 address (as per RFC 5952, RFC 3986)
        push(@merged_listen_sockets,
             $bind_addr =~ /:[0-9a-f]*:/i ? "[$bind_addr]:$_"
                                          : "$bind_addr:$_" );
      }
    }
  }
  # filter listen sockets according to protocol families available
  @listen_sockets = ();
  for (@merged_listen_sockets) {
    if (m{^/} || m{[/|]unix\z}si) {
      push(@listen_sockets, $_);  # looks like a Unix socket
    } elsif (m{^ \[ ( [^\]]* ) \] : }xs || m{^ ([^/|:]*) : }xs) {
      my $addr = $1;
      if ($addr =~ /:[0-9a-f]*:/i) {  # looks like an IPv6 address
        push(@{$have_inet6 ? \@listen_sockets : \@ignored}, $_);
      } elsif ($addr =~ /^\d+\.\d+\.\d+\.\d+\z/s) {  # an IPv4 address
        push(@{$have_inet4 ? \@listen_sockets : \@ignored}, $_);
      } else {  # can't tell without resolving, take it without checking
        push(@listen_sockets, $_);
      }
    }
  }
  do_log(2,"ignored due to unsupported protocol family: %s",
           join(', ',@ignored))  if @ignored;
  @listen_sockets or die "No listen sockets specified, aborting\n";
  do_log(2,"will bind to %s", join(', ',@listen_sockets));
}

# better catch and report potential Redis problems early before forking
if ($extra_code_redis && @storage_redis_dsn) {
  eval {
    my $redis_storage_tmp = Amavis::Redis->new(@storage_redis_dsn);
    $redis_storage_tmp->connect; undef $redis_storage_tmp; 1;
  } or do {
    warn "Redis error, starting anyway: $@";
  };
}

# DESTROY a ZMQ context (if any) of the main process,
# it would not survive across daemonization / forking,
# each child process needs to make its own context and sockets
undef $zmq_obj;

my $server = Amavis->new({
    # command args to be used after HUP must be untainted, deflt: [$0,@ARGV]
  # commandline => ['/usr/local/sbin/amavisd','-c',$config_file[0] ],
  # commandline => [],  # disable
    commandline => [ map(untaint($_), ($0,@ARGV)) ],
    port => \@listen_sockets,  # listen on these sockets (Unix, inet, inet6)
    host => $bind_to[0],  # default bind, redundant, merged to @listen_sockets
    listen => $listen_queue_size, # undef for a default
    max_servers => $max_servers,  # number of pre-forked children
    !defined($min_servers) ? ()
    : ( min_servers       => $min_servers,
        min_spare_servers => $min_spare_servers,
        max_spare_servers => $max_spare_servers),
    max_requests => defined $max_requests && $max_requests > 0 ? $max_requests
                                               : 2E9,  # avoid default of 1000
    user       => ($> == 0 || $< == 0) ? $daemon_user  : undef,
    group      => ($> == 0 || $< == 0) ? $daemon_group : undef,
    pid_file   => $amavisd_pid_by_mainpid ? undef
                  : defined $pid_file_override ? $pid_file_override : $pid_file,
    # socket serialization lockfile
    lock_file  => defined $lock_file_override? $lock_file_override: $lock_file,
  # serialize  => 'flock',     # flock, semaphore, pipe
    background => $daemonize ? 1 : undef,
    setsid     => $daemonize ? 1 : undef,
    chroot     => $daemon_chroot_dir ne '' ? $daemon_chroot_dir : undef,
    no_close_by_child => 1,
    leave_children_open_on_hup => 1,
    # no_client_stdout introduced with Net::Server 0.92, but is broken in 0.92
    no_client_stdout => (Net::Server->VERSION >= 0.93 ? 1 : 0),
    # controls log level for Net::Server internal log messages:
    #   0=err, 1=warning, 2=notice, 3=info, 4=debug
    log_level  => ($DEBUG || c('log_level') >= 5) ? 4 : 2,
    log_file   => undef,  # method will be overridden by a call to do_log()
  # SSL_cert_file => "$MYHOME/cert/mail-cert.pem",
  # SSL_key_file  => "$MYHOME/cert/mail-key.pem",
});

$0 = c('myprogram_name') . ' (master)';
sd_notify(0, "STATUS=Transferring control to Net::Server.");

$server->run;  # transferring control to Net::Server

# shouldn't get here
exit 1;
1;  # make perlcritic happy

# we read text (such as notification templates) from DATA sections
# to avoid any interpretations of special characters (e.g. \ or ') by Perl
#

__DATA__
#
package Amavis::ZMQ;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform $myversion $nanny_details_level);
  import Amavis::Util qw(ll do_log do_log_safe
                         snmp_initial_oids snmp_counters_get);
}

use vars qw($zmq_mod_name $zmq_mod_version $zmq_lib_version);
BEGIN {
  my($zmq_major, $zmq_minor, $zmq_patch);
  if (eval { require ZMQ::LibZMQ3 && require ZMQ::Constants }) {
    $zmq_mod_name = 'ZMQ::LibZMQ3';  # new interface module to zmq v3 or libxs
    import ZMQ::LibZMQ3;  import ZMQ::Constants qw(:all);
    ($zmq_major, $zmq_minor, $zmq_patch) = ZMQ::LibZMQ3::zmq_version();
  # *zmq_sendmsg   [native]                   # (socket,msgobj,flags)
  # *zmq_recvmsg   [native]                   # (socket,flags) -> msgobj
    *zmq_sendstr = sub {                      # (socket,string,flags)
      my $rv = zmq_send($_[0], $_[1], length $_[1], $_[2]||0);
      $rv == -1 ? undef : $rv;
    };
  } elsif (eval { require ZMQ::LibZMQ2 && require ZMQ::Constants }) {
    $zmq_mod_name = 'ZMQ::LibZMQ2';  # new interface module to zmq v2
    import ZMQ::LibZMQ2;  import ZMQ::Constants qw(:all);
    ($zmq_major, $zmq_minor, $zmq_patch) = ZMQ::LibZMQ2::zmq_version();
    # zmq v2/v3 incompatibile renaming
    *zmq_sendmsg = \&ZMQ::LibZMQ2::zmq_send;  # (socket,msgobj,flags)
    *zmq_recvmsg = \&ZMQ::LibZMQ2::zmq_recv;  # (socket,flags) -> msgobj
    *zmq_sendstr = sub {                      # (socket,string,flags)
      my $rv = zmq_send(@_);  $rv == -1 ? undef : $rv;
    };
  } elsif (eval { require ZeroMQ::Constants && require ZeroMQ::Raw }) {
    $zmq_mod_name = 'ZeroMQ';  # old interface module to zmq v2
    import ZeroMQ::Raw;  import ZeroMQ::Constants qw(:all);
    ($zmq_major, $zmq_minor, $zmq_patch) = ZeroMQ::version();
    # zmq v2/v3 incompatibile renaming
    *zmq_sendmsg = \&ZeroMQ::Raw::zmq_send;   # (socket,msgobj,flags)
    *zmq_recvmsg = \&ZeroMQ::Raw::zmq_recv;   # (socket,flags) -> msgobj
    *zmq_sendstr = sub {                      # (socket,string,flags)
      my $rv = zmq_send(@_);  $rv == -1 ? undef : $rv;
    };
  } else {
    die "Perl modules ZMQ::LibZMQ3 or ZMQ::LibZMQ2 or ZeroMQ not available\n";
  }
  $zmq_mod_version = $zmq_mod_name->VERSION;
  $zmq_lib_version = join('.', $zmq_major, $zmq_minor, $zmq_patch);
  1;
} # BEGIN

sub zmq_version {
  sprintf("%s %s, lib %s",
          $zmq_mod_name, $zmq_mod_version, $zmq_lib_version);
};

sub new {
  my($class,@socknames) = @_;
  my $self = { ctx => undef, sock => undef,
               inactivated => 0, socknames => [ @socknames ],
               base_timestamp => undef };
  bless $self, $class;
  $self->establish;
  $self;
}

sub inactivate {
  my $self = $_[0];
  $self->{inactivated} = 1;
}

use vars qw($zmq_in_establish);  # prevents loop if logging to zmq

sub establish {
  my $self = $_[0];
  return  if $self->{inactivated} || $zmq_in_establish;
  my($ctx,$sock);
  eval {
    $zmq_in_establish = 1;
    $ctx = $self->{ctx};
    if (!$ctx) {
      $self->{sock} = undef;  # just in case
    # do_log(5,'zmq: zmq_init');
      $self->{ctx} = $ctx = zmq_init(1);
      $ctx or die "Error creating ZMQ context: $!";
    }
    $sock = $self->{sock};
    if (!$sock && $ctx) {  # connect to a socket
    # do_log(5,'zmq: zmq_socket');
      $self->{sock} = $sock = zmq_socket($ctx, ZMQ_PUB);
      if (!$sock) {
        die "Error creating ZMQ socket: $!";
      } else {
      # do_log(5,'zmq: zmq_setsockopt');
        zmq_setsockopt($sock, ZMQ_LINGER, 2000) != -1  # milliseconds
          or die "Error setting ZMQ_LINGER on a ZMQ socket: $!";
        my $hwm = defined &ZMQ_SNDHWM ? ZMQ_SNDHWM()
                : defined &ZMQ_HWM    ? ZMQ_HWM() : undef;
        if (defined $hwm) {
          zmq_setsockopt($sock, $hwm, 1000) != -1
            or die "Error setting highwater mark on a ZMQ socket: $!";
        }
        for my $sockspec (@{$self->{socknames}}) {
          my $sock_ipv4only = 1;  # a ZMQ default
          if (defined &ZMQ_IPV4ONLY && $sockspec =~ /:[0-9a-f]*:/i) {
            zmq_setsockopt($sock, ZMQ_IPV4ONLY(), 0) != -1
              or die "Error turning off ZMQ_IPV4ONLY on a ZMQ socket: $!";
            $sock_ipv4only = 0;
          }
        # do_log(5,'zmq: zmq_connect %s%s', $sockspec,
        #          $sock_ipv4only ? '' : ', IPv6 enabled');
          zmq_connect($sock, $sockspec) == 0
            or die "Error connecting ZMQ socket to $sockspec: $!";
        }
      }
    }
    1;
  } or do {  # clean up, disable, and resignal a failure
    zmq_close($sock)  if $sock;  # ignoring status
    zmq_term($ctx)    if $ctx;   # ignoring status
    undef $self->{sock}; undef $self->{ctx};
    $self->{inactivated} = 1; $zmq_in_establish = 0;
    chomp $@; die "zmq establish failed: $@\n";  # propagate the exception
  };
  $zmq_in_establish = 0;
  $sock;
}

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  # can occur soon after fork, must not use context (like calling a logger)
  if (!$self->{inactivated}) {
    my $sock = $self->{sock};
    if ($sock) {
      zmq_setsockopt($sock, ZMQ_LINGER, 0);  # ignoring status
      zmq_close($sock);       # ignoring status
    }
    my $ctx = $self->{ctx};
    zmq_term($ctx)  if $ctx;  # ignoring status
  }
  undef $self->{sock}; undef $self->{ctx};
  %{$self} = ();  # then ditch the rest
}

sub register_proc {
  my($self, $details_level, $reset_timestamp, $state, $task_id) = @_;
  my $sock = $self->{sock};  # = $self->establish;
  return if !$sock;
# if (!defined $state || $details_level <= $nanny_details_level) {
  if (1) {
    my $pid = $$;
    my $msg;
    my $now = Time::HiRes::time;
    if ($reset_timestamp || !$self->{base_timestamp}) {
      $self->{base_timestamp} = $now;
      $msg = sprintf('am.st %d %014.3f ', $pid, $now);
    } else {
      my $dt = $now - $self->{base_timestamp};
      $msg = sprintf('am.st %d %d ', $pid, $dt <= 0 ? 0 : int($dt*1000 + 0.5));
    }
    if (!defined $state) {
      $msg .= 'exiting';
    } else {
      $state = '-'  if $state eq ' ' || $state eq '';  # simplifies parsing
      $msg .= $state;
      $msg .= ' ' . $task_id  if defined $task_id;
    }
  # do_log(5,'zmq: register_proc: %s', $msg);
    defined zmq_sendstr($sock, $msg)
      or die "Error sending a ZMQ message: $!";
  }
}

sub write_log {
# my($self, $level, $errmsg) = @_;
  my $self = $_[0];
  my $sock = $self->{sock};  # = $self->establish;
  return if !$sock;
  my $level = $_[1];
  my $nstars = 6 - $level;
  $nstars = 7 if $nstars > 7;
  $nstars = 1 if $nstars < 1;
  # ignoring status to prevent a logging loop
  zmq_sendstr($sock, sprintf('am.log.%s %s %014.3f %s', '*' x $nstars, $$,
                             Time::HiRes::time, $_[2]));
}

# insert startup time SNMP entry, called from the master process at startup
#
sub put_initial_snmp_data {
  my($self,$flush) = @_;
  my $sock = $self->{sock};  # = $self->establish;
  return if !$sock;
# do_log(5,'zmq: publishing initial snmp data');
  if ($flush) {
  # do_log(5,'zmq: sending am.snmp FLUSH');
    defined zmq_sendstr($sock, 'am.snmp FLUSH')
      or die "Error sending a ZMQ flush message: $!";
  }
  my $list_ref = snmp_initial_oids();
  my $list_ind_last = $#{$list_ref};
  for my $obj_ind (0 .. $list_ind_last) {
    my($key,$type,$val) = @{$list_ref->[$obj_ind]};
    my $more = $obj_ind < $list_ind_last;
    my $msg = sprintf('am.snmp %s %s %s', $key, $type, $val);
  # do_log(5,'zmq: sending %s %s', $more?'M':' ', $msg);
    defined zmq_sendstr($sock, $msg, $more ? ZMQ_SNDMORE : 0)
      or die "Error sending a ZMQ message: $!";
  };
}

sub update_snmp_variables {
  my $self = $_[0];
  my $sock = $self->{sock};  # = $self->establish;
  return if !$sock;
  my $msg;
  my $snmp_var_names_ref = snmp_counters_get();
  if (defined $snmp_var_names_ref && @$snmp_var_names_ref) {
    do_log(4,'zmq: updating snmp variables');
    for my $key (@$snmp_var_names_ref) {
      my($snmp_var_name, $val, $type) = ref $key ? @$key : ($key);
      if ($snmp_var_name eq 'entropy') {
        next;                        # don't broadcast entropy
      } elsif (!defined $type || $type eq '') {  # a counter, same as C32
        $type = 'C32';
        $val = 1  if !defined $val;  # by default a counter increments by 1
        next if $val < 0;            # a counter is supposed to be unsigned
      } elsif ($type eq 'C32' || $type eq 'C64') {  # a counter
        $val = 1  if !defined $val;  # by default a counter increments by 1
        next if $val < 0;            # a counter is supposed to be unsigned
      } elsif ($type eq 'INT') {     # an integer
        # no limitations here, sprintf will convert it to a string
      } elsif ($type eq 'TIM') {     # TimeTicks
        next if $val < 0;            # non-decrementing
      }
      if (defined $msg) {  # send assembled message from previous iteration
      # do_log(5,'zmq: sending M %s', $msg);
        defined zmq_sendstr($sock, $msg, ZMQ_SNDMORE)
          or die "Error sending a ZMQ message: $!";
      }
      $msg = sprintf('am.snmp %s %s %s', $snmp_var_name, $type, $val);
    }
    if (defined $msg) {  # last chunk of a multi-part message
    # do_log(5,'zmq: sending   %s', $msg);
      defined zmq_sendstr($sock, $msg, 0)
        or die "Error sending a ZMQ message: $!";
    }
  }
}

1;

__DATA__
#
package Amavis::DB::SNMP;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform $myversion $nanny_details_level);
  import Amavis::Util qw(ll do_log do_log_safe
                         snmp_initial_oids snmp_counters_get
                         add_entropy fetch_entropy_bytes);
}

use BerkeleyDB;
use MIME::Base64;
use Time::HiRes ();

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

sub DESTROY {
  my $self = $_[0];
  local($@,$!,$_); my $myactualpid = $$;
  if (defined($my_pid) && $myactualpid != $my_pid) {
    do_log_safe(5,"Amavis::DB::SNMP DESTROY skip, clone [%s] (born as [%s])",
                  $myactualpid, $my_pid);
  } else {
    do_log_safe(5,"Amavis::DB::SNMP DESTROY called");
    for my $db_name ('db_snmp', 'db_nanny') {
      my $db = $self->{$db_name};
      if (defined $db) {
        eval {
          $db->db_close==0 or die "db_close: $BerkeleyDB::Error, $!.";  1;
        } or do { $@ = "errno=$!"  if $@ eq '' };
        if ($@ ne '' && $@ !~ /\bDatabase is already closed\b/)
          { warn "[$myactualpid] BDB S+N DESTROY INFO ($db_name): $@" }
        undef $db;
      }
    }
  }
}

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

# insert startup time SNMP entry, called from the master process at startup
# (a classical subroutine, not a method)
#
sub put_initial_snmp_data($) {
  my $db = $_[0];
  my($eval_stat,$interrupt); $interrupt = '';
  { my $cursor;
    my $h1 = sub { $interrupt = $_[0] };
    local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8;
    eval {  # ensure cursor will be unlocked even in case of errors or signals
      $cursor = $db->db_cursor(DB_WRITECURSOR);  # obtain write lock
      defined $cursor or die "BDB S db_cursor: $BerkeleyDB::Error, $!.";
      my $list_ref = snmp_initial_oids();
      for my $obj (@$list_ref) {
        my($key,$type,$val) = @$obj;
        $cursor->c_put($key, sprintf("%s %s",$type,$val), DB_KEYLAST) == 0
          or die "BDB S c_put: $BerkeleyDB::Error, $!.";
      };
      $cursor->c_close==0 or die "BDB S c_close: $BerkeleyDB::Error, $!.";
      undef $cursor;  1;
    } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
    $cursor->c_close  if defined $cursor;  # unlock, ignoring status
    undef $cursor;
  };  # restore signal handlers
  if ($interrupt ne '') { kill($interrupt,$$) }  # resignal, ignoring status
  elsif (defined $eval_stat) {
    chomp $eval_stat;
    die "put_initial_snmp_data: BDB S $eval_stat\n";
  }
}

sub update_snmp_variables {
  my $self = $_[0];
  do_log(5,"updating snmp variables in BDB");
  my $snmp_var_names_ref = snmp_counters_get();
  my($eval_stat,$interrupt); $interrupt = '';
  if (defined $snmp_var_names_ref && @$snmp_var_names_ref) {
    my $db = $self->{'db_snmp'}; my $cursor;
    my $h1 = sub { $interrupt = $_[0] };
    local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8;
    eval {  # ensure cursor will be unlocked even in case of errors or signals
      $cursor = $db->db_cursor(DB_WRITECURSOR);  # obtain write lock
      defined $cursor or die "db_cursor: $BerkeleyDB::Error, $!.";
      for my $key (@$snmp_var_names_ref) {
        my($snmp_var_name,$arg,$type) = ref $key ? @$key : ($key);
        $type = 'C32'  if !defined($type) || $type eq '';
        if ($type eq 'C32' || $type eq 'C64') {  # a counter
          if (!defined($arg)) { $arg = 1 } # by default counter increments by 1
          elsif ($arg < 0)    { $arg = 0 } # counter is supposed to be unsigned
        } elsif ($type eq 'TIM') {  # TimeTicks
          if    ($arg < 0)    { $arg = 0 } # non-decrementing
        }
        my($val,$flags); local($1);
        my $stat = $cursor->c_get($snmp_var_name,$val,DB_SET);
        if ($stat==0) {  # exists, update it (or replace it)
          if    ($type eq 'C32' && $val=~/^C32 (\d+)\z/) { $val = $1+$arg }
          elsif ($type eq 'C64' && $val=~/^C64 (\d+)\z/) { $val = $1+$arg }
          elsif ($type eq 'TIM' && $val=~/^TIM (\d+)\z/) { $val = $1+$arg }
          elsif ($type eq 'INT' && $val=~/^INT ([+-]?\d+)\z/) { $val = $arg }
          elsif ($type=~/^(STR|OID)\z/ && $val=~/^\Q$type\E (.*)\z/) {
            if ($snmp_var_name ne 'entropy') { $val = $arg }
            else {  # blend-in entropy
              $val = $1; add_entropy($val, Time::HiRes::gettimeofday);
              $val = fetch_entropy_bytes(18);  # 18 bytes
              $val = encode_base64($val,'');   # 18*8/6 = 24 chars
              $val =~ tr{+/}{-_};  # base64 -> RFC 4648 base64url [A-Za-z0-9-_]
            }
          }
          else {
            do_log(-2,"WARN: variable syntax? %s: %s, clearing",
                      $snmp_var_name,$val);
            $val = 0;
          }
          $flags = DB_CURRENT;
        } else {  # create new entry
          $stat==DB_NOTFOUND  or die "c_get: $BerkeleyDB::Error, $!.";
          $flags = DB_KEYLAST; $val = $arg;
        }
        my $fmt = $type eq 'C32' ? "%010d" : $type eq 'C64' ? "%020.0f"
                : $type eq 'INT' ? "%010d" : undef;
        # format for INT should really be %011d, but keep compatibility for now
        my $str = defined($fmt) ? sprintf($fmt,$val) : $val;
        $cursor->c_put($snmp_var_name, $type.' '.$str, $flags) == 0
          or die "c_put: $BerkeleyDB::Error, $!.";
      }
      $cursor->c_close==0 or die "c_close: $BerkeleyDB::Error, $!.";
      undef $cursor;  1;
    } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
    if (defined $db) {
      $cursor->c_close  if defined $cursor;  # unlock, ignoring status
      undef $cursor;
#     if (!defined($eval_stat)) {
#       my $stat; $db->db_sync();  # not really needed
#       $stat==0 or warn "BDB S db_sync,status $stat: $BerkeleyDB::Error, $!.";
#     }
    }
  };  # restore signal handlers
  delete $self->{'cnt'};
  if ($interrupt ne '') { kill($interrupt,$$) }  # resignal, ignoring status
  elsif (defined $eval_stat) {
    chomp $eval_stat;
    die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
    die "update_snmp_variables: BDB S $eval_stat\n";
  }
}

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

sub register_proc {
  my($self, $details_level, $reset_timestamp, $state, $task_id) = @_;
  my $eval_stat; my $interrupt = '';
  if (!defined($state) || $details_level <= $nanny_details_level) {
    $task_id = ''  if !defined $task_id;
    my $db = $self->{'db_nanny'}; my $key = sprintf("%05d",$$);
    my $cursor; my $val;
    my $h1 = sub { $interrupt = $_[0] };
    local(@SIG{qw(INT HUP TERM TSTP QUIT ALRM USR1 USR2)}) = ($h1) x 8;
    eval {  # ensure cursor will be unlocked even in case of errors or signals
      $cursor = $db->db_cursor(DB_WRITECURSOR);  # obtain write lock
      defined $cursor or die "db_cursor: $BerkeleyDB::Error, $!.";
      my $stat = $cursor->c_get($key,$val,DB_SET);
      $stat==0 || $stat==DB_NOTFOUND or die "c_get: $BerkeleyDB::Error, $!.";
      if ($stat==0 && !defined $state) {  # remove existing entry
        $cursor->c_del==0 or die "c_del: $BerkeleyDB::Error, $!.";
      } elsif (defined $state) {  # add new, or update existing entry
        my $timestamp; local($1);
        # keep its timestamp when updating existing record
        $timestamp = $1  if $stat==0 && $val=~/^(\d+(?:\.\d*)?) /s;
        $timestamp = sprintf("%014.3f", Time::HiRes::time)
                       if !defined($timestamp) || $reset_timestamp;
        my $new_val = sprintf("%s %-14s", $timestamp, $state.$task_id);
        $cursor->c_put($key, $new_val,
                       $stat==0 ? DB_CURRENT : DB_KEYLAST ) == 0
          or die "c_put: $BerkeleyDB::Error, $!.";
      }
      $cursor->c_close==0 or die "c_close: $BerkeleyDB::Error, $!.";
      undef $cursor;  1;
    } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
    if (defined $db) {
      $cursor->c_close  if defined $cursor;  # unlock, ignoring status
      undef $cursor;
#     if (!defined($eval_stat)) {
#       my $stat = $db->db_sync();  # not really needed
#       $stat==0 or warn "BDB N db_sync,status $stat: $BerkeleyDB::Error, $!.";
#     }
    }
  };  # restore signal handlers
  if ($interrupt ne '') {
    kill($interrupt,$$);  # resignal, ignoring status
  } elsif (defined $eval_stat) {
    chomp $eval_stat;
    do_log_safe(5, "register_proc: BDB N %s", $eval_stat);
    die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
    die "register_proc: BDB N $eval_stat\n";
  }
}

1;

#
package Amavis::DB;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw($db_home $daemon_chroot_dir);
  import Amavis::Util qw(untaint ll do_log);
}

use BerkeleyDB;

# create new databases, then close them (called by the parent process)
# (called only if $db_home is nonempty)
#
sub init($$) {
  my($predelete_nanny, $predelete_snmp) = @_;
  my $name = $db_home;
  $name = "$daemon_chroot_dir $name"  if $daemon_chroot_dir ne '';
  if ($predelete_nanny || $predelete_snmp) {  # delete existing db files first?
    local(*DIR);
    opendir(DIR,$db_home) or die "db_init: Can't open directory $name: $!";
    # modifying a directory while traversing it can cause surprises, avoid;
    # avoid slurping the whole directory contents into memory
    my($f, @rmfiles);
    while (defined($f = readdir(DIR))) {
      next  if $f eq '.' || $f eq '..';
      if      ($f =~ /^(__db\.)?nanny\.db\z/) {
        push(@rmfiles, $f)  if $predelete_nanny;
      } elsif ($f =~ /^(__db\.)?snmp\.db\z/) {
        push(@rmfiles, $f)  if $predelete_snmp;
      } elsif ($f =~ /^__db\.\d+\z/s) {
        push(@rmfiles, $f)  if $predelete_nanny && $predelete_snmp;
      } elsif ($f =~ /^(?:cache-expiry|cache)\.db\z/s) {
        push(@rmfiles, $f);  # old databases, no longer used since 2.7.0-pre9
      }
    }
    closedir(DIR) or die "db_init: Error closing directory $name: $!";
    do_log(1, 'Deleting db files %s in %s', join(',',@rmfiles), $name);
    for my $f (@rmfiles) {
      my $fname = $db_home . '/' . untaint($f);
      unlink($fname) or die "db_init: Can't delete file $fname: $!";
    }
    undef @rmfiles;  # release storage
  }
  $! = 0; my $env = BerkeleyDB::Env->new(-Home=>$db_home, -Mode=>0640,
    -Flags=> DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL);
  defined $env
    or die "BDB can't create db env. at $db_home: $BerkeleyDB::Error, $!.";
  do_log(1, 'Creating db in %s/; BerkeleyDB %s, libdb %s',
            $name, BerkeleyDB->VERSION, $BerkeleyDB::db_version);
  $! = 0; my $dbs = BerkeleyDB::Hash->new(
    -Filename=>'snmp.db', -Flags=>DB_CREATE, -Env=>$env );
  defined $dbs or die "db_init: BDB no dbS: $BerkeleyDB::Error, $!.";
  $! = 0; my $dbn = BerkeleyDB::Hash->new(
    -Filename=>'nanny.db', -Flags=>DB_CREATE, -Env=>$env );
  defined $dbn or die "db_init: BDB no dbN: $BerkeleyDB::Error, $!.";

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

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

sub get_db_env { my $self = $_[0]; $$self }

1;

__DATA__
#
package Amavis::Lookup::SQLfield;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

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

# the sub new() is already declared in the always-loaded code section

# fieldtype: B=boolean, N=numeric, S=string,
#            N-: numeric, nonexistent field returns undef without complaint
#            S-: string,  nonexistent field returns undef without complaint
#            B-: boolean, nonexistent field returns undef without complaint
#            B0: boolean, nonexistent field treated as false
#            B1: boolean, nonexistent field treated as true

sub lookup_sql_field($$$%) {
  my($self, $addr, $get_all, %options) = @_;
  my(@result, @matchingkey, $sql_query, $field);
  if ($self) { $sql_query = $self->{sql_query}; $field = $self->{fieldname} }
  $sql_query = $Amavis::sql_lookups  if !defined $sql_query;  # global default
  if (!defined $self) {
    do_log(5, 'lookup_sql_field - no field query object, "%s" no match',$addr);
  } elsif (!defined $field || $field eq '') {
    do_log(5, 'lookup_sql_field() - no field name, "%s" no match', $addr);
  } elsif (!defined $sql_query) {
    do_log(5, 'lookup_sql_field(%s) - no sql_lookups object, "%s" no match',
              $field, $addr);
  } else {
    my(@result_attr_names) = !ref $field ? ( $field )
                            : ref $field eq 'ARRAY' ? @$field
                            : ref $field eq 'HASH' ? keys %$field : ();
    my(%attr_name_to_sqlfield_name) =
                              ref $field eq 'HASH' ? %$field
                            : map( ($_,$_), @result_attr_names);
    my $fieldtype = $self->{fieldtype};
    $fieldtype = 'S-'  if !defined $fieldtype;
    my($res_ref,$mk_ref) = $sql_query->lookup_sql($addr,1, %options,
              !exists($self->{args}) ? () : (ExtraArguments => $self->{args}));
    if (!defined $res_ref || !@$res_ref) {
      ll(5) && do_log(5, 'lookup_sql_field(%s), "%s" no matching records',
        join(',', map(lc($_) eq lc($attr_name_to_sqlfield_name{$_}) ? $_
                        : $_ . '/' . $attr_name_to_sqlfield_name{$_},
                      @result_attr_names)),  $addr);
    } else {
      my %nosuchfield;
      for my $ind (0 .. $#$res_ref) {
        my($any_field_matches, @match_values_by_ind);
        my $h_ref = $res_ref->[$ind];  my $mk = $mk_ref->[$ind];
        for my $result_attr_ind (0 .. $#result_attr_names) {
          my $result_attr_name = $result_attr_names[$result_attr_ind];
          next  if !defined $result_attr_name;
          my $fieldname = $attr_name_to_sqlfield_name{$result_attr_name};
          next  if !defined $fieldname || $fieldname eq '';
          my $match;
          if (!exists($h_ref->{$fieldname})) {
            $nosuchfield{$fieldname} = 1;
            # record found, but no field with that name in the table
            # fieldtype: B0: boolean, nonexistent field treated as false,
            #            B1: boolean, nonexistent field treated as true
            if ($fieldtype =~ /^.-/s) {   # allowed to not exist
              # this type is almost universally in use now, continue searching
            } elsif ($fieldtype =~ /^B1/) {  # defaults to true
              # only used for the 'local' field
              $match = 1;  # nonexistent field treated as 1
            } elsif ($fieldtype =~ /^B0/) {  # boolean, defaults to false
              # no longer in use
              $match = 0;  # nonexistent field treated as 0
            } else {
              # treated as 'no match', returns undef
            }
          } else {  # field exists
            # fieldtype: B=boolean, N=numeric, S=string
            $match = $h_ref->{$fieldname};
            if (!defined $match) {
              # NULL field values represented as undef
            } elsif ($fieldtype =~ /^B/) {  # boolean
              # convert values 'N', 'F', '0', ' ' and "\000" to 0
              # to allow value to be used directly as a Perl boolean
              $match = 0  if $match =~ /^([NnFf ]|0+|\000+)\ *\z/;
            } elsif ($fieldtype =~ /^N/) {  # numeric
              $match = $match + 0;  # convert string into a number
            } elsif ($fieldtype =~ /^S/) {  # string
              $match =~ s/ +\z//  # trim trailing spaces
                if $trim_trailing_space_in_lookup_result_fields;
            }
          }
          $match_values_by_ind[$result_attr_ind] = $match;
          $any_field_matches = 1  if defined $match;
        }
        ll(5) && do_log(5, 'lookup_sql_field(%s) rec=%d, "%s" result: %s',
          join(',',  map(lc($_) eq lc($attr_name_to_sqlfield_name{$_}) ? $_
                           : $_ . '/' . $attr_name_to_sqlfield_name{$_},
                         @result_attr_names)),
          $ind, $addr,
          join(', ', map(defined $_ ? '"'.$_.'"' : 'undef',
                         @match_values_by_ind)) );
        if ($any_field_matches) {
          push(@matchingkey, $mk);
          push(@result, !ref $field ? $match_values_by_ind[0] :
                 { map( ($result_attr_names[$_], $match_values_by_ind[$_]),
                        grep(defined $match_values_by_ind[$_],
                             (0 .. $#result_attr_names) )) } );
          last  if !$get_all;
        }
      }
      do_log(5, 'lookup_sql_field, no such fields: %s',
             join(', ', keys %nosuchfield))  if ll(5) && %nosuchfield;
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

#
package Amavis::Lookup::SQL;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(untaint untaint_inplace snmp_count
                         ll do_log do_log_safe);
  import Amavis::rfc2821_2822_Tools qw(make_query_keys);
  import Amavis::Out::SQL::Connection ();
}

use DBI qw(:sql_types);

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

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  do_log_safe(5,"Amavis::Lookup::SQL DESTROY called");
}

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

sub clear_cache {
  my $self = $_[0];
  delete $self->{cache};
}

# lookup_sql() performs a lookup for an e-mail address against a SQL map.
# If a match is found it returns whatever the query returns (a reference
# to a hash containing values of requested fields), otherwise returns undef.
# A match aborts further fetching sequence, unless $get_all is true.
#
# The $addr may be a string of octets (assumed to be UTF-8 encoded)
# or a string of characters which gets first encoded to UTF-8 octets.
# International domain name (IDN) in $addr will be converted to ACE
# and lowercased. International domain names in SQL are expected to be
# encoded in ASCII-compatible encoding (ACE).
#
# SQL lookups (e.g. for user+foo@example.com) are performed in order
# which can be requested by 'ORDER BY' in the SELECT statement, otherwise
# the order is unspecified, which is only useful if only specific entries
# exist in a database (e.g. only full addresses, not domains).
#
# The following order is recommended, going from specific to more general:
#  - lookup for user+foo@example.com
#  - lookup for user@example.com (only if $recipient_delimiter nonempty)
#  - lookup for user+foo ('naked lookup' (i.e. no '@'): only if local)
#  - lookup for user  ('naked lookup': local and $recipient_delimiter nonempty)
#  - lookup for @sub.example.com
#  - lookup for @.sub.example.com
#  - lookup for @.example.com
#  - lookup for @.com
#  - lookup for @.       (catchall)
# NOTE:
#  this is different from hash and ACL lookups in two important aspects:
#    - a key without '@' implies a mailbox (=user) name, not domain name;
#    - a naked mailbox name (i.e. no '@' in the query) lookups are only
#      performed when the e-mail address (usually its domain part) matches
#      static local_domains* lookups.
#
# Domain part is always lowercased when constructing a key,
# localpart is lowercased unless $localpart_is_case_sensitive is true.
#
sub lookup_sql($$$%) {
  my($self, $addr,$get_all,%options) = @_;
  my(@matchingkey,@result);
  my $extra_args = $options{ExtraArguments};
  my $sel; my $sql_cl_r = cr('sql_clause');
  my $clause_name = $self->{clause_name};
  $sel = $sql_cl_r->{$clause_name}  if defined $sql_cl_r;
  $sel = $$sel  if ref $sel eq 'SCALAR';  # allow one level of indirection
  if (!defined($sel) || $sel eq '') {
    ll(4) && do_log(4,"lookup_sql disabled for clause: %s", $clause_name);
    return(!wantarray ? undef : (undef,undef));
  } elsif (!defined $extra_args &&
           exists $self->{cache} && exists $self->{cache}->{$addr})
  { # cached ?
    my $c = $self->{cache}->{$addr}; @result = @$c if ref $c;
    @matchingkey = map('/cached/',@result); # will do for now, improve some day
#   if (!ll(5)) {}# don't bother preparing log report which will not be printed
#   elsif (!@result) { do_log(5,'lookup_sql (cached): "%s" no match', $addr) }
#   else {
#     for my $m (@result) {
#       do_log(5, "lookup_sql (cached): \"%s\" matches, result=(%s)",
#         $addr, join(", ", map { sprintf("%s=>%s", $_,
#                                 !defined($m->{$_})?'-':'"'.$m->{$_}.'"'
#                                        ) } sort keys(%$m) ) );
#     }
#   }
    if (!$get_all) {
      return(!wantarray ? $result[0] : ($result[0], $matchingkey[0]));
    } else {
      return(!wantarray ? \@result   : (\@result,   \@matchingkey));
    }
  }
  my $is_local;  # not looked up in SQL and LDAP to avoid recursion!
  $is_local = Amavis::Lookup::lookup(0,$addr,
                                     grep(ref ne 'Amavis::Lookup::SQL' &&
                                          ref ne 'Amavis::Lookup::SQLfield' &&
                                          ref ne 'Amavis::Lookup::LDAP' &&
                                          ref ne 'Amavis::Lookup::LDAPattr',
                                          @{ca('local_domains_maps')}));
  my($keys_ref,$rhs_ref) = make_query_keys($addr,
                                    $sql_lookups_no_at_means_domain,$is_local);
  if (!$sql_allow_8bit_address) { s/[^\040-\176]/?/gs for @$keys_ref }
  my $n = scalar(@$keys_ref);  # number of keys
  my(@extras_tmp,@pos_args); local($1);
  @extras_tmp = @$extra_args  if $extra_args;
  my $sel_taint = substr($sel,0,0);  # taintedness
  my $datatype = $sql_allow_8bit_address ? SQL_VARBINARY : SQL_VARCHAR;

  # substitute %k for a list of keys, %a for unmodified full mail address,
  # %l for full unmodified localpart, %u for lowercased username (a localpart
  # without extension), %e for lowercased extension, %d for lowercased domain,
  # and ? for each extra argument
  $sel =~ s{ ( %[kaluedL] | \? ) }
           { push(@pos_args,
                  $1 eq '%k' ? map([$_,$datatype], @$keys_ref)
                : $1 eq '%a' ? [$rhs_ref->[0], $datatype] #full addr
                : $1 eq '%l' ? [$rhs_ref->[1], $datatype] #localpart
                : $1 eq '%u' ? [$rhs_ref->[2], $datatype] #username
                : $1 eq '%e' ? [$rhs_ref->[3], $datatype] #extension
                : $1 eq '%d' ? [$rhs_ref->[4], $datatype] #domain
                   #*** (%L is experimental, incomplete)
                : $1 eq '%L' ? [($is_local?'1':'0'), SQL_BOOLEAN] #is local
                : shift @extras_tmp),
             $1 eq '%k' ? join(',', ('?') x $n) : '?' }xgse;
  $sel = untaint($sel) . $sel_taint;  # keep original clause taintedness
  ll(4) && do_log(4,"lookup_sql %s \"%s\", query args: %s",
                   $clause_name, $addr,
                   join(', ', map(!ref $_ ? '"'.$_.'"' : '['.join(',',@$_).']',
                                  @pos_args)) );
  ll(4) && do_log(4,"lookup_sql select: %s", $sel);
  my $a_ref; my $match = {}; my $conn_h = $self->{conn_h};
  $conn_h->begin_work_nontransaction;  # (re)connect if not connected
  my $driver = $conn_h->driver_name;  # only available when connected
  if ($driver eq 'Pg') {
    $datatype = { pg_type => DBD::Pg::PG_BYTEA() };
    for (@pos_args)
      { $_->[1] = $datatype  if ref($_) && $_->[1]==SQL_VARBINARY }
  }
  for (@pos_args) {
    if (ref $_) { untaint_inplace($_->[0]) } else { untaint_inplace($_) }
  }
  eval {
    snmp_count('OpsSqlSelect');
    $conn_h->execute($sel,@pos_args);  # do the query
    # fetch query results
    while ( defined($a_ref=$conn_h->fetchrow_arrayref($sel)) ) {
      my(@names) = @{$conn_h->sth($sel)->{NAME_lc}};
      $match = {}; @$match{@names} = @$a_ref;
      if ($clause_name eq 'sel_policy' && !exists $match->{'local'} &&
          defined $match->{'email'} && $match->{'email'} eq '@.') {
        # UGLY HACK to let a catchall (@.) imply that field 'local' has
        # a value undef (NULL) when that field is not present in the
        # database. This overrides B1 fieldtype default by an explicit
        # undef for '@.', causing a fallback to static lookup tables.
        # The purpose is to provide a useful default for local_domains
        # lookup if the field 'local' is not present in the SQL table.
        # NOTE: field names 'local' and 'email' are hardwired here!!!
        push(@names,'local'); $match->{'local'} = undef;
        do_log(5, 'lookup_sql: "%s" matches catchall, local=>undef', $addr);
      }
      push(@result, {%$match});  # copy hash
      push(@matchingkey, join(", ", map { sprintf("%s=>%s", $_,
                                !defined($match->{$_})?'-':'"'.$match->{$_}.'"'
                                ) } @names));
      last  if !$get_all;
    }
    $conn_h->finish($sel)  if defined $a_ref;  # only if not all read
    1;
  } or do {
    my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    do_log(-1, "lookup_sql: %s, %s, %s", $err, $DBI::err, $DBI::errstr);
    die $err  if $err =~ /^timed out\b/;  # resignal timeout
    die $err;
  };
  if (!ll(4)) {
    # don't bother preparing log report which will not be printed
  } elsif (!@result) {
    do_log(4,'lookup_sql, "%s" no match', $addr);
  } else {
    do_log(4,'lookup_sql(%s) matches, result=(%s)', $addr,$_) for @matchingkey;
  }
  # save for future use, but only within processing of this message
  $self->{cache}->{$addr} = \@result;
  section_time('lookup_sql');
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

__DATA__
#^L
package Amavis::LDAP::Connection;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

use Net::LDAP;
use Net::LDAP::Util;

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION
              $have_sasl $ldap_sys_default);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  $have_sasl = eval { require Authen::SASL };
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll do_log do_log_safe);
  import Amavis::Timing qw(section_time);
}

BEGIN {
  # must be in a separate BEGIN block to be able to see imported symbols
  $ldap_sys_default = {
    hostname       => 'localhost',
    localaddr      => undef,
    port           => undef,  # 389 or 636, default provided by Net::LDAP
    scheme         => undef,  # 'ldaps' or 'ldap', depending on hostname
    version        => 3,
    timeout        => 120,
    deref          => 'find',
    bind_dn        => undef,
    bind_password  => undef,
    tls            => 0,
    verify         => 'none',
    sslversion     => 'tlsv1',
    clientcert     => undef,
    clientkey      => undef,
    cafile         => undef,
    capath         => undef,
    sasl           => 0,
    sasl_mech      => undef,  # space-separated list of mech names
    sasl_auth_id   => undef,
  };
  1;
}

sub new {
  my($class,$default) = @_;
  my $self = bless { ldap => undef }, $class;
  $self->{incarnation} = 1;
  for (qw(hostname localaddr port scheme inet6 version timeout
          base scope deref bind_dn bind_password
          tls verify sslversion clientcert clientkey cafile capath
          sasl sasl_mech sasl_auth_id)) {
    # replace undefined attributes with user values or defaults
    $self->{$_} = $default->{$_}          if !defined($self->{$_});
    $self->{$_} = $ldap_sys_default->{$_} if !defined($self->{$_});
  }
  if (!defined $self->{scheme}) {
    $self->{scheme} = $self->{hostname} =~ /^ldaps/i ? 'ldaps' : 'ldap';
  }
  $self;
}

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

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  do_log_safe(5,"Amavis::LDAP::Connection DESTROY called");
  # ignore failure, make perlcritic happy
  eval { $self->disconnect_from_ldap } or 1;
}

sub incarnation { my $self = $_[0]; $self->{incarnation} }
sub in_transaction { 0 }

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

sub connect_to_ldap {
  my $self = $_[0];
  my($bind_err,$start_tls_err);
  do_log(3,"Connecting to LDAP server");
  my $hostlist = ref $self->{hostname} eq 'ARRAY' ?
                     join(", ",@{$self->{hostname}}) : $self->{hostname};
  do_log(4,"connect_to_ldap: trying %s", $hostlist);
  my $ldap = Net::LDAP->new($self->{hostname},
                            localaddr => $self->{localaddr},
                            port    => $self->{port},
                            scheme  => $self->{scheme},
                            version => $self->{version},
                            timeout => $self->{timeout},
                            keepalive => 1,  # since Net::LDAP 0.53
                        # remaining keepalive* options need Socket::Linux and a
                        # patch at [rt.cpan.org #83039], otherwise are ignored
                            keepalive_idle => 240,
                            keepalive_interval => 30,
                            keepalive_probe => 10,
                            );
  if (!$ldap) {  # connect failed
    do_log(-1,"connect_to_ldap: unable to connect to host %s", $hostlist);
  } else {
    do_log(3,"connect_to_ldap: connected to %s", $hostlist);
  # $ldap->debug(12);   # debug output goes to STDERR
    if ($self->{tls}) { # TLS required
      my $mesg = $ldap->start_tls(verify => $self->{verify},
                                  sslversion => $self->{sslversion},
                                  clientcert => $self->{clientcert},
                                  clientkey => $self->{clientkey},
                                  cafile => $self->{cafile},
                                  capath => $self->{capath});
      if ($mesg->code) { # start TLS failed
        my $err = $mesg->error_name;
        do_log(-1,"connect_to_ldap: start TLS failed: %s", $err);
        $self->ldap(undef);
        $start_tls_err = 1;
      } else { # started TLS
        do_log(3,"connect_to_ldap: TLS version %s enabled", $mesg);
      }
    }
    if ($self->{bind_dn} || $self->{sasl}) {  # bind required
      my $sasl;
      my $passw = $self->{bind_password};
      if ($self->{sasl}) {  # using SASL to authenticate?
        $have_sasl or die "connect_to_ldap: SASL requested but no Authen::SASL";
        $sasl = Authen::SASL->new(mechanism => $self->{sasl_mech},
                                  callback => { user => $self->{sasl_auth_id},
                                                pass => $passw } );
      }
      my $mesg = $ldap->bind($self->{bind_dn},
                             $sasl          ? (sasl     => $sasl)
                           : defined $passw ? (password => $passw) : ());
      $passw = 'X' x length($passw)  if defined $passw;  # can't hurt
      if ($mesg->code) {  # bind failed
        my $err = $mesg->error_name;
        do_log(-1,"connect_to_ldap: bind failed: %s", $err);
        $self->ldap(undef);
        $bind_err = 1;
      } else {  # bind succeeded
        do_log(3,"connect_to_ldap: bind %s succeeded", $self->{bind_dn});
      }
    }
  }
  $self->ldap($ldap); $self->{incarnation}++;
  $ldap or die "connect_to_ldap: unable to connect";
  if ($start_tls_err) { die "connect_to_ldap: start TLS failed" }
  if ($bind_err)      { die "connect_to_ldap: bind failed" }
  section_time('ldap-connect');
  $self;
}

sub disconnect_from_ldap {
  my $self = $_[0];
  return if !$self->ldap;
  do_log(4,"disconnecting from LDAP");
  $self->ldap->disconnect;
  $self->ldap(undef);
  1;
}

sub do_search {
  my($self,$base,$scope,$filter) = @_;
  my($result,$error_name);
  $self->ldap or die "do_search: ldap not available";
  do_log(5,'lookup_ldap: searching base="%s", scope="%s", filter="%s"',
           $base, $scope, $filter);
  eval {
    $result = $self->{ldap}->search(base   => $base,
                                    scope  => $scope,
                                    filter => $filter,
                                    deref  => $self->{deref},
                                    );
    if ($result->code) {
      $error_name = $result->error_name;
      if ($error_name eq 'LDAP_NO_SUCH_OBJECT') {
        # probably alright, e.g. a foreign %d
        do_log(4, 'do_search failed in "%s": %s', $base, $error_name);
      } else {
        die $error_name."\n";
      }
    }
    1;
  } or do {
    my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    die $err  if $err =~ /^timed out\b/;  # resignal timeout
    if ($err !~ /^LDAP_/) {
      die "do_search: $err";
    } elsif ($error_name !~ /^LDAP_(?:BUSY|UNAVAILABLE|UNWILLING_TO_PERFORM|
                             TIMEOUT|SERVER_DOWN|CONNECT_ERROR|OTHER|
                             LOCAL_ERROR|OPERATIONS_ERROR)\z/x) {
      die "do_search: failed: $error_name\n";
    } else {  # LDAP related error, worth retrying
      do_log(0, "NOTICE: do_search: trying again: %s", $error_name);
      $self->disconnect_from_ldap;
      $self->connect_to_ldap;
      $self->ldap or die "do_search: reconnect failed";
      do_log(5,
        'lookup_ldap: searching (again) base="%s", scope="%s", filter="%s"',
        $base, $scope, $filter);
      eval {
        $result = $self->{ldap}->search(base   => $base,
                                        scope  => $scope,
                                        filter => $filter,
                                        deref  => $self->{deref},
                                        );
        if ($result->code) { die $result->error_name, "\n"; }
        1;
      } or do {
        my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
        $self->disconnect_from_ldap;
        die $err  if $err =~ /^timed out\b/;  # resignal timeout
        die "do_search: failed again, $err";
      };
    };
  };
  $result;
}

1;

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

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

# the sub new() is already declared in the always-loaded code section

# attrtype: B=boolean, N=numeric, S=string, L=list
#           N-: numeric, nonexistent field returns undef without complaint
#           S-: string,  nonexistent field returns undef without complaint
#           L-: list,    nonexistent field returns undef without complaint
#           B-: boolean, nonexistent field returns undef without complaint
#           B0: boolean, nonexistent field treated as false
#           B1: boolean, nonexistent field treated as true

sub lookup_ldap_attr($$$%) {
  my($self, $addr, $get_all, %options) = @_;
  my(@result, @matchingkey, $ldap_query, $attr);
  if ($self) { $ldap_query = $self->{ldap_query}; $attr = $self->{attrname} }
  $ldap_query = $Amavis::ldap_lookups  if !defined $ldap_query;  # global dflt
  if (!defined $self) {
    do_log(5, 'lookup_ldap_attr - no attr query object, "%s" no match',$addr);
  } elsif (!defined $attr || $attr eq '') {
    do_log(5, 'lookup_ldap_attr() - no attribute name, "%s" no match', $addr);
  } elsif (!defined $ldap_query) {
    do_log(5, 'lookup_ldap_attr(%s) - no ldap_lookups object, "%s" no match',
              $attr, $addr);
  } else {
    # result attribute names are case-sensitive
    # LDAP attribute names are case-INsensitive
    my(@result_attr_names) = !ref $attr ? ( $attr )
                            : ref $attr eq 'ARRAY' ? @$attr
                            : ref $attr eq 'HASH' ? keys %$attr : ();
    my(%attr_name_to_ldapattr_name) =
                              ref $attr eq 'HASH' ? %$attr
                            : map( ($_,$_), @result_attr_names);
    my $attrtype = $self->{attrtype};
    $attrtype = 'S-'  if !defined $attrtype;
    my($res_ref,$mk_ref) = $ldap_query->lookup_ldap($addr,1, %options,
              !exists($self->{args}) ? () : (ExtraArguments => $self->{args}));
    if (!defined $res_ref || !@$res_ref) {
      ll(5) && do_log(5, 'lookup_ldap_attr(%s), "%s" no matching entries',
        join(',', map(lc($_) eq lc($attr_name_to_ldapattr_name{$_}) ? $_
                        : $_ . '/' . lc($attr_name_to_ldapattr_name{$_}),
                      @result_attr_names)),  $addr);
    } else {
      my %nosuchattr;
      for my $ind (0 .. $#$res_ref) {
        my($any_attr_matches, @match_values_by_ind);
        my $h_ref = $res_ref->[$ind];  my $mk = $mk_ref->[$ind];
        for my $result_attr_ind (0 .. $#result_attr_names) {
          my $result_attr_name = $result_attr_names[$result_attr_ind];
          next  if !defined $result_attr_name;
          my $attrname = $attr_name_to_ldapattr_name{$result_attr_name};
          next  if !defined $attrname || $attrname eq '';
          my $match;
          if (!exists($h_ref->{lc $attrname})) {
            $nosuchattr{$attrname} = 1;
            # LDAP entry found, but no attribute with that name in it
            if ($attrtype =~ /^.-/s) {      # allowed to not exist
              # this type is almost universally in use now, continue searching
            } elsif ($attrtype =~ /^B1/) {  # defaults to true
              # only used for the 'local' attr
              $match = 1;  # nonexistent attribute treated as 1
            } elsif ($attrtype =~ /^B0/) {  # boolean, defaults to false
              # no longer in use
              $match = 0;  # nonexistent attribute treated as 0
            } else {
              # treated as 'no match', returns undef
            }
          } else {  # attribute exists
            # attrtype: B=boolean, N=numeric, S=string
            $match = $h_ref->{lc $attrname};
            if (!defined $match) {
              # NULL attribute values represented as undef
            } elsif ($attrtype =~ /^B/) {  # boolean
              $match = $match eq 'TRUE' ? 1 : 0;  # convert TRUE|FALSE to 1|0
            } elsif ($attrtype =~ /^N/) {  # numeric
              $match = $match + 0;  # unify different numeric forms
            } elsif ($attrtype =~ /^S/) {  # string
              $match =~ s/ +\z//  # trim trailing spaces
                if $trim_trailing_space_in_lookup_result_fields;
            } elsif ($self->{attrtype} =~ /^L/) {  # list
              #$match = join(', ',@$match);
            }
          }
          $match_values_by_ind[$result_attr_ind] = $match;
          $any_attr_matches = 1  if defined $match;
        }
        ll(5) && do_log(5, 'lookup_ldap_attr(%s) rec=%d, "%s" result: %s',
              join(',', map(lc($_) eq lc($attr_name_to_ldapattr_name{$_}) ? $_
                              : $_ . '/' . lc($attr_name_to_ldapattr_name{$_}),
                            @result_attr_names)),
              $ind, $addr,
              join(', ', map(defined $_ ? '"'.$_.'"' : 'undef',
                             @match_values_by_ind)) );
        if ($any_attr_matches) {
          push(@matchingkey, $mk);
          push(@result, !ref $attr ? $match_values_by_ind[0] :
                 { map( ($result_attr_names[$_], $match_values_by_ind[$_]),
                        grep(defined $match_values_by_ind[$_],
                             (0 .. $#result_attr_names) )) } );
          last  if !$get_all;
        }
      }
      do_log(5, 'lookup_ldap_attr, no such attrs: %s',
             join(', ', keys %nosuchattr))  if ll(5) && %nosuchattr;
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION
              $ldap_sys_default @ldap_attrs @mv_ldap_attrs);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(untaint untaint_inplace snmp_count
                         ll do_log do_log_safe idn_to_ascii);
  import Amavis::rfc2821_2822_Tools qw(make_query_keys split_address);
  import Amavis::LDAP::Connection ();

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

  @ldap_attrs = qw(amavisLocal amavisMessageSizeLimit
    amavisVirusLover amavisSpamLover amavisUncheckedLover
    amavisBannedFilesLover amavisBadHeaderLover
    amavisBypassVirusChecks amavisBypassSpamChecks
    amavisBypassBannedChecks amavisBypassHeaderChecks
    amavisSpamTagLevel amavisSpamTag2Level amavisSpamKillLevel
    amavisSpamDsnCutoffLevel amavisSpamQuarantineCutoffLevel
    amavisSpamSubjectTag amavisSpamSubjectTag2 amavisSpamModifiesSubj
    amavisVirusQuarantineTo amavisSpamQuarantineTo amavisBannedQuarantineTo
    amavisUncheckedQuarantineTo amavisBadHeaderQuarantineTo
    amavisCleanQuarantineTo amavisArchiveQuarantineTo
    amavisAddrExtensionVirus amavisAddrExtensionSpam
    amavisAddrExtensionBanned amavisAddrExtensionBadHeader
    amavisWarnVirusRecip amavisWarnBannedRecip amavisWarnBadHeaderRecip
    amavisVirusAdmin amavisNewVirusAdmin amavisSpamAdmin
    amavisBannedAdmin amavisBadHeaderAdmin
    amavisBannedRuleNames amavisDisclaimerOptions
    amavisForwardMethod amavisSaUserConf amavisSaUserName
    amavisBlacklistSender amavisWhitelistSender
  );
  @mv_ldap_attrs = qw(amavisBlacklistSender amavisWhitelistSender);
  1;
}

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

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  do_log_safe(5,"Amavis::Lookup::LDAP DESTROY called");
}

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

sub clear_cache {
  my $self = $_[0];
  delete $self->{cache};
}

# The $addr may be a string of octets (assumed to be UTF-8 encoded)
# or a string of characters which gets first encoded to UTF-8 octets.
# International domain name (IDN) in $addr will be converted to ACE
# and lowercased. International domain names in LDAP are expected to be
# encoded in ASCII-compatible encoding (ACE).
#
sub lookup_ldap($$$%) {
  my($self,$addr,$get_all,%options) = @_;
  my(@result,@matchingkey,@tmp_result,@tmp_matchingkey);
  if (exists $self->{cache} && exists $self->{cache}->{$addr}) { # cached?
    my $c = $self->{cache}->{$addr}; @result = @$c if ref $c;
    @matchingkey = map('/cached/',@result); # will do for now, improve some day
#   if (!ll(5)) {
#     # don't bother preparing log report which will not be printed
#   } elsif (!@result) {
#     do_log(5,'lookup_ldap (cached): "%s" no match', $addr);
#   } else {
#     for my $m (@result) {
#       do_log(5, 'lookup_ldap (cached): "%s" matches, result=(%s)',
#         $addr, join(", ", map { sprintf("%s=>%s", $_,
#                                 !defined($m->{$_})?'-':'"'.$m->{$_}.'"'
#                                        ) } sort keys(%$m) ) );
#     }
#   }
    if (!$get_all) {
      return(!wantarray ? $result[0] : ($result[0], $matchingkey[0]));
    } else {
      return(!wantarray ? \@result   : (\@result,   \@matchingkey));
    }
  }
  my $is_local;  # not looked up in SQL and LDAP to avoid recursion!
  $is_local = Amavis::Lookup::lookup(0,$addr,
                                     grep(ref ne 'Amavis::Lookup::SQL' &&
                                          ref ne 'Amavis::Lookup::SQLfield' &&
                                          ref ne 'Amavis::Lookup::LDAP' &&
                                          ref ne 'Amavis::Lookup::LDAPattr',
                                          @{ca('local_domains_maps')}));
  my($keys_ref,$rhs_ref,@keys);
  ($keys_ref,$rhs_ref) = make_query_keys($addr,
                                   $ldap_lookups_no_at_means_domain,$is_local);
  @keys = @$keys_ref;
  unshift(@keys, '<>')  if $addr eq '';  # a hack for a null return path
  untaint_inplace($_) for @keys; # untaint keys
  $_ = Net::LDAP::Util::escape_filter_value($_) for @keys;
  # process %m
  my $filter = $self->{query_filter};
  my @filter_attr;  my $expanded_filter = '';
  for my $t ($filter =~ /\G( \( [^(=]+ = %m \) | [ \t0-9A-Za-z]+ | . )/xgs) {
    if ($t !~ m{ \( ([^(=]+) = %m \) }xs) { $expanded_filter .= $t }
    else {
      push(@filter_attr, $1);
      $expanded_filter .= '(|' . join('', map("($1=$_)", @keys)) . ')';
    }
  }
  $filter = $expanded_filter;
  # process %d
  my $base = $self->{base};
  if ($base =~ /%d/) {
    my($localpart,$domain) = split_address($addr);
    if ($domain) {
      untaint_inplace($domain); local($1);
      $domain =~ s/^\@?(.*?)\.*\z/$1/s;
      $domain = idn_to_ascii($domain);
      $base =~ s/%d/&Net::LDAP::Util::escape_dn_value($domain)/gse;
    }
  }
  # build hash of keys and array position
  my(%xref); my $key_num = 0;
  $xref{$_} = $key_num++ for @keys;
  #
  do_log(4,'lookup_ldap "%s", query keys: %s, base: %s, filter: %s',
    $addr,join(', ',map("\"$_\"",@keys)),$self->{base},$self->{query_filter});
  my $conn_h = $self->{conn_h};
  $conn_h->begin_work;  # (re)connect if not connected
  eval {
    snmp_count('OpsLDAPSearch');
    my(@entry);
    my $search_obj = $conn_h->do_search($base, $self->{scope}, $filter);
    @entry = $search_obj->entries  if $search_obj && !$search_obj->code;
    my(%mv_ldap_attrs) = map((lc($_), 1), @mv_ldap_attrs);
    for my $entry (@entry) {
      my $match = {};
      $match->{dn} = $entry->dn;
      for my $attr (@ldap_attrs) {
        my $value;
        do_log(9,'lookup_ldap: reading attribute "%s" from object', $attr);
        $attr = lc $attr;
        if ($mv_ldap_attrs{$attr}) {  # multivalued
          $value = $entry->get_value($attr, asref => 1);
        } else {
          $value = $entry->get_value($attr);
        }
        $match->{$attr} = $value  if defined $value;
      }
      my $pos;
      for my $attr (@filter_attr) {
        my $value = scalar($entry->get_value($attr));
        if (defined $value) {
          if (!exists $match->{'amavislocal'} && $value eq '@.') {
            # NOTE: see lookup_sql
            $match->{'amavislocal'} = undef;
            do_log(5, 'lookup_ldap: "%s" matches catchall, amavislocal=>undef',
                      $addr);
          }
          $pos = $xref{$value};
          last;
        }
      }
      my $key_str = join(", ",map {sprintf("%s=>%s",$_,!defined($match->{$_})?
        '-':'"'.$match->{$_}.'"')} keys(%$match));
      push(@tmp_result,      [$pos,{%$match}]); # copy hash
      push(@tmp_matchingkey, [$pos,$key_str]);
      last if !$get_all;
    }
    1;
  } or do {
    my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    do_log(-1,"lookup_ldap: %s", $err);
    die $err;
  };
  @result      = map($_->[1], sort {$a->[0] <=> $b->[0]} @tmp_result);
  @matchingkey = map($_->[1], sort {$a->[0] <=> $b->[0]} @tmp_matchingkey);
  if (!ll(4)) {
    # don't bother preparing log report which will not be printed
  } elsif (!@result) {
    do_log(4,'lookup_ldap, "%s" no match', $addr);
  } else {
    do_log(4,'lookup_ldap(%s) matches, result=(%s)',$addr,$_) for @matchingkey;
  }
  # save for future use, but only within processing of this message
  $self->{cache}->{$addr} = \@result;
  section_time('lookup_ldap');
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

__DATA__
#
package Amavis::In::AMPDP;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll do_log debug_oneshot dump_captured_log
                         untaint snmp_counters_init read_file
                         snmp_count proto_encode proto_decode
                         switch_to_my_time switch_to_client_time
                         am_id new_am_id add_entropy rmdir_recursively
                         generate_mail_id);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Lookup::IP qw(lookup_ip_acl normalize_ip_addr);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::In::Message;
  import Amavis::In::Connection;
  import Amavis::IO::Zlib;
  import Amavis::Out::EditHeader qw(hdr);
  import Amavis::Out qw(mail_dispatch);
  import Amavis::Notify qw(msg_from_quarantine);
}
use subs @EXPORT;

use Errno qw(ENOENT EACCES);
use IO::File ();
use Time::HiRes ();
use Digest::MD5;
use MIME::Base64;

sub new($) { my $class = $_[0];  bless {}, $class }

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

  my(%attr);
  $0 = sprintf("%s (ch%d-P-idle)",
               c('myprogram_name'), $Amavis::child_invocation_count);
  ll(5) && do_log(5, "process_policy_request: %s, %s, fileno=%s",
                     $old_amcl, c('myprogram_name'), fileno($sock));
  if ($old_amcl) {
    # Accept a single request from traditional amavis helper program.
    # Receive TEMPDIR/SENDER/RCPTS/LDA/LDAARGS from client
    # Simple protocol: \2 means LDA follows; \3 means EOT (end of transmission)
    die "process_policy_request: old AM.CL protocol is no longer supported\n";

  } else {  # new amavis helper protocol AM.PDP or a Postfix policy server
    # for Postfix policy server see Postfix docs SMTPD_POLICY_README
    my(@response); local($1,$2,$3);
    local($/) = "\012";  # set line terminator to LF (Postfix idiosyncrasy)
    my $ln;  # can accept multiple tasks
    switch_to_client_time("start receiving AM.PDP data");
    $conn->appl_proto('AM.PDP');
    for ($! = 0; defined($ln=$sock->getline); $! = 0) {
      my $end_of_request = $ln =~ /^\015?\012\z/ ? 1 : 0;  # end of request?
      switch_to_my_time($end_of_request ? 'rx entire AM.PDP request'
                                        : 'rx AM.PDP line');
      $0 = sprintf("%s (ch%d-P)",
                   c('myprogram_name'), $Amavis::child_invocation_count);
      Amavis::Timing::init(); snmp_counters_init();
      # must not use \r and \n, not the same as \015 and \012 on some platforms
      if ($end_of_request) {  # end of request
        section_time('got data');
        my $msg_size;
        eval {
          my($msginfo,$bank_names_ref) = preprocess_policy_query(\%attr,$conn);
          $Amavis::MSGINFO = $msginfo;  # ugly
          my $req = lc($attr{'request'});
          @response = $req eq 'smtpd_access_policy'
                        ? postfix_policy($msginfo,\%attr)
                  : $req =~ /^(?:release|requeue|report)\z/
                        ? dispatch_from_quarantine($msginfo, $req,
                                 $req eq 'report' ? 'abuse' : 'miscategorized')
                  : check_ampdp_policy($msginfo,$check_mail,0,$bank_names_ref);
          $msg_size = $msginfo->msg_size;
          undef $Amavis::MSGINFO;  # release global reference
          1;
        } or do {
          my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
          do_log(-2, "policy_server FAILED: %s", $err);
          @response = (proto_encode('setreply','450','4.5.0',"Failure: $err"),
                       proto_encode('return_value','tempfail'),
                       proto_encode('exit_code',sprintf("%d",EX_TEMPFAIL)));
          die $err  if $err =~ /^timed out\b/;  # resignal timeout
        # last;
        };
        $sock->print( join('', map($_."\015\012", (@response,'')) ))
          or die "Can't write response to socket: $!, fileno=".fileno($sock);
        %attr = (); @response = ();
        if (ll(2)) {
          my $rusage_report = Amavis::Timing::rusage_report();
          do_log(2,"size: %d, %s", $msg_size, Amavis::Timing::report());
          do_log(2,"size: %d, RUSAGE %s", $msg_size, $rusage_report)
            if defined $rusage_report;
        }
      } elsif ($ln =~ /^ ([^=\000\012]*?) (=|:[ \t]*)
                         ([^\012]*?) \015?\012 \z/xsi) {
        my $attr_name = proto_decode($1);
        my $attr_val  = proto_decode($3);
        if (!exists $attr{$attr_name}) {
          $attr{$attr_name} = $attr_val;
        } else {
          $attr{$attr_name} = [ $attr{$attr_name} ]  if !ref $attr{$attr_name};
          push(@{$attr{$attr_name}}, $attr_val);
        }
        my $known_attr = scalar(grep($_ eq $attr_name, qw(
          request protocol_state version_client protocol_name helo_name
          client_name client_address client_port client_source sender recipient
          delivery_care_of queue_id partition_tag mail_id secret_id quar_type
          mail_file tempdir tempdir_removed_by policy_bank requested_by) ));
        do_log(!$known_attr?1:3,
               "policy protocol: %s=%s", $attr_name,$attr_val);
      } else {
        do_log(-1, "policy protocol: INVALID AM.PDP ATTRIBUTE LINE: %s", $ln);
      }
      $0 = sprintf("%s (ch%d-P-idle)",
                   c('myprogram_name'), $Amavis::child_invocation_count);
      switch_to_client_time("receiving AM.PDP data");
    }
    defined $ln || $! == 0  or die "Read from client socket FAILED: $!";
    switch_to_my_time('end of AM.PDP session');
  };
  $0 = sprintf("%s (ch%d-P)",
               c('myprogram_name'), $Amavis::child_invocation_count);
}

# Based on given query attributes describing a message to be checked or
# released, return a new Amavis::In::Message object with filled-in information
#
sub preprocess_policy_query($$) {
  my($attr_ref,$conn) = @_;

  my $now = Time::HiRes::time;
  my $msginfo = Amavis::In::Message->new;
  $msginfo->rx_time($now);
  $msginfo->log_id(am_id());
  $msginfo->conn_obj($conn);
  $msginfo->originating(1);
  $msginfo->add_contents_category(CC_CLEAN,0);
  add_entropy(%$attr_ref);

  # amavisd -> amavis-helper protocol query consists of any number of
  # the following lines, the response is terminated by an empty line.
  # The 'request=AM.PDP' is a required first field, the order of
  # remaining fields is arbitrary, but multivalued attributes such as
  # 'recipient' must retain their relative order.
  # Required AM.PDP fields are: request, tempdir, sender, recipient(s)
  #   request=AM.PDP
  #   version_client=n             (currently ignored)
  #   tempdir=/var/amavis/amavis-milter-MWZmu9Di
  #   tempdir_removed_by=client    (tempdir_removed_by=server is a default)
  #   mail_file=/var/amavis/am.../email.txt (defaults to tempdir/email.txt)
  #   sender=<foo@example.com>
  #   recipient=<bar1@example.net>
  #   recipient=<bar2@example.net>
  #   recipient=<bar3@example.net>
  #   delivery_care_of=server      (client or server, client is a default)
  #   queue_id=qid
  #   protocol_name=ESMTP
  #   helo_name=host.example.com
  #   client_address=10.2.3.4
  #   client_port=45678
  #   client_name=host.example.net
  #   client_source=LOCAL/REMOTE/[UNAVAILABLE]
  #     (matches local_header_rewrite_clients, see Postfix XFORWARD_README)
  #   policy_bank=SMTP_AUTH,TLS,ORIGINATING,MYNETS,...
  # Required 'release' or 'requeue' or 'report' fields are: request, mail_id
  #   request=release  (or request=requeue, or request=report)
  #   mail_id=xxxxxxxxxxxx
  #   secret_id=xxxxxxxxxxxx              (authorizes a release/report)
  #   partition_tag=xx                    (required if mail_id is not unique)
  #   quar_type=x                         F/Z/B/Q/M  (defaults to Q or F)
  #                                       file/zipfile/bsmtp/sql/mailbox
  #   mail_file=...  (optional: overrides automatics; $QUARANTINEDIR prepended)
  #   requested_by=<releaser@example.com> (optional: lands in Resent-From:)
  #   sender=<foo@example.com>            (optional: replaces envelope sender)
  #   recipient=<bar1@example.net>        (optional: replaces envelope recips)
  #   recipient=<bar2@example.net>
  #   recipient=<bar3@example.net>
  my(@recips); my(@bank_names);
  exists $attr_ref->{'request'} or die "Missing 'request' field";
  my $ampdp = $attr_ref->{'request'} =~
                               /^(?:AM\.CL|AM\.PDP|release|requeue|report)\z/i;
  local $1;
  @bank_names =
    map(/^\s*(\S.*?)\s*\z/s ? $1 : (), split(/,/, $attr_ref->{'policy_bank'}))
    if defined $attr_ref->{'policy_bank'};
  my $d_co  = $attr_ref->{'delivery_care_of'};
  my $td_rm = $attr_ref->{'tempdir_removed_by'};
  $msginfo->client_delete(defined($td_rm) && lc($td_rm) eq 'client' ? 1 : 0);
  $msginfo->queue_id($attr_ref->{'queue_id'})
    if exists $attr_ref->{'queue_id'};
  $msginfo->client_proto($attr_ref->{'protocol_name'})
    if exists $attr_ref->{'protocol_name'};
  if (exists $attr_ref->{'client_address'}) {
    $msginfo->client_addr(normalize_ip_addr($attr_ref->{'client_address'}));
  }
  $msginfo->client_port($attr_ref->{'client_port'})
    if exists $attr_ref->{'client_port'};
  $msginfo->client_name($attr_ref->{'client_name'})
    if exists $attr_ref->{'client_name'};
  $msginfo->client_source($attr_ref->{'client_source'})
    if exists $attr_ref->{'client_source'}
       &&  uc($attr_ref->{'client_source'}) ne '[UNAVAILABLE]';
  $msginfo->client_helo($attr_ref->{'helo_name'})
    if exists $attr_ref->{'helo_name'};
# $msginfo->body_type('8BITMIME');
  $msginfo->requested_by(unquote_rfc2821_local($attr_ref->{'requested_by'}))
    if exists $attr_ref->{'requested_by'};
  if (exists $attr_ref->{'sender'}) {
    my $sender = $attr_ref->{'sender'};
    $sender = '<'.$sender.'>'  if $sender !~ /^<.*>\z/;
    $msginfo->sender_smtp($sender);
    $sender = unquote_rfc2821_local($sender);
    $msginfo->sender($sender);
  }
  if (exists $attr_ref->{'recipient'}) {
    my $r = $attr_ref->{'recipient'}; @recips = ();
    for my $addr (!ref($r) ? $r : @$r) {
      my $addr_quo = $addr;
      my $addr_unq = unquote_rfc2821_local($addr);
      $addr_quo = '<'.$addr_quo.'>'  if $addr_quo !~ /^<.*>\z/;
      my $recip_obj = Amavis::In::Message::PerRecip->new;
      $recip_obj->recip_addr($addr_unq);
      $recip_obj->recip_addr_smtp($addr_quo);
      $recip_obj->dsn_orcpt($addr_quo);
      $recip_obj->recip_destiny(D_PASS);  # default is Pass
      $recip_obj->delivery_method('')  if !defined($d_co) ||
                                          lc($d_co) eq 'client';
      push(@recips,$recip_obj);
    }
    $msginfo->per_recip_data(\@recips);
  }
  if (!exists $attr_ref->{'tempdir'}) {
    my $tempdir = Amavis::TempDir->new;
    $tempdir->prepare_dir;
    $msginfo->mail_tempdir($tempdir->path);
    # Save the Amavis::TempDir object from destruction by keeping a ref to it
    # in $msginfo. When $msginfo is destroyed, the temporary directory will be
    # automatically destroyed too. This is specific to AM.PDP requests without
    # a working directory provided by a caller, and different from usual
    # SMTP sessions which keep a per-process permanent reference to an
    # Amavis::TempDir object, which makes keeping it in mail_tempdir_obj
    # not necessary.
    $msginfo->mail_tempdir_obj($tempdir);
  } else {
    local($1,$2); my $tempdir = $attr_ref->{tempdir};
    $tempdir =~ m{^ (?: \Q$TEMPBASE\E | \Q$MYHOME\E )
                    (?: / (?! \.\. (?:\z|/)) [A-Za-z0-9_.-]+ )*
                    / [A-Za-z0-9_.-]+ \z}xso
      or die "Suspicious temporary directory name '$tempdir'";
    $msginfo->mail_tempdir(untaint($tempdir));
  }
  my $quar_type;
  my $p_mail_id;
  if (!$ampdp) {
    # don't bother with filenames
  } elsif ($attr_ref->{'request'} =~ /^(?:release|requeue|report)\z/i) {
    exists $attr_ref->{'mail_id'} or die "Missing 'mail_id' field";
    $msginfo->partition_tag($attr_ref->{'partition_tag'});  # may be undef
    $p_mail_id = $attr_ref->{'mail_id'};
    # amavisd almost-base64: 62 +, 63 -  (in use up to 2.6.4, dropped in 2.7.0)
    # RFC 4648 base64:       62 +, 63 /  (not used here)
    # RFC 4648 base64url:    62 -, 63 _
    $p_mail_id =~ m{^ [A-Za-z0-9] [A-Za-z0-9_+-]* ={0,2} \z}xs
      or die "Invalid mail_id '$p_mail_id'";
    $p_mail_id = untaint($p_mail_id);
    $msginfo->parent_mail_id($p_mail_id);
    $msginfo->mail_id(scalar generate_mail_id());
    if (!exists($attr_ref->{'secret_id'}) || $attr_ref->{'secret_id'} eq '') {
      die "Secret_id is required, but missing"  if c('auth_required_release');
    } else {
      # version 2.7.0 and later uses RFC 4648 base64url and id=b64(md5(sec)),
      # versions before 2.7.0 used almost-base64 and id=b64(md5(b64(sec)))
      { # begin block, 'last' exits it
        my $secret_b64 = $attr_ref->{'secret_id'};
        $secret_b64 = ''  if !defined $secret_b64;
        if (index($secret_b64,'+') < 0) {  # new or undetermined format
          local($_) = $secret_b64;  tr{-_}{+/};  # revert base64url to base64
          my $secret_bin = decode_base64($_);
          my $id_new_b64 = Digest::MD5->new->add($secret_bin)->b64digest;
          substr($id_new_b64, 12) = '';
          $id_new_b64 =~ tr{+/}{-_};  # base64 -> RFC 4648 base64url
          last  if $id_new_b64 eq $p_mail_id;  # exit enclosing block
        }
        if (index($secret_b64,'_') < 0) {  # old or undetermined format
          my $id_old_b64 = Digest::MD5->new->add($secret_b64)->b64digest;
          substr($id_old_b64, 12) = '';
          $id_old_b64 =~ tr{/}{-};  # base64 -> almost-base64
          last  if $id_old_b64 eq $p_mail_id;  # exit enclosing block
        }
        die "Secret_id $secret_b64 does not match mail_id $p_mail_id";
      };  # end block, 'last' arrives here
    }
    $quar_type = $attr_ref->{'quar_type'};
    if (!defined($quar_type) || $quar_type eq '') {
      # choose some reasonable default (simpleminded)
      $quar_type = c('spam_quarantine_method') =~ /^sql:/i ? 'Q' : 'F';
    }
    my $fn = $p_mail_id;
    if ($quar_type eq 'F' || $quar_type eq 'Z') {
      $QUARANTINEDIR ne '' or die "Config variable \$QUARANTINEDIR is empty";
      if ($attr_ref->{'mail_file'} ne '') {
        $fn = $attr_ref->{'mail_file'};
        $fn =~ m{^[A-Za-z0-9][A-Za-z0-9/_.+-]*\z}s && $fn !~ m{\.\.(?:/|\z)}
          or die "Unsafe filename '$fn'";
        $fn = $QUARANTINEDIR.'/'.untaint($fn);
      } else {  # automatically guess a filename - simpleminded
        if ($quarantine_subdir_levels < 1) { $fn = "$QUARANTINEDIR/$fn" }
        else { my $subd = substr($fn,0,1);   $fn = "$QUARANTINEDIR/$subd/$fn" }
        $fn .= '.gz'  if $quar_type eq 'Z';
      }
    }
    $msginfo->mail_text_fn($fn);
  } elsif (!exists $attr_ref->{'mail_file'}) {
    $msginfo->mail_text_fn($msginfo->mail_tempdir . '/email.txt');
  } else {
    # SECURITY: just believe the supplied file name, blindly untainting it
    $msginfo->mail_text_fn(untaint($attr_ref->{'mail_file'}));
  }
  my $fname = $msginfo->mail_text_fn;
  if ($ampdp && defined($fname) && $fname ne '') {
    my $fh;
    my $releasing = $attr_ref->{'request'}=~ /^(?:release|requeue|report)\z/i;
    new_am_id('rel-'.$msginfo->mail_id)  if $releasing;
    if ($releasing && $quar_type eq 'Q') {  # releasing from SQL
      do_log(5, "preprocess_policy_query: opening in sql: %s", $p_mail_id);
      my $obj = $Amavis::sql_storage;
      $Amavis::extra_code_sql_quar && $obj
        or die "SQL quarantine code not enabled (3)";
      my $conn_h = $obj->{conn_h}; my $sql_cl_r = cr('sql_clause');
      my $sel_msg  = $sql_cl_r->{'sel_msg'};
      my $sel_quar = $sql_cl_r->{'sel_quar'};
      if (!defined($msginfo->partition_tag) &&
          defined($sel_msg) && $sel_msg ne '') {
        do_log(5, "preprocess_policy_query: missing partition_tag in request,".
                  " fetching msgs record for mail_id=%s", $p_mail_id);
        # find a corresponding partition_tag if missing from a release request
        $conn_h->begin_work_nontransaction;  #(re)connect if necessary
        $conn_h->execute($sel_msg, $p_mail_id);
        my $a_ref; my $cnt = 0; my $partition_tag;
        while ( defined($a_ref=$conn_h->fetchrow_arrayref($sel_msg)) ) {
          $cnt++;
          $partition_tag = $a_ref->[0]  if !defined $partition_tag;
          ll(5) && do_log(5, "release: got msgs record for mail_id=%s: %s",
                             $p_mail_id, join(', ',@$a_ref));
        }
        $conn_h->finish($sel_msg)  if defined $a_ref;  # only if not all read
        $cnt <= 1 or die "Multiple ($cnt) records with same mail_id exist, ".
                         "specify a partition_tag in the AM.PDP request";
        if ($cnt < 1) {
          do_log(0, "release: no records with msgs.mail_id=%s in a database, ".
                    "trying to read from a quar. anyway", $p_mail_id);
        }
        $msginfo->partition_tag($partition_tag);  # could still be undef/NULL !
      }
      ll(5) && do_log(5, "release: opening mail_id=%s, partition_tag=%s",
                         $p_mail_id, $msginfo->partition_tag);
      $conn_h->begin_work_nontransaction;  # (re)connect if not connected
      $fh = Amavis::IO::SQL->new;
      $fh->open($conn_h, $sel_quar, $p_mail_id,
                'r', untaint($msginfo->partition_tag))
        or die "Can't open sql obj for reading: $!";  1;
    } else {  # mail checking or releasing from a file
      do_log(5, "preprocess_policy_query: opening mail '%s'", $fname);
      # set new amavis message id
      new_am_id( ($fname =~ m{amavis-(milter-)?([^/ \t]+)}s ? $2 : undef),
                 $Amavis::child_invocation_count )  if !$releasing;
      # file created by amavis helper program or other client, just open it
      my(@stat_list) = lstat($fname); my $errn = @stat_list ? 0 : 0+$!;
      if ($errn == ENOENT) { die "File $fname does not exist" }
      elsif ($errn) { die "File $fname inaccessible: $!" }
      elsif (!-f _) { die "File $fname is not a plain file" }
      add_entropy(@stat_list);
      if ($fname =~ /\.gz\z/) {
        $fh = Amavis::IO::Zlib->new;
        $fh->open($fname,'rb') or die "Can't open gzipped file $fname: $!";
      } else {
      # $msginfo->msg_size(0 + (-s _));  # underestimates the RFC 1870 size
        $fh = IO::File->new;
        $fh->open($fname,'<') or die "Can't open file $fname: $!";
        binmode($fh,':bytes') or die "Can't cancel :utf8 mode: $!";
        my $file_size = $stat_list[7];
        if ($file_size < 100*1024) {  # 100 KiB 'small mail', read into memory
          do_log(5, 'preprocess_policy_query: reading from %s to memory, '.
                    'file size %d bytes', $fname, $file_size);
          my $str = ''; read_file($fh,\$str);
          $fh->seek(0,0) or die "Can't rewind file $fname: $!";
          $msginfo->mail_text_str(\$str);  # save mail as a string
        }
      }
    }
    $msginfo->mail_text($fh);  # save file handle to object
    $msginfo->log_id(am_id());
  }
  if ($ampdp && ll(3)) {
    do_log(3, "Request: %s %s %s: %s -> %s", $attr_ref->{'request'},
              $attr_ref->{'mail_id'}, $msginfo->mail_tempdir,
              $msginfo->sender_smtp,
              join(',', map($_->recip_addr_smtp, @recips)) );
  } else {
    do_log(3, "Request: %s(%s): %s %s %s: %s[%s] <%s> -> <%s>",
              @$attr_ref{qw(request protocol_state mail_id protocol_name
              queue_id client_name client_address sender recipient)});
  }
  ($msginfo, \@bank_names);
}

sub check_ampdp_policy($$$$) {
  my($msginfo,$check_mail,$old_amcl,$bank_names_ref) = @_;
  my($smtp_resp, $exit_code, $preserve_evidence);
  my(%baseline_policy_bank) = %current_policy_bank;
  # do some sanity checks before deciding to call check_mail()
  if (!ref($msginfo->per_recip_data) || !defined($msginfo->mail_text)) {
    $smtp_resp = '450 4.5.0 Incomplete request'; $exit_code = EX_TEMPFAIL;
  } else {
    # loading a policy bank can affect subsequent c(), cr() and ca() results,
    # so it is necessary to load each policy bank in the right order and soon
    # after information becomes available; general principle is that policy
    # banks are loaded in order in which information becomes available:
    # interface/socket, client IP, SMTP session info, sender, ...
    my $cl_ip  = $msginfo->client_addr;
    my $cl_src = $msginfo->client_source;
    my(@bank_names_cl);
    { my $cl_ip_tmp = $cl_ip;
      # treat unknown client IP addr as 0.0.0.0, from "This" Network, RFC 1700
      $cl_ip_tmp = '0.0.0.0'  if !defined($cl_ip) || $cl_ip eq '';
      my(@cp) = @{ca('client_ipaddr_policy')};
      do_log(-1,'@client_ipaddr_policy must contain pairs, '.
                'number of elements is not even')  if @cp % 2 != 0;
      my $labeler = Amavis::Lookup::Label->new('client_ipaddr_policy');
      while (@cp > 1) {
        my $lookup_table = shift(@cp);
        my $policy_names = shift(@cp);  # comma-separated string of names
        next if !defined $policy_names;
        if (lookup_ip_acl($cl_ip_tmp, $labeler, $lookup_table)) {
          local $1;
          push(@bank_names_cl,
               map(/^\s*(\S.*?)\s*\z/s ? $1 : (), split(/,/, $policy_names)));
          last;  # should we stop here or not?
        }
      }
    }
    # load policy banks from the 'client_ipaddr_policy' lookup
    Amavis::load_policy_bank($_,$msginfo) for @bank_names_cl;
    # additional banks from the request
    Amavis::load_policy_bank(untaint($_),$msginfo) for @$bank_names_ref;
    my $sender = $msginfo->sender;
    if (defined $policy_bank{'MYUSERS'} &&
        $sender ne '' && $msginfo->originating &&
        lookup2(0,$sender, ca('local_domains_maps'))) {
      Amavis::load_policy_bank('MYUSERS',$msginfo);
    }
    my $debrecipm = ca('debug_recipient_maps');
    if (lookup2(0, $sender, ca('debug_sender_maps')) ||
        @$debrecipm && grep(lookup2(0, $_->recip_addr, $debrecipm),
                                    @{$msginfo->per_recip_data})) {
      debug_oneshot(1);
    }
    # check_mail() expects open file on $fh, need not be rewound
    Amavis::check_mail_begin_task();
    ($smtp_resp, $exit_code, $preserve_evidence) = &$check_mail($msginfo,0);
    my $fh = $msginfo->mail_text;  my $tempdir = $msginfo->mail_tempdir;
    $fh->close or die "Error closing temp file: $!"   if $fh;
    undef $fh; $msginfo->mail_text(undef);
    $msginfo->mail_text_str(undef); $msginfo->body_start_pos(undef);
    my $errn = $tempdir eq '' ? ENOENT : (stat($tempdir) ? 0 : 0+$!);
    if ($tempdir eq '' || $errn == ENOENT) {
      # do nothing
    } elsif ($msginfo->client_delete) {
      do_log(4, "AM.PDP: deletion of %s is client's responsibility", $tempdir);
    } elsif ($preserve_evidence) {
      do_log(-1,'AM.PDP: tempdir is to be PRESERVED: %s', $tempdir);
    } else {
      my $fname = $msginfo->mail_text_fn;
      do_log(4, 'AM.PDP: tempdir and file being removed: %s, %s',
                $tempdir,$fname);
      unlink($fname) or die "Can't remove file $fname: $!"  if $fname ne '';
      # must step out of the directory which is about to be deleted,
      # otherwise rmdir can fail (e.g. on Solaris)
      chdir($TEMPBASE) or die "Can't chdir to $TEMPBASE: $!";
      rmdir_recursively($tempdir);
    }
  }
  # amavisd -> amavis-helper protocol response consists of any number of
  # the following lines, the response is terminated by an empty line:
  #   version_server=2
  #   log_id=xxx
  #   delrcpt=<recipient>
  #   addrcpt=<recipient>
  #   delheader=hdridx hdr_head
  #   chgheader=hdridx hdr_head hdr_body
  #   insheader=hdridx hdr_head hdr_body
  #   addheader=hdr_head hdr_body
  #   replacebody=new_body  (not implemented)
  #   quarantine=reason  (currently never used, supposed to call
  #                       smfi_quarantine, placing message on hold)
  #   return_value=continue|reject|discard|accept|tempfail
  #   setreply=rcode xcode message
  #   exit_code=n

  my(@response); my($rcpt_deletes,$rcpt_count)=(0,0);
  push(@response, proto_encode('version_server', '2'));
  push(@response, proto_encode('log_id', $msginfo->log_id));
  for my $r (@{$msginfo->per_recip_data}) {
    $rcpt_count++;
    $rcpt_deletes++  if $r->recip_done;
  }
  local($1,$2,$3);
  if ($smtp_resp=~/^([1-5]\d\d) ([245]\.\d{1,3}\.\d{1,3})(?: |\z)(.*)\z/s)
    { push(@response, proto_encode('setreply', $1,$2,$3)) }
  if (     $exit_code == EX_TEMPFAIL) {
    push(@response, proto_encode('return_value','tempfail'));
  } elsif ($exit_code == EX_NOUSER) {          # reject the whole message
    push(@response, proto_encode('return_value','reject'));
  } elsif ($exit_code == EX_UNAVAILABLE) {     # reject the whole message
    push(@response, proto_encode('return_value','reject'));
  } elsif ($exit_code == 99 || $rcpt_deletes >= $rcpt_count) {
    $exit_code = 99; # let MTA discard the message, it was already handled here
    push(@response, proto_encode('return_value','discard'));
  } elsif (grep($_->delivery_method ne '', @{$msginfo->per_recip_data})) {
    # explicit forwarding by us
    die "Not all recips done, but explicit forwarding";  # just in case
  } else {  # EX_OK
    for my $r (@{$msginfo->per_recip_data}) {  # modified recipient addresses?
      my $newaddr = $r->recip_final_addr;
      if ($r->recip_done) {           # delete
        push(@response, proto_encode('delrcpt', $r->recip_addr_smtp))
          if defined $r->recip_addr;  # if in the original list, not always_bcc
      } elsif ($newaddr ne $r->recip_addr) {   # modify, e.g. adding extension
        push(@response, proto_encode('delrcpt', $r->recip_addr_smtp))
          if defined $r->recip_addr;  # if in the original list, not always_bcc
        push(@response, proto_encode('addrcpt',
                                     qquote_rfc2821_local($newaddr)));
      }
    }
    my $hdr_edits = $msginfo->header_edits;
    if ($hdr_edits) {  # any added or modified header fields?
      local($1,$2); my($field_name,$edit,$field_body);
      while ( ($field_name,$edit) = each %{$hdr_edits->{edit}} ) {
        $field_body = $msginfo->get_header_field_body($field_name,0);  # first
        if (!defined($field_body)) {
          # such header field does not exist or is not available, do nothing
        } else {                 # edit the first occurrence
          chomp($field_body);
          my $orig_field_body = $field_body;
          for my $e (@$edit) {   # possibly multiple (iterative) edits
            if (!defined($e)) { $field_body = undef; last }  # delete existing
            my($new_fbody,$verbatim) = &$e($field_name,$field_body);
            if (!defined($new_fbody)) { $field_body = undef; last }  # delete
            my $curr_head = $verbatim ? ($field_name . ':' . $new_fbody)
                                      : hdr($field_name, $new_fbody, 0,
                                            $msginfo->smtputf8);
            chomp($curr_head); $curr_head .= "\n";
            $curr_head =~ /^([^:]*?)[ \t]*:(.*)\z/s;
            $field_body = $2; chomp($field_body);  # carry to next iteration
          }
          if (!defined($field_body)) {
            push(@response, proto_encode('delheader','1',$field_name));
          } elsif ($field_body ne $orig_field_body) {
            # sendmail inserts a space after a colon, remove ours
            $field_body =~ s/^[ \t]//;
            push(@response, proto_encode('chgheader','1',
                                         $field_name,$field_body));
          }
        }
      }
      my $hdridx = c('prepend_header_fields_hdridx');  # milter insertion index
      $hdridx = 0  if !defined($hdridx) || $hdridx < 0;
      $hdridx = sprintf("%d",$hdridx);  # convert to string
      # prepend header fields one at a time, topmost field last
      for my $hf (map(ref $hdr_edits->{$_} ? reverse @{$hdr_edits->{$_}} : (),
                      qw(addrcvd prepend)) ) {
        if ($hf =~ /^([^:]*?)[ \t]*:[ \t]*(.*?)$/s)
          { push(@response, proto_encode('insheader',$hdridx,$1,$2)) }
      }
      # append header fields
      for my $hf (map(ref $hdr_edits->{$_} ? @{$hdr_edits->{$_}} : (),
                      qw(append)) ) {
        if ($hf =~ /^([^:]*?)[ \t]*:[ \t]*(.*?)$/s)
          { push(@response, proto_encode('addheader',$1,$2)) }
      }
    }
    if ($old_amcl) {   # milter via old amavis helper program
      # warn if there is anything that should be done but MTA is not capable of
      # (or a helper program cannot pass the request)
      for (grep(/^(delrcpt|addrcpt)=/, @response))
        { do_log(-1, "WARN: MTA can't do: %s", $_) }
      if ($rcpt_deletes && $rcpt_count-$rcpt_deletes > 0) {
        do_log(-1, "WARN: ACCEPT THE WHOLE MESSAGE, ".
                   "MTA-in can't do selective recips deletion");
      }
    }
    push(@response, proto_encode('return_value','continue'));
  }
  push(@response, proto_encode('exit_code',sprintf("%d",$exit_code)));
  ll(3) && do_log(3, 'mail checking ended: %s', join("\n",@response));
  dump_captured_log(1, c('enable_log_capture_dump'));
  %current_policy_bank = %baseline_policy_bank;  # restore bank settings
  @response;
}

# just a proof-of-concept, experimental
#
sub postfix_policy($$) {
  my($msginfo,$attr_ref) = @_;
  my(@response);
  if ($attr_ref->{'request'} ne 'smtpd_access_policy') {
    die("unknown 'request' value: " . $attr_ref->{'request'});
  } else {
    @response = 'action=DUNNO';
  }
  @response;
}

sub dispatch_from_quarantine($$$) {
  my($msginfo,$request_type,$feedback_type) = @_;
  my $err;
  eval {
    # feed information to a msginfo object, possibly replacing it
    $msginfo = msg_from_quarantine($msginfo,$request_type,$feedback_type);
    mail_dispatch($msginfo,0,1);  # re-send the original mail or report
    1;
  } or do {
    $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    do_log(0, "WARN: dispatch_from_quarantine failed: %s",$err);
    die $err  if $err =~ /^timed out\b/;  # resignal timeout
  };
  my(@response);
  my $per_recip_data = $msginfo->per_recip_data;
  if (!defined($per_recip_data) || !@$per_recip_data) {
    push(@response, proto_encode('setreply','250','2.5.0',
                                 "No recipients, nothing to do"));
  } else {
    Amavis::build_and_save_structured_report($msginfo,'SEND');
    for my $r (@$per_recip_data) {
      local($1,$2,$3); my($smtp_s,$smtp_es,$msg);
      my $resp = $r->recip_smtp_response;
      if ($err ne '')
        { ($smtp_s,$smtp_es,$msg) = ('450', '4.5.0', "ERROR: $err") }
      elsif ($resp =~ /^([1-5]\d\d) ([245]\.\d{1,3}\.\d{1,3})(?: |\z)(.*)\z/s)
        { ($smtp_s,$smtp_es,$msg) = ($1,$2,$3) }
      elsif ($resp =~ /^(([1-5])\d\d)(?: |\z)(.*)\z/s)
        { ($smtp_s,$smtp_es,$msg) = ($1, "$2.0.0" ,$3) }
      else
        { ($smtp_s,$smtp_es,$msg) = ('450', '4.5.0', "Unexpected: $resp") }
      push(@response, proto_encode('setreply',$smtp_s,$smtp_es,$msg));
    }
  }
  @response;
}

1;

__DATA__
#
package Amavis::In::SMTP;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll do_log do_log_safe untaint
                         dump_captured_log log_capture_enabled
                         am_id new_am_id snmp_counters_init
                         orcpt_decode xtext_decode safe_encode_utf8_inplace
                         idn_to_ascii sanitize_str add_entropy
                         debug_oneshot waiting_for_client prolong_timer
                         switch_to_my_time switch_to_client_time
                         setting_by_given_contents_category);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Lookup::IP qw(lookup_ip_acl normalize_ip_addr);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::TempDir;
  import Amavis::In::Message;
  import Amavis::In::Connection;
}

use Errno qw(ENOENT EACCES EINTR EAGAIN);
use MIME::Base64;
use Time::HiRes ();
#use IO::Socket::SSL;

BEGIN {  # due to dynamic loading runs only after config files have been read

  # for compatibility with 2.10 or earlier:
  $smtpd_tls_server_options{SSL_key_file} = $smtpd_tls_key_file
    if !exists $smtpd_tls_server_options{SSL_key_file} &&
       defined $smtpd_tls_key_file;
  $smtpd_tls_server_options{SSL_cert_file} = $smtpd_tls_cert_file
    if !exists $smtpd_tls_server_options{SSL_cert_file} &&
       defined $smtpd_tls_cert_file;

  my $tls_security_level = c('tls_security_level_in');
  $tls_security_level = 0  if !defined($tls_security_level) ||
                              lc($tls_security_level) eq 'none';
  if ($tls_security_level) {
    ( defined $smtpd_tls_server_options{SSL_cert_file} &&
      $smtpd_tls_server_options{SSL_cert_file} ne ''
    ) or die '$tls_security_level is enabled '.
          'but $smtpd_tls_server_options{SSL_cert_file} is not provided'."\n";
    ( defined $smtpd_tls_server_options{SSL_key_file} &&
      $smtpd_tls_server_options{SSL_key_file} ne ''
    ) or die '$tls_security_level is enabled '.
          'but $smtpd_tls_server_options{SSL_key_file} is not provided'."\n";
  }
  1;
}

sub new($) {
  my $class = $_[0];
  my $self = bless {}, $class;
  undef $self->{sock};              # SMTP socket
  $self->{proto} = undef;           # SMTP / ((ESMTP / LMTP) (A | S | SA)? )
  $self->{smtp_outbuf} = undef;     # SMTP responses buffer for PIPELINING
  undef $self->{pipelining};        # may we buffer responses?
  undef $self->{session_closed_normally};  # closed properly with QUIT
  $self->{within_data_transfer} = 0;
  $self->{smtp_inpbuf} = '';        # SMTP input buffer
  $self->{tempdir} = Amavis::TempDir->new;  # TempDir object
  $self;
}

sub DESTROY {
  my $self = $_[0];
  local($@,$!,$_); my $myactualpid = $$;
  eval {
    if (defined($my_pid) && $myactualpid != $my_pid) {
      do_log(5,"Skip closing SMTP session in a clone [%s] (born as [%s])",
                $myactualpid, $my_pid);
    } elsif (ref($self->{sock}) && ! $self->{session_closed_normally}) {
      my $msg = "421 4.3.2 Service shutting down, closing channel";
      $msg .= ", during waiting for input from client" if waiting_for_client();
      $msg .= ", sig: " .
              join(',', keys %Amavisd::got_signals)  if %Amavisd::got_signals;
      $self->smtp_resp(1,$msg);
    }
    1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";
    do_log_safe(1,"SMTP shutdown: %s", $eval_stat);
  };
}

sub readline {
  my($self, $timeout) = @_;
  my($rout,$eout,$rin,$ein);
  my $ifh = $self->{sock};
  for (;;) {
    local($1);
    return $1  if $self->{smtp_inpbuf} =~ s/^(.*?\015\012)//s;
#   if (defined $timeout) {
#     if (!defined $rin) {
#       $rin = $ein = ''; vec($rin, fileno $self->{sock}, 1) = 1; $ein = $rin;
#     }
#     my($nfound,$timeleft) =
#       select($rout=$rin, undef, $eout=$ein, $timeout);
#     defined $nfound && $nfound >= 0
#       or die "Select failed: ".
#              (!$self->{ssl_active} ? $! : $ifh->errstr.", $!");
#     if (!$nfound) {
#       do_log(2, 'smtp readline: timed out, %s s', $timeout);
#       $timeout = undef; next;  # carry on as usual
#     }
#   }
    my $nbytes = $ifh->sysread($self->{smtp_inpbuf}, 16384,
                               length($self->{smtp_inpbuf}));
    if ($nbytes) {
      ll(5) && do_log(5, 'smtp readline: read %d bytes, new size: %d',
                         $nbytes, length($self->{smtp_inpbuf}));
    } elsif (defined $nbytes) {  # defined but zero
      do_log(5, 'smtp readline: EOF');
      $! = 0;  # eof, no error
      last;
    } elsif ($! == EAGAIN || $! == EINTR) {
      do_log(5, 'smtp readline: interrupted: %s',
                !$self->{ssl_active} ? $! : $ifh->errstr.", $!");
      # retry
    } else {
      do_log(5, 'smtp readline: error: %s',
                !$self->{ssl_active} ? $! : $ifh->errstr.", $!");
      last;
    }
  }
  undef;
}

# Efficiently copy mail text from an SMTP socket to a file, converting
# CRLF to a local filesystem newlines \n, and handling dot-destuffing.
# Should be called just after the DATA command has been responded to,
# stops reading at a CRLF DOT CRLF or eof. Does not report stuffing errors.
#
# Our current statistics (Q4 2011) shows that 80 % of messages are below
# 30.000 bytes, and 90 % of messages are below 100.000 bytes in size.
#
sub copy_smtp_data {
  my($self, $ofh, $out_str_ref, $size_limit) = @_;
  my $ifh = $self->{sock};
  my $buff = $self->{smtp_inpbuf};  # work with a local copy
  $$out_str_ref = ''  if ref $out_str_ref;
  # assumes to be called right after a DATA<CR><LF>
  my $eof = 0; my $at_the_beginning = 1;
  my $size = 0; my $oversized = 0;
  my($errno,$nreads,$j);
  my $smtpd_t_o = c('smtpd_timeout');
  while (!$eof) {
    # alarm should apply per-line, but we are dealing with whole chunks here
    alarm($smtpd_t_o);
    $nreads = $ifh->sysread($buff, 65536, length $buff);
    if ($nreads) {
      ll(5) && do_log(5, "smtp copy: read %d bytes into buffer, new size: %d",
                         $nreads, length($buff));
    } elsif (defined $nreads) {
      $eof = 1;
      do_log(5, "smtp copy: EOF");
    } else {
      $eof = 1;
      $errno = !$self->{ssl_active} ? $! : $ifh->errstr.", $!";
      do_log(5, "smtp copy: error: %s", $errno);
    }
    if ($at_the_beginning && substr($buff,0,3) eq ".\015\012") {
      # a preceding \015\012 is implied, although no longer in the buffer
      substr($buff,0,3) = '';
      $self->{within_data_transfer} = 0;
      last;
    } elsif ( ($j=index($buff,"\015\012.\015\012")) >= 0 ) {  # last chunk
      my $carry = substr($buff,$j+5);  # often empty
      substr($buff,$j+2) = '';  # ditch the dot and the rest
      $size += length($buff);
      if (!$oversized) {
        $buff =~ s/\015\012\.?/\n/gs;
        # the last chunk is allowed to overshoot the 'small mail' limit
        $$out_str_ref .= $buff  if $out_str_ref;
        if ($ofh) {
          my $nwrites;
          for (my $ofs = 0; $ofs < length($buff); $ofs += $nwrites) {
            $nwrites = syswrite($ofh, $buff, length($buff)-$ofs, $ofs);
            defined $nwrites  or die "Error writing to mail file: $!";
          }
        }
        if ($size_limit && $size > $size_limit) {
          do_log(1,"Message size exceeded %d B", $size_limit);
          $oversized = 1;
        }
      }
      $buff = $carry;
      $self->{within_data_transfer} = 0;
      last;
    }
    my $carry = '';
    if ($eof) {
      # flush whatever is in the buffer, no more data coming
    } elsif ($at_the_beginning &&
             ($buff eq ".\015" || $buff eq '.' || $buff eq '')) {
      $carry = $buff; $buff = '';
    } elsif (substr($buff,-4,4) eq "\015\012.\015") {
      substr($buff,-4,4) = ''; $carry = "\015\012.\015";
    } elsif (substr($buff,-3,3) eq "\015\012.") {
      substr($buff,-3,3) = ''; $carry = "\015\012.";
    } elsif (substr($buff,-2,2) eq "\015\012") {
      substr($buff,-2,2) = ''; $carry = "\015\012";
    } elsif (substr($buff,-1,1) eq "\015") {
      substr($buff,-1,1) = ''; $carry = "\015";
    }
    if ($buff ne '') {
      $at_the_beginning = 0;
      # message size is defined in RFC 1870, includes CRLF but no stuffed dots
      # NOTE: we overshoot here by the number of stuffed dots, for performance;
      # the message size will be finely adjusted in get_body_digest()
      $size += length($buff);
      if (!$oversized) {
        # The RFC 5321 is quite clear, leading "." characters in
        # SMTP are stripped regardless of the following character.
        # Some MTAs only trim "." when the next character is also
        # a ".", but this violates the RFC.
        $buff =~ s/\015\012\.?/\n/gs;  # quite fast, but still a bottleneck
        if (!$out_str_ref) {
          # not writing to memory
        } elsif (length($$out_str_ref) < 100*1024) {  # 100 KiB 'small mail'
          $$out_str_ref .= $buff;
        } else {  # large mail, hand over writing to a file
#         my $nwrites;
#         for (my $ofs = 0; $ofs < length($$out_str_ref); $ofs += $nwrites) {
#           $nwrites = syswrite($ofh, $$out_str_ref,
#                               length($$out_str_ref)-$ofs, $ofs);
#           defined $nwrites  or die "Error writing to mail file: $!";
#         }
          $$out_str_ref = '';
          $out_str_ref = undef;
        }
        if ($ofh) {
          my $nwrites;
          for (my $ofs = 0; $ofs < length($buff); $ofs += $nwrites) {
            $nwrites = syswrite($ofh, $buff, length($buff)-$ofs, $ofs);
            defined $nwrites  or die "Error writing to mail file: $!";
          }
        }
        if ($size_limit && $size > $size_limit) {
          do_log(1,"Message size exceeded %d B, ".
                   "skipping further input", $size_limit);
          my $trunc_str = "\n***TRUNCATED***\n";
          $$out_str_ref .= $trunc_str  if $out_str_ref;
          if ($ofh) {
            my $nwrites = syswrite($ofh, $trunc_str);
            defined $nwrites  or die "Error writing to mail file: $!";
          }
          $oversized = 1;
        }
      }
    }
    $buff = $carry;
  }
  do_log(5, "smtp copy: %d bytes still buffered at end", length($buff));
  $self->{smtp_inpbuf} = $buff;  # put a local copy back into object
  !$self->{within_data_transfer}  or die "Connection broken during DATA: ".
                         (!$self->{ssl_active} ? $! : $ifh->errstr.", $!");
  # return a message size and an indication of exceeded size limit
  ($size,$oversized);
}

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

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

# Parse the "PROXY protocol header", which is a block of connection info
# the connection initiator prepends at the beginning of a connection.
# Recognizes the PROXY protocol Version 1  (V 2 is not supported here).
# http://www.haproxy.org/download/1.5/doc/proxy-protocol.txt
#
sub haproxy_protocol_parse($) {
  local($_) = $_[0];  # a "PROXY protocol header"
  my($proto, $src_addr, $dst_addr, $src_port, $dst_port);
  local($1,$2,$3,$4,$5);
  if (/^PROXY\ (UNKNOWN)/) {
    $proto = $1;  # receiver must ignore anything presented before the CRLF
  } elsif (/^PROXY\ ((?-i)TCP4)\ ((?:\d{1,3}\.){3}\d{1,3})
                               \ ((?:\d{1,3}\.){3}\d{1,3})
                               \ (\d{1,5})\ (\d{1,5})\x0D\x0A\z/xs) {
    ($proto, $src_addr, $dst_addr, $src_port, $dst_port) = ($1,$2,$3,$4,$5);
  } elsif (/^PROXY\ ((?-i)TCP6)\ ([0-9a-f]{0,4} (?: : [0-9a-f]{0,4}){2,7})
                               \ ([0-9a-f]{0,4} (?: : [0-9a-f]{0,4}){2,7})
                               \ (\d{1,5})\ (\d{1,5})\x0D\x0A\z/xsi) {
    ($proto, $src_addr, $dst_addr, $src_port, $dst_port) = ($1,$2,$3,$4,$5);
  }
  return ($proto)  if $proto !~ /^TCP[46]\z/;
  return if $src_port && $src_port =~ /^0/;  # leading zeroes not allowed
  return if $dst_port && $dst_port =~ /^0/;
  $src_port = 0+$src_port; $dst_port = 0+$dst_port;  # turn to numeric
  return if $src_port > 65535 || $dst_port > 65535;
  ($proto, $src_addr, $dst_addr, $src_port, $dst_port);
}

# process the "PROXY protocol header" and pretend the claimed connection
#
sub haproxy_apply($$) {
  my($conn, $line) = @_;
  if (defined $line) {
    ll(4) && do_log(4, 'HAProxy: < %s', $line);
    my($proto, $src_addr, $dst_addr, $src_port, $dst_port) =
      haproxy_protocol_parse($line);
    if (!defined $src_addr || !defined $dst_addr ||
        !$src_port || !$dst_port) {
      do_log(0, "HAProxy: PROXY protocol header expected, got: %s", $line);
      die "HAProxy: a PROXY protocol header expected";
    } elsif (!Amavis::access_is_allowed(undef, $src_addr, $src_port,
                                               $dst_addr, $dst_port)) {
      do_log(0, "HAProxy, access denied: %s [%s]:%d -> [%s]:%d",
                $proto, $src_addr, $src_port, $dst_addr, $dst_port);
      die "HAProxy: access from client $src_addr denied\n";
    } else {
      if (ll(3)) {
        do_log(3,
          "HAProxy: accepted:   (client) [%s]:%d -> [%s]:%d (HA Proxy/server)",
          $src_addr, $src_port, $dst_addr, $dst_port);
        do_log(3,
          "HAProxy: (HA Proxy/initiator) [%s]:%d -> [%s]:%d (me/target)",
          $conn->client_ip||'x', $conn->client_port||0,
          $conn->socket_ip||'x', $conn->socket_port||0);
      };
      $conn->client_ip(untaint(normalize_ip_addr($src_addr)));
      $conn->socket_ip(untaint(normalize_ip_addr($dst_addr)));
      $conn->client_port(untaint($src_port));
      $conn->socket_port(untaint($dst_port));
    }
  }
}

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

  my($msginfo, $authenticated, $auth_user, $auth_pass);
  my(%announced_ehlo_keywords);
  $self->{sock} = $sock;
  $self->{pipelining} = 0;    # may we buffer responses?
  $self->{smtp_outbuf} = [];  # SMTP responses buffer for PIPELINING
  $self->{session_closed_normally} = 0;  # closed properly with QUIT?
  $self->{ssl_active} = 0;    # session upgraded to SSL
  my $tls_security_level = c('tls_security_level_in');
  $tls_security_level = 0  if !defined($tls_security_level) ||
                              lc($tls_security_level) eq 'none';
  my $myheloname;
# $myheloname = idn_to_ascii(c('myhostname'));
# $myheloname = 'localhost';
# $myheloname = '[127.0.0.1]';
  my $sock_ip = $conn->socket_ip;
  $myheloname = defined $sock_ip && $sock_ip ne '' ? "[$sock_ip]"
                                                   : '[localhost]';
  new_am_id(undef, $Amavis::child_invocation_count, undef);
  my $initial_am_id = 1;
  my($sender_unq, $sender_quo, @recips, $got_rcpt);
  my $max_recip_size_limit;  # maximum of per-recipient message size limits
  my($terminating,$aborting,$eof,$voluntary_exit); my(%xforward_args);
  my $seq = 0;
  my(%baseline_policy_bank) = %current_policy_bank;
  $conn->appl_proto($self->{proto} = $lmtp ? 'LMTP' : 'SMTP');

  my $final_oversized_destiny_all_pass = 1;
  my $oversized_fd_map_ref =
    setting_by_given_contents_category(CC_OVERSIZED,
                                       cr('final_destiny_maps_by_ccat'));
  my $oversized_lovers_map_ref =
    setting_by_given_contents_category(CC_OVERSIZED,
                                       cr('lovers_maps_by_ccat'));
  # system-wide message size limit, if any
  my $message_size_limit = c('smtpd_message_size_limit');
  if ($enforce_smtpd_message_size_limit_64kb_min &&
      $message_size_limit && $message_size_limit < 65536) {
    $message_size_limit = 65536;  # RFC 5321 requires at least 64k
  }

  if (c('haproxy_target_enabled')) {
    Amavis::Timing::go_idle(4);
    my $line; { local($/) = "\012"; $line = $self->readline }
    Amavis::Timing::go_busy(5);
    defined $line  or die "Error reading, expected a PROXY header: $!";
    haproxy_apply($conn, $line);
  }

  my $smtpd_greeting_banner_tmp = c('smtpd_greeting_banner');
  $smtpd_greeting_banner_tmp =~
    s{ \$ (?: \{ ([^\}]+) \} |
              ([a-zA-Z](?:[a-zA-Z0-9_-]*[a-zA-Z0-9])?\b) ) }
     { { 'helo-name'    => $myheloname,
         'myhostname'   => idn_to_ascii(c('myhostname')),
         'version'      => $myversion,
         'version-id'   => $myversion_id,
         'version-date' => $myversion_date,
         'product'      => $myproduct_name,
         'protocol'     => $lmtp?'LMTP':'ESMTP' }->{lc($1.$2)}
     }xgse;
  $self->smtp_resp(1,"220 $smtpd_greeting_banner_tmp");
  section_time('SMTP greeting');
  # each call to smtp_resp starts a $smtpd_timeout timeout to tame slow clients

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

# (causes holdups in Postfix, it doesn't retry immediately; better set max_use)
#     $Amavis::child_task_count >= $max_requests    # exceeded max_requests
#     && /^(?:HELO|EHLO|LHLO|DATA|NOOP|QUIT|VRFY|EXPN|TURN)\z/ && do {
#       # pipelining checkpoints;
#       # in case of multiple-transaction protocols (e.g. SMTP, LMTP)
#       # we do not like to keep running indefinitely at the MTA's mercy
#       my $msg = "Closing transmission channel ".
#                  "after $Amavis::child_task_count transactions, $_";
#       do_log(2,"%s",$msg); $self->smtp_resp(1,"421 4.3.0 ".$msg);  #flush!
#       $terminating=1; last;
#     };

      $tls_security_level && lc($tls_security_level) ne 'may' &&
      !$self->{ssl_active} && !/^(?:NOOP|EHLO|STARTTLS|QUIT)\z/ && do {
        $self->smtp_resp(1,"530 5.7.0 Must issue a STARTTLS command first",
                         1,$cmd);
        last;
      };

#     lc($tls_security_level) eq 'verify' && !/^QUIT\z/ && do {
#       $self->smtp_resp(1,"554 5.7.0 Command refused due to lack of security",
#                        1,$cmd);
#       last;
#     };

      /^NOOP\z/ && do { $self->smtp_resp(1,"250 2.0.0 Ok $_"); last };  #flush!

      /^QUIT\z/ && do {
        if ($args ne '') {
          $self->smtp_resp(1,"501 5.5.4 Error: QUIT does not accept arguments",
                           1,$cmd);  #flush
        } else {
          my $smtpd_quit_banner_tmp = c('smtpd_quit_banner');
          $smtpd_quit_banner_tmp =~
            s{ \$ (?: \{ ([^\}]+) \} |
                      ([a-zA-Z](?:[a-zA-Z0-9_-]*[a-zA-Z0-9])?\b) ) }
             { { 'helo-name'    => $myheloname,
                 'myhostname'   => idn_to_ascii(c('myhostname')),
                 'version'      => $myversion,
                 'version-id'   => $myversion_id,
                 'version-date' => $myversion_date,
                 'product'      => $myproduct_name,
                 'protocol'     => $lmtp?'LMTP':'ESMTP' }->{lc($1.$2)}
             }xgse;
          $self->smtp_resp(1,"221 2.0.0 $smtpd_quit_banner_tmp");  #flush!
          $terminating = 1;
        }
        last;
      };

      /^(?:RSET|HELO|EHLO|LHLO|STARTTLS)\z/ && do {
        # explicit or implicit session reset
        $sender_unq = $sender_quo = undef; @recips = (); $got_rcpt = 0;
        undef $max_recip_size_limit; undef $msginfo;  # forget previous
        $final_oversized_destiny_all_pass = 1;
        %current_policy_bank = %baseline_policy_bank;  # restore bank settings
        %xforward_args = ();
        if (/^(?:RSET|STARTTLS)\z/ && $args ne '') {
          $self->smtp_resp(1,"501 5.5.4 Error: $_ does not accept arguments",
                           1,$cmd);
        } elsif (/^RSET\z/) {
          $self->smtp_resp(0,"250 2.0.0 Ok $_");
        } elsif (/^STARTTLS\z/) {  # RFC 3207 (ex RFC 2487)
          if ($self->{ssl_active}) {
            $self->smtp_resp(1,"554 5.5.1 Error: TLS already active");
          } elsif (!$tls_security_level) {
            $self->smtp_resp(1,"502 5.5.1 Error: command not available");
        # } elsif (!$announced_ehlo_keywords{'STARTTLS'}) {
        #   $self->smtp_resp(1,"502 5.5.1 Error: ".
        #                      "service extension STARTTLS was not announced");
          } else {
            $self->smtp_resp(1,"220 2.0.0 Ready to start TLS");  #flush!
            %announced_ehlo_keywords = ();
            IO::Socket::SSL->start_SSL($sock,
              SSL_server => 1,
              SSL_hostname => idn_to_ascii(c('myhostname')),
              SSL_error_trap => sub {
                my($sock,$msg) = @_;
                do_log(-2,"STARTTLS, upgrading socket to TLS failed: %s",$msg);
              },
              %smtpd_tls_server_options,
            ) or die "Error upgrading input socket to TLS: ".
                     IO::Socket::SSL::errstr();
            if ($self->{smtp_inpbuf} ne '') {
              do_log(-1, "STARTTLS pipelining violation attempt, sanitized");
              $self->{smtp_inpbuf} = '';  # ditch any buffered data
            }
            $self->{ssl_active} = 1;
            ll(3) && do_log(3,"smtpd TLS cipher: %s", $sock->get_cipher);
            section_time('SMTP starttls');
          }
        } elsif (/^HELO\z/) {
          $self->{pipelining} = 0; $lmtp = 0;
          $conn->appl_proto($self->{proto} = 'SMTP');
          $self->smtp_resp(0,"250 $myheloname");
          $conn->smtp_helo($args); section_time('SMTP HELO');
        } elsif (/^(?:EHLO|LHLO)\z/) {
          $self->{pipelining} = 1; $lmtp = $_ eq 'LHLO' ? 1 : 0;
          $conn->appl_proto($self->{proto} = $lmtp ? 'LMTP' : 'ESMTP');
          my(@ehlo_keywords) = (
            'VRFY',
            'PIPELINING',           # RFC 2920
            !defined($message_size_limit) ? 'SIZE'  # RFC 1870
              : sprintf('SIZE %d',$message_size_limit),
            'ENHANCEDSTATUSCODES',  # RFC 2034, RFC 3463, RFC 5248
            '8BITMIME',             # RFC 6152
            'SMTPUTF8',             # RFC 6531
            'DSN',                  # RFC 3461
            !$tls_security_level || $self->{ssl_active} ? ()
              : 'STARTTLS',         # RFC 3207 (ex RFC 2487)
            !@{ca('auth_mech_avail')} ? ()   # RFC 4954 (ex RFC 2554)
              : join(' ','AUTH',@{ca('auth_mech_avail')}),
            'XFORWARD NAME ADDR PORT PROTO HELO IDENT SOURCE',
          # 'XCLIENT NAME ADDR PORT PROTO HELO LOGIN',
          );
          my(%smtpd_discard_ehlo_keywords) =
            map((uc($_),1), @{ca('smtpd_discard_ehlo_keywords')});
          # RFC 6531: Servers offering this extension MUST provide
          #   support for, and announce, the 8BITMIME extension
          $smtpd_discard_ehlo_keywords{'SMTPUTF8'} = 1
            if $smtpd_discard_ehlo_keywords{'8BITMIME'};
          @ehlo_keywords =
            grep(/^([A-Za-z0-9]+)/ &&
                 !$smtpd_discard_ehlo_keywords{uc $1}, @ehlo_keywords);
          $self->smtp_resp(1,"250 $myheloname\n" .
                             join("\n",@ehlo_keywords));  #flush!
          %announced_ehlo_keywords =
            map( (/^([A-Za-z0-9]+)/ && uc $1, 1), @ehlo_keywords);
          $conn->smtp_helo($args); section_time("SMTP $_");
        };
        last;
      };

      /^XFORWARD\z/ && do {  # Postfix extension
        my $xcmd = $_;
        if (defined $sender_unq) {
          $self->smtp_resp(1,"503 5.5.1 Error: $xcmd not allowed ".
                             "within transaction",1,$cmd);
          last;
        }
        my $bad;
        for (split(' ',$args)) {
          if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]* ) =
                  ( [\x21-\x7E\x80-\xFF]{0,255} )\z/xs) {
            $self->smtp_resp(1,"501 5.5.4 Syntax error in $xcmd parameters",
                             1, $cmd);
            $bad = 1; last;
          } else {
            my($name,$val) = (uc($1), $2);
            if ($name=~/^(?:NAME|ADDR|PORT|PROTO|HELO|IDENT|SOURCE|LOGIN)\z/) {
              $val = undef  if uc($val) eq '[UNAVAILABLE]';
              # Postfix since vers 2.3 (20060610) uses xtext-encoded (RFC 3461)
              # strings in XCLIENT and XFORWARD attribute values, previous
              # versions sent plain text with neutered special characters.
              # The IDENT option is available since postfix 2.8.0 .
              $val = xtext_decode($val)  if defined $val &&
                                            $val =~ /\+([0-9a-fA-F]{2})/;
              $xforward_args{$name} = $val;
            } else {
              $self->smtp_resp(1,"501 5.5.4 $xcmd command parameter ".
                                 "error: $name=$val",1,$cmd);
              $bad = 1; last;
            }
          }
        }
        $self->smtp_resp(1,"250 2.5.0 Ok $_")  if !$bad;
        last;
      };

      /^HELP\z/ && do {
        $self->smtp_resp(0,"214 2.0.0 See $myproduct_name home page at:\n".
                           "http://www.ijs.si/software/amavisd/");
        last;
      };

      /^AUTH\z/ && @{ca('auth_mech_avail')} && do {  # RFC 4954 (ex RFC 2554)
      # if (!$announced_ehlo_keywords{'AUTH'}) {
      #   $self->smtp_resp(1,"502 5.5.1 Error: ".
      #                      "service extension AUTH was not announced");
      #   last;
      # } elsif
        if ($args !~ /^([^ ]+)(?: ([^ ]*))?\z/is) {
          $self->smtp_resp(1,"501 5.5.2 Syntax: AUTH mech [initresp]",1,$cmd);
          last;
        }
        # enhanced status codes: RFC 4954, RFC 5248
        my($auth_mech,$auth_resp) = (uc($1), $2);
        if ($authenticated) {
          $self->smtp_resp(1,"503 5.5.1 Error: session already authenticated",
                             1,$cmd);
        } elsif (defined $sender_unq) {
          $self->smtp_resp(1,"503 5.5.1 Error: AUTH not allowed within ".
                             "transaction",1,$cmd);
        } elsif (!grep(uc($_) eq $auth_mech, @{ca('auth_mech_avail')})) {
          $self->smtp_resp(1,"504 5.5.4 Error: requested authentication ".
                             "mechanism not supported",1,$cmd);
        } else {
          my($state,$result,$challenge);
          if   ($auth_resp eq '=') { $auth_resp = '' }  # zero length
          elsif ($auth_resp eq '') { $auth_resp = undef }
          for (;;) {
            if ($auth_resp !~ m{^[A-Za-z0-9+/]*=*\z}) {
              $self->smtp_resp(1,"501 5.5.2 Authentication failed: ".
                                 "malformed authentication response",1,$cmd);
              last;
            } else {
              $auth_resp = decode_base64($auth_resp)  if $auth_resp ne '';
              ($state,$result,$challenge) =
                authenticate($state, $auth_mech, $auth_resp);
              if (ref($result) eq 'ARRAY') {
                $self->smtp_resp(0,"235 2.7.0 Authentication succeeded");
                $authenticated = 1; ($auth_user,$auth_pass) = @$result;
                do_log(2,"AUTH %s, user=%s", $auth_mech,$auth_user); #auth_resp
                last;
              } elsif (defined $result && !$result) {
                $self->smtp_resp(0,"535 5.7.8 Authentication credentials ".
                                   "invalid", 1, $cmd);
                last;
              }
            }
            # server challenge or ready prompt
            $self->smtp_resp(1,"334 ".encode_base64($challenge,''));
            $! = 0; $auth_resp = $self->readline;
            defined $auth_resp  or die "Error reading auth resp: ".
                            (!$self->{ssl_active} ? $! : $sock->errstr.", $!");
            switch_to_my_time('rx AUTH challenge reply');
            do_log(5, "%s< %s", $self->{proto},$auth_resp);
            $auth_resp =~ s/\015?\012\z//;
            if (length($auth_resp) > 12288) {  # RFC 4954
              $self->smtp_resp(1,"500 5.5.6 Authentication exchange ".
                                 "line is too long");
              last;
            } elsif ($auth_resp eq '*') {
              $self->smtp_resp(1,"501 5.7.1 Authentication aborted");
              last;
            }
          }
        }
        last;
      };

      /^VRFY\z/ && do {
        if ($args eq '') {
          $self->smtp_resp(1,"501 5.5.2 Syntax: VRFY address", 1,$cmd); #flush!
        } else {  # RFC 2505
          $self->smtp_resp(1,"252 2.0.0 Argument not checked", 0,$cmd); #flush!
        }
        last;
      };

      /^MAIL\z/ && do {  # begin new SMTP transaction
        if (defined $sender_unq) {
          $self->smtp_resp(1,"503 5.5.1 Error: nested MAIL command", 1, $cmd);
          last;
        }
        if (!$authenticated &&
            c('auth_required_inp') && @{ca('auth_mech_avail')} ) {
          $self->smtp_resp(1,"530 5.7.0 Authentication required", 1, $cmd);
          last;
        }
        # begin SMTP transaction
        my $now = Time::HiRes::time;
        if (!$seq) { # the first connect
          section_time('SMTP pre-MAIL');
        } else {     # establish a new time reference for each transaction
          Amavis::Timing::init(); snmp_counters_init();
        }
        $seq++;
        new_am_id(undef, $Amavis::child_invocation_count, $seq)
          if !$initial_am_id;
        $initial_am_id = 0;
        # enter 'in transaction' state
        $Amavis::zmq_obj->register_proc(1,1,'m',am_id()) if $Amavis::zmq_obj;
        $Amavis::snmp_db->register_proc(1,1,'m',am_id()) if $Amavis::snmp_db;
        Amavis::check_mail_begin_task();
        $self->{tempdir}->prepare_dir;
        $self->{tempdir}->prepare_file;
        $msginfo = Amavis::In::Message->new;
        $msginfo->rx_time($now);
        $msginfo->log_id(am_id());
        $msginfo->conn_obj($conn);

        my $cl_ip = normalize_ip_addr($xforward_args{'ADDR'});
        my $cl_port = $xforward_args{'PORT'};
        my $cl_src  = $xforward_args{'SOURCE'};  # local_header_rewrite_clients
        my $cl_login= $xforward_args{'LOGIN'};   # XCLIENT
        $cl_port = undef  if $cl_port !~ /^\d{1,9}\z/ || $cl_port > 65535;
        my(@bank_names_cl);
        { my $cl_ip_tmp = $cl_ip;
          # treat unknown client IP address as 0.0.0.0,
          # from "This" Network, RFC 1700
          $cl_ip_tmp = '0.0.0.0'  if !defined($cl_ip) || $cl_ip eq '';
          my(@cp) = @{ca('client_ipaddr_policy')};
          do_log(-1,'@client_ipaddr_policy must contain pairs, '.
                    'number of elements is not even')  if @cp % 2 != 0;
          my $labeler = Amavis::Lookup::Label->new('client_ipaddr_policy');
          while (@cp > 1) {
            my $lookup_table = shift(@cp);
            my $policy_names = shift(@cp);  # comma-separated string of names
            next if !defined $policy_names;
            if (lookup_ip_acl($cl_ip_tmp, $labeler, $lookup_table)) {
              local $1;
              push(@bank_names_cl,
                map(/^\s*(\S.*?)\s*\z/s ? $1 : (), split(/,/, $policy_names)));
              last;  # should we stop here or not?
            }
          }
        }
        # load policy banks from the 'client_ipaddr_policy' lookup
        Amavis::load_policy_bank($_,$msginfo) for @bank_names_cl;
        $msginfo->originating(c('originating'));

        $msginfo->client_addr($cl_ip);      # ADDR
        $msginfo->client_port($cl_port);    # PORT
        $msginfo->client_source($cl_src);   # SOURCE
        $msginfo->client_name($xforward_args{'NAME'});
        $msginfo->client_helo($xforward_args{'HELO'});
        $msginfo->client_proto($xforward_args{'PROTO'});
        $msginfo->queue_id($xforward_args{'IDENT'});
      # $msginfo->body_type('7BIT');  # presumed, unless explicitly declared
        %xforward_args = ();  # reset values for the next transaction
        if ($self->{ssl_active}) {
          $msginfo->tls_cipher($sock->get_cipher);
          if ($self->{proto} =~ /^(LMTP|ESMTP)\z/i) {
            $self->{proto} .= 'S';  # RFC 3848
            $conn->appl_proto($self->{proto});
          }
        }
        my $submitter;
        if ($authenticated) {
          $msginfo->auth_user($auth_user); $msginfo->auth_pass($auth_pass);
          if ($self->{proto} =~ /^(LMTP|ESMTP)S?\z/i) {
            $self->{proto} .= 'A';  # RFC 3848
            $conn->appl_proto($self->{proto});
          }
        } elsif (c('auth_reauthenticate_forwarded') &&
                 c('amavis_auth_user') ne '') {
          $msginfo->auth_user(c('amavis_auth_user'));
          $msginfo->auth_pass(c('amavis_auth_pass'));
        # $submitter = quote_rfc2821_local(c('mailfrom_notify_recip'));
        # safe_encode_utf8_inplace($submitter)  # to octets (if not already)
        # $submitter = expand_variables($submitter) if defined $submitter;
        }
        local($1,$2);
        if ($args !~ /^FROM: [ \t]*
                      ( < (?:  " (?: \\. | [^\\"] ){0,999} " | [^"\@ \t] )*
                          (?: \@ (?: \[ (?: \\. | [^\]\\] ){0,999} \] |
                                     [^\[\]\\> \t] )* )? > )
                      (?: [ \t]+ (.+) )? \z/isx ) {
          $self->smtp_resp(0,"501 5.5.2 Syntax: MAIL FROM:<address>",1,$cmd);
          last;
        }
        my($addr,$opt) = ($1,$2);
        my($size,$dsn_ret,$dsn_envid,$smtputf8);
        my $msg; my $msg_nopenalize = 0;
        for (split(' ',$opt)) {
          if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]* )
                  (?: = ( [^=\000-\040\177]+ ) )? \z/xs) {
                  # any CHAR excluding "=", SP, and control characters
            $msg = "501 5.5.4 Syntax error in MAIL FROM parameters";
          } else {
            my($name,$val) = (uc($1),$2);
            if (!defined($val) && $name =~ /^(?:BODY|RET|ENVID|AUTH)\z/) {
              $msg = "501 5.5.4 Syntax error in MAIL parameter, ".
                     "value is required: $name";
            } elsif ($name eq 'SIZE') {  # RFC 1870
              if (!$announced_ehlo_keywords{'SIZE'}) {
                do_log(5,'service extension SIZE was not announced');
                # "555 5.5.4 Service extension SIZE was not announced: $name"
              }
              if (!defined $val) {
                # value not provided, ignore
              } elsif ($val !~ /^\d{1,20}\z/) {
                $msg = "501 5.5.4 Syntax error in MAIL parameter: $name";
              } else {
                $size = untaint($val)  if !defined $size;
              }
            } elsif ($name eq 'SMTPUTF8') {  # RFC 6531
              if (!$announced_ehlo_keywords{'SMTPUTF8'}) {
                do_log(5,'service extension SMTPUTF8 was not announced');
                # "555 5.5.4 Service extension SMTPUTF8 not announced: $name"
              }
              if (defined $val) {
                # RFC 6531: The parameter does not accept a value.
                $msg = "501 5.5.4 Syntax error in MAIL parameter: $name";
              } else {
                $msginfo->smtputf8(1);
                if ($self->{proto} =~ /^(LMTP|ESMTP)S?A?\z/si) {
                  $self->{proto} = 'UTF8' . $self->{proto};  # RFC 6531
                  $self->{proto} =~ s/^UTF8ESMTP/UTF8SMTP/s;
                  $conn->appl_proto($self->{proto});
                }
              }
            } elsif ($name eq 'BODY') {  # RFC 6152: 8bit-MIMEtransport
              if (!$announced_ehlo_keywords{'8BITMIME'}) {
                do_log(5,'service extension 8BITMIME was not announced: BODY');
                # "555 5.5.4 Service extension 8BITMIME not announced: $name"
              }
              if (defined $val && $val =~ /^(?:7BIT|8BITMIME)\z/i) {
                $msginfo->body_type(uc $val);
              } else {
                $msg = "501 5.5.4 Syntax error in MAIL parameter: $name";
              }
            } elsif ($name eq 'RET') {    # RFC 3461
              if (!$announced_ehlo_keywords{'DSN'}) {
                do_log(5,'service extension DSN was not announced: RET');
                # "555 5.5.4 Service extension DSN not announced: $name"
              }
              if (!defined($dsn_ret)) {
                $dsn_ret = uc $val;
              } else {
                $msg = "501 5.5.4 Syntax error in MAIL parameter: $name";
              }
            } elsif ($name eq 'ENVID') {  # RFC 3461, value encoded as xtext
              if (!$announced_ehlo_keywords{'DSN'}) {
                do_log(5,'service extension DSN was not announced: ENVID');
                # "555 5.5.4 Service extension DSN not announced: $name"
              }
              if (!defined($dsn_envid)) {
                $dsn_envid = $val;
              } else {
                $msg = "501 5.5.4 Syntax error in MAIL parameter: $name";
              }
            } elsif ($name eq 'AUTH') {   # RFC 4954 (ex RFC 2554)
              if (!$announced_ehlo_keywords{'AUTH'}) {
                do_log(5,'service extension AUTH was not announced');
                # "555 5.5.4 Service extension AUTH not announced: $name"
              }
              my $s = xtext_decode($val); # encoded as xtext: RFC 3461
              do_log(5,"MAIL command, %s, submitter: %s", $authenticated,$s);
              if (defined $submitter) {   # authorized identity
                $msg = "504 5.5.4 MAIL command duplicate param.: $name=$val";
              } elsif (!@{ca('auth_mech_avail')}) {
                do_log(3,"MAIL command parameter AUTH supplied, but ".
                         "authentication capability not announced, ignored");
                $submitter = '<>';
                # mercifully ignore invalid parameter for the benefit of
                # running amavisd as a Postfix pre-queue smtp proxy filter
              # $msg = "503 5.7.4 Error: authentication disabled";
              } else {
                $submitter = $s;
              }
            } else {
              $msg = "504 5.5.4 MAIL command parameter error: $name=$val";
            }
          }
          last  if defined $msg;
        }
        if (!defined($msg) && defined $dsn_ret && $dsn_ret!~/^(FULL|HDRS)\z/) {
          $msg = "501 5.5.4 Syntax error in MAIL parameter RET: $dsn_ret";
        }
        if (!defined $msg) {
          $sender_quo = $addr; $sender_unq = unquote_rfc2821_local($addr);
          $addr = $1  if $addr =~ /^<(.*)>\z/s;
          my $requoted = qquote_rfc2821_local($sender_unq);
          do_log(2, "address modified (sender): %s -> %s",
                    $sender_quo, $requoted)  if $requoted ne $sender_quo;
          if (defined $policy_bank{'MYUSERS'} &&
              $sender_unq ne '' && $msginfo->originating &&
              lookup2(0,$sender_unq, ca('local_domains_maps'))) {
            Amavis::load_policy_bank('MYUSERS',$msginfo);
          }
          debug_oneshot(
            lookup2(0,$sender_unq, ca('debug_sender_maps')) ? 1 : 0,
            $self->{proto} . "< $cmd");
        # $submitter = $addr  if !defined($submitter);  # RFC 4954: MAY
          $submitter = '<>'   if !defined($msginfo->auth_user);
          $msginfo->auth_submitter($submitter);
          if (defined $size) {
            do_log(5, "mesage size set to a declared size %s", $size);
            $msginfo->msg_size(0+$size);
          }
          if (defined $dsn_ret || defined $dsn_envid) {
            # keep ENVID in xtext-encoded form
            $msginfo->dsn_ret($dsn_ret)      if defined $dsn_ret;
            $msginfo->dsn_envid($dsn_envid)  if defined $dsn_envid;
          }
          $msg = "250 2.1.0 Sender $sender_quo OK";
        };
        $self->smtp_resp(0,$msg, !$msg_nopenalize && $msg=~/^5/ ? 1 : 0, $cmd);
        section_time('SMTP MAIL');
        last;
      };

      /^RCPT\z/ && do {
        if (!defined($sender_unq)) {
          $self->smtp_resp(1,"503 5.5.1 Need MAIL command before RCPT",1,$cmd);
          @recips = (); $got_rcpt = 0;
          last;
        }
        $got_rcpt++;
        local($1,$2);
        if ($args !~ /^TO: [ \t]*
                      ( < (?:  " (?: \\. | [^\\"] ){0,999} " | [^"\@ \t] )*
                          (?: \@ (?: \[ (?: \\. | [^\]\\] ){0,999} \] |
                                     [^\[\]\\> \t] )* )? > )
                      (?: [ \t]+ (.+) )? \z/isx ) {
          $self->smtp_resp(0,"501 5.5.2 Syntax: RCPT TO:<address>",1,$cmd);
          last;
        }
        my($addr_smtp,$opt) = ($1,$2);
        my($notify,$orcpt);
        my $msg; my $msg_nopenalize = 0;
        for (split(' ',$opt)) {
          if (!/^ ( [A-Za-z0-9] [A-Za-z0-9-]*  )
                  (?: = ( [^=\000-\040\177]+ ) )? \z/xs) {
                  # any CHAR excluding "=", SP, and control characters
            $msg = "501 5.5.4 Syntax error in RCPT parameters";
          } else {
            my($name,$val) = (uc($1),$2);
            if (!defined($val) && $name =~ /^(?:NOTIFY|ORCPT)\z/) {
              $msg = "501 5.5.4 Syntax error in RCPT parameter, ".
                     "value is required: $name";
            } elsif ($name eq 'NOTIFY') {  # RFC 3461
              if (!$announced_ehlo_keywords{'DSN'}) {
                do_log(5,'service extension DSN was not announced: NOTIFY');
                # "555 5.5.4 Service extension DSN not announced: $name"
              }
              if (!defined($notify)) {
                $notify = $val;
              } else {
                $msg = "501 5.5.4 Syntax error in RCPT parameter $name";
              }
            } elsif ($name eq 'ORCPT') {
              # RFC 3461: value encoded as xtext
              # RFC 6533: utf-8-addr-xtext, utf-8-addr-unitext, utf-8-address
              if (!$announced_ehlo_keywords{'DSN'}) {
                do_log(5,'service extension DSN was not announced: ORCPT');
                # "555 5.5.4 Service extension DSN not announced: $name"
              }
              if (defined $orcpt) {  # duplicate
                $msg = "501 5.5.4 Syntax error in RCPT parameter $name";
              } else {
                my($addr_type, $orcpt_dec) =
                  orcpt_decode($val, $msginfo->smtputf8);
                $orcpt = $addr_type . ';' . $orcpt_dec;
              }
            } else {
              $msg = "555 5.5.4 RCPT command parameter unrecognized: $name";
              # 504 5.5.4 RCPT command parameter not implemented:
              # 504 5.5.4 RCPT command parameter error:
              # 555 5.5.4 RCPT command parameter unrecognized:
            }
          }
          last  if defined $msg;
        }
        my $addr = unquote_rfc2821_local($addr_smtp);
        my $requoted = qquote_rfc2821_local($addr);
        if ($requoted ne $addr_smtp) {  # check for valid canonical quoting
          # RFC 3461: If no ORCPT parameter was present in the RCPT command
          # when the message was received, an ORCPT parameter MAY be added
          # to the RCPT command when the message is relayed. If an ORCPT
          # parameter is added by the relaying MTA, it MUST contain the
          # recipient address from the RCPT command used when the message
          # was received by that MTA
          if (defined $orcpt) {
            do_log(2, "address modified (recip): %s -> %s, orcpt retained: %s",
                      $addr_smtp, $requoted, $orcpt);
          } else {
            do_log(2, "address modified (recip): %s -> %s, setting orcpt",
                      $addr_smtp, $requoted);
            $orcpt = ';' . $addr_smtp;
          }
        }
        if (lookup2(0,$addr, ca('debug_recipient_maps'))) {
          debug_oneshot(1, $self->{proto} . "< $cmd");
        }
        my $mslm = ca('message_size_limit_maps');
        my $recip_size_limit;
        $recip_size_limit = lookup2(0,$addr,$mslm)  if @$mslm;
        if ($recip_size_limit) {
          # RFC 5321 requires at least 64k
          $recip_size_limit = 65536
            if $recip_size_limit < 65536 &&
               $enforce_smtpd_message_size_limit_64kb_min;
          $max_recip_size_limit = $recip_size_limit
            if $recip_size_limit > $max_recip_size_limit;
        }
        my $mail_size = $msginfo->msg_size;
        if (!defined($msg) && defined($notify)) {
          my(@v) = split(/,/,uc($notify),-1);
          if (grep(!/^(?:NEVER|SUCCESS|FAILURE|DELAY)\z/, @v)) {
            $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ".
                   "illegal value: $notify";
          } elsif (grep($_ eq 'NEVER', @v) && grep($_ ne 'NEVER', @v)) {
            $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ".
                   "illegal combination of values: $notify";
          } elsif (!@v) {
            $msg = "501 5.5.4 Error in RCPT parameter NOTIFY, ".
                   "missing value: $notify";
          }
          $notify = \@v;  # replace a string with a listref of items
        }
        if (!defined($msg) && $recip_size_limit) {
          # check mail size if known, update $final_oversized_destiny_all_pass
          my $fd = !ref $oversized_fd_map_ref ? $oversized_fd_map_ref # compat
               : lookup2(0, $addr, $oversized_fd_map_ref, Label => 'Destiny4');
          if (!defined $fd || $fd == D_PASS) {
            $fd = D_PASS;  # keep D_PASS
          } elsif (defined($oversized_lovers_map_ref) &&
                   lookup2(0, $addr, $oversized_lovers_map_ref,
                           Label => 'Lovers4')) {
            $fd = D_PASS;  # D_PASS for oversized lovers
          } else {  # $fd != D_PASS, blocked if oversized
            if ($final_oversized_destiny_all_pass) {
              $final_oversized_destiny_all_pass = 0;  # not PASS for all recips
              do_log(5, 'Not a D_PASS on oversized for all recips: %s', $addr);
            }
          }
          # check declared mail size here if known, otherwise we'll check
          # the actual mail size after the message is received
          if (defined $mail_size && $mail_size > $recip_size_limit) {
            $msg = $fd == D_TEMPFAIL ? '452 4.3.4' :
                   $fd == D_PASS     ? '250 2.3.4' : '552 5.3.4';
            $msg .= " Declared message size ($mail_size B) ".
                    "exceeds size limit for recipient $addr_smtp";
            $msg_nopenalize = 1;
            do_log(0, "%s %s 'RCPT TO': %s", $self->{proto},
                   $fd == D_TEMPFAIL ? 'TEMPFAIL' :
                   $fd == D_PASS ? 'PASS' : 'REJECT',
                   $msg);
          }
        }
        if (!defined($msg) && $got_rcpt > $smtpd_recipient_limit) {
          $msg = "452 4.5.3 Too many recipients";
        }
        if (!defined $msg) {
          $msg = "250 2.1.5 Recipient $addr_smtp OK";
        }
        if ($msg =~ /^2/) {
          my $recip_obj = Amavis::In::Message::PerRecip->new;
          $recip_obj->recip_addr($addr);
          $recip_obj->recip_addr_smtp($addr_smtp);
          $recip_obj->recip_destiny(D_PASS);  # default is Pass
          $recip_obj->dsn_notify($notify)  if defined $notify;
          $recip_obj->dsn_orcpt($orcpt)    if defined $orcpt;
          push(@recips,$recip_obj);
        }
        $self->smtp_resp(0,$msg, !$msg_nopenalize && $msg=~/^5/ ? 1 : 0, $cmd);
        last;
      };

      /^DATA\z/ && $args ne '' && do {
        $self->smtp_resp(1,"501 5.5.4 Error: DATA does not accept arguments",
                         1,$cmd);  #flush
        last;
      };

      /^DATA\z/ && !@recips && do {
        if (!defined($sender_unq)) {
          $self->smtp_resp(1,"503 5.5.1 Need MAIL command before DATA",1,$cmd);
        } elsif (!$got_rcpt) {
          $self->smtp_resp(1,"503 5.5.1 Need RCPT command before DATA",1,$cmd);
        } elsif ($lmtp) {  # RFC 2033 requires 503 code!
          $self->smtp_resp(1,"503 5.1.1 Error (DATA): no valid recipients",
                           0,$cmd);  #flush!
        } else {
          $self->smtp_resp(1,"554 5.1.1 Error (DATA): no valid recipients",
                           0,$cmd);  #flush!
        }
        last;
      };

#     /^DATA\z/ && uc($msginfo->body_type) eq "BINARYMIME" && do {  # RFC 3030
#       $self->smtp_resp(1,"503 5.5.1 DATA is incompatible with BINARYMIME",
#                          0,$cmd);  #flush!
#       last;
#     };

      /^DATA\z/ && do {
        # set timer to the initial value, MTA timer starts here
        if ($message_size_limit) {  # enforce system-wide size limit
          if (!$max_recip_size_limit ||
              $max_recip_size_limit > $message_size_limit) {
            $max_recip_size_limit = $message_size_limit;
          }
        }
        my $size = 0; my $oversized = 0; my $eval_stat; my $complete;
        # preallocate some storage
        my $out_str = ''; vec($out_str,65536,8) = 0; $out_str = '';
        eval {
          $msginfo->sender($sender_unq); $msginfo->sender_smtp($sender_quo);
          $msginfo->per_recip_data(\@recips);
          ll(1) && do_log(1, "%s %s:%s %s: %s -> %s%s Received: %s",
            $conn->appl_proto,
            !ref $inet_socket_bind && $conn->socket_ip eq $inet_socket_bind
              ? '' : '['.$conn->socket_ip.']',
            $conn->socket_port, $self->{tempdir}->path,
            $sender_quo,
            join(',', map($_->recip_addr_smtp, @{$msginfo->per_recip_data})),
            join('',
              !defined $msginfo->msg_size  ? () :  # RFC 1870
                                   ' SIZE='.$msginfo->msg_size,
              !defined $msginfo->body_type ? () : ' BODY='.$msginfo->body_type,
              !$msginfo->smtputf8          ? () : ' SMTPUTF8',
              !defined $msginfo->dsn_ret   ? () : ' RET='.$msginfo->dsn_ret,
              !defined $msginfo->dsn_envid ? () :
                                   ' ENVID='.xtext_decode($msginfo->dsn_envid),
              !defined $msginfo->auth_submitter ||
                       $msginfo->auth_submitter eq '<>' ? () :
                                   ' AUTH='.$msginfo->auth_submitter,
            ),
            make_received_header_field($msginfo,0) );
          # pipelining checkpoint
          $self->smtp_resp(1,"354 End data with <CR><LF>.<CR><LF>");  #flush!
          $self->{within_data_transfer} = 1;
          # data transferring state
          $Amavis::zmq_obj->register_proc(2,0,'d',am_id()) if $Amavis::zmq_obj;
          $Amavis::snmp_db->register_proc(2,0,'d',am_id()) if $Amavis::snmp_db;
          section_time('SMTP pre-DATA-flush')  if $self->{pipelining};
          $self->{tempdir}->empty(0);  # mark the mail file as non-empty
          switch_to_client_time('receiving data');
          my $fh = $self->{tempdir}->fh;
          # the copy_smtp_data() will use syswrite, flush buffer just in case
          if ($fh) { $fh->flush or die "Can't flush mail file: $!" }
          if (!$max_recip_size_limit || $final_oversized_destiny_all_pass) {
            # no message size limit enforced, faster
            ($size,$oversized) = $self->copy_smtp_data($fh, \$out_str, undef);
          } else {  # enforce size limit
            do_log(5,"enforcing size limit %s during DATA",
                     $max_recip_size_limit);
            ($size,$oversized) = $self->copy_smtp_data($fh, \$out_str,
                                                       $max_recip_size_limit);
          };
          switch_to_my_time('rx data-end');
          $complete = !$self->{within_data_transfer};
          $eof = 1  if !$complete;
          # normal data termination, eof on socket, timeout, fatal error
          do_log(4, "%s< .<CR><LF>", $self->{proto})  if $complete;
          if ($fh) {
            $fh->flush or die "Can't flush mail file: $!";
            # On some systems you have to do a seek whenever you
            # switch between reading and writing. Among other things,
            # this may have the effect of calling stdio's clearerr(3).
            $fh->seek(0,1) or die "Can't seek on file: $!";
          }
          section_time('SMTP DATA');
          1;
        } or do {  # end eval
          $eval_stat = $@ ne '' ? $@ : "errno=$!";
        };
        if ( defined $eval_stat || !$complete ||  # err or connection broken
             ($oversized && !$final_oversized_destiny_all_pass) ) {
          chomp $eval_stat  if defined $eval_stat;
          # on error, either send: '421 Shutting down',
          # or: '451 Aborted, error in processing' and NOT shut down!
          if ($oversized && !defined $eval_stat &&
              !$self->{within_data_transfer}) {
            my $msg = "552 5.3.4 Message size ($size B) exceeds size limit";
            do_log(0, "%s REJECT: %s", $self->{proto},$msg);
            $self->smtp_resp(1,$msg, 0,$cmd);
          } elsif (!$self->{within_data_transfer}) {
            my $msg = 'Error in processing: ' .
                      (defined $eval_stat ? $eval_stat
                       : !$complete ? 'incomplete' : '(no error?)');
            do_log(-2, "%s TROUBLE: 451 4.5.0 %s", $self->{proto},$msg);
            $self->smtp_resp(1,"451 4.5.0 $msg");
        ### $aborting = $msg;
          } else {
            $aborting = "Connection broken during data transfer"  if $eof;
            $aborting .= ', '  if $aborting ne '' && defined $eval_stat;
            $aborting .= $eval_stat  if defined $eval_stat;
            $aborting .= " during waiting for input from client"
              if defined $eval_stat && $eval_stat =~ /^timed out\b/
                 && waiting_for_client();
            $aborting = '???'  if $aborting eq '';
            do_log(defined $eval_stat ? -1 : 3,
                   "%s ABORTING: %s", $self->{proto}, $aborting);
          }
        } else {  # all OK
          # According to RFC 1047 it is not a good idea to do lengthy
          # processing here, but we do not have much choice, amavis has no
          # queuing mechanism and cannot accept responsibility for delivery.
          #
          # check contents before responding
          # check_mail() expects an open file handle in $msginfo->mail_text,
          # need not be rewound
          $msginfo->mail_tempdir($self->{tempdir}->path);
          $msginfo->mail_text_fn($self->{tempdir}->path . '/email.txt');
          $msginfo->mail_text($self->{tempdir}->fh);
          $msginfo->mail_text_str(\$out_str)  if defined $out_str &&
                                                 $out_str ne '';
          #
          # RFC 1870: The message size is defined as the number of octets,
          # including CR-LF pairs, but not counting the SMTP DATA command's
          # terminating dot or doubled (stuffing) dots
          my $declared_size = $msginfo->msg_size;  # RFC 1870
          if (!defined($declared_size)) {
            do_log(5, "message size set to %s", $size);
          } elsif ($size > $declared_size) { # shouldn't happen with decent MTA
            do_log(4,"Actual message size %s B greater than the ".
                     "declared %s B", $size,$declared_size);
          } elsif ($size < $declared_size) { # not unusual, but permitted
            do_log(4,"Actual message size %d B less than the declared %d B",
                     $size,$declared_size);
          }
          $msginfo->msg_size(untaint($size)); # store actual RFC 1870 mail size

          # some fatal errors are not catchable by eval (like exceeding virtual
          # memory), but may still allow processing to continue in a DESTROY or
          # END method; turn on trouble flag here to allow DESTROY to deal with
          # such a case correctly, then clear the flag after content checking
          # if everything turned out well
          $self->{tempdir}->preserve(1);
          my($smtp_resp, $exit_code, $preserve_evidence) =
            &$check_mail($msginfo,$lmtp);  # do all the contents checking
          $self->{tempdir}->preserve(0)  if !$preserve_evidence;  # clear if ok
          prolong_timer('check done');

          if ($smtp_resp =~ /^4/) {
            # ok, not-done recipients are to be expected, do not check
          } elsif (grep(!$_->recip_done && $_->delivery_method ne '',
                        @{$msginfo->per_recip_data})) {
            die "TROUBLE: (MISCONFIG?) not all recipients done";
          } elsif (grep(!$_->recip_done && $_->delivery_method eq '',
                        @{$msginfo->per_recip_data})) {
            die "NOT ALL RECIPIENTS DONE, EMPTY DELIVERY_METHOD!";
          # do_log(0, "NOT ALL RECIPIENTS DONE, EMPTY DELIVERY_METHOD!");
          }
          section_time('SMTP pre-response');
          if (!$lmtp) {  # smtp
            do_log(3, 'sending SMTP response: "%s"', $smtp_resp);
            $self->smtp_resp(0, $smtp_resp);
          } else {       # lmtp
            my $bounced = $msginfo->dsn_sent;  # 1=bounced, 2=suppressed
            for my $r (@{$msginfo->per_recip_data}) {
              my $resp = $r->recip_smtp_response;
              my $recip_quoted = $r->recip_addr_smtp;
              if ($resp=~/^[24]/) {
                # success or tempfail, no need to change status
              } elsif ($bounced && $bounced == 1) {  # genuine bounce
                # a non-delivery notifications was already sent by us, so
                # MTA must not bounce it again; turn status into a success
                $resp = sprintf("250 2.5.0 Ok %s, DSN was sent (%s)",
                                $recip_quoted, $resp);
              } elsif ($bounced) {  # fake bounce - bounce was suppressed
                $resp = sprintf("250 2.5.0 Ok %s, DSN suppressed (%s)",
                                $recip_quoted, $resp);
              } elsif ($resp=~/^5/ && $r->recip_destiny != D_REJECT) {
                # just in case, if the bounce suppression scheme did not work
                $resp = sprintf("250 2.5.0 Ok %s, DSN suppressed_2 (%s)",
                                $recip_quoted, $resp);
              }
              do_log(3, 'LMTP response for %s: "%s"', $recip_quoted, $resp);
              $self->smtp_resp(0, $resp);
            }
          }
          $self->smtp_resp_flush;  # optional, but nice to report timing right
          section_time('SMTP response');
        };  # end all OK
        $self->{tempdir}->clean;
        my $msg_size = $msginfo->msg_size;
        my $sa_rusage = $msginfo->supplementary_info('RUSAGE-SA');
        $sender_unq = $sender_quo = undef; @recips = (); $got_rcpt = 0;
        undef $max_recip_size_limit; undef $msginfo;  # forget previous
        $final_oversized_destiny_all_pass = 1;
        %xforward_args = ();
        section_time('dump_captured_log')  if log_capture_enabled();
        dump_captured_log(1, c('enable_log_capture_dump'));
        %current_policy_bank = %baseline_policy_bank;  # restore bank settings
        # report elapsed times by section for each transaction
        # (the time for a QUIT remains unaccounted for)
        if (ll(2)) {
          my $am_rusage_report = Amavis::Timing::rusage_report();
          my $am_timing_report = Amavis::Timing::report();
          if ($sa_rusage && @$sa_rusage) {
            local $1; my $sa_cpu_sum = 0; $sa_cpu_sum += $_ for @$sa_rusage;
            $am_timing_report =~  # ugly hack
              s{\bcpu ([0-9.]+) ms\]}
               {sprintf("cpu %s ms, AM-cpu %.0f ms, SA-cpu %.0f ms]",
                        $1, $1 - $sa_cpu_sum*1000, $sa_cpu_sum*1000) }se;
          }
          do_log(2,"size: %d, %s", $msg_size, $am_timing_report);
          do_log(2,"size: %d, RUSAGE %s", $msg_size, $am_rusage_report)
            if defined $am_rusage_report;
        }
        Amavis::Timing::init(); snmp_counters_init();
        $Amavis::last_task_completed_at = Time::HiRes::time;
        last;
      };  # DATA

      /^(?:EXPN|TURN|ETRN|SEND|SOML|SAML)\z/ && do {
        $self->smtp_resp(1,"502 5.5.1 Error: command $_ not implemented",
                           0,$cmd);
        last;
      };
      # catchall (unknown commands):  #flush!
      $self->smtp_resp(1,"500 5.5.2 Error: command $_ not recognized", 1,$cmd);
    };  # end of 'switch' block
    if ($terminating || defined $aborting) {  # exit SMTP-session loop
      $voluntary_exit = 1; last;
    }

    # don't bother, just flush any responses regardless of pending input;
    # this also keeps us on the safe side when a Postfix pre-queue setup
    # turns HELO into EHLO sessions and smtpd_proxy_options=speed_adjust
    # is not in use
    $self->smtp_resp_flush;
#
#   if ($self->{smtp_outbuf} && @{$self->{smtp_outbuf}} &&
#       $self->{pipelining}) {
#     # RFC 2920 requires a flush whenever a local TCP input buffer is emptied
#     my $fd_sock = fileno($sock);
#     my $rout; my $rin = ''; vec($rin,$fd_sock,1) = 1;
#     my($nfound, $timeleft) = select($rout=$rin, undef, undef, 0);
#     if (defined $nfound && $nfound > 0 && vec($rout, $fd_sock, 1)) {
#       # input is available, do not bother flushing output yet
#       do_log(2,"pipelining in effect, input available, flush delayed");
#     } else {
#       $self->smtp_resp_flush;
#     }
#   }

    $0 = sprintf("%s (ch%d-%s-idle)",
                c('myprogram_name'), $Amavis::child_invocation_count, am_id());
    Amavis::Timing::go_idle(6);
  } # end of loop
  my($errn,$errs);
  if (!$voluntary_exit) {
    $eof = 1;
    if (!defined($_)) {
      $errn = 0+$!;
      $errs = !$self->{ssl_active} ? "$!" : $sock->errstr.", $!";
    }
  }
  # come here when: QUIT is received, eof or err on socket, or we need to abort
  $0 = sprintf("%s (ch%d)",
               c('myprogram_name'), $Amavis::child_invocation_count);
  alarm(0); do_log(4,"SMTP session over, timer stopped");
  Amavis::Timing::go_busy(7);
  # flush just in case, session might have been disconnected
  eval {
    $self->smtp_resp_flush;  1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    do_log(1, "flush failed: %s", $eval_stat);
  };
  my $msg =
    defined $aborting && !$eof ? "ABORTING the session: $aborting" :
    defined $aborting ? $aborting :
    !$terminating ? "client broke the connection without a QUIT ($errs)" : '';
  if ($msg eq '') {
    # ok
  } elsif ($aborting) {
    do_log(-1, "%s: NOTICE: %s", $self->{proto},$msg);
  } else {
    do_log( 3, "%s: notice: %s", $self->{proto},$msg);
  }
  if (defined $aborting && !$eof)
    { $self->smtp_resp(1,"421 4.3.2 Service shutting down, ".$aborting) }
  $self->{session_closed_normally} = 1;
  # Net::Server closes connection after child_finish_hook
}

# sends an SMTP response consisting of a 3-digit code and an optional message;
# slow down evil clients by delaying response on permanent errors
#
sub smtp_resp($$$;$$) {
  my($self, $flush,$resp, $penalize,$line) = @_;
  if ($penalize) {  # PENALIZE syntax errors?
    do_log(0, "%s: %s; smtp_resp: %s", $self->{proto},$resp,$line);
#   sleep 1;
#   section_time('SMTP penalty wait');
  }
  push(@{$self->{smtp_outbuf}}, @{wrap_smtp_resp(sanitize_str($resp,1))});
  $self->smtp_resp_flush   if $flush || !$self->{pipelining} ||
                              @{$self->{smtp_outbuf}} > 200;
}

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

1;

__DATA__
#
package Amavis::In::Courier;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

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

1;

__DATA__
#
package Amavis::Out::SMTP::Protocol;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform);
  import Amavis::Util qw(ll do_log min max minmax);
}

use Errno qw(EIO EINTR EAGAIN ECONNRESET);
use Encode ();
use Time::HiRes ();

sub init {
  my $self = $_[0];
  delete $self->{domain};  delete $self->{supports};
  $self->{pipelining} = 0;
}

sub new {
  my($class,$socket_specs,%arg) = @_;
  my $self = bless {}, $class;
  $self->{at_line_boundary} = 1;
  $self->{dotstuffing}  = 1;  # defaults to on
  $self->{dotstuffing}  = 0 if defined $arg{DotStuffing} && !$arg{DotStuffing};
  $self->{strip_cr}     = 1;  # sanitizing bare CR enabled by default
  $self->{strip_cr}     = 0 if defined $arg{StripCR} && !$arg{StripCR};
  $self->{sanitize_nul} = 1;  # sanitizing NUL bytes enabled by default
  $self->{sanitize_nul} = 0 if defined $arg{SanitizeNUL} && !$arg{SanitizeNUL};
  $self->{null_cnt} = 0;
  $self->{io} = Amavis::IO::RW->new($socket_specs, Eol => "\015\012", %arg);
  $self->init;
  $self;
}

sub close {
  my $self = $_[0];
  $self->{io}->close;
}

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  eval { $self->close } or 1;  # ignore failure, make perlcritic happy
}

sub ehlo_response_parse {
  my($self,$smtp_resp) = @_;
  delete $self->{domain};  delete $self->{supports};
  my(@ehlo_lines) = split(/\n/,$smtp_resp,-1);
  my $bad; my $first = 1; local($1,$2);
  for my $el (@ehlo_lines) {
    if ($first) {
      if ($el =~ /^(\d{3})(?:[ \t]+(.*))?\z/s) { $self->{domain} = $2 }
      elsif (!defined($bad)) { $bad = $el }
      $first = 0;
    } elsif ($el =~ /^([A-Z0-9][A-Z0-9-]*)(?:[ =](.*))?\z/si) {
      $self->{supports}{uc($1)} = defined $2 ? $2 : '';
    } elsif ($el =~ /^[ \t]*\z/s) {
      # don't bother (e.g. smtp-sink)
    } elsif (!defined($bad)) {
      $bad = $el;
    }
  }
  $self->{pipelining} = defined $self->{supports}{'PIPELINING'} ? 1 : 0;
  do_log(0, "Bad EHLO kw %s ignored in %s, socket %s",
            $bad, $smtp_resp, $self->socketname)  if defined $bad;
  1;
}

sub domain
  { my $self = $_[0]; $self->{domain} }

sub supports
  { my($self,$keyword) = @_; $self->{supports}{uc($keyword)} }

*print = \&datasend;  # alias name for datasend
sub datasend {
  my $self = shift;
  my $buff = @_ == 1 ? $_[0] : join('',@_);
  do_log(-1,"WARN: Unicode string passed to datasend: %s", $buff)
    if utf8::is_utf8($buff);  # always false on tainted, Perl 5.8 bug #32687
# ll(5) && do_log(5, 'smtp print %d bytes>', length($buff));
  $buff =~ tr/\015//d  if $self->{strip_cr};  # sanitize bare CR if necessary
  if ($self->{sanitize_nul}) {
    my $cnt = $buff =~ tr/\x00//;  # quick triage
    if ($cnt) {
      # this will break DKIM signatures, but IMAP (cyrus) hates NULs in mail
      $self->{null_cnt} += $cnt;
      $buff =~ s{\x00}{\xC0\x80}gs;  # turn to "Modified UTF-8" encoding of NUL
    }
  }
  # CR/LF are never split across a buffer boundary
  $buff =~ s{\n}{\015\012}gs;  # quite fast, but still a bottleneck
  if ($self->{dotstuffing}) {
    $buff =~ s{\015\012\.}{\015\012..}gs;  # dot stuffing
    $self->{io}->print('.')  if substr($buff,0,1) eq '.' &&
                             $self->{at_line_boundary};
  }
  $self->{io}->print($buff);
  $self->{at_line_boundary} = $self->{io}->at_line_boundary;
  $self->{io}->out_buff_large ? $self->flush : 1;
}

sub socketname
  { my $self = shift; $self->{io}->socketname(@_) }

sub protocol
  { my $self = shift; $self->{io}->protocol(@_) }

sub timeout
  { my $self = shift; $self->{io}->timeout(@_) }

sub ssl_active
  { my $self = shift; $self->{io}->ssl_active(@_) }

sub ssl_upgrade
  { my $self = shift; $self->{io}->ssl_upgrade(@_) }

sub last_io_event_timestamp
  { my $self = shift; $self->{io}->last_io_event_timestamp(@_) }

sub last_io_event_tx_timestamp
  { my $self = shift; $self->{io}->last_io_event_tx_timestamp(@_) }

sub eof
  { my $self = shift; $self->{io}->eof(@_) }

sub flush
  { my $self = shift; $self->{io}->flush(@_) }

sub dataend {
  my $self = $_[0];
  if (!$self->{at_line_boundary}) {
    $self->datasend("\n");
  }
  if ($self->{dotstuffing}) {
    $self->{dotstuffing} = 0;
    $self->datasend(".\n");
    $self->{dotstuffing} = 1;
  }
  if ($self->{null_cnt}) {
    do_log(0, 'smtp forwarding: SANITIZED %d NULL byte(s)', $self->{null_cnt});
    $self->{null_cnt} = 0;
  }
  $self->{io}->out_buff_large ? $self->flush : 1;
}

sub command {
  my($self,$command,@args) = @_;
  my $line = $command =~ /:\z/ ? $command.join(' ',@args)
                               : join(' ',$command,@args);
  ll(3) && do_log(3, 'smtp cmd> %s', $line);
  $self->datasend($line."\n"); $self->{at_line_boundary} = 1;
  # RFC 2920: commands that can appear anywhere in a pipelined command group
  #   RSET, MAIL FROM, SEND FROM, SOML FROM, SAML FROM, RCPT TO, (data)
  if (!$self->{pipelining} || $self->{io}->out_buff_large ||
      $command !~ /^(?:RSET|MAIL|SEND|SOML|SAML|RCPT)\b/is) {
    return $self->flush;
  }
  1;
}

sub smtp_response {
  my $self = $_[0];
  my $resp = ''; my($line,$code,$enh); my $first = 1;
  for (;;) {
    $line = $self->{io}->get_response_line;
    last  if !defined $line;  # eof, error, timeout
    my $line_complete = $line =~ s/\015\012\z//s;
    $line .= ' INCOMPLETE'  if !$line_complete;
    my $more; local($1,$2,$3);
    $line =~ s/^(\d{3}) (-|\ |\z)
                (?: ([245] \. \d{1,3} \. \d{1,3}) (\ |\z) )?//xs;
    if ($first) { $code = $1; $enh = $3; $first = 0 } else { $resp .= "\n" }
    $resp .= $line; $more = $2 eq '-';
    last  if !$more || !$line_complete;
  }
  !defined $code ? undef : $code . (defined $enh ? " $enh" : '') . ' '. $resp;
}

sub helo { my $self = shift; $self->init; $self->command("HELO",@_) }
sub ehlo { my $self = shift; $self->init; $self->command("EHLO",@_) }
sub lhlo { my $self = shift; $self->init; $self->command("LHLO",@_) }
sub noop { my $self = shift; $self->command("NOOP",@_) }
sub rset { my $self = shift; $self->command("RSET",@_) }
sub auth { my $self = shift; $self->command("AUTH",@_) }
sub data { my $self = shift; $self->command("DATA",@_) }
sub quit { my $self = shift; $self->command("QUIT",@_) }

sub mail {
  my($self,$reverse_path,%params) = @_;
  my(@mail_parameters) =
    map { my $v = $params{$_}; defined($v) ? "$_=$v" : "$_" } (keys %params);
  $self->command("MAIL FROM:", $reverse_path, @mail_parameters);
}

sub recipient {
  my($self,$forward_path,%params) = @_;
  my(@rcpt_parameters) =
    map { my $v = $params{$_}; defined($v) ? "$_=$v" : "$_" } (keys %params);
  $self->command("RCPT TO:", $forward_path, @rcpt_parameters);
}

1;

package Amavis::Out::SMTP::Session;

# provides a mechanism for SMTP session caching

use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&rundown_stale_sessions);
  import Amavis::Conf qw(:platform c cr ca $smtp_connection_cache_enable
                         %smtp_tls_client_options);
  import Amavis::Util qw(min max minmax ll do_log snmp_count idn_to_ascii);
}
use subs @EXPORT_OK;
use vars qw(%sessions_cache);

use Time::HiRes qw(time);

sub new {
  my($class, $socket_specs, $deadline,
     $wildcard_implied_host, $wildcard_implied_port) = @_;
  my $self; my $cache_key; my $found_cached = 0;
  for my $proto_sockname (ref $socket_specs ? @$socket_specs : $socket_specs) {
    $cache_key = $proto_sockname;
    local($1,$2,$3,$4);
    if ($proto_sockname =~   # deal with dynamic destinations (wildcards)
        /^([a-z][a-z0-9.+-]*) : (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*)/xsi) {
      my $peeraddress = defined $2 ? $2 : $3;  my $peerport = $4;
      $peeraddress = $wildcard_implied_host  if $peeraddress eq '*';
      $peerport    = $wildcard_implied_port  if $peerport    eq '*';
      $cache_key = sprintf("%s:[%s]:%s", $1, $peeraddress, $peerport);
    }
    if (exists $sessions_cache{$cache_key}) { $found_cached = 1; last }
  }
  if ($found_cached) {
    $self = $sessions_cache{$cache_key};
    $self->{deadline} = $deadline;
    do_log(3, "smtp session reuse (%s), %d transactions so far",
              $cache_key, $self->{transaction_count});
  } else {
    do_log(3, "smtp session: setting up a new session");
    $cache_key = undef;
    $self = bless {
      socket_specs => $socket_specs,
      socketname => undef, protocol => undef, smtp_handle => undef,
      deadline => $deadline, timeout => undef, in_xactn => 0,
      transaction_count => 0, state => 'down', established_at_time => undef,
      wildcard_implied_host => $wildcard_implied_host,
      wildcard_implied_port => $wildcard_implied_port,
    }, $class;
  }
  $self->establish_or_refresh;
  if (!defined $cache_key) {  # newly established session
    $cache_key = sprintf("%s:%s", $self->protocol, $self->socketname);
    $sessions_cache{$cache_key} = $self;
  }
  $self;
}

sub smtp_handle
  { @_<2 ? $_[0]->{handle}     : ($_[0]->{handle} = $_[1]) }
sub socketname
  { @_<2 ? shift->{socketname} : ($_[0]->{socketname} = $_[1]) }
sub protocol
  { @_<2 ? shift->{protocol}   : ($_[0]->{protocol} = $_[1]) }
sub session_state
  { @_<2 ? shift->{state}      : ($_[0]->{state} = $_[1]) }
sub in_smtp_transaction
  { @_<2 ? shift->{in_xactn}   : ($_[0]->{in_xactn} = $_[1]) }
sub established_at_time
  { @_<2 ? shift->{established_at_time} : ($_[0]->{established_at_time}=$_[1])}

sub transaction_begins {
  my $self = $_[0];
  !$self->in_smtp_transaction
    or die "smtp session: transaction_begins, but already active";
  $self->in_smtp_transaction(1);
}

sub transaction_begins_unconfirmed {
  my $self = $_[0];
  snmp_count('OutConnTransact'); $self->{transaction_count}++;
  !$self->in_smtp_transaction
    or die "smtp session: transaction_begins_unconfirmed, but already active";
  $self->in_smtp_transaction(undef);
}

sub transaction_ends {
  my $self = $_[0];
  $self->in_smtp_transaction(0);
}

sub transaction_ends_unconfirmed {
  my $self = $_[0];
  # if already 0 then keep it, otherwise undefine
  $self->in_smtp_transaction(undef)  if $self->in_smtp_transaction;
}

sub timeout {
  my $self = shift;
  if (@_) {
    my $timeout = shift;
    $self->{timeout} = $timeout;
    $self->{handle}->timeout($timeout)  if defined $self->{handle};
  # do_log(5, "smtp session, timeout set to %s", $timeout);
  }
  $self->{timeout};
}

sub supports {
  my($self,$keyword) = @_;
  $self->{handle} ? $self->{handle}->supports($keyword) : undef;
}

sub smtp_response {
  my $self = $_[0];
  $self->{handle} ? $self->{handle}->smtp_response : undef;
}

sub quit {
  my $self = $_[0];
  my $smtp_handle = $self->smtp_handle;
  if (defined $smtp_handle) {
    $self->session_state('quitsent');
    snmp_count('OutConnQuit');
    $smtp_handle->quit;  #flush!   QUIT
  }
}

sub close {
  my($self,$keep_connected) = @_;
  my $msg;  my $smtp_handle = $self->smtp_handle;
  if (defined($smtp_handle) && $smtp_handle->eof) {
    $msg = 'already disconnected'; $keep_connected = 0;
  } else {
    $msg = $keep_connected ? 'keeping connection' : 'disconnecting';
  }
  do_log(3, "Amavis::Out::SMTP::Session close, %s", $msg);
  if (!$keep_connected) {
    if (defined $smtp_handle) {
      $smtp_handle->close
        or do_log(1, "Error closing Amavis::Out::SMTP::Protocol obj");
      $self->in_smtp_transaction(0); $self->established_at_time(undef);
      $self->smtp_handle(undef); $self->session_state('down');
    }
    if (defined $self->socketname) {
      my $cache_key = sprintf("%s:%s", $self->protocol, $self->socketname);
      delete $sessions_cache{$cache_key} if exists $sessions_cache{$cache_key};
    }
  }
  1;
}

sub rundown_stale_sessions($) {
  my $close_all = $_[0];
  my $num_sessions_closed = 0;
  for my $cache_key (keys %sessions_cache) {
    my $smtp_session = $sessions_cache{$cache_key};
    my $smtp_handle = $smtp_session->smtp_handle;
    my $established_at_time = $smtp_session->established_at_time;
    my $last_event_time;
    $last_event_time = $smtp_handle->last_io_event_timestamp  if $smtp_handle;
    my $now = Time::HiRes::time;
    if ($close_all || !$smtp_connection_cache_enable ||
        !defined($last_event_time)     || $now - $last_event_time     >= 30 ||
        !defined($established_at_time) || $now - $established_at_time >= 60) {
      ll(3) && do_log(3,"smtp session rundown%s%s%s, %s, state %s",
                        $close_all ? ' all sessions'
                        : $smtp_connection_cache_enable ? ' stale sessions'
                        : ', cache off',
                        !defined($last_event_time) ? ''
                          : sprintf(", idle %.1f s", $now - $last_event_time),
                        !defined($established_at_time) ? ''
                          : sprintf(", since %.1f s ago",
                                    $now - $established_at_time),
                        $cache_key, $smtp_session->session_state);
      if ($smtp_session->session_state ne 'down' &&
          $smtp_session->session_state ne 'quitsent' &&
          (!defined($last_event_time) || $now - $last_event_time <= 55)) {
        do_log(3,"smtp session rundown, sending QUIT");
        eval { $smtp_session->quit } or 1;  #flush!   QUIT  (ignoring failures)
      }
      if ($smtp_session->session_state eq 'quitsent') {  # collect response
        $smtp_session->timeout(5);
        my $smtp_resp = eval { $smtp_session->smtp_response };
        if (!defined $smtp_resp) {
          do_log(3,"No SMTP resp. to QUIT");
        } elsif ($smtp_resp eq '') {
          do_log(3,"Empty SMTP resp. to QUIT");
        } elsif ($smtp_resp !~ /^2/) {
          do_log(3,"Negative SMTP resp. to QUIT: %s", $smtp_resp);
        } else {  # success, $smtp_resp =~ /^2/
          do_log(3,"smtp resp to QUIT: %s", $smtp_resp);
        }
      }
      if ($smtp_session->session_state ne 'down') {
        do_log(3,"smtp session rundown, closing session %s", $cache_key);
        $smtp_session->close(0)
          or do_log(-2, "Error closing smtp session %s", $cache_key);
        $num_sessions_closed++;
      }
    }
  }
  $num_sessions_closed;
}

sub establish_or_refresh {
  my $self = $_[0];
  # Timeout should be more than MTA normally takes to check DNS and RBL,
  # which may take a minute or more in case of unreachable DNS server.
  # Specifying shorter timeout will cause alarm to terminate the wait
  # for SMTP status line prematurely, resulting in status code 000.
  # RFC 5321 (ex RFC 2821) section 4.5.3.2 requires timeout to be
  # at least 5 minutes
  my $smtp_connect_timeout  =  35;  # seconds
  my $smtp_helo_timeout     = 300;
  my $smtp_starttls_timeout = 300;
  my $smtp_handle = $self->smtp_handle;
  my $smtp_resp; my $last_event_time;
  $last_event_time = $smtp_handle->last_io_event_timestamp  if $smtp_handle;
  my $now = Time::HiRes::time;
  do_log(5,"establish_or_refresh, state: %s", $self->session_state);
  die "panic, still in SMTP transaction"  if $self->in_smtp_transaction;
  if (defined($smtp_handle) &&
      $self->session_state ne 'down' && $self->session_state ne 'quitsent') {
    # if session has been idling for some time, check with a low-cost NOOP
    # whether the session is still alive - reconnecting at this time is cheap;
    # note that NOOP is non-pipelinable, MTA must respond immediately
    if (defined($last_event_time) && $now - $last_event_time <= 18) {
      snmp_count('OutConnReuseRecent');
      do_log(3,"smtp session most likely still valid (short idle %.1f s)",
                $now - $last_event_time);
    } else {  # Postfix default smtpd idle timeout is 60 s
      eval {
        $self->timeout(15);
        $smtp_handle->noop;  #flush!
        $smtp_resp = $self->smtp_response;  # fetch response to NOOP
        do_log(3,"smtp resp to NOOP (idle %.1f s): %s",
                 $now - $last_event_time, $smtp_resp);
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        do_log(3,"smtp NOOP failed (idle %.1f s): %s",
                 $now - $last_event_time, $eval_stat);
        $smtp_resp = '';
      };
      if ($smtp_resp =~ /^2/) {
        snmp_count('OutConnReuseRefreshed');
      } else {
        snmp_count('OutConnReuseFail');
        $self->close(0) or do_log(-1, "Error closing smtp session");
      }
    }
  }
  if ($self->session_state eq 'down' || $self->session_state eq 'quitsent') {
    if (defined $smtp_handle) {
      $smtp_handle->close
        or do_log(-2, "Error closing Amavis::Out::SMTP::Protocol obj");
      undef $smtp_handle;
    }
    my $localaddr = c('local_client_bind_address');  # IP assigned to socket
    snmp_count('OutConnNew');
    $smtp_handle = Amavis::Out::SMTP::Protocol->new(
      $self->{socket_specs}, LocalAddr => $localaddr, Timeout => 35,
      WildcardImpliedHost => $self->{wildcard_implied_host},
      WildcardImpliedPort => $self->{wildcard_implied_port});
    $self->smtp_handle($smtp_handle);
    defined $smtp_handle  # don't change die text, it is referred to elsewhere
      or die sprintf("Can't connect to %s",
                     !ref $self->{socket_specs} ? $self->{socket_specs}
                                     : join(", ",@$self->{socket_specs}) );
    $self->socketname($smtp_handle->socketname);
    $self->protocol($smtp_handle->protocol);
    $self->session_state('connected');
    $self->established_at_time(time);
    $self->timeout($smtp_connect_timeout);
    $smtp_resp = $self->smtp_response;  # fetch greeting
    if (!defined $smtp_resp || $smtp_resp eq '') {
      die sprintf("%s greeting, dt: %.3f s\n",
                  !defined $smtp_resp ? 'No' : 'Empty',
                  time - $smtp_handle->last_io_event_tx_timestamp);
    } elsif ($smtp_resp !~ /^2/) {
      die "Negative greeting: $smtp_resp\n";
    } else {  # success, $smtp_resp =~ /^2/
      do_log(3,"smtp greeting: %s, dt: %.1f ms", $smtp_resp,
               1000*(time-$smtp_handle->last_io_event_tx_timestamp));
    }
  }
  if ($self->session_state eq 'connected') {
    my $lmtp = lc($self->protocol) eq 'lmtp' ? 1 : 0;  # RFC 2033
    my $deadline = $self->{deadline};
    my $tls_security_level = c('tls_security_level_out');
    $tls_security_level = 0  if !defined($tls_security_level) ||
                                lc($tls_security_level) eq 'none';
    my $myheloname = c('localhost_name');  # host name used in EHLO/HELO/LHLO
    $myheloname = 'localhost'  if $myheloname eq '';
    $myheloname = idn_to_ascii($myheloname);
    for (1..2) {
      # send EHLO/LHLO/HELO
      $self->timeout(max(60,min($smtp_helo_timeout,
                                $deadline - time)));
      if ($lmtp) { $smtp_handle->lhlo($myheloname) }  #flush!
      else       { $smtp_handle->ehlo($myheloname) }  #flush!
      $smtp_resp = $self->smtp_response;  # fetch response to EHLO/LHLO
      if (!defined $smtp_resp || $smtp_resp eq '') {
        die sprintf("%s response to %s, dt: %.3f s\n",
                    !defined $smtp_resp ? 'No' : 'Empty',
                    $lmtp ? 'LHLO' : 'EHLO',
                    time - $smtp_handle->last_io_event_tx_timestamp);
      } elsif ($smtp_resp =~ /^2/) {  # success
        do_log(3,"smtp resp to %s: %s", $lmtp?'LHLO':'EHLO', $smtp_resp);
      } elsif ($lmtp) {  # failure, no fallback possible
        die "Negative SMTP resp. to LHLO: $smtp_resp\n";
      } else {  # failure, SMTP fallback to HELO
        do_log(3,"Negative SMTP resp. to EHLO, will try HELO: %s", $smtp_resp);
        $smtp_handle->helo($myheloname);  #flush!
        $smtp_resp = $self->smtp_response;  # fetch response to HELO
        if (!defined $smtp_resp || $smtp_resp eq '') {
          die sprintf("%s response to HELO, dt: %.3f s\n",
                      !defined $smtp_resp ? 'No' : 'Empty',
                      time - $smtp_handle->last_io_event_tx_timestamp);
        } elsif ($smtp_resp !~ /^2/) {
          die "Negative response to HELO: $smtp_resp\n";
        } else {  # success, $smtp_resp =~ /^2/
          do_log(3,"smtp resp to HELO: %s", $smtp_resp);
        }
      }
      $self->session_state('ehlo');
      $smtp_handle->ehlo_response_parse($smtp_resp);
      my $tls_capable = defined $self->supports('STARTTLS');  # RFC 3207
      ll(5) && do_log(5, "tls active=%d, capable=%s, sec_level=%s",
                 $smtp_handle->ssl_active, $tls_capable, $tls_security_level);
      if ($smtp_handle->ssl_active) {
        last;  # done
      } elsif (!$tls_capable &&
               $tls_security_level && lc($tls_security_level) ne 'may') {
        die "MTA does not offer STARTTLS, ".
            "but TLS is required: \"$tls_security_level\"";
      } elsif (!$tls_capable || !$tls_security_level) {
        last;  # not offered and not mandated
      } else {
        $self->timeout(max(60,min($smtp_starttls_timeout,
                                  $deadline - time)));
        $smtp_handle->command('STARTTLS');  #flush!
        $smtp_resp = $self->smtp_response;  # fetch response to STARTTLS
        $smtp_resp = ''  if !defined $smtp_resp;
        do_log(3,"smtp resp to STARTTLS: %s", $smtp_resp);
        if ($smtp_resp !~ /^2/) {
          (!$tls_security_level || lc($tls_security_level) eq 'may')
            or die "Negative SMTP resp. to STARTTLS: $smtp_resp\n";
        } else {
          $smtp_handle->ssl_upgrade(%smtp_tls_client_options)
            or die "Error upgrading socket to SSL";
          $self->session_state('connected');
        }
      }
    }
  }
  $self;
}

1;

package Amavis::Out::SMTP;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT = qw(&mail_via_smtp);
  import Amavis::Conf qw(:platform c cr ca $smtp_connection_cache_enable);
  import Amavis::Util qw(untaint min max minmax ll do_log snmp_count
                         xtext_encode xtext_decode orcpt_encode orcpt_decode
                         idn_to_ascii mail_addr_idn_to_ascii
                         prolong_timer get_deadline
                         collect_equal_delivery_recips);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Out::EditHeader;
}

use Time::HiRes qw(time);
use Encode ();
# use Authen::SASL;

# simple OO wrapper around Mail::DKIM::Signer to provide a method 'print'
# and to convert \n to CRLF
#
sub new_dkim_wrapper {
  my($class, $handle,$strip_cr) = @_;
  bless { handle => $handle, strip_cr => $strip_cr }, $class;
}

sub close { 1 }

sub print {
  my $self = shift;
  my $buff = @_ == 1 ? $_[0] : join('',@_);
  do_log(-1,"WARN: Unicode string passed to Amavis::Out::SMTP::print : %s",
      $buff)  if utf8::is_utf8($buff);  # false on tainted, Perl 5.8 bug #32687
  $buff =~ tr/\015//d  if $self->{strip_cr};  # sanitize bare CR
  $buff =~ s{\n}{\015\012}gs;
  $self->{handle}->PRINT($buff);
}

# Add a log_id to the SMTP status text, insert a fabricated RFC 3463 enhanced
# status code if missing in an MTA response, see also RFC 5248
#
sub enhance_smtp_response($$$$$) {
  my($smtp_resp,$am_id,$mta_id,$dflt_enhcode,$cmd_name) = @_;
  local($1,$2,$3,$4); my $resp_msg;
  my($resp_code,$resp_more,$resp_enhcode) = ('451', ' ', '4.5.0');
  if (!defined($smtp_resp) || $smtp_resp eq '') {
    $smtp_resp = sprintf('No resp. to %s', $cmd_name);
  } elsif ($smtp_resp !~ /^[245]\d{2}/) {
    $smtp_resp = sprintf('Bad resp. to %s: %s', $cmd_name,$smtp_resp);
  } elsif ($smtp_resp =~ /^ (\d{3}) (\ |-|\z) [ \t]*
                            ([245] \. \d{1,3} \. \d{1,3})?
                            \s* (.*) \z/xs) {
    ($resp_code, $resp_more, $resp_enhcode, $resp_msg) = ($1, $2, $3, $4);
    if (!defined $resp_enhcode && $resp_code =~ /^[245]/) {
      my $c = substr($resp_code,0,1);
      $resp_enhcode = $dflt_enhcode; $resp_enhcode =~ s/^\d*/$c/;
    }
  }
  sprintf("%s%s%s from MTA(%s): %s",
          $resp_code, $resp_more, $resp_enhcode, $mta_id, $smtp_resp);
}

# Send mail using SMTP - single transaction
# (e.g. forwarding original mail or sending notification)
# May throw exception (die) if temporary failure (4xx) or other problem
#
# Multiple transactions may be necessary, either due to different delivery
# methods (IP address, port, SMTP vs. LMTP) or due to '452 Too many recipients'
#
sub mail_via_smtp(@) {
  my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;
  #
  # RFC 2033: LMTP protocol MUST NOT be used on the TCP port 25
  #
  # $initial_submission can be treated as a boolean, but for more detailed
  # needs it can be any of:  false: 0
  #                       or true: 'Quar', 'Dsn', 'Notif', 'AV', 'Arf'
  my $which_section = 'fwd_init';
  my $id = $msginfo->parent_mail_id;
  $id = $msginfo->mail_id . (defined $id ? "($id)" : "");
  my $sender_smtp = $msginfo->sender_smtp;
  my $logmsg = sprintf("%s %s", $id, $initial_submission?'SEND':'FWD');
  my($per_recip_data_ref, $proto_sockname) =
    collect_equal_delivery_recips($msginfo, $filter, qr/^(?:smtp|lmtp):/i);
  if (!$per_recip_data_ref || !@$per_recip_data_ref) {
    do_log(5, "%s from %s, nothing to do", $logmsg, $sender_smtp);
    return 1;
  }
  my $proto_sockname_displ = !ref $proto_sockname ? $proto_sockname
                               : '(' . join(', ',@$proto_sockname) . ')';
  my(@per_recip_data) = @$per_recip_data_ref;  undef $per_recip_data_ref;
  ll(4) && do_log(4, "about to connect to %s, %s from %s -> %s",
                     $proto_sockname_displ, $logmsg, $sender_smtp,
                     join(',', qquote_rfc2821_local(
                                map($_->recip_final_addr, @per_recip_data)) ));
  my $am_id = $msginfo->log_id;
  my $dsn_envid = $msginfo->dsn_envid;
  my $dsn_ret = $msginfo->dsn_ret;
  my $smtputf8 = $msginfo->smtputf8;  # SMTPUTF8 requested
  my $smtputf8_capable;               # SMTPUTF8 offered by MTA, RFC 6531
  my($relayhost, $protocol, $lmtp, $mta_id, @snmp_vars);
  my($smtp_session, $smtp_handle, $smtp_resp, $smtp_response);
  my($any_valid_recips, $any_tempfail_recips, $pipelining,
     $any_valid_recips_and_data_sent, $recips_done_by_early_fail,
     $in_datasend_mode, $dsn_capable, $auth_capable) = (0) x 8;
  my $mimetransport8bit_capable = 0;  # RFC 6152
  my(%from_options);
  # RFC 5321 (ex RFC 2821), section 4.5.3.2. Timeouts
  my $smtp_connect_timeout   =  35;
  my $smtp_helo_timeout      = 300;
  my $smtp_starttls_timeout  = 300;
  my $smtp_xforward_timeout  = 300;
  my $smtp_mail_timeout      = 300;
  my $smtp_rcpt_timeout      = 300;
  my $smtp_data_init_timeout = 120;
  my $smtp_data_xfer_timeout = 180;
  my $smtp_data_done_timeout = 600;
  my $smtp_quit_timeout      =  10;  # 300
  my $smtp_rset_timeout      =  20;
  # can appear anywhere in a pipelined command group:
  #   RSET, MAIL FROM, SEND FROM, SOML FROM, SAML FROM, RCPT TO, data
  # can only appear as the last command in a pipelined group:  --> flush
  #   EHLO, DATA, VRFY, EXPN, TURN, QUIT, NOOP,
  #   AUTH(RFC 4954), STARTTLS(RFC 3207), and all unknown commands

  # needed to implement dynamic_destination: a '*' in place of a host or port
  my($wildcard_implied_host, $wildcard_implied_port);
  my $conn = $msginfo->conn_obj;
  if ($conn) {
    my $host = $conn->client_ip;
    $wildcard_implied_host = $host  if defined($host) && $host ne '';
    my $port = $conn->socket_port;
    $wildcard_implied_port = $port+1  if defined($port) && $port =~ /^\d+\z/;
  }
  my($remaining_time, $deadline) = get_deadline($which_section, 1, 0);
  alarm(0);  # stop the timer
  my $err;
  eval {
    $which_section = 'fwd-connect';
    $smtp_session = Amavis::Out::SMTP::Session->new($proto_sockname, $deadline,
                               $wildcard_implied_host, $wildcard_implied_port)
      or die "Can't establish an SMTP/LMTP session with $proto_sockname_displ";
    $smtp_handle = $smtp_session->smtp_handle;
    if ($smtp_handle) {
      $relayhost = $smtp_handle->socketname;
      $protocol = $smtp_handle->protocol;
      $lmtp = lc($protocol) eq 'lmtp' ? 1 : 0;  # RFC 2033
      $mta_id = sprintf("%s:%s", $protocol, $relayhost);
      @snmp_vars = !$initial_submission ?
        ('', 'Relay',  'Proto'.uc($protocol), 'Proto'.uc($protocol).'Relay')
      : ('', 'Submit', 'Proto'.uc($protocol), 'Proto'.uc($protocol).'Submit',
         'Submit'.$initial_submission);
      snmp_count('OutMsgs'.$_)  for @snmp_vars;
    }
    $dsn_capable = c('propagate_dsn_if_possible') &&
                   defined($smtp_session->supports('DSN'));         # RFC 3461
    $mimetransport8bit_capable =  # 8bit-MIMEtransport service extension
                   defined($smtp_session->supports('8BITMIME'));    # RFC 6152
    $smtputf8_capable =           # "Internationalized Email" service extension
                   $mimetransport8bit_capable &&
                   defined($smtp_session->supports('SMTPUTF8'));    # RFC 6531
    $pipelining =  defined($smtp_session->supports('PIPELINING'));  # RFC 2920
    do_log(3,"No announced PIPELINING support by MTA?")  if !$pipelining;
    ll(5) && do_log(5,"Remote host presents itself as: %s, handles %s",
                      $smtp_handle->domain,
                      join(', ', $dsn_capable ? 'DSN' : (),
                                 $pipelining  ? 'PIPELINING' : (),
                                 $mimetransport8bit_capable ? '8BITMIME' : (),
                                 $smtputf8_capable ? 'SMTPUTF8' : () ) );
    if ($lmtp && !$pipelining) {  # RFC 2033 requirements
      die "An LMTP server implementation MUST implement PIPELINING";
    }
    if ($lmtp && !defined($smtp_session->supports('ENHANCEDSTATUSCODES'))) {
      die "An LMTP server implementation MUST implement ENHANCEDSTATUSCODES";
    }

    if (!$smtputf8_capable || !$smtputf8) {
      # if SMTPUTF8 is not requested or if MTA is unable to handle
      # IDN with U-labels, and local part is all-ASCII, then we may
      # still get this delivered by converting a domain name
      # to ASCII-compatible encoding (ACE)
      if ($sender_smtp =~ /^ [\x00-\x7F]* \@ [^\@]* [^\x00-\x7F] [^\@]*\z/xs) {
        # localpart all-ASCII, domain is non-ASCII
        my $idn_ascii = mail_addr_idn_to_ascii($sender_smtp);
        do_log(2,'sender IDN encoded to ACE: %s -> %s',
                 $sender_smtp, $idn_ascii);
        $sender_smtp = $idn_ascii;
      }
      for my $r (@per_recip_data) {
        next  if $r->recip_done;
        my $rcpt_addr = $r->recip_final_addr;
        if ($rcpt_addr =~ /^ [\x00-\x7F]* \@ [^\@]* [^\x00-\x7F] [^\@]*\z/xs) {
          my $idn_ascii = mail_addr_idn_to_ascii($rcpt_addr);
          do_log(2,'recipient IDN encoded to ACE: %s -> %s',
                   $rcpt_addr, $idn_ascii);
          $rcpt_addr = $idn_ascii;
          $r->dsn_orcpt(join(';', orcpt_decode(';'.$r->recip_addr_smtp)))
            if !defined $r->dsn_orcpt;
          # N.B.: change recip_addr_modified(), not recip_final_addr() !
          $r->recip_addr_modified($rcpt_addr);
        }
      }
    }

    if ($smtputf8) {  # SMTPUTF8 handling was requested, RFC 6531
      #
      # RFC 6531 section 3.4: If the SMTPUTF8-aware SMTP client is aware
      # that neither the envelope nor the message being sent requires any
      # of the SMTPUTF8 extension capabilities, it SHOULD NOT supply the
      # SMTPUTF8 parameter with the MAIL command.
      #
      my($sender_8bit, $recips_8bit);
      $sender_8bit = 1  if $msginfo->sender_smtp =~ tr/\x00-\x7F//c;
      for my $r (@per_recip_data) {
        next  if $r->recip_done;
        $recips_8bit = 1  if $r->recip_final_addr =~ tr/\x00-\x7F//c;
      }

      if (!ll(5)) {
        # don't bother, just logging
      } elsif ($sender_8bit || $recips_8bit || $msginfo->header_8bit) {
        do_log(5,'SMTPUTF8 option requested and is needed, %s is non-ASCII',
                 join(' & ', $sender_8bit  ? 'sender' : (),
                             $recips_8bit  ? 'recip'  : (),
                             $msginfo->header_8bit ? 'header' : () ));
      } else {
        do_log(5,'SMTPUTF8 option requested but not needed');
      }

      if (!$smtputf8_capable) {
        # RFC 6531 sect 3.5: An SMTPUTF8-aware SMTP client MUST NOT send
        # an internationalized message to an SMTP server that does not
        # support SMTPUTF8.
        # 550 5.6.7 Non-ASCII addresses not permitted for that sender
        # 553 5.6.7 Non-ASCII addresses not permitted for that recipient
        # after DATA-dot:
        # 554 5.6.9 UTF-8 header message cannot be transmitted to one or more
        #   recipients, so the message must be rejected
        #
        if (!$sender_8bit && !$recips_8bit) {
          # mail addresses are all-ASCII, don't care for an 8bit header
          do_log(3,'SMTPUTF8 option requested but not offered, turning it off');
          $smtputf8 = 0;  # turn off if not needed
        }
      }
    }
    section_time($which_section);

    $which_section = 'fwd-xforward';
    my $cl_ip = $msginfo->client_addr;
    if (defined $cl_ip && $cl_ip ne '' &&
        defined($smtp_session->supports('XFORWARD'))) {
      $cl_ip = 'IPv6:'.$cl_ip  if $cl_ip =~ /:[0-9a-f]*:/i &&
                                  $cl_ip !~ /^IPv6:/i;
      my(%xfwd_supp_opt) = map((uc($_),1),
                               split(' ',$smtp_session->supports('XFORWARD')));
      my(@params) = map
        { my($n,$v) = @$_;
          # Postfix since version 20060610 uses xtext-encoded (RFC 3461)
          # strings in XCLIENT and XFORWARD attribute values, previous
          # versions expected plain text with neutered special characters;
          # see README_FILES/XFORWARD_README
          if (defined $v && $v ne '') {
            $v =~ s/[^\041-\176]/?/gs;  # isprint
            $v =~ s/[<>()\\";\@]/?/gs;  # other chars that are special in hdrs
                     # postfix/src/smtpd/smtpd.c NEUTER_CHARACTERS
            $v = xtext_encode($v);
            substr($v,255) = ''  if length($v) > 255;  # chop xtext, not nice
          }
          !defined $v || $v eq '' || !$xfwd_supp_opt{$n} ? () : ("$n=$v") }
        ( ['ADDR',$cl_ip],                ['NAME',$msginfo->client_name],
          ['PORT',$msginfo->client_port], ['PROTO',$msginfo->client_proto],
          ['HELO',$msginfo->client_helo], ['SOURCE',$msginfo->client_source],
          ['IDENT',$msginfo->queue_id] );
      $smtp_session->timeout(
        max(60,min($smtp_xforward_timeout,$deadline-time())));
      $smtp_handle->command('XFORWARD',@params);  #flush!
      $smtp_resp = $smtp_session->smtp_response;  # fetch response to XFORWARD
      if (!defined $smtp_resp || $smtp_resp eq '') {
        do_log(-1,"%s SMTP resp. to XFORWARD, dt: %.3f s",
                  !defined $smtp_resp ? 'No' : 'Empty',
                  time - $smtp_handle->last_io_event_tx_timestamp);
      } elsif ($smtp_resp !~ /^2/) {
        do_log(0,"Negative SMTP resp. to XFORWARD: %s", $smtp_resp);
      } else {  # success, $smtp_resp =~ /^2/
        do_log(3,"smtp resp to XFORWARD: %s", $smtp_resp);
      }
      section_time($which_section);
    }

    $which_section = 'fwd-auth';
    my $auth_user = $msginfo->auth_user;
    my $mechanisms = $smtp_session->supports('AUTH');
    if (!c('auth_required_out')) {
      do_log(3,"AUTH not needed, user='%s', MTA offers '%s'",
               $auth_user,$mechanisms);
    } elsif ($mechanisms eq '') {
      do_log(3,"INFO: MTA does not offer AUTH capability, user='%s'",
               $auth_user);
    } elsif (!defined $auth_user) {
      do_log(0,"INFO: AUTH needed for submission but AUTH data not available");
    } else {
      do_log(3,"INFO: authenticating %s, server supports AUTH %s",
               $auth_user,$mechanisms);
      $auth_capable = 1;
#     my $sasl = Authen::SASL->new(
#       'callback' => { 'user' => $auth_user, 'authname' => $auth_user,
#                       'pass' => $msginfo->auth_pass });
#     $smtp_handle->auth($sasl) or die "sending AUTH, user=$auth_user\n";#flush
      do_log(0,"Sorry, AUTH not supported in this version of amavisd!");
      section_time($which_section);
    }

    $which_section = 'fwd-pre-mail-from';
    $smtp_session->timeout(max(60,min($smtp_mail_timeout,$deadline-time())));
    my $fetched_mail_resp = 0;  my $fetched_rcpt_resp = 0;
    my $data_command_accepted = 0;
    if ($initial_submission && $dsn_capable && !defined($dsn_envid)) {
      # ENVID identifies transaction, not a message
      $dsn_envid = xtext_encode(sprintf("AM.%s.%s\@%s",
                     $msginfo->mail_id || $msginfo->log_id,
                     iso8601_utc_timestamp(time),
                     idn_to_ascii(c('myhostname')) ));
    }
    $from_options{'RET'} = $dsn_ret  if $dsn_capable && defined $dsn_ret;
    if ($dsn_capable && defined $dsn_envid) {
      # check for proper encoding (RFC 3461), just in case
      if ($dsn_envid =~ tr/ =\x00-\x1F//) {
        do_log(-1, "Prohibited character in ENVID: %s", $dsn_envid);
      } else {
        $from_options{'ENVID'} = $dsn_envid;
      }
    }

    my $submitter = $msginfo->auth_submitter;
    $from_options{'AUTH'} = xtext_encode($submitter)  # RFC 4954 (ex RFC 2554)
      if $auth_capable &&
         defined($submitter) && $submitter ne '' && $submitter ne '<>';

    if ($smtputf8 && $smtputf8_capable) {
      $from_options{'SMTPUTF8'} = undef;  # turn option *on*, no value
    }

    my $btype = $msginfo->body_type;
    if (defined $btype && $btype ne '') {
      $btype = uc $btype;
      if ($btype ne '7BIT' && $btype ne '8BITMIME') {
        do_log(-1,'requested BODY type %s is unknown/unsupported', $btype);
      } elsif ($mimetransport8bit_capable) {
        $from_options{'BODY'} = $btype;
      }
    }
    if (!$mimetransport8bit_capable &&
        defined $btype && $btype ne '' && uc $btype ne '7BIT') {
      do_log(-1,'requested BODY type is %s, but MTA does not announce '.
                '8bit-MIMEtransport capability', $btype);  # RFC 6152
      for my $r (@per_recip_data) {
        next  if $r->recip_done;
        $r->recip_smtp_response('550 5.6.3 Conversion to 7BIT required '.
                                'but not supported');
        $r->recip_remote_mta($relayhost); $r->recip_done(2);
      }
      $recips_done_by_early_fail = 1;
    } elsif ($smtputf8 &&
             !$smtputf8_capable && $sender_smtp =~ tr/\x00-\x7F//c) {
      do_log(1,'SMTPUTF8 option requested, not offered by MTA, '.
               'sender is non-ASCII: %s', $sender_smtp);
      for my $r (@per_recip_data) {
        next  if $r->recip_done;
        $r->recip_smtp_response('550 5.6.7 Non-ASCII addresses not permitted '.
                                'for sender');
        $r->recip_remote_mta($relayhost); $r->recip_done(2);
      }
      $recips_done_by_early_fail = 1;
    } else {
      $which_section = 'fwd-mail-from';
      $smtp_handle->mail($sender_smtp, %from_options);  # MAIL FROM
      # consider the transaction state unknown until we see a response
      $smtp_session->transaction_begins_unconfirmed; # also counts transactions
      if (!$pipelining) {
        $smtp_resp = $smtp_session->smtp_response;  $fetched_mail_resp = 1;
        if (!defined $smtp_resp || $smtp_resp eq '') {
          die sprintf("%s response to MAIL, dt: %.3f s\n",
                      !defined $smtp_resp ? 'No' : 'Empty',
                      time - $smtp_handle->last_io_event_tx_timestamp);
        } elsif ($smtp_resp =~ /^2/) {
          do_log(3, "smtp resp to MAIL: %s", $smtp_resp);
          $smtp_session->transaction_begins;  # transaction is active
        } else {  # failure
          do_log(1, "smtp resp to MAIL: %s", $smtp_resp);
          # transaction state unchanged, consider it unknown
          my $smtp_resp_ext = enhance_smtp_response($smtp_resp,$am_id,$mta_id,
                                                    '.1.0','MAIL FROM');
          for my $r (@per_recip_data) {
            next  if $r->recip_done;
            $r->recip_remote_mta($relayhost);
            $r->recip_remote_mta_smtp_response($smtp_resp);
            $r->recip_smtp_response($smtp_resp_ext); $r->recip_done(2);
          }
          $recips_done_by_early_fail = 1;
        }
        section_time($which_section);
      }
    }

    $which_section = 'fwd-rcpt-to';
    $smtp_session->timeout(max(60,min($smtp_rcpt_timeout,$deadline-time())));
    my($skipping_resp, @per_recip_data_rcpt_sent);
    for my $r (@per_recip_data) {  # send recipient addresses
      next  if $r->recip_done;
      if (defined $skipping_resp) {
        $r->recip_smtp_response($skipping_resp); $r->recip_done(2);
        next;
      }
      # prepare to send a RCPT TO command
      my $raddr = qquote_rfc2821_local($r->recip_final_addr);
      if ($smtputf8 && !$smtputf8_capable && $raddr =~ tr/\x00-\x7F//c) {
        do_log(1,'SMTPUTF8 option requested, not offered by MTA, '.
                 'recipient is non-ASCII: %s', $raddr);
        $r->recip_smtp_response('553 5.6.7 Non-ASCII addresses '.
                                'not permitted for recipient');
        $r->recip_remote_mta($relayhost); $r->recip_done(2);
      } elsif (!$dsn_capable) {
        $smtp_handle->recipient($raddr);  # a barebones RCPT TO command
        push(@per_recip_data_rcpt_sent, $r);  # remember which recips were sent
      } else {  # include dsn options with a RCPT TO command
        my(@dsn_notify);  # implies a default when the list is empty
        my $dn = $r->dsn_notify;
        @dsn_notify = @$dn  if $dn && $msginfo->sender ne '';  # if nondefault
        if (c('terminate_dsn_on_notify_success')) {
          # we want to handle option SUCCESS locally
          if (grep($_ eq 'SUCCESS', @dsn_notify)) {  # strip out SUCCESS
            @dsn_notify = grep($_ ne 'SUCCESS', @dsn_notify);
            @dsn_notify = ('NEVER')  if !@dsn_notify;
            do_log(3,"stripped out SUCCESS, result: NOTIFY=%s",
                     join(',',@dsn_notify));
          }
        }
        my(%rcpt_options);
        $rcpt_options{'NOTIFY'} =
          join(',', map(uc($_),@dsn_notify))  if @dsn_notify;
        my($addr_type, $addr) =
          orcpt_encode($r->dsn_orcpt, $smtputf8 && $smtputf8_capable, 1);
        $rcpt_options{'ORCPT'} = $addr_type.';'.$addr  if defined $addr;
        $smtp_handle->recipient($raddr, %rcpt_options);  # RCPT TO
        push(@per_recip_data_rcpt_sent, $r);  # remember which recips were sent
      }
      if (!$pipelining) {  # must fetch responses to RCPT TO right away
        $smtp_resp = $smtp_session->smtp_response;  $fetched_rcpt_resp = 1;
        if (defined $smtp_resp && $smtp_resp ne '') {
          $r->recip_remote_mta($relayhost);
          $r->recip_remote_mta_smtp_response($smtp_resp);
          my $smtp_resp_ext = enhance_smtp_response($smtp_resp,$am_id,$mta_id,
                                                    '.1.0','RCPT TO');
          $r->recip_smtp_response($smtp_resp_ext);  # preliminary response
        }
        if (!defined $smtp_resp || $smtp_resp eq '') {
          die sprintf("%s response to RCPT (%s), dt: %.3f s\n",
                      !defined $smtp_resp ? 'No' : 'Empty',  $raddr,
                      time - $smtp_handle->last_io_event_tx_timestamp);
        } elsif ($smtp_resp =~ /^2/) {
          do_log(3, "smtp resp to RCPT (%s): %s", $raddr,$smtp_resp);
          $any_valid_recips++;
        } else {  # failure
          do_log(1, "smtp resp to RCPT (%s): %s", $raddr,$smtp_resp);
          if ($smtp_resp =~ /^452/) {  # too many recipients - see RFC 5321
            do_log(-1, 'Only %d recips sent in one go: "%s"',
                       $any_valid_recips, $smtp_resp)
                       if !defined $skipping_resp;
            $skipping_resp = enhance_smtp_response($smtp_resp,$am_id,$mta_id,
                                                   '.5.3','RCPT TO');
          } elsif ($smtp_resp =~ /^4/) {
            $any_tempfail_recips++;
          }
          $r->recip_done(2);  # got a negative response to RCPT TO
        }
      }
    }
    section_time($which_section)  if !$pipelining;  # otherwise it just shows 0

    my $what_cmd;
    if (!@per_recip_data_rcpt_sent ||  # no recipients were sent
        $fetched_rcpt_resp && !$any_valid_recips) {  # no recipients accepted
      # it is known there are no valid recipients, don't go into DATA section
      do_log(0,"no valid recipients, skip data transfer");
      $smtp_session->timeout($smtp_rset_timeout);
      $what_cmd = 'RSET';  $smtp_handle->rset;  # send a RSET
      $smtp_session->transaction_ends_unconfirmed;
    } elsif ($fetched_rcpt_resp &&              # no pipelining
             $any_tempfail_recips && !$dsn_per_recip_capable) {
      # we must not proceed if mail did not came in as LMTP,
      # or we would generate mail duplicates on each delivery attempt
      do_log(-1,"mail_via_smtp: DATA skipped, tempfailed recips: %s",
                $any_tempfail_recips);
      $smtp_session->timeout($smtp_rset_timeout);
      $what_cmd = 'RSET';  $smtp_handle->rset;  # send a RSET
      $smtp_session->transaction_ends_unconfirmed;
    } else {  # pipelining, or we know we got a clearance to proceed
      $which_section = 'fwd-data-cmd';
      # pipelining in effect, or we have at least one valid recipient, go DATA
      $smtp_session->timeout(
        max(60,min($smtp_data_init_timeout,$deadline-time())));
      $smtp_handle->data;  #flush!  DATA
      $in_datasend_mode = 1;  # DATA command was sent (but not yet confirmed)
      if (!$fetched_mail_resp) {  # pipelining in effect, late response to MAIL
        $which_section = 'fwd-mail-pip';
        $smtp_session->timeout(
          max(60,min($smtp_mail_timeout,$deadline-time())));
        $smtp_resp = $smtp_session->smtp_response;  $fetched_mail_resp = 1;
        if (!defined $smtp_resp || $smtp_resp eq '') {
          die sprintf("%s response to MAIL (pip), dt: %.3f s\n",
                      !defined $smtp_resp ? 'No' : 'Empty',
                      time - $smtp_handle->last_io_event_tx_timestamp);
        } elsif ($smtp_resp =~ /^2/) {
          do_log(3, "smtp resp to MAIL (pip): %s", $smtp_resp);
          $smtp_session->transaction_begins;  # transaction is active
        } else {  # failure
          do_log(1, "smtp resp to MAIL (pip): %s", $smtp_resp);
          # transaction state unchanged, consider it unknown
          my $smtp_resp_ext = enhance_smtp_response($smtp_resp,
                                         $am_id, $mta_id, '.1.0', 'MAIL FROM');
          for my $r (@per_recip_data) {
            next  if $r->recip_done;
            $r->recip_remote_mta($relayhost);
            $r->recip_remote_mta_smtp_response($smtp_resp);
            $r->recip_smtp_response($smtp_resp_ext); $r->recip_done(2);
          }
          $recips_done_by_early_fail = 1;
        }
        section_time($which_section);
      }
      if (!$fetched_rcpt_resp) {  # pipelining in effect, late response to RCPT
        $which_section = 'fwd-rcpt-pip';
        $smtp_session->timeout(
          max(60,min($smtp_rcpt_timeout,$deadline-time())));
        for my $r (@per_recip_data_rcpt_sent) {  # only for those actually sent
          my $raddr = qquote_rfc2821_local($r->recip_final_addr);
          $smtp_resp = $smtp_session->smtp_response;  $fetched_rcpt_resp = 1;
          if (defined $smtp_resp && $smtp_resp ne '') {
            if ($r->recip_done) {  # shouldn't happen, unless MAIL FROM failed
              do_log(-1,"panic: recipient done, but got an ".
                        "smtp resp to RCPT (pip) (%s): %s",
                        $raddr,$smtp_resp)  if !$recips_done_by_early_fail;
              next;  # do not overwrite previous diagnostics
            }
            $r->recip_remote_mta($relayhost);
            $r->recip_remote_mta_smtp_response($smtp_resp);
            my $smtp_resp_ext = enhance_smtp_response($smtp_resp,
                                           $am_id, $mta_id, '.1.0', 'RCPT TO');
            $r->recip_smtp_response($smtp_resp_ext);  # preliminary response
          }
          if (!defined $smtp_resp || $smtp_resp eq '') {
            die sprintf("%s response to RCPT (pip) (%s), dt: %.3f s\n",
                        !defined $smtp_resp ? 'No' : 'Empty',  $raddr,
                        time - $smtp_handle->last_io_event_tx_timestamp);
          } elsif ($smtp_resp =~ /^2/) {
            do_log(3, "smtp resp to RCPT (pip) (%s): %s", $raddr,$smtp_resp);
            $any_valid_recips++;
          } else {  # failure
            do_log(1, "smtp resp to RCPT (pip) (%s): %s", $raddr,$smtp_resp);
            if ($smtp_resp =~ /^452/) {  # too many recipients - see RFC 5321
              do_log(-1, 'Only %d recips sent in one go: "%s"',
                         $any_valid_recips, $smtp_resp)
                         if !defined $skipping_resp;
              $skipping_resp = enhance_smtp_response($smtp_resp,$am_id,$mta_id,
                                                     '.5.3','RCPT TO');
            } elsif ($smtp_resp =~ /^4/) {
              $any_tempfail_recips++;
            }
            $r->recip_done(2);  # got a negative response to RCPT TO
          }
        }
        section_time($which_section);
      }
      $which_section = 'fwd-data-chkpnt'  if $pipelining;
      $smtp_session->timeout(
        max(60,min($smtp_data_init_timeout,$deadline-time())));
      $smtp_resp = $smtp_session->smtp_response;  # fetch response to DATA
      section_time($which_section);
      $data_command_accepted = 0;
      if (!defined $smtp_resp || $smtp_resp eq '') {
        do_log(-1,"%s SMTP resp. to DATA, dt: %.3f s",
                  !defined $smtp_resp ? 'No' : 'Empty',
                  time - $smtp_handle->last_io_event_tx_timestamp);
        $smtp_resp = sprintf("450 4.5.0 %s response to DATA",
                             !defined $smtp_resp ? 'No' : 'Empty');
      } elsif ($smtp_resp !~ /^3/) {
        do_log(0,"Negative SMTP resp. to DATA: %s", $smtp_resp);
      } else {  # success, $smtp_resp =~ /^3/
        $data_command_accepted = 1;
        do_log(3,"smtp resp to DATA: %s", $smtp_resp);
      }
      if (!$data_command_accepted) {
        $in_datasend_mode = 0;
        $smtp_session->timeout($smtp_rset_timeout);
        $what_cmd = 'RSET';  $smtp_handle->rset;  # send a RSET
        $smtp_session->transaction_ends_unconfirmed;
        # replace success responses to RCPT TO commands with a response to DATA
        for my $r (@per_recip_data_rcpt_sent) {  # only for those actually sent
          next  if $r->recip_done;  # skip those that failed at earlier stages
          $r->recip_remote_mta($relayhost);
          $r->recip_remote_mta_smtp_response($smtp_resp);
          my $smtp_resp_ext = enhance_smtp_response($smtp_resp,
                                              $am_id, $mta_id, '.5.0', 'DATA');
          $smtp_response = $smtp_resp_ext  if !defined $smtp_response;
          $r->recip_smtp_response($smtp_resp_ext); $r->recip_done(2);
        }
      } elsif (!$any_valid_recips) {  # pipelining and no recipients, in DATA
        do_log(2,"Too late, DATA accepted but no valid recips, send dummy");
        $which_section = 'fwd-dummydata-end';
        $smtp_session->timeout(
          max(60,min($smtp_data_done_timeout,$deadline-time())));
        $what_cmd = 'data-dot';
        $smtp_handle->dataend;  # .<CR><LF>  as required by RFC 2920: if a DATA
               # command was accepted the SMTP client should send a single dot
        $in_datasend_mode = 0; $smtp_session->transaction_ends_unconfirmed;
      } elsif ($any_tempfail_recips && !$dsn_per_recip_capable) {  # pipelining
        # we must not proceed if mail did not came in as LMTP,
        # or we would generate mail duplicates on each delivery attempt
        do_log(2,"Too late, DATA accepted but tempfailed recips, bail out");
        die "Bail out, DATA accepted but tempfailed recips, not an LMTP input";
      } else {  # all ok so far, we are in a DATA state and must send contents
        $which_section = 'fwd-data-hdr';
        my $hdr_edits = $msginfo->header_edits;
        $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
        $smtp_session->timeout(
          max(60,min($smtp_data_xfer_timeout,$deadline-time())));
        my($received_cnt,$file_position) =
          $hdr_edits->write_header($msginfo,$smtp_handle,!$initial_submission);
        if ($received_cnt > 100) {
          # loop detection required by RFC 5321 (ex RFC 2821) section 6.3
          # Do not modify the signal text, it gets matched elsewhere!
          die "Too many hops: $received_cnt 'Received:' header fields\n";
        }
        $which_section = 'fwd-data-contents';
        # a file handle or a string ref or MIME::Entity object
        my $msg = $msginfo->mail_text;
        my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
        $msg = $msg_str_ref  if ref $msg_str_ref;
        if (!defined $msg) {
          # empty mail
        } elsif (ref $msg eq 'SCALAR') {
          # do it in chunks, saves memory, cache friendly
          while ($file_position < length($$msg)) {
            $smtp_handle->datasend(substr($$msg,$file_position,16384));
            $file_position += 16384;  # may overshoot, no problem
          }
        } elsif ($msg->isa('MIME::Entity')) {
          $msg->print_body($smtp_handle);
        } else {
          my($nbytes,$buff);
          while (($nbytes = $msg->read($buff,3*16384)) > 0) {
            $smtp_handle->datasend($buff);
          }
          defined $nbytes or die "Error reading: $!";
        }
        section_time($which_section);

        $which_section = 'fwd-data-end';
        $smtp_session->timeout(
          max(60,min($smtp_data_done_timeout,$deadline-time())));
        $what_cmd = 'data-dot';
        $smtp_handle->dataend;  # .<CR><LF>
        $in_datasend_mode = 0; $smtp_session->transaction_ends_unconfirmed;
        $any_valid_recips_and_data_sent = 1;
        section_time($which_section)  if !$pipelining;  # otherwise it shows 0
      }
    }
    if ($pipelining && !$smtp_connection_cache_enable) {
      do_log(5,"smtp connection_cache disabled, sending QUIT");
      $smtp_session->quit;  #flush!   QUIT
      # can't be sure until we see a response, consider uncertain just in case
      $smtp_session->transaction_ends_unconfirmed;
    }
    $which_section = 'fwd-rundown-1';
    $smtp_resp = undef;
    if (!defined $what_cmd) {
      # not expecting a response?
    } elsif ($what_cmd ne 'data-dot') {  # must be a response to a RSET
      $smtp_resp = $smtp_session->smtp_response;  # fetch a response
      if (!defined $smtp_resp || $smtp_resp eq '') {
        die sprintf("%s SMTP response to %s, dt: %.3f s",
                    !defined $smtp_resp ? 'No' : 'Empty',  $what_cmd,
                    time - $smtp_handle->last_io_event_tx_timestamp);
      } elsif ($smtp_resp !~ /^2/) {
        die "Negative SMTP response to $what_cmd: $smtp_resp";
      } else {  # success, $smtp_resp =~ /^2/
        do_log(3,"smtp resp to %s: %s", $what_cmd,$smtp_resp);
        $smtp_session->transaction_ends  if $what_cmd eq 'RSET';
      }
    } else {  # get response(s) to data-dot
      # replace success responses to RCPT TO commands with a final response
      my $first = 1;  my $anyfail = 0;  my $anysucc = 0;
      for my $r (@per_recip_data_rcpt_sent) {  # only for those actually sent
        if ($lmtp || $first) {
          $first = 0;  my $raddr = qquote_rfc2821_local($r->recip_final_addr);
          $raddr .= ', etc.'  if !$lmtp && @per_recip_data > 1;
          $smtp_resp = $smtp_session->smtp_response;  # resp to data-dot
          if (!defined $smtp_resp || $smtp_resp eq '') {
            $anyfail = 1;
            do_log(0,"%s SMTP response to %s (%s), dt: %.3f s",
                     !defined $smtp_resp ? 'No' : 'Empty', $what_cmd, $raddr,
                     time - $smtp_handle->last_io_event_tx_timestamp);
          } elsif ($smtp_resp !~ /^2/) {
            $anyfail = 1;
            do_log(0,"Negative SMTP response to %s (%s): %s, dt: %.1f ms",
                     $what_cmd, $raddr, $smtp_resp,
                     1000*(time-$smtp_handle->last_io_event_tx_timestamp));
          } else {  # success, $smtp_resp =~ /^2/
            $anysucc = 1;
            ll(3) && do_log(3,"smtp resp to %s (%s): %s, dt: %.1f ms",
                       $what_cmd, $raddr, $smtp_resp,
                       1000*(time-$smtp_handle->last_io_event_tx_timestamp));
          }
        }
        next  if $r->recip_done;  # skip those that failed at earlier stages
        $r->recip_remote_mta($relayhost);
        $r->recip_remote_mta_smtp_response($smtp_resp);
        my $smtp_resp_ext = enhance_smtp_response($smtp_resp,$am_id,$mta_id,
                                                  '.6.0','data-dot');
        $smtp_response = $smtp_resp_ext  if !defined $smtp_response;
        $r->recip_smtp_response($smtp_resp_ext); $r->recip_done(2);
        $r->recip_mbxname($r->recip_final_addr)  if $smtp_resp =~ /^2/;
      }
      if ($first) {  # fetch an uncollected response
        # fetch unprocessed response if all recipients were rejected
        # but we nevertheless somehow entered a data transfer mode
        # (i.e. if an SMTP server failed to reject a DATA command).
        # RFC 2033: when there have been no successful RCPT commands in the
        # mail transaction, the DATA command MUST fail with a 503 reply code
        $smtp_resp = $smtp_session->smtp_response;  # resp to data-dot
        $smtp_resp = ''  if !defined $smtp_resp;
        if ($smtp_resp =~ /^2/) { $anysucc = 1 } else { $anyfail = 1 }
        do_log(3,"smtp resp to _dummy_ data %s: %s", $what_cmd,$smtp_resp);
      }
      if ($anysucc && !$anyfail) {
        # we are certain all went fine and a transaction is definitely over
        $smtp_session->transaction_ends;
      }
    }
#   if ($pipelining) {}     # QUIT was already sent
#   elsif (!$smtp_connection_cache_enable)  {
#     $smtp_session->quit;  #flush!   QUIT
#     # can't be sure until we see a response, consider uncertain just in case
#     $smtp_session->transaction_ends_unconfirmed;
#   }
#   if ($smtp_session->session_state eq 'quitsent') {
#     $smtp_session->timeout($smtp_quit_timeout);
#     $smtp_resp = $smtp_session->smtp_response;
#     $smtp_resp = ''  if !defined $smtp_resp;
#     do_log(3,"smtp resp to QUIT: %s", $smtp_resp);
#     if ($smtp_resp =~ /^2/) {
#       $smtp_session->transaction_ends;
#     } else {
#       $smtp_session->transaction_ends_unconfirmed;
#       do_log(0,"Negative SMTP resp. to QUIT: %s", $smtp_resp);
#     }
#   }
    my $keep_session = $smtp_session->session_state ne 'quitsent';
    if ($keep_session && !defined($smtp_session->in_smtp_transaction)) {
      do_log(2,"SMTP transaction state uncertain, closing just in case");
      $keep_session = 0;
    }
    $smtp_session->close($keep_session)
      or die "Error closing Amavis::Out::SMTP::Session";
    undef $smtp_handle; undef $smtp_session;
    1;
    # some unusual error conditions _are_ captured by eval, but fail to set $@
  } or do { $err = $@ ne '' ? $@ : "errno=$!"; chomp $err };
  my $saved_section_name = $which_section;
  $which_section = 'fwd-end-chkpnt';
  do_log(2,"mail_via_smtp: session failed: %s", $err)  if defined $err;
  prolong_timer($which_section);  # restart timer
  # terminate the SMTP session if still alive
  if (!defined($smtp_session)) {
    # already closed normally
  } elsif ($in_datasend_mode) {
    # We are aborting SMTP session. Data transfer mode must NOT be terminated
    # with a dataend (dot), otherwise recipient will receive a chopped-off mail
    # (and possibly be receiving it over and over again during each MTA retry.
    do_log(-1, "mail_via_smtp: NOTICE: aborting SMTP session, %s", $err);
    $smtp_session->close(0);  # abruptly terminate SMTP session, ignore status
  } else {
    do_log(5,"smtp session done, sending QUIT");
    eval {
      $smtp_session->timeout(1);    # don't wait for too long
      $smtp_session->quit;  #flush! # send a QUIT regardless of success so far
      $smtp_session->transaction_ends_unconfirmed;
      for (my $cnt=0; ; $cnt++) {  # curious if there are any pending responses
        my $smtp_resp = $smtp_session->smtp_response;
        last  if !defined $smtp_resp;
        do_log(0,"discarding unprocessed reply: %s", $smtp_resp);
        if ($cnt > 20) { do_log(-1,"aborting, discarding many replies"); last }
      }
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(-1, "mail_via_smtp: error during QUIT: %s", $eval_stat);
    };
    $smtp_session->close(0);  # terminate SMTP session, ignore status
  }
  undef $smtp_handle; undef $smtp_session;
  # prepare final smtp response and log abnormal events
  for my $r (@per_recip_data) {
    my $resp = $r->recip_smtp_response;
    $smtp_response = $resp  if !defined($smtp_response) ||
                               $resp =~ /^4/ && $smtp_response !~ /^4/ ||
                               $resp !~ /^2/ && $smtp_response !~ /^[45]/;
  }
  if (!defined $err) {
    # no errors
  } elsif ($err =~ /^timed out\b/ || $err =~ /: Timeout\z/) {
    $smtp_response = sprintf("450 4.4.2 Timed out during %s, MTA(%s), id=%s",
                             $saved_section_name, $mta_id, $am_id);
  } elsif ($err =~ /^Can't connect\b/) {
    $smtp_response = sprintf("450 4.4.1 %s, MTA(%s), id=%s",
                             $err, $mta_id, $am_id);
  } elsif ($err =~ /^Too many hops\b/) {
    $smtp_response = sprintf("554 5.4.6 Reject: %s, id=%s", $err, $am_id);
  } else {
    $smtp_response = sprintf("451 4.5.0 From MTA(%s) during %s (%s): id=%s",
                             $mta_id, $saved_section_name, $err, $am_id);
  }
  # NOTE: $initial_submission argument is typically treated as a boolean
  # but a value of 'AV' is supplied by av_smtp_client to allow a forwarding
  # method to distinguish it from ordinary submissions
  my $ll = ($smtp_response =~ /^2/ || $initial_submission eq 'AV') ? 1 : -1;
  ll($ll) && do_log($ll, "%s from %s -> %s, %s %s",
          $logmsg, $sender_smtp,
          join(',', qquote_rfc2821_local(
                      map($_->recip_final_addr, @per_recip_data))),
          join(' ', map { my $v=$from_options{$_}; defined($v)?"$_=$v":"$_" }
                        (keys %from_options)),
          $smtp_response);
  if (defined $smtp_response) {
    $msginfo->dsn_passed_on($dsn_capable && $smtp_response=~/^2/ &&
                            !c('terminate_dsn_on_notify_success') ? 1 : 0);
    for my $r (@per_recip_data) {
      # attach an SMTP response to each recip that was not already processed
      if (!$r->recip_done) {  # mark it as done
        $r->recip_smtp_response($smtp_response); $r->recip_done(2);
        $r->recip_mbxname($r->recip_final_addr)  if $smtp_response =~ /^2/;
      } elsif ($any_valid_recips_and_data_sent &&
               $r->recip_smtp_response =~ /^452/) {
        # 'undo' the RCPT TO '452 Too many recipients' situation,
        # mail needs to be transferred in more than one transaction
        $r->recip_smtp_response(undef); $r->recip_done(undef);
      }
    }
    if ($smtp_response =~ /^2/) {
      snmp_count('OutMsgsDelivers');
      my $size = $msginfo->msg_size;
      snmp_count( ['OutMsgsSize'.$_, $size, 'C64'] )  for @snmp_vars;
    } elsif ($smtp_response =~ /^4/) {
      snmp_count('OutMsgsAttemptFails');
    } elsif ($smtp_response =~ /^5/) {
      snmp_count('OutMsgsRejects');
    }
  }
  section_time($which_section);
  die $err  if defined($err) && $err =~ /^timed out\b/;  # resignal timeout
  1;
}

1;

__DATA__
#
package Amavis::Out::Pipe;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT = qw(&mail_via_pipe);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Util qw(untaint min max minmax ll do_log snmp_count
                         collect_equal_delivery_recips);
  import Amavis::ProcControl qw(exit_status_str proc_status_ok kill_proc
                         run_command_consumer);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Out::EditHeader;
}

use Errno qw(ENOENT EACCES ESRCH);
use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);

# Send mail using external mail submission program 'sendmail' or its lookalike
# (also available with Postfix and Exim) - used for forwarding original mail
# or sending notifications or quarantining. May throw exception (die) on
# temporary failure (4xx) or other problem.
#
sub mail_via_pipe(@) {
  my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;
  my(@snmp_vars) = !$initial_submission ?
    ('', 'Relay',  'ProtoPipe', 'ProtoPipeRelay')
  : ('', 'Submit', 'ProtoPipe', 'ProtoPipeSubmit',
     'Submit'.$initial_submission);
  snmp_count('OutMsgs'.$_)  for @snmp_vars;
  my $id = $msginfo->parent_mail_id;
  $id = $msginfo->mail_id . (defined $id ? "($id)" : "");
  my $logmsg = sprintf("%s %s via PIPE from %s", $id,
                       ($initial_submission ? 'SEND' : 'FWD'),
                       $msginfo->sender_smtp);
  my($per_recip_data_ref, $proto_sockname) =
    collect_equal_delivery_recips($msginfo, $filter, qr/^pipe:/i);
  if (!$per_recip_data_ref || !@$per_recip_data_ref) {
    do_log(5, "%s, nothing to do", $logmsg);  return 1;
  }
  $proto_sockname = $proto_sockname->[0]  if ref $proto_sockname;
  ll(1) && do_log(1, "delivering to %s, %s -> %s",
                     $proto_sockname, $logmsg,
                     join(',', qquote_rfc2821_local(
                           map($_->recip_final_addr, @$per_recip_data_ref)) ));
  # just use the first one, ignoring failover alternatives
  local($1);
  $proto_sockname =~ /^pipe:(.*)\z/si
    or die "Bad fwd method syntax: ".$proto_sockname;
  my $pipe_args = $1;
  $pipe_args =~ s/^flags=\S*\s*//i;  # flags are currently ignored, q implied
  $pipe_args =~ s/^argv=//i;
  my(@pipe_args) = split(' ',$pipe_args);  my(@command) = shift(@pipe_args);
  my $dsn_capable = c('propagate_dsn_if_possible');  # assume, unless disabled
  $dsn_capable = 0  if $command[0] !~ /sendmail/;  # a hack, don't use -N or -V
  if ($dsn_capable) {    # DSN is supported since Postfix 2.3
    # notify options are per-recipient, yet a command option -N applies to all
    my $common_list; my $not_all_the_same = 0;
    for my $r (@{$msginfo->per_recip_data}) {
      my $dsn_notify = $r->dsn_notify;
      my $d;
      if ($msginfo->sender eq '') {
        $d = 'NEVER';
      } elsif (!$dsn_notify) {
        $d = 'DELAY,FAILURE';  # sorted
      } else {
        $d = uc(join(',', sort @$dsn_notify));  # normalize order
      }
      if (!defined($common_list)) { $common_list = $d }
      elsif ($d ne $common_list) { $not_all_the_same = 1 }
    }
    if ($common_list=~/\bSUCCESS\b/ && c('terminate_dsn_on_notify_success')) {
      # strip out option SUCCESS, we want to handle it locally
      my(@dsn_notify) = grep($_ ne 'SUCCESS', split(/,/,$common_list));
      @dsn_notify = ('NEVER')  if !@dsn_notify;
      $common_list = join(',',@dsn_notify);
      do_log(3,"stripped out SUCCESS, result: NOTIFY=%s", $common_list);
    }
    if ($not_all_the_same || $msginfo->sender eq '') {}  # leave at default
    elsif ($common_list eq 'DELAY,FAILURE') {}           # leave at default
    else { unshift(@pipe_args, '-N', $common_list) }
    unshift(@pipe_args,
            '-V', $msginfo->dsn_envid)  if defined $msginfo->dsn_envid;
    # but there is no mechanism to specify ORCPT or RET
  }
  for (@pipe_args) {
    # The sendmail command line expects addresses quoted as per RFC 822.
    #   "funny user"@some.domain
    # For compatibility with Sendmail, the Postfix sendmail command line also
    # accepts address formats that are legal in RFC 822 mail header section:
    #   Funny Dude <"funny user"@some.domain>
    # Although addresses passed as args to sendmail submission program
    # should not be <...> bracketed, for some reason original sendmail
    # issues a warning on null reverse-path, but gladly accepts <>.
    # As this is not strictly wrong, we comply to make it happy.
    # NOTE: the -fsender is not allowed, -f and sender must be separate args!
    my $null_ret_path = '<>';  # some sendmail lookalikes want '<>', others ''
    # Courier sendmail accepts '' but not '<>' for null reverse path
    $null_ret_path = ''  if $Amavis::extra_code_in_courier;
    if (/^\$\{sender\}\z/i) {
      push(@command, $msginfo->sender eq '' ? $null_ret_path
       : do { my $s = $msginfo->sender_smtp;
              $s =~ s/^<//; $s =~ s/>\z//; untaint($s) });
    } elsif (/^\$\{recipient\}\z/i) {
      push(@command,
           map { $_ eq '' ? $null_ret_path : untaint(quote_rfc2821_local($_)) }
           map($_->recip_final_addr, @$per_recip_data_ref));
    } else {
      push(@command, $_);
    }
  }
  ll(5) && do_log(5, "mail_via_pipe running command: %s", join(' ',@command));
  local $SIG{CHLD} = 'DEFAULT';
  local $SIG{PIPE} = 'IGNORE';  # don't signal on a write to a widowed pipe
  my($proc_fh,$pid) = run_command_consumer(undef,undef,@command);
  my $hdr_edits = $msginfo->header_edits;
  $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
  my($received_cnt,$file_position) =
    $hdr_edits->write_header($msginfo,$proc_fh,!$initial_submission);
  my $msg = $msginfo->mail_text;
  my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
  $msg = $msg_str_ref  if ref $msg_str_ref;
  if ($received_cnt > 100) {  # loop detection required by RFC 5321 section 6.3
                              # deal with it later, for now just skip the body
  } elsif (!defined $msg) {
    # empty mail
  } elsif (ref $msg eq 'SCALAR') {
    # do it in chunks, saves memory, cache friendly
    while ($file_position < length($$msg)) {
      $proc_fh->print(substr($$msg,$file_position,16384))
        or die "writing mail text to a pipe failed: $!";
      $file_position += 16384;  # may overshoot, no problem
    }
  } elsif ($msg->isa('MIME::Entity')) {
    $msg->print_body($proc_fh);
  } else {
    my($nbytes,$buff);
    while (($nbytes = $msg->read($buff,32768)) > 0) {
      $proc_fh->print($buff)
        or die "writing mail text to a pipe failed: $!";
    }
    defined $nbytes or die "Error reading: $!";
  }
  $proc_fh->flush or die "Can't flush pipe to a mail submission program: $!";
  my $smtp_response;
  if ($received_cnt > 100) { # loop detection required by RFC 5321 section 6.3
    do_log(-2, "Too many hops: %d 'Received:' header fields", $received_cnt);
    kill_proc($pid,$command[0],10,$proc_fh,'too many hops')  if defined $pid;
    $proc_fh->close; undef $proc_fh; undef $pid;  # and ignore status
    $smtp_response = "554 5.4.6 Reject: " .
                     "Too many hops: $received_cnt 'Received:' header fields";
  } else {
    my $err = 0; $proc_fh->close or $err=$!;
    my $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;
    # sendmail program (Postfix variant) can return the following exit codes:
    # EX_OK(0), EX_DATAERR, EX_SOFTWARE, EX_TEMPFAIL, EX_NOUSER, EX_UNAVAILABLE
    if (proc_status_ok($child_stat,$err, EX_OK)) {
      $smtp_response = "250 2.6.0 Ok";  # submitted to MTA
      snmp_count('OutMsgsDelivers');
      my $size = $msginfo->msg_size;
      snmp_count( ['OutMsgsSize'.$_, $size, 'C64'] )  for @snmp_vars;
    } elsif (proc_status_ok($child_stat,$err, EX_TEMPFAIL)) {
      $smtp_response = "450 4.5.0 Temporary failure submitting message";
      snmp_count('OutMsgsAttemptFails');
    } elsif (proc_status_ok($child_stat,$err, EX_NOUSER)) {
      $smtp_response = "554 5.1.1 Recipient unknown";
      snmp_count('OutMsgsRejects');
    } elsif (proc_status_ok($child_stat,$err, EX_UNAVAILABLE)) {
      $smtp_response = "554 5.5.0 Mail submission service unavailable";
      snmp_count('OutMsgsRejects');
    } else {
      $smtp_response = "451 4.5.0 Failed to submit a message: ".
                       exit_status_str($child_stat,$err);
      snmp_count('OutMsgsAttemptFails');
    }
    ll(3) && do_log(3,"mail_via_pipe %s, %s, %s", $command[0],
                      exit_status_str($child_stat,$err), $smtp_response);
  }
  $smtp_response .= ", id=" . $msginfo->log_id;
  for my $r (@$per_recip_data_ref) {
    next  if $r->recip_done;
    $r->recip_smtp_response($smtp_response); $r->recip_done(2);
    $r->recip_mbxname($r->recip_final_addr)  if $smtp_response =~ /^2/;
  }
  $msginfo->dsn_passed_on($dsn_capable && $smtp_response=~/^2/ &&
                          !c('terminate_dsn_on_notify_success') ? 1 : 0);
  section_time('fwd-pipe');
  1;
}

1;

__DATA__
#
package Amavis::Out::BSMTP;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT = qw(&mail_via_bsmtp);
  import Amavis::Conf qw(:platform $QUARANTINEDIR c cr ca);
  import Amavis::Util qw(untaint min max minmax ll do_log snmp_count
                         idn_to_ascii collect_equal_delivery_recips);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Out::EditHeader;
}

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

# store message in a BSMTP format
#
# RFC 2442: Application/batch-SMTP material is generated by a specially
# modified SMTP client operating without a corresponding SMTP server.
# The client simply assumes a successful response to all commands it issues.
# The resulting content then consists of the collected output from the SMTP
# client.
#
sub mail_via_bsmtp(@) {
  my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;
  my(@snmp_vars) = !$initial_submission ?
    ('', 'Relay',  'ProtoBSMTP', 'ProtoBSMTPRelay')
  : ('', 'Submit', 'ProtoBSMTP', 'ProtoBSMTPSubmit',
     'Submit'.$initial_submission);
  snmp_count('OutMsgs'.$_)  for @snmp_vars;
  my $logmsg = sprintf("%s via BSMTP: %s", ($initial_submission?'SEND':'FWD'),
                       $msginfo->sender_smtp);
  my($per_recip_data_ref, $proto_sockname) =
    collect_equal_delivery_recips($msginfo, $filter, qr/^bsmtp:/i);
  if (!$per_recip_data_ref || !@$per_recip_data_ref) {
    do_log(5, "%s, nothing to do", $logmsg);  return 1;
  }
  $proto_sockname = $proto_sockname->[0]  if ref $proto_sockname;
  ll(1) && do_log(1, "delivering to %s, %s -> %s",
                     $proto_sockname, $logmsg,
                     join(',', qquote_rfc2821_local(
                           map($_->recip_final_addr, @$per_recip_data_ref)) ));
  # just use the first one, ignoring failover alternatives
  local($1);
  $proto_sockname =~ /^bsmtp:(.*)\z/si
    or die "Bad fwd method syntax: ".$proto_sockname;
  my $bsmtp_file_final = $1; my $mbxname;
  my $s = $msginfo->sender;  # sanitized sender name for use in a filename
  $s =~ tr/a-zA-Z0-9@._+-/=/c;
  substr($s,100) = '...'  if length($s) > 100+3;
  $s =~ s/\@/_at_/g; $s =~ s/^(\.{0,2})\z/_$1/;
  $bsmtp_file_final =~ s{%(.)}
    {  $1 eq 'b' ? $msginfo->body_digest
     : $1 eq 'P' ? $msginfo->partition_tag
     : $1 eq 'm' ? $msginfo->mail_id||''
     : $1 eq 'n' ? $msginfo->log_id
     : $1 eq 's' ? untaint($s)  # a hack, avoid using %s
     : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1)  #,'-')
     : $1 eq '%' ? '%' : '%'.$1 }gse;
  # prepend directory if not specified
  my $bsmtp_file_final_to_show = $bsmtp_file_final;
  $bsmtp_file_final = $QUARANTINEDIR."/".$bsmtp_file_final
    if $QUARANTINEDIR ne '' && $bsmtp_file_final !~ m{^/};
  my $bsmtp_file_tmp = $bsmtp_file_final . ".tmp";
  my $mp; my $err;
  eval {
    my $errn = lstat($bsmtp_file_tmp) ? 0 : 0+$!;
    if ($errn == ENOENT) {}   # good, no file, as expected
    elsif ($errn==0 && (-f _ || -l _))
      { die "File $bsmtp_file_tmp already exists, refuse to overwrite" }
    else
      { die "File $bsmtp_file_tmp exists??? Refuse to overwrite it, $!" }
    $mp = IO::File->new;
    # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
    $mp->open($bsmtp_file_tmp, untaint(O_CREAT|O_EXCL|O_WRONLY), 0640)
      or die "Can't create BSMTP file $bsmtp_file_tmp: $!";
    binmode($mp,':bytes') or die "Can't set :bytes, $!";

#   RFC 2442: Since no SMTP server is present the client must be prepared
#   to make certain assumptions about which SMTP extensions can be used.
#   The generator MAY assume that ESMTP [RFC 1869 (obsoleted by RFC 5321)]
#   facilities are available, that is, it is acceptable to use the EHLO
#   command and additional parameters on MAIL FROM and RCPT TO.  If EHLO
#   is used MAY assume that the 8bitMIME [RFC 6152], SIZE [RFC 1870], and
#   NOTARY [RFC 1891] extensions are available. In particular, NOTARY
#   SHOULD be used. (nowadays called DSN)

    my $myheloname = c('localhost_name');  # host name used in EHLO/HELO/LHLO
    $myheloname = 'localhost'  if $myheloname eq '';
    $myheloname = idn_to_ascii($myheloname);
    $mp->printf("EHLO %s\n", $myheloname)  or die "print failed (EHLO): $!";
    my $btype = $msginfo->body_type;  # RFC 6152: need "8bit Data"? (RFC 2045)
    $btype = ''  if !defined $btype;
    my $dsn_envid = $msginfo->dsn_envid; my $dsn_ret = $msginfo->dsn_ret;
    $mp->printf("MAIL FROM:%s\n", join(' ',
                          $msginfo->sender_smtp,
                          $btype ne ''       ? ('BODY='.uc($btype))  : (),
                          defined $dsn_ret   ? ('RET='.$dsn_ret)     : (),
                          defined $dsn_envid ? ('ENVID='.$dsn_envid) : () ),
                ) or die "print failed (MAIL FROM): $!";
    for my $r (@$per_recip_data_ref) {
      my(@dsn_notify);  # implies a default when the list is empty
      my $dn = $r->dsn_notify;
      @dsn_notify = @$dn  if $dn && $msginfo->sender ne '';  # if nondefault
      if (@dsn_notify && c('terminate_dsn_on_notify_success')) {
        # we want to handle option SUCCESS locally
        if (grep($_ eq 'SUCCESS', @dsn_notify)) {  # strip out SUCCESS
          @dsn_notify = grep($_ ne 'SUCCESS', @dsn_notify);
          @dsn_notify = ('NEVER')  if !@dsn_notify;
          do_log(3,"stripped out SUCCESS, result: NOTIFY=%s",
                   join(',',@dsn_notify));
        }
      }
      $mp->printf("RCPT TO:%s\n", join(' ',
                       qquote_rfc2821_local($r->recip_final_addr),
                       @dsn_notify ? ('NOTIFY='.join(',',@dsn_notify))  : (),
                       defined $r->dsn_orcpt ? ('ORCPT='.$r->dsn_orcpt) : () ),
                  ) or die "print failed (RCPT TO): $!";
    }
    $mp->print("DATA\n") or die "print failed (DATA): $!";
    my $hdr_edits = $msginfo->header_edits;
    $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
    my($received_cnt,$file_position) =
      $hdr_edits->write_header($msginfo,$mp,!$initial_submission);
    my $msg = $msginfo->mail_text;
    my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
    $msg = $msg_str_ref  if ref $msg_str_ref;
    if ($received_cnt > 100) {  # loop detection required by RFC 5321 sect. 6.3
      die "Too many hops: $received_cnt 'Received:' header fields";
    } elsif (!defined $msg) {
      # empty mail
    } elsif (ref $msg eq 'SCALAR') {
      my $buff = substr($$msg,$file_position);
      $buff =~ s/^\./../gm;
      $mp->print($buff)  or die "print failed - data: $!";
    } elsif ($msg->isa('MIME::Entity')) {
      $msg->print_body($mp);
    } else {
      my $ln;
      for ($! = 0; defined($ln=$msg->getline); $! = 0) {
        $mp->print($ln=~/^\./ ? (".",$ln) : $ln)
          or die "print failed - data: $!";
      }
      defined $ln || $! == 0  or die "Error reading: $!";
    }
    $mp->print(".\n")    or die "print failed (final dot): $!";
  # $mp->print("QUIT\n") or die "print failed (QUIT): $!";
    $mp->close or die "Error closing BSMTP file $bsmtp_file_tmp: $!";
    undef $mp;
    rename($bsmtp_file_tmp, $bsmtp_file_final)
      or die "Can't rename BSMTP file to $bsmtp_file_final: $!";
    $mbxname = $bsmtp_file_final;
    1;
  } or do { $err = $@ ne '' ? $@ : "errno=$!" };
  my $smtp_response;
  if ($err eq '') {
    $smtp_response = "250 2.6.0 Ok, queued as BSMTP $bsmtp_file_final_to_show";
    snmp_count('OutMsgsDelivers');
    my $size = $msginfo->msg_size;
    snmp_count( ['OutMsgsSize'.$_, $size, 'C64'] )  for @snmp_vars;
  } else {
    chomp $err;
    unlink($bsmtp_file_tmp)
      or do_log(-2,"Can't delete half-finished BSMTP file %s: %s",
                   $bsmtp_file_tmp, $!);
    $mp->close  if defined $mp;  # ignore status
    if ($err =~ /too many hops\b/i) {
      $smtp_response = "554 5.4.6 Reject: $err";
      snmp_count('OutMsgsRejects');
    } else {
      $smtp_response = "451 4.5.0 Writing $bsmtp_file_tmp failed: $err";
      snmp_count('OutMsgsAttemptFails');
    }
    die $err  if $err =~ /^timed out\b/;  # resignal timeout
  }
  $smtp_response .= ", id=" . $msginfo->log_id;
  $msginfo->dsn_passed_on($smtp_response=~/^2/ &&
                          !c('terminate_dsn_on_notify_success') ? 1 : 0);
  for my $r (@$per_recip_data_ref) {
    next  if $r->recip_done;
    $r->recip_smtp_response($smtp_response); $r->recip_done(2);
    $r->recip_mbxname($mbxname)  if $mbxname ne '' && $smtp_response =~ /^2/;
  }
  section_time('fwd-bsmtp');
  1;
}

1;

__DATA__
#
package Amavis::Out::Local;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&mail_to_local_mailbox);
  import Amavis::Conf qw(:platform c cr ca
                         $QUARANTINEDIR $quarantine_subdir_levels);
  import Amavis::Util qw(snmp_count ll do_log untaint unique_list
                         collect_equal_delivery_recips);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Out::EditHeader;
}

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

use subs @EXPORT_OK;

# Deliver to local mailboxes only, ignore the rest: either to directory
# (maildir style), or file (Unix mbox).  (normally used as a quarantine method)
#
sub mail_to_local_mailbox(@) {
  my($msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;

  # note that recipients of a message being delivered to a quarantine
  # are typically not the original envelope recipients, but are pseudo
  # address provided to do_quarantine() based on @quarantine_to_maps;
  # nevertheless, we do the usual collect_equal_delivery_recips() ritual
  # here too for consistency
  #
  my $logmsg = sprintf("%s via LOCAL: %s", ($initial_submission?'SEND':'FWD'),
                       $msginfo->sender_smtp);
  my($per_recip_data_ref, $proto_sockname) =
    collect_equal_delivery_recips($msginfo, $filter, qr/^local:/i);
  if (!$per_recip_data_ref || !@$per_recip_data_ref) {
    do_log(5, "%s, nothing to do", $logmsg);  return 1;
  }
  my(@per_recip_data) = @$per_recip_data_ref;  undef $per_recip_data_ref;
  $proto_sockname = $proto_sockname->[0]  if ref $proto_sockname;
  ll(4) && do_log(4, "delivering to %s, %s -> %s",
                     $proto_sockname, $logmsg,
                     join(',', qquote_rfc2821_local(
                           map($_->recip_final_addr, @per_recip_data)) ));
  # just use the first one, ignoring failover alternatives
  local($1);
  $proto_sockname =~ /^local:(.*)\z/si
    or die "Bad local method syntax: ".$proto_sockname;
  my $via_arg = $1;
  my(@snmp_vars) = !$initial_submission ?
    ('', 'Relay', 'ProtoLocal', 'ProtoLocalRelay')
  : ('', 'Submit','ProtoLocal', 'ProtoLocalSubmit',
     'Submit'.$initial_submission);
  snmp_count('OutMsgs'.$_)  for @snmp_vars;
  my $sender = $msginfo->sender;
  for my $r (@per_recip_data) {  # determine a mailbox file for each recipient
    # each recipient gets his own copy; these are not the original message's
    # recipients but are mailbox addresses, typically telling where a message
    # to be quarantined is to be stored
    my $recip = $r->recip_final_addr;

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

    my($mbxname, $suggested_filename);
    my($localpart,$domain) = split_address($recip);
    my $ldar = cr('local_delivery_aliases');  # a ref to a hash
    my $alias = $ldar->{$localpart};
    if (ref($alias) eq 'ARRAY') {
      ($mbxname, $suggested_filename) = @$alias;
    } elsif (ref($alias) eq 'CODE') {  # lazy (delayed) evaluation
      ($mbxname, $suggested_filename) = &$alias;
    } elsif ($alias ne '') {
      ($mbxname, $suggested_filename) = ($alias, undef);
    } elsif (!exists $ldar->{$localpart}) {
      do_log(3, "no key '%s' in %s, using a default",
                $localpart, '%local_delivery_aliases');
      ($mbxname, $suggested_filename) = ($QUARANTINEDIR, undef);
    }
    if (!defined($mbxname) || $mbxname eq '' || $recip eq '') {
      my $why = !exists $ldar->{$localpart} ? 1 : $alias eq '' ? 2 : 3;
      do_log(2, "skip local delivery(%s): <%s> -> <%s>", $why,$sender,$recip);
      my $smtp_response = "250 2.6.0 Ok, skip local delivery($why)";
      $smtp_response .= ", id=" . $msginfo->log_id;
      $r->recip_smtp_response($smtp_response); $r->recip_done(2);
      next;
    }
    my $ux;  # is it a UNIX-style mailbox?
    my $errn = stat($mbxname) ? 0 : 0+$!;
    if ($errn == ENOENT) {
      $ux = 1;           # $mbxname is a UNIX-style mailbox (new file)
    } elsif ($errn != 0) {
      die "Can't access a mailbox file or directory $mbxname: $!";
    } elsif (-f _) {
      $ux = 1;           # $mbxname is a UNIX-style mailbox (existing file)
    } elsif (!-d _) {
      die "Mailbox is neither a file nor a directory: $mbxname";
    } else {             # a directory
      $ux = 0;  # $mbxname is a directory (amavis/maildir style mailbox)
      my $explicitly_suggested_filename = $suggested_filename ne '';
      if ($suggested_filename eq '')
        { $suggested_filename = $via_arg ne '' ? $via_arg : '%m' }
      my $mail_id = $msginfo->mail_id;
      if (!defined($mail_id)) {
        do_log(-1, "mail_to_local_mailbox: mail_id still undefined!?");
        $mail_id = '';
      }
      $suggested_filename =~ s{%(.)}
        {  $1 eq 'b' ? $msginfo->body_digest
         : $1 eq 'P' ? $msginfo->partition_tag
         : $1 eq 'm' ? $mail_id
         : $1 eq 'n' ? $msginfo->log_id
         : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1)  #,'-')
         : $1 eq '%' ? '%' : '%'.$1 }gse;
    # $mbxname = File::Spec->catfile($mbxname, $suggested_filename);
      $mbxname = "$mbxname/$suggested_filename";
      if ($quarantine_subdir_levels>=1 && !$explicitly_suggested_filename) {
        # using a subdirectory structure to disperse quarantine files
        local($1,$2); my $subdir = substr($mail_id, 0, 1);
        $subdir=~/^[A-Z0-9]\z/i or die "Unexpected first char: $subdir";
        $mbxname =~ m{^ (.*/)? ([^/]+) \z}xs; my($path,$fname) = ($1,$2);
      # $mbxname = File::Spec->catfile($path, $subdir, $fname);
        $mbxname = "$path$subdir/$fname";  # resulting full filename
        my $errn = stat("$path$subdir") ? 0 : 0+$!;
        # only test for ENOENT, other errors will be detected later on access
        if ($errn == ENOENT) {  # check/prepare a set of subdirectories
          do_log(2, "checking/creating quarantine subdirs under %s", $path);
          for my $d ('A'..'Z','a'..'z','0'..'9') {
            $errn = stat("$path$d") ? 0 : 0+$!;
            if ($errn == ENOENT) {
              mkdir("$path$d", 0750) or die "Can't create dir $path$d: $!";
            }
          }
        }
      }
    }
    # save location where mail should be stored, prepend a mailbox style
    $r->recip_mbxname(($ux ? 'mbox' : 'maildir') . ':' . $mbxname);
  }
  #
  # now go ahead and store a message to predetermined files in recip_mbxname;
  # iterate by groups of recipients with the same mailbox name
  #
  @per_recip_data = grep(!$_->recip_done, @per_recip_data);
  while (@per_recip_data) {
    my $mbxname = $per_recip_data[0]->recip_mbxname;  # first mailbox name
    # collect all recipient which have the same mailbox file as the first one
    my(@recips_with_same_mbx) =
                      grep($_->recip_mbxname eq $mbxname, @per_recip_data);
    @per_recip_data = grep($_->recip_mbxname ne $mbxname, @per_recip_data);

    # retrieve mailbox style and a filename
    local($1,$2);  $mbxname =~ /^([^:]*):(.*)\z/;
    my $ux = $1 eq 'mbox' ? 1 : 0;  $mbxname = $2;

    my(@recips) = map($_->recip_final_addr, @recips_with_same_mbx);
    @recips = unique_list(\@recips);
    my $smtp_response;
    { # a block is used as a 'switch' statement - 'last' will exit from it
      do_log(1,"local delivery: %s -> %s, mbx=%s",
               $msginfo->sender_smtp, join(", ",@recips), $mbxname);
      my $eval_stat; my($mp,$pos);
      my $errn = stat($mbxname) ? 0 : 0+$!;
      section_time('stat-mbx');
      local $SIG{CHLD} = 'DEFAULT';
      local $SIG{PIPE} = 'IGNORE';  # don't signal on a write to a widowed pipe
      eval {                        # try to open the mailbox file for writing
        if (!$ux) {  # one mail per file, will create specified file
          if ($errn == ENOENT) {
            # good, no file, as expected
          } elsif ($errn != 0) {
            die "File $mbxname not accessible, refuse to write: $!";
          } elsif (!-f _) {
            die "File $mbxname is not a regular file, refuse to write";
          } else {
            die "File $mbxname already exists, refuse to overwrite";
          }
          if ($mbxname =~ /\.gz\z/) {
            $mp = Amavis::IO::Zlib->new; # ?how to request an exclusive access?
            $mp->open($mbxname,'wb')
              or die "Can't create gzip file $mbxname: $!";
          } else {
            $mp = IO::File->new;
            # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
            $mp->open($mbxname, untaint(O_CREAT|O_EXCL|O_WRONLY), 0640)
              or die "Can't create file $mbxname: $!";
            binmode($mp,':bytes') or die "Can't cancel :utf8 mode: $!";
          }
        } else {  # append to a UNIX-style mailbox
                  # deliver only to non-executable regular files
          if ($errn == ENOENT) {
            # if two processes try creating the same new UNIX-style mailbox
            # file at the same time, one will tempfail at this point, with
            # its mail delivery to be retried later by MTA
            $mp = IO::File->new;
            # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
            $mp->open($mbxname, untaint(O_CREAT|O_EXCL|O_APPEND|O_WRONLY),0640)
              or die "Can't create file $mbxname: $!";
          } elsif ($errn==0 && !-f _) {
            die "Mailbox $mbxname is not a regular file, refuse to deliver";
          } elsif (-x _ || -X _) {
            die "Mailbox file $mbxname is executable, refuse to deliver";
          } else {
            $mp = IO::File->new;
            # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
            $mp->open($mbxname, untaint(O_APPEND|O_WRONLY), 0640)
              or die "Can't append to $mbxname: $!";
          }
          binmode($mp,':bytes') or die "Can't cancel :utf8 mode: $!";
          flock($mp,LOCK_EX) or die "Can't lock mailbox file $mbxname: $!";
          $mp->seek(0,2) or die "Can't position mailbox file to its tail: $!";
          $pos = $mp->tell;  # remember where we started
        }
        section_time('open-mbx');
        1;
      } or do {
        $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        $smtp_response =
          $eval_stat =~ /^timed out\b/ ? "450 4.4.2" : "451 4.5.0";
        $smtp_response .= " Local delivery(1) to $mbxname failed: $eval_stat";
        die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
      };
      last  if defined $eval_stat;  # exit block, not the loop
      my $failed = 0;  $eval_stat = undef;
      eval {  # if things fail from here on, try to restore mailbox state
        if ($ux) {
          # a null return path may not appear in the 'From ' delimiter line
          my $snd = $sender eq '' ? 'MAILER-DAEMON' # as in sendmail & Postfix
                                  : $msginfo->sender_smtp;
          # if the envelope sender contains spaces, tabs, or newlines,
          # the program (like qmail-local) replaces them with hyphens
          $snd =~ s/[ \t\n]/-/sg;
          # date/time in asctime (ctime) format, English month names!
          # RFC 4155 and qmail-local require UTC time, no timezone name
          $mp->printf("From %s %s\n", $snd, scalar gmtime($msginfo->rx_time) )
            or die "Can't write mbox separator line to $mbxname: $!";
        }
        my $hdr_edits = $msginfo->header_edits;
        if (!$hdr_edits) {
          $hdr_edits = Amavis::Out::EditHeader->new;
          $msginfo->header_edits($hdr_edits);
        }
        $hdr_edits->delete_header('Return-Path');
        $hdr_edits->prepend_header('Delivered-To', join(', ',@recips));
        $hdr_edits->prepend_header('Return-Path', $msginfo->sender_smtp);
        my($received_cnt,$file_position) =
          $hdr_edits->write_header($msginfo,$mp,!$initial_submission);
        if ($received_cnt > 110) {
          # loop detection required by RFC 5321 (ex RFC 2821) section 6.3
          # Do not modify the signal text, it gets matched elsewhere!
          die "Too many hops: $received_cnt 'Received:' header fields\n";
        }
        my $msg = $msginfo->mail_text;
        my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
        $msg = $msg_str_ref  if ref $msg_str_ref;
        if (!$ux) {  # do it in blocks for speed if we can
          if (!defined $msg) {
            # empty mail
          } elsif (ref $msg eq 'SCALAR') {
            $mp->print(substr($$msg,$file_position))
              or die "Can't write to $mbxname: $!";
          } elsif ($msg->isa('MIME::Entity')) {
            die "quarantining a MIME::Entity object is not implemented";
          } else {
            my($nbytes,$buff);
            while (($nbytes = $msg->read($buff,32768)) > 0) {
              $mp->print($buff) or die "Can't write to $mbxname: $!";
            }
            defined $nbytes or die "Error reading: $!";
          }
        } else {     # for UNIX-style mailbox file delivery: escape 'From '
          # mail(1) and elm(1) recognize /^From / as a message delimiter
          # only after a blank line, which is correct. Other MUAs like mutt,
          # thunderbird, kmail and pine need all /^From / lines escaped.
          # See also http://en.wikipedia.org/wiki/Mbox and RFC 4155.
          if (!defined $msg) {
            # empty mail
          } elsif (ref $msg eq 'SCALAR') {
            my $buff = substr($$msg,$file_position);
          # $buff =~ s/^From />From /gm;   # mboxo  format
            $buff =~ s/^(?=\>*From )/>/gm; # mboxrd format
            $mp->print($buff) or die "Can't write to $mbxname: $!";
          } elsif ($msg->isa('MIME::Entity')) {
            die "quarantining a MIME::Entity object is not implemented";
          } else {
            my $ln; my $blank_line = 1;
            # need to copy line-by-line, slow
            for ($! = 0; defined($ln=$msg->getline); $! = 0) {
              # see wikipedia and RFC 4155 for "From " escaping conventions
              $mp->print('>') or die "Can't write to $mbxname: $!"
                if $ln =~ /^(?:>*)From /;        # escape all "From " lines
              # if $blank_line && $ln =~ /^(?:>*)From /; # only after blankline
              $mp->print($ln) or die "Can't write to $mbxname: $!";
              $blank_line = $ln eq "\n";
            }
            defined $ln || $! == 0  or die "Error reading: $!";
          }
        }
        # must append an empty line for a Unix mailbox format
        $mp->print("\n") or die "Can't write to $mbxname: $!"  if $ux;
        1;
      } or do {  # trouble
        $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        if ($ux && defined($pos)) {
          $mp->flush or die "Can't flush file $mbxname: $!";
          $can_truncate or
            do_log(-1, "Truncating a mailbox file will most likely fail");
          # try to restore UNIX-style mailbox to previous size;
          # Produces a fatal error if truncate isn't implemented on the system
          $mp->truncate($pos) or die "Can't truncate file $mbxname: $!";
        }
        $failed = 1;
        die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
      };
    # if ($ux) {
    #   # explicit unlocking is unnecessary, close will do a flush & unlock
    #   $mp->flush or die "Can't flush mailbox file $mbxname: $!";
    #   flock($mp,LOCK_UN) or die "Can't unlock mailbox $mbxname: $!";
    # }
      $mp->close or die "Error closing $mbxname: $!";
      undef $mp;
      if (!$failed) {
        $smtp_response = "250 2.6.0 Ok, delivered to $mbxname";
        snmp_count('OutMsgsDelivers');
        my $size = $msginfo->msg_size;
        snmp_count( ['OutMsgsSize'.$_, $size, 'C64'] )  for @snmp_vars;
      } elsif ($@ =~ /^timed out\b/) {
        $smtp_response = "450 4.4.2 Local delivery to $mbxname timed out";
        snmp_count('OutMsgsAttemptFails');
      } elsif ($@ =~ /too many hops\b/i) {
        $smtp_response = "554 5.4.6 Rejected delivery to mailbox $mbxname: $@";
        snmp_count('OutMsgsRejects');
      } else {
        $smtp_response = "451 4.5.0 Local delivery to mailbox $mbxname ".
                         "failed: $@";
        snmp_count('OutMsgsAttemptFails');
      }
    }  # end of block, 'last' within the block brings us here
    do_log(-1, "%s", $smtp_response)  if $smtp_response !~ /^2/;
    $smtp_response .= ", id=" . $msginfo->log_id;
    for my $r (@recips_with_same_mbx) {
      $r->recip_smtp_response($smtp_response); $r->recip_done(2);
      $r->recip_mbxname($smtp_response =~ /^2/ ? $mbxname : undef);
    }
  }
  section_time('save-to-local-mailbox');
}

1;

__DATA__
#
package Amavis::OS_Fingerprint;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

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

use Errno qw(EINTR EAGAIN);
use Socket;
use IO::Socket::UNIX;
#use IO::Socket::INET;
use Time::HiRes ();

sub new {
  my($class, $service_method,$timeout,
     $src_ip,$src_port, $dst_ip,$dst_port, $nonce) = @_;
  local($1,$2,$3); my($service_host, $service_port, $service_path);
  if ($service_method =~
      m{^p0f: (?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*) }six) {
    ($service_host, $service_port) = ($1.$2, $3);
  } elsif ($service_method =~
      m{^p0f: ( / [^ ]+ ) \z}six) {  # looks like a unix socket
    $service_path = $1;
  } else {
    die "Bad p0f method syntax: $service_method";
  }
  $dst_ip = '0.0.0.0'  if !defined $dst_ip;         # our MTA's IP address
  $dst_port = defined $dst_port ? 0+$dst_port : 0;  # our MTA port, usually 25
  $src_port = defined $src_port ? 0+$src_port : 0;  # remote client's port no.
  do_log(4,"Fingerprint query: [%s]:%s %s %s",
           $src_ip, $src_port, $nonce, $service_method);
  my $sock; my $query; my $query_sent = 0;
  # send a UDP query to p0f-analyzer
  $query = '['.$src_ip.']' . ($src_port==0 ? '' : ':'.$src_port);
  if (defined $service_path) {
    $sock = IO::Socket::UNIX->new(Type => SOCK_DGRAM, Peer => $service_path);
    $sock or do_log(0,"Can't connect to a Unix socket %s: %s",
                       $service_path, $!);
  } else {  # assume an INET or INET6 protocol family
    $service_host = idn_to_ascii($service_host);
    $sock = $io_socket_module_name->new(
              Type => SOCK_DGRAM, Proto => 'udp',
              PeerAddr => $service_host, PeerPort => $service_port);
    $sock or do_log(0,"Can't create a socket [%s]:%s: %s",
                       $service_host, $service_port, $!);
  }
  if ($sock) {
    defined $sock->syswrite("$query $nonce")
      or do_log(0, "Fingerprint - error sending a query: %s", $!);
    $query_sent = 1;
  }
  return  if !$query_sent;
  bless { sock => $sock, wait_until => (Time::HiRes::time + $timeout),
          query => $query, nonce => $nonce }, $class;
}

sub collect_response {
  my $self = $_[0];
  my $timeout = $self->{wait_until} - Time::HiRes::time;
  if ($timeout < 0) { $timeout = 0 };
  my $sock = $self->{sock};
  my($resp,$nfound,$inbuf);
  my($rin,$rout); $rin = ''; vec($rin,fileno($sock),1) = 1;
  for (;;) {
    $nfound = select($rout=$rin, undef, undef, $timeout);
    last  if !$nfound || $nfound < 0;
    my $rv = $sock->sysread($inbuf,1024);
    if (!defined $rv) {
      if ($! == EAGAIN || $! == EINTR) {
        Time::HiRes::sleep(0.1);  # slow down, just in case
      } else {
        do_log(2, "Fingerprint - error reading from socket: %s", $!);
      }
    } elsif (!$rv) {  # sysread returns 0 at eof
      last;
    } else {
      local($1,$2,$3);
      if ($inbuf =~ /^([^ ]*) ([^ ]*) (.*)\015\012\z/) {
        my($r_query,$r_nonce,$r_resp) = ($1,$2,$3);
        if ($r_query eq $self->{query} && $r_nonce eq $self->{nonce})
          { $resp = $r_resp };
      }
      do_log(4,"Fingerprint collect: max_wait=%.3f, %.35s... => %s",
               $timeout,$inbuf,$resp);
      $timeout = 0;
    }
  }
  defined $nfound && $nfound >= 0
    or die "Fingerprint - select on socket failed: $!";
  $sock->close  or die "Error closing socket: $!";
  $resp;
}

1;

__DATA__
#^L
package Amavis::TinyRedis;

use strict;
use re 'taint';
use warnings;
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

use Errno qw(EINTR EAGAIN EPIPE ENOTCONN ECONNRESET ECONNABORTED);
use IO::Socket::UNIX;
use Time::HiRes ();

use vars qw($VERSION);
BEGIN {
  $VERSION = '1.000';
  import Amavis::Conf qw(:platform);  # $io_socket_module_name
}

sub new {
  my($class, %args) = @_;
  my $self = bless { args => {%args} }, $class;
  my $outbuf = ''; $self->{outbuf} = \$outbuf;
  $self->{batch_size} = 0;
  $self->{server} = $args{server} || $args{sock} || '127.0.0.1:6379';
  $self->{on_connect} = $args{on_connect};
  return if !$self->connect;
  $self;
}

sub DESTROY {
  my $self = $_[0];
  local($@, $!, $_);
  undef $self->{sock};
}

sub disconnect {
  my $self = $_[0];
  local($@, $!);
  undef $self->{sock};
}

sub connect {
  my $self = $_[0];

  $self->disconnect;
  my $sock;
  my $server = $self->{server};
  if ($server =~ m{^/}) {
    $sock = IO::Socket::UNIX->new(
              Peer => $server, Type => SOCK_STREAM);
  } elsif ($server =~ /^(?: \[ ([^\]]+) \] | ([^:]+) ) : ([^:]+) \z/xs) {
    $server = defined $1 ? $1 : $2;  my $port = $3;
    $sock = $io_socket_module_name->new(
              PeerAddr => $server, PeerPort => $port, Proto => 'tcp');
  } else {
    die "Invalid 'server:port' specification: $server";
  }
  if ($sock) {
    $self->{sock} = $sock;

    $self->{sock_fd} = $sock->fileno; $self->{fd_mask} = '';
    vec($self->{fd_mask}, $self->{sock_fd}, 1) = 1;

    # an on_connect() callback must not use batched calls!
    $self->{on_connect}->($self)  if $self->{on_connect};
  }
  $sock;
}

# Receive, parse and return $cnt consecutive redis replies as a list.
#
sub _response {
  my($self, $cnt) = @_;

  my $sock = $self->{sock};
  if (!$sock) {
    $self->connect  or die "Connect failed: $!";
    $sock = $self->{sock};
  };

  my @list;

  for (1 .. $cnt) {

    my $result = <$sock>;
    if (!defined $result) {
      $self->disconnect;
      die "Error reading from Redis server: $!";
    }
    chomp $result;
    my $resp_type = substr($result, 0, 1, '');

    if ($resp_type eq '$') {  # bulk reply
      if ($result < 0) {
        push(@list, undef);  # null bulk reply
      } else {
        my $data = ''; my $ofs = 0; my $len = $result + 2;
        while ($len > 0) {
          my $nbytes = read($sock, $data, $len, $ofs);
          if (!$nbytes) {
            $self->disconnect;
            defined $nbytes  or die "Error reading from Redis server: $!";
            die "Redis server closed connection";
          }
          $ofs += $nbytes; $len -= $nbytes;
        }
        chomp $data;
        push(@list, $data);
      }

    } elsif ($resp_type eq ':') {  # integer reply
      push(@list, 0+$result);

    } elsif ($resp_type eq '+') {  # status reply
      push(@list, $result);

    } elsif ($resp_type eq '*') {  # multi-bulk reply
      push(@list, $result < 0 ? undef : $self->_response(0+$result) );

    } elsif ($resp_type eq '-') {  # error reply
      die "$result\n";

    } else {
      die "Unknown Redis reply: $resp_type ($result)";
    }
  }
  \@list;
}

sub _write_buff {
  my($self, $bufref) = @_;

  if (!$self->{sock}) { $self->connect or die "Connect failed: $!" };
  my $nwrite;
  for (my $ofs = 0; $ofs < length($$bufref); $ofs += $nwrite) {
    # to reliably detect a disconnect we need to check for an input event
    # using a select; checking status of syswrite is not sufficient
    my($rout, $wout, $inbuff); my $fd_mask = $self->{fd_mask};
    my $nfound = select($rout=$fd_mask, $wout=$fd_mask, undef, undef);
    defined $nfound && $nfound >= 0 or die "Select failed: $!";
    if (vec($rout, $self->{sock_fd}, 1) &&
        !sysread($self->{sock}, $inbuff, 1024)) {
      # eof, try reconnecting
      $self->connect  or die "Connect failed: $!";
    }
    local $SIG{PIPE} = 'IGNORE';  # don't signal on a write to a widowed pipe
    $nwrite = syswrite($self->{sock}, $$bufref, length($$bufref)-$ofs, $ofs);
    next if defined $nwrite;
    $nwrite = 0;
    if ($! == EINTR || $! == EAGAIN) {  # no big deal, try again
      Time::HiRes::sleep(0.1);  # slow down, just in case
    } else {
      $self->disconnect;
      if ($! == ENOTCONN   || $! == EPIPE ||
          $! == ECONNRESET || $! == ECONNABORTED) {
        $self->connect  or die "Connect failed: $!";
      } else {
        die "Error writing to redis socket: $!";
      }
    }
  }
  1;
}

# Send a redis command with arguments, returning a redis reply.
#
sub call {
  my $self = shift;

  my $buff = '*' . scalar(@_) . "\015\012";
  $buff .= '$' . length($_) . "\015\012" . $_ . "\015\012"  for @_;

  $self->_write_buff(\$buff);
  local($/) = "\015\012";
  my $arr_ref = $self->_response(1);
  $arr_ref && $arr_ref->[0];
}

# Append a redis command with arguments to a batch.
#
sub b_call {
  my $self = shift;

  my $bufref = $self->{outbuf};
  $$bufref .= '*' . scalar(@_) . "\015\012";
  $$bufref .= '$' . length($_) . "\015\012" . $_ . "\015\012"  for @_;
  ++ $self->{batch_size};
}

# Send a batch of commands, returning an arrayref of redis replies,
# each array element corresponding to one command in a batch.
#
sub b_results {
  my $self = $_[0];
  my $batch_size = $self->{batch_size};
  return if !$batch_size;
  my $bufref = $self->{outbuf};
  $self->_write_buff($bufref);
  $$bufref = ''; $self->{batch_size} = 0;
  local($/) = "\015\012";
  $self->_response($batch_size);
}

1;


package Amavis::Redis;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Util qw(ll do_log do_log_safe min max minmax untaint
                         safe_encode safe_encode_utf8 idn_to_ascii
                         format_time_interval unique_list snmp_count);
  import Amavis::Lookup::IP qw(lookup_ip_acl normalize_ip_addr);
  import Amavis::Timing qw(section_time);
}

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

sub disconnect {
  my $self = $_[0];
# do_log(5, "redis: disconnect");
  $self->{connected} = 0; undef $self->{redis};
}

sub on_connect {
  my($self, $r) = @_;
  my $db_id = $self->{db_id} || 0;
  do_log(5, "redis: on_connect, db_id %d", $db_id);
  eval {
    $r->call('SELECT', $db_id) eq 'OK' ? 1 : 0;
  } or do {
    if ($@ =~ /^NOAUTH\b/ || $@ =~ /^ERR operation not permitted/) {
      defined $self->{password}
        or die "Redis server requires authentication, no password provided";
      $r->call('AUTH', $self->{password});
      $r->call('SELECT', $db_id);
    } else {
      chomp $@; die "Command 'SELECT $db_id' failed: $@";
    }
  };
  eval {
    $r->call('CLIENT', 'SETNAME', 'amavis['.$$.']') eq 'OK' ? 1 : 0;
  } or do {  # no big deal, just log
    do_log(5, "redis: command 'CLIENT SETNAME' failed: %s", $@);
  };
  1;
}

sub connect {
  my $self = $_[0];
# do_log(5, "redis: connect");
  $self->disconnect  if $self->{connected};
  $self->{redis} = $self->{db_id} = $self->{ttl} = undef;

  my($r, $err, $dsn, %options);
  my $dsn_list_ref = $self->{redis_dsn};
  for my $j (1 .. @$dsn_list_ref) {
    $dsn = $dsn_list_ref->[0];
    %options = ref $dsn eq 'HASH' ? %$dsn : ();
    # expiration time (time-to-live) is 16 days by default
    $self->{ttl} = exists $options{ttl} ? $options{ttl} : $storage_redis_ttl;
    $self->{db_id} = $options{db_id};
    if (defined $options{password}) {
      $self->{password} = $options{password};
      $options{password} = '(hidden)';  # for logging purposes
    }
    undef $err;
    eval {
      my %opt = %options; delete @opt{qw(ttl db_id password)};
      $opt{server} = idn_to_ascii($opt{server})  if defined $opt{server};
      $r = Amavis::TinyRedis->new(on_connect => sub { $self->on_connect(@_) },
                                  %opt);
      $r or die "Error: $!";
    } or do {
      undef $r; $err = $@; chomp $err;
    };
    $self->{redis} = $r;
    last if $r;  # success, done
    if ($j < @$dsn_list_ref) {  # not all tried yet
      do_log(0, "Can't connect to a redis server, %s: %s; trying next",
                 join(' ',%options), $err);
      push(@$dsn_list_ref, shift @$dsn_list_ref);  # rotate left
    }
  }
  if (!$r) {
    $self->{redis} = $self->{db_id} = $self->{ttl} = undef;
    die sprintf("Can't connect to a redis server %s: %s\n",
                join(' ',%options), $err);
  }
  $self->{connected} = 1;
  ll(5) && do_log(5, "redis: connected to: %s, ttl %s s",
                  !defined $options{server} ? 'default server'
                                            : join(' ',%options),
                  $self->{ttl}||'x');
  section_time("redis-connect");
  $self->load_lua_programs;
  $r;
}

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  do_log_safe(5,"Amavis::Redis DESTROY called");
  # ignore potential errors during DESTROY of a Redis object
  eval { $self->{connected} = 0; undef $self->{redis} };
}

# find a penpals record which proves that a local user (sender) really sent a
# mail to a given recipient some time ago. Returns an interval time in seconds
# since the last such mail was sent by our local user to a specified recipient
# (or undef if information is not available).  If @$message_id_list is a
# nonempty list of Message-IDs as found in References header field, the query
# also finds previous outgoing messages with a matching Message-ID but
# possibly to recipients different from what the mail was originally sent to.
#
sub penpals_find {
  my($self, $msginfo, $message_id_list) = @_;

  my $sender = $msginfo->sender;
  $message_id_list = []  if !$message_id_list;
  return if !@$message_id_list && $sender eq '';

  # inbound or internal_to_internal, except self_to_self
  my(@per_recip_data) = grep(!$_->recip_done && $_->recip_is_local &&
                             lc($sender) ne lc($_->recip_addr),
                             @{$msginfo->per_recip_data});
  return if !@per_recip_data;

# do_log(5, "redis: penpals_find");
  snmp_count('PenPalsAttempts');

  my $sender_smtp = $msginfo->sender_smtp;
  local($1); $sender_smtp =~ s/^<(.*)>\z/$1/s;
  my(@recip_addresses) =
    map { my $a = $_->recip_addr_smtp; $a =~ s/^<(.*)>\z/$1/s; lc $a }
        @per_recip_data;

  # NOTE: swap recipient and sender in a query 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:

  # no need for cryptographical strength, just checking for protocol errors
  my $nonce = $msginfo->mail_id;
  my $result;
  my @args = (
    0, sprintf("%.0f",$msginfo->rx_time), $nonce, lc $sender_smtp,
    scalar @recip_addresses, @recip_addresses,
    scalar @$message_id_list, @$message_id_list,
  );
  eval {
    $self->connect  if !$self->{connected};
    $result =
      $self->{redis}->call('EVALSHA', $self->{lua_query_penpals}, @args);
    1;
  } or do {  # Lua function probably not cached, define again and re-try
    if ($@ !~ /^NOSCRIPT/) {
      $self->disconnect; undef $result; chomp $@;
      do_log(-1, 'penpals_find, Redis Lua error: %s', $@);
    } else {
      $self->load_lua_programs;
      $result =
        $self->{redis}->call('EVALSHA', $self->{lua_query_penpals}, @args);
    }
  };

  my $ok = 1;
  if (!$result || !@$result) {
    $ok = 0; $self->disconnect;
    do_log(0, "redis: penpals_find - no results");
  } else {
    my $r_nonce = pop(@$result);
    if (!defined($r_nonce) || $r_nonce ne $nonce) {
      # redis protocol falling out of step?
      $ok = 0; $self->disconnect;
      do_log(-1,"redis: penpals_find - nonce mismatch, expected %s, got %s",
                 $nonce, defined $r_nonce ? $r_nonce : 'UNDEF');
    }
  }
  if ($ok && (@$result != @per_recip_data)) {
    $ok = 0; $self->disconnect;
    do_log(-1,"redis: penpals_find - number of results expected %d, got %d",
              scalar @per_recip_data, scalar @$result);
  }
  if ($ok) {
    for my $r (@per_recip_data) {
      my $result_entry = shift @$result;
      next if !$result_entry;
      my($sid, $rid, $send_time, $best_ref_mail_id, $report) = @$result_entry;
      if (!$send_time) {  # undef or empty (or zero)
        snmp_count('PenPalsMisses');
        ll(4) && do_log(4, "penpals: (redis) not found (%s,%s)%s%s",
                   $sid ? $sid : $r->recip_addr_smtp,
                   $rid ? $rid : $msginfo->sender_smtp,
                   !$report ? '' : ', refs: '.$report,
                   !@$message_id_list ? '' :
                                        '; '.join(', ',@$message_id_list) );
      } else {  # found a previous related correspondence
        snmp_count('PenPalsHits');
        my $age = max(0, $msginfo->rx_time - $send_time);
        $r->recip_penpals_age($age);
        $r->recip_penpals_related($best_ref_mail_id);
        ll(3) && do_log(3, "penpals: (redis) found (%s,%s) age %s%s",
                   $sid ? $sid : $r->recip_addr_smtp,
                   $rid ? $rid : $msginfo->sender_smtp,
                   format_time_interval($age),
                   !$report ? '' : ', refs: '.$report );
        # $age and $best_ref_mail_id are not logged explicitly,
        # as they can be seen in the first entry of a lua query report
        # (i.e. the last string)
      }
    }
  }
  $ok;
}

sub save_info_preliminary {
  my($self, $msginfo) = @_;

  my $mail_id = $msginfo->mail_id;
  defined $mail_id  or die "save_info_preliminary: mail_id still undefined";

  $self->connect  if !$self->{connected};
  ll(5) && do_log(5, 'redis: save_info_preliminary: %s, %s, ttl %s s',
                  $mail_id, int $msginfo->rx_time, $self->{ttl}||'x');

  # use Lua to do HSETNX *and* EXPIRE atomically, otherwise we risk inserting
  # a key with no expiration time if redis server goes down inbetween
  my $added;
  my $r = $self->{redis};
  my(@args) = (1, $mail_id,  int $msginfo->rx_time,
               $self->{ttl} ? int $self->{ttl} : 0);
  eval {
    $added = $r->call('EVALSHA', $self->{lua_save_info_preliminary}, @args);
    1;
  } or do {  # Lua function probably not cached, define again and re-try
    if ($@ !~ /^NOSCRIPT/) {
      $self->disconnect; chomp $@;
      do_log(-1, 'save_info_preliminary, Redis Lua error: %s', $@);
    } else {
      $self->load_lua_programs;
      $added = $r->call('EVALSHA', $self->{lua_save_info_preliminary}, @args);
    }
  };
  $self->disconnect  if !$database_sessions_persistent;
  $added;  # 1 if added successfully, false otherwise
}

sub query_and_update_ip_reputation {
  my($self, $msginfo) = @_;

  my $ip_trace_ref = $msginfo->ip_addr_trace_public;
  return if !$ip_trace_ref;
  my @ip_trace = unique_list($ip_trace_ref);
  return if !@ip_trace;

  # Irwin-Hall distribution - approximates normal distribution
  # n = 4, mean = n/2, variance = n/12, sigma = sqrt(n/12) =~ 0.577
  my $normal_random = (rand() + rand() + rand() + rand() - 2) / 0.577;

  my(@args) = (scalar @ip_trace, map("ip:$_",@ip_trace),
               sprintf("%.3f", $msginfo->rx_time),
               sprintf("%.6f", $normal_random) );
  my($r, $ip_stats);
  eval {
    $self->connect  if !$self->{connected};
    $r = $self->{redis};
    $ip_stats = $r->call('EVALSHA', $self->{lua_query_and_update_ip}, @args);
    1;
  } or do {  # Lua function probably not cached, define again and re-try
    if ($@ !~ /^NOSCRIPT/) {
      $self->disconnect; chomp $@;
      do_log(-1, "query_and_update_ip_reputation, Redis Lua error: %s", $@);
    } else {
      $self->load_lua_programs;
      $ip_stats = $r->call('EVALSHA', $self->{lua_query_and_update_ip}, @args);
    }
  };
  my($highest_score, $worst_ip);
  for my $entry (!$ip_stats ? () : @$ip_stats) {
    my($ip, $n_all, $s, $h, $b, $tfirst, $tlast, $ttl) = @$entry;
    $ip =~ s/^ip://s;  # strip key prefix
    # the current event is not yet counted nor classified
    if ($n_all <= 0) {
      do_log(5, "redis: IP %s ttl: %.1f h", $ip, $ttl/3600);
    } else {
      my $n_other = $n_all - ($s + $h + $b);
      if ($n_other < 0) { $n_all = $s + $h + $b; $n_other = 0 }  # just in case
      my $bad_content_ratio = ($s+$b) / $n_all;
      # gains strength by the number of samples, watered down by share of ham
      my $score = !($s+$b) ? 0 : 0.9 * ($n_all**0.36) * exp(-6 * $h/$n_all);

      my $ip_ignore;
      if ($score >= 0.05) {
        # it is cheaper to do a redis/lookup unconditionally,
        # then ditch an ignored IP address later if necessary
        my($key, $err);
        ($ip_ignore, $key, $err) =
          lookup_ip_acl($ip, @{ca('ip_repu_ignore_maps')});
        undef $ip_ignore if $err;
      }
      my $ll = ($score <= 0 || $ip_ignore) ? 3 : 2;  # log level
      if (ll($ll)) {
        my $rxtime = $msginfo->rx_time;
        do_log($ll, "redis: IP %s age: %s%s, ttl: %.1f h, %s, %s%s",
          $ip, format_time_interval($rxtime-$tfirst),
          defined $tlast ? ', last: '.format_time_interval($rxtime-$tlast) :'',
          $ttl/3600,
          $n_other ?
            ($b ? "s/h/bv/?: $s/$h/$b/$n_other" : "s/h/?: $s/$h/$n_other")
          : ($b ? "s/h/bv: $s/$h/$b"            : "s/h: $s/$h"),
          $score <= 0 ? 'clean' : sprintf("%.0f%%, score: %.1f",
                                          100*$bad_content_ratio, $score),
          $ip_ignore ? ' =>0 ip_repu_ignore' : '');
      }
      $score = 0  if $ip_ignore || $score < 0.05;
      if (!defined $highest_score || $score > $highest_score) {
        $highest_score = $score; $worst_ip = $ip;
      }
    }
  }
  $self->disconnect  if !$database_sessions_persistent;
  ($highest_score, $worst_ip);
}

sub save_structured_report {
  my($self, $report_ref, $log_key, $queue_size_limit) = @_;
  return if !$report_ref;
  $self->connect  if !$self->{connected};
  my $r = $self->{redis};
  my $report_json = Amavis::JSON::encode($report_ref);  # as string of chars
  # use safe_encode() instead of safe_encode_utf8() here, this way we ensure
  # the resulting string of octets is always a valid UTF-8, even in case
  # of a non-ASCII input string with utf8 flag off
  $report_json = safe_encode('UTF-8', $report_json);  # convert to octets
  do_log(5, "redis: structured_report: %s %s", $log_key, $report_json);
  $r->b_call("RPUSH", $log_key, $report_json);
  # keep most recent - queue size limit in case noone is pulling events
  $r->b_call("LTRIM", $log_key, -$queue_size_limit, -1) if $queue_size_limit;
  my $res = $r->b_results;  # errors will be signalled
  do_log(5, "redis: save_structured_report, %d bytes, q_lim=%s, q_size=%s",
            length $report_json, $queue_size_limit || 0,
            $res ? join(', ',@$res) : '?')  if ll(5);
  1;
}

sub save_info_final {
  my($self, $msginfo, $report_ref) = @_;

  $self->connect  if !$self->{connected};
  my $r = $self->{redis};

  if (c('enable_ip_repu')) {
    my $rigm = ca('ip_repu_ignore_maps');
    my $ip_trace_ref = $msginfo->ip_addr_trace_public;
    my @ip_trace;
    @ip_trace = grep { my($ignore, $key, $err) = lookup_ip_acl($_, @$rigm);
                       !$ignore || $err;
                     } unique_list($ip_trace_ref)  if $ip_trace_ref;
    if (@ip_trace) {
      my $content =
        $msginfo->is_in_contents_category(CC_VIRUS)  ? 'b' :
        $msginfo->is_in_contents_category(CC_BANNED) ? 'b' : undef;
      if (!defined $content) {  # test for ham or spam
        my($min, $max);
        for my $r (@{$msginfo->per_recip_data}) {
          my $spam_level = $r->spam_level;
          next if !defined $spam_level;
          $max = $spam_level  if !defined $max || $spam_level > $max;
          $min = $spam_level  if !defined $min || $spam_level < $min;
        }
        if (defined $min) {
          my $ip_repu_score = $msginfo->ip_repu_score || 0;  # positive or 0
          # avoid self-reinforcing feedback in the IP reputation auto-learning,
          # use the score without the past IP reputation contribution
          if    ($max - $ip_repu_score <  0.5) { $content = 'h' }
          elsif ($min - $ip_repu_score >= 5)   { $content = 's' }
        }
      }
      if (!defined $content) {
        # just increment the total counter
        $r->b_call("HINCRBY", "ip:$_", 'n', 1) for @ip_trace;
        $r->b_results;
        if (ll(5)) { do_log(5,"redis: IP INCR %s", $_) for @ip_trace }
      } else {
        # content type is known
        for (@ip_trace) {
          $r->b_call("HINCRBY", "ip:$_", 'n', 1);
          $r->b_call("HINCRBY", "ip:$_", $content, 1);
        }
        my $counts = $r->b_results;
        if (ll(5) && $counts) {
          do_log(5,"redis: IP INCR %s n=%d, %s=%d",
                 $_, shift @$counts, $content, shift @$counts) for @ip_trace;
        }
      }
    }
  }

  if (!$msginfo->originating) {
    # don't bother saving info on incoming messages, saves Redis storage
    # while still offering necessary data for a pen pals function
    $self->disconnect  if !$database_sessions_persistent;
    return;
  }

  my $mail_id = $msginfo->mail_id;
  defined $mail_id  or die "save_info_preliminary: mail_id still undefined";

  my $sender_smtp = $msginfo->sender_smtp;
  local($1); $sender_smtp =~ s/^<(.*)>\z/$1/s;

  my(@recips);  # only recipients which did receive a message
  for my $r (@{$msginfo->per_recip_data}) {
    my($dest, $resp) = ($r->recip_destiny, $r->recip_smtp_response);
    next if $dest != D_PASS || ($r->recip_done && $resp !~ /^2/);
    my $addr_smtp = $r->recip_addr_smtp;
    next if !defined $addr_smtp;
    local($1); $addr_smtp =~ s/^<(.*)>\z/$1/s;
    # don't remember messages sent to self
    next if lc($sender_smtp) eq lc($addr_smtp);
    # don't remember problematic outgoing messages, even if delivered
    next if $r->is_in_contents_category(CC_VIRUS)  ||
            $r->is_in_contents_category(CC_BANNED) ||
            $r->is_in_contents_category(CC_SPAM)   ||  # kill_level
            $r->is_in_contents_category(CC_SPAMMY);    # tag2_level
    push(@recips, lc $addr_smtp);
  }

  my $m_id = $msginfo->get_header_field_body('message-id');
  $m_id = join(' ',parse_message_id($m_id))
    if defined $m_id && $m_id ne '';  # strip CFWS
  my(@args) = map(defined $_ ? $_ : '',  # avoid nil in a Lua table
                   ($self->{ttl}, $msginfo->log_id,
                    $m_id, $msginfo->client_addr, lc $sender_smtp, @recips) );
  if (!@recips) {
    do_log(5,"redis: save_info_final: %s deleted", $mail_id);
  } elsif (ll(5)) {
    do_log(5,"redis: save_info_final: %s, passed %d of %d recips, %s",
             $mail_id, scalar @recips, scalar @{$msginfo->per_recip_data},
             join(', ',@args));
  }
  my $result;
  eval {
    $result = $r->call('EVALSHA', $self->{lua_save_final},
                       1, $mail_id, @args);
    1;
  } or do {  # Lua function probably not cached, define again and re-try
    if ($@ !~ /^NOSCRIPT/) {
      $self->disconnect; undef $result; chomp $@;
      do_log(-1, "save_info_final, Redis Lua error: %s", $@);
    } else {
      $self->load_lua_programs;
      $result = $r->call('EVALSHA', $self->{lua_save_final},
                         1, $mail_id, @args);
    }
  };

  my $ok = 1;
  my $r_nonce = $result;
  if (!defined($r_nonce) || $r_nonce ne $mail_id) {
    # redis protocol falling out of step?
    $ok = 0; $self->disconnect;
    do_log(-1,"redis: save_info_final - nonce mismatch, expected %s, got %s",
               $mail_id, defined $r_nonce ? $r_nonce : 'UNDEF');
  }
  # $r->call("EVAL", 'collectgarbage()', 0);
  $self->disconnect  if !$database_sessions_persistent;
  $ok;
}

sub load_lua_programs($) {
  my $self = $_[0];
  do_log(5, "redis: load_lua_programs");
  my $r = $self->{redis};

  eval {
    $self->{lua_save_info_preliminary} = $r->call('SCRIPT', 'LOAD', <<'END');
--LUA_SAVE_INFO_PRELIMINARY
    local rcall, tonumber = redis.call, tonumber
    local mail_id, rx_time, ttl = KEYS[1], ARGV[1], ARGV[2]

    -- ensure the mail_id is unique, report false otherwise
    local added = rcall("HSETNX", mail_id, "time", rx_time)
    if added == 1 and ttl and tonumber(ttl) > 0 then
      if rcall("EXPIRE", mail_id, ttl) ~= 1 then
        return { err = "Failed to set EXPIRE on key " .. mail_id }
      end
    end
    return added  -- 1:yes, 0:no,failed
END
  } or do {
    $self->disconnect; die "Redis LUA error - lua_save_info_preliminary: $@\n"
  };

  eval {
    $self->{lua_save_final} = $r->call('SCRIPT', 'LOAD', <<'END');
--LUA_SAVE_FINAL
    local mail_id = KEYS[1]
    local rcall = redis.call
    local ARGV = ARGV

    -- not delivered to any recipient, just delete the useless record
    if #ARGV < 6 then
      rcall("DEL", mail_id)

    else
      local ttl, log_id, msgid, client_addr, sender = unpack(ARGV,1,5)
      local tonumber, unpack = tonumber, unpack
      if not tonumber(ttl) or tonumber(ttl) <= 0 then ttl = nil end

      local addresses = { [sender] = true }
      -- remaining arguments 6 to #ARGV are recipient addresses
      for r = 6, #ARGV do addresses[ARGV[r]] = true end

      -- create mail address -> id mapping
      for addr in pairs(addresses) do
        local addr_key = "a:" .. addr
        local addr_id
        if not ttl then
          addr_id = rcall("GET", addr_key)
        else
          -- to avoid potential race between GET and EXPIRE, set EXPIRE first
          local refreshed = rcall("EXPIRE", addr_key, ttl)
          if refreshed == 1 then addr_id = rcall("GET", addr_key) end
        end
        if not addr_id then
          -- not found, assign a new id and store the email address
          addr_id = rcall("INCR", "last.id.addr")  -- get next id, starts at 1
          addr_id = tostring(addr_id)
          local ok
          if ttl then
            ok = rcall("SET", addr_key, addr_id, "EX", ttl, "NX")
          else
            ok = rcall("SET", addr_key, addr_id,            "NX")
          end
          if not ok then
            -- shouldn't happen, Lua program runs atomically, but anyway...
            addr_id = rcall("GET", addr_key)  -- collision, retry
          end
        end
        addresses[addr] = addr_id
      end

      -- create a Message-ID -> id mapping
      local msgid_key = "m:" .. msgid
      local msgid_id = rcall("GET", msgid_key)
      if msgid_id then  -- unlikely duplicate Message-ID, but anyway...
        if ttl then rcall("EXPIRE", msgid_key, ttl) end -- extend its lifetime
      else
        msgid_id = rcall("INCR", "last.id.msgid")  -- get next id, starts at 1
        msgid_id = tostring(msgid_id)
        local ok
        if ttl then
          ok = rcall("SET", msgid_key, msgid_id, "EX", ttl, "NX")
        else
          ok = rcall("SET", msgid_key, msgid_id,            "NX")
        end
        if not ok then
          -- shouldn't happen, Lua program runs atomically, but anyway...
          msgid_id = rcall("GET", msgid_key)  -- collision, retry
        end
      end

      -- store additional information to an existing mail_id record
      local sender_id = addresses[sender]
      rcall("HSET",   mail_id,  "log", log_id)
   -- rcall("HMSET",  mail_id,  "log", log_id,
   --            "msgid", msgid_id,  "ip", client_addr,  "sender", sender_id)

      -- store relations: sender/msgid and sender/recipient pairs
      local mapkeys = { "sm:" .. sender_id .. "::" .. msgid_id }
      for r = 6, #ARGV do
        local recip_id = addresses[ARGV[r]]
        -- only the most recent sr:* record is kept, older are overwritten
        mapkeys[#mapkeys+1] = "sr:"  .. sender_id .. ":" .. recip_id
   --   mapkeys[#mapkeys+1] = "srm:" .. sender_id .. ":" .. recip_id ..
   --                                                        ":" .. msgid_id
      end
      if not ttl then
        for _,k in ipairs(mapkeys) do rcall("SET", k, mail_id) end
      else
        for _,k in ipairs(mapkeys) do rcall("SET", k, mail_id, "EX", ttl) end
      end
    end

    return mail_id
END
  } or do {
    $self->disconnect; die "Redis LUA error - lua_save_final: $@\n"
  };

  eval {
    $self->{lua_query_and_update_ip} = $r->call('SCRIPT', 'LOAD', <<'END');
--LUA_QUERY_AND_UPDATE_IP
    local rcall, tonumber, unpack, floor, sprintf =
      redis.call, tonumber, unpack, math.floor, string.format
    local KEYS, ARGV = KEYS, ARGV
    local rx_time, normal_random = ARGV[1], tonumber(ARGV[2])

    local results = {}
    for j = 1, #KEYS do
      local ipkey = KEYS[j]  -- an IP address, prefixed by "ip:"
      local tfirst, tlast  -- Unix times of creation and last access
      local n, s, h, b     -- counts: all, spam, ham, banned+virus
      local age, ttl       -- time since creation, time to live in seconds
      local ip_addr_data =
        rcall("HMGET", ipkey, 'tl', 'tf', 'n', 's', 'h', 'b')
      if ip_addr_data then
        tlast, tfirst, n, s, h, b = unpack(ip_addr_data,1,6)
      end
      if not tlast then  -- does not exist, a new entry is needed
        n = 0; tfirst = rx_time; ttl = 3*3600  -- 3 hours for new entries
        rcall("HMSET", ipkey, 'tf', rx_time, 'tl', rx_time, 'n', '0')
      else  -- a record for this IP address exists, collect its counts and age
        n = tonumber(n) or 0
        local rx_time_n, tfirst_n, tlast_n =
          tonumber(rx_time), tonumber(tfirst), tonumber(tlast)
        if rx_time_n and tfirst_n and tlast_n then  -- valid numbers
          age      = rx_time_n - tfirst_n  -- time since entry creation
          local dt = rx_time_n - tlast_n   -- time since last occurrence
          ttl = 3600 * (n >= 8 and 80 or (3 + n^2.2))  -- 4 to 80 hours
          if ttl < 1.5 * dt then ttl = 1.5 * dt end
        else  -- just in case - ditch a record with invalid fields
          n = 0; tfirst = rx_time; ttl = 3*3600
          rcall("DEL", ipkey);
          rcall("HMSET", ipkey, 'tf', rx_time, 'n', '0')
        end
        rcall("HMSET", ipkey, 'tl', rx_time)  -- update its last-seen time
      end
      -- the 's', 'h', 'b' and 'n' counts will be updated later
      if normal_random then
        -- introduce some randomness, don't let spammers depend on a fixed ttl
        ttl = ttl * (1 + normal_random * 0.2)
        if ttl < 4000 then ttl = 4000 end  -- no less than 1h 7min
      end
      -- set time-to-live in seconds, capped at 3 days, integer
      if age and (age + ttl > 3*24*3600) then ttl = 3*24*3600 - age end
      if ttl < 1 then
        rcall("DEL", ipkey); ttl = 0
      else
        rcall("EXPIRE", ipkey, floor(ttl))
      end
      results[#results+1] = { ipkey, n or 0, s or 0, h or 0, b or 0,
                              tfirst or "", tlast or "", ttl }
    end
    return results
END
  } or do {
    $self->disconnect; die "Redis LUA error - lua_query_and_update_ip: $@\n"
  };

  eval {
    $self->{lua_query_penpals} = $r->call('SCRIPT', 'LOAD', <<'END');
--LUA_QUERY_PENPALS
    local tonumber, unpack, sprintf = tonumber, unpack, string.format
    local rcall = redis.call
    local ARGV = ARGV

    local now, nonce, recipient = ARGV[1], ARGV[2], ARGV[3]
    local senders_count = tonumber(ARGV[4])
    local senders_argv_ofs = 5
    local messageid_argv_ofs = senders_argv_ofs + senders_count + 1
    local messageid_count = tonumber(ARGV[messageid_argv_ofs - 1])

    local q_keys1 = {}
    -- current sender as a potential previous recipient
    if recipient == '' then recipient = nil end  -- nothing ever sent to "<>"
    if recipient then
      q_keys1[#q_keys1+1] = "a:" .. recipient
    end
    for j = 1, senders_count do
      q_keys1[#q_keys1+1] = "a:" .. ARGV[senders_argv_ofs + j - 1]
    end
    for j = 1, messageid_count do
      q_keys1[#q_keys1+1] = "m:" .. ARGV[messageid_argv_ofs + j - 1]
    end

    -- map e-mail addresses and referenced Message-IDs to internal id numbers
    local q_result = rcall("MGET", unpack(q_keys1))
    q_keys1 = nil

    local rid        -- internal id of a recipient's e-mail addresses
    local mids = {}  -- internal ids corresponding to referenced "Message-ID"s
    local senders = {}
    if q_result then
      local k = 0;
      if recipient then  -- nonempty e-mail address, i.e. not "<>"
        k = k+1; rid = q_result[k]
      end
      for j = 1, senders_count do
        k = k+1;
        if not q_result[k] then senders[j] = false  -- non-nil
        else senders[j] = { sid = q_result[k] } end
      end
      for j = 1, messageid_count do
        k = k+1;  if q_result[k] then mids[q_result[k]] = true end
      end
    end
    q_result = nil

    -- prepare query keys to find a closest-matching previous e-mail message
    -- for each sender
    local q_keys2, belongs_to_sender, on_hit_txt = {}, {}, {}
    for _, s in ipairs(senders) do
      if s then
        -- try sender/Message-ID pairs without a recipient
        for m in pairs(mids) do
          local nxt = #q_keys2 + 1
          q_keys2[nxt] = "sm:" .. s.sid .. "::" .. m
          on_hit_txt[nxt] = "mid=" .. m
          belongs_to_sender[nxt] = s
        end
        -- try a sender/recipient pair without a Message-ID ref
        if rid then
          local nxt = #q_keys2 + 1
          q_keys2[nxt] = "sr:" .. s.sid .. ":" .. rid
          on_hit_txt[nxt] = "rid=" .. rid
          belongs_to_sender[nxt] = s
        end
      end
    end

    -- get an internal id (or nil) of a matching mail_id for each query key
    local q_result2
    if #q_keys2 >= 1 then q_result2 = rcall("MGET", unpack(q_keys2)) end

    local msginfo = {}  -- data about a message mail_id (e.g. its rx_time)
    if q_result2 then
      for j = 1, #q_keys2 do
        local rx_time_n
        local mail_id = q_result2[j]

        if not mail_id then
          -- no matching mail_id
        elseif msginfo[mail_id] then  -- already looked-up
          rx_time_n = msginfo[mail_id].rx_time_n
        else  -- not yet looked-up
          msginfo[mail_id] = {}
          -- see if a record for this mail_id exists, find its timestamp
          rx_time_n = tonumber(rcall("HGET", mail_id, "time"))
          msginfo[mail_id].rx_time_n = rx_time_n
        end

        if rx_time_n then  -- exists and is a valid number
          local s = belongs_to_sender[j]
          if not s.hits then s.hits = {} end
          if not s.hits[mail_id] then
            s.hits[mail_id] = on_hit_txt[j]
          else
            s.hits[mail_id] = s.hits[mail_id] .. " " .. on_hit_txt[j]
          end

          -- for each sender manage a sorted list of mail_ids found
          if not s.mail_id_list then
            s.mail_id_list = { mail_id }
          else
            -- keep sender's mail_id_list sorted by rx_time, highest first
            local mail_id_list = s.mail_id_list
            local first_smaller_ind
            for j = 1, #mail_id_list do
              if msginfo[mail_id_list[j]].rx_time_n <= rx_time_n then
                first_smaller_ind = j; break
              end
            end
            table.insert(mail_id_list,
                         first_smaller_ind or #mail_id_list+1, mail_id)
          end
        end
      end
    end

    local results = {}  -- one entry for each sender, followed by a nonce
    for _, s in ipairs(senders) do
      if not s or not s.mail_id_list then  -- no matching mail_id
        results[#results+1] = { s and s.sid or "", rid }
      else  -- some matches for this sender, compile a report
        local report = {}; local mail_id_list = s.mail_id_list
        for _, mail_id in ipairs(mail_id_list) do  -- first is best
          report[#report+1] = sprintf("%s (%.0f s) %s", mail_id,
                                tonumber(now) - msginfo[mail_id].rx_time_n,
                                s.hits and s.hits[mail_id] or "")
        end
        results[#results+1] =
          { s.sid or "", rid or "", msginfo[mail_id_list[1]].rx_time_n,
            mail_id_list[1], table.concat(report,", ") }
      end
    end
    results[#results+1] = nonce
    return results
END
    1;
  } or do {
    $self->disconnect; die "Redis LUA error - lua_query_penpals: $@\n"
  };

  ll(5) && do_log(5, "redis: SHA fingerprints: final %s, query %s",
                  map(substr($_,0,10), @$self{qw(lua_save_final lua_query)}));
  section_time("redis-load");
  1;
}

1;

__DATA__
#^L
package Amavis::Out::SQL::Connection;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Util qw(ll do_log do_log_safe);
  import Amavis::Timing qw(section_time);
}

use DBI qw(:sql_types);

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

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

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

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

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

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  do_log_safe(5,"Amavis::Out::SQL::Connection DESTROY called");
  # ignore failures, make perlcritic happy
  eval { $self->disconnect_from_sql } or 1;
}

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

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

# returns DBD driver name such as 'Pg', 'mysql';  or undef if unknown
#
sub driver_name {
  my $self = $_[0];  my $dbh = $self->dbh;
  $dbh or die "sql driver_name: dbh not available";
  !$dbh->{Driver} ? undef : $dbh->{Driver}->{Name};
}

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

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

sub commit {
  my $self = shift; do_log(5,"sql commit");
  $self->in_transaction(0);
  my $dbh = $self->dbh;
  $dbh or die "commit: dbh not available";
  $dbh->commit(@_);  my($rv_err,$rv_str) = ($dbh->err, $dbh->errstr);
  do_log(2,"sql commit status: err=%s, errstr=%s",
           $rv_err,$rv_str)  if defined $rv_err;
  ($rv_err,$rv_str);  # potentially useful to see non-fatal errors
};

sub rollback {
  my $self = shift; do_log(5,"sql rollback");
  $self->in_transaction(0);
  $self->dbh or die "rollback: dbh not available";
  eval {
    $self->dbh->rollback(@_);  1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    do_log(-1,"sql rollback error, reconnecting (%s)", $eval_stat);
    $self->disconnect_from_sql;
    die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
    $self->connect_to_sql;
#   $self->dbh->rollback(@_);  # too late now, hopefully implied in disconnect
  };
};

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

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

sub execute {
  my($self,$clause,@args) = @_;
  $self->dbh or die "sql execute: dbh not available";
  my $sth = $self->sth($clause);  # fetch cached st. handle or prepare new
  if ($sth) {
    ll(5) && do_log(5, "sql: executing clause (%d args): %s",
                       scalar(@args), $clause);
  } else {
    ll(4) && do_log(4,"sql: preparing and executing (%d args): %s",
                       scalar(@args), $clause);
    $sth = $self->dbh->prepare($clause); $self->sth($clause,$sth);
    $sth or die "sql: prepare failed: ".$DBI::errstr;
  }
  my($rv_err,$rv_str);
  eval {
    for my $j (0..$#args) { # arg can be a scalar or [val,type] or [val,\%attr]
      my $arg = $args[$j];
      $sth->bind_param($j+1, !ref($arg) ? $arg : @$arg);
    # ll(5) && do_log(5, "sql: bind %d: %s",
    #                 $j+1, !ref($arg) ? $arg : '['.join(',',@$arg).']' );
    }
    $sth->execute; $rv_err = $sth->err; $rv_str = $sth->errstr;  1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    # man DBI: ->err code is typically an integer but you should not assume so
    # $DBI::errstr is normally already contained in $eval_stat
    my $sqlerr   = $sth ? $sth->err   : $DBI::err;
    my $sqlstate = $sth ? $sth->state : $DBI::state;
    my $msg = sprintf("err=%s, %s, %s", $sqlerr, $sqlstate, $eval_stat);
    if (!$sth) {
      die "sql execute (no handle): ".$msg;
    } elsif (! ($sqlerr eq '2006' || $sqlerr eq '2013'   ||   # MySQL
                ($sqlerr == -1 && $sqlstate eq  'S1000') ||   # PostgreSQL 7
                ($sqlerr ==  7 && $sqlstate =~ /^(S8|08|57)...\z/i) )) { #PgSQL
                # libpq-fe.h: ExecStatusType PGRES_FATAL_ERROR=7
      # ignore failures, make perlcritic happy
      eval { $self->disconnect_from_sql } or 1;  # better safe than sorry
      die "sql exec: $msg\n";
    } else {  # Server has gone away; Lost connection to...
      # MySQL: 2006, 2013;  PostgreSQL: 7
      if ($self->in_transaction) {
        # ignore failures, make perlcritic happy
        eval { $self->disconnect_from_sql } or 1;
        die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
        die "sql execute failed within transaction, $msg";
      } else {  # try one more time
        do_log(0,"NOTICE: reconnecting in response to: %s", $msg);
        # ignore failures, make perlcritic happy
        eval { $self->disconnect_from_sql } or 1;
        die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
        $self->connect_to_sql;
        $self->dbh or die "sql execute: reconnect failed";
        do_log(4,"sql: preparing and executing (again): %s", $clause);
        $sth = $self->dbh->prepare($clause); $self->sth($clause,$sth);
        $sth or die "sql: prepare (reconnected) failed: ".$DBI::errstr;
        $rv_err = $rv_str = undef;
        eval {
          for my $j (0..$#args) {  # a scalar or [val,type] or [val,\%attr]
            $sth->bind_param($j+1, !ref($args[$j]) ? $args[$j] : @{$args[$j]});
          }
          $sth->execute; $rv_err = $sth->err; $rv_str = $sth->errstr;  1;
        } or do {
          $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
          $msg = sprintf("err=%s, %s, %s", $DBI::err,$DBI::state,$eval_stat);
          $self->disconnect_from_sql;
          die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
          die "sql execute failed again, $msg";
        };
      }
    }
  };
  # $rv_err: undef indicates success, "" indicates an 'information',
  #          "0" indicates a 'warning', true indicates an error
  do_log(2,"sql execute status: err=%s, errstr=%s",
           $rv_err,$rv_str)  if defined $rv_err;
  ($rv_err,$rv_str);  # potentially useful to see non-fatal errors
}

# Connect to a database.  Take a list of database connection
# parameters and try each until one succeeds.
#  -- based on code from Ben Ransford <amavis@uce.ransford.org> 2002-09-22
#
sub connect_to_sql {
  my $self = shift;  # a list of DSNs to try connecting to sequentially
  my $dbh; my(@dsns) = @{$self->{dsn_list}};
  do_log(3,"Connecting to SQL database server");
  for my $tmpdsn (@dsns) {
    my($dsn, $username, $password) = @$tmpdsn;
    do_log(4,"connect_to_sql: trying '%s'", $dsn);
    $dbh = DBI->connect($dsn, $username, $password,
             {PrintError => 0, RaiseError => 0, Taint => 1, AutoCommit => 1} );
    if ($dbh) {
      $self->dsn_current($dsn);
      do_log(3,"connect_to_sql: '%s' succeeded", $dsn);
      last;
    }
    do_log(-1,"connect_to_sql: unable to connect to DSN '%s': %s",
              $dsn, $DBI::errstr);
  }
  $self->dbh($dbh); delete($self->{sth});
  $self->in_transaction(0); $self->{incarnation}++;
  $dbh or die "connect_to_sql: unable to connect to any dataset";
  $dbh->{'RaiseError'} = 1;
# $dbh->{mysql_auto_reconnect} = 1;  # questionable benefit
# $dbh->func(30000,'busy_timeout');  # milliseconds (SQLite)

  # https://mathiasbynens.be/notes/mysql-utf8mb4
  #   Never use utf8 in MySQL — always use utf8mb4 instead.
  #   SET NAMES utf8mb4 COLLATE utf8mb4_unicode_ci
  my $cmd = $self->driver_name eq 'mysql' ? "SET NAMES 'utf8mb4'"
                                          : "SET NAMES 'utf8'";
  eval {
    $dbh->do($cmd); 1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    do_log(2,"connect_to_sql: %s failed: %s", $cmd, $eval_stat);
  };
  section_time('sql-connect');
  $self;
}

sub disconnect_from_sql($) {
  my $self = $_[0];
  my $did_disconnect;
  $self->in_transaction(0);
  if ($self->dbh) {
    do_log(4,"disconnecting from SQL");
    $self->dbh->disconnect; $self->dbh(undef);
    $did_disconnect = 1;
  }
  delete $self->{sth}; $self->dsn_current(undef);
  $did_disconnect;
}

1;

__DATA__
#^L
package Amavis::Out::SQL::Log;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Util qw(ll do_log do_log_safe min max minmax add_entropy
                         untaint untaint_inplace format_time_interval
                         truncate_utf_8 orcpt_encode
                         idn_to_utf8 idn_to_ascii mail_addr_idn_to_ascii
                         safe_encode safe_encode_utf8 safe_decode_mime
                         snmp_count ccat_split ccat_maj);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Out::SQL::Connection ();
}

use DBI qw(:sql_types);

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

sub DESTROY {
  my $self = $_[0]; local($@,$!,$_);
  do_log_safe(5,"Amavis::Out::SQL::Log DESTROY called");
}

# find an existing e-mail address record or insert one, returning its id;
# may return undef if 'sel_adr' or 'ins_adr' SQL clauses are not defined;
#
sub find_or_save_addr {
  my($self,$addr,$partition_tag,$keep_localpart_case) = @_;
  my $id; my $existed = 0; my($localpart,$domain);
  my $naddr = untaint($addr);
  if ($naddr ne '') {    # normalize address (lowercase, 7-bit, max 255 ch...)
    ($localpart,$domain) = split_address($naddr);
    $domain = idn_to_ascii($domain);
    if (!$keep_localpart_case && !c('localpart_is_case_sensitive')) {
      $localpart = lc $localpart;
    }
    local($1);
    $domain = $1  if $domain=~/^\@?(.*?)\.*\z/s;  # chop leading @ and tr. dots
    $naddr = $localpart.'@'.$domain;
    substr($naddr,255) = ''  if length($naddr) > 255;
    # avoid UTF-8 SQL trouble, legitimate RFC 5321 addresses only need 7 bits
    $naddr =~ s/[^\040-\176]/?/gs  if !$sql_allow_8bit_address;
    # SQL character strings disallow zero octets, and also disallow any other
    # octet values and sequences of octet values that are invalid according to
    # the database's selected character set encoding
  }
  my $conn_h = $self->{conn_h}; my $sql_cl_r = cr('sql_clause');
  my $sel_adr = $sql_cl_r->{'sel_adr'};
  my $ins_adr = $sql_cl_r->{'ins_adr'};
  if (!defined($sel_adr) || $sel_adr eq '') {
    # no way to query a database, behave as if no record was found
    do_log(5,"find_or_save_addr: sel_adr query disabled, %s", $naddr);
  } else {
    $conn_h->begin_work_nontransaction;  #(re)connect if necessary, autocommit
    my $datatype = SQL_VARCHAR;
    if ($sql_allow_8bit_address) {
      my $driver = $conn_h->driver_name;  # only available when connected
      $datatype = $driver eq 'Pg' ? { pg_type => DBD::Pg::PG_BYTEA() }
                                  : SQL_VARBINARY;
    }
    $conn_h->execute($sel_adr, $partition_tag, [$naddr,$datatype]);
    my($a_ref,$a2_ref);
    if (defined($a_ref=$conn_h->fetchrow_arrayref($sel_adr))) {  # exists?
      $id = $a_ref->[0]; $conn_h->finish($sel_adr);
      $existed = 1;
    } elsif (!defined($ins_adr) || $ins_adr eq '') {
      # record does not exist, insertion is not allowed
      do_log(5,"find_or_save_addr: ins_adr insertion disabled, %s", $naddr);
    } else {  # does not exist, attempt to insert a new e-mail address record
      my $invdomain;  # domain with reversed fields, chopped to 255 characters
      $invdomain = join('.', reverse split(/\./,$domain,-1));
      substr($invdomain,255) = ''  if length($invdomain) > 255;
      $conn_h->begin_work_nontransaction;  # (re)connect if not connected
      my $eval_stat;
      eval { $conn_h->execute($ins_adr, $partition_tag,
                              [$naddr,$datatype], $invdomain); 1 }
        or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
      # INSERT may have failed because of race condition with other processes;
      # try the SELECT again, it will most likely succeed this time;
      # SELECT after INSERT also avoids the need for a working last_insert_id()
      $conn_h->begin_work_nontransaction;  # (re)connect if not connected
      # try select again, regardless of the success of INSERT
      $conn_h->execute($sel_adr, $partition_tag, [$naddr,$datatype]);
      if ( defined($a2_ref=$conn_h->fetchrow_arrayref($sel_adr)) ) {
        $id = $a2_ref->[0]; $conn_h->finish($sel_adr);
        add_entropy($id);
        if (!defined($eval_stat)) {  # status of the INSERT
          do_log(5,"find_or_save_addr: record inserted, id=%s, %s",
                   $id,$naddr);
        } else {
          $existed = 1; chomp $eval_stat;
          do_log(5,"find_or_save_addr: found on a second attempt, ".
                   "id=%s, %s, (first attempt: %s)", $id,$naddr,$eval_stat);
          die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
        }
      } else {  # still does not exist
        $id = $existed = undef;
        if (defined $eval_stat) {  # status of the INSERT
          chomp $eval_stat;
          die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
        };
        die "find_or_save_addr: failed to insert addr $naddr: $eval_stat";
      }
    }
  }
  ($id, $existed);
}

# find a penpals record which proves that a local user (sid) really sent a
# mail to a recipient (rid) some time ago. Returns an interval time in seconds
# since the last such mail was sent by our local user to a specified recipient
# (or undef if information is not available).  If @$message_id_list is a
# nonempty list of Message-IDs as found in References header field, the query
# also finds previous outgoing messages with a matching Message-ID but
# possibly to recipients different from what the mail was originally sent to.
#
sub penpals_find {
  my($self, $sid,$rid,$message_id_list, $msginfo) = @_;
  my($a_ref,$found,$age,$send_time,$ref_mail_id,$ref_subj,$ref_mid,$ref_rid);
  my $conn_h = $self->{conn_h}; my $sql_cl_r = cr('sql_clause');
  my $sel_penpals = $sql_cl_r->{'sel_penpals'};
  my $sel_penpals_msgid = $sql_cl_r->{'sel_penpals_msgid'};
  $message_id_list = []  if !$message_id_list;
  if (defined($sel_penpals_msgid) && @$message_id_list && defined($sid)) {
    # list of refs to Message-ID is nonempty, try reference or recipient match
    my $n = scalar(@$message_id_list);  # number of keys
    my(@args) = ($sid,$rid);  my(@pos_args);  local($1);
    my $sel_taint = substr($sel_penpals_msgid,0,0);   # taintedness
    $sel_penpals_msgid =~
           s{ ( %m | \? ) }  # substitute %m for keys and ? for next arg
            { push(@pos_args,
                   $1 eq '%m' ? (map { my $s=$_; $s=~s/[^\040-\176]/?/gs; $s }
                                     @$message_id_list)
                              : shift @args),
              $1 eq '%m' ? join(',', ('?') x $n) : '?' }xgse;
    # keep original clause taintedness
    $sel_penpals_msgid = untaint($sel_penpals_msgid) . $sel_taint;
    untaint_inplace($_) for @pos_args;  # untaint arguments
    do_log(4, "penpals: query args: %s", join(', ',@pos_args));
    do_log(4, "penpals: %s", $sel_penpals_msgid);
    $conn_h->begin_work_nontransaction;  # (re)connect if not connected
    $conn_h->execute($sel_penpals_msgid,@pos_args);
    snmp_count('PenPalsAttempts'); snmp_count('PenPalsAttemptsMid');
    if (!defined($a_ref=$conn_h->fetchrow_arrayref($sel_penpals_msgid))) {
      snmp_count('PenPalsMisses');
    } else {
      ($send_time, $ref_mail_id, $ref_subj, $ref_mid, $ref_rid) = @$a_ref;
      $found = 1;  $conn_h->finish($sel_penpals_msgid);
      my $rid_match = defined $ref_rid && defined $rid && $rid eq $ref_rid;
      my $mid_match = grep($ref_mid eq $_, @$message_id_list);
      my $t = $mid_match && $rid_match     ? 'MidRid' :
            # $mid_match && !defined($rid) ? 'MidNullRPath' :
              $mid_match ? 'Mid' : $rid_match ? 'Rid' : 'none';
      snmp_count('PenPalsHits'.$t); snmp_count('PenPalsHits');
      ll(4) && do_log(4, "penpals: MATCH ON %s: %s",
                         $t, join(", ",@$a_ref));
    }
  }
  if (!$found && defined($sel_penpals) && defined($rid) && defined($sid)) {
    # list of Message-ID references not given, try matching on recipient only
    $conn_h->begin_work_nontransaction;  # (re)connect if not connected
    $conn_h->execute($sel_penpals, untaint($sid), untaint($rid));
    snmp_count('PenPalsAttempts'); snmp_count('PenPalsAttemptsRid');
    if (!defined($a_ref=$conn_h->fetchrow_arrayref($sel_penpals))) {  # exists?
      snmp_count('PenPalsMisses');
    } else {
      ($send_time, $ref_mail_id, $ref_subj) = @$a_ref;
      $found = 1;  $conn_h->finish($sel_penpals);
      snmp_count('PenPalsHitsRid'); snmp_count('PenPalsHits');
      ll(4) && do_log(4, "penpals: MATCH ON RID(%s): %s",
                         $rid, join(", ",@$a_ref));
    }
  }
  if (!$found) {
    ll(4) && do_log(4, "penpals: (sql) not found (%s,%s)%s", $sid,$rid,
             !@$message_id_list ? '' : ' refs: '.join(", ",@$message_id_list));
  } else {
    $age = max(0, $msginfo->rx_time - $send_time);
    ll(3) && do_log(3, "penpals: (sql) found (%s,%s) %s age %s (%.0f s)",
                    $sid, $rid, $ref_mail_id,
                    format_time_interval($age), $age);
  }
  ($age, $ref_mail_id, $ref_subj);
}

sub save_info_preliminary {
  my($self, $msginfo) = @_;
  my $mail_id = $msginfo->mail_id;
  defined $mail_id  or die "save_info_preliminary: mail_id still undefined";
  my $partition_tag = $msginfo->partition_tag;
  my($sid,$existed,$sender_smtp); local($1);
  $sender_smtp = $msginfo->sender_smtp; $sender_smtp =~ s/^<(.*)>\z/$1/s;
  # find an existing e-mail address record for sender, or insert a new one
  ($sid,$existed) = $self->find_or_save_addr($sender_smtp,$partition_tag);
  if (defined $sid) {
    $msginfo->sender_maddr_id($sid);
    # there is perhaps 30-50% chance the sender address is already in the db
    snmp_count('SqlAddrSenderAttempts');
    snmp_count($existed ? 'SqlAddrSenderHits' : 'SqlAddrSenderMisses');
    do_log(4,"save_info_preliminary %s, sender id: %s, %s, %s",
             $mail_id, $sid, $sender_smtp, $existed ? 'exists' : 'new' );
  }
  # find existing address records for recipients, or insert them
  for my $r (@{$msginfo->per_recip_data}) {
    my $addr_smtp = $r->recip_addr_smtp;
    if (defined $addr_smtp) {
      $addr_smtp =~ s/^<(.*)>\z/$1/s;
      $addr_smtp = mail_addr_idn_to_ascii($addr_smtp);
    }
    my($rid, $o_rid, $existed);
    if ($addr_smtp ne '') {
      ($rid,$existed) = $self->find_or_save_addr($addr_smtp,$partition_tag);
      # there is perhaps 90-100% chance the recipient addr is already in the db
      if (defined $rid) {
        $r->recip_maddr_id($rid);
        snmp_count('SqlAddrRecipAttempts');
        snmp_count($existed ? 'SqlAddrRecipHits' : 'SqlAddrRecipMisses');
        my($addr_type, $addr) = orcpt_encode($r->dsn_orcpt, 1);
        ll(4) && do_log(4,"save_info_preliminary %s, recip id: %s, %s%s, %s",
                          $mail_id, $rid, $addr_smtp,
                          defined $addr ? " (ORCPT $addr_type;$addr)" : '',
                          $existed ? 'exists' : 'new');
      }
    }
  }
  my $conn_h = $self->{conn_h}; my $sql_cl_r = cr('sql_clause');
  my $ins_msg = $sql_cl_r->{'ins_msg'};
  if (!defined($ins_msg) || $ins_msg eq '') {
    do_log(4,"save_info_preliminary: ins_msg undef, not saving");
  } elsif (!defined($sid)) {
    do_log(4,"save_info_preliminary: sid undef, not saving");
  } else {
    $conn_h->begin_work;  # SQL transaction starts
    eval {
      # MySQL does not like a standard iso8601 delimiter 'T' or a timezone
      # when data type of msgs.time_iso is TIMESTAMP (instead of a string)
      my $time_iso = $timestamp_fmt_mysql && $conn_h->driver_name eq 'mysql'
                       ? iso8601_utc_timestamp($msginfo->rx_time,1,'')
                       : iso8601_utc_timestamp($msginfo->rx_time);
      # insert a placeholder msgs record with sender information
      $conn_h->execute($ins_msg,
        $partition_tag, $msginfo->mail_id, $msginfo->secret_id,
        $msginfo->log_id, int($msginfo->rx_time), $time_iso,
        untaint($sid), c('policy_bank_path'), untaint($msginfo->client_addr),
        0+untaint($msginfo->msg_size),
        untaint(substr(idn_to_utf8(c('myhostname')),0,255)));
      $conn_h->commit;  1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      if ($conn_h->in_transaction) {
        eval {
          $conn_h->rollback;
          do_log(1,"save_info_preliminary: rollback done");  1;
        } or do {
          $@ = "errno=$!"  if $@ eq '';  chomp $@;
          do_log(1,"save_info_preliminary: rollback %s", $@);
          die $@  if $@ =~ /^timed out\b/;  # resignal timeout
        };
      }
      do_log(-1, "WARN save_info_preliminary: %s", $eval_stat);
      die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
      return 0;
    };
  }
  1;
}

sub save_info_final {
  my($self, $msginfo, $report_ref) = @_;
  my $mail_id = $msginfo->mail_id;
  defined $mail_id  or die "save_info_final: mail_id still undefined";
  my $dsn_sent = $msginfo->dsn_sent;
  $dsn_sent = !$dsn_sent ? 'N' : $dsn_sent==1 ? 'Y' : $dsn_sent==2 ? 'q' : '?';
  my $sid = $msginfo->sender_maddr_id;
  my $conn_h = $self->{conn_h}; my($sql_cl_r) = cr('sql_clause');
  my $ins_msg = $sql_cl_r->{'ins_msg'};
  my $upd_msg = $sql_cl_r->{'upd_msg'};
  my $ins_rcp = $sql_cl_r->{'ins_rcp'};
  if ($ins_msg eq '' || $upd_msg eq '' || $ins_rcp eq '') {
    # updates disabled
  } elsif (!defined($sid)) {
    # sender not in table maddr, msgs record was not inserted by preliminary
  } else {
    $conn_h->begin_work;  # SQL transaction starts
    eval {
      my(%ccat_short_name) = (  # as written to a SQL record
        CC_VIRUS,'V',  CC_BANNED,'B',  CC_UNCHECKED,'U',
        CC_SPAM,'S',   CC_SPAMMY,'Y',  CC_BADH.",2",'M',  CC_BADH,'H',
        CC_OVERSIZED,'O',  CC_MTA,'T',  CC_CLEAN,'C',  CC_CATCHALL,'?');
      my($min_spam_level, $max_spam_level) =
        minmax(map($_->spam_level, @{$msginfo->per_recip_data}));
      # insert per-recipient records into table msgrcpt
      my $r_seq_num = 0;  # can serve as a component of a primary key
      for my $r (@{$msginfo->per_recip_data}) {
        $r_seq_num++;
        my $rid = $r->recip_maddr_id;
        next  if !defined $rid; # e.g. always_bcc, or table 'maddr' is disabled
        my $o_rid = $r->recip_maddr_id_orig;  # may be undef
        my $spam_level = $r->spam_level;
        my($dest,$resp) = ($r->recip_destiny, $r->recip_smtp_response);
        my $d = $resp=~/^4/ ? 'TEMPFAIL'
             : ($dest==D_BOUNCE && $resp=~/^5/) ? 'BOUNCE'
             : ($dest!=D_BOUNCE && $resp=~/^5/) ? 'REJECT'
             : ($dest==D_PASS  && ($resp=~/^2/ || !$r->recip_done)) ? 'PASS'
             : ($dest==D_DISCARD) ? 'DISCARD' : '?';
        my $r_content_type =
          $r->setting_by_contents_category(\%ccat_short_name);
        for ($r_content_type) { $_ = ' '  if !defined $_ || /^ *\z/ }
        substr($resp,255) = ''  if length($resp) > 255;
        $resp =~ s/[^\040-\176]/?/gs;  # just in case, only need 7 bit printbl
        # avoid op '?:' on tainted operand in args list, see PR [perl #81028]
        my $recip_local_yn = $r->recip_is_local ? 'Y' : 'N';
        my $blacklisted_yn = $r->recip_blacklisted_sender ? 'Y' : 'N';
        my $whitelisted_yn = $r->recip_whitelisted_sender ? 'Y' : 'N';
        $conn_h->execute($ins_rcp,
          $msginfo->partition_tag, $mail_id,
          $sql_schema_version < 2.007000 ? untaint($rid)
            : ($r_seq_num, untaint($rid), $recip_local_yn, $r_content_type),
          substr($d,0,1), ' ',
          $blacklisted_yn, $whitelisted_yn, 0+untaint($spam_level),
          untaint($resp),
        );
        # untaint(defined $o_rid ? $o_rid : $rid),
        # int($msginfo->rx_time),
        # untaint($r->user_policy_id),
      }
      my $q_to = $msginfo->quarantined_to;  # ref to a list of quar. locations
      if (!defined($q_to) || !@$q_to) { $q_to = undef }
      else {
        $q_to = $q_to->[0];  # keep only the first quarantine location
        $q_to =~ s{^\Q$QUARANTINEDIR\E/}{};  # strip directory name
      }
      my $m_id = $msginfo->get_header_field_body('message-id');
      $m_id = join(' ',parse_message_id($m_id))  if $m_id ne '';  # strip CFWS
      my $subj = $msginfo->get_header_field_body('subject');
      my $from = $msginfo->get_header_field_body('from');  # raw full field
      my $rfc2822_from   = $msginfo->rfc2822_from;  # undef, scalar or listref
      my $rfc2822_sender = $msginfo->rfc2822_sender;  # undef or scalar
      $rfc2822_from = join(', ',@$rfc2822_from)  if ref $rfc2822_from;
      my $os_fp = $msginfo->client_os_fingerprint;
      $_ = !defined($_) ? '' :untaint($_) for ($subj,$from,$m_id,$q_to,$os_fp);
      for ($subj,$from) {  # character set decoding, sanitation
        chomp; s/\n(?=[ \t])//gs; s/^[ \t]+//s; s/[ \t]+\z//s;  # unfold, trim
        eval {  # convert to UTF-8 octets, truncate to 255 bytes
          my $chars  = safe_decode_mime($_);      # to logical characters
          my $octets = safe_encode_utf8($chars);  # to bytes, UTF-8 encoded
          $octets = truncate_utf_8($octets,255);
          # man DBI: Drivers should accept [unicode and non-unicode] strings
          # and, if required, convert them to the character set of the
          # database being used. Similarly, when fetching from the database
          # character data that isn't iso-8859-1 the driver should convert
          # it into UTF-8.
          $_ = $octets; 1;  # pass bytes to SQL, UTF-8, works better
        } or do {
          my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
          do_log(1,"save_info_final INFO: header field ".
                   "not decodable, keeping raw bytes: %s", $eval_stat);
          substr($_,255) = ''  if length($_) > 255;
          die $eval_stat  if $eval_stat =~ /^timed out\b/; # resignal timeout
        };
      }
      for ($m_id,$q_to,$os_fp) {  # truncate to 255 ch, ensure 7-bit characters
        substr($_,255) = ''  if length($_) > 255;
        s/[^\040-\176]/?/gs;  # only use 7 bit printable, compatible with UTF-8
      }
      my $content_type =
        $msginfo->setting_by_contents_category(\%ccat_short_name);
      my $checks_performed = $msginfo->checks_performed;
      $checks_performed = !ref $checks_performed ? ''
                : join('', grep($checks_performed->{$_}, qw(V S H B F P D)));
      my $q_type = $msginfo->quar_type;
      # only keep the first quarantine type used (e.g. ignore archival quar.)
      $q_type = $q_type->[0]  if ref $q_type;
      for ($q_type,$content_type) { $_ = ' '  if !defined $_ || /^ *\z/ }
      $min_spam_level = 0  if !defined $min_spam_level;
      $max_spam_level = 0  if !defined $max_spam_level;
      my $orig = $msginfo->originating ? 'Y' : 'N';
      ll(4) && do_log(4,"save_info_final %s, orig=%s, chks=%s, cont.ty=%s, ".
                        "q.type=%s, q.to=%s, dsn=%s, score=%s, ".
                        "Message-ID: %s, From: '%s', Subject: '%s'",
                        $mail_id, $orig, $checks_performed, $content_type,
                        $q_type, $q_to, $dsn_sent, $min_spam_level,
                        $m_id, $from, $subj);
      # update message record with additional information
      $conn_h->execute($upd_msg,
               $content_type, $q_type, $q_to, $dsn_sent,
               0+untaint($min_spam_level), $m_id, $from, $subj,
               untaint($msginfo->client_addr), # we may have a better info now
               $sql_schema_version < 2.007000 ? () : $orig,
               $msginfo->partition_tag, $mail_id);
               # $os_fp, $rfc2822_sender, $rfc2822_from, $checks_performed, ...
      # SQL_CHAR, SQL_VARCHAR, SQL_VARBINARY, SQL_BLOB, SQL_INTEGER, SQL_FLOAT,
      # SQL_TIMESTAMP, SQL_TYPE_TIMESTAMP_WITH_TIMEZONE, ...
      $conn_h->commit;  1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      if ($conn_h->in_transaction) {
        eval {
          $conn_h->rollback;
          do_log(1,"save_info_final: rollback done");  1;
        } or do {
          $@ = "errno=$!"  if $@ eq '';  chomp $@;
          do_log(1,"save_info_final: rollback %s", $@);
          die $@  if $@ =~ /^timed out\b/;  # resignal timeout
        };
      }
      do_log(-1, "WARN save_info_final: %s", $eval_stat);
      die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
      return 0;
    };
  }
  1;
}

1;

__DATA__
#
package Amavis::IO::SQL;

# an IO wrapper around SQL for inserting/retrieving mail text
# to/from a database

use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Util qw(ll do_log untaint min max minmax);
}

use Errno qw(ENOENT EACCES EIO);
use DBI qw(:sql_types);
# use DBD::Pg;

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

sub open {
  my $self = shift;
  if (exists $self->{conn_h}) {
    eval { $self->close } or 1;  # ignore failure, make perlcritic happy
  }
  @$self{qw(conn_h clause dbkey mode partition_tag maxbuf rx_time)} = @_;
  my $conn_h = $self->{conn_h}; $self->{buf} = '';
  $self->{chunk_ind} = $self->{pos} = $self->{bufpos} = $self->{eof} = 0;
  my $driver; my $eval_stat;
  eval { $driver = $conn_h->driver_name;  1 }
    or do { $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat };
  die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
  if ($self->{mode} eq 'w') {  # open for write access
    ll(4) && do_log(4,"Amavis::IO::SQL::open %s drv=%s (%s); key=%s, p_tag=%s",
                    $self->{mode}, $driver, $self->{clause},
                    $self->{dbkey}, $self->{partition_tag});
  } else {  # open for read access
    $eval_stat = undef;
    eval {
      $conn_h->execute($self->{clause}, $self->{partition_tag},$self->{dbkey});
      1;
    } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat };
    my $ll = $eval_stat ne '' ? -1 : 4;
    do_log($ll,"Amavis::IO::SQL::open %s drv=%s (%s); key=%s, p_tag=%s, s: %s",
               $self->{mode}, $driver, $self->{clause},
               $self->{dbkey}, $self->{partition_tag}, $eval_stat)  if ll($ll);
    if ($eval_stat ne '') {
      if ($eval_stat =~ /^timed out\b/) { die $eval_stat }  # resignal timeout
      else { die "Amavis::IO::SQL::open $driver SELECT error: $eval_stat" }
      $! = EIO; return;  # not reached
    }
    $eval_stat = undef;
    eval {  # fetch the first chunk; if missing treat it as a file-not-found
      my $a_ref = $conn_h->fetchrow_arrayref($self->{clause});
      if (!defined($a_ref)) { $self->{eof} = 1 }
      else { $self->{buf} = $a_ref->[0]; $self->{chunk_ind}++ }
      1;
    } or do {
      $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      if ($eval_stat =~ /^timed out\b/) { die $eval_stat }  # resignal timeout
      else { die "Amavis::IO::SQL::open $driver read error: $eval_stat" }
      $! = EIO; return;  # not reached
    };
    if ($self->{eof}) {  # no records, make it look like a missing file
      do_log(0,"Amavis::IO::SQL::open key=%s, p_tag=%s: no such record",
               $self->{dbkey}, $self->{partition_tag});
      $! = ENOENT;  # No such file or directory
      return;
    }
  }
  $self;
}

sub DESTROY {
  my $self = $_[0];
  local($@,$!,$_); my $myactualpid = $$;
  if ($self && $self->{conn_h}) {
    eval {
      $self->close or die "Error closing: $!";  1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      warn "[$myactualpid] Amavis::IO::SQL::close error: $eval_stat";
    };
    delete $self->{conn_h};
  }
}

sub close {
  my $self = $_[0];
  my $eval_stat;
  eval {
    if ($self->{mode} eq 'w') {
      $self->flush or die "Can't flush: $!";
    } elsif ($self->{conn_h} && $self->{clause} && !$self->{eof}) {
      # reading, closing before eof was reached
      $self->{conn_h}->finish($self->{clause}) or die "Can't finish: $!";
    };
    1;
  } or do {
    $eval_stat = $@ ne '' ? $@ : "errno=$!";
  };
  delete @$self{
    qw(conn_h clause dbkey mode maxbuf rx_time buf chunk_ind pos bufpos eof) };
  if (defined $eval_stat) {
    chomp $eval_stat;
    if ($eval_stat =~ /^timed out\b/) { die $eval_stat }  # resignal timeout
    else { die "Error closing, $eval_stat" }
    $! = EIO; return;  # not reached
  }
  1;
}

sub seek {
  my($self,$pos,$whence) = @_;
  $whence == 0  or die "Only absolute seek is supported on sql i/o";
  $pos >= 0     or die "Can't seek to a negative absolute position on sql i/o";
  ll(5) && do_log(5, "Amavis::IO::SQL::seek mode=%s, pos=%s",
                     $self->{mode}, $pos);
  $self->{mode} ne 'w'
    or die "Seek to $whence,$pos on sql i/o only supported for read mode";
  if ($pos < $self->{pos}) {
    if (!$self->{eof} && $self->{chunk_ind} <= 1) {
      # still in the first chunk, just reset pos
      $self->{pos} = $self->{bufpos} = 0;  # reset
    } else {  # beyond the first chunk, restart the query from the beginning
      my($con,$clause,$key,$mode,$partition_tag,$maxb,$rx_time) =
        @$self{qw(conn_h clause dbkey mode partition_tag maxbuf rx_time)};
      $self->close or die "seek: error closing, $!";
      $self->open($con,$clause,$key,$mode,$partition_tag,$maxb,$rx_time)
        or die "seek: reopen failed: $!";
    }
  }
  my $skip = $pos - $self->{pos};
  if ($skip > 0) {
    my $s;  my $nbytes = $self->read($s,$skip);  # acceptable for small skips
    defined $nbytes or die "seek: error skipping $skip bytes on sql i/o: $!";
  }
  1;  # seek is supposed to return 1 upon success, 0 otherwise
}

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

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

sub flush {
  my $self = $_[0];
  return  if $self->{mode} ne 'w';
  my $msg; my $conn_h = $self->{conn_h};
  while ($self->{buf} ne '') {
    my $ind = $self->{chunk_ind} + 1;
    ll(4) && do_log(4, "sql flush: key: (%s, %d), p_tag=%s, rx_t=%d, size=%d",
                $self->{dbkey}, $ind, $self->{partition_tag}, $self->{rx_time},
                min(length($self->{buf}),$self->{maxbuf}));
    eval {
      my $driver = $conn_h->driver_name;
      $conn_h->execute($self->{clause},
                       $self->{partition_tag}, $self->{dbkey}, $ind,
                     # int($self->{rx_time}),
                       [ untaint(substr($self->{buf},0,$self->{maxbuf})),
                         $driver eq 'Pg' ? { pg_type => DBD::Pg::PG_BYTEA() }
                                         : SQL_BLOB ] );
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      $msg = $eval_stat;
    };
    last  if defined $msg;
    substr($self->{buf},0,$self->{maxbuf}) = ''; $self->{chunk_ind} = $ind;
  }
  if (defined $msg) {
    chomp $msg;
    if ($msg =~ /^timed out\b/) { die $msg }  # resignal timeout
    else {
      $msg = "flush: sql inserting text failed, $msg";
      die $msg;  # we can't stash an arbitrary error message string into $!,
                 # which forces us to use 'die' to properly report an error
    }
    $! = EIO; return;  # not reached
  }
  1;
}

sub print {
  my $self = shift;
  $self->{mode} eq 'w' or die "Can't print, not opened for writing";
  my $buff_ref = @_ == 1 ? \$_[0] : \join('',@_);
  my $len = length($$buff_ref);
  my $nbytes; my $conn_h = $self->{conn_h};
  if ($len <= 0) { $nbytes = "0 but true" }
  else {
    $self->{buf} .= $$buff_ref; $self->{pos} += $len; $nbytes = $len;
    while (length($self->{buf}) >= $self->{maxbuf}) {
      my $ind = $self->{chunk_ind} + 1;
      ll(4) && do_log(4, "sql print: key: (%s, %d), p_tag=%s, size=%d",
                         $self->{dbkey}, $ind,
                         $self->{partition_tag}, $self->{maxbuf});
      eval {
        my $driver = $conn_h->driver_name;
        $conn_h->execute($self->{clause},
                         $self->{partition_tag}, $self->{dbkey}, $ind,
                       # int($self->{rx_time}),
                         [ untaint(substr($self->{buf},0,$self->{maxbuf})),
                           $driver eq 'Pg' ? { pg_type => DBD::Pg::PG_BYTEA() }
                                           : SQL_BLOB ] );
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        # we can't stash an arbitrary error message string into $!,
        # which forces us to use 'die' to properly report an error
        if ($eval_stat =~ /^timed out\b/) { die $eval_stat } # resignal timeout
        else { die "print: sql inserting mail text failed, $eval_stat" }
        $! = EIO; return;  # not reached
      };
      substr($self->{buf},0,$self->{maxbuf}) = ''; $self->{chunk_ind} = $ind;
    }
  }
  $nbytes;
}

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

1;

#^L
package Amavis::Out::SQL::Quarantine;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT = qw(&mail_via_sql);
  import Amavis::Conf qw(:platform c cr ca $sql_quarantine_chunksize_max);
  import Amavis::rfc2821_2822_Tools qw(qquote_rfc2821_local);
  import Amavis::Util qw(ll do_log snmp_count collect_equal_delivery_recips);
  import Amavis::Timing qw(section_time);
  import Amavis::Out::SQL::Connection ();
}
use subs @EXPORT;

use DBI qw(:sql_types);

sub mail_via_sql {
  my($conn_h,
     $msginfo, $initial_submission, $dsn_per_recip_capable, $filter) = @_;
  my(@snmp_vars) = !$initial_submission ?
    ('', 'Relay',  'ProtoSQL', 'ProtoSQLRelay')
  : ('', 'Submit', 'ProtoSQL', 'ProtoSQLSubmit',
     'Submit'.$initial_submission);
  snmp_count('OutMsgs'.$_)  for @snmp_vars;
  my $logmsg =
    sprintf("%s via SQL (%s): %s", ($initial_submission?'SEND':'FWD'),
            $conn_h->dsn_current, $msginfo->sender_smtp);
  my($per_recip_data_ref, $proto_sockname) =
    collect_equal_delivery_recips($msginfo, $filter, qr/^sql:/i);
  if (!$per_recip_data_ref || !@$per_recip_data_ref) {
    do_log(5, "%s, nothing to do", $logmsg);  return 1;
  }
  my $mail_id = $msginfo->mail_id;
  defined $mail_id  or die "mail_via_sql: mail_id still undefined";
  $proto_sockname = $proto_sockname->[0]  if ref $proto_sockname;
  ll(1) && do_log(1, "delivering to %s, %s -> %s, mail_id %s",
                     $proto_sockname, $logmsg,
                     join(',', qquote_rfc2821_local(
                            map($_->recip_final_addr, @$per_recip_data_ref)) ),
                     $mail_id);
  my $msg = $msginfo->mail_text;  # a scalar reference, or a file handle
  my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
  $msg = $msg_str_ref  if ref $msg_str_ref;
  my($err,$smtp_response);
  eval {
    my $sql_cl_r = cr('sql_clause');
    $conn_h->begin_work;  # SQL transaction starts
    eval {
      my $mp = Amavis::IO::SQL->new;
      $mp->open($conn_h, $sql_cl_r->{'ins_quar'}, $msginfo->mail_id, 'w',
                $msginfo->partition_tag, $sql_quarantine_chunksize_max,
                $msginfo->rx_time)
        or die "Can't open Amavis::IO::SQL object: $!";
      my $hdr_edits = $msginfo->header_edits;
      $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
      my($received_cnt,$file_position) =
        $hdr_edits->write_header($msginfo,$mp,!$initial_submission);
      if ($received_cnt > 100) { # loop detection required by RFC 5321 sect 6.2
        die "Too many hops: $received_cnt 'Received:' header fields";
      } elsif (!defined $msg) {
        # empty mail
      } elsif (ref $msg eq 'SCALAR') {
        $mp->print(substr($$msg,$file_position))
          or die "Can't write to SQL storage: $!";
      } elsif ($msg->isa('MIME::Entity')) {
        $msg->print_body($mp);
      } else {
        my($nbytes,$buff);
        while (($nbytes = $msg->read($buff,32768)) > 0) {
          $mp->print($buff) or die "Can't write to SQL storage: $!";
        }
        defined $nbytes or die "Error reading: $!";
      }
      $mp->close or die "Error closing Amavis::IO::SQL object: $!";
      $conn_h->commit;  1;
    } or do {
      my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;  my $msg = $err;
      $msg = "writing mail text to SQL failed: $msg"; do_log(0,"%s",$msg);
      if ($conn_h->in_transaction) {
        eval {
          $conn_h->rollback;
          do_log(1,"mail_via_sql: rollback done");  1;
        } or do {
          $@ = "errno=$!"  if $@ eq '';  chomp $@;
          do_log(1,"mail_via_sql: rollback %s", $@);
          die $@  if $@ =~ /^timed out\b/;  # resignal timeout
        };
      }
      die $err  if $err =~ /^timed out\b/;  # resignal timeout
      die $msg;
    };
    1;
  } or do { $err = $@ ne '' ? $@ : "errno=$!" };
  if ($err eq '') {
    $smtp_response = "250 2.6.0 Ok, Stored to sql db as mail_id $mail_id";
    snmp_count('OutMsgsDelivers');
    my $size = $msginfo->msg_size;
    snmp_count( ['OutMsgsSize'.$_, $size, 'C64'] )  for @snmp_vars;
  } else {
    chomp $err;
    if ($err =~ /too many hops\b/i) {
      $smtp_response = "554 5.4.6 Reject: $err";
      snmp_count('OutMsgsRejects');
    } else {
      $smtp_response =
        "451 4.5.0 Storing to sql db as mail_id $mail_id failed: $err";
      snmp_count('OutMsgsAttemptFails');
    }
    die $err  if $err =~ /^timed out\b/;  # resignal timeout
  }
  $smtp_response .= ", id=" . $msginfo->log_id;
  for my $r (@$per_recip_data_ref) {
    next  if $r->recip_done;
    $r->recip_smtp_response($smtp_response); $r->recip_done(2);
    if ($smtp_response =~ /^2/) {
      my $mbxname = $mail_id;
      my $p_tag = $msginfo->partition_tag;
      $mbxname .= '[' . $p_tag . ']'
        if defined($p_tag) && $p_tag ne '' && $p_tag ne '0';
      $r->recip_mbxname($mbxname);
    }
  }
  section_time('fwd-sql');
  1;
}

1;

__DATA__
#
package Amavis::AV;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::Util qw(ll untaint min max minmax unique_list do_log
                         add_entropy proto_decode rmdir_recursively
                         prolong_timer get_deadline generate_mail_id);
  import Amavis::ProcControl qw(exit_status_str proc_status_ok
                         run_command run_as_subprocess
                         collect_results collect_results_structured);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Timing qw(section_time);
  import Amavis::Out qw(mail_dispatch);
  import Amavis::rfc2821_2822_Tools qw(one_response_for_all);
}
use subs @EXPORT_OK;
use vars @EXPORT;

use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);
use Errno qw(EPIPE ENOTCONN ENOENT EACCES EINTR EAGAIN ECONNRESET);
use Time::HiRes ();

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

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

# called from sub ask_clamav or ask_daemon, should not run as a subprocess
#
use vars qw($clamav_obj $clamav_version);
sub clamav_module_internal_pre($) {
  my $av_name = $_[0];
  if (!defined $clamav_obj) {
    ($clamav_obj,$clamav_version) = clamav_module_init($av_name);  # first time
  } elsif ($clamav_obj->statchkdir) {     # db reload needed?
    do_log(2, "%s: reloading virus database", $av_name);
    ($clamav_obj,$clamav_version) = clamav_module_init($av_name);
  }
}

# called from sub ask_clamav or ask_daemon, may be called directly
# or in a subprocess
#
sub clamav_module_internal($@) {
  my($query, $bare_fnames,$names_to_parts,$tempdir, $av_name) = @_;
  $query = join(' ',@$query)  if ref $query;
  my $fname = "$tempdir/parts/$query";   # file to be checked
  my $part = $names_to_parts->{$query};  # get corresponding parts object
  my $options = 0;  # bitfield of options to Mail::ClamAV::scan
  my($opt_archive,$opt_mail);
  if ($clamav_version < 0.12) {
    $opt_archive = &Mail::ClamAV::CL_ARCHIVE;
    $opt_mail    = &Mail::ClamAV::CL_MAIL;
  } else {         # >= 0.12, reflects renamed flags in libclamav 0.80
    $opt_archive = &Mail::ClamAV::CL_SCAN_ARCHIVE;
    $opt_mail    = &Mail::ClamAV::CL_SCAN_MAIL;
  }
  # see clamav.h for standard options enabled by CL_SCAN_STDOPT
  $options |= &Mail::ClamAV::CL_SCAN_STDOPT  if $clamav_version >= 0.13;
  $options |= $opt_archive;  # turn on ARCHIVE
  $options &= ~$opt_mail;    # turn off MAIL
  my $type_decl = $part->type_declared;
  if (ref $part &&
      ($part->type_short eq 'MAIL' ||
       defined $type_decl && $type_decl=~m{^message/(?:rfc822|global)\z}si)) {
    do_log(2, "%s: $query - enabling option CL_MAIL", $av_name);
    $options |= $opt_mail;   # turn on MAIL
  }
  my $ret = $clamav_obj->scan(untaint($fname), $options);
  my($output,$status);
  if    ($ret->virus) { $status = 1; $output = "INFECTED: $ret" }
  elsif ($ret->clean) { $status = 0; $output = "CLEAN" }
  else { $status = 2; $output = $ret->error.", errno=".$ret->errno }
  ($status,$output);  # return synthesised status and a result string
}

# subroutine available for calling from @av_scanners list entries;
# it has the same args and returns as run_av() below
#
sub ask_clamav {
  my($bare_fnames,$names_to_parts,$tempdir, $av_name) = @_;
  clamav_module_internal_pre($av_name);  # must not run as a subprocess
# my(@results) = ask_av(\&clamav_module_internal, @_);  # invoke directly
  my($proc_fh,$pid) = run_as_subprocess(\&ask_av, \&clamav_module_internal,@_);
  my($results_ref,$child_stat) =
    collect_results_structured($proc_fh,$pid,$av_name,200*1024);
  !$results_ref ? () : @$results_ref;
}

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

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

# run by a master(!) process, invoked from a hook run_n_children_hook
#
sub sophos_savi_reload {
  if (defined $savi_obj) {
    do_log(3,"sophos_savi_reload: about to reload SAVI data");
    eval {
      my $status = $savi_obj->load_data;
      do_log(-1,"sophos_savi_reload: failed to load SAVI virus data %s (%s)",
                 $savi_obj->error_string($status), $status) if defined $status;
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(-1,"sophos_savi_reload failed: %s", $eval_stat);
    };
    my $version = $savi_obj->version;
    if (!ref($version)) {
      do_log(-1,"sophos_savi_reload: Can't get SAVI version: %s", $version);
    } else {
      do_log(2,"Updated SAVI data: Version %s (engine %d.%d) ".
               "recognizing %d viruses", $version->string,
               $version->major, $version->minor, $version->count);
    }
  }
}

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

# implements client side of the Sophos SSSP protocol
#
sub sophos_sssp_internal {
  my($query,
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_;
  my($query_template, $socket_specs) = !$args ? () : @$args;

  # short timeout for connect and sending a request
  prolong_timer('sophos_sssp_connect', undef, undef, 10);
  my($remaining_time, $deadline) = get_deadline('sophos_sssp_internal');
  # section_time('sssp-pre');

  my $sssp_handle =
    Amavis::IO::RW->new($socket_specs, Eol => "\015\012", Timeout => 10);
  defined $sssp_handle or die "Can't connect to savdid";
  # section_time('sssp-conn');

  my $ln; local($1);
  $ln = $sssp_handle->get_response_line;  # greeting
  defined $ln && $ln ne ''  or die "sssp no greeting";
  do_log(5,"sssp greeting %s", $ln);
  $ln =~ m{^OK\s+SSSP/(\d+.*)\015\012\z}s  or die "sssp bad greeting '$ln'";
  # section_time('sssp-greet');

# # Use the SSSP OPTIONS request only if necessary, it is cheaper to have the
# # options set in the configuration file. If a client has needs different
# # from other clients, create another channel tailored for that client.
# #
# $sssp_handle->print("SSSP/1.0 OPTIONS\015\012".
#                     "savists:zipdecompression 1\015\012".
#                     "output: brief\015\012\015\012")
#   or die "Error writing to sssp socket";
# $sssp_handle->flush or die "Error flushing sssp socket";
# $ln = $sssp_handle->get_response_line;
# defined $ln && $ln ne ''  or die "sssp no response to OPTIONS";
# do_log(5,"sssp response to OPTIONS: %s", $ln);
# $ln =~ /^ACC\s+(\S*)/  or die "sssp OPTIONS request not accepted";
# while (defined($ln = $sssp_handle->get_response_line)) {
#   last if $ln eq "\015\012";
#   do_log(5,"sssp result of OPTIONS: %s", $ln);
# }
# # section_time('sssp-opts');

  my $output = '';
  # normal timeout for reading a response
  prolong_timer('sophos_sssp_scan');
  $sssp_handle->timeout(max(3, $deadline - Time::HiRes::time));
  for my $fname (!ref($query) ? $query : @$query) {
    my $fname_enc = $fname;
    $fname_enc =~ s/([%\000-\040\177\377])/sprintf("%%%02X",ord($1))/gse;
    $sssp_handle->print("SSSP/1.0 SCANDIRR $fname_enc\015\012")
      or die "Error writing to sssp socket";
    $sssp_handle->flush or die "Error flushing sssp socket";
    $ln = $sssp_handle->get_response_line;
    defined $ln && $ln ne ''  or die "sssp no response to SCANDIRR";
    do_log(5,"sssp response to SCANDIRR: %s", $ln);
    # section_time('sssp-scan-ack');
    $ln =~ /^ACC\s+(\S*)/  or die "sssp SCANDIRR request not accepted";
    while (defined($ln = $sssp_handle->get_response_line)) {
      last if $ln eq "\015\012";
      do_log(3,"sssp result: %s", $ln);
      $output .= $ln  if length($output) < 10000;
    }
  }
  $output = proto_decode($output);
  # section_time('sssp-scan-result');

  $sssp_handle->print("BYE\015\012") or die "Error writing to sssp socket";
  $sssp_handle->flush or die "Error flushing sssp socket";
  $sssp_handle->timeout(max(3, $deadline - Time::HiRes::time));
  while (defined($ln = $sssp_handle->get_response_line)) {
    do_log(5,"sssp response to BYE: %s", $ln);
    last if $ln eq "\015\012" || $ln =~ /^BYE/;
  }
  # section_time('sssp-bye');
  $sssp_handle->close  or do_log(-1, "sssp - error closing session: $!");
  # section_time('sssp-close');
  (0,$output);  # return synthesised status and a result string
}

# implements client side of the AVIRA SAVAPI3 protocol
#
sub avira_savapi_internal {
  my($query,
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_;
  my($query_template, $socket_specs, $product_id) = !$args ? () : @$args;

  # short timeout for connect and sending a request
  prolong_timer('avira_savapi_connect', undef, undef, 10);
  my($remaining_time, $deadline) = get_deadline('avira_savapi_internal');
  # section_time('savapi-pre');

  my $savapi_handle =
    Amavis::IO::RW->new($socket_specs, Eol => "\012", Timeout => 10);
  defined $savapi_handle or die "Can't connect to savapi daemon";
  # section_time('savapi-conn');

  my $ln; local($1);
  $ln = $savapi_handle->get_response_line;  # greeting
  defined $ln && $ln ne ''  or die "savapi no greeting";
  do_log(5,"savapi greeting %s", $ln);
  $ln =~ m{^100 SAVAPI:(\d+.*)\012\z}s  or die "savapi bad greeting '$ln'";
  # section_time('savapi-greet');

  $remaining_time = int(max(3, $deadline - Time::HiRes::time + 0.5));
  for my $cmd ("SET PRODUCT $product_id",
               "SET SCAN_TIMEOUT $remaining_time",
               "SET CWD $tempdir/parts",
              ) {
    # consider: "SET MAILBOX_SCAN 1", "SET ARCHIVE_SCAN 1", "SET HEUR_LEVEL 2"
    $savapi_handle->print($cmd."\012") or die "Error writing '$cmd' to socket";
    $savapi_handle->flush or die "Error flushing socket";
    $ln = $savapi_handle->get_response_line;
    defined $ln && $ln ne ''  or die "savapi: no response to $cmd";
    do_log(5,"savapi response to '%s': %s", $cmd,$ln);
    $ln =~ /^100/  or die "savapi: $cmd request not accepted: $ln";
  }
  # section_time('savapi-settings');

  # set a normal timeout for reading a response
  prolong_timer('avira_savapi_scan');
  $savapi_handle->timeout(max(3, $deadline - Time::HiRes::time));
  my $keep_one_success; my $output = '';
  for my $fname (!ref($query) ? $query : @$query) {
    my $cmd = "SCAN $fname";  # files only, no directories
    $savapi_handle->print($cmd."\012") or die "Error writing '$cmd' to socket";
    $savapi_handle->flush or die "Error flushing socket";
    while (defined($ln = $savapi_handle->get_response_line)) {
      do_log(5,"savapi response to '%s': %s", $cmd,$ln);
      if ($ln =~ /^200/) {  # clean
        $keep_one_success = $ln  if !defined $keep_one_success;
      } else {
        $output .= $ln  if length($output) < 10000;  # sanity limit
      }
      last if $ln =~ /^([0125-9]\d\d|300|319).*\012/;  # terminal status
    # last if $ln =~ !/^(310|420|421|422|430).*\012/;  # nonterminal status
    }
  }
  $output = $keep_one_success  if $output eq '' && defined $keep_one_success;
  do_log(5,"savapi result: %s", $output);
  # section_time('savapi-scan-result');

  $savapi_handle->print("QUIT\012")
    or do_log(-1, "savapi - error writing QUIT to socket");
  $savapi_handle->flush
    or do_log(-1, "savapi - error flushing socket after QUIT");
  $savapi_handle->close
    or do_log(-1, "savapi - error closing session: $!");
  # section_time('savapi-close');
  (0,$output);  # return synthesised status and a result string
}

# implements client side of the ClamAV clamd protocol
#
sub clamav_clamd_internal {
  my($query,
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args) = @_;
  my($query_template, $socket_specs, $product_id) = !$args ? () : @$args;

  # short timeout for connect
  prolong_timer('clamav_connect', undef, undef, 10);
  my($remaining_time, $deadline) = get_deadline('clamav_internal');
  my $clamav_handle =
    Amavis::IO::RW->new($socket_specs, Eol => "\000", Timeout => 10);
  $clamav_handle or die "Can't connect to a clamd daemon";

  # set a normal timeout
  prolong_timer('clamav_scan');
  $clamav_handle->timeout(max(3, $deadline - Time::HiRes::time));
  $clamav_handle->print("zIDSESSION\0")
    or die "Error writing 'zIDSESSION' to a clamd socket: $!";

  my(@requests, @requests_filename, @requests_timestamp, $end_sent);
  my($req_id, $requests_pending) = (0,0);
  my $requests_remaining = !ref $query ? 1 : scalar @$query;
  my($keep_one_success, $aborted_id, $found_infected);
  my $output = '';
  while ($requests_remaining > 0 || $requests_pending > 0) {
    my $throttling = $requests_pending >= 8;
    if ($throttling) {
      # wait first for some of the pending results before sending new requests
      $clamav_handle->flush or die "Error flushing socket: $!";
      do_log(5,'clamav: throttling: %d pending, %d remaining',
               $requests_pending, $requests_remaining);
    } elsif ($requests_remaining > 0) {
      my $fname = !ref $query ? $query : $query->[$req_id];
      $req_id++;
      $requests[$req_id] = 'INITIATING';
      $requests_filename[$req_id] = $fname;
      ll(5) && do_log(5,'clamav: sending contents of %s, req_id %d',
                      $fname, $req_id);
      $clamav_handle->print("zINSTREAM\0")
        or die "Error writing 'zINSTREAM' to a clamd socket: $!";
      $requests[$req_id] = 'OPEN';
      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: $!";
      eval {
        my($nbytes,$buff); $buff = pack('N',0);
        while (($nbytes=$fh->read($buff, 32768-4, 4)) > 0) {
          $requests[$req_id] = 'SENDING';
          substr($buff,0,4) = pack('N',$nbytes);  # 32 bits len -> 4 bytes
          $clamav_handle->print($buff)
            or die "Error writing $nbytes bytes to a clamd socket: $!";
        }
        defined $nbytes or die "Error reading from $fname: $!";
        my $eod = pack('N',0);  # length zero indicates end of data
        if ($requests_remaining <= 0) { $eod .= "zEND\0"; $end_sent = 1 }
        $clamav_handle->print($eod)
          or die "Error writing end-of-data to a clamd socket: $!";
        $clamav_handle->flush or die "Error flushing clamd socket: $!";
        $requests[$req_id] = 'SENT';
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        $requests[$req_id] = 'ABORTED: '.$eval_stat;
        $aborted_id = $req_id;  # also boolean true, request IDs start with 1
        do_log(-1,'clamav: while feeding req_id %d: %s', $req_id, $eval_stat);
        my $disc_len = $clamav_handle->discard_pending_output;
        do_log(2,'clamav: discarding %d bytes', $disc_len)  if $disc_len;
      };
      $requests_timestamp[$req_id] = Time::HiRes::time;
      $requests_remaining--; $requests_pending++;
      $fh->close or die "Error closing file $fname: $!";
      do_log(5,'clamav: finished sending %s, req_id %d', $fname, $req_id);
    }
    while ( ($requests_pending > 0 && !$aborted_id) ||
            $clamav_handle->response_line_available ) {
      my $ln = $clamav_handle->get_response_line;
      last if !defined $ln;
      my $rx_time = Time::HiRes::time;
      do_log(5,'clamav: got response %s', $ln);

      my($id, $id_n, $resp); local($1,$2);
      if ($ln =~ /^(\d+):\s*(.*?)\000\z/s) {
        ($id,$resp) = ($1,$2); $id_n = 0+$id;
      } elsif ($ln =~ / ERROR\000\z/) {
        if ($aborted_id) {
          $id = $aborted_id; $id_n = 0+$id;
          do_log(-1,'clamav: (possibly id=%d) error response: %s', $id,$ln);
        } else {
          do_log(-1,'clamav: error response: %s', $ln);
        }
      } else {
        do_log(-1,'clamav: unparseable response %s', $ln);
        next;
      }
      if (!defined $id) {
        # failure already reported
      } elsif (!defined $requests[$id_n]) {
        do_log(-1,'clamav: bogus id %s in response ignored: %s', $id,$ln);
      } elsif ($requests[$id_n] eq 'DONE') {
        do_log(-1,'clamav: duplicate result for id %s: %s', $id,$ln);
      } else {
        ll(5) && do_log(5,'clamav: request id %s on %s took %.1f ms',
                          $id, $requests_filename[$id_n],
                          1000 * ($rx_time - $requests_timestamp[$id_n]));
        if ($requests[$id_n] ne 'SENT') {
          do_log(2,'clamav: result based on incomplete data, state %s: %s',
                   $requests[$id_n], $ln);
        }
        $ln =~ s/\000\z/\n/s;
        $ln =~ s/^\Q$id\E:\s*stream:\s*/$requests_filename[$id_n]: /s;
        if (defined $resp && $resp =~ /\bOK\z/) {  # clean
          $keep_one_success = $ln  if !defined $keep_one_success;
        } else {
          $output .= $ln  if length($output) < 10000;  # sanity limit
        }
        $requests[$id_n] = 'DONE';
        $requests_pending--  if $requests_pending > 0;
        undef $requests_filename[$id_n];
        undef $requests_timestamp[$id_n];
        if ($resp =~ /\bFOUND\z/) {
          $found_infected = 1;
          if ($requests_remaining > 0 && c('first_infected_stops_scan')) {
            do_log(2,'clamav: first infected stops scan');
            $requests_remaining = 0;
          }
        }
      }
    }
    if ($aborted_id) {
      do_log(-1,'clamav: aborting: %d pending, %d remaining',
                $requests_pending, $requests_remaining);
      $clamav_handle->close
        or do_log(5,'clamav: error closing session: %s', $!);
      undef $clamav_handle;
      if ($found_infected) {
        # just normally return an infection report,
        # even though not all content has been scanned
        do_log(5,'clamav: result: %s', $output);
        return (0,$output);  # return synthesised status and a result string
      } else {
        die 'clamav: '.$requests[$aborted_id];
      }
    }
  }
  $output = $keep_one_success  if $output eq '' && defined $keep_one_success;
  do_log(5,'clamav: result: %s', $output);
  if ($clamav_handle) {
    if (!$end_sent) {
      $clamav_handle->print("zEND\0")
        or do_log(-1,"clamav: error writing 'zEND' to a clamd socket: %s", $!);
    }
    $clamav_handle->close
      or do_log(-1,'clamav: error closing session: %s', $!);
  }
  (0,$output);  # return synthesised status and a result string
}

sub av_smtp_client($$$$) {
  my($msginfo,$av_name,$av_test_method,$av_test_recip) = @_;
  $av_test_recip = 'dummy@localhost'  if !defined $av_test_recip;
  my $test_msg = Amavis::In::Message->new;
  $test_msg->rx_time($msginfo->rx_time);      # copy the reception time
  $test_msg->log_id($msginfo->log_id);        # use the same log_id
  $test_msg->partition_tag($msginfo->partition_tag);  # same partition_tag
  $test_msg->parent_mail_id($msginfo->mail_id);
  $test_msg->mail_id(scalar generate_mail_id());
  $test_msg->conn_obj($msginfo->conn_obj);
  $test_msg->mail_id($msginfo->mail_id);      # use the same mail_id
  $test_msg->body_type($msginfo->body_type);  # use the same BODY= type
  $test_msg->header_8bit($msginfo->header_8bit);
  $test_msg->body_8bit($msginfo->body_8bit);
  $test_msg->body_digest($msginfo->body_digest);  # copy original digest
  $test_msg->dsn_ret($msginfo->dsn_ret);
  $test_msg->dsn_envid($msginfo->dsn_envid);
  $test_msg->smtputf8($msginfo->smtputf8);
  $test_msg->sender($msginfo->sender);        # original sender
  $test_msg->sender_smtp($msginfo->sender_smtp);
  $test_msg->auth_submitter($msginfo->sender_smtp);
  $test_msg->auth_user(c('amavis_auth_user'));
  $test_msg->auth_pass(c('amavis_auth_pass'));
  $test_msg->recips([$av_test_recip]);        # made-up recipient
  $_->delivery_method($av_test_method)  for @{$test_msg->per_recip_data};
  $test_msg->originating(0);                  # disables DKIM signing
  $test_msg->mail_text($msginfo->mail_text);  # the original mail contents
  $test_msg->mail_text_str($msginfo->mail_text_str);
  $test_msg->body_start_pos($msginfo->body_start_pos);
  $test_msg->skip_bytes($msginfo->skip_bytes);
  # NOTE: $initial_submission argument is typically treated as a boolean
  # but here a value of 2 is supplied to allow a forwarding method to
  # distinguish it from ordinary submissions
  mail_dispatch($test_msg, 'AV', 0);
  my($smtp_resp, $exit_code, $dsn_needed) =
    one_response_for_all($test_msg, 0);  # check status
  do_log(2, "av_smtp_client %s: %s, %s", $av_name,$av_test_method,$smtp_resp);
  (0, $smtp_resp);
}

# same args and returns as run_av() below,
# but prepended by a $query, which is a string to be sent to the daemon.
# Handles UNIX, INET and INET6 domain sockets.
# More than one socket may be specified for redundancy, they will be tried
# one after the other until one succeeds.
#
sub ask_daemon_internal {
  my($query,  # expanded query template, often a command and a file or dir name
     $bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args,
     $sts_clean,$sts_infected,$how_to_get_names,  # regexps
  ) = @_;
  my($query_template_orig,$socket_specs) = @$args;
  my $output = '';
  $socket_specs = [ $socket_specs ]  if !ref($socket_specs);
  my($remaining_time, $deadline) =
    get_deadline('ask_daemon_internal_connect_pre');
  my $max_retries = 2 * @$socket_specs;  my $retries = 0;
  # Sophie, Trophie and fpscand can accept multiple requests per session
  # and return a single line response each time
  my $multisession = $av_name =~ /\b(Sophie|Trophie|fpscand)\b/i ? 1 : 0;
  for (;;) {  # gracefully handle cases when av process times out or restarts
    # short timeout for connect and sending a request
    prolong_timer('ask_daemon_internal_connect', undef, undef, 10);
    @$socket_specs  or die "panic, no sockets specified!?";  # sanity
    # try the first one in the current list
    my $socketname = $socket_specs->[0];
    my $sock = $st_sock{$socketname};
    my $eval_stat;
    eval {
      if (!$st_socket_created{$socketname}) {
        ll(3) && do_log(3, "%s: Connecting to socket %s %s%s",
                           $av_name, $daemon_chroot_dir, $socketname,
                           !$retries ? '' : ", retry #$retries" );
        $sock = Amavis::IO::RW->new($socketname, Timeout => 10);
        $st_sock{$socketname} = $sock;
        defined $sock or die "Can't connect to socket $socketname\n";
        $st_socket_created{$socketname} = 1;
      }
      $query = join(' ',@$query)  if ref $query;
      ll(3) && do_log(3,"%s: Sending %s to socket %s",
                        $av_name, $query, $socketname);
      $sock->print($query) or die "Error writing to socket $socketname\n";
      $sock->flush         or die "Error flushing socket $socketname\n";

      # normal timeout for reading a response
      prolong_timer('ask_daemon_internal_scan');
      $sock->timeout(max(3, $deadline - Time::HiRes::time));
      if ($multisession) {
        # depends on TCP segment boundaries, unreliable
        my $nread = $sock->read($output,16384);
        defined $nread  or die "Error reading from $socketname: $!\n";
        # and keep the socket open
      } else {  # single request/response per connection
        my $buff = '';
        for (;;) {
          my $nread = $sock->read($buff,16384);
          if (!defined($nread)) {
            die "Error reading from $socketname: $!\n";
          } elsif ($nread < 1) {
            last;   # sysread returns 0 at eof
          } else {  # successful read
            $output .= $buff  if length($output) < 100000;  # sanity
          }
        }
        $sock->close  or die "Error closing socket $socketname\n";
        $st_sock{$socketname} = $sock = undef;
        $st_socket_created{$socketname} = 0;
      }
      $output ne '' or die "Empty result from $socketname\n";
      1;
    } or do {
      $eval_stat = $@ ne '' ? $@ : "errno=$!";
    };
    prolong_timer('ask_daemon_internal');
    last  if !defined $eval_stat;  # mission accomplished

    # error handling (the most interesting error codes are EPIPE and ENOTCONN)
    chomp $eval_stat; my $err = "$!"; my $errn = 0+$!;

    # close socket through its DESTROY method, ignoring status
    $st_sock{$socketname} = $sock = undef;
    $st_socket_created{$socketname} = 0;

    if (Time::HiRes::time >= $deadline) {
      die "ask_daemon_internal: Exceeded allowed time";
    }
    ++$retries <= $max_retries
      or die "Too many retries to talk to $socketname ($eval_stat)";
    if ($retries <= 1 && $errn == EPIPE) {  # common, don't cause concern
      do_log(2,"%s broken pipe (don't worry), retrying (%d)",
               $av_name,$retries);
    } else {
      do_log( ($retries > 1 ? -1 : 1),
              "%s: %s, retrying (%d)", $av_name,$eval_stat,$retries);
      if ($retries % @$socket_specs == 0) {  # every time the list is exhausted
        my $dly = min(20, 1 + 5 * ($retries/@$socket_specs - 1));
        do_log(3,"%s: sleeping for %s s", $av_name,$dly);
        sleep($dly);   # slow down a possible runaway
      }
    }
    # leave good socket as the first entry in the list
    # so that it will be tried first when needed again
    if (@$socket_specs > 1) {
      push(@$socket_specs, shift @$socket_specs);  # circular shift left
    }
  }
  (0,$output);  # return synthesised status and a result string
}

# subroutine is available for calling from @av_scanners list entries;
# it has the same args and returns as run_av() below.
# Based on an implied protocol, or on an explicitly specified protocol name
# in the second element of array @$args, it determines a subroutine needed
# to implement the required protocol (defaulting to &ask_daemon_internal)
# and replaces $command in the argument list by this subroutine reference,
# then calls run_av with adjusted arguments.  So, its main purpose is to map
# a protocol name (a string) into an internal code reference.
#
sub ask_daemon {
  my($bare_fnames,$names_to_parts,$tempdir, $av_name,$command,$args,
     $sts_clean,$sts_infected,$how_to_get_names) = @_;
  my($av_method,$av_protocol); local($1);
  # determine a protocol name from the second element of array @$args
  $av_method = $args->[1]  if $args && @$args >= 2;
  $av_method = $av_method->[0]  if ref $av_method;
  $av_protocol = lc($1)  if defined $av_method &&
                            $av_method =~ /^([a-z][a-z0-9.+-]*):/si;
  my $code; my $run_spawned = 0;
  if (!defined $av_protocol) {
    # for compatibility with old style socket specification with
    # no protocol (scheme) field, equivalent to a former call to ask_av()
    #   Sophie, Trophie, ClamAV-clamd, OpenAntiVirus, AVG,
    #   F-Prot fpscand, F-Prot f-protd, DrWebD, avast, ESET NOD32SS
    $code = \&ask_daemon_internal;
  } elsif ($av_protocol =~ /^(simple|sophie|trophie)\z/) {
    # same as default, but with an explicit protocol prefix
    $code = \&ask_daemon_internal;
  } elsif ($av_protocol eq 'sssp') {  # Sophos SSSP
    $code = \&sophos_sssp_internal;
  } elsif ($av_protocol eq 'savapi') {  # Avira SAVAPI3
    $code = \&avira_savapi_internal;
  } elsif ($av_protocol eq 'clamd') {  # ClamAV clamd protocol
    $code = \&clamav_clamd_internal;
  } elsif ($av_protocol eq 'smtp' || $av_protocol eq 'lmtp') {
    $code = sub { av_smtp_client($Amavis::MSGINFO, $av_name,
                                 $av_method, $args->[2]) };
  } elsif ($av_protocol eq 'savi-perl') {  # using SAVI-Perl perl module
    if (@_ < 3+6) {  # supply default arguments for backward compatibility
      $args = ['*']; $sts_clean = [0]; $sts_infected = [1];
      $how_to_get_names = qr/^(.*) FOUND$/m;
    }
    $code = \&sophos_savi_internal;
  } elsif ($av_protocol eq 'clamav-perl') {  # using Mail::ClamAV perl module
    clamav_module_internal_pre($av_name);  # must not run as a subprocess
    $code = \&clamav_module_internal; $run_spawned = 1;
  }
  ll(5) && do_log(5, "ask_daemon: proto=%s, spawn=%s, (%s) %s",
                     !defined $av_protocol ? 'DFLT' : $av_protocol,
                     $run_spawned, $av_name, $av_method);
  ref $code or die "Unsupported AV protocol name: $av_method";
  $command = $code;
  # reassemble arguments, after possibly being modified
  my(@run_av_args) = ($bare_fnames,$names_to_parts,$tempdir,
          $av_name,$command,$args, $sts_clean,$sts_infected,$how_to_get_names);
  my(@results);
  if (!$run_spawned) {
    @results = run_av(@run_av_args);  # invoke directly
  } else {
    my($proc_fh,$pid) = run_as_subprocess(\&ask_av, @run_av_args);
    my($results_ref,$child_stat) =
      collect_results_structured($proc_fh,$pid,$av_name,200*1024);
    @results = @$results_ref  if $results_ref;
  }
  @results;  # ($scan_status,$output,$virusnames)
}

# for compatibility with pre-2.6.0 versions of amavisd-new and
# old @av_scanners entries;  use ask_daemon and/or run_av instead
sub ask_av(@) {
  my($code, @run_av_args) = @_;
  $run_av_args[4] = $code;  # replaces $command with a supplied $code
  run_av(@run_av_args);
}

# Call a virus scanner and parse its output.
# Returns a triplet, or dies in case of failure.
# The first element of the triplet has the following semantics:
# - true if virus found,
# - 0 if no viruses found,
# - undef if it did not complete its job;
# the second element is a string, the text as provided by the virus scanner;
# the third element is ref to a list of virus names found (if any).
#   (it is guaranteed the list will be nonempty if virus was found)
#
# If there is at least one glob character '*' present in a query template, the
# subroutine will traverse supplied files (@$bare_fnames) and call a supplied
# subroutine or program for each file to be scanned, summarizing the final
# av scan result. If there are no glob characters in a template, the result
# is a single call to a supplied subroutine or program, which will presumably
# traverse a directory by itself.
#
sub run_av(@) {
  my($bare_fnames,  # a ref to a list of filenames to scan (basenames)
     $names_to_parts, # ref to a hash that maps base file names to parts object
     $tempdir,      # temporary directory
      # n-tuple from an @av_scanners list entry starts here
     $av_name, $command, $args,
     $sts_clean,    # a ref to a list of status values, or a regexp
     $sts_infected, # a ref to a list of status values, or a regexp
     $how_to_get_names, # ref to sub, or a regexp to get list of virus names
     $pre_code, $post_code,  # routines to be invoked before and after av
  ) = @_;
  my($scan_status,@virusnames,$error_str); my $output = '';
  return (0,$output,\@virusnames)  if !defined($bare_fnames) || !@$bare_fnames;
  my($query_template, $socket_specs); my $av_protocol = '';
  if (!ref $args) {
    $query_template = $args;
  } else {
    ($query_template, $socket_specs) = @$args;
    $socket_specs = $socket_specs->[0]  if ref $socket_specs;
    if (defined $socket_specs) {
      local($1);
      $av_protocol = lc($1)  if $socket_specs =~ /^([a-z][a-z0-9.+-]*):/si;
    }
  }
  my $one_at_a_time = 0;
  $one_at_a_time = 1  if ref $command &&
                         $av_protocol !~ /^(?:sssp|savapi|clamd)\z/;
  my(@query_template) = $one_at_a_time ? $query_template  # treat it as one arg
                                    : split(' ',$query_template);  # shell-like
  my $bare_fnames_last = $#{$bare_fnames};
  do_log(5,"run_av (%s): query template(%s,%d): %s",
           $av_name,$one_at_a_time,$bare_fnames_last,$query_template);
  my($remaining_time, $deadline) = prolong_timer('run_av_pre');
  my $cwd = "$tempdir/parts";
  chdir($cwd) or die "Can't chdir to $cwd: $!";
  &$pre_code(@_)  if defined $pre_code;
  # a '{}' will be replaced by a directory name, '{}/*' and '*' by file names
  local($1);
  my(@query_expanded) = map($_ eq '*' || $_ eq '{}/*' ? []
                          : m{^ \{ \} ( / .* )? \z}xs ? "$tempdir/parts$1"
                          : $_,  @query_template);
  my $eval_stat;
  eval {
    for (my $k = 0; $k <= $bare_fnames_last;  ) {  # traverse fnames in chunks
      my(@processed_filenames);
      my $arglist_size = 0;  # size of a command with its arguments so far
      for ($command,@query_expanded) { $arglist_size+=length($_)+1 if !ref $_ }
      for (@query_expanded) { @$_ = () if ref $_ }  # reset placeholder lists
      while ($k <= $bare_fnames_last) {  # traverse fnames individually
        my $f = $bare_fnames->[$k];  my $multi = 0;
        if ($one_at_a_time) {  # glob templates may be substrings anywhere
          local($1);  @query_expanded = @query_template;  # start afresh
          s{ ( \{ \} (?: / \* )? | \* ) }
           { $1 eq '{}'   ? "$tempdir/parts"
           : $1 eq '{}/*' ? ($multi=1,"$tempdir/parts/$f")
           : $1 eq '*'    ? ($multi=1,$f)  : $1
           }xgse  for @query_expanded;
        } else {
          # collect as many filename arguments as suitable, but at least one
          my $arg_size = 0;
          for (@query_template) {
            if ($_ eq '{}/*') { $arg_size += length("$tempdir/parts/$f") + 1 }
            elsif ($_ eq '*') { $arg_size += length($f) + 1 }
          }
        # do_log(5,"run_av arglist size: %d + %d", $arglist_size,$arg_size);
          if (@processed_filenames && $arglist_size + $arg_size > 4000) {
            # POSIX requires 4 kB as a minimum buffer size for program args
            last;  # enough collected for now, the rest on the next iteration
          }
          # exact matching on command arguments, no substring matches
          for my $j (0..$#query_template) {
            if (ref $query_expanded[$j]) {  # placeholders collecting fnames
              my $arg = $query_template[$j];
              my $repl = $arg eq '{}/*' ? "$tempdir/parts/$f"
                       : $arg eq '*'    ? $f  : undef;
              $multi = 1;
              push(@{$query_expanded[$j]}, untaint($repl));
              $arglist_size += length($repl) + 1;
            }
          }
        }
        $k = $multi ? $k+1 : $bare_fnames_last+1;
        push(@processed_filenames, $multi ? $f : "$tempdir/parts");
        last  if $one_at_a_time;
      }
      # now that arguments have been expanded, invoke the scanner
      my($child_stat,$t_status,$t_output);
      prolong_timer('run_av_scan');  # restart timer
      if (ref $command) {
        my(@q) = map(ref $_ ? @$_ : $_, @query_expanded);
        ll(3) && do_log(3, "run_av Using (%s): (code) %s",
                           $av_name, join(' ',@q));
        # call subroutine directly, passing all our arguments to it
        ($t_status,$t_output) = &$command(!@q ? '' : @q==1 ? $q[0] : \@q, @_);
        prolong_timer('run_av_3');  # restart timer
        $child_stat = 0;  # no spawned process, just declare success
        do_log(4,"run_av (%s) result: %s", $av_name,$t_output);
      } else {
        my($proc_fh,$pid); my $results_ref;
        my $eval_stat2;
        eval {
          my(@q) = map(ref $_ ? @$_ : $_, @query_expanded);
          ll(3) && do_log(3,"run_av Using (%s): %s %s",
                            $av_name,$command,join(' ',@q));
          ($proc_fh,$pid) = run_command(undef, '&1', $command, @q);
          ($results_ref,$child_stat) =
            collect_results($proc_fh,$pid, $av_name,200*1024);
          1;
        } or do { $eval_stat2 = $@ ne '' ? $@ : "errno=$!" };
        undef $proc_fh; undef $pid;
        $error_str = exit_status_str($child_stat,0);
        $t_status = WEXITSTATUS($child_stat)  if defined $child_stat;
        prolong_timer('run_av_4');  # restart timer
        if (defined $eval_stat2) {
          chomp $eval_stat2; $error_str = $eval_stat2;
          do_log(-1, "run_av (%s): %s", $av_name,$eval_stat2);
        }
        if (defined $results_ref)
          { $t_output = $$results_ref; undef $results_ref }
        chomp($t_output); my $t_output_trimmed = $t_output;
        $t_output_trimmed =~ s/\r\n/\n/gs; local($1);
        $t_output_trimmed =~ s/([ \t\n\r])[ \t\n\r]{4,}/$1.../gs;
        $t_output_trimmed = "..." . substr($t_output_trimmed,-800)
          if length($t_output_trimmed) > 800;
        do_log(3, "run_av: %s %s, %s", $command,$error_str,$t_output_trimmed);
      }
      if (!defined($child_stat) || !WIFEXITED($child_stat)) {
        # leave $scan_status undefined, indicating an error
      # braindamaged Perl: empty string implies the last successfully
      # matched regular expression; we must avoid this
      } elsif (defined $sts_infected && (
          ref($sts_infected) eq 'ARRAY' ? (grep($_==$t_status, @$sts_infected))
                              : $sts_infected eq '' ? 1  # avoid m// stupidity
                              : $t_output=~/$sts_infected/m)) {  # is infected
        # test for infected first, in case both expressions match
        $scan_status = 1;  # 'true' indicates virus found
        my(@t_virusnames) = ref($how_to_get_names) eq 'CODE'
                              ? &$how_to_get_names($t_output)
                              : $how_to_get_names eq '' ? ()
                              : $t_output=~/$how_to_get_names/gm;
        @t_virusnames = grep(defined $_, @t_virusnames);
        push(@virusnames, @t_virusnames);
        $output .= $t_output . "\n";
        do_log(2,"run_av (%s): %s INFECTED: %s", $av_name,
                 join(' ',@processed_filenames), join(', ',@t_virusnames) );
      } elsif (!defined($sts_clean)) {  # clean, but inconclusive
        # by convention: undef $sts_clean means result is inconclusive,
        # file appears clean, but continue scanning with other av scanners,
        # the current scanner does not want to vouch for it; useful for a
        # scanner like jpeg checker which tests for one vulnerability only
        do_log(3,"run_av (%s): CLEAN, but inconclusive", $av_name);
      } elsif (ref($sts_clean) eq 'ARRAY'
                    ? (grep($_==$t_status, @$sts_clean))
                    : ""=~/x{0}/ && $t_output=~/$sts_clean/m) {  # is clean
        # 'false' (but defined) indicates no viruses
        $scan_status = 0  if !$scan_status;   # no viruses, no errors
        do_log(3,"run_av (%s): CLEAN", $av_name);
      } else {
      # $error_str = "unexpected $error_str, output=\"$t_output_trimmed\"";
        $error_str = "unexpected $error_str, output=\"$t_output\"";
        do_log(-1,"run_av (%s) FAILED - %s", $av_name,$error_str);
        last;  # error, bail out
      }
      die "Exceeded allowed time\n"  if time >= $deadline;
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  &$post_code(@_)  if defined $post_code;
  @virusnames = ('')  if $scan_status && !@virusnames;  # ensure nonempty list
  do_log(3,"run_av (%s) result: clean", $av_name)
    if defined($scan_status) && !$scan_status;
  chdir($tempdir) or die "Can't chdir to $tempdir: $!";
  if (defined $eval_stat) {
    prolong_timer('run_av_5');  # restart timer
    die "run_av error: $eval_stat\n";
  }
  if (!defined($scan_status) && defined($error_str)) {
    die "$command $error_str";  # die is more informative than a return value
  }
  ($scan_status, $output, \@virusnames);
}

# @av_scanners is a list of n-tuples, where fields semantics is:
#  1. name: an AV scanner plain name, to be used in log and reports;
#  2a. program: a scanner program name; this string will be submitted to
#     subroutine find_external_programs(), which will try to find the full
#     program path name during startup according to a search path in variable
#     $path; if program is not found, this scanner is disabled. Besides a
#     simple string (a full program path name or just the basename to be
#     looked for in PATH), this may be an array ref of alternative program
#     names or full paths - the first match in the list will be used;
#  2b. subroutine: alternatively, this second field may be a subroutine
#     reference, and the whole n-tuple entry is passed to it as args;
#     it should return a triple: ($scan_status,$output,$virusnames_ref),
#     where:
#     - $scan_status is: true if a virus was found, 0 if no viruses,
#       undef if scanner was unable to complete its job (failed);
#     - $output is an optional result string to appear in logging and macro %v;
#     - $virusnames_ref is a ref to a list of detected virus names (may be
#       undef or a ref to an empty list);
#  3. args: command arguments to be given to the scanner program;
#     a substring {} will be replaced by the directory name to be scanned, i.e.
#     "$tempdir/parts", a "*" will be replaced by base file names of parts;
#  4. clean: an array ref of av scanner exit status values, or a regexp
#     (to be matched against scanner output), indicating NO VIRUSES found;
#     a special case is a value undef, which does not claim file to be clean
#     (i.e. it never matches, similar to []), but suppresses a failure warning;
#     to be used when the result is inconclusive (useful for specialized and
#     quick partial scanners such as jpeg checker);
#  5. infected: an array ref of av scanner exit status values, or a regexp
#     (to be matched against scanner output), indicating VIRUSES WERE FOUND;
#     a value undef may be used and it never matches (for consistency with 4.);
#     Note: the virus match prevails over a 'not found' match, so it is safe
#     even if the no. 4. matches for viruses too;
#  6. virus name: a regexp (to be matched against scanner output), returning
#     a list of virus names found, or a sub ref, returning such a list when
#     given scanner output as argument;
#  7. and 8.: (optional) subroutines to be executed before and after scanner
#     (e.g. to set environment or current directory);
#     see examples for these at KasperskyLab AVP and NAI uvscan.

sub virus_scan($$) {
  my($msginfo,$firsttime) = @_;
  my $tempdir = $msginfo->mail_tempdir;
  my($scan_status,$output,@virusname);
  my(@detecting_scanners,@av_scanners_results);
  my $anyone_done = 0; my $anyone_tried = 0;
  my($bare_fnames_ref,$names_to_parts);
  my $j; my $tier = 'primary';
  for my $av (@{ca('av_scanners')}, "\000", @{ca('av_scanners_backup')}) {
    next  if !defined $av;
    if ($av eq "\000") {  # 'magic' separator between lists
      last  if $anyone_done;
      do_log(-1,"WARN: all %s virus scanners failed, considering backups",
                $tier);
      $tier = 'secondary';  next;
    }
    next  if !ref $av || !defined $av->[1];
    if (!defined $bare_fnames_ref) {  # first time: collect file names to scan
      my $parts_root = $msginfo->parts_root;
      ($bare_fnames_ref,$names_to_parts) =
        files_to_scan("$tempdir/parts", $parts_root);
      if (!@$bare_fnames_ref) {
        do_log(2, "Not calling virus scanners, no files to scan in %s/parts",
                  $tempdir);
      } else {
        do_log(5, "Calling virus scanners, %d files to scan in %s/parts",
                  scalar(@$bare_fnames_ref), $tempdir);
      }
    }
    my($scanner_name,$command) = @$av;
    $anyone_tried = 1; my($this_status,$this_output,$this_vn);
    if (!@$bare_fnames_ref) {  # no files to scan?
      ($this_status,$this_output,$this_vn) = (0, '', undef);  # declare clean
    } else {  # call virus scanner
      do_log(5, "invoking av-scanner %s", $scanner_name);
      eval {
        ($this_status,$this_output,$this_vn) = ref $command eq 'CODE'
            ? &$command($bare_fnames_ref,$names_to_parts,$tempdir, @$av)
            :    run_av($bare_fnames_ref,$names_to_parts,$tempdir, @$av);
        1;
      } or do {
        my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
        $err = sprintf("%s av-scanner FAILED: %s", $scanner_name, $err);
        do_log(-1, "%s", $err);
        $this_status = undef;
      };
    }
    $anyone_done = 1  if defined $this_status;
    $j++; section_time("AV-scan-$j");
    if ($this_status && $this_vn && @$this_vn) {
      @$this_vn = unique_list($this_vn);
      # virus is reported by this scanner; is it for real, or is it just spam?
      my(@spam_hits);  my $vnts = ca('virus_name_to_spam_score_maps');
      @spam_hits =  # map each reported virus name to spam score or to undef
        map(scalar(lookup2(0,$_,$vnts)), @$this_vn)  if ref $vnts;
      if (@spam_hits && !grep(!defined($_), @spam_hits)) {  # all defined
        # AV scanner did trigger, but all provided names are actually spam!
        my(%seen);
        for my $r (@{$msginfo->per_recip_data}) {
          my $spam_tests = $r->spam_tests;
          if ($spam_tests) {
            local($1,$2);
            for (split(/,/, join(',',map($$_,@$spam_tests)))) {
              $seen{$1} = $2  if /^AV\.([^=]*)=([0-9.+-]+)\z/;
            }
          }
        }
        my(@vnms,@hits);
        # remove already detected virus names and duplicates from the list
        for my $j (0..$#$this_vn) {
          my $vname = $this_vn->[$j];
          if (!exists($seen{$vname})) {
            push(@vnms,$vname); push(@hits,$spam_hits[$j]);
            $seen{$vname} = $spam_hits[$j];  # keep only one copy
          }
        }
        @$this_vn = @vnms; @spam_hits = @hits;
        if (!@spam_hits) {
          do_log(2,"Turning AV infection into a spam report, ".
                   "name already accounted for");
        } else {
          my $spam_level = max(@spam_hits);
          my $spam_tests = join(',',
                    map(sprintf("AV:%s=%s", $this_vn->[$_], $spam_hits[$_]),
                        (0..$#$this_vn) ));
          for my $r (@{$msginfo->per_recip_data}) {
            $r->spam_level( ($r->spam_level || 0) + $spam_level );
            if (!$r->spam_tests) {
              $r->spam_tests([ \$spam_tests ]);
            } else {
              push(@{$r->spam_tests}, \$spam_tests);
            }
          }
          my $spam_report = $spam_tests;
          my $spam_summary =
            sprintf("AV scanner %s reported spam (not infection):\n%s\n",
                    $scanner_name, join(',',@$this_vn));
          do_log(2,"Turning AV infection into a spam report: score=%s, %s",
                   $spam_level, $spam_tests);
          if (defined($msginfo->spam_report)||defined($msginfo->spam_summary)){
            $spam_report = $msginfo->spam_report . ', ' . $spam_report
              if $msginfo->spam_report ne '';
            $spam_summary = $msginfo->spam_summary . "\n\n" . $spam_summary
              if $msginfo->spam_summary ne '';
          }
          $msginfo->spam_report($spam_report);
          $msginfo->spam_summary($spam_summary);
        }
        $this_status = 0; @$this_vn = (); # TURN OFF ALERT for this AV scanner!
      }
    }
    push(@av_scanners_results,
         [$av, $this_status, !$this_vn ? () : @$this_vn]);
    if ($this_status) {  # a virus detected by this scanner, really! (not spam)
      push(@detecting_scanners, $scanner_name);
      if (!@virusname) {  # store results of the first scanner detecting
        @virusname = @$this_vn  if $this_vn;
        $scan_status = $this_status; $output = $this_output;
      }
      last  if c('first_infected_stops_scan');  # stop now if we found a virus?
    } elsif (!defined($scan_status)) {  # tentatively keep regardless of status
      $scan_status = $this_status; $output = $this_output;
    }
  }
  if (ll(2) && @virusname && @detecting_scanners) {
    my(@ds) = @detecting_scanners;  s/,/;/ for @ds;  # facilitates parsing
    do_log(2, "virus_scan: (%s), detected by %d scanners: %s",
              join(', ',@virusname), scalar(@ds), join(', ',@ds));
  }
  $output =~ s{\Q$tempdir\E/parts/?}{}gs  if defined $output;  # hide path info
  if (!$anyone_tried) { die "NO VIRUS SCANNERS AVAILABLE\n" }
  elsif (!$anyone_done) { die "ALL VIRUS SCANNERS FAILED\n" }
  ($scan_status, $output, \@virusname,
   \@detecting_scanners, \@av_scanners_results);  # return a 5-tuple
}

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

1;

__DATA__
#
package Amavis::SpamControl;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

use Fcntl qw(:flock);
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Util qw(ll do_log min max minmax untaint untaint_inplace
                         unique_list);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::rfc2821_2822_Tools qw(make_query_keys qquote_rfc2821_local);
}

sub new {
  my $class = $_[0];
  my $self = bless { scanners_list => [] }, $class;
  for my $as (@{ca('spam_scanners')}) {
    if (ref $as && defined $as->[1] && $as->[1] ne '') {
      my($scanner_name,$module,@args) = @$as; my $scanner_obj;
      do_log(5, "SpamControl: attempting to load scanner %s, module %s",
                $scanner_name,$module);
      { no strict 'subs';
        $scanner_obj = $module->new($scanner_name,$module,@args);
      }
      if ($scanner_obj) {
        push(@{$self->{scanners_list}}, [$scanner_obj, @$as]);
        do_log(2, "SpamControl: scanner %s, module %s",
                  $scanner_name,$module);
      } else {
        do_log(5, "SpamControl: no scanner %s, module %s",
                  $scanner_name,$module);
      }
    }
  }
  $self;
}

# called at startup, before chroot and before main fork
#
sub init_pre_chroot {
  my $self = $_[0];
  for my $as (@{$self->{scanners_list}}) {
    my($scanner_obj,$scanner_name) = @$as;
    if ($scanner_obj && $scanner_obj->UNIVERSAL::can('init_pre_chroot')) {
      $scanner_obj->init_pre_chroot;
      do_log(1, "SpamControl: init_pre_chroot on %s done", $scanner_name);
    }
  }
}

# called at startup, after chroot and changing UID, but before main fork
#
sub init_pre_fork {
  my $self = $_[0];
  for my $as (@{$self->{scanners_list}}) {
    my($scanner_obj,$scanner_name) = @$as;
    if ($scanner_obj && $scanner_obj->UNIVERSAL::can('init_pre_fork')) {
      $scanner_obj->init_pre_fork;
      do_log(1, "SpamControl: init_pre_fork on %s done", $scanner_name);
    }
  }
}

# called during child process initialization
#
sub init_child {
  my $self = $_[0];
  my $failure_msg;
  for my $as (@{$self->{scanners_list}}) {
    my($scanner_obj,$scanner_name) = @$as;
    if ($scanner_obj && $scanner_obj->UNIVERSAL::can('init_child')) {
      eval {
        $scanner_obj->init_child;
        do_log(5, "SpamControl: init_child on %s done", $scanner_name);
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
        do_log(-1, "init_child on spam scanner %s failed: %s",
                   $scanner_name, $eval_stat);
        $failure_msg = "init_child $scanner_name failed: $eval_stat"
          if !defined $failure_msg;
      };
    }
  }
  if (defined $failure_msg) { die $failure_msg }
}

sub lock {
  my($self,$scanner_obj,$lock_type_name) = @_;
  my $lock_file = $scanner_obj->{options}->{'lock_file'};
  if (defined $lock_file && $lock_file ne '') {
    my $lock_type = $scanner_obj->{options}->{$lock_type_name};
    $lock_type = $scanner_obj->{options}->{'lock_type'} if !defined $lock_type;
    $lock_type = 'exclusive'  if !defined $lock_type;
    if ($lock_type ne '' && lc($lock_type) ne 'none') {
      my $lock_fh = IO::File->new;
      $lock_fh->open($lock_file, O_CREAT|O_RDWR, 0640)
        or die "Can't open a lock file $lock_file: $!";
      $scanner_obj->{lock_fh} = $lock_fh;
      my $lock_type_displ;
      if (defined $lock_type && lc($lock_type) eq 'shared') {
        $lock_type = LOCK_SH; $lock_type_displ = 'a shared';
      } else {
        $lock_type = LOCK_EX; $lock_type_displ = 'an exclusive';
      }
      do_log(5,"acquring %s lock on %s for %s",
                $lock_type_displ, $lock_file, $scanner_obj->{scanner_name});
      flock($lock_fh, $lock_type)
        or die "Can't acquire $lock_type_displ lock on $lock_file: $!";
    }
  }
}

sub unlock {
  my($self,$scanner_obj) = @_;
  my $lock_fh = $scanner_obj->{lock_fh};
  if ($lock_fh) {
    my $scanner_name = $scanner_obj->{scanner_name};
    do_log(5, "releasing a lock for %s", $scanner_name);
    # close would unlock automatically, but let's check for locking mistakes
    flock($lock_fh, LOCK_UN)
      or die "Can't release a lock for $scanner_name: $!";
    $lock_fh->close or die "Can't close a lock file for $scanner_name: $!";
    undef $scanner_obj->{lock_fh};
  }
}

# actual spam checking for every message
#
sub spam_scan {
  my($self,$msginfo) = @_;
  my $failure_msg;
  for my $as (@{$self->{scanners_list}}) {
    my($scanner_obj,$scanner_name) = @$as;
    next if !$scanner_obj && !$scanner_obj->UNIVERSAL::can('check');
    do_log(5, "SpamControl: calling spam scanner %s", $scanner_name);
    $self->lock($scanner_obj, 'classifier_lock_type');
    eval {
      $scanner_obj->check($msginfo); 1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
      do_log(-1, "checking with spam scanner %s failed: %s",
                 $scanner_name, $eval_stat);
      $failure_msg =
        "$scanner_name failed: $eval_stat"  if !defined $failure_msg;
    };
    $self->unlock($scanner_obj);
  }
  if (defined $failure_msg) { die $failure_msg }
  1;
}

sub auto_learn {
  my($self,$msginfo) = @_;
  my $failure_msg;
  for my $as (@{$self->{scanners_list}}) {
    my($scanner_obj,$scanner_name) = @$as;
    next if !$scanner_obj || !$scanner_obj->UNIVERSAL::can('auto_learn');
    next if !$scanner_obj->UNIVERSAL::can('can_auto_learn') ||
            !$scanner_obj->can_auto_learn;

    # learn-on-error logic: what was the final outcome
    my($min_spam_level, $max_spam_level) =
      minmax(map($_->spam_level, @{$msginfo->per_recip_data}));
    next if !defined $min_spam_level || !defined $max_spam_level;

    # learn-on-error logic: what this scanner thinks
    my $my_verdict = $msginfo->supplementary_info('VERDICT-'.$scanner_name);
    $my_verdict = !defined $my_verdict ? '' : lc $my_verdict;
    my $my_score = $msginfo->supplementary_info('SCORE-'.$scanner_name);
    $my_score = 0  if !defined $my_score;

    # learn-on-error logic: opinions differ?
    my $learn_as;  # leaving out a contribution by this spam scanner
    if ($my_verdict ne 'ham' && $max_spam_level-$my_score < 0.5) {
      $learn_as = 'ham';
    } elsif ($my_verdict ne 'spam' && $min_spam_level-$my_score >= 5) {
      $learn_as = 'spam';
    }
    next if !defined $learn_as;

    ll(2) && do_log(2,
      "SpamControl: scanner %s, auto-learn as %s / %.3f (was: %s / %s)",
      $scanner_name, $learn_as,
      $my_verdict ne 'ham' ? $max_spam_level : $min_spam_level,
      $my_verdict, !$my_score ? '0' : sprintf("%.3f",$my_score));

    $self->lock($scanner_obj, 'learner_lock_type');
    eval {
      $scanner_obj->auto_learn($msginfo,$learn_as); 1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
      do_log(-1, "auto-learning with spam scanner %s failed: %s",
                 $scanner_name, $eval_stat);
      $failure_msg =
        "$scanner_name failed: $eval_stat"  if !defined $failure_msg;
    };
    $self->unlock($scanner_obj);
  }
  if (defined $failure_msg) { die $failure_msg }
  1;
}

# called during child process shutdown
#
sub rundown_child() {
  my $self = $_[0];
  for my $as (@{$self->{scanners_list}}) {
    my($scanner_obj,$scanner_name) = @$as;
    if ($scanner_obj && $scanner_obj->UNIVERSAL::can('rundown_child')) {
      eval {
        $scanner_obj->rundown_child;
        do_log(5, "SpamControl: rundown_child on %s done", $scanner_name);
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
        do_log(-1, "rundown_child on spam scanner %s failed: %s",
                   $scanner_name, $eval_stat);
      };
    }
  }
}

# check envelope sender and author for white or blacklisting by each recipient;
# Saves the result in recip_blacklisted_sender and recip_whitelisted_sender
# properties of each recipient object, and updates spam score for each
# recipient according to soft-w/b-listing.
#
sub white_black_list($$$$) {
  my($msginfo,$sql_wblist,$user_id_sql,$ldap_lookups) = @_;
  my $fm = $msginfo->rfc2822_from;
  my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
  my(@senders) = ($msginfo->sender, @rfc2822_from);
  @senders = unique_list(\@senders);  # remove possible duplicates
  ll(4) && do_log(4,"wbl: checking sender %s",
                    scalar(qquote_rfc2821_local(@senders)));
  my($any_w,$any_b,$all,$wr,$br);
  $any_w = 0; $any_b = 0; $all = 1;
  for my $r (@{$msginfo->per_recip_data}) {  # for each recipient
    next  if $r->recip_done;  # already dealt with
    my($wb,$boost); my $found = 0; my $recip = $r->recip_addr;
    my($user_id_ref,$mk_ref);
    $user_id_ref = $r->user_id;
    $user_id_ref = []  if !defined $user_id_ref;
    do_log(5,"wbl: (SQL) recip <%s>, %s matches",
             $recip, scalar(@$user_id_ref))  if $sql_wblist && ll(5);
    for my $sender (@senders) {
      for my $ind (0..$#{$user_id_ref}) { # for ALL SQL sets matching the recip
        my $user_id = $user_id_ref->[$ind];  my $mkey;
        ($wb,$mkey) = lookup(0,$sender,
                Amavis::Lookup::SQLfield->new($sql_wblist,'wb','S',$user_id) );
        do_log(4,'wbl: (SQL) recip <%s>, rid=%s, got: "%s"',
                 $recip,$user_id,$wb);
        if (!defined($wb)) {
          # NULL field or no match: remains undefined
        } elsif ($wb =~ /^ *([+-]?\d+(?:\.\d*)?) *\z/) {  # numeric
          my $val = 0+$1;  # penalty points to be added to the score
          $boost += $val;
          ll(2) && do_log(2,
                  'wbl: (SQL) soft-%slisted (%s) sender <%s> => <%s> (rid=%s)',
                  ($val<0?'white':'black'), $val, $sender, $recip, $user_id);
          $wb = undef;  # not hard- white or blacklisting, does not exit loop
        } elsif ($wb =~ /^[ \000]*\z/) {        # neutral, stops the search
          $found=1; $wb = 0;
          do_log(5, 'wbl: (SQL) recip <%s> is neutral to sender <%s>',
                    $recip,$sender);
        } elsif ($wb =~ /^([BbNnFf])[ ]*\z/) {  # blacklisted (B,N(o), F(alse))
          $found=1; $wb = -1; $any_b++; $br = $recip;
          $r->recip_blacklisted_sender(1);
          do_log(5, 'wbl: (SQL) recip <%s> blacklisted sender <%s>',
                    $recip,$sender);
        } else {            # whitelisted (W, Y(es), T(true), or anything else)
          if ($wb =~ /^([WwYyTt])[ ]*\z/) {
            do_log(5, 'wbl: (SQL) recip <%s> whitelisted sender <%s>',
                      $recip,$sender);
          } else {
            do_log(-1,'wbl: (SQL) recip <%s> whitelisted sender <%s>, '.
                      'unexpected wb field value: "%s"', $recip,$sender,$wb);
          }
          $found=1; $wb = +1; $any_w++; $wr = $recip;
          $r->recip_whitelisted_sender(1);
        }
        last  if $found;
      }
      if (!$found && $ldap_lookups && c('enable_ldap')) {  # LDAP queries
        my $wblist;
        my($keys_ref,$rhs_ref) = make_query_keys($sender,0,0);
        my(@keys) = @$keys_ref;
        unshift(@keys, '<>')  if $sender eq ''; # a hack for a null return path
        untaint_inplace($_) for @keys;  # untaint keys
        $_ = Net::LDAP::Util::escape_filter_value($_) for @keys;
        do_log(5,'wbl: (LDAP) query keys: %s', join(', ',map("\"$_\"",@keys)));

        $wblist = lookup(0,$recip,Amavis::Lookup::LDAPattr->new(
                                $ldap_lookups, 'amavisBlacklistSender', 'L-'));
        for my $key (@keys) {
          if (grep(lc($_) eq lc($key), @$wblist)) {
            $found=1; $wb = -1; $br = $recip; $any_b++;
            $r->recip_blacklisted_sender(1);
            do_log(5,'wbl: (LDAP) recip <%s> blacklisted sender <%s>',
                     $recip,$sender);
          }
        }
        $wblist = lookup(0,$recip,Amavis::Lookup::LDAPattr->new(
                                $ldap_lookups, 'amavisWhitelistSender', 'L-'));
        for my $key (@keys) {
          if (grep(lc($_) eq lc($key), @$wblist)) {
            $found=1; $wb = +1; $wr = $recip; $any_w++;
            $r->recip_whitelisted_sender(1);
            do_log(5,'wbl: (LDAP) recip <%s> whitelisted sender <%s>',
                     $recip,$sender);
          }
        }
      }
      if (!$found) {  # fall back to static lookups if no match
        # sender can be both white- and blacklisted at the same time
        my($val, $r_ref, $mk_ref, @t);

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

1;

__DATA__
#
package Amavis::SpamControl::ExtProg;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars :sa c cr ca);
  import Amavis::Util qw(ll do_log sanitize_str min max minmax
                         prolong_timer get_deadline);
  import Amavis::ProcControl qw(exit_status_str proc_status_ok
                         kill_proc run_command run_command_consumer);
  import Amavis::rfc2821_2822_Tools qw(qquote_rfc2821_local);
  import Amavis::Timing qw(section_time);
}
use subs @EXPORT_OK;

use Errno qw(EIO EINTR EAGAIN ECONNRESET EBADF);
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Time::HiRes ();

sub new {
  my($class, $scanner_name,$module,@args) = @_;
  my($cmd,$cmdargs,%options) = @args;
  return if !defined $cmd || $cmd eq '';
  bless {
    scanner_name => $scanner_name, command => $cmd, args => $cmdargs,
    options => \%options,
  }, $class;
}

sub check {
  my($self,$msginfo) = @_;
  $self->check_or_learn($msginfo,undef);
};

sub auto_learn {
  my($self,$msginfo,$learn_as) = @_;
  $self->check_or_learn($msginfo,$learn_as);
}

sub can_auto_learn {
  my $self = $_[0];
  my $opt = $self->{options};
  $opt && defined $opt->{'learn_ham'} && defined $opt->{'learn_spam'};
}

# pass a mail message to an external (spam checking) program,
# extract interesting header fields from the result
#
sub check_or_learn {
  my($self,$msginfo,$learn_as) = @_;
  my $scanner_name = $self->{scanner_name};
  my $cmd = $self->{command};
  my $cmdargs; my $auto_learning;
  if (!defined $learn_as) {
    $cmdargs = $self->{args};
  } elsif ($learn_as eq 'ham') {
    $cmdargs = $self->{options}->{'learn_ham'}; $auto_learning = 1;
  } elsif ($learn_as eq 'spam') {
    $cmdargs = $self->{options}->{'learn_spam'}; $auto_learning = 1;
  }
  my $size_limit;
  my $mbsl = $self->{options}->{'mail_body_size_limit'};
  $mbsl = c('sa_mail_body_size_limit')  if !defined $mbsl;
  if (defined $mbsl) {
    $size_limit = min(64*1024, $msginfo->orig_header_size) + 1 +
                  min($mbsl,   $msginfo->orig_body_size);
    # don't bother if slightly oversized, it's faster without size checks
    undef $size_limit  if $msginfo->msg_size < $size_limit + 5*1024;
  }
  my $prefix = '';
  # fake a local delivery agent by inserting a Return-Path
  $prefix .= sprintf("Return-Path: %s\n", $msginfo->sender_smtp);
  $prefix .= sprintf("X-Envelope-To: %s\n",
                     join(",\n ",qquote_rfc2821_local(@{$msginfo->recips})));
  my $os_fp = $msginfo->client_os_fingerprint;
  $prefix .= sprintf("X-Amavis-OS-Fingerprint: %s\n",
                     sanitize_str($os_fp))  if defined($os_fp) && $os_fp ne '';
  my(@av_tests);
  my $per_recip_data = $msginfo->per_recip_data;
  $per_recip_data = []  if !$per_recip_data;
  for my $r (@$per_recip_data) {
    my $spam_tests = $r->spam_tests;
    push(@av_tests, grep(/^AV\..+=/,
                 split(/,/, join(',',map($$_,@$spam_tests)))))  if $spam_tests;
  }
  $prefix .= sprintf("X-Amavis-AV-Status: %s\n",
                     sanitize_str(join(',',@av_tests)))  if @av_tests;
  $prefix .= sprintf("X-Amavis-PolicyBank: %s\n", c('policy_bank_path'));
  $prefix .= sprintf("X-Amavis-MessageSize: %d%s\n", $msginfo->msg_size,
                     !defined $size_limit ? '' : ", TRUNCATED to $size_limit");
  my $resp_stdout_fh  = IO::File->new;  # parent reading side of the pipe
  my $child_stdout_fh = IO::File->new;  # child stdout writing side of a pipe
  my $resp_stderr_fh  = IO::File->new;  # parent reading side of the pipe
  my $child_stderr_fh = IO::File->new;  # child stderr writing side of a pipe
  pipe($resp_stdout_fh, $child_stdout_fh)
    or die "$scanner_name: Can't create pipe1: $!";
  pipe($resp_stderr_fh, $child_stderr_fh)
    or die "$scanner_name: Can't create pipe2: $!";
  binmode($resp_stdout_fh)  or die "Can't set pipe1 to binmode: $!";
  binmode($resp_stderr_fh)  or die "Can't set pipe2 to binmode: $!";

  my($proc_fh,$pid) = run_command_consumer('&='.fileno($child_stdout_fh),
                                           '&='.fileno($child_stderr_fh),
                                           $cmd, @$cmdargs);
  $child_stdout_fh->close
    or die "Parent failed to close child side of the pipe1: $!";
  $child_stderr_fh->close
    or die "Parent failed to close child side of the pipe2: $!";
  undef $child_stdout_fh; undef $child_stderr_fh;

  my($remaining_time, $deadline) = get_deadline($scanner_name.'_scan', 0.8, 5);
  alarm(0);  # stop the timer
  my $proc_fd = fileno($proc_fh);
  my $resp_stdout_fd = fileno($resp_stdout_fh);
  my $resp_stderr_fd = fileno($resp_stderr_fh);
  my $response = ''; my $response_stderr = ''; my $response_chopped = 0;
  my $child_stat; my $bytes_sent = 0; my $err_on_child = 0;
  my $msg = $msginfo->mail_text;
  my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
  $msg = $msg_str_ref  if ref $msg_str_ref;
  eval {
    if (!defined $msg) {
      # empty mail
    } elsif (ref $msg ne 'SCALAR' && $msg->isa('MIME::Entity')) {
    # $msg->print_body($proc_fh);  # flushing the pipe?
      die "$scanner_name: reading from MIME::Entity is not implemented";
    } else {  # handles a message in-memory or on a file
      my $file_position = $msginfo->skip_bytes;
      if (ref $msg ne 'SCALAR') {
        $msg->seek($file_position, 0) or die "Can't rewind mail file: $!";
      }
      my $data_source = $prefix;
      my $eof_on_response = 0;
      my $eof_on_msg = 0; my $force_eof_on_msg = 0;
      my($rout,$wout,$eout,$rin,$win,$ein); $rin=$win=$ein='';
      vec($rin,$resp_stdout_fd,1) = 1;
      vec($rin,$resp_stderr_fd,1) = 1;
      for (;;) {
        vec($win,$proc_fd,1) = 0;
        vec($win,$proc_fd,1) = 1  if defined $proc_fh &&
                                     (!$eof_on_msg || $data_source ne '');
        $ein = $rin | $win;
        my $timeout = max(3, $deadline - Time::HiRes::time);
        my($nfound,$timeleft) =
          select($rout=$rin, $wout=$win, $eout=$ein, $timeout);
        defined $nfound && $nfound >= 0
          or die "$scanner_name: select failed: $!";
        if (vec($rout,$resp_stderr_fd,1)) {
          my $inbuf = ''; $! = 0;
          my $nread = sysread($resp_stderr_fh, $inbuf, 16384);
          if ($nread) {  # successful read
            ll(5) && do_log(5, 'rx stderr: %d %s [...]',
                               $nread, substr($inbuf,0,1000));
            $response_stderr .= $inbuf  if length($response_stderr) < 10000;
          } elsif (defined $nread) {  # defined but zero: EOF
            # sysread returns 0 at eof
          } elsif ($! == EAGAIN || $! == EINTR) {
            Time::HiRes::sleep(0.1);  # slow down, just in case
          } else {  # read error
            do_log(0,"%s: error reading from pipe2: %s", $scanner_name,$!);
          }
        }
        if (vec($rout,$resp_stdout_fd,1)) {
          my $inbuf = ''; $! = 0;
          my $nread = sysread($resp_stdout_fh, $inbuf, 16384);
          if ($nread) {  # successful read
            ll(5) && do_log(5, 'rx: %d %s [...]',
                               $nread, substr($inbuf,0,30));
            my $response_l = length($response);
            if ($response_chopped || $response_l >= 65536) {
              # ignore the rest of input
            } else {
              $response .= $inbuf;
              my $j = $response_l <= 1 ? 0 : $response_l - 1;
              # we only need a mail header from the returned text
              $response_chopped = 1  if index($response,"\n\n",$j) >= 0;
            }
          } elsif (defined $nread) {  # defined but zero: EOF
            $eof_on_response = 1;  # sysread returns 0 at eof
          } elsif ($! == EAGAIN || $! == EINTR) {
            Time::HiRes::sleep(0.1);  # slow down, just in case
          } else {  # read error
            $eof_on_response = 1;
            die "$scanner_name: error reading from pipe1: $!";
          }
        }
        if (vec($wout,$proc_fd,1)) {  # subprocess is ready to receive more
          if ($data_source eq '' && !$eof_on_msg) {  # get more data
            my $nread = 0;
            if ($force_eof_on_msg) {
              # pretend to already be at eof
            } elsif (ref $msg ne 'SCALAR') {  # message is on a file
              $nread = $msg->read($data_source,32768);
            } elsif ($file_position < length($$msg)) {  # message in memory
              # do it in chunks, saves memory, cache friendly
              $data_source = substr($$msg,$file_position,32768);
              $nread = length($data_source);
            }
            if (!$nread) {
              $eof_on_msg = 1;
              defined $nread or die "$scanner_name: error reading message: $!";
              if (defined $proc_fh) { $proc_fh->close or $err_on_child=$! };
              undef $proc_fh;
              do_log(5,"tx: eof");
            }
            $file_position += $nread;
            if (defined $size_limit) {
              my $remaining_room = $size_limit - $bytes_sent;
              $remaining_room = 0  if $remaining_room < 0;
              if ($nread > $remaining_room) {
                substr($data_source, $remaining_room) = '';
                do_log(5,"tx: (size limit) %d -> %d", $nread,$remaining_room);
                $force_eof_on_msg = 1;
              }
            }
          }
          if ($data_source ne '' && defined $proc_fh) {
            ll(5) && do_log(5, "tx: %d %s [...]",
                            length($data_source), substr($data_source,0,30));
            # syswrite does a write(2), no need to call $proc_fh->flush
            my $nwrite = syswrite($proc_fh, $data_source);
            if (!defined($nwrite)) {
              if ($! == EAGAIN || $! == EINTR) {
                Time::HiRes::sleep(0.1);   # slow down, just in case
              } else {
                $data_source = ''; $eof_on_msg = 1;  # simulate an eof
                do_log(-1,"%s: error writing to pipe: %s", $scanner_name,$!);
                $proc_fh->close or $err_on_child=$!; undef $proc_fh;
                do_log(5,"tx: eof (wr err)");
              }
            } elsif ($nwrite > 0) {  # successful write
              $bytes_sent += $nwrite;
              if ($nwrite < length($data_source)) {
                substr($data_source,0,$nwrite) = '';
              } else {
                $data_source = '';
              }
            }
          }
        }
        last  if $eof_on_response;
        if (Time::HiRes::time >= $deadline) {
          die "$scanner_name: exceeded allowed time\n";
        }
      }
    }
    if (defined $proc_fh) { $proc_fh->close or $err_on_child=$! }
    $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;
    1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
    do_log(-1,"%s failed: %s", $scanner_name,$eval_stat);
    kill_proc($pid,$scanner_name,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
  };
  prolong_timer($scanner_name);  # restart timer

  substr($response_stderr,2000) = '[...]'  if length($response_stderr) > 2000;
  if (proc_status_ok($child_stat,$err_on_child)) {
    do_log(2, "%s stderr: %s",
              $scanner_name,$response_stderr)  if $response_stderr ne '';
  } else {
    do_log(-1,"%s stderr: %s",
              $scanner_name,$response_stderr)  if $response_stderr ne '';
    die "$scanner_name: error running program $cmd: " .
           exit_status_str($child_stat,$err_on_child) . "\n";
  }
  # keep just a header section in $response
  if ($response eq '') {
    # empty mail
  } elsif (substr($response, 0,1) eq "\n") {
    $response = '';  # empty header section
  } else {
    my $ind = index($response,"\n\n");  # find header/body separator
    substr($response, $ind+1) = ''  if $ind >= 0;
  }
  my $crm114_score;
  if ($cmd =~ /\bcrm/ && $response =~ /^\s*([+-]?\d*(?:\.\d*)?)\s*$/) {
    $crm114_score = $1;
    $response = '';  # skip the header parsing loop below
  }
  my(@response_lines) = split(/^/m, $response, -1);
  push(@response_lines, "\n", "\n");  # insure a trailing NL and a separator
  undef $response;

  my(%header_field, @header_field_name, $curr_head);
  # scan mail header section retrieved from an external program on its stdout
  for my $ln (@response_lines) {  # guaranteed to contain header/body separator
    if ($ln =~ /^[ \t]/) {  # folded
      $curr_head .= $ln;
    } else {  # a new header field, process previous if any
      if (defined $curr_head) {
        local($1,$2);
        if ($curr_head =~ /^ ( (?: X-DSPAM | X-CRM114 | X-Bogosity) [^:]*? )
                           [ \t]* : [ \t]* (.*) $/xs) {
          my($hn,$hb) = ($1,$2); my $hnlc = lc $hn;
          push(@header_field_name, $hn)  if !exists($header_field{$hnlc});
          $header_field{$hnlc} = $hb;  # keep last
        }
      }
      $curr_head = $ln;
      last  if $ln eq "\n";
    }
  }

  my($spam_score, $spam_tests);
  my $score_factor = $self->{options}->{'score_factor'};

  my $dspam_result = $header_field{lc('X-DSPAM-Result')};
  if (defined $dspam_result) {
    if ($dspam_result =~ /\b(signature|result|probability|confidence)=.*;/) {
      # combined result, split
      my(%attribute);
      for my $attr (split(/;\s*/, $dspam_result)) {
        local($1,$2);
        my($n,$v) = ($attr =~ /^([^=]*)=(.*)\z/s) ? ($1,$2) : ('user',$attr);
        $v =~ s/^"//; $v =~ s/"\z//; $attribute{$n} = $v;
      }
      # simulate separate header fields
      @header_field_name = qw(X-DSPAM-Result X-DSPAM-Class X-DSPAM-Confidence
                              X-DSPAM-Probability X-DSPAM-Signature);
      for my $hn (@header_field_name) {
        my $hnlc = lc $hn; my $name = $hnlc; $name =~ s/^X-DSPAM-//i;
        $header_field{$hnlc} = $attribute{$name};
      }
    }
    $dspam_result =       $header_field{lc('X-DSPAM-Result')};
    my $dspam_signature = $header_field{lc('X-DSPAM-Signature')};
    $dspam_result    = ''  if !defined $dspam_result;
    $dspam_signature = ''  if !defined $dspam_signature;
    chomp($dspam_result); chomp($dspam_signature);
    $dspam_signature = ''  if $dspam_signature eq 'N/A';
    if (!$auto_learning) {
      $msginfo->supplementary_info('DSPAMRESULT',    $dspam_result);
      $msginfo->supplementary_info('DSPAMSIGNATURE', $dspam_signature);
      $msginfo->supplementary_info('VERDICT-'.$scanner_name, $dspam_result);
      $spam_score = $dspam_result eq 'Spam' ? 10 : -1;  # fabricated
      $score_factor = 1  if !defined $score_factor;
      $spam_score *= $score_factor;
      $spam_tests = sprintf("%s.%s=%.3f",
                            $scanner_name, $dspam_result, $spam_score);
      do_log(2,"%s result: %s, score=%.3f, sig=%s",
               $scanner_name, $dspam_result, $spam_score, $dspam_signature);
    }
  }

  my $crm114_status = $header_field{lc('X-CRM114-Status')};
  if (defined $crm114_score || defined $crm114_status) {
    local($1,$2);
    if (!defined $crm114_status) {  # presumably using --stats_only
      # fabricate a Status from score
      $crm114_status = !defined $crm114_score ? 'unknown'
                     : $crm114_score <= -10 ? uc('spam')
                     : $crm114_score >= +10 ? 'GOOD' : 'UNSURE';
      $header_field{lc('X-CRM114-Status')} =
        sprintf("%s ( %s )", $crm114_status, $crm114_score);
      @header_field_name = qw(X-CRM114-Status);
    } elsif ($crm114_status =~ /^([A-Z]+)\s+\(\s+([-\d\.]+)\s+\)/) {
      $crm114_status = $1; $crm114_score = $2;
    }
    my $crm114_cacheid = $header_field{lc('X-CRM114-CacheID')};
    if (defined $crm114_cacheid && $crm114_cacheid =~ /^sfid-\s*$/i) {
      delete $header_field{lc('X-CRM114-CacheID')}; $crm114_cacheid = undef;
    }
    s/[ \t\r\n]+\z//  for ($crm114_status, $crm114_score, $crm114_cacheid);
    $score_factor = -0.10  if !defined $score_factor;
    $spam_score = $score_factor * $crm114_score;
    $spam_tests = sprintf("%s.%s(%s)=%.3f",
                    $scanner_name, $crm114_status, $crm114_score, $spam_score);
    if (!$auto_learning) {
      $msginfo->supplementary_info('VERDICT-'.$scanner_name,
                         uc $crm114_status eq 'GOOD' ? 'Ham' : $crm114_status);
      $msginfo->supplementary_info('CRM114STATUS',
                           sprintf("%s ( %s )", $crm114_status,$crm114_score));
      $msginfo->supplementary_info('CRM114SCORE',   $crm114_score);
      $msginfo->supplementary_info('CRM114CACHEID', $crm114_cacheid);
      do_log(2,"%s result: score=%s (%s), status=%s, cacheid=%s",
               $scanner_name, $spam_score,
               $crm114_score, $crm114_status, $crm114_cacheid);
    }
  }

  my $bogo_line = $header_field{lc('X-Bogosity')};
  my($bogo_status, $bogo_score, $bogo_tests);
  if (defined $bogo_line) {
    ($bogo_status, $bogo_tests, $bogo_score) = split(/,\s*/,$bogo_line);
    local($1);
    $bogo_score =~ s/^spamicity=([0-9.+-]*).*\z/$1/s;
    $spam_score = $bogo_status eq 'Spam' ? 5 : $bogo_status eq 'Ham' ? -5 : 0;
    $score_factor = 1  if !defined $score_factor;
    $spam_score = $score_factor * $spam_score;
    # trim trailing fraction zeroes
    $spam_score = 0 + sprintf("%.3f",$spam_score);
    $spam_tests = sprintf("%s=%s", $scanner_name, $spam_score);
#   $spam_tests = sprintf("%s(%s/%s)=%s",
#                   $scanner_name, $bogo_status, $bogo_score, $spam_score);
    if (!$auto_learning) {
      $msginfo->supplementary_info('VERDICT-'.$scanner_name, $bogo_status);
      $msginfo->supplementary_info('BOGOSTATUS', sprintf("%s ( %s )",
                                                   $bogo_status, $bogo_score));
      $msginfo->supplementary_info('BOGOSCORE', $bogo_score);
      do_log(2,"%s result: score=%s (%s), status=%s",
               $scanner_name, $spam_score, $bogo_score, $bogo_status);
    }
  }

  if (!$auto_learning) {
    my $hdr_edits = $msginfo->header_edits;
    my $use_our_hdrs = cr('prefer_our_added_header_fields');
    my $allowed_hdrs = cr('allowed_added_header_fields');
    my $all_local = !grep(!$_->recip_is_local, @$per_recip_data);
    for my $hn (@header_field_name) {
      my $hnlc = lc $hn; my $hb = $header_field{$hnlc};
      if (defined $hb) {
        $hb =~ s/[ \t\r\n]+\z//;  # trim trailing whitespace and eol
        do_log(5,"%s: suppl attr: %s = '%s'", $scanner_name,$hn,$hb);
        $msginfo->supplementary_info($hn,$hb);
        # add header fields to passed mail for all recipients
        if ($all_local && $allowed_hdrs && $allowed_hdrs->{$hnlc} &&
            !($use_our_hdrs && $use_our_hdrs->{$hnlc})) {
          $hdr_edits->add_header($hn,$hb,2);
        }
      }
    }
    if (defined $spam_score) {
      $msginfo->supplementary_info('SCORE-'.$scanner_name, $spam_score);
      for my $r (@$per_recip_data) {
        $r->spam_level( ($r->spam_level || 0) + $spam_score );
        if (!$r->spam_tests) {
          $r->spam_tests([ \$spam_tests ]);
        } else {
          push(@{$r->spam_tests}, \$spam_tests);
        }
      }
    }
  }
  section_time($scanner_name);
}

1;

__DATA__
#
package Amavis::SpamControl::SpamdClient;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars :sa c cr ca);
  import Amavis::Util qw(ll do_log sanitize_str min max minmax get_deadline);
  import Amavis::rfc2821_2822_Tools qw(qquote_rfc2821_local);
  import Amavis::Timing qw(section_time);
}

use Errno qw(ENOENT EACCES);

sub new {
  my($class, $scanner_name,$module,@args) = @_;
  my(%options) = @args;
  bless { scanner_name => $scanner_name, options => \%options }, $class;
}

# needs spamd running, could be started like this:
#   spamd -H /var/amavis/home -r /var/amavis/home/spamd.pid -s stderr \
#     -u vscan -g vscan -x -P --allow-tell --min-children=2 --max-children=2

sub check {
  my($self,$msginfo) = @_;
  my($which_section, $spam_level, $sa_tests, $size_limit, %attr);
  my $scanner_name = $self->{scanner_name};
  my $mbsl = $self->{options}->{'mail_body_size_limit'};
  $mbsl = c('sa_mail_body_size_limit')  if !defined $mbsl;
  if (defined $mbsl) {
    $size_limit = min(64*1024, $msginfo->orig_header_size) + 1 +
                  min($mbsl,   $msginfo->orig_body_size);
    # don't bother if slightly oversized, it's faster without size checks
    undef $size_limit  if $msginfo->msg_size < $size_limit + 5*1024;
  }
  my $hdr_edits = $msginfo->header_edits;
  # fake a local delivery agent by inserting Return-Path
  $which_section = 'prepare pseudo header section';
  my $hdr_prefix = '';
  $hdr_prefix .= sprintf("Return-Path: %s\n", $msginfo->sender_smtp);
  $hdr_prefix .= sprintf("X-Envelope-To: %s\n",
       join(",\n ",qquote_rfc2821_local(@{$msginfo->recips})));
  my $os_fp = $msginfo->client_os_fingerprint;
  $hdr_prefix .= sprintf("X-Amavis-OS-Fingerprint: %s\n",
       sanitize_str($os_fp))  if defined($os_fp) && $os_fp ne '';
  my(@av_tests);
  my $per_recip_data = $msginfo->per_recip_data;
  $per_recip_data = []  if !$per_recip_data;
  for my $r (@$per_recip_data) {
    my $spam_tests = $r->spam_tests;
    push(@av_tests, grep(/^AV\..+=/,
                 split(/,/, join(',',map($$_,@$spam_tests)))))  if $spam_tests;
  }
  $hdr_prefix .= sprintf("X-Amavis-AV-Status: %s\n",
                         sanitize_str(join(',',@av_tests)))  if @av_tests;
  $hdr_prefix .= sprintf("X-Amavis-PolicyBank: %s\n", c('policy_bank_path'));
  $hdr_prefix .= sprintf("X-Amavis-MessageSize: %d%s\n", $msginfo->msg_size,
                   !defined $size_limit ? '' : ", TRUNCATED to $size_limit");
  my($remaining_time, $deadline) = get_deadline('spamd check', 1, 5);
  my $msg = $msginfo->mail_text;
  my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
  $msg = $msg_str_ref  if ref $msg_str_ref;
  eval {
    $which_section = 'spamd_connect';  do_log(3,"connecting to spamd");
    my $spamd_handle = Amavis::IO::RW->new(
      [ '127.0.0.1:783', '[::1]:783' ], Eol => "\015\012", Timeout => 10);
    defined $spamd_handle or die "Can't connect to spamd, $@ ($!)";
    $spamd_handle->timeout(max(3, $deadline - Time::HiRes::time));
    section_time($which_section);

    $which_section = 'spamd_tx';  do_log(4,"sending to spamd");
    $hdr_prefix =~ s{\n}{\015\012}gs;
    my $file_position = $msginfo->skip_bytes;
    my $msgsize = length($hdr_prefix);  # prepended lines...
    $msgsize += $msginfo->msg_size;     # size as defined by RFC 1870
    $msgsize -= $file_position;   # TODO: adjust for CRLF (alright for 0)
    ll(5) && do_log(5, "spamc: message size: %d + %d - %d = %s",
               length($hdr_prefix), $msginfo->msg_size, $file_position,
               defined $size_limit && $msgsize > $size_limit
                 ? "LIM:$size_limit" : $msgsize);
    if (defined $size_limit && $msgsize > $size_limit) {
      # consider $size_limit in the RFC 1870 sense for simplicity
      $msgsize = $size_limit;
    }
    $spamd_handle->print("SYMBOLS SPAMC/1.3\015\012");  # HEADERS
    $spamd_handle->print("Content-length: " . $msgsize . "\015\012");
    $spamd_handle->print("\015\012");
    $spamd_handle->print($hdr_prefix);
    my $bytes_written = length($hdr_prefix);
    if (!defined $msg) {
      # empty mail
    } elsif (ref $msg eq 'SCALAR') {
      # do it in chunks, saves memory, cache friendly
      my $done;
      while ($file_position < length($$msg)) {
        my $buff = substr($$msg,$file_position,16384);
        $file_position += length($buff);
        $buff =~ s{\n}{\015\012}gs;
        if (defined $size_limit &&
            $bytes_written + length($buff) >= $size_limit) {
          substr($buff, $size_limit - $bytes_written) = '';  # truncate
          # spamd reads line-by-line and hangs if not terminated by a NL
          substr($buff,-1,1) = "\012";
          do_log(5,"spamc: reached size limit %d bytes, ".
                   "%d = %d (sent) + %d (still to go)",
                   $size_limit, $bytes_written+length($buff),
                   $bytes_written, length($buff));
          $done = 1;
        }
        $spamd_handle->print($buff);
        $bytes_written += length($buff);
        last if $done;
      }
    } elsif ($msg->isa('MIME::Entity')) {  # TODO - content length won't match!
      do_log(3,"spamc: message is MIME::Entity, size won't match");
      $msg->print_body($spamd_handle);
    } else {
      $msg->seek($file_position,0) or die "Can't rewind mail file: $!";
      my($nbytes,$buff,$done);
      while ( $nbytes=$msg->sysread($buff,16384) ) {
        $file_position += $nbytes;
        $buff =~ s{\n}{\015\012}gs;
        if (defined $size_limit &&
            $bytes_written + length($buff) >= $size_limit) {
          substr($buff, $size_limit - $bytes_written) = '';  # truncate
          # spamd reads line-by-line and hangs if not terminated by a NL
          substr($buff,-1,1) = "\012";
          do_log(5,"spamc: reached size limit %d bytes, ".
                   "%d = %d (sent) + %d (still to go)",
                   $size_limit, $bytes_written+length($buff),
                   $bytes_written, length($buff));
          $done = 1;
        }
        $spamd_handle->print($buff);
        $bytes_written += length($buff);
        last if $done;
      }
      defined $nbytes or die "Error reading: $!";
    }
    $spamd_handle->flush;
    $hdr_prefix = undef;
    section_time($which_section);

    $which_section = 'spamd_rx';  do_log(4,"receiving from spamd");
    my($version, $resp_code, $resp_msg);
    local($1,$2,$3); my($ln,$error,$first); $first = 1;
    while (defined($ln = $spamd_handle->get_response_line)) {
      do_log(4,"from spamd - resp.hdr: %s", $ln);
      if ($ln eq "\015\012") {
        last;
      } elsif ($first) {
        $first = 0; $ln =~ s/\015\012\z//;
        ($version,$resp_code,$resp_msg) = split(/[ \t]+/,$ln,3);
      } elsif ($ln =~ /^([^:]*?)[ \t]*:[ \t]*(.*)\015\012\z/i) {
        $attr{lc($1)} = $2;
      } else { $error = $ln }
    }
    if ($first) { do_log(-1,"Empty spamd response") }
    elsif (defined $error) { do_log(-1,"Error in spamd resp: %s",$error) }
    elsif ($resp_code !~ /^\d+\z/ || $resp_code != 0) {
      do_log(-1,"Failure reported by spamd: %s %s %s",
                $version,$resp_code,$resp_msg);
    } else {
      my $reply_len = 0;
      while (defined($ln = $spamd_handle->get_response_line)) {
        do_log(5,"from spamd: %s", $ln);
        $reply_len += length($ln); $ln =~ s/\015\012\z//; $sa_tests = $ln;
      }
      do_log(-1,"Reply from spamd size mismatch: %d %s",
                $reply_len, $attr{'content-length'}
            )  if $reply_len != $attr{'content-length'};
    }
    $spamd_handle->close;  # terminate the session, ignoring status
    undef $spamd_handle;
    $spam_level = $2  if $attr{'spam'} =~ m{(\S+) ; (\S+) / (\S+)};
    1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
    do_log(-1,"%s client failed: %s", $scanner_name, $eval_stat);
  };
  section_time($which_section);
  my $score_factor = $self->{options}->{'score_factor'};
  if (defined $spam_level && defined $score_factor) {
    $spam_level *= $score_factor;
  }
  do_log(2,"%s spamd score=%s, tests=%s",
           $scanner_name, $spam_level, $sa_tests);
  $msginfo->supplementary_info('SCORE-'.$scanner_name, $spam_level);
  $msginfo->supplementary_info('VERDICT-'.$scanner_name,
                               $attr{'spam'} =~ /^True/  ? 'Spam'
                             : $attr{'spam'} =~ /^False/ ? 'Ham' : 'Unknown');
  for my $r (@$per_recip_data) {
    $r->spam_level( ($r->spam_level || 0) + $spam_level );
    if (!$r->spam_tests) {
      $r->spam_tests([ \$sa_tests ]);
    } else {
      push(@{$r->spam_tests}, \$sa_tests);
    }
  }
}

1;

__DATA__
#
package Mail::SpamAssassin::Logger::Amavislog;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  # let a 'require' understand that this module is already loaded:
  $INC{'Mail/SpamAssassin/Logger/Amavislog.pm'} = 'amavisd';
  import Amavis::Util qw(ll do_log);
}

sub new {
  my($class,%args) = @_;
  my(%llmap) = (error => -1, warn => 0, info => 1, dbg => 3);
  # $args{debug} is a simple boolean, sets the log level floor to 1 when true
  if ($args{debug}) { for (keys %llmap) { $llmap{$_} = 1 if $llmap{$_} > 1 } }
  bless { llmap => \%llmap }, $class;
}

sub close_log { 1 }

sub log_message {
  my($self, $level,$msg) = @_;
  my $ll = $self->{llmap}->{$level};
  $ll = 1  if !defined $ll;
  ll($ll) && do_log($ll, "SA %s: %s", $level,$msg);
  1;
}

1;

package Amavis::SpamControl::SpamAssassin;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform :confvars :sa $daemon_user c cr ca);
  import Amavis::Util qw(ll do_log do_log_safe sanitize_str prolong_timer
                         add_entropy min max minmax get_deadline
                         safe_encode_utf8_inplace);
  import Amavis::ProcControl qw(exit_status_str proc_status_ok
                         kill_proc run_command run_as_subprocess
                         collect_results collect_results_structured);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Timing qw(section_time get_rusage);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::IO::FileHandle;
}
use subs @EXPORT_OK;

use Errno qw(ENOENT EACCES EAGAIN EBADF);
use FileHandle;
use Mail::SpamAssassin;

sub getCommonSAModules {
  my $self = $_[0];
  my(@modules) = qw(
    Mail::SpamAssassin::Locker
    Mail::SpamAssassin::Locker::Flock
    Mail::SpamAssassin::Locker::UnixNFSSafe
    Mail::SpamAssassin::PersistentAddrList
    Mail::SpamAssassin::DBBasedAddrList
    Mail::SpamAssassin::AutoWhitelist
    Mail::SpamAssassin::BayesStore
    Mail::SpamAssassin::BayesStore::DBM
    Mail::SpamAssassin::PerMsgLearner
    Net::DNS::RR::SOA Net::DNS::RR::NS Net::DNS::RR::MX
    Net::DNS::RR::A Net::DNS::RR::AAAA Net::DNS::RR::PTR
    Net::DNS::RR::CNAME Net::DNS::RR::DNAME Net::DNS::RR::OPT
    Net::DNS::RR::TXT Net::DNS::RR::SPF Net::DNS::RR::NAPTR
    Net::DNS::RR::RP Net::DNS::RR::HINFO Net::DNS::RR::AFSDB
    Net::CIDR::Lite
    URI URI::Escape URI::Heuristic URI::QueryParam URI::Split URI::URL
    URI::WithBase URI::_foreign URI::_generic URI::_ldap URI::_login
    URI::_query URI::_segment URI::_server URI::_userpass
    URI::_idna URI::_punycode URI::data URI::ftp
    URI::gopher URI::http URI::https URI::ldap URI::ldapi URI::ldaps
    URI::mailto URI::mms URI::news URI::nntp URI::pop URI::rlogin URI::rsync
    URI::rtsp URI::rtspu URI::sip URI::sips URI::snews URI::ssh URI::telnet
    URI::tn3270 URI::urn URI::urn::oid
    URI::file URI::file::Base URI::file::Unix URI::file::Win32
  );
  # DBD::mysql
  # DBI::Const::GetInfo::ANSI DBI::Const::GetInfo::ODBC DBI::Const::GetInfoType
  # Mail::SpamAssassin::BayesStore::SQL
  # Mail::SpamAssassin::SQLBasedAddrList
  # ??? ArchiveIterator Reporter Getopt::Long Sys::Syslog lib
  @modules;
}

sub getSA2Modules {
  qw(Mail::SpamAssassin::UnixLocker Mail::SpamAssassin::BayesStoreDBM
  );
# Mail::SpamAssassin::SpamCopURI
}

sub getSA31Modules {
  qw( );
# Mail::SpamAssassin::BayesStore::MySQL
# Mail::SpamAssassin::BayesStore::PgSQL
}

sub getSA32Modules {
  qw(Mail::SpamAssassin::Bayes Mail::SpamAssassin::Bayes::CombineChi
     Mail::SpamAssassin::Locales Encode::Detect
  );
# Mail::SpamAssassin::BayesStore::MySQL
# Mail::SpamAssassin::BayesStore::PgSQL
# /var/db/spamassassin/compiled/.../Mail/SpamAssassin/CompiledRegexps/body_0.pm
}

sub getSAPlugins {
  my $self = $_[0];
  my(@modules);
  my $sa_version_num = $self->{version_num};
  push(@modules, qw(Hashcash RelayCountry SPF URIDNSBL)) if $sa_version_num>=3;
  push(@modules, qw(DKIM))  if $sa_version_num >= 3.001002;
  if ($sa_version_num >= 3.001000) {
    push(@modules, qw(
      AWL AccessDB AntiVirus AutoLearnThreshold DCC MIMEHeader Pyzor Razor2
      ReplaceTags TextCat URIDetail WhiteListSubject));
      # 'DomainKeys' plugin fell out of fashion with SA 3.2.0, don't load it
      # 'SpamCop' loads Net::SMTP and Net::Cmd, not needed otherwise
  }
  if ($sa_version_num >= 3.002000) {
    push(@modules, qw(
      BodyEval DNSEval HTMLEval HeaderEval MIMEEval RelayEval URIEval WLBLEval
      ASN Bayes BodyRuleBaseExtractor Check HTTPSMismatch OneLineBodyRuleType
      ImageInfo Rule2XSBody Shortcircuit VBounce));
  }
  if ($sa_version_num >= 3.004000) {
    push(@modules, qw(AskDNS));
  }
  $_ = 'Mail::SpamAssassin::Plugin::'.$_  for @modules;
  my(%mod_names) = map(($_,1), @modules);
  # add supporting modules
  push(@modules, qw(Razor2::Client::Agent))
    if $mod_names{'Mail::SpamAssassin::Plugin::Razor2'};
# push(@modules, qw(IP::Country::Fast))
#   if $mod_names{'Mail::SpamAssassin::Plugin::RelayCountry'};
  push(@modules, qw(Mail::DKIM Mail::DKIM::Verifier Net::DNS::Resolver))
    if $mod_names{'Mail::SpamAssassin::Plugin::DKIM'};
  push(@modules, qw(Image::Info Image::Info::GIF Image::Info::JPEG
                    Image::Info::PNG Image::Info::BMP Image::Info::TIFF))
    if $mod_names{'Mail::SpamAssassin::Plugin::ImageInfo'};
  if ($mod_names{'Mail::SpamAssassin::Plugin::SPF'}) {
    if ($sa_version_num < 3.002000) {
      # only the old Mail::SPF::Query was supported
      push(@modules, qw(Mail::SPF::Query));
    } else {
      # SA 3.2.0 supports both the newer Mail::SPF and the old Mail::SPF::Query
      # but we won't be loading the Mail::SPF::Query
      push(@modules, qw(
        Mail::SPF Mail::SPF::Server Mail::SPF::Request
        Mail::SPF::Mech Mail::SPF::Mech::A Mail::SPF::Mech::PTR
        Mail::SPF::Mech::All Mail::SPF::Mech::Exists Mail::SPF::Mech::IP4
        Mail::SPF::Mech::IP6 Mail::SPF::Mech::Include Mail::SPF::Mech::MX
        Mail::SPF::Mod Mail::SPF::Mod::Exp Mail::SPF::Mod::Redirect
        Mail::SPF::SenderIPAddrMech
        Mail::SPF::v1::Record Mail::SPF::v2::Record
        NetAddr::IP NetAddr::IP::Util
        auto::NetAddr::IP::_compV6 auto::NetAddr::IP::short
        auto::NetAddr::IP::InetBase::inet_any2n
        auto::NetAddr::IP::InetBase::inet_n2ad
        auto::NetAddr::IP::InetBase::inet_n2dx
        auto::NetAddr::IP::InetBase::inet_ntoa
        auto::NetAddr::IP::InetBase::ipv6_aton
        auto::NetAddr::IP::InetBase::ipv6_ntoa
      ));
    }
  }
  if ($mod_names{'Mail::SpamAssassin::Plugin::DomainKeys'} ||
      $mod_names{'Mail::SpamAssassin::Plugin::DKIM'}) {
    push(@modules, qw(
      Crypt::OpenSSL::RSA
      auto::Crypt::OpenSSL::RSA::new_public_key
      auto::Crypt::OpenSSL::RSA::new_key_from_parameters
      auto::Crypt::OpenSSL::RSA::get_key_parameters
      auto::Crypt::OpenSSL::RSA::import_random_seed
      Digest::SHA Error));
  }
# HTML/HeadParser.pm
# do_log(5, "getSAPlugins %s: %s", $sa_version_num, join(', ',@modules));
  @modules;
}

# invoked by a parent process before forking and chrooting
#
sub loadSpamAssassinModules {
  my $self = $_[0];
  my $sa_version_num = $self->{version_num};
  my @modules;  # modules to be loaded before chroot takes place
  push(@modules, $self->getCommonSAModules);
  if (!defined($sa_version_num)) {
    die "loadSpamAssassinModules: unknown version of Mail::SpamAssassin";
  } elsif ($sa_version_num < 3) {
    push(@modules, $self->getSA2Modules);
  } elsif ($sa_version_num >= 3.001 && $sa_version_num < 3.002) {
    push(@modules, $self->getSA31Modules);
  } elsif ($sa_version_num >= 3.002) {
    push(@modules, $self->getSA32Modules);
  }
  push(@modules, $self->getSAPlugins);
  my $missing;
  $missing = Amavis::Boot::fetch_modules('PRE-COMPILE OPTIONAL MODULES', 0,
                                         @modules)  if @modules;
  do_log(2, 'INFO: SA version: %s, %.6f, no optional modules: %s',
         $self->{version}, $sa_version_num, join(' ',@$missing))
         if ref $missing && @$missing;
}

# invoked by a parent process before forking but after chrooting
#
sub initializeSpamAssassinLogger {
  my $self = $_[0];
  local($1,$2,$3,$4,$5,$6);  # just in case
  if (!Mail::SpamAssassin::Logger->UNIVERSAL::can('add')) {
    # old SA?
  } elsif (!Mail::SpamAssassin::Logger::add(method => 'Amavislog',
                                            debug  => $sa_debug )) {
    do_log(-1,"Mail::SpamAssassin::Logger::add failed");
  } else {  # successfully rigged SpamAssassin with our logger
    Mail::SpamAssassin::Logger::remove('stderr');  # remove a default SA logger
    if (defined $sa_debug && $sa_debug =~ /[A-Za-z_,-]/) {
      # looks like a list of SA debug facilities
      push(@sa_debug_fac, split(/[ \t]*,[ \t]*/, $sa_debug));
    } else {
      unshift(@sa_debug_fac, 'info', $sa_debug ? 'all' : () );
    }
  }
}

# invoked by a parent process before forking but after chrooting
#
sub new_SpamAssassin_instance {
  my($self,$running_as_parent) = @_;
  # pick next available number as an instance name
  my $sa_instance_name = sprintf('%s', scalar @{$self->{instances}});
  do_log(1, "initializing Mail::SpamAssassin (%s)", $sa_instance_name);
  my $sa_version_num = $self->{version_num};
  my(@new_sa_debug_fac);
  for my $fac (@sa_debug_fac) { # handle duplicates and negation: foo,nofoo,x,x
    my $bfac = $fac;  $bfac =~ s/^none\z/noall/i;  $bfac =~ s/^no(?=.)//si;
    @new_sa_debug_fac = grep(!/^(no)?\Q$bfac\E\z/si, @new_sa_debug_fac);
    push(@new_sa_debug_fac, $fac);
  }
  do_log(2,"SpamAssassin debug facilities: %s", join(',',@sa_debug_fac));
  my $sa_args = {
    debug             => !@sa_debug_fac ? undef : \@sa_debug_fac,
    save_pattern_hits => grep(lc($_) eq 'all', @sa_debug_fac) ? 1 : 0,
    dont_copy_prefs   => 1,
    require_rules     => 1,
    stop_at_threshold => 0,
    need_tags         => 'TIMING,LANGUAGES,RELAYCOUNTRY,ASN,ASNCIDR',
    local_tests_only  => $sa_local_tests_only,
    home_dir_for_helpers => $helpers_home,
    rules_filename       => $sa_configpath,
    site_rules_filename  => $sa_siteconfigpath,
    userprefs_filename   => $sa_userprefs_file,
    skip_prng_reseeding  => 1,  # we'll do it ourselves (SA 3.4.0)
#   PREFIX            => '/usr/local',
#   DEF_RULES_DIR     => '/usr/local/share/spamassassin',
#   LOCAL_RULES_DIR   => '/etc/mail/spamassassin',
#   LOCAL_STATE_DIR   => '/var/lib/spamassassin',
#see Mail::SpamAssassin man page for other options
  };
  if ($sa_version_num < 3.001005 && !defined $sa_args->{LOCAL_STATE_DIR})
    { $sa_args->{LOCAL_STATE_DIR} = '/var/lib' } # don't ignore sa-update rules
  local($1,$2,$3,$4,$5,$6);  # avoid Perl bug, $1 gets tainted in compile_now
  my $spamassassin_obj = Mail::SpamAssassin->new($sa_args);
# $Mail::SpamAssassin::DEBUG->{rbl}=-3;
# $Mail::SpamAssassin::DEBUG->{rulesrun}=4+64;
  if ($running_as_parent) {
    # load SA config files and rules, try to preload most modules
    $spamassassin_obj->compile_now;
    $spamassassin_obj->call_plugins("prefork_init");  # since SA 3.4.0
  }
  if (ll(2) && !@{$self->{instances}}) {
    # created the first/main/only SA instance
    if ($spamassassin_obj->UNIVERSAL::can('get_loaded_plugins_list')) {
      my(@plugins) = $spamassassin_obj->get_loaded_plugins_list;
      do_log(2, "SpamAssassin loaded plugins: %s", join(', ', sort
        map { my $n = ref $_; $n =~ s/^Mail::SpamAssassin::Plugin:://; $n }
            @plugins));
#     printf STDOUT ("%s\n", join(", ",@plugins));
#       not in use: AccessDB AntiVirus TextCat; ASN BodyRuleBaseExtractor
#                   OneLineBodyRuleType Rule2XSBody Shortcircuit
    }
  }
  # provide a default username
  my $sa_uname = $spamassassin_obj->{username};
  if (!defined $sa_uname || $sa_uname eq '')
    { $spamassassin_obj->{username} = $sa_uname = $daemon_user }
  $self->{default_username} = $sa_uname  if !defined $self->{default_username};

  my $sa_instance = {
    instance_name => $sa_instance_name,
    spamassassin_obj => $spamassassin_obj,
    loaded_user_name => $sa_uname, loaded_user_config => '',
    conf_backup => undef, conf_backup_additional => {},
  };
  # remember some initial settings, like %msa_backup in spamd
  for (qw(username user_dir userstate_dir learn_to_journal)) {
    if (exists $spamassassin_obj->{$_}) {
      $sa_instance->{conf_backup_additional}{$_} = $spamassassin_obj->{$_};
    }
  }
  push(@{$self->{instances}}, $sa_instance);

  alarm(0);  # seems like SA forgets to clear alarm in some cases
  umask($self->{saved_umask});  # restore our umask, SA clobbered it
  section_time('SA new');

  $sa_instance;
}

sub new {
  my($class, $scanner_name,$module,@args) = @_;
  my(%options) = @args;
  my $self =
    bless { scanner_name => $scanner_name, options => \%options }, $class;
  $self->{initialized_stage} = 1;
  $self->{saved_umask} = umask;
  my $sa_version = Mail::SpamAssassin->Version;
  local($1,$2,$3);
  my $sa_version_num;  # turn '3.1.8-pre1' into 3.001008
  $sa_version_num = sprintf("%d.%03d%03d", $1,$2,$3)
    if $sa_version =~ /^(\d+)\.(\d+)(?:\.(\d+))/;  # ignore trailing non-digits
  $self->{version} = $sa_version;
  $self->{version_num} = $sa_version_num;
  $self->{default_username} = undef;
  $self->{instances} = [];
  $self;
}

sub init_pre_chroot {
  my $self = $_[0];
  $self->{initialized_stage} == 1
    or die "Wrong initialization sequence: " . $self->{initialized_stage};
  $self->loadSpamAssassinModules;
  $self->{initialized_stage} = 2;
}

sub init_pre_fork {
  my $self = $_[0];
  $self->{initialized_stage} == 2
    or die "Wrong initialization sequence: " . $self->{initialized_stage};
  $self->initializeSpamAssassinLogger;
  $self->new_SpamAssassin_instance(1)  for (1 .. max(1,$sa_num_instances));
  $self->{initialized_stage} = 3;
}

sub init_child {
  my $self = $_[0];
  $self->{initialized_stage} == 3
    or die "Wrong initialization sequence: " . $self->{initialized_stage};
  for my $sa_instance (@{$self->{instances}}) {
    my $spamassassin_obj = $sa_instance->{spamassassin_obj};
    next if !$spamassassin_obj;
    $spamassassin_obj->call_plugins("spamd_child_init");
    umask($self->{saved_umask});  # restore our umask, SA may have clobbered it
  }
  $self->{initialized_stage} = 4;
}

sub rundown_child {
  my $self = $_[0];
  for my $sa_instance (@{$self->{instances}}) {
    my $spamassassin_obj = $sa_instance->{spamassassin_obj};
    next if !$spamassassin_obj;
    do_log(3,'SA rundown_child (%s)', $sa_instance->{instance_name});
    $spamassassin_obj->call_plugins("spamd_child_post_connection_close");
    umask($self->{saved_umask});  # restore our umask, SA may have clobbered it
  }
  $self->{initialized_stage} = 5;
}

sub call_spamassassin($$$$) {
  my($self,$msginfo,$lines,$size_limit) = @_;
  my(@result); my($mail_obj,$per_msg_status);
  my $which_section = 'SA prepare';
  my $saved_pid = $$; my $sa_version_num = $self->{version_num};

  my $msg = $msginfo->mail_text;  # a file handle or a string ref
  my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
  $msg = $msg_str_ref  if ref $msg_str_ref;

  # pass data to SpamAssassin as ARRAY or GLOB or STRING or STRING_REF
  my $data_representation = ref($msg) eq 'SCALAR' ? 'STRING' : 'GLOB';
  $data_representation = 'STRING_REF'
    if $data_representation eq 'STRING' && $sa_version_num >= 3.004000;
  my $data;  # this will be passed to SpamAssassin's parser
  local(*F);

  if ($data_representation eq 'STRING' ||
      $data_representation eq 'STRING_REF') {
    $which_section = 'SA msg read';
    $data = join('', @$lines);  # a string to be passed to SpamAssassin
    if (!defined $msg) {
      # empty mail
    } elsif (ref $msg eq 'SCALAR') {
      $data .= $$msg;
    } elsif ($msg->isa('MIME::Entity')) {
      die "passing a MIME::Entity object to SpamAssassin is not implemented";
    } else {  # read message into memory, yuck
      my $file_position = $msginfo->skip_bytes;
      $msg->seek($file_position, 0) or die "Can't rewind mail file: $!";
      my $nbytes;
      while ( $nbytes=$msg->sysread($data, 32768, length $data) ) {
        $file_position += $nbytes;
        last if defined $size_limit && length($data) > $size_limit;
      }
      defined $nbytes or die "Error reading: $!";
    }
    if (defined $size_limit && length($data) > $size_limit) {
      substr($data,$size_limit) = "[...]\n";
    }
    section_time($which_section);

  } elsif ($data_representation eq 'ARRAY') {
    # read message into memory, yuck - even worse: line-by-line
    $which_section = 'SA msg read';  my $ln; my $len = 0;
    if (defined $size_limit) { $len += length($_) for @$lines }
    $msg->seek($msginfo->skip_bytes, 0) or die "Can't rewind mail file: $!";
    for ($! = 0; defined($ln=<$msg>); $! = 0) {  # header section
      push(@$lines,$ln);
      if (defined $size_limit)
        { $len += length($ln); last if $len > $size_limit }
      last if $ln eq "\n";
    }
    defined $ln || $! == 0  or   # returning EBADF at EOF is a perl bug
      $! == EBADF ? do_log(0,"Error reading mail header section: %s", $!)
                  : die "Error reading mail header section: $!";
    if (!defined $size_limit) {
      for ($! = 0; defined($ln=<$msg>); $! = 0) { push(@$lines,$ln) }  # body
    } else {
      for ($! = 0; defined($ln=<$msg>); $! = 0) {  # body
        push(@$lines,$ln);
        $len += length($ln);  last if $len > $size_limit;
      }
    }
    defined $ln || $! == 0  or   # returning EBADF at EOF is a perl bug
      $! == EBADF ? do_log(1,"Error reading mail body: %s", $!)
                  : die "Error reading mail body: $!";
    $data = $lines;  # array of lines to be passed to SpamAssassin
    section_time($which_section);
  }

  my($rusage_self_before, $rusage_children_before, @sa_cpu_usage);
  my $eval_stat;
  $which_section = 'SA prelim';
  eval {
    if ($data_representation eq 'GLOB') { # pass mail as a GLOB to SpamAssassin
      ref($msg) ne 'SCALAR'  # expects $msg to be a file handle
        or die "panic: data_representation is GLOB, but message is in memory";
      do_log(2,"truncating a message passed to SA at %d bytes, orig %d",
               $size_limit, $msginfo->msg_size)  if defined $size_limit;
      # present a virtual file to SA, an original mail file prefixed by @$lines
      tie(*F,'Amavis::IO::FileHandle');
      open(F, $msg,$lines,$size_limit) or die "Can't open SA virtual file: $!";
      binmode(F) or die "Can't set binmode on a SA virtual file: $!";
      $data = \*F;  # a GLOB to be passed to SpamAssassin
    }

    $which_section = 'SA userconf';
    my $sa_default_username = $self->{default_username};
    my $per_recip_data = $msginfo->per_recip_data;
    $per_recip_data = []  if !$per_recip_data;
    my $uconf_maps_ref = ca('sa_userconf_maps');
    my $uname_maps_ref = ca('sa_username_maps');
    $uconf_maps_ref = []  if !$uconf_maps_ref;
    $uname_maps_ref = []  if !$uname_maps_ref;
    my(%uconf_filename_available);
    my(%sa_configs_hash);  # collects distinct config names and usernames
    my $uconf_unsupported = 0;
    my $r_ind = 0;
    for my $r (@$per_recip_data) {
      my($uconf,$uname);
      my $recip_addr = $r->recip_addr;
      $uconf = lookup2(0, $recip_addr, $uconf_maps_ref)  if @$uconf_maps_ref;
      $uname = lookup2(0, $recip_addr, $uname_maps_ref)  if @$uname_maps_ref;
      $uconf = ''  if !defined $uconf;
      $uname = $sa_default_username  if !defined $uname || $uname eq '';
      if ($uconf =~ /^sql:/i) {
        $uconf = $uname eq $sa_default_username ? '' : 'sql:'.$uname;
      }
      if ($sa_version_num < 3.003000 && $uconf ne '') {
        $uconf = ''; $uconf_unsupported = 1;
      }
      if ($uconf eq '') {
        # ok, no special config required, just using a default
      } elsif ($uconf =~ /^sql:/i) {
        # assume data is in SQL, possibly an empty set
      } else {
        $uconf = "$MYHOME/$uconf"  if $uconf !~ m{^/};
        if ($uconf_filename_available{$uconf}) {
          # good, already checked and is available, keep it
        } elsif (defined $uconf_filename_available{$uconf}) {
          # defined but false, already checked and failed, use a default config
          $uconf = '';
        } else {
          # check for existence of a SA user configuration/preferences file
          my(@stat_list) = stat($uconf);  # symlinks-friendly
          my $errn = @stat_list ? 0 : 0+$!;
          my $msg = $errn == ENOENT ? "does not exist"
                  : $errn           ? "is inaccessible: $!"
                  :  -d _           ? "is a directory"
                  : !-f _           ? "is not a regular file"
                  : !-r _           ? "is not readable" : undef;
          if (defined $msg) {
            do_log(1,'SA user config file "%s" %s, ignoring it', $uconf,$msg);
            $uconf_filename_available{$uconf} = 0;  # defined but false
            $uconf = '';  # ignoring it, use a default config
          } else {
            $uconf_filename_available{$uconf} = 1;
          }
        }
      }
      # collect lists of recipient indices for each unique config/user pair
      # the %sa_configs_hash is a two-level hash: on $uconf and $uname
      my $p = $sa_configs_hash{$uconf};
      if (!$p) { $sa_configs_hash{$uconf} = $p = {} }
      if (!exists $p->{$uname}) { $p->{$uname} = $r_ind }
      else { $p->{$uname} .= ',' . $r_ind }
      $r_ind++;
    }
    if ($uconf_unsupported) {
      do_log(5,'SA user config loading unsupported for SA older than 3.3.0');
    }

    # refresh $sa_instance->{loaded_user_name}, just in case
    for my $sa_instance (@{$self->{instances}}) {
      my $spamassassin_obj = $sa_instance->{spamassassin_obj};
      next if !$spamassassin_obj;
      my $sa_uname = $spamassassin_obj->{username};
      $sa_instance->{loaded_user_name} = defined $sa_uname ? $sa_uname : '';
    }

    my $sa_instance = $self->{instances}[0];
    my $curr_conf = $sa_instance->{loaded_user_config};
    my $curr_user = $sa_instance->{loaded_user_name};

    # switching config files is the most expensive, sort to minimize switching
    my(@conf_names);  # a list of config names for which SA needs to be called;
                      # sorted: current first, baseline second, then the rest
    push(@conf_names, $curr_conf)  if exists $sa_configs_hash{$curr_conf};
    push(@conf_names, '')  if $curr_conf ne '' && exists $sa_configs_hash{''};
    push(@conf_names,
         grep($_ ne '' && $_ ne $curr_conf, keys %sa_configs_hash));

    # call SA checking for each distinct SA userprefs config filename and user
    for my $conf_user_pair (map { my $c = $_;
                                  map([$c,$_], keys %{$sa_configs_hash{$c}})
                                } @conf_names) {
      my($uconf,$uname) = @$conf_user_pair;
      # comma-separated list of recip indices which use this SA config
      my $rind_list = $sa_configs_hash{$uconf}{$uname};
      if (ll(5)) {
        do_log(5, "SA user config: \"%s\", username: \"%s\", %s, %s",
                  $uconf, $uname, $rind_list,
                  join(', ', map("($_)" . $per_recip_data->[$_]->recip_addr,
                                 split(/,/,$rind_list))));
      }
      my $sa_instance;
      if (@{$self->{instances}} <= 1) {
        # pick the only choice
        $sa_instance = $self->{instances}[0];

      } else {
        # choosing a suitably-matching SpamAssassin instance
        my(@sa_instances_matching_uconf, @sa_instances_matching_both,
           @sa_instances_available);
        for my $sa_instance (@{$self->{instances}}) {
          next if !$sa_instance->{spamassassin_obj};
          push(@sa_instances_available, $sa_instance);
          if ($sa_instance->{loaded_user_config} eq $uconf) {
            push(@sa_instances_matching_uconf, $sa_instance);
            if ($sa_instance->{loaded_user_name} eq $uname) {
              push(@sa_instances_matching_both, $sa_instance);
            }
          }
        }
        my $fit_descr;
        if (@sa_instances_matching_both) {
          # just pick the first
          $sa_instance = $sa_instances_matching_both[0];
          $fit_descr = sprintf('exact fit, %d choices',
                               scalar @sa_instances_matching_both);
        } elsif (@sa_instances_matching_uconf) {
          # picking one at random
          my $j = @sa_instances_matching_uconf <= 1 ? 0
                : int(rand(scalar(@sa_instances_matching_uconf)));
          $sa_instance = $sa_instances_available[$j];
          $fit_descr = sprintf('good fit: same config, other user, %d choices',
                               scalar @sa_instances_matching_uconf);
        } elsif ($uconf eq '') {
          # the first instance is a good choice for switching to a dflt config
          $sa_instance = $self->{instances}[0];
          $fit_descr = 'need a default config, picking first';
        } elsif (@sa_instances_available <= 1) {
          $sa_instance = $sa_instances_available[0];
          $fit_descr = 'different config, picking the only one available';
        } elsif (@sa_instances_available == 2) {
          $sa_instance = $sa_instances_available[1];
          $fit_descr = 'different config, picking the second one';
        } else {
          # picking one at random, preferably not the first
          my $j = 1+int(rand(scalar(@sa_instances_available)-1));
          $sa_instance = $sa_instances_available[$j];
          $fit_descr = 'different config, picking one at random';
        }
        do_log(2,'SA user config: instance chosen (%s), %s',
                 $sa_instance->{instance_name}, $fit_descr);
      }
      my $curr_conf = $sa_instance->{loaded_user_config};
      my $curr_user = $sa_instance->{loaded_user_name};
      my $spamassassin_obj = $sa_instance->{spamassassin_obj};

      if ($curr_conf ne '' && $curr_conf ne $uconf) {
        # revert SA configuration to its initial state
        $which_section = 'revert_config';
        ref $sa_instance->{conf_backup}
          or die "panic, no conf_backup available";
        for (qw(username user_dir userstate_dir learn_to_journal)) {
          if (exists $sa_instance->{conf_backup_additional}{$_}) {
            $spamassassin_obj->{$_} =
              $sa_instance->{conf_backup_additional}{$_};
          } else {
            delete $spamassassin_obj->{$_};
          }
        }
        # config leaks fixed in SpamAssassin 3.3.0, SA bug 6205, 6003, 4179
        $spamassassin_obj->copy_config($sa_instance->{conf_backup}, undef)
          or die "copy_config: failed to restore";
        $sa_instance->{loaded_user_config} = $curr_conf = '';
        do_log(5,"SA user config reverted to a saved copy");
        section_time($which_section);
      }
      if ($uconf ne '' && $uconf ne $curr_conf) {
        # load SA user configuration/preferences
        if (!defined $sa_instance->{conf_backup}) {
          $which_section = 'save_config';
          do_log(5,"SA user config: saving SA user config");
          $sa_instance->{conf_backup} = {};
          $spamassassin_obj->copy_config(undef, $sa_instance->{conf_backup})
            or die "copy_config: failed to save configuration";
          section_time($which_section);
        }
        $which_section = 'load_config';
        # User preferences include scoring options, scores, whitelists
        # and blacklists, etc, but do not include rule definitions,
        # privileged settings, etc. unless allow_user_rules is enabled;
        # and they never include administrator settings
        if ($uconf =~ /^sql:/) {
          $uconf eq 'sql:'.$uname
            or die "panic: loading SA config mismatch: $uname <-> $uconf";
          do_log(5,"loading SA user config from SQL %s", $uname);
          $spamassassin_obj->load_scoreonly_sql($uname);
        } else {
          do_log(5,"loading SA user config file %s", $uconf);
          $spamassassin_obj->read_scoreonly_config($uconf);
        }
        $sa_instance->{loaded_user_config} = $curr_conf = $uconf;
        section_time($which_section);
      }
      if ($uname ne $curr_user) {
        $which_section = 'SA switch_user';
        do_log(5,'SA user config: switching SA (%s) username "%s" -> "%s"',
                 $sa_instance->{instance_name}, $curr_user, $uname);
        $spamassassin_obj->signal_user_changed({ username => $uname });
        $sa_instance->{loaded_user_name} = $curr_user = $uname;
        section_time($which_section);
      }
      ll(3) && do_log(3, "calling SA parse (%s), SA vers %s, %.6f, ".
                         "data as %s, recips_ind [%s]%s%s",
                         $sa_instance->{instance_name},
                         $self->{version}, $sa_version_num,
                         $data_representation, $rind_list,
                         ($uconf eq '' ? '' : ", conf: \"$uconf\""),
                         ($uname eq '' ? '' : ", user: \"$uname\"") );

      if ($data_representation eq 'GLOB') {
        seek(F,0,0) or die "Can't rewind a SA virtual file: $!";
      }
      $spamassassin_obj->timer_reset
        if $spamassassin_obj->UNIVERSAL::can('timer_reset');

      $which_section = 'SA parse';
      my($remaining_time, $deadline) = get_deadline('SA check', 1, 5);

      my(@mimepart_digests);
      for (my(@traversal_stack) = $msginfo->parts_root;
           my $part = pop @traversal_stack; ) {  # pre-order tree traversal
        my $digest = $part->digest;
        push(@mimepart_digests, $digest)  if defined $digest;
        push(@traversal_stack, reverse @{$part->children}) if $part->children;
      }
      do_log(5,'mimepart digest: %s', $_) for @mimepart_digests;

      my(%suppl_attrib) = (
        'skip_prng_reseed' => 1,  # do not call srand(), we already did it
        'return_path'  => $msginfo->sender_smtp,
        'recipients'   => [ map(qquote_rfc2821_local($_->recip_addr),
                            @$per_recip_data[split(/,/, $rind_list)]) ],
        'originating'  => $msginfo->originating ? 1 : 0,
        'message_size' => $msginfo->msg_size,
        'body_size'    => $msginfo->orig_body_size,
        !@mimepart_digests ? ()
          : ('mimepart_digests' => \@mimepart_digests),
        !c('enable_dkim_verification') ? ()
          : ('dkim_signatures' => $msginfo->dkim_signatures_all),
        !defined $deadline ? ()
          : ('master_deadline' => $deadline),
        'rule_hits' => [
          # known attributes: rule, area, score, value, ruletype, tflags, descr
        # { rule=>'AM:TEST1', score=>0.11 },
        # { rule=>'TESTTEST', defscore=>0.22, descr=>'my test' },
          !defined $size_limit ? () :
            { rule=>'__TRUNCATED', score=>-0.1, area=>'RAW: ', tflags=>'nice',
              descr=>"Message size truncated to $size_limit B" },
        ],
        'amavis_policy_bank_path' => c('policy_bank_path'),
      );

      ($rusage_self_before, $rusage_children_before) = get_rusage();
      $mail_obj = $sa_version_num < 3
        ? Mail::SpamAssassin::NoMailAudit->new(data=>$data, add_From_line=>0)
        : $spamassassin_obj->parse(
            $data_representation eq 'STRING_REF' ? \$data : $data,
            0, \%suppl_attrib);
      section_time($which_section);

      $which_section = 'SA check';
      if (@conf_names <= 1) {
        do_log(4,"CALLING SA check (%s)", $sa_instance->{instance_name});
      } else {
        do_log(4,"CALLING SA check (%s) for recips: %s",
                 $sa_instance->{instance_name},
                 join(", ", @{$suppl_attrib{'recipients'}}));
      }
      { local($1,$2,$3,$4,$5,$6);  # avoid Perl 5.8.x bug, $1 gets tainted
        $per_msg_status = $spamassassin_obj->check($mail_obj);
      }
      do_log(4,"DONE SA check (%s)", $sa_instance->{instance_name});
      section_time($which_section);

      $which_section = 'SA collect';
      my($spam_level,$spam_report,$spam_summary,%supplementary_info);
      { local($1,$2,$3,$4,$5,$6);  # avoid Perl 5.8.x taint bug
        if ($sa_version_num < 3) {
          $spam_level = $per_msg_status->get_hits;
          $supplementary_info{'TESTSSCORES'} = $supplementary_info{'TESTS'} =
            $per_msg_status->get_names_of_tests_hit;
        } else {
          $spam_level = $per_msg_status->get_score;
          for my $t (qw(VERSION SUBVERSION RULESVERSION
                        TESTS TESTSSCORES ADDEDHEADERHAM ADDEDHEADERSPAM
                        AUTOLEARN AUTOLEARNSCORE SC SCRULE SCTYPE
                        LANGUAGES RELAYCOUNTRY ASN ASNCIDR DCCB DCCR DCCREP
                        DKIMDOMAIN DKIMIDENTITY AWLSIGNERMEAN
                        HAMMYTOKENS SPAMMYTOKENS
                        CRM114STATUS CRM114SCORE CRM114CACHEID)) {
            my $tag_value = $per_msg_status->get_tag($t);
            if (defined $tag_value) {
              # for some reason tags ASN and ASNCIDR have UTF8 flag on;
              # encode any character strings to UTF-8 octets for consistency
              safe_encode_utf8_inplace($tag_value);  # to octets if not already
              $supplementary_info{$t} = $tag_value;
            }
          }
        }
        { # fudge
          my $crm114_status = $supplementary_info{'CRM114STATUS'};
          my $crm114_score  = $supplementary_info{'CRM114SCORE'};
          if (defined $crm114_status && defined $crm114_score) {
            $supplementary_info{'CRM114STATUS'} =
              sprintf("%s ( %s )", $crm114_status,$crm114_score);
          }
        }
        # get_report() taints $1 and $2 !
        $spam_summary = $per_msg_status->get_report;
      # $spam_summary = $per_msg_status->get_tag('SUMMARY');
        $spam_report  = $per_msg_status->get_tag('REPORT');
        safe_encode_utf8_inplace($spam_summary); # to octets (if not already)
        safe_encode_utf8_inplace($spam_report);  # to octets (if not already)
        # fetch the TIMING tag last:
        $supplementary_info{'TIMING'} = $per_msg_status->get_tag('TIMING');
        $supplementary_info{'RUSAGE-SA'} = \@sa_cpu_usage;  # filled-in later
      }
    # section_time($which_section);  # don't bother reporting separately, short

      $which_section = 'SA check finish';
      if (defined $per_msg_status)
        { $per_msg_status->finish; undef $per_msg_status }
      if (defined $mail_obj)
        { $mail_obj->finish if $sa_version_num >= 3; undef $mail_obj }
    # section_time($which_section);  # don't bother reporting separately, short

      # returning the result as a data structure instead of modifying
      # the $msginfo objects directly is used to make it possible to run
      # this subroutine as a subprocess; modifications to $msginfo objects
      # would be lost if done in a context of a spawned process
      push(@result, {
        recip_ind_list => $rind_list, user_config => $uconf,
        spam_level => $spam_level,
        spam_report => $spam_report, spam_summary => $spam_summary,
        supplementary_info => \%supplementary_info,
      });
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };

  $which_section = 'SA finish';
  if (defined $per_msg_status)  # just in case
    { $per_msg_status->finish; undef $per_msg_status }
  if (defined $mail_obj)  # just in case
    { $mail_obj->finish if $sa_version_num >= 3; undef $mail_obj }
  if ($data_representation eq 'GLOB') {
    close(F) or die "Can't close SA virtual file: $!";
    untie(*F);
  }
  umask($self->{saved_umask});  # restore our umask, SA may have clobbered it
  if ($$ != $saved_pid) {
    do_log_safe(-2,"PANIC, SA checking produced a clone process ".
                   "of [%s], CLONE [%s] SELF-TERMINATING", $saved_pid,$$);
    POSIX::_exit(3);  # SIGQUIT, avoid END and destructor processing
  # POSIX::_exit(6);  # SIGABRT, avoid END and destructor processing
  }

  if ($rusage_self_before && $rusage_children_before) {
    my($rusage_self_after, $rusage_children_after) = get_rusage();
    @sa_cpu_usage = (
      $rusage_self_after->{ru_utime} - $rusage_self_before->{ru_utime},
      $rusage_self_after->{ru_stime} - $rusage_self_before->{ru_stime},
      $rusage_children_after->{ru_utime} -
                                   $rusage_children_before->{ru_utime},
      $rusage_children_after->{ru_stime} -
                                   $rusage_children_before->{ru_stime} );
  }
# section_time($which_section);
  if (defined $eval_stat) { chomp $eval_stat; die $eval_stat }  # resignal
  \@result;
}

sub check {
  my($self,$msginfo) = @_;
  $self->{initialized_stage} == 4
    or die "Wrong initialization sequence: " . $self->{initialized_stage};
  my $scanner_name = $self->{scanner_name};
  my $which_section; my $prefix = '';
  my($spam_level,$sa_tests,$spam_report,$spam_summary,$supplementary_info_ref);
  my $hdr_edits = $msginfo->header_edits;
  my $size_limit;
  my $mbsl = $self->{options}->{'mail_body_size_limit'};
  $mbsl = c('sa_mail_body_size_limit')  if !defined $mbsl;
  if (defined $mbsl) {
    $size_limit = min(64*1024, $msginfo->orig_header_size) + 1 +
                  min($mbsl,   $msginfo->orig_body_size);
    # don't bother if slightly oversized, it's faster without size checks
    undef $size_limit  if $msginfo->msg_size < $size_limit + 5*1024;
  }
  # fake a local delivery agent by inserting a Return-Path
  $prefix .= sprintf("Return-Path: %s\n", $msginfo->sender_smtp);
  $prefix .= sprintf("X-Envelope-To: %s\n",
                     join(",\n ",qquote_rfc2821_local(@{$msginfo->recips})));
  my $os_fp = $msginfo->client_os_fingerprint;
  $prefix .= sprintf("X-Amavis-OS-Fingerprint: %s\n",
                     sanitize_str($os_fp))  if defined($os_fp) && $os_fp ne '';
  my(@av_tests);
  for my $r (@{$msginfo->per_recip_data}) {
    my $spam_tests = $r->spam_tests;
    push(@av_tests, grep(/^AV[.:].+=/,
                 split(/,/, join(',',map($$_,@$spam_tests)))))  if $spam_tests;
  }
  $prefix .= sprintf("X-Amavis-AV-Status: %s\n",
                     sanitize_str(join(',',@av_tests)))  if @av_tests;
  $prefix .= sprintf("X-Amavis-PolicyBank: %s\n", c('policy_bank_path'));
  $prefix .= sprintf("X-Amavis-MessageSize: %d%s\n", $msginfo->msg_size,
                     !defined $size_limit ? '' : ", TRUNCATED to $size_limit");
  for my $hf_name (qw(
        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)) {
    my $suppl_attr_val = $msginfo->supplementary_info($hf_name);
    if (defined $suppl_attr_val && $suppl_attr_val ne '') {
      chomp $suppl_attr_val;
      $prefix .= sprintf("%s: %s\n", $hf_name, sanitize_str($suppl_attr_val));
    }
  }

  $which_section = 'SA call';
  my($proc_fh,$pid); my $eval_stat; my $results_aref;
  eval {
    # NOTE ON TIMEOUTS: SpamAssassin may use timer for its own purpose,
    # disabling it before returning. It seems it only uses timer when
    # external tests are enabled.
    local $SIG{ALRM} = sub {
      my $s = Carp::longmess("SA TIMED OUT, backtrace:");
      # crop at some rather arbitrary limit
      substr($s,900-3) = '[...]'  if length($s) > 900;
      do_log(-1,"%s",$s);
    };
    prolong_timer('spam_scan_sa_pre', 1, 4);  # restart the timer
    #
    # note: array @lines at this point contains only prepended synthesized
    # header fields, but may be extended in sub call_spamassassin() by
    # reading-in the rest of the message; this may or may not happen in
    # a separate process (called through run_as_subprocess or directly);
    # each line must be terminated by a \n character, which must be the
    # only \n in a line;
    #
    my(@lines) = split(/^/m, $prefix, -1);  $prefix = undef;

    if (!$sa_spawned) {
      $results_aref = call_spamassassin($self,$msginfo,\@lines,$size_limit);
    } else {
      ($proc_fh,$pid) = run_as_subprocess(\&call_spamassassin,
                                   $self,$msginfo,\@lines,$size_limit);
      my($results,$child_stat) =
        collect_results_structured($proc_fh,$pid,'spawned SA',200*1024);
      $results_aref = $results->[0]  if defined $results;
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  section_time($which_section)  if $sa_spawned;

  $which_section = 'SA done';
  prolong_timer('spam_scan_sa');  # restart the timer
  if ($results_aref) {
    # for each group of recipients using the same SA userconf file
    for my $h (@$results_aref) {
      my $rind_list = $h->{recip_ind_list};
      my(@r_list) = @{$msginfo->per_recip_data}[split(/,/,$rind_list)];
      my $uconf = $h->{user_config};
      $spam_level = $h->{spam_level};
      $spam_report = $h->{spam_report}; $spam_summary = $h->{spam_summary};
      $supplementary_info_ref = $h->{supplementary_info};
      $supplementary_info_ref = {}  if !$supplementary_info_ref;
      $sa_tests = $supplementary_info_ref->{'TESTSSCORES'};
      add_entropy($spam_level,$sa_tests);
      my $score_factor = $self->{options}->{'score_factor'};
      if (defined $spam_level && defined $score_factor) {
        $spam_level *= $score_factor;
      }
      do_log(3,"spam_scan: score=%s autolearn=%s tests=[%s] recips=%s",
               $spam_level, $supplementary_info_ref->{'AUTOLEARN'},
               $sa_tests, $rind_list);
      my(%sa_tests_h);
      if (defined $sa_tests && $sa_tests ne 'none') {
        for my $t (split(/,[ \t]*/, $sa_tests)) {
          my($test_name,$score) = split(/=/, $t, 2);
          $sa_tests_h{$test_name} = $score;
        }
      }
      my $dkim_adsp_suppress;
      if (exists $sa_tests_h{'DKIM_ADSP_DISCARD'}) {
        # must honour ADSP 'discardable', suppress a bounce
        do_log(2,"spam_scan: dsn_suppress_reason DKIM_ADSP_DISCARD");
        $dkim_adsp_suppress = 1;
      }
      $msginfo->supplementary_info('SCORE-'.$scanner_name, $spam_level);
      $msginfo->supplementary_info('VERDICT-'.$scanner_name,
        $spam_level >= 5 ? 'Spam' : $spam_level < 1 ? 'Ham' : 'Unknown');
      for my $r (@r_list) {
        $r->spam_level( ($r->spam_level || 0) + $spam_level );
        $r->spam_report($spam_report); $r->spam_summary($spam_summary);
        if (!$r->spam_tests) {
          $r->spam_tests([ \$sa_tests ]);
        } else {
          # comes last: here we use push, unlike elsewhere where may do unshift
          push(@{$r->spam_tests}, \$sa_tests);
        }
        if ($dkim_adsp_suppress) {
          $r->dsn_suppress_reason('DKIM_ADSP_DISCARD' .
                    !defined $_ ? '' : ", $_")  for $r->dsn_suppress_reason;
        }
      }
    }
  }
  if (defined($msginfo->spam_report) || defined($msginfo->spam_summary)) {
    $spam_report = $msginfo->spam_report . ', ' . $spam_report
      if $msginfo->spam_report ne '';
    $spam_summary = $msginfo->spam_summary . "\n\n" . $spam_summary
      if $msginfo->spam_summary ne '';
  }
  $msginfo->spam_report($spam_report); $msginfo->spam_summary($spam_summary);
  for (keys %$supplementary_info_ref) {
    $msginfo->supplementary_info($_, $supplementary_info_ref->{$_});
  }
  if (defined $eval_stat) {  # SA timed out?
    kill_proc($pid,'a spawned SA',1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid; chomp $eval_stat;
    do_log(-2, "SA failed: %s", $eval_stat);
  # die "$eval_stat\n"  if $eval_stat !~ /timed out\b/;
  }
  1;
}

1;

__DATA__
#
package Amavis::Unpackers;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&init &decompose_part &determine_file_types);
  import Amavis::Util qw(untaint min max minmax ll do_log snmp_count
                         prolong_timer rmdir_recursively add_entropy);
  import Amavis::ProcControl qw(exit_status_str proc_status_ok run_command
                         kill_proc collect_results collect_results_structured);
  import Amavis::Conf qw(:platform :confvars $file c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Unpackers::MIME qw(mime_decode);
  import Amavis::Unpackers::NewFilename qw(consumed_bytes);
}

BEGIN {
  use vars qw($filemagic);
  eval {
    require File::LibMagic;
    File::LibMagic->VERSION(1.00);
    import File::LibMagic;
    $filemagic = File::LibMagic->new;
  } or do {
    undef $filemagic;
  };
}

use subs @EXPORT_OK;

use Errno qw(ENOENT EACCES EINTR EAGAIN);
use POSIX qw(SIGALRM);
use IO::File qw(O_CREAT O_EXCL O_WRONLY);
use Time::HiRes ();
use File::Basename qw(basename);
use Compress::Zlib 1.35;  # avoid security vulnerability in <= 1.34
use Archive::Zip 1.14 qw(:CONSTANTS :ERROR_CODES);

# recursively descend into a directory $dir containing potentially unsafe
# files with unpredictable names, soft links, etc., rename each regular
# nonempty file to a directory $outdir giving it a generated name,
# and discard all the rest, including the directory $dir.
# Return a pair: number of bytes that 'sanitized' files now occupy,
# and a number of parts-objects created.
#
sub flatten_and_tidy_dir($$$;$$);  # prototype
sub flatten_and_tidy_dir($$$;$$) {
  my($dir, $outdir, $parent_obj, $item_num_offset, $orig_names) = @_;
  do_log(4, 'flatten_and_tidy_dir: processing directory "%s"', $dir);
  my $consumed_bytes = 0;
  my $item_num = 0; my $parent_placement = $parent_obj->mime_placement;
  chmod(0750, $dir) or die "Can't change protection of \"$dir\": $!";
  local(*DIR); opendir(DIR,$dir) or die "Can't open directory \"$dir\": $!";
  # modifying a directory while traversing it can cause surprises, avoid;
  # avoid slurping the whole directory contents into memory
  my($f, @rmfiles, @renames, @recurse);
  while (defined($f = readdir(DIR))) {
    next  if $f eq '.' || $f eq '..';
    my $msg;  my $fname = $dir . '/' . $f;
    my(@stat_list) = lstat($fname); my $errn = @stat_list ? 0 : 0+$!;
    if    ($errn == ENOENT) { $msg = "does not exist" }
    elsif ($errn)           { $msg = "inaccessible: $!" }
    if (defined $msg) { die "flatten_and_tidy_dir: \"$fname\" $msg," }
    add_entropy(@stat_list);
    my $newpart_obj = Amavis::Unpackers::Part->new($outdir,$parent_obj);
    $item_num++;
    $newpart_obj->mime_placement(sprintf("%s/%d", $parent_placement,
                                                 $item_num+$item_num_offset) );
    # save tainted original member name if available, or a tainted file name
    my $original_name = !ref($orig_names) ? undef : $orig_names->{$f};
    $newpart_obj->name_declared(defined $original_name ? $original_name : $f);
    # untaint, but if $dir happens to still be tainted, we want to know and die
    $fname = $dir . '/' . untaint($f);
    if (-d _) {
      $newpart_obj->attributes_add('D');
      push(@recurse, $fname);
    } elsif (-l _) {
      $newpart_obj->attributes_add('L');
      push(@rmfiles, [$fname, 'soft link']);
    } elsif (!-f _) {
      $newpart_obj->attributes_add('S');
      push(@rmfiles, [$fname, 'nonregular file']);
    } elsif (-z _) {
      push(@rmfiles, [$fname, 'empty file']);
    } else {
      chmod(0750, $fname)
        or die "Can't change protection of file \"$fname\": $!";
      my $size = 0 + (-s _);
      $newpart_obj->size($size);
      $consumed_bytes += $size;
      my $newpart = $newpart_obj->full_name;
      push(@renames, [$fname, $newpart, $original_name]);
    }
  }
  closedir(DIR) or die "Error closing directory \"$dir\": $!";
  my $cnt_u = scalar(@rmfiles);
  for my $pair (@rmfiles) {
    my($fname,$what) = @$pair;
    do_log(5,'flatten_and_tidy_dir: deleting %s "%s"', $what,$fname);
    unlink($fname) or die "Can't remove $what \"$fname\": $!";
  }
  undef @rmfiles;
  my $cnt_r = scalar(@renames);
  for my $tuple (@renames) {
    my($fname,$newpart,$original_name) = @$tuple;
    ll(5) && do_log(5,'flatten_and_tidy_dir: renaming "%s"%s to %s', $fname,
              !defined $original_name ? '' : " ($original_name)", $newpart);
    rename($fname,$newpart) or die "Can't rename \"$fname\" to $newpart: $!";
  }
  undef @renames;
  for my $fname (@recurse) {
    do_log(5,'flatten_and_tidy_dir: descending into subdir "%s"', $fname);
    my($bytes,$cnt) = flatten_and_tidy_dir($fname, $outdir, $parent_obj,
                                    $item_num+$item_num_offset, $orig_names);
    $consumed_bytes += $bytes; $item_num += $cnt;
  }
  rmdir($dir) or die "Can't remove directory \"$dir\": $!";
  section_time("ren$cnt_r-unl$cnt_u-files$item_num");
  ($consumed_bytes, $item_num);
}

sub determine_file_types($$) {
  my($tempdir, $partslist_ref) = @_;
  if ($filemagic) {
    determine_file_types_libmagic($tempdir, $partslist_ref);
  } elsif (defined $file && $file ne '') {
    determine_file_types_fileutility($tempdir, $partslist_ref);
  } else {
    die "Neither File::LibMagic nor Unix utility file(1) are available";
  }
}

# associate full and short file content types with each part
# based on libmagic (uses File::LibMagic module)
#
sub determine_file_types_libmagic($$) {
  my($tempdir, $partslist_ref) = @_;
  my(@all_part_list) = grep($_->exists, @$partslist_ref);
  my $initial_num_parts = scalar(@all_part_list);
  do_log(5, 'using File::LibMagic on %d files', $initial_num_parts);
  for my $part (@all_part_list) {
    my($type_long, $type_short);
    eval {
      $type_long = $filemagic->describe_filename($part->full_name);
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(0, 'File::LibMagic::describe_filename failed on %s: %s',
             $part->base_name, $eval_stat);
    };
    if (defined $type_long) {
      $type_short = lookup2(0,$type_long,\@map_full_type_to_short_type_maps);
      ll(4) && do_log(4, "File-type of %s: %s%s",
                         $part->base_name, $type_long,
                         (!defined $type_short ? ''
                            : !ref $type_short ? "; ($type_short)"
                            : '; (' . join(', ',@$type_short) . ')'
                         ) );
      $part->type_long($type_long); $part->type_short($type_short);
      $part->attributes_add('C')
        if !ref($type_short) ? $type_short eq 'pgp.enc'  # encrypted?
                             : grep($_ eq 'pgp.enc', @$type_short);
    }
  }
  section_time(sprintf('get-file-type%d', $initial_num_parts));
  1;
}

# call 'file(1)' utility for each part,
# and associate full and short file content types with each part
#
sub determine_file_types_fileutility($$) {
  my($tempdir, $partslist_ref) = @_;
  defined $file && $file ne ''
    or die "Unix utility file(1) not available, but is needed";
  my(@all_part_list) = grep($_->exists, @$partslist_ref);
  my $initial_num_parts = scalar(@all_part_list);
  my $cwd = "$tempdir/parts";
  if (@all_part_list) { chdir($cwd) or die "Can't chdir to $cwd: $!" }
  my($proc_fh,$pid); my $eval_stat;
  eval {
    while (@all_part_list) {
      my(@part_list,@file_list); # collect reasonably small subset of filenames
      my $arglist_size = length($file);  # size of a command name itself
      while (@all_part_list) {   # collect as many args as safe, at least one
        my $nm = $all_part_list[0]->full_name;
        local($1); $nm =~ s{^\Q$cwd\E/(.*)\z}{$1}s;  # remove cwd from filename
        # POSIX requires 4 kB as a minimum buffer size for program arguments
        last  if @file_list && $arglist_size + length($nm) + 1 > 4000;
        push(@part_list, shift(@all_part_list));     # swallow the next one
        push(@file_list, $nm);  $arglist_size += length($nm) + 1;
      }
      if (scalar(@file_list) < $initial_num_parts) {
        do_log(2, "running file(1) on %d (out of %d) files, arglist size %d",
                   scalar(@file_list), $initial_num_parts, $arglist_size);
      } else {
        do_log(5, "running file(1) on %d files, arglist size %d",
                   scalar(@file_list), $arglist_size);
      }
      ($proc_fh,$pid) = run_command(undef, '&1', $file, @file_list);
      my $index = 0; my $ln;
      for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
        do_log(5, "result line from file(1): %s", $ln);
        chomp($ln); local($1,$2);
        if ($index > $#file_list) {
          do_log(-1,"NOTICE: Skipping unexpected output from file(1): %s",$ln);
        } else {
          my $part   = $part_list[$index];  # walk through @part_list in sync
          my $expect = $file_list[$index];  # walk through @file_list in sync
          if ($ln !~ /^(\Q$expect\E):[ \t]*(.*)\z/s) {
            # split file name from type
            do_log(-1,"NOTICE: Skipping bad output from file(1) ".
                      "at [%d, %s], got: %s", $index,$expect,$ln);
          } else {
            my $type_short; my $actual_name = $1; my $type_long = $2;
            $type_short =
              lookup2(0,$type_long,\@map_full_type_to_short_type_maps);
            ll(4) && do_log(4, "File-type of %s: %s%s",
                               $part->base_name, $type_long,
                               (!defined $type_short ? ''
                                  : !ref $type_short ? "; ($type_short)"
                                  : '; (' . join(', ',@$type_short) . ')'
                               ) );
            $part->type_long($type_long); $part->type_short($type_short);
            $part->attributes_add('C')
              if !ref($type_short) ? $type_short eq 'pgp.enc'  # encrypted?
                                   : grep($_ eq 'pgp.enc', @$type_short);
            $index++;
          }
        }
      }
      defined $ln || $! == 0 || $! == EAGAIN
        or die "Error reading from file(1) utility: $!";
      do_log(-1,"unexpected(file): %s",$!)  if !defined($ln) && $! == EAGAIN;
      my $err = 0; $proc_fh->close or $err = $!;
      my $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
      undef $proc_fh; undef $pid; my(@errmsg);
      # exit status is 1 when result is 'ERROR: ...', accept it mercifully
      proc_status_ok($child_stat,$err, 0,1)
        or push(@errmsg, "failed, ".exit_status_str($child_stat,$err));
      if ($index < @part_list) {
        push(@errmsg, sprintf("parsing failure - missing last %d results",
                              @part_list - $index));
      }
      !@errmsg  or die join(", ",@errmsg);
      # even though exit status 1 is accepted, log a warning nevertheless
      proc_status_ok($child_stat,$err)
        or do_log(-1, "file utility failed: %s",
                       exit_status_str($child_stat,$err));
    }
    1;
  } or do {
    $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
    kill_proc($pid,$file,1,$proc_fh,$eval_stat)  if defined $pid;
  };
  chdir($tempdir) or die "Can't chdir to $tempdir: $!";
  section_time(sprintf('get-file-type%d', $initial_num_parts));
  if (defined $eval_stat) {
    do_log(-2, "file(1) utility (%s) FAILED: %s", $file,$eval_stat);
  # die "file(1) utility ($file) error: $eval_stat";
  }
  1;
}

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

  my $hold; my(@parts); my $depth = 1;
  my($any_undecipherable, $any_encrypted, $over_levels) = (0,0,0);
  my $which_section = "parts_decode";
  # fetch all not-yet-visited part names, and start a new cycle
TIER:
  while (@parts = @{$file_generator_object->parts_list}) {
    if ($MAXLEVELS > 0 && $depth > $MAXLEVELS) {
      $over_levels = 1;
      $hold = "Maximum decoding depth ($MAXLEVELS) exceeded";
      last;
    }
    $file_generator_object->parts_list_reset;  # new cycle of names
    # clip to avoid very long log entries
    my(@chopped_parts) = @parts > 5 ? @parts[0..4] : @parts;
    ll(4) && do_log(4,"decode_parts: level=%d, #parts=%d : %s",
                     $depth, scalar(@parts),
                     join(', ', (map($_->base_name, @chopped_parts)),
                     (@chopped_parts >= @parts ? () : "...")) );
    for my $part (@parts) {  # test for existence of all expected files
      my $fname = $part->full_name;  my $errn = 0;
      if ($fname eq '') { $errn = ENOENT }
      else {
        my(@stat_list) = lstat($fname);
        if (@stat_list) { add_entropy(@stat_list) } else { $errn = 0+$! }
      }
      if ($errn == ENOENT) {
        $part->exists(0);
      # $part->type_short('no-file')  if !defined $part->type_short;
      } elsif ($errn) {
        die "decompose_mail: inaccessible file $fname: $!";
      } elsif (!-f _) {  # not a regular file
        my $what = -l _ ? 'symlink' : -d _ ? 'directory' : 'non-regular file';
        do_log(-1, "WARN: decompose_mail: removing unexpected %s %s",
                   $what,$fname);
        if (-d _) { rmdir_recursively($fname) }
        else { unlink($fname) or die "Can't delete $what $fname: $!" }
        $part->exists(0);
        $part->type_short(-l _ ? 'symlink' : -d _ ? 'dir' : 'special')
          if !defined $part->type_short;
      } elsif (-z _) {   # empty file
        unlink($fname) or die "Can't remove \"$fname\": $!";
        $part->exists(0);
        $part->type_short('empty')  if !defined $part->type_short;
        $part->type_long('empty')   if !defined $part->type_long;
      } else {
        $part->exists(1);
      }
    }
    if (!defined $file || $file eq '') {
      do_log(5,'utility file(1) not available, skipping determine_file_types');
    } else {
      determine_file_types($tempdir, \@parts);
    }
    for my $part (@parts) {
      if ($part->exists && !defined($hold)) {
        my($hold_tmp, $over_levels_tmp) = decompose_part($part, $tempdir);
        $hold = $hold_tmp if $hold_tmp;
        $over_levels ||= $over_levels_tmp;
      }
      my $attr = $part->attributes;
      if (defined $attr) {
        $any_undecipherable++  if index($attr, 'U') >= 0;
        $any_encrypted++       if index($attr, 'C') >= 0;
      }
    }
    last TIER  if defined $hold;
    $depth++;
  }
  section_time($which_section); prolong_timer($which_section);
  ($hold, $any_undecipherable, $any_encrypted, $over_levels);
}

# Decompose one part
#
sub decompose_part($$) {
  my($part, $tempdir) = @_;
  # possible return values from eval:
  # 0 - truly atomic or unknown or archiver failure; consider atomic
  # 1 - some archive, successfully unpacked, result replaces original
  # 2 - probably unpacked, but keep the original (eg self-extracting archive)
  my $hold; my $eval_stat; my($sts, $any_called, $over_levels) = (0,0,0);
  eval {
    my $type_short = $part->type_short;
    my(@ts) = !defined $type_short ? ()
                : !ref $type_short ? ($type_short) : @$type_short;
    if (@ts) {  # when one or more short types are known
      snmp_count("OpsDecType-".join('.',@ts));
      for my $dec_tuple (@{ca('decoders')}) {  # first matching decoder wins
        next  if !defined $dec_tuple;
        my($short_types, $code, @args) = @$dec_tuple;
        if ($code && grep(ref $short_types ? $short_types->{$_}
                                           : $_ eq $short_types, @ts)) {
          $any_called = 1; $sts = &$code($part,$tempdir,@args);
          last;
        }
      }
    }
    1;
  } or do {
    $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    my $ll = -1;
    if ($eval_stat =~ /\bExceeded storage quota\b.*\bbytes by/ ||
        $eval_stat =~ /\bMaximum number of files\b.*\bexceeded/) {
      $hold = $eval_stat; $ll = 1; $over_levels = 1;
    }
    do_log($ll,"Decoding of %s (%s) failed, leaving it unpacked: %s",
               $part->base_name, $part->type_long, $eval_stat);
    $sts = 2;  # keep the original, along with possible decoded files
  };
  if ($any_called) {
    chdir($tempdir) or die "Can't chdir to $tempdir: $!";  # just in case
  }
  if ($sts == 1 && lookup2(0,$part->type_long,\@keep_decoded_original_maps)) {
    # don't trust this file type or unpacker,
    # keep both the original and the unpacked file
    ll(4) && do_log(4,"file type is %s, retain original %s",
                      $part->type_long, $part->base_name);
    $sts = 2;  # keep the original, along with possible decoded files
  }
  if ($sts == 1) {
    ll(5) && do_log(5,"decompose_part: deleting %s", $part->full_name);
    unlink($part->full_name)
      or die sprintf("Can't unlink %s: %s", $part->full_name, $!);
  }
  ll(4) && do_log(4,"decompose_part: %s - %s", $part->base_name,
                    ['atomic','archive, unpacked','source retained']->[$sts]);
  section_time('decompose_part')  if $any_called;
  die $eval_stat  if $eval_stat =~ /^timed out\b/;  # resignal timeout
  ($hold, $over_levels);
}

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

#
# Uncompression/unarchiving routines
# Possible return codes:
# 0 - truly atomic or unknown or archiver failure; consider atomic
# 1 - some archiver format, successfully unpacked, result replaces original
# 2 - probably unpacked, but keep the original (eg self-extracting archive)

# if ASCII text, try multiple decoding methods as provided by UUlib
# (uuencoded, xxencoded, BinHex, yEnc, Base64, Quoted-Printable)
#
use vars qw($have_uulib_module);
sub do_ascii($$) {
  my($part, $tempdir) = @_;
  ll(4) && do_log(4,"do_ascii: Decoding part %s", $part->base_name);
  if (!defined $have_uulib_module) {
    eval {
      require Convert::UUlib && ($have_uulib_module = 1);
      # avoid an exploitable security hole in Convert::UUlib 1.04 and older
      Convert::UUlib->VERSION(1.05);  # 1.08 or newer is preferred!
      $have_uulib_module;
    } or do {
      $have_uulib_module = 0;
      chomp $@;  $@ =~ s/ \(you may need to install the .*\z//i;
      do_log(5,"do_ascii: module Convert::UULIB unavailable: %s", $@);
    };
  }
  return 0 if !$have_uulib_module;
  snmp_count('OpsDecByUUlibAttempt');

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

  alarm(0);  # stop the timer
  local($SIG{ALRM}); my($sigset,$action,$oldaction);
  if ($] < 5.008) {  # in old Perl signals could be delivered at any time
    $SIG{ALRM} = sub { die "timed out\n" };
  } elsif ($] < 5.008001) {  # Perl 5.8.0
    # 5.8.0 does not have POSIX::SigAction::safe but uses safe signals, which
    # means a runaway uulib can't be aborted; tough luck, upgrade your Perl!
    $SIG{ALRM} = sub { die "timed out\n" };  # old way, but won't abort
  } else {  # Perl >= 5.8.0 has 'safe signals', and SigAction::safe available
    # POSIX::sigaction can bypass safe Perl signals on request;
    # alternatively, use Perl module Sys::SigAction
    $sigset = POSIX::SigSet->new(SIGALRM); $oldaction = POSIX::SigAction->new;
    $action = POSIX::SigAction->new(sub { die "timed out\n" },
                                    $sigset, &POSIX::SA_RESETHAND);
    $action->safe(1);
    POSIX::sigaction(SIGALRM,$action,$oldaction)
      or die "Can't set ALRM handler: $!";
    do_log(4,"do_ascii: Setting sigaction handler, was %d", $oldaction->safe);
  }
  my $eval_stat;
  eval {  # must not go away without calling Convert::UUlib::CleanUp !
    my($sts,$count);
    prolong_timer('do_ascii_pre');  # restart timer
    $sts = Convert::UUlib::Initialize();
    $sts = 0  if !defined $sts; # avoid Use of uninit. value in numeric eq (==)
    $sts == Convert::UUlib::RET_OK()
      or die "Convert::UUlib::Initialize failed: ".
             Convert::UUlib::strerror($sts);
    my $uulib_version =
      Convert::UUlib::GetOption(Convert::UUlib::OPT_VERSION());
    !Convert::UUlib::SetOption(Convert::UUlib::OPT_IGNMODE(), 1)
      or die "bad uulib OPT_IGNMODE";
  # !Convert::UUlib::SetOption(Convert::UUlib::OPT_DESPERATE(), 1)
  #   or die "bad uulib OPT_DESPERATE";
    if (defined $action) {
      $action->safe(0);  # bypass safe Perl signals
      POSIX::sigaction(SIGALRM,$action) or die "Can't set ALRM handler: $!";
    }
    # may take looong time on malformed messages, allow it to be interrupted
    ($sts, $count) = Convert::UUlib::LoadFile($part->full_name);
    if (defined $action) {
      $action->safe(1);  # re-establish safe signal handling
      POSIX::sigaction(SIGALRM,$action) or die "Can't set ALRM handler: $!";
    }
    if ($sts != Convert::UUlib::RET_OK()) {
      my $errmsg = Convert::UUlib::strerror($sts) . ": $!";
      $errmsg .= ", (???"
        . Convert::UUlib::strerror(
            Convert::UUlib::GetOption(Convert::UUlib::OPT_ERRNO()))."???)"
        if $sts == Convert::UUlib::RET_IOERR();
      die "Convert::UUlib::LoadFile (uulib V$uulib_version) failed: $errmsg";
    }
    ll(4) && do_log(4,"do_ascii: Decoding part %s (%d items), uulib V%s",
                      $part->base_name, $count, $uulib_version);
    my $uu;
    my $item_num = 0; my $parent_placement = $part->mime_placement;
    for (my $j = 0; $uu = Convert::UUlib::GetFileListItem($j); $j++) {
      $item_num++;
      ll(4) && do_log(4,
                 "do_ascii(%d): state=0x%02x, enc=%s%s, est.size=%s, name=%s",
                  $j, $uu->state, Convert::UUlib::strencoding($uu->uudet),
                  ($uu->mimetype ne '' ? ", mimetype=" . $uu->mimetype : ''),
                  $uu->size, $uu->filename);
      if (!($uu->state & Convert::UUlib::FILE_OK())) {
        $any_errors = 1;
        do_log(1,"do_ascii: Convert::UUlib info: %s not decodable, %s",
                 $j,$uu->state);
      } else {
        my $newpart_obj = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
        $newpart_obj->mime_placement("$parent_placement/$item_num");
        $newpart_obj->name_declared($uu->filename);
        my $newpart = $newpart_obj->full_name;
        if (defined $action) {
          $action->safe(0);  # bypass safe Perl signals
          POSIX::sigaction(SIGALRM,$action) or die "Can't set ALRM handlr: $!";
        }
        $! = 0;
        $sts = $uu->decode($newpart);  # decode to file $newpart
        my $err_decode = "$!";
        if (defined $action) {
          $action->safe(1);  # re-establish safe signal handling
          POSIX::sigaction(SIGALRM,$action) or die "Can't set ALRM handlr: $!";
        }
        chmod(0750, $newpart) or $! == ENOENT  # chmod, don't panic if no file
          or die "Can't change protection of \"$newpart\": $!";
        my $statmsg;
        my $errn = lstat($newpart) ? 0 : 0+$!;
        if    ($errn == ENOENT) { $statmsg = "does not exist"   }
        elsif ($errn) { $statmsg = "inaccessible: $!" }
        elsif ( -l _) { $statmsg = "is a symlink"     }
        elsif ( -d _) { $statmsg = "is a directory"   }
        elsif (!-f _) { $statmsg = "not a regular file" }
        if (defined $statmsg) { $statmsg = "; file status: $newpart $statmsg" }
        my $size = 0 + (-s _);
        $newpart_obj->size($size);
        consumed_bytes($size, 'do_ascii');
        if ($sts == Convert::UUlib::RET_OK() && $errn==0) {
          $any_decoded = 1;
          do_log(4,"do_ascii: RET_OK%s", $statmsg)  if defined $statmsg;
        } elsif ($sts == Convert::UUlib::RET_NODATA() ||
                 $sts == Convert::UUlib::RET_NOEND()) {
          $any_errors = 1;
          do_log(-1,"do_ascii: Convert::UUlib error: %s%s",
                    Convert::UUlib::strerror($sts), $statmsg);
        } else {
          $any_errors = 1;
          my $errmsg = Convert::UUlib::strerror($sts) . ":: $err_decode";
          $errmsg .= ", " . Convert::UUlib::strerror(
                  Convert::UUlib::GetOption(Convert::UUlib::OPT_ERRNO()) )
            if $sts == Convert::UUlib::RET_IOERR();
          die("Convert::UUlib failed: " . $errmsg . $statmsg);
        }
      }
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_ascii');  # restart timer
  if (defined $oldaction) {
    POSIX::sigaction(SIGALRM,$oldaction)
      or die "Can't restore ALRM handler: $!";
  }
  Convert::UUlib::CleanUp();
  snmp_count('OpsDecByUUlib')  if $any_decoded;
  if (defined $old_env_tmpdir) { $ENV{TMPDIR} = $old_env_tmpdir }
  else { delete $ENV{TMPDIR} }
  if (defined $eval_stat) { chomp $eval_stat; die "do_ascii: $eval_stat\n" }
  $any_errors ? 2 : $any_decoded ? 1 : 0;
}

# use Archive-Zip
#
sub do_unzip($$;$$) {
  my($part, $tempdir, $archiver_dummy, $testing_for_sfx) = @_;
  ll(4) && do_log(4, "Unzipping %s", $part->base_name);
  # avoid DoS vulnerability in < 2.017, CVE-2009-1391
  # Compress::Raw::Zlib->VERSION(2.017);  # module not loaded
  snmp_count('OpsDecByArZipAttempt');
  my $zip = Archive::Zip->new;
  my(@err_nm) = qw(AZ_OK AZ_STREAM_END AZ_ERROR AZ_FORMAT_ERROR AZ_IO_ERROR);
  my $retval = 1;
  # need to set up a temporary minimal error handler
  Archive::Zip::setErrorHandler(sub { return 5 });
  my $sts = $zip->read($part->full_name);
  Archive::Zip::setErrorHandler(sub { die @_ });
  my($any_unsupp_compmeth,$any_zero_length);
  my($encryptedcount,$extractedcount) = (0,0);
  if ($sts != AZ_OK) {  # not a zip? corrupted zip file? other errors?
    if ($testing_for_sfx && $sts == AZ_FORMAT_ERROR) {
      # a normal status for executable that is not a self extracting archive
      do_log(4, "do_unzip: ok, exe is not a zip sfx: %s (%s)",
                $err_nm[$sts], $sts);
    } else {
      do_log(-1, "do_unzip: not a zip: %s (%s)", $err_nm[$sts], $sts);
#     $part->attributes_add('U');  # perhaps not, it flags as **UNCHECKED** too
#                                  # many bounces containing chopped-off zip
    }
    $retval = 0;
  } else {
    my $item_num = 0; my $parent_placement = $part->mime_placement;
    for my $mem ($zip->members) {
      my $newpart_obj = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
      $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num");
      $newpart_obj->name_declared($mem->fileName);
      my $compmeth = $mem->compressionMethod;
      if ($compmeth!=COMPRESSION_DEFLATED && $compmeth!=COMPRESSION_STORED) {
        $any_unsupp_compmeth = $compmeth;
        $newpart_obj->attributes_add('U');
      } elsif ($mem->isEncrypted) {
        $encryptedcount++;
        $newpart_obj->attributes_add('U','C');
      } elsif ($mem->isDirectory) {
        $newpart_obj->attributes_add('D');
      } else {
        # want to read uncompressed - set to COMPRESSION_STORED
        my $oldc = $mem->desiredCompressionMethod(COMPRESSION_STORED);
        $sts = $mem->rewindData;
        $sts == AZ_OK or die sprintf("%s: error rew. member data: %s (%s)",
                                     $part->base_name, $err_nm[$sts], $sts);
        my $newpart = $newpart_obj->full_name;
        my $outpart = IO::File->new;
        # 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 file $newpart: $!";
        binmode($outpart) or die "Can't set file $newpart to binmode: $!";
        my $size = 0;
        while ($sts == AZ_OK) {
          my $buf_ref;
          ($buf_ref, $sts) = $mem->readChunk;
          $sts == AZ_OK || $sts == AZ_STREAM_END
            or die sprintf("%s: error reading member: %s (%s)",
                           $part->base_name, $err_nm[$sts], $sts);
          my $buf_len = length($$buf_ref);
          if ($buf_len > 0) {
            $size += $buf_len;
            $outpart->print($$buf_ref) or die "Can't write to $newpart: $!";
            consumed_bytes($buf_len, 'do_unzip');
          }
        }
        $any_zero_length = 1  if $size == 0;
        $newpart_obj->size($size);
        $outpart->close or die "Error closing $newpart: $!";
        $mem->desiredCompressionMethod($oldc);
        $mem->endRead;
        $extractedcount++;
      }
    }
    snmp_count('OpsDecByArZip');
  }
  if ($any_unsupp_compmeth) {
    $retval = 2;
    do_log(-1, "do_unzip: %s, unsupported compression method: %s",
               $part->base_name, $any_unsupp_compmeth);
  } elsif ($any_zero_length) {  # possible zip vulnerability exploit
    $retval = 2;
    do_log(1, "do_unzip: %s, members of zero length, archive retained",
              $part->base_name);
  } elsif ($encryptedcount) {
    $retval = 2;
    do_log(1,
      "do_unzip: %s, %d members are encrypted, %s extracted, archive retained",
      $part->base_name, $encryptedcount,
      !$extractedcount ? 'none' : $extractedcount);
  }
  $retval;
}

# use external decompressor program from the compress/gzip/bzip2/xz/lz4 family
#
sub do_uncompress($$$) {
  my($part, $tempdir, $decompressor) = @_;
  ll(4) && do_log(4,"do_uncompress %s by %s", $part->base_name,$decompressor);
  my $decompressor_name = basename((split(' ',$decompressor))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  my $newpart_obj = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
  $newpart_obj->mime_placement($part->mime_placement."/1");
  my $newpart = $newpart_obj->full_name;
  my($type_short, $name_declared) = ($part->type_short, $part->name_declared);
  local($1);  my(@rn);  # collect recommended file names
  push(@rn,$1)
    if $part->type_long =~ /^\S+\s+compressed data, was "(.+)"(\z|, from\b)/;
  for my $name_d (!ref $name_declared ? ($name_declared) : @$name_declared) {
    next  if $name_d eq '';
    my $name = $name_d;
    for (!ref $type_short ? ($type_short) : @$type_short) {
      $_ eq 'F'    and $name=~s/\.F\z//;
      $_ eq 'Z'    and $name=~s/\.Z\z//    || $name=~s/\.tg?z\z/.tar/;
      $_ eq 'gz'   and $name=~s/\.gz\z//   || $name=~s/\.tgz\z/.tar/;
      $_ eq 'bz'   and $name=~s/\.bz\z//   || $name=~s/\.tbz\z/.tar/;
      $_ eq 'bz2'  and $name=~s/\.bz2?\z// || $name=~s/\.tbz2?\z/.tar/;
      $_ eq 'xz'   and $name=~s/\.xz\z//   || $name=~s/\.txz\z/.tar/;
      $_ eq 'lzma' and $name=~s/\.lzma\z// || $name=~s/\.tlz\z/.tar/;
      $_ eq 'lrz'  and $name=~s/\.lrz\z//;
      $_ eq 'lzo'  and $name=~s/\.lzo\z//;
      $_ eq 'lz4'  and $name=~s/\.lz4\z//;
      $_ eq 'rpm'  and $name=~s/\.rpm\z/.cpio/;
    }
    push(@rn,$name)  if !grep($_ eq $name, @rn);
  }
  $newpart_obj->name_declared(@rn==1 ? $rn[0] : \@rn)  if @rn;
  my($proc_fh,$pid); my $retval = 1;

  prolong_timer('do_uncompress_pre');  # restart timer
  my $eval_stat;
  eval {
    ($proc_fh,$pid) =
      run_command($part->full_name, '/dev/null', split(' ',$decompressor));
    my($rv,$err) = run_command_copy($newpart,$proc_fh,$pid);  # may die
    undef $proc_fh; undef $pid;
    if (!proc_status_ok($rv,$err)) {
#     unlink($newpart) or die "Can't unlink $newpart: $!";
      my $msg = sprintf('Error running decompressor %s on %s, %s',
                   $decompressor, $part->base_name, exit_status_str($rv,$err));
      # bzip2 and gzip use status 2 as a warning about corrupted file
      if (proc_status_ok($rv,$err, 2)) {do_log(0,"%s",$msg)} else {die $msg}
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_uncompress');  # restart timer
  if (defined $eval_stat) {
    $retval = 0; chomp $eval_stat;
    kill_proc($pid,$decompressor,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
    die "do_uncompress: $eval_stat\n";  # propagate failure
  }
  $retval;
}

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

# DROPED SUPPORT for Archive::Tar; main drawback of this module is: it either
# loads an entire tar into memory (horrors!), or when using extract_archive()
# it does not relativize absolute paths (which makes it possible to store
# members in any directory writable by uid), and does not provide a way to
# capture contents of members with the same name. Use pax program instead!
#
#use Archive::Tar;
#sub do_tar($$) {
# my($part, $tempdir) = @_;
# snmp_count('OpsDecByArTar');
# # Work around bug in Archive-Tar
# my $tar = eval { Archive::Tar->new($part->full_name) };
# if (!defined($tar)) {
#   chomp $@;
#   do_log(4, "Faulty archive %s: %s", $part->full_name, $@);
#   die $@  if $@ =~ /^timed out\b/;  # resignal timeout
#   return 0;
# }
# do_log(4,"Untarring %s", $part->base_name);
# my $item_num = 0; my $parent_placement = $part->mime_placement;
# my(@list) = $tar->list_files;
# for (@list) {
#   next  if m{/\z};  # ignore directories
#     # this is bad (reads whole file into scalar)
#     # need some error handling, too
#   my $data = $tar->get_content($_);
#   my $newpart_obj = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
#   $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num");
#   my $newpart = $newpart_obj->full_name;
#   my $outpart = IO::File->new;
#   # 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 file $newpart: $!";
#   binmode($outpart) or die "Can't set file $newpart to binmode: $!";
#   $outpart->print($data) or die "Can't write to $newpart: $!";
#   $newpart_obj->size(length($data));
#   consumed_bytes(length($data), 'do_tar');
#   $outpart->close or die "Error closing $newpart: $!";
# }
# 1;
#}

# use external program to expand 7-Zip archives
#
sub do_7zip($$$;$) {
  my($part, $tempdir, $archiver, $testing_for_sfx) = @_;
  ll(4) && do_log(4, "Expanding 7-Zip archive %s", $part->base_name);
  my $decompressor_name = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}Attempt");
  my $last_line; my $any_encrypted; my $bytes = 0; my $mem_cnt = 0;
  my $retval = 1; my($proc_fh,$pid); my $fn = $part->full_name;
  prolong_timer('do_7zip_pre');  # restart timer
  my $eval_stat;
  eval {
    ($proc_fh,$pid) = run_command(undef, '&1', $archiver,
                                  'l', '-slt', "-w$tempdir/parts", '--', $fn);
    my @list;
    my $ln; my($name,$size,$attr,$enc); my $entries_cnt = 0;
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      $last_line = $ln  if $ln =~ /\S/;  # keep last nonempty line
      chomp($ln); local($1);
      if ($ln !~ /\S/) {  # empty line separates members
	if (defined $attr && $attr =~ /^D/) {
          do_log(5,'do_7zip: member: %s "%s", (skipped directory)',
                 $attr,$name);
	} elsif (defined $enc && defined $name) {
          do_log(5,'do_7zip: member: %s "%s", %s bytes (skipped encrypted)',
                 $attr,$name,$size);
          # make a phantom entry - carrying only name and attributes
          my $parent_placement = $part->mime_placement;
          my $newpart_obj =
            Amavis::Unpackers::Part->new("$tempdir/parts",$part);
          $newpart_obj->mime_placement("$parent_placement/$entries_cnt");
          $newpart_obj->name_declared($name);
          $newpart_obj->attributes_add('U','C');
	} elsif (defined $name || defined $size) {
          do_log(5,'do_7zip: member: %s "%s", %s bytes',
                 $attr, $name, defined $size ? $size : '?');
          if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES) {
            die "Maximum number of files ($MAXFILES) exceeded";
          }
          if (defined $size && $size > 0) {
            push(@list, untaint($name));
            $bytes += $size; $mem_cnt++;
	  }
        }
        undef $name; undef $size; undef $attr; undef $enc;
      }
      elsif ($ln =~ /^Path = (.*)\z/s)       { $name = $1 }
      elsif ($ln =~ /^Size = ([0-9]+)\z/s)   { $size = $1 }
      elsif ($ln =~ /^Attributes = (.*)\z/s) { $attr = $1 }
      elsif ($ln =~ /^Encrypted = \+\z/s)    { $enc = $any_encrypted = 1 }
      elsif ($ln =~ /^ERROR:.* Can not open encrypted archive\. Wrong password\?\z/s) {
        do_log(5,'do_7zip: archive is encrypted');
        $part->attributes_add('U','C');
      }
    }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading (1): $!";
    do_log(-1,"unexpected(do_7zip_1): %s",$!) if !defined($ln) && $! == EAGAIN;
    if (defined $name || defined $size) {
      do_log(5,'do_7zip: member: %s "%s", %s bytes', $attr,$name,$size);
      if (defined $size && $size > 0) { $bytes += $size; $mem_cnt++ }
    }
    # consume all remaining output to avoid broken pipe
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      $last_line = $ln  if $ln =~ /\S/;
    }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading (2): $!";
    do_log(-1,"unexpected(do_7zip_2): %s",$!)  if !defined($ln) && $! == EAGAIN;
    my $err = 0; $proc_fh->close or $err = $!;
    my $rv = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;  local($1,$2);
    if (proc_status_ok($rv,$err,1) && $mem_cnt > 0 && $bytes > 0) { # just warn
      do_log(4,"do_7zip: warning, %s", exit_status_str($rv,$err));
    } elsif (!proc_status_ok($rv,$err)) {
      die sprintf("can't get a list of archive members: %s; %s",
                  exit_status_str($rv,$err), $last_line);
    }
    if ($mem_cnt > 0 || $bytes > 0) {
      consumed_bytes($bytes, 'do_7zip-pre', 1);  # pre-check on estimated size
      snmp_count("OpsDecBy\u${decompressor_name}");
      if (!$any_encrypted) {
        # supplying an empty list extracts all files, avoids exceeding the
        # argv size limit as there is no need to exclude excrypted members
        # (which would result in 7z returning a nonzero status)
        @list = ();
      }
      ($proc_fh,$pid) = run_command(undef, '&1', $archiver, 'x', '-bd', '-y',
                          "-w$tempdir/parts", "-o$tempdir/parts/7zip", '--',
                          $fn, @list);
      collect_results($proc_fh,$pid,$archiver,16384,[0,1]);
      undef $proc_fh; undef $pid;
      my $errn = lstat("$tempdir/parts/7zip") ? 0 : 0+$!;
      if ($errn != ENOENT) {
        my $b = flatten_and_tidy_dir("$tempdir/parts/7zip",
                                     "$tempdir/parts", $part);
        consumed_bytes($b, 'do_7zip');
      }
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_7zip');  # restart timer
  if (defined $eval_stat) {
    $retval = 0; chomp $eval_stat;
    kill_proc($pid,$archiver,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
  # if ($testing_for_sfx) { die "do_7zip: $eval_stat" }
  # else { do_log(-1, "do_7zip: %s", $eval_stat) };
    die "do_7zip: $eval_stat\n"  # propagate failure
  }
  $retval;
}

# use external program to expand RAR archives
#
sub do_unrar($$$;$) {
  my($part, $tempdir, $archiver, $testing_for_sfx) = @_;
  ll(4) && do_log(4, "Expanding RAR archive %s", $part->base_name);
  my $decompressor_name = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}Attempt");
  # unrar exit codes: SUCCESS=0, WARNING=1, FATAL_ERROR=2, CRC_ERROR=3,
  #   LOCK_ERROR=4, WRITE_ERROR=5, OPEN_ERROR=6, USER_ERROR=7, MEMORY_ERROR=8,
  #   CREATE_ERROR=9, USER_BREAK=255
  my(@list); my $hypcount = 0; my $encryptedcount = 0;
  my $lcnt = 0; my $member_name; my $bytes = 0; my $last_line;
  my $item_num = 0; my $parent_placement = $part->mime_placement;
  my $retval = 1; my $fn = $part->full_name; my($proc_fh,$pid);
  my $unrarvers = 5;
  my(@common_rar_switches) = qw(-c- -p- -idcdp);  # -av-

  prolong_timer('do_unrar_pre');  # restart timer
  my $eval_stat;
  eval {
    ($proc_fh,$pid) =
      run_command(undef, '&1', $archiver, 'v',@common_rar_switches,'--',$fn);
    # jump hoops because there is no simple way to just list all the files
    my $ln; my $entries_cnt = 0;
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      $last_line = $ln  if $ln !~ /^\s*$/;  # keep last nonempty line
      chomp;
      if ($ln =~ /^unexpected end of archive/) {
        last;
      } elsif ($ln =~ /^------/) {
        $hypcount++;
        last  if $hypcount >= 2;
      } elsif ($hypcount < 1 && $ln =~ /^Encrypted file:/) {
        do_log(4,"do_unrar: %s", $ln);
        $part->attributes_add('U','C');
      } elsif ($hypcount < 1 &&
               $ln =~ /^\s+Size\s+Packed Ratio\s+Date\s+Time\s+Attr\s+CRC/) {
        do_log(5,"do_unrar: found unrar version < 5");
        $unrarvers = 4;
      } elsif ($hypcount == 1) {
        if ($unrarvers >= 5) {
          local($1,$2,$3,$4,$5);
          if ($ln !~ /^ ([* ]) \s+ \S+ \s+ (\d+) \s+ (\d+) \s+
                      ( \d+ % | --> | <-- | <-> ) \s+
                      \S+ \s+ \S+ \s+ \S+ \s+ (.*)/xs) {
            do_log($testing_for_sfx ? 4 : -1,
                   "do_unrar: can't parse info line for \"%s\" %s",
                   $member_name,$ln);
          } else {
            $member_name = $5;
            if ($1 eq '*') {   # member is encrypted
              $encryptedcount++; $item_num++;
              # make a phantom entry - carrying only name and attributes
              my $newpart_obj =
                Amavis::Unpackers::Part->new("$tempdir/parts",$part);
              $newpart_obj->mime_placement("$parent_placement/$item_num");
              $newpart_obj->name_declared($member_name);
              $newpart_obj->attributes_add('U','C');
            } else {  # makes no sense extracting encrypted files
              do_log(5,'do_unrar: member: "%s", size: %s', $member_name,$2);
              if ($2 > 0) { $bytes += $2; push(@list, $member_name) }
            }
            undef $member_name;
          }
        } else {  # old version of unrar
          $lcnt++; local($1,$2,$3);
          if ($lcnt % 2 == 0) {  # information line (every other line)
            if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES)
              { die "Maximum number of files ($MAXFILES) exceeded" }
            if ($ln !~ /^ \s+ (\d+) \s+ (\d+) \s+
                        ( \d+% | --> | <-- | <-> )/xs) {
              do_log($testing_for_sfx ? 4 : -1,
                     "do_unrar: can't parse info line for \"%s\" %s",
                     $member_name,$ln);
            } elsif (defined $member_name) {
              do_log(5,'do_unrar: member: "%s", size: %s', $member_name,$1);
              if ($1 > 0) { $bytes += $1; push(@list, $member_name) }
            }
            undef $member_name;
          } elsif ($ln =~ /^(.)(.*)\z/s) {
            $member_name = $2; # all but the first character (space or '*')
            if ($1 eq '*') {   # member is encrypted
              $encryptedcount++; $item_num++;
              # make a phantom entry - carrying only name and attributes
              my $newpart_obj =
                Amavis::Unpackers::Part->new("$tempdir/parts",$part);
              $newpart_obj->mime_placement("$parent_placement/$item_num");
              $newpart_obj->name_declared($member_name);
              $newpart_obj->attributes_add('U','C');
              undef $member_name;  # makes no sense extracting encrypted files
            }
          }
        }
      }
    }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading (1): $!";
    do_log(-1,"unexpected(unrar_1): %s",$!)  if !defined($ln) && $! == EAGAIN;
    $ln = undef;  # consume all remaining output to avoid broken pipe
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0)
      { $last_line = $ln  if $ln !~ /^\s*$/ }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading (2): $!";
    do_log(-1,"unexpected(unrar_2): %s",$!)  if !defined($ln) && $! == EAGAIN;
    my $err = 0; $proc_fh->close or $err = $!;
    my $rv = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;  local($1,$2);
    if (proc_status_ok($rv,$err, 7)) {       # USER_ERROR
      die printf("perhaps this %s does not recognize switches ".
                 "-av- and -idcdp, it is probably too old. Upgrade: %s",
                 $archiver, 'http://www.rarlab.com/');
    } elsif (proc_status_ok($rv,$err, 3)) {  # CRC_ERROR
      # NOTE: password protected files in the archive cause CRC_ERROR
      do_log(4,"do_unrar: CRC_ERROR - undecipherable, %s",
               exit_status_str($rv,$err));
      $part->attributes_add('U');
    } elsif (proc_status_ok($rv,$err, 1) && @list && $bytes > 0) {
                                             # WARNING, probably still ok
      do_log(4,"do_unrar: warning, %s", exit_status_str($rv,$err));
    } elsif (!proc_status_ok($rv,$err)) {
      die("can't get a list of archive members: " .
          exit_status_str($rv,$err) ."; ".$last_line);
    } elsif (!$bytes && $last_line =~ /^\Q$fn\E is not RAR archive$/) {
      chomp($last_line);  die $last_line;
    } elsif ($last_line !~ /^\s*(\d+)\s+(\d+)/s) {
      do_log(-1,"do_unrar: unable to obtain orig total size: %s", $last_line);
    } else {
      do_log(4,"do_unrar: summary size: %d, sum of sizes: %d",
             $2,$bytes)  if abs($bytes - $2) > 100;
      $bytes = $2  if $2 > $bytes;
    }
    consumed_bytes($bytes, 'do_unrar-pre', 1);  # pre-check on estimated size
    if (!@list) {
      do_log(4,"do_unrar: no archive members, or not an archive at all");
      if ($testing_for_sfx) { return 0 } else { $part->attributes_add('U') }
    } else {
      snmp_count("OpsDecBy\u${decompressor_name}");
      # unrar/rar can make a dir by itself, but can't hurt (sparc64 problem?)
      mkdir("$tempdir/parts/rar", 0750)
        or die "Can't mkdir $tempdir/parts/rar: $!";
      ($proc_fh,$pid) =
        run_command(undef, '&1', $archiver, qw(x -inul -ver -o- -kb),
                    @common_rar_switches, '--', $fn, "$tempdir/parts/rar/");
      collect_results($proc_fh,$pid,$archiver,16384,
                      [0,1,3] );  # one of: SUCCESS, WARNING, CRC
      undef $proc_fh; undef $pid;
      my $errn = lstat("$tempdir/parts/rar") ? 0 : 0+$!;
      if ($errn != ENOENT) {
        my $b = flatten_and_tidy_dir("$tempdir/parts/rar",
                                     "$tempdir/parts", $part);
        consumed_bytes($b, 'do_unrar');
      }
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_unrar');  # restart timer
  if ($encryptedcount) {
    do_log(1,
      "do_unrar: %s, %d members are encrypted, %s extracted, archive retained",
      $part->base_name, $encryptedcount, !@list ? 'none' : scalar(@list) );
    $retval = 2;
  }
  if (defined $eval_stat) {
    $retval = 0; chomp $eval_stat;
    kill_proc($pid,$archiver,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
  # if ($testing_for_sfx) { die "do_unrar: $eval_stat" }
  # else { do_log(-1, "do_unrar: %s", $eval_stat) };
    die "do_unrar: $eval_stat\n"  # propagate failure
  }
  $retval;
}

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

  prolong_timer('do_lha_pre');  # restart timer
  my $eval_stat;
  eval {
  # ($proc_fh,$pid) = run_command(undef, '&1', $archiver, 'lq', $fn);
    ($proc_fh,$pid) = run_command(undef, '&1', $archiver, 'lq', $fn.".exe");
    my $ln; my $entries_cnt = 0;
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      chomp($ln); local($1);
      if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES)
        { die "Maximum number of files ($MAXFILES) exceeded" }
      if ($ln =~ m{/\z}) {
        # ignore directories
      } elsif ($ln =~ /^LHa: (Warning|Fatal error): /) {
        push(@checkerr,$ln)  if @checkerr < 3;
      } elsif ($ln=~m{^(?:\S+\s+\d+/\d+|.{23})(?:\s+\S+){5}\s*(\S.*?)\s*\z}s) {
        my $name = $1; $name = $1 if $name =~ m{^(.*) -> (.*)\z}s;  # symlink
        push(@list, $name);
      } else { do_log(5,"do_lha: skip: %s", $ln) }
    }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading: $!";
    do_log(-1,"unexpected(do_lha): %s",$!)  if !defined($ln) && $! == EAGAIN;
    my $err = 0; $proc_fh->close or $err = $!;
    my $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;
    if (!proc_status_ok($child_stat,$err) || @checkerr) {
      die('(' . join(", ",@checkerr) .') ' .exit_status_str($child_stat,$err));
    } elsif (!@list) {
      $part->attributes_add('U')  if !$testing_for_sfx;
      die "no archive members, or not an archive at all";
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_lha');  # restart timer
  if (defined $eval_stat) {
    unlink($fn.".exe") or do_log(-1, "Can't unlink %s.exe: %s", $fn,$!);
    $retval = 0; chomp $eval_stat;
    kill_proc($pid,$archiver,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
  # if ($testing_for_sfx) { die "do_lha: $eval_stat" }
  # else { do_log(-1, "do_lha: %s", $eval_stat) };
    die "do_lha: $eval_stat\n";  # propagate failure
  } else {  # preliminary archive traversal done, now extract files
    snmp_count("OpsDecBy\u${decompressor_name}");
    my $rv;
    eval {
      # store_mgr may die, make sure we unlink the .exe file
      $rv = store_mgr($tempdir, $part, \@list, $archiver, 'pq', $fn.".exe");
      1;
    } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
    unlink($fn.".exe") or do_log(-1, "Can't unlink %s.exe: %s", $fn,$!);
    if (defined $eval_stat) { die "do_lha: $eval_stat\n" } # propagate failure
    $rv==0  or die exit_status_str($rv);
  }
  $retval;
}

# use external program to expand ARC archives;
# works with original arc, or a GPL licensed 'nomarch'
# (http://rus.members.beeb.net/nomarch.html)
#
sub do_arc($$$) {
  my($part, $tempdir, $archiver) = @_;
  my $decompressor_name = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");
  my $is_nomarch = $archiver =~ /nomarch/i;
  ll(4) && do_log(4,"Unarcing %s, using %s",
                    $part->base_name, ($is_nomarch ? "nomarch" : "arc") );
  my $cmdargs = ($is_nomarch ? '-l -U' : 'ln') . ' ' . $part->full_name;
  my($proc_fh,$pid) = run_command(undef, '/dev/null', $archiver,
                                  split(' ',$cmdargs));
  my(@list); my $ln; my $entries_cnt = 0;
  for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
    if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES)
      { die "Maximum number of files ($MAXFILES) exceeded" }
    push(@list,$ln);
  }
  defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading: $!";
  do_log(-1,"unexpected(do_arc): %s",$!)  if !defined($ln) && $! == EAGAIN;
  my $err = 0; $proc_fh->close or $err = $!;
  my $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
  undef $proc_fh; undef $pid;
  proc_status_ok($child_stat,$err)
    or do_log(-1, 'do_arc: %s',exit_status_str($child_stat,$err));
  #*** no spaces in filenames allowed???
  local($1);  s/^([^ \t\r\n]*).*\z/$1/s for @list;  # keep only filenames
  if (@list) {
    # store_mgr may die, allow failure to propagate
    my $rv = store_mgr($tempdir, $part, \@list, $archiver,
                       ($is_nomarch ? ('-p', '-U') : 'p'), $part->full_name);
    do_log(-1, 'arc %', exit_status_str($rv))  if $rv;
  }
  1;
}

# use external program to expand ZOO archives
#
sub do_zoo($$$) {
  my($part, $tempdir, $archiver) = @_;
  my $is_unzoo = $archiver =~ m{\bunzoo[^/]*\z}i ? 1 : 0;
  ll(4) && do_log(4,"Expanding ZOO archive %s, using %s",
                    $part->base_name, ($is_unzoo ? "unzoo" : "zoo") );
  my $decompressor_name = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}");

  my(@list); my $separ_count = 0; my $bytes = 0; my($ln,$last_line);
  my $retval = 1; my $fn = $part->full_name; my($proc_fh,$pid);
  symlink($fn, "$fn.zoo")  # Zoo needs extension of .zoo!
    or die sprintf("Can't symlink %s %s.zoo: %s", $fn,$fn,$!);

  prolong_timer('do_zoo_pre');  # restart timer
  my $eval_stat; my $entries_cnt = 0;
  eval {
    ($proc_fh,$pid) = run_command(undef, '&1', $archiver,
                                  $is_unzoo ? qw(-l) : qw(l), "$fn.zoo");
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      $last_line = $ln  if $ln !~ /^\s*$/;  # keep last nonempty line
      if ($ln =~ /^------/) { $separ_count++ }
      elsif ($separ_count == 1) {
        local($1,$2);
        if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES)
          { die "Maximum number of files ($MAXFILES) exceeded" }
        if ($ln !~ /^\s*(\d+)(?:\s+\S+){6}\s+(?:[0-7]{3,})?\s*(.*)$/) {
          do_log(3,"do_zoo: can't parse line %s", $ln);
        } else {
          do_log(5,'do_zoo: member: "%s", size: %s', $2,$1);
          if ($1 > 0) { $bytes += $1; push(@list,$2) }
        }
      }
    }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading: $!";
    do_log(-1,"unexpected(do_zoo): %s",$!)  if !defined($ln) && $! == EAGAIN;
    my $err = 0; $proc_fh->close or $err = $!;
    my $rv = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;  local($1);
    if (!proc_status_ok($rv,$err)) {
      die("can't get a list of archive members: " .
          exit_status_str($rv,$err) ."; ".$last_line);
    } elsif ($last_line !~ /^\s*(\d+)\s+\d+%\s+\d+/s) {
      do_log(-1,"do_zoo: unable to obtain orig total size: %s", $last_line);
    } else {
      do_log(4,"do_zoo: summary size: %d, sum of sizes: %d",
             $1,$bytes)  if abs($bytes - $1) > 100;
      $bytes = $1  if $1 > $bytes;
    }
    consumed_bytes($bytes, 'do_zoo-pre', 1);  # pre-check on estimated size
    $retval = 0  if @list;
    if (!$is_unzoo) {
      # unzoo cannot cleanly extract to stdout without prepending a clutter
      # store_mgr may die
      my $rv = store_mgr($tempdir,$part,\@list,$archiver,'xpqqq:',"$fn.zoo");
      do_log(-1,"do_zoo (store_mgr) %s", exit_status_str($rv))  if $rv;
    } else {  # this code section can handle zoo and unzoo
      # but zoo is unsafe in this mode (and so is unzoo, a little less so)
      my $cwd = "$tempdir/parts/zoo";
      mkdir($cwd, 0750) or die "Can't mkdir $cwd: $!";
      chdir($cwd) or die "Can't chdir to $cwd: $!";
      # don't use "-j ./" in unzoo, it does not protect from relative paths!
      # "-j X" is less bad, but: "unzoo: 'X/h/user/01.lis' cannot be created"
      ($proc_fh,$pid) =
        run_command(undef, '&1', $archiver,
                    $is_unzoo ? qw(-x -j X) : qw(x),
                    "$fn.zoo",  $is_unzoo ? '*;*' : () );
      collect_results($proc_fh,$pid,$archiver,16384,[0]);
      undef $proc_fh; undef $pid;
      my $b = flatten_and_tidy_dir("$tempdir/parts/zoo",
                                   "$tempdir/parts", $part);
      consumed_bytes($b, 'do_zoo');
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_zoo');  # restart timer
  if (defined $eval_stat) {
    $retval = 0; chomp $eval_stat;
    kill_proc($pid,$archiver,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
    do_log(-1,"do_zoo: %s", $eval_stat);
  }
  chdir($tempdir) or die "Can't chdir to $tempdir: $!";
  unlink("$fn.zoo") or die "Can't unlink $fn.zoo: $!";
  if (defined $eval_stat) { die "do_zoo: $eval_stat\n" }  # propagate failure
  $retval;
}

# use external program to expand ARJ archives
#
sub do_unarj($$$;$) {
  my($part, $tempdir, $archiver, $testing_for_sfx) = @_;
  do_log(4, "Expanding ARJ archive %s", $part->base_name);
  my $decompressor_name = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${decompressor_name}Attempt");
  # options to arj, ignored by unarj
  # provide some password in -g to turn fatal error into 'bad password' error
  $ENV{ARJ_SW} = "-i -jo -b5 -2h -jyc -ja1 -gsecret -w$tempdir/parts";
  # unarj needs extension of .arj!
  my $fn = $part->full_name;
  symlink($part->full_name, $fn.".arj")
    or die sprintf("Can't symlink %s %s.arj: %s", $fn, $fn, $!);
  my $retval = 1; my($proc_fh,$pid);

  prolong_timer('do_unarj_pre');  # restart timer
  my $eval_stat;
  eval {
    # obtain total original size of archive members from the index/listing
    ($proc_fh,$pid) = run_command(undef, '&1', $archiver, 'l', $fn.".arj");
    my $last_line; my $ln;
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0)
      { $last_line = $ln  if $ln !~ /^\s*$/ }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading (1): $!";
    do_log(-1,"unexpected(do_unarj_1): %s",$!) if !defined($ln) && $! == EAGAIN;
    my $err = 0; $proc_fh->close or $err = $!;
    my $rv = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;
    if (!proc_status_ok($rv,$err, 0,1,3)) {  # one of: success, warn, CRC err
      $part->attributes_add('U')  if !$testing_for_sfx;
      die "not an ARJ archive? ".exit_status_str($rv,$err);
    } elsif ($last_line =~ /^\Q$fn\E.arj is not an ARJ archive$/) {
      die "last line: $last_line";
    } elsif ($last_line !~ /^\s*(\d+)\s*files\s*(\d+)/s) {
      $part->attributes_add('U')  if !$testing_for_sfx;
      die "unable to obtain orig size of files: $last_line, ".
          exit_status_str($rv,$err);
    } else {
      consumed_bytes($2, 'do_unarj-pre', 1); # pre-check on estimated size
    }
    # unarj has very limited extraction options, arj is much better!
    mkdir("$tempdir/parts/arj",0750)
      or die "Can't mkdir $tempdir/parts/arj: $!";
    chdir("$tempdir/parts/arj")
      or die "Can't chdir to $tempdir/parts/arj: $!";
    snmp_count("OpsDecBy\u${decompressor_name}");
    ($proc_fh,$pid) = run_command(undef, '&1', $archiver, 'e', $fn.".arj");
    my($encryptedcount,$skippedcount,$entries_cnt) = (0,0,0);
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES)
        { die "Maximum number of files ($MAXFILES) exceeded" }
      $encryptedcount++
        if $ln =~ /^(Extracting.*\bBad file data or bad password|File is password encrypted, Skipped)\b/s;
      $skippedcount++
        if $ln =~ /(\bexists|^File is password encrypted|^Unsupported .*), Skipped\b/s;
    }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading (2): $!";
    do_log(-1,"unexpected(do_unarj_2): %s",$!) if !defined($ln) && $! == EAGAIN;
    $err = 0; $proc_fh->close or $err = $!;
    $rv = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid;
    chdir($tempdir) or die "Can't chdir to $tempdir: $!";
    if (proc_status_ok($rv,$err, 0,1)) {}  # success, warn
    elsif (proc_status_ok($rv,$err, 3))    # CRC err
      { $part->attributes_add('U')  if !$testing_for_sfx }
    else { do_log(0, "unarj: error extracting: %s",exit_status_str($rv,$err)) }
    # add attributes to the parent object, because we didn't remember names
    # of its scrambled members
    $part->attributes_add('U')  if $encryptedcount || $skippedcount;
    $part->attributes_add('C')  if $encryptedcount;
    my $errn = lstat("$tempdir/parts/arj") ? 0 : 0+$!;
    if ($errn != ENOENT) {
      my $b = flatten_and_tidy_dir("$tempdir/parts/arj",
                                   "$tempdir/parts",$part);
      consumed_bytes($b, 'do_unarj');
      snmp_count("OpsDecBy\u${decompressor_name}");
    }
    proc_status_ok($rv,$err, 0,1,3)  # one of: success, warn, CRC err
      or die "unarj: can't extract archive members: ".
             exit_status_str($rv,$err);
    if ($encryptedcount || $skippedcount) {
      do_log(1,
        "do_unarj: %s, %d members are encrypted, %d skipped, archive retained",
        $part->base_name, $encryptedcount, $skippedcount);
      $retval = 2;
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_unarj');  # restart timer
  unlink($fn.".arj") or die "Can't unlink $fn.arj: $!";
  if (defined $eval_stat) {
    $retval = 0; chomp $eval_stat;
    kill_proc($pid,$archiver,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
  # if ($testing_for_sfx) { die "do_unarj: $eval_stat" }
  # else { do_log(-1, "do_unarj: %s", $eval_stat) };
    die "do_unarj: $eval_stat\n"  # propagate failure
  }
  $retval;
}

# use external program to expand TNEF archives
#
sub do_tnef_ext($$$) {
  my($part, $tempdir, $archiver) = @_;
  do_log(4, "Extracting from TNEF encapsulation (ext) %s", $part->base_name);
  my $archiver_name = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${archiver_name}");
  mkdir("$tempdir/parts/tnef",0750)
    or die "Can't mkdir $tempdir/parts/tnef: $!";
  my $retval = 1; my($proc_fh,$pid);

  prolong_timer('do_tnef_ext_pre');  # restart timer
  my $rem_quota = max(10*1024, untaint(consumed_bytes(0,'do_tnef_ext')));
  my $eval_stat;
  eval {
    ($proc_fh,$pid) = run_command(undef, '&1', $archiver,
                          '--number-backups', '-x', "$rem_quota",
                          '-C', "$tempdir/parts/tnef", '-f', $part->full_name);
    collect_results($proc_fh,$pid,$archiver,16384,[0]);
    undef $proc_fh; undef $pid;  1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_tnef_ext');  # restart timer
  if (defined $eval_stat) {
    $retval = 0; chomp $eval_stat;
    do_log(-1, "tnef_ext: %s", $eval_stat);
  }
  my $b = flatten_and_tidy_dir("$tempdir/parts/tnef","$tempdir/parts",$part);
  if ($b > 0) {
    do_log(4, "tnef_ext extracted %d bytes from a tnef container", $b);
    consumed_bytes($b, 'do_tnef_ext');
  }
  if (defined $eval_stat) { die "do_tnef_ext: $eval_stat\n" }  # propagate
  $retval;
}

# use Convert-TNEF
#
use vars qw($have_tnef_module);
sub do_tnef($$) {
  my($part, $tempdir) = @_;
  do_log(4, "Extracting from TNEF encapsulation (int) %s", $part->base_name);
  if (!defined $have_tnef_module) {
    eval {
      require Convert::TNEF && ($have_tnef_module = 1);
    } or do {
      $have_tnef_module = 0;
      chomp $@;  $@ =~ s/ \(you may need to install the .*\z//i;
      do_log(5,"module Convert::TNEF unavailable: %s", $@);
    };
  }
  return 0 if !$have_tnef_module;
  snmp_count('OpsDecByTnef');

  my $tnef = Convert::TNEF->read_in($part->full_name,
       {output_dir=>"$tempdir/parts", buffer_size=>16384, ignore_checksum=>1});
  defined $tnef or die "Convert::TNEF failed: ".$Convert::TNEF::errstr;
  my $item_num = 0; my $parent_placement = $part->mime_placement;
  for my $a ($tnef->message, $tnef->attachments) {
    for my $attr_name ('AttachData','Attachment') {
      my $dh = $a->datahandle($attr_name);
      if (defined $dh) {
        my $newpart_obj = Amavis::Unpackers::Part->new("$tempdir/parts",$part);
        $item_num++;
        $newpart_obj->mime_placement("$parent_placement/$item_num");
        $newpart_obj->name_declared([$a->name, $a->longname]);
        my $newpart = $newpart_obj->full_name;
        my $outpart = IO::File->new;
        # 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 file $newpart: $!";
        binmode($outpart) or die "Can't set file $newpart to binmode: $!";
        my $filepath = $dh->path; my $size = 0;
        if (defined $filepath) {
          my($io,$nbytes,$buff); $dh->binmode(1);
          $io = $dh->open("r") or die "Can't open MIME::Body handle: $!";
          while (($nbytes=$io->read($buff,16384)) > 0) {
            $outpart->print($buff) or die "Can't write to $newpart: $!";
            $size += $nbytes; consumed_bytes($nbytes, 'do_tnef_1');
          }
          defined $nbytes or die "Error reading from MIME::Body handle: $!";
          $io->close or die "Error closing MIME::Body handle: $!";
          undef $buff;  # release storage
        } else {
          my $buff = $dh->as_string; my $nbytes = length($buff);
          $outpart->print($buff) or die "Can't write to $newpart: $!";
          $size += $nbytes; consumed_bytes($nbytes, 'do_tnef_2');
        }
        $newpart_obj->size($size);
        $outpart->close or die "Error closing $newpart: $!";
      }
    }
  }
  $tnef->purge  if defined $tnef;
  1;
}

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

  prolong_timer('do_pax_cpio_pre');  # restart timer
  my $eval_stat;
  eval {
    chdir("$tempdir/parts/arch")
      or die "Can't chdir to $tempdir/parts/arch: $!";
    my(@cmdargs) = $is_pax ? qw(-r -k -p am -s /[^A-Za-z0-9_]/-/gp)
                       : qw(-i -d --no-absolute-filenames --no-preserve-owner);
    ($proc_fh,$pid) = run_command($part->full_name, '&1', $archiver, @cmdargs);
    my $output = ''; my $ln; my $entries_cnt = 0;
    for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
      chomp($ln);
      if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES)
        { die "Maximum number of files ($MAXFILES) exceeded" }
      if (!$is_pax || $ln !~ /^(.*) >> (\S*)\z/) { $output .= $ln."\n" }
      else {  # parse output from pax -s///p
        my($member_name,$file_name) = ($1,$2);
        if (!exists $orig_names{$file_name}) {
          $orig_names{$file_name} = $member_name;
        } else {
          do_log(0,'do_pax_cpio: member "%s" is hidden by a '.
                   'previous archive member "%s", file: %s',
                   $member_name, $orig_names{$file_name}, $file_name);
          undef $orig_names{$file_name};  # cause it to exist but undefined
          $name_clash = 1;
        }
      }
    }
    defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading (2): $!";
    do_log(-1,"unexpected(pax_cpio_2): %s",$!) if !defined($ln) && $! == EAGAIN;
    my $err = 0; $proc_fh->close or $err = $!;
    my $child_stat = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    undef $proc_fh; undef $pid; chomp($output);
    proc_status_ok($child_stat,$err)
      or die(exit_status_str($child_stat,$err).' '.$output);
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('do_pax_cpio');  # restart timer
  chdir($tempdir) or die "Can't chdir to $tempdir: $!";
  my $b = flatten_and_tidy_dir("$tempdir/parts/arch", "$tempdir/parts",
                               $part, 0, \%orig_names);
  consumed_bytes($b, 'do_pax_cpio');
  if (defined $eval_stat) {
    chomp $eval_stat;
    kill_proc($pid,$archiver,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
    die "do_pax_cpio: $eval_stat\n";  # propagate failure
  }
  $name_clash ? 2 : 1;
}

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

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

sub do_cabextract($$$) {
  my($part, $tempdir, $archiver) = @_;
  do_log(4, "Expanding cab archive %s", $part->base_name);
  my $archiver_name = basename((split(' ',$archiver))[0]);
  snmp_count("OpsDecBy\u${archiver_name}");
  my($proc_fh,$pid) =
    run_command(undef, '/dev/null', $archiver, '-l', $part->full_name);
  local($1,$2); my $bytes = 0; my $ln; my $entries_cnt = 0;
  for ($! = 0; defined($ln=$proc_fh->getline); $! = 0) {
    chomp($ln);
    next  if $ln =~ /^(?: ?File size|----|Viewing cabinet:|\z)/s;
    next  if $ln =~ /^\s*All done, no errors/s;
    if ($entries_cnt++, $MAXFILES && $entries_cnt > $MAXFILES)
      { die "Maximum number of files ($MAXFILES) exceeded" }
    if ($ln !~ /^\s* (\d+) \s* \| [^|]* \| \s (.*) \z/x) {
      do_log(-1, "do_cabextract: can't parse toc line: %s", $ln);
    } else {
      do_log(5, 'do_cabextract: member: "%s", size: %s', $2,$1);
      $bytes += $1  if $1 > 0;
    }
  }
  defined $ln || $! == 0 || $! == EAGAIN  or die "Error reading: $!";
  do_log(-1,"unexpected(cabextract): %s",$!)  if !defined($ln) && $! == EAGAIN;
  # consume remaining output to avoid broken pipe (just in case)
  collect_results($proc_fh,$pid,'cabextract-1',16384,[0]);
  undef $proc_fh; undef $pid;
  mkdir("$tempdir/parts/cab",0750) or die "Can't mkdir $tempdir/parts/cab: $!";
  ($proc_fh,$pid) = run_command(undef, '/dev/null', $archiver, '-q', '-d',
                                "$tempdir/parts/cab", $part->full_name);
  collect_results($proc_fh,$pid,'cabextract-2',16384,[0]);
  undef $proc_fh; undef $pid;
  my $b = flatten_and_tidy_dir("$tempdir/parts/cab", "$tempdir/parts", $part);
  consumed_bytes($b, 'do_cabextract');
  1;
}

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

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

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

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

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

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

  0;
}

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

# Given a file handle (typically opened pipe to a subprocess, as returned
# by run_command), copy from it to a specified output file in binary mode.
#
sub run_command_copy($$$) {
  my($outfile, $ifh, $pid) = @_;
  my $ofh = IO::File->new;
  # O_WRONLY etc. can become tainted in Perl5.8.9 [perlbug #62502]
  $ofh->open($outfile, untaint(O_CREAT|O_EXCL|O_WRONLY), 0640)  # calls sysopen
    or die "Can't create file $outfile: $!";
  binmode($ofh) or die "Can't set file $outfile to binmode: $!";
  binmode($ifh) or die "Can't set binmode on pipe: $!";
  my($eval_stat, $rv, $rerr); $rerr = 0;
  eval {
    my($nread, $nwrite, $tosend, $offset, $inbuf);
    for (;;) {
      $nread = sysread($ifh, $inbuf, 65536);
      if (!defined($nread)) {
        if ($! == EAGAIN || $! == EINTR) {
          Time::HiRes::sleep(0.1);  # just in case
        } else {
          die "Error reading: $!";
        }
      } elsif ($nread < 1) {  # sysread returns 0 at eof
        last;
      } else {
        consumed_bytes($nread, 'run_command_copy');
        $tosend = $nread; $offset = 0;
        while ($tosend > 0) {  # handle partial writes
          $nwrite = syswrite($ofh, $inbuf, $tosend, $offset);
          if (!defined($nwrite)) {
            if ($! == EAGAIN || $! == EINTR) {
              Time::HiRes::sleep(0.1);  # just in case
            } else {
              die "Error writing to $outfile: $!";
            }
          } elsif ($nwrite < 1) {
            Time::HiRes::sleep(0.1);  # just in case
          } else {
            $tosend -= $nwrite; $offset += $nwrite;
          }
        }
      }
    }
    $ifh->close or $rerr = $!;
    $rv = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    $ofh->close or die "Error closing $outfile: $!";
    1;
  } or do {
    $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    # remember error, close socket ignoring status
    $rerr = $!; $ifh->close;
    $rv = defined $pid && waitpid($pid,0) > 0 ? $? : undef;
    do_log(-1, "run_command_copy: %s", $eval_stat);
    $ofh->close  or do_log(-1, "Error closing %s: %s", $outfile,$!);
  };
  if (defined $eval_stat) { die "run_ccpy: $eval_stat\n" }  # propagate failure
  ($rv,$rerr);  # return subprocess termination status and reading/close errno
}

# extract listed files from archive and store each in a new file
#
sub store_mgr($$$@) {
  my($tempdir, $parent_obj, $list, $archiver, @args) = @_;
  my $item_num = 0; my $parent_placement = $parent_obj->mime_placement;
  my $retval = 0; my($proc_fh,$pid);
  prolong_timer('store_mgr_pre');  # restart timer
  my $eval_stat;
  eval {
    for my $f (@$list) {
      next  if $f =~ m{/\z};  # ignore directories
      my $newpart_obj =
        Amavis::Unpackers::Part->new("$tempdir/parts",$parent_obj);
      $item_num++; $newpart_obj->mime_placement("$parent_placement/$item_num");
      $newpart_obj->name_declared($f);  # store tainted name
      my $newpart = $newpart_obj->full_name;
      ll(5) && do_log(5,'store_mgr: extracting "%s" to file %s using %s',
                        $f, $newpart, $archiver);
      if ($f =~ m{^\.?[A-Za-z0-9_][A-Za-z0-9/._=~-]*\z}) { #presumably safe arg
      } else {  # this is not too bad, as run_command does not use shell
        do_log(1, 'store_mgr: NOTICE: suspicious file name "%s"', $f);
      }
      ($proc_fh,$pid) = run_command(undef, '/dev/null',
                                    $archiver, @args, untaint($f));
      my($rv,$err) = run_command_copy($newpart,$proc_fh,$pid);  # may die
      my $ll = proc_status_ok($rv,$err) ? 5 : 1;
      ll($ll) && do_log($ll,"store_mgr: extracted by %s, %s",
                            $archiver, exit_status_str($rv,$err));
      $retval = $rv  if $retval == 0 && $rv != 0;
    }
    1;
  } or do { $eval_stat = $@ ne '' ? $@ : "errno=$!" };
  prolong_timer('store_mgr');  # restart timer
  if (defined $eval_stat) {
    $retval = 0; chomp $eval_stat;
    kill_proc($pid,$archiver,1,$proc_fh,$eval_stat)  if defined $pid;
    undef $proc_fh; undef $pid;
    die "store_mgr: $eval_stat\n";  # propagate failure
  }
  $retval;  # return the first nonzero status (if any), or 0
}
1;

__DATA__
#
package Amavis::DKIM::CustomSigner;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

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

sub sign_digest {
  my($self_key, $digest_alg_name, $digest) = @_;
  my $code = $self_key->{CustomSigner};
  &$code($digest_alg_name, $digest, %$self_key);
}

1;

package Amavis::DKIM;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&dkim_key_postprocess &generate_authentication_results
                  &dkim_make_signatures &adjust_score_by_signer_reputation
                  &collect_some_dkim_info);
  import Amavis::Conf qw(:platform c cr ca $myproduct_name
                  %dkim_signing_keys_by_domain
                  @dkim_signing_keys_list @dkim_signing_keys_storage);
  import Amavis::Util qw(min max minmax untaint ll do_log unique_list
                  format_time_interval get_deadline
                  idn_to_ascii mail_addr_idn_to_ascii idn_to_utf8
                  safe_encode_utf8 proto_encode proto_decode);
  import Amavis::rfc2821_2822_Tools qw(split_address quote_rfc2821_local
                  qquote_rfc2821_local);
  import Amavis::Timing qw(section_time);
  import Amavis::Lookup qw(lookup lookup2);
}
use subs @EXPORT_OK;

use IO::File ();
use Crypt::OpenSSL::RSA ();
use MIME::Base64;
use Net::DNS::Resolver;
use Mail::DKIM::Verifier 0.31;
use Mail::DKIM::Signer   0.31;
use Mail::DKIM::TextWrap;
use Mail::DKIM::Signature;
use Mail::DKIM::DkSignature;

# Convert private keys (as strings in PEM format) into RSA objects
# and do some pre-processing on @dkim_signing_keys_list entries
# (may run unprivileged)
#
sub dkim_key_postprocess() {
  # convert private keys (as strings in PEM format) into RSA objects
  for my $ks (@dkim_signing_keys_storage) {
    my($pkcs1,$dev,$inode,$fname) = @$ks;
    if (ref $pkcs1 && UNIVERSAL::isa($pkcs1,'Crypt::OpenSSL::RSA')) {
      # it is already a Crypt::OpenSSL::RSA object
    } else {
      # assume a string is a private key in PEM format, convert it to RSA obj
      $ks->[0] = $pkcs1 = Crypt::OpenSSL::RSA->new_private_key($pkcs1);
    }
    my $key_size = 8 * $pkcs1->size;
    my $minimum_key_bits = c('dkim_minimum_key_bits');
    if ($key_size < 1024) {
      do_log(0,"NOTE: DKIM %d-bit signing key is shorter than ".
               "a recommended RFC 6376 minimum of %d bits, file: %s",
               $key_size, 1024, $fname);
    } elsif ($minimum_key_bits && $key_size < $minimum_key_bits) {
      do_log(0,"INFO: DKIM %d-bit signing key is shorter than ".
               "a configured \$dkim_minimum_key_bits of %d bits, file: %s",
               $key_size, $minimum_key_bits, $fname);
    }
  }
  for my $ent (@dkim_signing_keys_list) {
    my $domain = $ent->{domain};
    $dkim_signing_keys_by_domain{$domain} = []
      if !$dkim_signing_keys_by_domain{$domain};
  }
  my $any_wild; my $j = 0;
  for my $ent (@dkim_signing_keys_list) {
    $ent->{v} = 'DKIM1'  if !defined $ent->{v};  # provide a default
    if (defined $ent->{n}) {  # encode n as qp-section (RFC 6376, RFC 2047)
      $ent->{n} =~ s{([\000-\037\177=;"])}{sprintf('=%02X',ord($1))}gse;
    }
    my $domain = $ent->{domain};
    if (exists $ent->{g}) {
      do_log(0,"INFO: the 'g' tag is historic (RFC 6376), signers are ".
               "advised not to include a 'g' tag in key records: ".
               "s=%s d=%s g=%s", $ent->{selector}, $domain, $ent->{g});
    }
    if (ref($domain) eq 'Regexp') {
      $ent->{domain_re} = $domain;
      $any_wild = sprintf("key#%d, %s", $j+1, $domain)  if !defined $any_wild;
    } elsif ($domain =~ /\*/) {
      # wildcarded signing domain in a key declaration, evil, asks for trouble!
      # support wildcards in signing domain for compatibility with dkim_milter
      my $regexp = $domain;
      $regexp =~ s/\*{2,}/*/gs;   # collapse successive wildcards
      # '*' is a wildcard, quote the rest
      $regexp =~ s{ ([@\#/.^\$|*+?(){}\[\]\\]) }
                  { $1 eq '*' ? '.*' : '\\'.$1 }xgse;
      $regexp = '^' . $regexp . '\\z';  # implicit anchors
      $regexp =~ s/^\^\.\*//s;    # remove leading anchor if redundant
      $regexp =~ s/\.\*\\z\z//s;  # remove trailing anchor if redundant
      $regexp = '(?:)'  if $regexp eq '';  # just in case, non-empty regexp
      # presence of {'domain_re'} entry lets get_dkim_key use this regexp
      # instead of a direct string comparison with {'domain'}
      $ent->{domain_re} = qr{$regexp};  # compiled regexp object
      $any_wild = sprintf("key#%d, %s", $j+1, $domain)  if !defined $any_wild;
    }
    # %dkim_signing_keys_by_domain entries contain lists of indices into
    # the @dkim_signing_keys_list of all potentially applicable signing keys.
    # This hash (keyed by domain name) avoids linear searching for signing
    # keys for all fully-specified domains in @dkim_signing_keys_list.
    # Wildcarded entries must still be looked up sequentially at run-time
    # to preserve the declared order and the 'first match wins' paradigm.
    # Such entries are only supported for compatibility with dkim_milter
    # and are evil because amavisd has no quick way of verifying that DNS RR
    # really exists, so signatures generated by amavisd can fail when not all
    # possible DNS resource records exist for wildcarded signing domains.
    #
    if (!defined($ent->{domain_re})) { # no regexp, just plain match on domain
      push(@{$dkim_signing_keys_by_domain{$domain}}, $j);
    } else {  # a wildcard in a signing domain, compatibility with dkim_milter
      # wildcarded signing domain potentially matches any _by_domain entry
      for my $d (keys %dkim_signing_keys_by_domain) {
        push(@{$dkim_signing_keys_by_domain{$d}}, $j);
      }
      # the '*' entry collects only wildcarded signing keys
      $dkim_signing_keys_by_domain{'*'} = []
        if !$dkim_signing_keys_by_domain{'*'};
      push(@{$dkim_signing_keys_by_domain{'*'}}, $j);
    }
    $j++;
  }
  do_log(0,"dkim: wildcard in signing domain (%s), may produce unverifiable ".
           "signatures with no published public key, avoid!", $any_wild)
        if $any_wild;
}

# Fetch a private DKIM signing key for a given signing domain, with its
# resource-record (RR) constraints compatible with proposed signature options.
# The first such key is returned as a hash; if no key is found an empty hash
# is returned. When a selector (s) is given it must match the selector of
# a key; when algorithm (a) is given, the key type and a hash algorithm must
# match the desired use too; the service type (s) must be 'email' or '*';
# when identity (i) is given it must match the granularity (g) of a key.
# RFC 6376: the "g=" tag has been deprecated in this version of the DKIM
# specification (and thus MUST now be ignored), signers are advised not to
# include the "g=" tag in key records.
#
# sign.opts.     key options
# ----------     -----------
#  d         =>  domain
#  s         =>  selector
#  a         =>  k, h(list)
#  i         =>  g, t=s
#
sub get_dkim_key(@) {
  @_ % 2 == 0 or die "get_dkim_key: a list of pairs is expected as query opts";
  my(%options) = @_;  # signature options (v, a, c, d, h, i, l, q, s, t, x, z),
    # of which d is required, while s, a and t are optional but taken into
    # account in searching for a compatible key - the rest are ignored
  my(%key_options);
  my $domain = $options{d}; my $selector = $options{s};
  defined $domain && $domain ne ''
    or die "get_dkim_key: domain is required, but tag 'd' is missing";
  $domain   = idn_to_ascii($domain);
  $selector = idn_to_ascii($selector)  if defined $selector;
  my(@indices) = $dkim_signing_keys_by_domain{$domain} ?
                   @{$dkim_signing_keys_by_domain{$domain}} :
                 $dkim_signing_keys_by_domain{'*'} ?
                   @{$dkim_signing_keys_by_domain{'*'}} : ();
  if (@indices) {
    $selector = $selector eq '' ? undef : lc($selector)  if defined $selector;
    local($1,$2);
    my($keytype,$hashalg) =
      defined $options{a} && $options{a} =~ /^([a-z0-9]+)-(.*)\z/is ? ($1,$2)
                                                              : ('rsa',undef);
    my($identity_localpart,$identity_domain) =
      !defined($options{i}) ? () : split_address($options{i});
    $identity_localpart = ''  if !defined $identity_localpart;
    $identity_domain    = ''  if !defined $identity_domain;
    $identity_domain =
      idn_to_ascii($identity_domain)  if $identity_domain ne '';
    # find the first key (associated with a domain) with compatible options
    for my $j (@indices) {
      my $ent = $dkim_signing_keys_list[$j];
      next unless defined $ent->{domain_re} ? $domain =~ $ent->{domain_re}
                                            : $domain eq $ent->{domain};
      next if defined $selector && $ent->{selector} ne $selector;
      next if $keytype ne (exists $ent->{k} ? $ent->{k} : 'rsa');
      next if exists $ent->{s} &&
              !(grep($_ eq '*' || $_ eq 'email', split(/:/, $ent->{s})) );
      next if defined $hashalg && exists $ent->{'h'} &&
              !(grep($_ eq $hashalg, split(/:/, $ent->{'h'})) );
      if (defined($options{i})) {
        if ($identity_domain eq $domain) {
          # ok
        } elsif (exists $ent->{t} && (grep($_ eq 's', split(/:/,$ent->{t})))) {
          next;  # no subdomains allowed
        }
        # the 'g' tag is now historic, RFC 6376
        if (!exists($ent->{g}) || $ent->{g} eq '*') {
          # ok
        } elsif ($ent->{g} =~ /^ ([^*]*) \* (.*) \z/xs) {
          next if $identity_localpart !~ /^ \Q$1\E .* \Q$2\E \z/xs;
        } else {
          next if $identity_localpart ne $ent->{g};
        }
      }
      %key_options = %$ent;  last;  # found a suitable match
    }
  }
  if (defined $key_options{key_storage_ind}) {
    # obtain actual key from @dkim_signing_keys_storage
    ($key_options{key}) =
      @{$dkim_signing_keys_storage[$key_options{key_storage_ind}]};
  }
  %key_options;
}

# send a query to a signing service, collect its response and parse it;
# the protocol is much like the AM.PDP protocol, except that attributes
# are different
#
sub query_signing_service($$) {
  my($server, $query) = @_;
  my($remaining_time, $deadline) = get_deadline('query_signing_service');
  my $sock = Amavis::IO::RW->new($server, Eol => "\015\012", Timeout => 10);
  $sock or die "Error connecting to a signing server $server: $!";
  my $req_id = sprintf("%08x", rand(0x7fffffff));
  my $req_id_attr = proto_encode('request_id', $req_id);
  $sock->print(join('', map($_."\015\012", (@$query, $req_id_attr, ''))))
    or die "Error sending a query to a signing server";
  ll(5) && do_log(5, "dkim: query_signing_service, query: %s",
                     join('; ', @$query, $req_id_attr));
  $sock->flush or die "Error flushing signing server session";
  # collect a reply
  $sock->timeout(max(2, $deadline - Time::HiRes::time));
  my(%attr,$ln); local($1,$2);
  while (defined($ln = $sock->get_response_line)) {
    last  if $ln eq "\015\012";  # end of a response block
    if ($ln =~ /^ ([^=\000\012]*?) = ([^\012]*?) \015\012 \z/xsi) {
      $attr{proto_decode($1)} = proto_decode($2);
    }
  }
  $sock->close  or die "Error closing session to a signing server $server: $!";
  ll(5) && do_log(5, "dkim: query_signing_service, got: %s",
                  join('; ', map($_.'='.$attr{$_}, keys %attr)));
  $attr{request_id} eq $req_id
    or die "Answer id '$attr{request_id}' from $server ".
           "does not match the query id '$req_id'";
  \%attr;
}

# send candidate originator addresses and signature options to a signing
# service and let it choose a selector 's' and a domain 'd', thus uniquely
# identifying a signing key
#
sub let_signing_service_choose($$$$) {
  my($server, $msginfo, $sender_search_list_ref, $sig_opt_prelim) = @_;
  my(@query) = (
    proto_encode('request', 'choose_key'),
    proto_encode('log_id',  $msginfo->log_id),
  );
  # provide some additional information potentially useful in decision-making
  if ($sig_opt_prelim) {
    for my $opt (sort keys %$sig_opt_prelim) {
      push(@query, proto_encode('sig.'.$opt, $sig_opt_prelim->{$opt}));
    }
  }
  push(@query, proto_encode('sender', $msginfo->sender_smtp));
  for my $r (@{$msginfo->per_recip_data}) {
    push(@query, proto_encode('recip', $r->recip_addr_smtp));
  }
  for my $pair (!$sender_search_list_ref ? () : @$sender_search_list_ref) {
    my($addr,$addr_src) = @$pair;
    push(@query, proto_encode('candidate', $addr_src,
                              qquote_rfc2821_local($addr)));
  }
  my $attr;
  eval {
    $attr = query_signing_service($server,\@query);  1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    do_log(0, "query_signing_service failed: %s", $eval_stat);
  };
  my(%sig_options, $chosen_addr_src, $chosen_addr);
  if ($attr) {
    for my $opt (keys %$attr) {
      if ($opt =~ /^sig\.(.+)\z/) {
        $sig_options{$1} = $attr->{$opt}  if !exists($sig_options{$1});
      }
    }
    if (defined $attr->{chosen_candidate}) {
      ($chosen_addr_src, $chosen_addr) =
        split(' ', $attr->{chosen_candidate}, 2);
    }
  }
  (!$attr ? undef : \%sig_options,  $chosen_addr_src, $chosen_addr);
}

# a CustomSigner callback routine passed to Mail::DKIM in place of a key;
# the routine will be called by Mail::DKIM::Algorithm::*rsa_sha* routines
# instead of calling their own Mail::DKIM::PrivateKey::sign_digest()
#
sub remote_signer {
  my($digest_alg_name, $digest, %args) = @_;
  # $digest: header digest (binary), ready for signing,
  #          e.g. $algorithm->{header_digest}->digest
  my $server  = $args{Server};   # our own info passed back to us
  my $msginfo = $args{MsgInfo};  # our own info passed back to us
  my(@query) = (
    proto_encode('request', 'sign'),
    proto_encode('digest_alg', $digest_alg_name),
    proto_encode('digest', encode_base64($digest,'')),
    proto_encode('s',      $args{Selector}),
    proto_encode('d',      $args{Domain}),
    proto_encode('log_id', $msginfo->log_id),
  );
  my($attr, $b, $reason);
  eval {
    $attr = query_signing_service($server, \@query);  1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    $reason = $eval_stat;
  };
  if ($attr) { $b = $attr->{b};  $reason = $attr->{reason} }
  if (!defined($b) || $b eq '') {
    $reason = 'no signature from a signing server'  if !defined $reason;
  # die "Can't sign, $reason, query: " . join('; ',@query) . "\n";
    do_log(0, "dkim: can't sign, %s, query: %s", $reason, join('; ',@query));
    return '';  # Mail::DKIM::Algorithm::rsa_sha256 doesn't like undef
  }
  decode_base64($b);  # resulting signature
}

# prepare requested DKIM signatures for a provided message,
# returning them as a list of Mail::DKIM::Signature objects
#
sub dkim_make_signatures($$;$) {
  my($msginfo,$initial_submission,$callback) = @_;
  my(@signatures);   # resulting signature objects
  my(%sig_options);  # signature options and constraints for choosing a key
  my(%key_options);  # options associated with a signing key, IDN as ACE
  my(@tried_domains);  # used for logging a failure
  my($chosen_addr,$chosen_addr_src); my $do_sign = 0;
  my $fm = $msginfo->rfc2822_from;  # authors
  my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
  my $allowed_hdrs = cr('allowed_added_header_fields');
  my $from_str = join(', ', qquote_rfc2821_local(@rfc2822_from));  # logging
  substr($from_str,100) = '[...]'  if length($from_str) > 100;
  if (!$allowed_hdrs || !$allowed_hdrs->{lc('DKIM-Signature')}) {
    do_log(5, "dkim: inserting a DKIM-Signature header field disabled");
  } elsif (!$msginfo->originating) {
    do_log(5, "dkim: not signing mail which is not originating from our site");
  } elsif ($msginfo->is_in_contents_category(CC_VIRUS)) {
    do_log(2, "dkim: not signing infected mail (from inside), From: %s",
              $from_str);
  } elsif ($msginfo->is_in_contents_category(CC_SPAM)) {
    # it is prudent not to sign outgoing spam, otherwise an attacker may be
    # able to replay a signed message, re-sending it to other recipients
    # in bulk directly from botnets
    do_log(2, "dkim: not signing spam (from inside), From: %s", $from_str);
  } elsif ($msginfo->is_in_contents_category(CC_SPAMMY)) {
    do_log(2, "dkim: not signing suspected spam (from inside), From: %s",
              $from_str);
  } else {
    # Choose a signing key based on the first match on the following
    # addresses (in this order): 2822.From, followed by 2822.Resent-From and
    # 2822.Resent-Sender address pairs traversed top-down by resent blocks,
    # followed by 2822.Sender and 2821.mail_from. We choose to look up
    # a From first, as it generates an author domain signature, but the
    # search order on remaining entries is admittedly unusual.
    # Btw, dkim-milter uses the following search order:
    #   Resent-Sender, Resent-From, Sender, From.
    # Only a signature based on 2822.From is considered an author domain
    # signature, others are just third-party signatures and have no more
    # merit than any other third-party signature according to RFC 6376.
    #
    my $rf = $msginfo->rfc2822_resent_from;
    my $rs = $msginfo->rfc2822_resent_sender;
    my(@rfc2822_resent_from, @rfc2822_resent_sender);
    @rfc2822_resent_from   = @$rf  if defined $rf;
    @rfc2822_resent_sender = @$rs  if defined $rs;
    my(@search_list); # collects candidate addresses for choosing a signing key
    # author addresses go first (typically exactly one, but possibly more)
    push(@search_list, map([$_,'From'], @rfc2822_from));
    # merge Resent-From and Resent-Sender addresses by resent blocks, top-down;
    # a merge is simplified by the fact that there is an equal number of
    # resent blocks in @rfc2822_resent_from and @rfc2822_resent_sender lists
    while (@rfc2822_resent_from || @rfc2822_resent_sender) {
      # for each resent block
      while (@rfc2822_resent_from) {
        my $addr = shift(@rfc2822_resent_from);
        last  if !defined $addr;  # undef delimits resent blocks
        push(@search_list, [$addr, 'Resent-From']);
      }
      while (@rfc2822_resent_sender) {
        my $addr = shift(@rfc2822_resent_sender);
        last  if !defined $addr;  # undef delimits resent blocks
        push(@search_list, [$addr, 'Resent-Sender']);
      }
    }
    push(@search_list, [$msginfo->rfc2822_sender, 'Sender']);
    push(@search_list, [$msginfo->sender,      'mail_from']);
    { # remove duplicates and empty addresses
      my(%addr_seen);
      @search_list =
        grep { my($a,$src) = @$_; defined $a && $a ne '' && !$addr_seen{$a}++ }
             @search_list;
    }
    ll(2) && do_log(2, "dkim: candidate originators: %s",
                    join(", ", map($_->[1].':'.qquote_rfc2821_local($_->[0]),
                                   @search_list)));

    # dkim_signwith_sd() may provide a ref to a pair [selector,domain] - if
    # available (e.g. by a custom hook), it will force signing with a private
    # key associated with this selector and domain, otherwise we fall back
    # to consulting an external service if available, or else we use our
    # built-in algorithm for choosing a selector & domain and their associated
    # signing key
    #
    my $sd_pair = $msginfo->dkim_signwith_sd;
    if (ref($sd_pair) eq 'ARRAY') {
      my($s,$d) = @$sd_pair;
      if (defined $s && $s ne '' && defined $d && $d ne '') {
        do_log(5, "dkim: dkim_signwith_sd presets d=%s, s=%s", $d,$s);
        $sig_options{s} = $s; $sig_options{d} = $d;
      }
    }

    my $dkim_signing_service = c('dkim_signing_service');
    if (defined $dkim_signing_service && $dkim_signing_service ne '') {
      # try the signing service: it should provide an 's' and 'd' if it has
      # a suitable signing key available, and/or may supply signing options,
      # overriding the defaults set so far
      my $sig_opt_ref;
      ($sig_opt_ref, $chosen_addr_src, $chosen_addr) =
        let_signing_service_choose($dkim_signing_service,
                                   $msginfo, \@search_list, undef);
      if ($sig_opt_ref) {  # merge returned signature options with ours
        while (my($k,$v) = each(%$sig_opt_ref)) {
          $sig_options{$k} = $v  if defined $v;
        }
      }
    }

    my $sobm = ca('dkim_signature_options_bysender_maps');
    # last resort: fall back to our local configuration settings
    for my $pair (@search_list) {
      my($addr,$addr_src) = @$pair;
      my($addr_localpart,$addr_domain) = split_address($addr);
      # fetch a list of hashes from all entries matching the address
      my($dkim_options_ref,$mk_ref);
      ($dkim_options_ref,$mk_ref) = lookup2(1,$addr,$sobm)  if $sobm && @$sobm;
      $dkim_options_ref = []  if !defined $dkim_options_ref;
      # signature options (parenthesized options are set automatically;
      # the RFC 6651 (failure reporting) added a tag: r=y) :
      #   (v), a, (b), (bh), c, d, (h), i, (l), q, r, s, (t), x, (z)
      # place a catchall default at the end of the list of options;
      push(@$dkim_options_ref, { c => 'relaxed/simple', a => 'rsa-sha256' });
      # start each iteration with the same set of options collected so far
      my(%tmp_sig_options) = %sig_options;
      # traverse list of hashes from specific to general, first match wins
      for my $opts_hash_ref (@$dkim_options_ref) {
        next  if ref $opts_hash_ref ne 'HASH';  # just in case
        while (my($k,$v) = each(%$opts_hash_ref)) {  # for each entry in a hash
          $tmp_sig_options{$k} = $v  if !exists $tmp_sig_options{$k};
        }
      }
      # a default for a signing domain is a domain of each tried address
      if (!exists($tmp_sig_options{d})) {
        my $d = $addr_domain; $d =~ s/^\@//; $tmp_sig_options{d} = $d;
      }
      push(@tried_domains, $tmp_sig_options{d});
      ll(5) && do_log(5, "dkim: signature options for %s(%s): %s",
                      $addr, $addr_src,
                      join('; ', map($_.'='.$tmp_sig_options{$_},
                                     keys %tmp_sig_options)));

      # find a private key associated with a signing domain and selector,
      # and meeting constraints
      %key_options = get_dkim_key(%tmp_sig_options)
        if defined $tmp_sig_options{d} && $tmp_sig_options{d} ne '';
    # my(@domain_path); # host.sub.example.com sub.example.com example.com com
    # $addr_domain =~ s/^\@//; $addr_domain =~ s/\.\z//;
    # if ($addr_domain !~ /\[/) {  # don't split address literals
    #   for (my $d=$addr_domain; $d ne ''; $d =~ s/^[^.]*(?:\.|\z)//s)
    #     { push(@domain_path,$d) }
    # }
    # for my $d (@domain_path) {
    #   $tmp_sig_options{d} = $d;
    #   %key_options = get_dkim_key(%tmp_sig_options);
    #   last  if defined $key_options{key};
    # }
      my $key = $key_options{key};
      if (defined $key && $key ne '') {  # found; copy the key and its options
        $tmp_sig_options{key} = $key;
        $tmp_sig_options{s} = idn_to_utf8($key_options{selector});
        $chosen_addr = $addr; $chosen_addr_src = $addr_src;
        # merge the just collected signature options into the final set
        while (my($k,$v) = each(%tmp_sig_options)) {
          $sig_options{$k} = $v  if defined $v;
        }
        last;
      }
    }

    # provide defaults for 'c' and 'a' tags if missing
    $sig_options{c} = 'relaxed/simple'  if !exists $sig_options{c};
    $sig_options{a} = 'rsa-sha256'      if !exists $sig_options{a};

    # prepare for a second stage of using an external signing service:
    # when we do have a 's' and 'd', thus uniquely identifying a signing key,
    # but do not have a key ourselves, we'll provide a callback routine
    # in place of a key object so that Mail::DKIM will call it at the time
    # of signing, and our routine will consult a remote signing service
    #
    if (!defined $sig_options{key} &&
        defined $dkim_signing_service && $dkim_signing_service ne '' &&
        defined $sig_options{d} && $sig_options{d} ne '' &&
        defined $sig_options{s} && $sig_options{s} ne '') {
      my $s = $sig_options{s};  my $d = $sig_options{d};
      # let Mail::DKIM use our custom code for signing (pref. 0.38 or later)
      $key_options{key} = Amavis::DKIM::CustomSigner->new(
           CustomSigner => \&remote_signer, MsgInfo => $msginfo,
           Selector => idn_to_ascii($s),
           Domain => idn_to_ascii($d),
           Server => $dkim_signing_service);
      $key_options{selector} = $s;  $key_options{domain} = $d;
      $sig_options{key} = $key_options{key};
    }

    my $sig_opt_d_ace = idn_to_ascii($sig_options{d});
    if (!defined $sig_opt_d_ace || $sig_opt_d_ace eq '') {
      do_log(2, "dkim: not signing, empty signing domain, From: %s",$from_str);
    } elsif (!defined $sig_options{key} || $sig_options{key} eq '') {
      do_log(2, "dkim: not signing, no applicable private key for domains %s,".
                " s=%s, From: %s",
                join(", ",@tried_domains), $sig_options{s}, $from_str);
    } else {
      # copy key's options to signature options for convenience
      for (keys %key_options) {
        $sig_options{'KEY.'.$_} = $key_options{$_}  if /^[ghknst]\z/;
      }
      $sig_options{'KEY.key_ind'} = $key_options{key_ind};

      # check matching of identity to a signing domain or provide a default;
      # presence of a t=s flag in a public key RR prohibits subdomains in i
      my $key_allows_subdomains =
        grep($_ eq 's', split(/:/,$sig_options{'KEY.t'})) ? 0 : 1;
      if (defined $sig_options{i}) {  # explicitly given, possibly empty
        # have mercy: provide a leading '@' if missing
        $sig_options{i} = '@'.$sig_options{i}  if $sig_options{i} ne '' &&
                                                  $sig_options{i} !~ /\@/;
      } elsif (!$key_allows_subdomains) {
        # we have no other choice but to keep it at its default @d
      } else {  # the public key record permits subdomains
        # provide default for i in a form of a sender's domain
        local($1);
        if ($chosen_addr =~ /\@([^\@]*)\z/) {
          my $identity_domain = $1;
          if (idn_to_ascii($identity_domain) =~ /.\.\Q$sig_opt_d_ace\E\z/s) {
            $sig_options{i} = '@'.$identity_domain;
            do_log(5, "dkim: identity defaults to %s", $sig_options{i});
          }
        }
      }
      if (!defined $sig_options{i} || $sig_options{i} eq '') {
        $do_sign = 1;  # just sign, don't bother with i
      } else {  # check if the requested i is compatible with d
        local($1);
        my $identity_domain = $sig_options{i} =~ /\@([^\@]*)\z/ ? $1 : '';
        my $identity_domain_ace = idn_to_ascii($identity_domain);
        if (!$key_allows_subdomains && $identity_domain_ace ne $sig_opt_d_ace){
          do_log(2, "dkim: not signing, identity domain %s not the same as ".
                    "a signing domain %s, flags t=%s, From: %s",
                    $sig_options{i}, $sig_options{d}, $sig_options{'KEY.t'},
                    $from_str);
        } elsif ($key_allows_subdomains &&
                 $identity_domain_ace !~ /(?:^|\.)\Q$sig_opt_d_ace\E\z/i) {
          do_log(2, "dkim: not signing, identity %s not a subdomain of %s, ".
                    "From: %s", $sig_options{i}, $sig_options{d}, $from_str);
        } else {
          $do_sign = 1;
        }
      }
    }
  }
  my $sig_opt_d_ace = idn_to_ascii($sig_options{d});
  if ($do_sign) {  # avoid adding same signature on multiple passes through MTA
    my $sigs_ref = $msginfo->dkim_signatures_valid;
    if ($sigs_ref) {
      for my $sig (@$sigs_ref) {
        if ( idn_to_ascii($sig->domain) eq $sig_opt_d_ace &&
             (!defined $sig_options{i} || $sig_options{i} eq $sig->identity)) {
          do_log(2, "dkim: not signing, already signed by domain %s, ".
                    "From: %s", $sig_opt_d_ace, $from_str);
          $do_sign = 0;
        }
      }
    }
  }
  if ($do_sign) {
    # relative expiration time
    if (defined $sig_options{ttl} && $sig_options{ttl} > 0) {
      my $xt = $msginfo->rx_time + $sig_options{ttl};
      $sig_options{x} = int($xt) + ($xt > int($xt) ? 1 : 0);  # ceiling
    }
    # remove redundant options with RFC 6376 -default values
    for my $k (keys %sig_options) { delete $sig_options{$k} if !defined $k }
    delete $sig_options{i}  if $sig_options{i} =~ /^\@/ &&
                          idn_to_ascii($sig_options{i}) eq '@'.$sig_opt_d_ace;
    delete $sig_options{c}  if $sig_options{c} eq 'simple/simple' ||
                               $sig_options{c} eq 'simple';
    delete $sig_options{q}  if $sig_options{q} eq 'dns/txt';
    if (ref $callback eq 'CODE') { &$callback($msginfo,\%sig_options) }
    if (ll(2)) {
      my $opts = join(', ',map($_ eq 'key' ? ()
                            : ($_ . '=>' . safe_encode_utf8($sig_options{$_})),
                               sort keys %sig_options));
      do_log(2,"dkim: signing (%s), From: %s (%s:%s), %s",
               grep(/\@\Q$sig_opt_d_ace\E\z/si,
                    map(mail_addr_idn_to_ascii($_), @rfc2822_from))
                 ? 'author' : '3rd-party',
               $from_str, $chosen_addr_src, qquote_rfc2821_local($chosen_addr),
               $opts);
    }
    my $key = $sig_options{key};
    if (UNIVERSAL::isa($key,'Crypt::OpenSSL::RSA')) {
      # my $pkcs1 = $key->get_private_key_string;  # most compact
      # $pkcs1 =~ s/^---.*?---(?:\r?\n|\z)//gm;  $pkcs1 =~ tr/\r\n//d;
      # $key = Mail::DKIM::PrivateKey->load(Data => $pkcs1);
      $key = Mail::DKIM::PrivateKey->load(Cork => $key);  # avail since 0.31
    } elsif (ref $key) {
      # already a Mail::DKIM::PrivateKey or Amavis::DKIM::CustomSigner object
    } else {
      $key = Mail::DKIM::PrivateKey->load(File => $key);  # read from a file
    }

    # Sendmail milter interface does not provide a just-generated Received
    # header field to milters. Milters therefore need to fabricate a pseudo
    # Received header field in order to provide client IP address to a filter.
    # Unfortunately it is not possible to reliably fabricate a header field
    # which will exactly match the later-inserted one, so we must not sign
    # it to avoid a likely possibility of a signature being invalidated.
    my $conn = $msginfo->conn_obj;
    my $appl_proto = !$conn ? undef : $conn->appl_proto;
    my $skip_topmost_received = defined($appl_proto) &&
                           ($appl_proto eq 'AM.PDP' || $appl_proto eq 'AM.CL');
    my $policyfn = sub {
      my $dkim = $_[0];
      my $signed_header_fields_ref = cr('signed_header_fields') || {};
      my $hfn = $dkim->{header_field_names};
      my(@field_names_to_be_signed);
      #
      # when $signed_header_fields_ref->{$nm} is greater than 1 it indicates
      # that one surplus occurrence of a header filed name in an 'h' tag
      # should be inserted, consequently prohibiting further instances of
      # such header field to be added to a message header section without
      # breaking a signature; useful for example for a From and Subject
      #
      if ($hfn) {
        my(%hfn_cnt);
        $hfn_cnt{lc $_}++  for @$hfn;
        for (@$hfn) {
          my $nm = lc($_);
          push(@field_names_to_be_signed, $nm);  $hfn_cnt{$nm}--;
          if (!$hfn_cnt{$nm} && $signed_header_fields_ref->{$nm} > 1) {
            # causes signing one additional null occurrence of a header field
            push(@field_names_to_be_signed, $nm);
          }
        }
      }
      @field_names_to_be_signed =
        grep($signed_header_fields_ref->{$_}, @field_names_to_be_signed);
      if ($skip_topmost_received) {  # don't sign topmost Received header field
        for my $j (0..$#field_names_to_be_signed) {
          if (lc($field_names_to_be_signed[$j]) eq 'received')
            { splice(@field_names_to_be_signed,$j,1); last }
        }
      }
      my $expiration;
      if (defined $sig_options{x}) {
        $expiration = $sig_options{x};
        my $j = int($expiration);
        $expiration = $expiration > $j ? $j+1 : $j;  # ceiling
      }
      # RFC 6531 section 3.2: Any domain name to be looked up in the DNS
      # MUST conform to and be processed as specified for Internationalizing
      # Domain Names in Applications (IDNA) [RFC5890].  When doing lookups,
      # the SMTPUTF8-aware SMTP client or server MUST either use a Unicode-
      # aware DNS library, or transform the internationalized domain name
      # to A-label form (i.e., a fully- qualified domain name that contains
      # one or more A-labels but no U-labels) as specified in RFC 5890.
      $dkim->add_signature( Mail::DKIM::Signature->new(
        Selector  => idn_to_ascii($sig_options{s}),
        Domain    => idn_to_ascii($sig_options{d}),
        Timestamp => int($msginfo->rx_time),  # floor
        Headers   => join(':', reverse @field_names_to_be_signed),
        Key       => $key,
        !defined $sig_options{c} ? () : (Method     => $sig_options{c}),
        !defined $sig_options{a} ? () : (Algorithm  => $sig_options{a}),
        !defined $sig_options{q} ? () : (Query      => $sig_options{q}),
        !defined $sig_options{i} ? () : (Identity   =>
                                mail_addr_idn_to_ascii($sig_options{i})),
        !defined $expiration     ? () : (Expiration => $expiration), # ceiling
      ));
      undef;
    };  # end sub

    my $dkim_wrapper;
    eval {
      my $dkim_signer = Mail::DKIM::Signer->new(Policy => $policyfn);
      $dkim_signer or die "Could not create a Mail::DKIM::Signer object\n";
      #
      # NOTE: dkim wrapper will strip bare CR before signing, which suits
      # forwarding by SMTP which does the same; with other forwarding methods
      # such as a pipe or milter, bare CRs in a message may break signatures
      #
      # feeding mail to a DKIM signer
      $dkim_wrapper = Amavis::Out::SMTP->new_dkim_wrapper($dkim_signer,1);
      my $msg = $msginfo->mail_text;  # a file handle or a MIME::Entity object
      my $msg_str_ref = $msginfo->mail_text_str;  # have an in-memory copy?
      $msg = $msg_str_ref  if ref $msg_str_ref;
      my $hdr_edits = $msginfo->header_edits;
      $hdr_edits = Amavis::Out::EditHeader->new  if !$hdr_edits;
      my($received_cnt,$file_position) =
        $hdr_edits->write_header($msginfo,$dkim_wrapper,!$initial_submission);
      if (!defined $msg) {
        # empty mail
      } elsif (ref $msg eq 'SCALAR') {
        # do it in chunks, saves memory, cache friendly
        while ($file_position < length($$msg)) {
          $dkim_wrapper->print(substr($$msg,$file_position,16384))
            or die "Can't write to dkim signer: $!";
          $file_position += 16384;  # may overshoot, no problem
        }
      } elsif ($msg->isa('MIME::Entity')) {
        $msg->print_body($dkim_wrapper);
      } else {
        my($nbytes,$buff);
        while (($nbytes = $msg->read($buff,16384)) > 0) {
          $dkim_wrapper->print($buff) or die "Can't write to dkim signer: $!";
        }
        defined $nbytes or die "Error reading: $!";
      }
      $dkim_wrapper->close or die "Can't close dkim wrapper: $!";
      undef $dkim_wrapper;
      $dkim_signer->CLOSE or die "Can't close dkim signer: $!";
      @signatures = $dkim_signer->signatures;
      undef $dkim_signer;
      1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(0, "dkim: signing error: %s", $eval_stat);
    };
    if (defined $dkim_wrapper) { $dkim_wrapper->close }  # ignoring status
    section_time('fwd-data-dkim');
  }

  # signatures must have all the required tags: d, s, b, bh; check to make sure
  # if (ll(5)) { do_log(5, "dkim: %s", $_->as_string) for @signatures }
  my(@sane_signatures);
  for my $s (@signatures) {
    my(@missing);
    for my $pair ( ['d', $s->domain],  ['s', $s->selector],
                   ['b', $s->data],   ['bh', $s->body_hash] ) {
      my($tag,$val) = @$pair;
      push(@missing,$tag)  if !defined($val) || $val eq '';
    }
    if (!@missing) {
      push(@sane_signatures, $s);
      # remember just the last one (typically the only one)
      $msginfo->dkim_signwith_sd( [$s->selector, $s->domain] );
    } else {
      do_log(2, "dkim: signature is missing tag %s, skipping: %s",
                 join(',',@missing), $s->as_string);
    }
  }
  @sane_signatures;
}

# Prepare Authentication-Results header fields according to RFC 7601.
#
sub generate_authentication_results($;$$) {
  my($msginfo,$allow_none,$sigs_ref) = @_;
  $sigs_ref = $msginfo->dkim_signatures_all  if @_ < 3;  # for all by default
  my $authservid = c('myauthservid');
  $authservid = c('myhostname')  if !defined $authservid || $authservid eq '';
  $authservid = idn_to_ascii($authservid);
  # note that RFC 7601 declares A-R header field as structured, which is why
  # we are inserting a \n into top-level locations suitable for folding,
  # and let sub hdr() choose suitable folding points
  my(@results, %all_b, %all_b_valid, %all_b_8);
  my($sig_cnt_dk, $sig_cnt_dkim, $result_str) = (0, 0, '');

  for my $sig (!$sigs_ref ? () : @$sigs_ref) {  # first pass
    my($sig_result, $details, $str);
    $sig_result = $sig->result;
    if (defined $sig_result) {
      $sig_result = lc $sig_result;
    } else {
      ($sig_result, $details) = ('pass', 'just generated, assumed good');
      $sig->result($sig_result, $details);
    }
    my $valid = $sig_result eq 'pass';
    if ($valid) {
      my $expiration_time = $sig->expiration;
      if (defined $expiration_time &&
          $expiration_time =~ /^0*\d{1,10}\z/ &&
          $msginfo->rx_time > $expiration_time) {
        ($sig_result, $details) = ('fail', 'good, but expired');
        $sig->result($sig_result, $details);
        $valid = 0;
      }
    }
    if ($sig->isa('Mail::DKIM::DkSignature')) { $sig_cnt_dk++ }
                                         else { $sig_cnt_dkim++ };
    my $b = $sig->data;
    if (defined $b) {
      $b =~ tr/ \t\n//d;  # remove FWS, just in case
      $all_b_8{substr($b,0,8)}++;
      $all_b{$b}++;
      $all_b_valid{$b}++  if $valid;
    }
  }

  # RFC 7601 result: none, pass, fail, policy, neutral, temperror, permerror
  # Mail::DKIM result: pass, fail, invalid, temperror, none
  for my $sig (!$sigs_ref ? () : @$sigs_ref) {  # second pass
    my $result_val;  # RFC 7601 result value
    my $sig_result = lc $sig->result;
    my $details = $sig->result_detail;
    my $valid = $sig_result eq 'pass';
    if ($valid) {
      $result_val = 'pass';
    } else {
      # map a Mail::DKIM::Signature result into an RFC 7601 result value
      $result_val = $sig_result eq 'temperror' ? 'temperror'
                  : $sig_result eq 'fail'      ? 'fail'
                  : $sig_result eq 'invalid'   ? 'neutral' : 'permerror';
    }
    my $sdid_ace = idn_to_ascii($sig->domain);
    my $str = '';
    my $add_header_b;  # RFC 6008, should we add a header.b for this signature?
    my $key_size = eval {
      my $pk = $sig->get_public_key;
      $pk && $pk->cork && $pk->cork->size * 8;
    };
    if ($sig->isa('Mail::DKIM::DkSignature')) {
      $add_header_b = 1  if $sig_cnt_dk > 1;
      my $rfc2822_sender = $msginfo->rfc2822_sender;
      my $fm = $msginfo->rfc2822_from;
      my(@rfc2822_from) = !defined($fm) ? () : ref $fm ? @$fm : $fm;
      my $id_ace = defined $sdid_ace ? '@'.$sdid_ace : '';
      $str .= ";\n domainkeys=" . $result_val;
      $str .= sprintf(' (%d-bit key)', $key_size)  if $key_size;
      if (defined $details && $details ne '' && lc $details ne lc $result_val){
        local($1);  # turn it into an RFC 2045 quoted-string
        $details =~ s{([\000-\037\177"\\])}{\\$1}gs;  # RFC 5322 qtext
        $str .= "\n reason=\"$details\"";
      }
      if (@rfc2822_from && $rfc2822_from[0] =~ /(\@[^\@]*)\z/s &&
          idn_to_ascii($1) eq $id_ace) {
        $str .= "\n header.from=" .
                join(',', map(quote_rfc2821_local($_), @rfc2822_from));
      }
      if (defined($rfc2822_sender) && $rfc2822_sender =~ /(\@[^\@]*)\z/s &&
          idn_to_ascii($1) eq $id_ace) {
        $str .= "\n header.sender=" . quote_rfc2821_local($rfc2822_sender);
      }
    } else {  # a DKIM signature
      $add_header_b = 1  if $sig_cnt_dkim > 1;
      $str .= ";\n dkim=" . $result_val;
      $str .= sprintf(' (%d-bit key)', $key_size)  if $key_size;
      if (defined $details && $details ne '' && lc $details ne lc $result_val){
        local($1);  # turn it into an RFC 2045 quoted-string
        $details =~ s{([\000-\037\177"\\])}{\\$1}gs;  # RFC 5322 qtext
        $str .= "\n reason=\"$details\"";
      }
    }

    $str .= "\n header.d=" . $sdid_ace  if defined $sdid_ace;
    my $b = $sig->data;
    if (defined $b && $add_header_b) {
      # RFC 6008: The value associated with this item in the header field
      # MUST be at least the first eight characters of the digital signature
      # (the "b=" tag from a DKIM-Signature) for which a result is being
      # relayed, and MUST be long enough to be unique among the results
      # being reported.
      $b =~ tr/ \t\n//d;  # remove FWS, just in case
      if ($b !~ m{^ [A-Za-z0-9+/]+ =* \z}xs) {  # ensure base64 syntax
        do_log(2, "generate_AR: bad signature tag b=%s", $b);
      } elsif ($all_b{$b} > 1 && $all_b_valid{$b} && !$valid) {
        # exact duplicates: do not report invalid ones if at least one is valid
        # RFC 6008 section 6.2.: a cautious implementation could discard
        # the false negative in that instance.
        do_log(2, "generate_AR: not reporting bad duplicates: %s", $b);
        $str = '';  # ditch the report for this signature
      } elsif ($all_b_8{$b} > $all_b{$b}) {
        do_log(2, "generate_AR: not reporting b for collisions: %s", $b);
      } else {
        $str .= "\n header.b=" . substr($b,0,8);
      }
    }
    $result_str .= $str;
  }
  # just provide a single A-R with all results combined
  push(@results, $result_str)  if $result_str ne '';
  push(@results, ";\n dkim=none")  if !@results && $allow_none;
  $_ = sprintf("%s (%s)%s", $authservid, $myproduct_name, $_)  for @results;
  @results;  # none, one, or more A-R header field bodies
}

# adjust spam score for each recipient so that the final spam score
# will be shifted towards a fixed score assigned to a signing domain (its
# 'reputation', as obtained through @signer_reputation_maps); the formula is:
#   adjusted_spam_score = f*reputation + (1-f)*spam_score;  0 <= f <= 1
# which has the same semantics as auto_whitelist_factor in SpamAssassin AWL
#
sub adjust_score_by_signer_reputation($) {
  my $msginfo = $_[0];
  my $reputation_factor = c('reputation_factor');
  $reputation_factor = 0  if $reputation_factor < 0;
  $reputation_factor = 1  if $reputation_factor > 1;
  my $sigs_ref = $msginfo->dkim_signatures_valid;
  if (defined $reputation_factor && $reputation_factor > 0 &&
      $sigs_ref && @$sigs_ref) {
    my($best_reputation_signer,$best_reputation_score);
    my $minimum_key_bits = c('dkim_minimum_key_bits');
    my $srm = ca('signer_reputation_maps');
    # walk through all valid signatures, find best (smallest) reputation value
    for my $sig (@$sigs_ref) {
      my $sdid = $sig->domain;
      my($val,$key) = lookup2(0, '@'.$sdid, $srm);
      if (defined $val &&
          (!defined $best_reputation_score || $val < $best_reputation_score)) {
        my $key_size;
        $key_size = eval {
          my $pk = $sig->get_public_key;
          $pk && $pk->cork && $pk->cork->size * 8 }  if $minimum_key_bits;
        if ($key_size && $key_size < $minimum_key_bits) {
          do_log(1, "dkim: reputation for signing domain %s not used, ".
                    "valid signature ignored, %d-bit key is shorter than %d",
                     $sdid, $key_size, $minimum_key_bits);
        } else {
          $best_reputation_signer = $sdid;
          $best_reputation_score = $val;
        }
      }
    }
    if (defined $best_reputation_score) {
      my $ll = 2;  # initial log level
      for my $r (@{$msginfo->per_recip_data}) {
        my $spam_level = $r->spam_level;
        next  if !defined $spam_level;
        my $new_level = $reputation_factor  * $best_reputation_score
                  +  (1-$reputation_factor) * $spam_level;
        $r->spam_level($new_level);
        my $spam_tests = 'AM.DKIM_REPUT=' .
                         (0+sprintf("%.3f", $new_level-$spam_level));
        if (!$r->spam_tests) {
          $r->spam_tests([ \$spam_tests ]);
        } else {
          unshift(@{$r->spam_tests}, \$spam_tests);
        }
        ll($ll) &&
          do_log($ll, "dkim: score %.3f adjusted to %.3f due to reputation ".
                      "(%s) of a signer domain %s",  $spam_level, $new_level,
                      $best_reputation_score, $best_reputation_signer);
        $ll = 5;  # reduce log clutter after the first recipient
      }
    }
  }
}

# check if we have a valid author domain signature, and do
# other DKIM pre-processing;  called from collect_some_dkim()
#
sub collect_some_dkim_info($) {
  my $msginfo = $_[0];

  my $rfc2822_sender = $msginfo->rfc2822_sender;
  my(@rfc2822_from) = $msginfo->rfc2822_from;
  # now that we have a parsed From, check if we have a valid
  # author domain signature and do other DKIM pre-processing
  my(@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 (!$sigs_ref ? () : @$sigs_ref) {  # for each signature
    my $valid = lc($sig->result) eq 'pass';
    my($timestamp_age, $creation_time, $expiration_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 =~ /^0*\d{1,10}\z/;
    }
    $expiration_time = $sig->expiration;
    my $expired =
      defined $expiration_time && $expiration_time =~ /^0*\d{1,10}\z/ &&
      ($msginfo->rx_time > $expiration_time ||
       ( defined $creation_time && $creation_time =~ /^0*\d{1,10}\z/ &&
         $creation_time > $expiration_time )
      );

    my($pubkey, $key_size, $eval_stat);
    eval {
      # Mail::DKIM >=0.31 caches a public key result
      $pubkey = $sig->get_public_key;  # can die with "not available"
      $pubkey or die "No public key";
      $key_size = $pubkey->cork && $pubkey->cork->size * 8;
      $key_size or die "Can't determine a public key size";
      1;
    } or do {
      $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      do_log(5, "dkim: public key s=%s d=%s, error: %s",
                $sig->selector, $sig->domain, $eval_stat);
    };
    if ($pubkey && ll(5)) {
      # RFC 6376: Although the "g=" tag has been deprecated in this version
      # of the DKIM specification (and thus MUST now be ignored), signers are
      # advised not to include the "g=" tag in key records...
      do_log(5, "dkim: public key s=%s d=%s%s, %d-bit key",
                $sig->selector, $sig->domain,
                join('', map { my $v = $pubkey->get_tag($_);
                               defined $v ? " $_=$v" : '' } qw(v g h k t s)),
                $key_size||0 );
    }

    # 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);
    my $sdid_ace = idn_to_ascii($sig->domain);
    for my $addr (@addr_list) {
      next  if !defined $addr;
      local($1); my $domain;
      $domain = $1  if $addr =~ /\@([^\@]*)\z/s;
      # turn addresses in @addr_list into booleans, representing match outcome
      $addr = defined $domain && idn_to_ascii($domain) eq $sdid_ace ? 1 : 0;
    }

  # # 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.
  # # NOTE: currently unused and commented out
  # { my(%field_counts);
  #   my(@signed_header_field_names) = map(lc($_), $sig->headerlist); # 'h' tag
  #   $field_counts{$_}++  for @signed_header_field_names;
  #   for (my $j=-1;  ; $j--) {   # walk through header fields, bottom-up
  #     my($f_ind,$fld) = $msginfo->get_header_field2(undef,$j);
  #     last if !defined $f_ind;  # reached the top
  #     local $1;
  #     my $f_name; $f_name = lc $1 if $fld =~ /^([^:]*?)[ \t]*:/s;
  #     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 domain signature (based on RFC 2822.From)
      # is a valid concept in ADSP; we are also using the same rules to match
      # against RFC 2822.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]);  # SDID 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_ace = mail_addr_idn_to_ascii($rfc2822_from[$j]);
          # query key: as-is author address for author domain signatures, and
          # author address with '/@signer-domain' appended for 3rd party sign.
          # e.g.: 'user@example.com', 'user@sub.example.com/@example.org'
          my $sdid_ace = idn_to_ascii($sig->domain);
          for my $opt ( ($addr_list[$j+2] ? '' : ()), '/@'.$sdid_ace ) {
            next  if $bn_auth_already_queried{$key_ace.$opt};
            my($result,$matchingkey) = lookup2(0,$key_ace,$atpbm,
                       Label=>'AuthToPB', $opt eq '' ? () : (AppendStr=>$opt));
            $bn_auth_already_queried{$key_ace.$opt} = 1;
            next 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';
            }
            my $minimum_key_bits = c('dkim_minimum_key_bits');
            # $result is a list of bank names as a comma-separated string
            local $1;
            my(@pbn) = map(/^\s*(\S.*?)\s*\z/s ? $1 : (), split(/,/, $result));
            if (!@pbn) {
              # no policy banks specified, nothing to do
            } elsif ($key_size && $minimum_key_bits &&
                     $key_size < $minimum_key_bits) {
              do_log(1, "dkim: policy bank %s by %s NOT LOADED, valid ".
                        "signature ignored, %d-bit key is shorter than %d",
                        join(',',@pbn), $matchingkey,
                        $key_size, $minimum_key_bits);
            } else {
              push(@bank_names, @pbn);
              ll(2) && do_log(2, "dkim: policy bank %s by %s",
                                 join(',',@pbn), $matchingkey);
            }
          }
        }
      }
    }
    ll(2) && do_log(2, "dkim: %s%s%s %s signature by d=%s, From: %s, ".
                       "a=%s, c=%s, s=%s, i=%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' : ()),
      $sig->domain, join(", ", qquote_rfc2821_local(@rfc2822_from)),
      $sig->algorithm, scalar($sig->canonicalization),
      $sig->selector, $sig->identity,
      !$msginfo->originating ? ''
        : ', ORIG [' . $msginfo->client_addr . ']:' . $msginfo->client_port,
      !defined($msginfo->is_mlist) ? '' : ", m.list(".$msginfo->is_mlist.")",
      $valid ? '' : ', '.$sig->result_detail,
    );
    $sig_ind++;
  }
  Amavis::load_policy_bank($_,$msginfo) for @bank_names;
  $msginfo->originating(c('originating'));
  $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,$fld) = $msginfo->get_header_field2(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));
#   }
# }
}

1;

__DATA__
#
package Amavis::Tools;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&show_or_test_dkim_public_keys &generate_dkim_private_key
                  &convert_dkim_keys_file);
  import Amavis::Conf qw(:platform c cr ca
                  @dkim_signing_keys_list @dkim_signing_keys_storage);
  import Amavis::Util qw(untaint ll do_log
                  safe_encode_utf8_inplace idn_to_ascii idn_to_utf8);
  import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp);
}
use subs @EXPORT_OK;

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

# Prints DNS TXT resource records for corresponding DKIM private keys (as
# previously declared by calls to dkim_key) in a format directly suitable
# for inclusion in DNS zone files. If an argument is provided the result is
# restricted to listed domains only, otherwise RR for all domains are shown.
# Note that a domain may have more than one RR: one RR for each selector.
#
# When a search argument is provided (even if '.'), the printed list is
# sorted according to reversed domain labels (e.g. com.example.sub.host),
# entries with the same domain are kept in original order. When there are
# no search arguments, the original order is retained.
#
sub show_or_test_dkim_public_keys($$) {
  my($cmd,$args) = @_;
  # when list is empty all domains are implied
  my(@seek_domains) = map(idn_to_ascii($_), @$args);
  my(@sort_list) = map { my $d = lc($dkim_signing_keys_list[$_]->{domain});
                         my $d_re = $dkim_signing_keys_list[$_]->{domain_re};
                         [$_, $d, $d_re, join('.',reverse split(/\./,$d,-1))] }
                       0 .. $#dkim_signing_keys_list;
  if (@seek_domains) {  # sort only when there are any search arguments present
    @sort_list = sort {$a->[3] cmp $b->[3] || $a->[0] <=> $b->[0]} @sort_list;
  }
  my $any = 0;
  for my $e (@sort_list) {
    my($j,$domain,$domain_re) = @$e;  local($1);
    safe_encode_utf8_inplace($domain);  # to octets (if not already)
    my $domain_ace = idn_to_ascii($domain);
    next  if @seek_domains &&
             !grep { defined $domain_re ? lc($_) =~ /$domain_re/
                     : /^\.(.*)\z/s ?
                       $domain_ace eq lc($1) ||
                         $domain_ace =~ /(?:\.|\z)\Q$1\E\z/si
                     : $domain_ace eq lc($_) } @seek_domains;
    $any++;
    my $key_opts = $dkim_signing_keys_list[$j];
    if ($cmd eq 'testkeys' || $cmd eq 'testkey') {
      test_dkim_key(%$key_opts);
    } else {
      my $selector = $key_opts->{selector};
      safe_encode_utf8_inplace($selector);  # to octets (if not already)
      my $selector_ace = idn_to_ascii($selector);
      my $key_storage_ind = $key_opts->{key_storage_ind};
      my($key,$dev,$inode,$fname) =
        @{ $dkim_signing_keys_storage[$key_storage_ind] };
      my(@pub) = split(/\r?\n/, $key->get_public_key_x509_string);
      @pub = grep(!/^---.*?---\z/ && !/^[ \t]*\z/, @pub);
      my(@tags) = map($_.'='.$key_opts->{$_},
                      grep(defined $key_opts->{$_}, qw(v g h k s t n)));
      my $key_size = 8 * $key->size;
      printf("; key#%d %d bits, i=%s, d=%s%s\n",
             $key_opts->{key_ind} + 1, $key_size,
             $selector, $domain,
             defined $fname ? ', '.$fname : '');
      printf("; CANNOT DECLARE A WILDCARDED LABEL IN DNS, ".
             "AVOID OR EDIT MANUALLY!\n")  if defined $key_opts->{domain_re};
      printf("%s._domainkey.%s.\t%s TXT (%s)\n\n",
             $selector_ace, $domain_ace, '3600',
             join('', map("\n" . '  "' . $_ . '"',
                          join('; ',@tags,'p='), @pub)) );
    }
  }
  if (!@dkim_signing_keys_list) {
    printf("No DKIM private keys declared in a config file.\n");
  } elsif (!$any) {
    printf("No DKIM private keys match the selection list.\n");
  }
}

sub test_dkim_key(@) {
  my(%key_options) = @_;
  my $now = Time::HiRes::time;
  my $key_storage_ind = $key_options{key_storage_ind};
  my($key,$dev,$inode,$fname) =
    @{ $dkim_signing_keys_storage[$key_storage_ind] };
  if (UNIVERSAL::isa($key,'Crypt::OpenSSL::RSA')) {
    $key = Mail::DKIM::PrivateKey->load(Cork => $key);  # avail since 0.31
    # my $pkcs1 = $key->get_private_key_string;  # most compact
    # $pkcs1 =~ s/^---.*?---(?:\r?\n|\z)//gm;  $pkcs1 =~ tr/\r\n//d;
    # $key = Mail::DKIM::PrivateKey->load(Data => $pkcs1);
  }
  my $domain = idn_to_utf8($key_options{domain});
  my $domain_ace = idn_to_ascii($domain);
  my $selector_ace = idn_to_ascii($key_options{selector});
  my $policyfn = sub {
    my $dkim = $_[0];
    $dkim->add_signature( Mail::DKIM::Signature->new(
      Selector => $selector_ace, Domain => $domain_ace,
      Method => 'simple/simple', Algorithm => 'rsa-sha256',
      Timestamp => int($now), Expiration => int($now)+24*3600, Key => $key,
    )); undef;
  };
  my $msg = sprintf(
    "From: test\@%s\nMessage-ID: <123\@%s>\nDate: %s\nSubject: test\n\ntest\n",
    $domain, $domain, rfc2822_timestamp($now));
  $msg =~ s{\n}{\015\012}gs;
  my(@gen_signatures, @read_signatures);
  eval {
    my $dkim_signer = Mail::DKIM::Signer->new(Policy => $policyfn);
    $dkim_signer or die "Could not create a Mail::DKIM::Signer object";
    $dkim_signer->PRINT($msg) or die "Can't write to dkim: $!";
    $dkim_signer->CLOSE or die "Can't close dkim signer: $!";
    @gen_signatures = $dkim_signer->signatures;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    print STDERR "dkim signing failed: $eval_stat\n";
  };
  $msg = $_->as_string . "\015\012" . $msg  for @gen_signatures;
  eval {
    my $dkim_verifier = Mail::DKIM::Verifier->new;
    $dkim_verifier or die "Could not create a Mail::DKIM::Verifier object";
    $dkim_verifier->PRINT($msg) or die "Can't write to dkim: $!";
    $dkim_verifier->CLOSE or die "Can't close dkim_verifier: $!";
    @read_signatures = $dkim_verifier->signatures;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    print STDERR "dkim verification failed: $eval_stat\n";
  };
# printf("%s\n", $fname)  if defined $fname;
  printf("TESTING#%d %s: %s => %s\n",
         $key_options{key_ind} + 1, $domain,
         $_->selector . '._domainkey.' . $_->domain,
         $_->result_detail)  for @read_signatures;
}

sub generate_dkim_private_key(@) {
  my($fname,$nbits) = @_;
  my $fh;
  eval {
    $nbits = 1024  if !defined($nbits) || $nbits eq '';
    $nbits =~ /^\d+\z/  or die "Number of bits in a key must be numeric\n";
    $nbits >= 512
      or die "Number of bits is below 512 (suggested 1024..2048)\n";
    $nbits <= 4096
      or die "Number of bits too large (suggested 1024..2048)\n";
    defined $fname && $fname ne ''
      or die "File name for a key not provided\n";
    $nbits >= 1024
      or printf STDERR ("INFO: RFC 6376 states: Signers MUST use RSA keys ".
                        "of at least 1024 bits for long-lived keys.\n");
    $fh = IO::File->new;
    $fh->open(untaint($fname), O_CREAT|O_EXCL|O_RDWR, 0600)
      or die "Can't create file \"$fname\": $!\n";
    my $rsa = Crypt::OpenSSL::RSA->generate_key($nbits);
    $fh->print($rsa->get_private_key_string)
      or die "Error writing key to a file \"$fname\": $!\n";
    $fh->close or die "Can't close file \"$fname\": $!\n";
    undef $fh;
    printf STDERR ("Private RSA key successfully written to file \"%s\" ".
                   "(%d bits, PEM format) \n", $fname,$nbits);
    1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    $fh->close  if defined $fh;  # ignoring status
    die "genrsa: $eval_stat\n";
  }
}

# Reads a dkim-filter -compatible key specifications. From the dkim-filter
# man page: The keyfile should contain a set of lines of the form
# sender-pattern:signing-domain:keypath where sender-pattern is a pattern
# to match against message senders (with a special character "*" interpreted
# as "zero or more characters"), signing-domain is the domain to announce as
# the signing domain when generating signatures (or a '*', implying author's
# domain), and keypath is a path to the PEM-formatted private key to be used
# for signing messages which match the sender-pattern. The selector used in
# the signature will be the filename portion of keypath. A line starting
# with "/" is interpreted as a root directory for keys, meaning the keypath
# values after that line in the file are taken relative to that path. If a
# file referenced by keypath cannot be opened, the filter will try again by
# appending ".pem" and then ".private".  '#'-delimited comments and blank
# lines are ignored.
#
sub convert_dkim_keys_file($) {
  my $keysfile = $_[0];
  my $inp = IO::File->new;
  $inp->open($keysfile,'<')
    or die "dkim_key_file: Can't open file $keysfile for reading: $!";
  my($basedir,@options,@opt_re,%domain_selectors); my $rn = 0; my $ln;
  for ($! = 0; defined($ln=$inp->getline); $! = 0) {
    chomp($ln); $rn++; local($1); my($selector,$key_fn);
    if ($ln =~ /^ \s* (?: \# | \z)/xs) {
      # skip empty and all-comment lines
    } elsif ($ln =~ m{^/}) {
      $basedir = $ln;  $basedir .= '/' if $basedir !~ m{/\z};
    } else {
      my($sender_pattern, $signing_domain, $keypath) =
        map { my $s = $_; $s =~ s/^\s+//; $s =~ s/\s+\z//; $s }
            split(/:/, $ln, 3);
      defined $sender_pattern && $sender_pattern ne ''
        or die "Error in $keysfile, empty sender pattern, line $rn: $ln\n";
      defined $keypath && $keypath ne ''  ||  $signing_domain eq ''
        or die "Error in $keysfile, empty file name field, line $rn: $ln\n";
      $keypath = $basedir . $keypath  if defined $basedir && $keypath !~ m{^/};
      for my $ext ('', '.pem', '.private') {
        my $errn = stat($keypath.$ext) ? 0 : 0+$!;
        if ($errn != ENOENT) { $key_fn = $keypath.$ext; last }
      }
      defined $key_fn
        or die "File $keypath does not exist, $keysfile line $rn: $ln\n";
      $selector = lc($1)  if $keypath =~ m{ (?: ^ | / ) ( [^/]+? )
                                            (?: \.pem | \.private )? \z }xs;
      # must convert sender pattern to unquoted form to match actual addresses
      my $sender_domain;
      if ($sender_pattern eq '*' || $sender_pattern eq '*@*') {
        $sender_pattern = $sender_domain = '*';
      } else {
        my $sender_localpart;
        ($sender_localpart, $sender_domain) =
          Amavis::rfc2821_2822_Tools::split_address(
           Amavis::rfc2821_2822_Tools::unquote_rfc2821_local($sender_pattern));
        $sender_domain =~ s/^\@//;
        $sender_pattern = $sender_localpart.'@'.idn_to_ascii($sender_domain);
      }
      if ($signing_domain eq '*') { $signing_domain = $sender_domain }
      $signing_domain = idn_to_ascii($signing_domain);
      if ($signing_domain ne '' &&
          !$domain_selectors{$signing_domain}{$selector}) {
      # dkim_key($signing_domain,$selector,$key_fn);  # declare a signing key
        printf("dkim_key(%-18s %-12s '%s');\n",
               "'".$signing_domain."',", "'".$selector."',", $key_fn);
        $domain_selectors{$signing_domain}{$selector} = 1;
      }
      if ($signing_domain eq $sender_domain) { $signing_domain = '*' }
      push(@options, [$sender_pattern, $signing_domain, $selector]);
    }
  }
  defined $ln || $! == 0  or die "Error reading from $keysfile: $!";
  $inp->close or die "Error closing $keysfile: $!";
  #
  # prepare by_sender signature options lookup table when non-default
  # signing is required (e.g. third-party signatures)
  #
  my $in_options = 0;
  for my $opt (@options) {
    my($sender_pattern, $signing_domain, $selector) = @$opt;
    if ($signing_domain eq '*') {
      # implies author domain signature, no need for special options
    } else {
      $sender_pattern =~ s/\*{2,}/*/gs;   # collapse successive wildcards
      $sender_pattern =~  # '*' is a wildcard, quote the rest
        s{ ([@\#/.^\$|*+?(){}\[\]\\]) }{ $1 eq '*' ? '.*' : '\\'.$1 }xgse;
      $sender_pattern = '^' . $sender_pattern . '\\z';  # implicit anchors
      # remove trailing first, leading next, preferring /^.*\z/ -> /^/, not /\z/
      $sender_pattern =~ s/\.\*\\z\z//s;  # remove trailing anchor if redundant
      $sender_pattern =~ s/^\^\.\*//s;    # remove leading anchor if redundant
      $sender_pattern = '(?:)'  if $sender_pattern eq '';  # just in case
      $signing_domain = undef if $signing_domain eq '';
      $selector = undef       if $selector       eq '';
      # case insensitive matching for compatibility with dkim-milter
      push(@opt_re, [ qr/$sender_pattern/is =>
                        ( !defined($signing_domain) ||
                          keys(%{$domain_selectors{$signing_domain}})==1
                          ? { d => $signing_domain }
                          : { d => $signing_domain, s => $selector } ) ]);
      if (!$in_options) {
        printf("\n%s\n", '@dkim_signature_options_bysender_maps = (new_RE(');
        $in_options = 1;
      }
      printf("  [ %-30s => { d=>%s%s} ],\n",
           'qr/' . $sender_pattern . '/is',
           !defined($signing_domain) ? 'undef' : "'".$signing_domain."'",
           !defined($signing_domain) ||
           keys %{$domain_selectors{$signing_domain}} == 1 ? ''
             : !defined($selector) ? ', s=>undef' : ", s=>'".$selector."'");
    }
  }
  printf("%s\n", '));')  if $in_options;
# use Devel::Peek qw(Dump);
# use Data::Dump (); Data::Dump::dump(@opt_re);
# unshift(@dkim_signature_options_bysender_maps,
#         Amavis::Lookup::RE->new(@opt_re))  if @opt_re;
}

1;

__DATA__
#
# =============================================================================
# This text section governs how a main per-message amavisd-new log entry (at
# log level 0) is formed (config variable $log_short_templ). Empty disables it.
[?%#D|#|Passed #
[? [:ccat|major] |#
OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER-[:ccat|minor]|SPAMMY|SPAM|\
UNCHECKED[?[:ccat|minor]||-ENCRYPTED|]|BANNED (%F)|INFECTED (%V)]#
 {[:actions_performed]}#
,[?%p|| %p][?%a||[?%l|| LOCAL] [:client_addr_port]][?%e|| \[%e\]] [:mail_addr_decode_octets|%s] -> [%D|[:mail_addr_decode_octets|%D]|,]#
[? %q ||, quarantine: %q]#
[? %Q ||, Queue-ID: %Q]#
[? %m ||, Message-ID: [:mail_addr_decode_octets|%m]]#
[? %r ||, Resent-Message-ID: [:mail_addr_decode_octets|%r]]#
[? %i ||, mail_id: %i]#
, Hits: [:SCORE]#
, size: %z#
[? [:partition_tag] ||, pt: [:partition_tag]]#
[~[:remote_mta_smtp_response]|["^$"]||[", queued_as: "]]\
[remote_mta_smtp_response|[~%x|["queued as ([0-9A-Za-z]+)$"]|["%1"]|["%0"]]|/]#
#, Subject: [:dquote|[:mime2utf8|[:header_field_octets|Subject]|100|1]]#
#, From: [:uquote|[:mail_addr_decode_octets|[:rfc2822_from]]]#
#[? %#T ||, Tests: \[[%T|,]\]]#
[? [:dkim|sig_sd]    ||, dkim_sd=[:dkim|sig_sd]]#
[? [:dkim|newsig_sd] ||, dkim_new=[:dkim|newsig_sd]]#
, %y ms#
]
[?%#O|#|Blocked #
[? [:ccat|major|blocking] |#
OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER-[:ccat|minor]|SPAMMY|SPAM|\
UNCHECKED[?[:ccat|minor]||-ENCRYPTED|]|BANNED (%F)|INFECTED (%V)]#
 {[:actions_performed]}#
,[?%p|| %p][?%a||[?%l|| LOCAL] [:client_addr_port]][?%e|| \[%e\]] [:mail_addr_decode_octets|%s] -> [%O|[:mail_addr_decode_octets|%O]|,]#
[? %q ||, quarantine: %q]#
[? %Q ||, Queue-ID: %Q]#
[? %m ||, Message-ID: [:mail_addr_decode_octets|%m]]#
[? %r ||, Resent-Message-ID: [:mail_addr_decode_octets|%r]]#
[? %i ||, mail_id: %i]#
, Hits: [:SCORE]#
, size: %z#
[? [:partition_tag] ||, pt: [:partition_tag]]#
#, Subject: [:dquote|[:mime2utf8|[:header_field_octets|Subject]|100|1]]#
#, From: [:uquote|[:mail_addr_decode_octets|[:rfc2822_from]]]#
#[? %#T ||, Tests: \[[%T|,]\]]#
[? [:dkim|sig_sd]    ||, dkim_sd=[:dkim|sig_sd]]#
[? [:dkim|newsig_sd] ||, dkim_new=[:dkim|newsig_sd]]#
, %y ms#
]
__DATA__
#
# =============================================================================
# This text section governs how a verbose per-message amavisd-new log entry
# is formed (config variable $log_verbose_templ). An empty text will prevent
# a verbose log entry, multiline text will produce multiple log entries, one
# for each nonempty line. Syntax is explained in the README.customize file.
[?%#D|#|Passed #
[? [:ccat|major] |#
OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER-[:ccat|minor]|SPAMMY|SPAM|\
UNCHECKED[?[:ccat|minor]||-ENCRYPTED|]|BANNED (%F)|INFECTED (%V)]#
 {[:actions_performed]}#
,[?%p|| %p][?%a||[?%l|| LOCAL] [:client_addr_port]][?%e|| \[%e\]] [:client_protocol]/[:protocol] [:mail_addr_decode_octets|%s] -> [%D|[:mail_addr_decode_octets|%D]|,]#
#, ([ip_trace_public|%x| < ])#
, ([ip_proto_trace_public|%x| < ])#
[? [:tls_in] ||, tls: [:tls_in]]#
[? %q ||, quarantine: %q]#
[? %Q ||, Queue-ID: %Q]#
[? %m ||, Message-ID: [:mail_addr_decode_octets|%m]]#
[? %r ||, Resent-Message-ID: [:mail_addr_decode_octets|%r]]#
, mail_id: %i#
#, secret_id: [:secret_id]#
, b: [:substr|[:b64urlenc|[:body_digest]]|0|9]#
, Hits: [:SCORE]#
, size: %z#
[? [:partition_tag] ||, pt: [:partition_tag]]#
[~[:remote_mta_smtp_response]|["^$"]||[", queued_as: "]]\
[remote_mta_smtp_response|[~%x|["queued as ([0-9A-Za-z]+)$"]|["%1"]|["%0"]]|/]#
, Subject: [:dquote|[:mime2utf8|[:header_field_octets|Subject]|100|1]]#
, From: [:uquote|[:mail_addr_decode_octets|[:rfc2822_from]]]#
[? [:dkim|author] || (dkim:AUTHOR)]#
[? [:useragent|name]   ||, [:useragent|name]: [:uquote|[:useragent|body]]]#
, helo=[:client_helo]#
[? %#T ||, Tests: \[[%T|,]\]]#
#[:supplementary_info|VERSION|, SA: %%s]#
#[:supplementary_info|RULESVERSION|, rules: %%s]#
[? [:banning_rule_key]     ||, b.key=[:banning_rule_key]]#
[? [:banning_rule_comment] ||, b.com=[:banning_rule_comment]]#
[? [:banning_rule_rhs]     ||, b.rhs=[:banning_rule_rhs]]#
[? [:banned_parts_as_attr] ||, b.parts=[:banned_parts_as_attr]]#
[:supplementary_info|SCTYPE|, shortcircuit=%%s]#
[:supplementary_info|AUTOLEARN|, autolearn=%%s]#
[:supplementary_info|AUTOLEARNSCORE|, autolearnscore=%%s]#
[? [:supplementary_info|LANGUAGES] ||, languages=[:uquote|[:supplementary_info|LANGUAGES]]]#
[? [:supplementary_info|RELAYCOUNTRY] ||, relaycountry=[:uquote|[:supplementary_info|RELAYCOUNTRY]]]#
[? [:supplementary_info|ASN] ||, asn=[:uquote|[:supplementary_info|ASN] [:supplementary_info|ASNCIDR]]]#
#[? [:supplementary_info|DCCB] ||, dcc=[:supplementary_info|DCCB]:[:uquote|[:supplementary_info|DCCR]]]#
#[? [:supplementary_info|DCCREP] ||, dcc_rep=[:supplementary_info|DCCREP]]#
#[:supplementary_info|AWLSIGNERMEAN|, signer_avg=%%s]#
#[? [:dkim|domain]   ||, dkim_d=[:dkim|domain]]#
[? [:dkim|identity]  ||, dkim_i=[:dkim|identity]]#
[? [:dkim|sig_sd]    ||, dkim_sd=[:dkim|sig_sd]]#
[? [:dkim|newsig_sd] ||, dkim_new=[:dkim|newsig_sd]]#
[? [:rusage|ru_maxrss] ||, rss=[:rusage|ru_maxrss]]#
, %y ms#
]
[?%#O|#|Blocked #
[? [:ccat|major|blocking] |#
OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER-[:ccat|minor]|SPAMMY|SPAM|\
UNCHECKED[?[:ccat|minor]||-ENCRYPTED|]|BANNED (%F)|INFECTED (%V)]#
 {[:actions_performed]}#
,[?%p|| %p][?%a||[?%l|| LOCAL] [:client_addr_port]][?%e|| \[%e\]] [:client_protocol]/[:protocol] [:mail_addr_decode_octets|%s] -> [%O|[:mail_addr_decode_octets|%O]|,]#
#, ([ip_trace_public|%x| < ])#
, ([ip_proto_trace_public|%x| < ])#
[? [:tls_in] ||, tls: [:tls_in]]#
[? %q ||, quarantine: %q]#
[? %Q ||, Queue-ID: %Q]#
[? %m ||, Message-ID: [:mail_addr_decode_octets|%m]]#
[? %r ||, Resent-Message-ID: [:mail_addr_decode_octets|%r]]#
, mail_id: %i#
#, secret_id: [:secret_id]#
, b: [:substr|[:b64urlenc|[:body_digest]]|0|9]#
, Hits: [:SCORE]#
, size: %z#
[? [:partition_tag] ||, pt: [:partition_tag]]#
, Subject: [:dquote|[:mime2utf8|[:header_field_octets|Subject]|100|1]]#
, From: [:uquote|[:mail_addr_decode_octets|[:rfc2822_from]]]#
[? [:dkim|author] || (dkim:AUTHOR)]#
[? [:useragent|name]   ||, [:useragent|name]: [:uquote|[:useragent|body]]]#
, helo=[:client_helo]#
[? %#T ||, Tests: \[[%T|,]\]]#
#[:supplementary_info|VERSION|, SA: %%s]#
#[:supplementary_info|RULESVERSION|, rules: %%s]#
[? [:banning_rule_key]     ||, b.key=[:banning_rule_key]]#
[? [:banning_rule_comment] ||, b.com=[:banning_rule_comment]]#
[? [:banning_rule_rhs]     ||, b.rhs=[:banning_rule_rhs]]#
[? [:banned_parts_as_attr] ||, b.parts=[:banned_parts_as_attr]]#
[:supplementary_info|SCTYPE|, shortcircuit=%%s]#
[:supplementary_info|AUTOLEARN|, autolearn=%%s]#
[:supplementary_info|AUTOLEARNSCORE|, autolearnscore=%%s]#
[? [:supplementary_info|LANGUAGES] ||, languages=[:uquote|[:supplementary_info|LANGUAGES]]]#
[? [:supplementary_info|RELAYCOUNTRY] ||, relaycountry=[:uquote|[:supplementary_info|RELAYCOUNTRY]]]#
[? [:supplementary_info|ASN] ||, asn=[:uquote|[:supplementary_info|ASN] [:supplementary_info|ASNCIDR]]]#
#[? [:supplementary_info|DCCB] ||, dcc=[:supplementary_info|DCCB]:[:uquote|[:supplementary_info|DCCR]]]#
#[? [:supplementary_info|DCCREP] ||, dcc_rep=[:supplementary_info|DCCREP]]#
#[:supplementary_info|AWLSIGNERMEAN|, signer_avg=%%s]#
#[? [:dkim|domain]   ||, dkim_d=[:dkim|domain]]#
[? [:dkim|identity]  ||, dkim_i=[:dkim|identity]]#
[? [:dkim|sig_sd]    ||, dkim_sd=[:dkim|sig_sd]]#
[? [:dkim|newsig_sd] ||, dkim_new=[:dkim|newsig_sd]]#
[? [:rusage|ru_maxrss] ||, rss=[:rusage|ru_maxrss]]#
, %y ms#
]
__DATA__
#
# =============================================================================
# This text section governs how a main per-recipient amavisd-new log entry
# is formed (config variable $log_recip_templ). An empty text will prevent a
# log entry, multi-line text will produce multiple log entries, one for each
# nonempty line. Macro %. might be useful, it counts recipients starting
# from 1. Syntax is explained in the README.customize file.
# Long header fields will be automatically wrapped by the program.
#
[?%#D|#|Passed #
#([:ccat|name|main]) #
[? [:ccat|major] |OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER|SPAMMY|SPAM|\
UNCHECKED|BANNED (%F)|INFECTED (%V)]#
, [:mail_addr_decode_octets|%s] -> [%D|[:mail_addr_decode_octets|%D]|,], Hits: %c#
, tag=[:tag_level], tag2=[:tag2_level], kill=[:kill_level]#
[~[:remote_mta_smtp_response]|["^$"]||\
["queued as ([0-9A-Za-z]+)"]|[", queued_as: %1"]|[", fwd: %0"]]#
, %0/%1/%2/%k#
]
[?%#O|#|Blocked #
#([:ccat|name|blocking]) #
[? [:ccat|major|blocking] |#
OTHER|CLEAN|MTA-BLOCKED|OVERSIZED|BAD-HEADER|SPAMMY|SPAM|\
UNCHECKED|BANNED (%F)|INFECTED (%V)]#
, [:mail_addr_decode_octets|%s] -> [%D|[:mail_addr_decode_octets|%D]|,], Hits: %c#
, tag=[:tag_level], tag2=[:tag2_level], kill=[:kill_level]#
, %0/%1/%2/%k#
]
__DATA__
#
# =============================================================================
# This is a template for (neutral: non-virus, non-spam, non-banned)
# DELIVERY STATUS NOTIFICATIONS to sender.
# For syntax and customization instructions see README.customize.
# The From, To and Date header fields will be provided automatically.
# Long header fields will be automatically wrapped by the program.
#
Subject: [?%#D|Undeliverable mail|Delivery status notification]\
[? [:ccat|major] |||, MTA-BLOCKED\
|, OVERSIZED message\
|, invalid header section[=explain_badh|1]\
[?[:ccat|minor]||: bad MIME|: unencoded 8-bit character\
|: improper use of control char|: all-whitespace header line\
|: header line longer than 998 characters|: header field syntax error\
|: missing required header field|: duplicate header field|]\
|, UNSOLICITED BULK EMAIL apparently from you\
|, UNSOLICITED BULK EMAIL apparently from you\
|, contents UNCHECKED\
|, BANNED contents type (%F)\
|, VIRUS in message apparently from you (%V)\
]
Message-ID: <DSN%i@%h>

[? %#D |#|Your message WAS SUCCESSFULLY RELAYED to:\
[%D|\n  [:mail_addr_decode|%D]|]

[~[:dsn_notify]|["\\bSUCCESS\\b"]|\
and you explicitly requested a delivery status notification on success.\n]\
]
[? %#N |#|The message WAS NOT relayed to:\
[%N|\n  [:mail_addr_decode|%N]|]
]
[:wrap|78|||This [?%#D|nondelivery|delivery] report was \
generated by the program amavisd-new at host %h. \
Our internal reference code for your message is %n/%i]

# ccat_min 0: other,  1: bad MIME,  2: 8-bit char,  3: NUL/CR,
#          4: empty,  5: long,  6: syntax,  7: missing,  8: multiple
[? [:explain_badh] ||[? [:ccat|minor]
|INVALID HEADER
|INVALID HEADER: BAD MIME HEADER SECTION OR BAD MIME STRUCTURE
|INVALID HEADER: INVALID NON-ASCII CHARACTERS IN HEADER SECTION
|INVALID HEADER: INVALID CONTROL CHARACTERS IN HEADER SECTION
|INVALID HEADER: FOLDED HEADER FIELD LINE MADE UP ENTIRELY OF WHITESPACE
|INVALID HEADER: HEADER LINE LONGER THAN RFC 5322 LIMIT OF 998 CHARACTERS
|INVALID HEADER: HEADER FIELD SYNTAX ERROR
|INVALID HEADER: MISSING REQUIRED HEADER FIELD
|INVALID HEADER: DUPLICATE HEADER FIELD
|INVALID HEADER
]
[[:wrap|78|  |  |%X]\n]
]\
#
[:wrap|78||  |Return-Path: [:mail_addr_decode|%s][?[:dkim|envsender]|| (OK)]]
[:wrap|78||  |From: [:mime_decode|[:header_field_octets|From]|100]\
[?[:dkim|author]|| (dkim:AUTHOR)]]
[? [:header_field|Sender]|#|\
[:wrap|78||  |Sender: [:mime_decode|[:header_field_octets|Sender]|100]\
[?[:dkim|sender]|| (dkim:SENDER)]]]
[? %m |#|[:wrap|78||  |Message-ID: [:mail_addr_decode|%m]]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: [:mail_addr_decode|%r]]]
[? %#X|#|[? [:useragent] |#|[:wrap|78||  |[:useragent]]]]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]

# ccat_min 0: other,  1: bad MIME,  2: 8-bit char,  3: NUL/CR,
#          4: empty,  5: long,  6: syntax,  7: missing,  8: multiple
[? [:explain_badh] ||[? [:ccat|minor]
|# 0: other
|# 1: bad MIME
|# 2: 8-bit char
WHAT IS AN INVALID CHARACTER IN A MAIL HEADER SECTION?

  The RFC 5322 document specifies rules for forming internet messages.
  It does not allow the use of characters with codes above 127 to be
  used directly (non-encoded) in a mail header section.

  If such characters (e.g. with diacritics, or non-Latin) from UTF-8
  or other character set need to be included in a message header
  section, such message needs to be submitted to an SMTPUTF8-capable
  mailer (RFC 6532), or these characters need to be properly encoded
  according to RFC 2047.

  Necessary encoding is normally done transparently by a mail reader
  or other mail generating software. If automatic encoding is not
  available (e.g. by some old MUA) it is a user's responsibility
  to avoid using such characters in a header section, or to encode
  them manually. Typically offending header fields in this category
  are 'Subject', 'Organization', and comment fields or display names
  in e-mail addresses of 'From', 'To', or 'Cc'.

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

  If you don't know how to fix or avoid the problem, please report it
  to _your_ postmaster or system manager.
#
[~[:useragent]|^X-Mailer:\\s*Microsoft Outlook Express 6\\.00|["
  If using Microsoft Outlook Express as your MUA, make sure its
  settings under:
     Tools -> Options -> Send -> Mail Sending Format -> Plain & HTML
  are: "MIME format" MUST BE selected,
  and  "Allow 8-bit characters in headers" MUST NOT be enabled!
"]]#
|# 3: NUL/CR
IMPROPER USE OF CONTROL CHARACTER IN A MESSAGE HEADER SECTION

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

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

  The RFC 5322 document specifies rules for forming internet messages.
  Section '2.1.1. Line Length Limits' prohibits each line of a header
  section to be more than 998 characters in length (excluding the CRLF).
|# 6: syntax
|# 7: missing
MISSING REQUIRED HEADER FIELD

  The RFC 5322 document specifies rules for forming internet messages.
  Section '3.6. Field Definitions' specifies that certain header fields
  are required (origination date field and the "From:" originator field).
|# 8: multiple
DUPLICATE HEADER FIELD

  The RFC 5322 document specifies rules for forming internet messages.
  Section '3.6. Field Definitions' specifies that certain header fields
  must not occur more than once in a message header section.
|# other
]]#
__DATA__
#
# =============================================================================
# This is a template for VIRUS/BANNED SENDER NOTIFICATIONS.
# For syntax and customization instructions see README.customize.
# The From, To and Date header fields will be provided automatically.
# Long header fields will be automatically wrapped by the program.
#
Subject: [? [:ccat|major]
|Clean message from you\
|Clean message from you\
|Clean message from you (MTA blocked)\
|OVERSIZED message from you\
|BAD-HEADER in message from you\
|Spam claiming to be from you\
|Spam claiming to be from you\
|A message with UNCHECKED contents from you\
|BANNED contents from you (%F)\
|VIRUS in message apparently from you (%V)\
]
[? %m  |#|In-Reply-To: [:mail_addr_decode|%m]]
Message-ID: <VS%i@%h>

[? [:ccat|major] |Clean|Clean|MTA-BLOCKED|OVERSIZED|INVALID HEADER|\
Spammy|Spam|UNCHECKED contents|BANNED CONTENTS ALERT|VIRUS ALERT]

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

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

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

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: [:client_addr_port] %g]]

[:wrap|78||  |Received trace: [ip_proto_trace_all|%x| < ]]

[:wrap|78||  |Return-Path: [:mail_addr_decode|%s][?[:dkim|envsender]|| (OK)]]
[:wrap|78||  |From: [:mime_decode|[:header_field_octets|From]|100]\
[?[:dkim|author]|| (dkim:AUTHOR)]]
[? [:header_field|Sender]|#|\
[:wrap|78||  |Sender: [:mime_decode|[:header_field_octets|Sender]|100]\
[?[:dkim|sender]|| (dkim:SENDER)]]]
[? %m |#|[:wrap|78||  |Message-ID: [:mail_addr_decode|%m]]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: [:mail_addr_decode|%r]]]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]

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

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

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

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

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

- encrypted using pgp, gpg or other encryption methods;

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

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

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

The purpose of these restrictions is to avoid the most common
propagation methods used by viruses and other malware. These often
exploit automatic mechanisms and security holes in more popular
mail readers. By requiring an explicit and decisive action from a
recipient to decode mail, a danger of automatic malware propagation
is largely reduced.
#
# Details of our mail restrictions policy are available at ...

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

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

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: [:client_addr_port] %g]]

[:wrap|78||  |Received trace: [ip_proto_trace_all|%x| < ]]

[:wrap|78||  |Return-Path: [:mail_addr_decode|%s][?[:dkim|envsender]|| (OK)]]
[:wrap|78||  |From: [:mime_decode|[:header_field_octets|From]|100]\
[?[:dkim|author]|| (dkim:AUTHOR)]]
[? [:header_field|Sender]|#|\
[:wrap|78||  |Sender: [:mime_decode|[:header_field_octets|Sender]|100]\
[?[:dkim|sender]|| (dkim:SENDER)]]]
[? %m |#|[:wrap|78||  |Message-ID: [:mail_addr_decode|%m]]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: [:mail_addr_decode|%r]]]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]
[? %q |Not quarantined.|The message has been quarantined as: %q]

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

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

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

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

in an email to you [? %#V |from:|from probably faked sender:]
  [:mail_addr_decode|%o]
[? %#V |#|claiming to be: [:mail_addr_decode|%s]]

Content type: [:ccat|name|main]#
[? [:ccat|is_blocked_by_nonmain] ||, blocked for [:ccat|name]]
Our internal reference code for your message is %n/%i

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: [:client_addr_port] %g]]

[:wrap|78||  |Received trace: [ip_proto_trace_all|%x| < ]]

[:wrap|78||  |Return-Path: [:mail_addr_decode|%s][?[:dkim|envsender]|| (OK)]]
[:wrap|78||  |From: [:mime_decode|[:header_field_octets|From]|100]\
[?[:dkim|author]|| (dkim:AUTHOR)]]
[? [:header_field|Sender]|#|\
[:wrap|78||  |Sender: [:mime_decode|[:header_field_octets|Sender]|100]\
[?[:dkim|sender]|| (dkim:SENDER)]]]
[? %m |#|[:wrap|78||  |Message-ID: [:mail_addr_decode|%m]]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: [:mail_addr_decode|%r]]]
[? [:useragent] |#|[:wrap|78||  |[:useragent]]]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]
[? %q |Not quarantined.|The message has been quarantined as: %q]

Please contact your system administrator for details.
__DATA__
#
# =============================================================================
# This is a template for spam SENDER NOTIFICATIONS.
# For syntax and customization instructions see README.customize.
# The From, To and Date header fields will be provided automatically.
# Long header fields will be automatically wrapped by the program.
#
Subject: Considered UNSOLICITED BULK EMAIL, apparently from you
[? %m  |#|In-Reply-To: [:mail_addr_decode|%m]]
Message-ID: <SS%i@%h>

A message from [:mail_addr_decode|%s]\
[%R|\nto: [:mail_addr_decode|%R]|]

was considered unsolicited bulk e-mail (UBE).

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

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

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

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: [:client_addr_port] %g]]

[:wrap|78||  |Received trace: [ip_proto_trace_all|%x| < ]]

[:wrap|78||  |Return-Path: [:mail_addr_decode|%s][?[:dkim|envsender]|| (OK)]]
[:wrap|78||  |From: [:mime_decode|[:header_field_octets|From]|100]\
[?[:dkim|author]|| (dkim:AUTHOR)]]
[? [:header_field|Sender]|#|\
[:wrap|78||  |Sender: [:mime_decode|[:header_field_octets|Sender]|100]\
[?[:dkim|sender]|| (dkim:SENDER)]]]
[? %m |#|[:wrap|78||  |Message-ID: [:mail_addr_decode|%m]]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: [:mail_addr_decode|%r]]]
# [? [:useragent] |#|[:wrap|78||  |[:useragent]]]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]
[? %#X |#|\n[[:wrap|78||  |%X]\n]]

[? %#D |Delivery of the email was stopped!
]#
#
# Spam scanner report:
# [%A
# ]\
__DATA__
#
# =============================================================================
# This is a template for spam ADMINISTRATOR NOTIFICATIONS.
# For syntax and customization instructions see README.customize.
# Long header fields will be automatically wrapped by the program.
#
From: %f
Date: %d
Subject: Spam FROM [?%l||LOCAL ][?%a||[:client_addr_port] ][:mail_addr_decode|%s]
To: [? %#T |undisclosed-recipients:;|[%T|, ]]
[? %#C |#|Cc: [%C|, ]]
Message-ID: <SA%i@%h>

Content type: [:ccat|name|main]#
[? [:ccat|is_blocked_by_nonmain] ||, blocked for [:ccat|name]]
Internal reference code for the message is %n/%i

[? %a |#|[:wrap|78||  |First upstream SMTP client IP address: [:client_addr_port] %g]]

[:wrap|78||  |Received trace: [ip_proto_trace_all|%x| < ]]

[:wrap|78||  |Return-Path: [:mail_addr_decode|%s][?[:dkim|envsender]|| (OK)]]
[:wrap|78||  |From: [:mime_decode|[:header_field_octets|From]|100]\
[?[:dkim|author]|| (dkim:AUTHOR)]]
[? [:header_field|Sender]|#|\
[:wrap|78||  |Sender: [:mime_decode|[:header_field_octets|Sender]|100]\
[?[:dkim|sender]|| (dkim:SENDER)]]]
[? %m |#|[:wrap|78||  |Message-ID: [:mail_addr_decode|%m]]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: [:mail_addr_decode|%r]]]
[? [:useragent] |#|[:wrap|78||  |[:useragent]]]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]
[? %q |Not quarantined.|The message has been quarantined as: %q]

[? %#D |#|The message WILL BE relayed to:[%D|\n[:mail_addr_decode|%D]|]
]
[? %#N |#|The message WAS NOT relayed to:[%N|\n[:mail_addr_decode|%N]|]
]
Spam scanner report:
[%A
]\
__DATA__
#
# =============================================================================
# This is a template for the plain text part of a RELEASE FROM A QUARANTINE,
# applicable if a chosen release format is 'attach' (not 'resend').
#
From: %f
Date: %d
Subject: \[released message\] %j
To: [? %#T |undisclosed-recipients:;|[%T|, ]]
[? %#C |#|Cc: [%C|, ]]
Message-ID: <QRA%i@%h>

Please find attached a message which was held in a quarantine,
and has now been released.

[:wrap|78||  |Return-Path: [:mail_addr_decode|%s][?[:dkim|envsender]|| (OK)]]
[:wrap|78||  |From: [:mime_decode|[:header_field_octets|From]|100]\
[?[:dkim|author]|| (dkim:AUTHOR)]]
[? [:header_field|Sender]|#|\
[:wrap|78||  |Sender: [:mime_decode|[:header_field_octets|Sender]|100]\
[?[:dkim|sender]|| (dkim:SENDER)]]]
# [? %m |#|[:wrap|78||  |Message-ID: [:mail_addr_decode|%m]]]
# [? %r |#|[:wrap|78||  |Resent-Message-ID: [:mail_addr_decode|%r]]]
# [? [:useragent] |#|[:wrap|78||  |[:useragent]]]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]

Our internal reference code for the message is %n/%i
#
[~[:report_format]|["^attach$"]|["[? [:attachment_password] |#|

Contents of the attached mail message may pose a threat to your computer or
could be a social engineering deception, so it should be handled cautiously.
To prevent undesired automatic opening, the attached original mail message
has been wrapped in a password-protected ZIP archive.

Here is the password that allows opening of the attached archive:

  [:attachment_password]

Note that the attachment is not strongly encrypted and the password
is not a strong secret (being displayed in this non-encrypted text),
so this attachment is not suitable for guarding a secret contents.
The sole purpose of this password protection it to prevent undesired
accidental or automatic opening of a message, either by some filtering
software, a virus scanner, or by a mail reader.
]"]|]#
__DATA__
#
# =============================================================================
# This is a template for the plain text part of a problem/feedback report,
# with either the original message included in-line, or attached,
# or the message is structured as a FEEDBACK REPORT NOTIFICATIONS format.
# See RFC 5965 - "An Extensible Format for Email Feedback Reports".
#
From: %f
Date: %d
Subject: Fw: %j
To: [? %#T |undisclosed-recipients:;|[%T|, ]]
[? %#C |#|Cc: [%C|, ]]
Message-ID: <ARF%i@%h>
#Auto-Submitted: auto-generated

This is an e-mail [:feedback_type] report for a message \
[? %a |\nreceived on %d,|received from\nIP address [:client_addr_port] on %d,]

[:wrap|78||  |Return-Path: [:mail_addr_decode|%s]]
[:wrap|78||  |From: [:mime_decode|[:header_field_octets|From]|100]\
[?[:dkim|author]|| (dkim:AUTHOR)]]
[? [:header_field|Sender]|#|\
[:wrap|78||  |Sender: [:mime_decode|[:header_field_octets|Sender]|100]\
[?[:dkim|sender]|| (dkim:SENDER)]]]
[? %m |#|[:wrap|78||  |Message-ID: [:mail_addr_decode|%m]]]
[? %r |#|[:wrap|78||  |Resent-Message-ID: [:mail_addr_decode|%r]]]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]
[?[:dkim|author]|#|
A first-party DKIM or DomainKeys signature is valid, d=[:dkim|author].]

Reporting-MTA: %h
Our internal reference code for the message is %n/%i

[~[:report_format]|["^(arf|attach|dsn)$"]|["\
A complete original message is attached.
[~[:report_format]|["^arf$"]|\
For more information on the ARF format please see RFC 5965.
]"]|["\
A complete original message in its pristine form follows:
"]]#
__DATA__
#
# =============================================================================
# This is a template for the plain text part of an auto response (e.g.
# vacation, out-of-office), see RFC 3834.
#
From: %f
Date: %d
To: [? %#T |undisclosed-recipients:;|[%T|, ]]
[? %#C |#|Cc: [%C|, ]]
Reply-To: postmaster@%h
Message-ID: <ARE%i@%h>
Auto-Submitted: auto-replied
[:wrap|76||\t|Subject: Auto: autoresponse to: [:mail_addr_decode|%s]]
[? %m  |#|In-Reply-To: [:mail_addr_decode|%m]]
Precedence: junk

This is an auto-response to a message \
[? %a |\nreceived on %d,|received from\nIP address [:client_addr_port] on %d,]
envelope sender: [:mail_addr_decode|%s]
(author)   From: [:rfc2822_from]
[? %j |#|[:wrap|78||  |Subject: [:mime_decode|[:header_field_octets|Subject]|100]]]
[?[:dkim|author]|#|
A first-party DKIM or DomainKeys signature is valid, d=[:dkim|author].]