/amavisd-new-2.8.0/amavisd

#!/usr/bin/perl -T
#!/usr/bin/perl -d:NYTProf

#------------------------------------------------------------------------------
# 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-2012 Mark Martinec,
#   All Rights Reserved.
# with contributions from the amavis-user mailing list and individuals,
# as acknowledged in the release notes.
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

# Author: Mark Martinec <Mark.Martinec@ijs.si>
# Patches and problem reports are welcome.
#
# The latest version of this program is available at:
#   http://www.ijs.si/software/amavisd/
#------------------------------------------------------------------------------

# Here is a boilerplate from the amavisd(-snapshot) version,
# which is the version that served as a base code for the initial
# version of amavisd-new. License terms were the same:
#
#   Author:  Chris Mason <cmason@unixzone.com>
#   Current maintainer: Lars Hecking <lhecking@users.sourceforge.net>
#   Based on work by:
#         Mogens Kjaer, Carlsberg Laboratory, <mk@crc.dk>
#         Juergen Quade, Softing GmbH, <quade@softing.com>
#         Christian Bricart <shiva@aachalon.de>
#         Rainer Link <link@foo.fh-furtwangen.de>
#   This script is part of the AMaViS package.  For more information see:
#     http://amavis.org/
#   Copyright (C) 2000 - 2002 the people mentioned above
#   This software is licensed under the GNU General Public License (GPL)
#   See:  http://www.gnu.org/copyleft/gpl.html
#------------------------------------------------------------------------------

#------------------------------------------------------------------------------
#Index of packages in this file
#  Amavis::Boot
#  Amavis::Conf
#  Amavis::Log
#  Amavis::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)
#  Amavis::Lookup::LDAPattr (just the new() method)
#  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::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 strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';

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

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

# Fetch all required modules (or nicely report missing ones), and compile them
# once-and-for-all at the parent process, so that forked children can inherit
# and share already compiled code in memory. Children will still need to 'use'
# modules if they want to inherit from their name space.
#
sub fetch_modules($$@) {
  my($reason, $required, @modules) = @_;
  my $have_sawampersand = Devel::SawAmpersand->UNIVERSAL::can('sawampersand');
  my $amp = $have_sawampersand && Devel::SawAmpersand::sawampersand() ? 1 : 0;
  warn 'fetch_modules: PL_sawampersand flag was already turned on'  if $amp;
  my(@missing);
  for my $m (@modules) {
    local $_ = $m;
    $_ .= /^auto::/ ? '.al' : '.pm'  if !m{^/} && !m{\.(?:pm|pl|al|ix)\z};
    s{::}{/}g;
  # eval { my_require $_ } #more informative on err, but some problems reported
    eval { require $_ }
    or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      push(@missing,$m);
      $eval_stat =~ s/^/  /mgs;  # 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/;
    };
    if ($have_sawampersand && !$amp && Devel::SawAmpersand::sawampersand())
      { $amp = 1; warn "Loading of module $m turned on PL_sawampersand flag" }
  }
  die "ERROR: MISSING $reason:\n" . join('', map("  $_\n", @missing))
    if $required && @missing;
  \@missing;
}

BEGIN {
  if ($] <= 5.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::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.316';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = (
    'dynamic_confvars' =>  # per- policy bank settings
    [qw(
      $child_timeout $smtpd_timeout
      $policy_bank_name $protocol @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
      $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
      $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
      $enable_ldap

      @local_domains_maps @mynetworks_maps @client_ipaddr_policy
      @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_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 $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
      $unix_socketname $unix_socket_mode
      $smtp_connection_cache_on_demand $smtp_connection_cache_enable
      $smtpd_recipient_limit
      $smtpd_tls_cert_file $smtpd_tls_key_file
      $enforce_smtpd_message_size_limit_64kb_min
      $MAXLEVELS $MAXFILES
      $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR
      $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR
      $database_sessions_persistent $lookup_maps_imply_sql_and_ldap
      @lookup_sql_dsn @storage_sql_dsn
      $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
      $trim_trailing_space_in_lookup_result_fields
      $default_ldap $mail_digest_algorithm
      @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(
      $can_truncate $unicode_aware $my_pid
      $AF_INET6 $have_inet4 $have_inet6 $have_socket_ip
      &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 backwards compatibility
    [qw(
      %local_domains @local_domains_acl $local_domains_re @mynetworks
      %bypass_virus_checks @bypass_virus_checks_acl $bypass_virus_checks_re
      %bypass_spam_checks @bypass_spam_checks_acl $bypass_spam_checks_re
      %bypass_banned_checks @bypass_banned_checks_acl $bypass_banned_checks_re
      %bypass_header_checks @bypass_header_checks_acl $bypass_header_checks_re
      %virus_lovers @virus_lovers_acl $virus_lovers_re
      %spam_lovers @spam_lovers_acl $spam_lovers_re
      %banned_files_lovers @banned_files_lovers_acl $banned_files_lovers_re
      %bad_header_lovers @bad_header_lovers_acl $bad_header_lovers_re
      %virus_admin %spam_admin
      $newvirus_admin $virus_admin $banned_admin $bad_header_admin $spam_admin
      $warnvirusrecip $warnbannedrecip $warnbadhrecip
      $virus_quarantine_to $banned_quarantine_to $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'}));
    }
  }
  !defined $var ? undef : !ref $var ? \$var : $var;
}

# return a ref to a config variable value (which is supposed to be an array),
# converting undef to an empty array, and a scalar to a one-element array
# if necessary
#
sub ca($) {
  my $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'}));
    }
  }
  !defined $var ? [] : !ref $var ? [$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 4871.
# 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
  }
  $domain   = lc($domain)  if !ref($domain);  # possibly a regexp
  $selector = lc($selector);
  $key_options{domain} = $domain; $key_options{selector} = $selector;
  $key_options{key_storage_ind} = $key_storage_ind;
  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, $unicode_aware, base policy bank
  $myprogram_name = $0;  # typically 'amavisd'
  local $1; $myprogram_name =~ s{([^/]*)\z}{$1}s;
  $myproduct_name = 'amavisd-new';
  $myversion_id = '2.8.0'; $myversion_date = '20120630';

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

  $unicode_aware =
    $] >= 5.008 && length("\x{263a}")==1 && eval { require Encode };
  $read_config_files_depth = 0;
  eval { require Devel::SawAmpersand } or 1;  # load if avail, ignore failure
  # initialize policy bank hash to contain dynamic config settings
  for my $tag (@EXPORT_TAGS{'dynamic_confvars', 'legacy_dynamic_confvars'}) {
    for my $v (@$tag) {
      local($1,$2);
      if ($v !~ /^([%\$\@])(.*)\z/) { die "Unsupported variable type: $v" }
      else {
        no strict 'refs'; my($type,$name) = ($1,$2);
        $current_policy_bank{$name} = $type eq '$' ? \${"Amavis::Conf::$name"}
                                    : $type eq '@' ? \@{"Amavis::Conf::$name"}
                                    : $type eq '%' ? \%{"Amavis::Conf::$name"}
                                    : undef;
      }
    }
  }
  $current_policy_bank{'policy_bank_name'} = '';  # builtin policy
  $current_policy_bank{'policy_bank_path'} = '';
  $policy_bank{''} = { %current_policy_bank };    # copy
  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;

  # 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 program to detach itself from the terminal
  $daemonize = 1;

  # Net::Server pre-forking settings - defaults, overruled by amavisd.conf
  $max_servers  = 2;   # number of pre-forked children
  $max_requests = 20;  # retire a child after that many accepts, 0=unlimited

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

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

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

  # Can file be truncated?
  # Set to 1 if 'truncate' works (it is XPG4-UNIX standard feature,
  #                               not required by Posix).
  # Things will go faster with SMTP-in, otherwise (e.g. with milter)
  # it makes no difference as file truncation will not be used.
  $can_truncate = 1;

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

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

  $database_sessions_persistent = 1;  # keep SQL & LDAP sessions open when idle

  $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', ...

  # 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

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

  $bounce_killer_score = 0;

  #
  # Receiving mail related

  # $unix_socketname = '/var/amavis/amavisd.sock';  # 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 IO::Socket::IP if it exists, otherwise
  # fall back to IO::Socket::INET6 or IO::Socket::INET as appropriate
  #
  $have_socket_ip = eval {
    require IO::Socket::IP;
  };

  $have_inet4 =  # can we make a PF_INET socket?
    $have_socket_ip ? eval {
      my $sock = IO::Socket::IP->new(LocalAddr => '0.0.0.0', Proto => 'udp');
      $sock->close or die "error closing inet6 socket: $!"  if $sock;
      $sock ? 1 : undef;
    } : eval {
      require IO::Socket::INET;
      my $sock = IO::Socket::INET->new(LocalAddr => '0.0.0.0', Proto => 'udp');
      $sock->close or die "error closing inet socket: $!"  if $sock;
      $sock ? 1 : undef;
    };

  $have_inet6 =  # can we make a PF_INET6 socket?
    $have_socket_ip ? eval {
      my $sock = IO::Socket::IP->new(LocalAddr => '::', Proto => 'udp');
      $sock->close or die "error closing inet6 socket: $!"  if $sock;
      $sock ? 1 : undef;
    } : eval {
      require IO::Socket::INET6;
      my $sock = IO::Socket::INET6->new(LocalAddr => '::', Proto => 'udp');
      $sock->close or die "error closing inet6 socket: $!"  if $sock;
      $sock ? 1 : undef;
    };

  # 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] [FE80::]/10 [FEC0::]/10
                    10.0.0.0/8 172.16.0.0/12 192.168.0.0/16 169.254.0.0/16 );
  $originating = 0;  # a boolean, initially reflects @mynetworks,
                     # 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 = 'iso-8859-1';  # ... header field bodies
# $bdy_encoding = 'iso-8859-1';  # ... notification body text
  $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         (usual for far east charsets)

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

  # $myhostname is used by SMTP server module in the initial SMTP welcome line,
  # in inserted Received: lines, Message-ID in notifications, log entries, ...
  $myhostname = (POSIX::uname)[1];  # should be a FQDN !

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

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

  # $localhost_name is the name of THIS host running amavisd
  # (typically 'localhost'). It is used in HELO SMTP command
  # when reinjecting mail back to MTA via SMTP for final delivery,
  # and in inserted Received header field
  $localhost_name = 'localhost';

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

  #@auth_mech_avail = ('PLAIN','LOGIN');   # empty list disables incoming AUTH
  #$auth_required_inp = 1;  # incoming SMTP authentication required by amavisd?
  #$auth_required_out = 1;  # SMTP authentication required by MTA
  $auth_required_release = 1;  # secret_id is required for a quarantine release
  $tls_security_level_in  = undef;  # undef, 'may', 'encrypt', ...
  $tls_security_level_out = undef;  # undef, 'may', 'encrypt', ...
  $smtpd_tls_cert_file = undef;  # e.g. "$MYHOME/cert/amavisd-cert.pem"
  $smtpd_tls_key_file  = undef;  # e.g. "$MYHOME/cert/amavisd-key.pem"

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

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

  # where to send quarantined malware - specify undef to disable, or an
  # e-mail address containing '@', or just a local part, which will be
  # mapped by %local_delivery_aliases into local mailbox name or directory.
  # The lookup key is a recipient address
  $virus_quarantine_to      = 'virus-quarantine';
  $banned_quarantine_to     = 'banned-quarantine';
  $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

  # 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 using
  # %lovers_maps_by_ccat, or by %final_destiny_by_ccat resulting in D_PASS,
  # one may set the corresponding %addr_extension_maps_by_ccat to some string,
  # and the recipient address will have this string appended as an address
  # extension to a local-part (mailbox part) of the address. This extension
  # can be used by a final local delivery agent for example to place such mail
  # in different folder. Leaving 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 8bit control empty long syntax missing multiple);

  # RFC 4871 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 4871;
  # 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, To, Cc
  $signed_header_fields{lc($_)} = 0  for qw(Sender To Cc);
  #
  # a value greater than 1 causes signing of one additional null instance of
  # a header field, thus prohibiting prepending additional 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_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 current local time and
  # losing the cherishly preserved and prepared time of mail reception.
  # From the MySQL 4.1 documentation:
  # * With neither DEFAULT nor ON UPDATE clauses, it is the same as
  #   DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP.
  # * suppress the automatic initialization and update behaviors for the first
  #   TIMESTAMP column by explicitly assigning it a constant DEFAULT value
  #   (for example, DEFAULT 0)
  # * The first TIMESTAMP column in table row automatically is updated to
  #   the current timestamp when the value of any other column in the row is
  #   changed, unless the TIMESTAMP column explicitly is assigned a value
  #   other than NULL.

  # maps full string as returned by a file(1) utility into a short string;
  # first match wins, more specific entries should precede general ones!
  # the result may be a string or a ref to a list of strings;
  # see also sub decompose_part()

  # prepare an arrayref, later to be converted to an Amavis::Lookup::RE object
  $map_full_type_to_short_type_re = [
    [qr/^empty\z/                          => 'empty'],
    [qr/^directory\z/                      => 'dir'],
    [qr/^can't (stat|read)\b/              => 'dat'],  # file(1) diagnostics
    [qr/^cannot open\b/                    => 'dat'],  # file(1) diagnostics
    [qr/^ERROR:/                           => 'dat'],  # file(1) diagnostics
    [qr/can't read magic file|couldn't find any magic files/ => 'dat'],
    [qr/^data\z/                           => 'dat'],

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

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

    [qr/^JPEG image data\b/                => ['image','jpg'] ],
    [qr/^GIF image data\b/                 => ['image','gif'] ],
    [qr/^PNG image data\b/                 => ['image','png'] ],
    [qr/^TIFF image data\b/                => ['image','tif'] ],
    [qr/^PCX\b.*\bimage data\b/            => ['image','pcx'] ],
    [qr/^PC bitmap data\b/                 => ['image','bmp'] ],
    [qr/^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 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/^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 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 program path string (or a listref of
  # paths to be searched) or a reference to a variable containing such a path,
  # which allows for lazy evaluation, making possible to assign values to
  # legacy configuration variables even after the assignment to @decoders.
  @decoders = (
    ['mail', \&Amavis::Unpackers::do_mime_decode],
#   [[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],
    ['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(7z zip 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);

  @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 previous, 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 backwards compatib. needed
  @whitelist_sender_maps = (
    \%whitelist_sender, \@whitelist_sender_acl, \$whitelist_sender_re);
  @blacklist_sender_maps = (
    \%blacklist_sender, \@blacklist_sender_acl, \$blacklist_sender_re);
  @addr_extension_virus_maps  = (\$addr_extension_virus);
  @addr_extension_spam_maps   = (\$addr_extension_spam);
  @addr_extension_banned_maps = (\$addr_extension_banned);
  @addr_extension_bad_header_maps = (\$addr_extension_bad_header);
  @debug_sender_maps = (\@debug_sender_acl);
# @debug_recipient_maps = ();
  @remove_existing_spam_headers_maps = (\$remove_existing_spam_headers);

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

  # build backwards-compatible settings hashes
  %final_destiny_by_ccat = (
    CC_VIRUS,       sub { c('final_virus_destiny') },
    CC_BANNED,      sub { c('final_banned_destiny') },
    CC_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,
    CC_MTA.',2',    D_REJECT,
    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,   '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 = (
    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;
*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;

sub new_RE    { Amavis::Lookup::RE->new(@_) }

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

# compatibility with old names
use vars qw(%defang_by_ccat $sql_partition_tag $DO_SYSLOG $LOGFILE);
*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\.'                                  => 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\.(Scam4|Phishing|Junk)'              => 0.1 ],
    [ qr'^ScamNailer\.'                                    => 0.1 ],
    [ qr'^HTML/Bankish'                                    => 0.1 ],  # F-Prot
    [ 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
    @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 (!-f _)        { $msg = "is not a regular file" }
    elsif ($> && -o _)   { $msg = "should not be owned by EUID $>"}
    elsif ($> && -w _)   { $msg = "is writable by EUID $>, EGID $)" }
    elsif ($owner_uid)   { $msg = "should be owned by root (uid 0) "}
    if (defined $msg)    { die "Config file \"$config_file\" $msg," }
    $read_config_files_depth++;  push(@actual_config_files, $config_file);
    if ($read_config_files_depth >= 100) {
      print STDERR "read_config_files: recursion depth limit exceeded\n";
      exit 1;  # avoid unwinding deep recursion, abort right away
    }
    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;
# 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 $mydomain"  if !defined $X_HEADER_LINE;
  $X_HEADER_TAG = 'X-Virus-Scanned'               if !defined $X_HEADER_TAG;
  if ($X_HEADER_TAG =~ /^[!-9;-\176]+\z/) {
    # implicitly add to %allowed_added_header_fields for compatibility,
    # unless the hash entry already exists
    my $allowed_hdrs = cr('allowed_added_header_fields');
    $allowed_hdrs->{lc($X_HEADER_TAG)} = 1
      if $allowed_hdrs && !exists($allowed_hdrs->{lc($X_HEADER_TAG)});
  }
  $gunzip  = "$gzip -d"   if !defined $gunzip  && $gzip  ne '';
  $bunzip2 = "$bzip2 -d"  if !defined $bunzip2 && $bzip2 ne '';
  $unlzop  = "$lzop -d"   if !defined $unlzop  && $lzop  ne '';

  # substring ${myhostname} will be expanded later, just before use
  my $pname = '"Content-filter at ${myhostname}"';
  $hdrfrom_notify_sender = "$pname <postmaster\@\${myhostname}>"
    if !defined $hdrfrom_notify_sender;
  $hdrfrom_notify_recip = $mailfrom_notify_recip ne ''
    ? "$pname <$mailfrom_notify_recip>"
    : $hdrfrom_notify_sender  if !defined $hdrfrom_notify_recip;
  $hdrfrom_notify_admin = $mailfrom_notify_admin ne ''
    ? "$pname <$mailfrom_notify_admin>"
    : $hdrfrom_notify_sender  if !defined $hdrfrom_notify_admin;
  $hdrfrom_notify_spamadmin = $mailfrom_notify_spamadmin ne ''
    ? "$pname <$mailfrom_notify_spamadmin>"
    : $hdrfrom_notify_sender  if !defined $hdrfrom_notify_spamadmin;
  $hdrfrom_notify_release = $hdrfrom_notify_sender
    if !defined $hdrfrom_notify_release;
  $hdrfrom_notify_report = $hdrfrom_notify_sender
    if !defined $hdrfrom_notify_report;

  if ($final_banned_destiny == D_DISCARD && c('warnbannedsender') )
    { $final_banned_destiny = D_BOUNCE }
  if ($final_bad_header_destiny == D_DISCARD && c('warnbadhsender') )
    { $final_bad_header_destiny = D_BOUNCE }
  if (!%banned_rules) {
    # an associative array mapping a rule name
    # to a single 'banned names/types' lookup table
    %banned_rules = ('DEFAULT'=>$banned_filename_re);  # backwards compatible
  }
  1;
}

1;

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

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

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

# 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 later by avoiding a subroutine call
  $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;
}

sub init($$) {
  ($log_to_syslog, $logfile_name) = @_;
  $log_lines = 0; %log_entries_by_level = ();
  $log_retries = 0; %log_status_counts = ();
  open_log();
  if (!$log_to_syslog && $logfile_name eq '')
    { print STDERR "Logging to STDERR (no \$logfile and no \$do_syslog)\n" }
}

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

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

# turn debug logging to STDERR on or off
#
sub log_to_stderr(;$) {
  $log_to_stderr = shift  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  # how to obtain fd on syslog?
  : defined $loghandle ? $loghandle->fileno : fileno(STDERR);
}

sub open_log() {
  # don't bother to skip opening the log even if $log_to_stderr (debug) is true
  if ($log_to_syslog) {
    my $id = c('syslog_ident'); my $fac = c('syslog_facility');
    $fac =~ /^[A-Za-z0-9_]+\z/
      or die "Suspicious syslog facility name: $fac";
    my $syslog_facility_num = eval("LOG_\U$fac");
    $syslog_facility_num =~ /^\d+\z/
      or die "Unknown syslog facility name: $fac";
    # 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 ($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 ($> == 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: $!";
      }
    }
  } else {  # logging to STDERR
    STDERR->autoflush(1);  # just in case
  }
}

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 = 1;
  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"}++;
  if ($log_to_syslog && !$log_to_stderr) {
    my $prio;
    if    ($level >=  3) { $prio = $log_prio_debug }  # most frequent first
    elsif ($level >=  2) { $prio = $log_prio_info }
    elsif ($level >=  1) { $prio = $log_prio_info }
    elsif ($level >=  0) { $prio = $log_prio_notice }
    elsif ($level >= -1) { $prio = $log_prio_warning }
    elsif ($level >= -2) { $prio = $log_prio_err }
    else                 { $prio = $log_prio_crit }
    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{"$!"}++ }
  } else {
    $log_lines++;
    my $now = Time::HiRes::time;
    if ($log_to_stderr || !defined $loghandle) {
      my $prefix = sprintf('%s:%06.3f %s %s[%s]: ',  # syslog-like prefix
        strftime('%b %e %H:%M',localtime($now)), $now-int($now/60)*60,
        c('myhostname'), c('myprogram_name'), $$);  # milliseconds in timestamp
      # avoid multiple calls to write(2), join the string first!
      my $s = $prefix . $am_id . $alert_mark . $errmsg . "\n";
      print STDERR ($s)  or die "Error writing to STDERR: $!";
    } else {
      my $prefix = sprintf('%s %s %s[%s]: ',  # prepare a syslog-like prefix
        strftime('%b %e %H:%M:%S',localtime($now)),
        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($loghandle,0,2)   or die "Can't position log file to its tail: $!";
      $loghandle->print($s)  or die "Error writing to log file: $!";
      flock($loghandle,LOCK_UN)  or die "Can't unlock a log file: $!";
    }
  }
# POSIX::setlocale(LC_TIME, $old_locale);
  $within_write_log = 0;
}

1;

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

BEGIN {
  use vars qw(@ISA $VERSION);
  $VERSION = '2.316';
  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) = @_;
  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) = @_;
  undef $self->{fh};
};

sub flush {
  my($self) = @_;
  my $fh = $self->{fh};
  !$fh ? 1 : $fh->flush;
}

sub reposition_to_end {
  my($self) = @_;
  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.316';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&init &section_time &report &get_time_so_far);
}
use subs @EXPORT_OK;
use vars qw(@timing);

use Time::HiRes ();

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

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

# returns a string - a report of elapsed time by section
#
sub report() {
  section_time('rundown');
  my($notneeded, $t0) = (shift(@timing), shift(@timing));
  my $total = $t0 <= 0 ? 0 : $timing[-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
    push(@sections, sprintf('%s: %.0f (%.0f%%)%.0f',
                            $section, $dt*1000, $dtp, $dtp_c));
    $t0 = $t;
  }
  sprintf('TIMING [total %.0f ms] - %s', $total * 1000, join(', ',@sections));
}

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

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

sub idle_proc(@) {
  my $t1 = Time::HiRes::time;
  if (defined $t0) {
    ($t_was_busy ? $t_busy_cum : $t_idle_cum) += $t1 - $t0;
    Amavis::Util::ll(5) && Amavis::Util::do_log(5,
        'idle_proc, %s: was %s, %.1f ms, total idle %.3f s, busy %.3f s',
        $_[0],  $t_was_busy ? 'busy' : 'idle',  1000*($t1 - $t0),
        $t_idle_cum, $t_busy_cum);
  }
  $t0 = $t1;
}

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

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

sub report_load() {
  $t_busy_cum + $t_idle_cum <= 0 ? undef
  : sprintf('load: %.0f %%, total idle %.3f s, busy %.3f s',
      100*$t_busy_cum / ($t_busy_cum + $t_idle_cum), $t_idle_cum, $t_busy_cum);
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.316';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&untaint &untaint_inplace
                  &min &max &minmax &unique_list &unique_ref
                  &safe_encode &safe_encode_ascii &safe_encode_utf8
                  &safe_decode &q_encode &orcpt_encode &orcpt_decode
                  &xtext_encode &xtext_decode &proto_encode &proto_decode
                  &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 &sanitize_str_inplace &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 $myhostname $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 vars qw($enc_ascii $enc_utf8 $enc_tainted);
BEGIN {
  $enc_ascii = Encode::find_encoding('ascii');
  $enc_utf8  = Encode::find_encoding('UTF-8');
  $enc_ascii  or die "Amavis::Util: unknown encoding 'ascii'";
  $enc_utf8   or die "Amavis::Util: unknown encoding 'UTF-8'";
  $enc_tainted = substr($ENV{PATH}.$ENV{HOME}, 0,0);  # tainted empty string
  tainted($enc_tainted) or warn "Amavis::Util: can't obtain a tainted string";
  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;  # avoid 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] : \@_;  # accept list, or a list ref
  my %seen;  my(@result) = grep(defined($_) && !$seen{$_}++, @$r);
  @result;
}

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

# A wrapper for Encode::encode, avoiding a bug in Perl 5.8.0 which causes
# Encode::encode to loop and fill memory when given a tainted string.
# 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
# (still unresolved with Encode as bundled with Perl 5.14.2)
#
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'";
  return $enc->encode(@_)  if !tainted($_[0]);
  # propagate taintedness across taint-related bugs in module Encode
  $enc_tainted . $enc->encode(untaint($_[0]), $_[1]);
}

sub safe_encode_ascii($) {
# my($str) = @_;
  return undef  if !defined $_[0];  # must return undef even in a list context!
  return $enc_ascii->encode($_[0], 0)  if !tainted($_[0]);
  # propagate taintedness across taint-related bugs in module Encode
  $enc_tainted . $enc_ascii->encode(untaint($_[0]), 0);
}

sub safe_encode_utf8($) {
# my($str) = @_;
  return undef  if !defined $_[0];  # must return undef even in a list context!
  return $enc_utf8->encode($_[0], 0)  if !tainted($_[0]);
  # propagate taintedness across taint-related bugs in module Encode
  $enc_tainted . $enc_utf8->encode(untaint($_[0]), 0);
}

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 !tainted($_[0]);
  # propagate taintedness across taint-related bugs in module Encode
  $enc_tainted . $enc->decode(untaint($_[0]), $_[1]);
}

# Do the Q-encoding manually, the MIME::Words::encode_mimeword does not
# encode spaces and does not limit to 75 ch, which violates the RFC 2047
#
sub q_encode($$$) {
  my($octets,$encoding,$charset) = @_;
  my $prefix = '=?' . $charset . '?' . $encoding . '?';
  my $suffix = '?='; local($1,$2,$3);
  # FWS | utext (= NO-WS-CTL|rest of US-ASCII)
  $octets =~ /^ ( [\001-\011\013\014\016-\177]* [ \t] )?  (.*?)
                ( [ \t] [\001-\011\013\014\016-\177]* )? \z/sx;
  my($head,$rest,$tail) = ($1,$2,$3);
  # Q-encode $rest according to RFC 2047 (not for use in comments or phrase)
  $rest =~ s{([\000-\037\177\200-\377=?_])}{sprintf('=%02X',ord($1))}egs;
  $rest =~ tr/ /_/;   # turn spaces into _ (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/sx;
    $s .= $prefix.$1.$suffix; $rest = $2;
  }
  $s.$tail;
}

# encode "+", "=" and any character outside the range "!" (33) .. "~" (126)
#
sub xtext_encode($) {  # RFC 3461
  my($str) = @_; local($1);
  # avoid Encode::is_utf8 check, always false on tainted, Perl bug #32687
  $str = safe_encode_utf8($str);  # if Encode::is_utf8($str);
  $str =~ s/([^\041-\052\054-\074\076-\176])/sprintf('+%02X',ord($1))/egs;
  $str;
}

# decode xtext-encoded string as per RFC 3461
#
sub xtext_decode($) {
  my($str) = @_; local($1);
  $str =~ s/\+([0-9a-fA-F]{2})/pack('C',hex($1))/egs;
  $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))/egs 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))/egs;
  for (@strings) {      # encode % and nonprintables
    s/([^\041-\044\046-\176])/sprintf('%%%02x',ord($1))/egs;
  }
  $attribute_name . '=' . join(' ',@strings);
}

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

# xtext_encode and prepend 'rfc822;' to form a string to be used as ORCPT
#
sub orcpt_encode($) {  # RFC 3461
  # 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($str) = @_; local($1);  # argument should be SMTP-quoted address
  $str = $1  if $str =~ /^<(.*)>\z/s;  # strip-off <>
  $str =~ s/[^\040-\176]/?/gs;
  'rfc822;' . xtext_encode($str);
}

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

# Mostly for debugging and reporting purposes:
# Convert nonprintable characters in the argument
# to \[rnftbe], or \octal 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', "\f" => '\\f', "\t" => '\\t',
     "\b" => '\\b', "\e" => '\\e' );   # "\\" => '\\\\'
}
sub sanitize_str {
  my($str, $keep_eol) = @_;
  return ''  if !defined $str;
  my $taint = '';
  # Encode::is_utf8 is always false on tainted in Perl 5.8, Perl bug #32687
  if ($] < 5.010 || Encode::is_utf8($_[0])) {
    # inlined: $str = safe_encode_utf8($str);
    # obtain taintedness of the string, with UTF8 flag unconditionally off
    $taint = $enc_ascii->encode(substr($str,0,0));
    # untaint the string to work around a Perl 5.8.0 taint bug
    # where Encode::encode fills up all available memory
    # when given a tainted string with a non-encodeable character
    untaint_inplace($str);
    $str = $enc_utf8->encode($str, 0);  # convert to octets
  }
  local($1);
  if ($keep_eol) {
    $str =~ s/([^\012\040-\133\135-\176])/  # and \240-\376 ?
              exists($quote_controls_map{$1}) ? $quote_controls_map{$1} :
                   sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/egs;
  } else {
    $str =~ s/([^\040-\133\135-\176])/      # and \240-\376 ?
              exists($quote_controls_map{$1}) ? $quote_controls_map{$1} :
                   sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/egs;
  }
  $str .= $taint;  # preserve taintedness
  $str;
}

sub sanitize_str_inplace {
  my $taint = '';
  # Encode::is_utf8 is always false on tainted in Perl 5.8, Perl bug #32687
  if ($] < 5.010 || Encode::is_utf8($_[0])) {
    # inlined: $_[0] = safe_encode_utf8($_[0]);
    # obtain taintedness of the string, with UTF8 flag unconditionally off
    $taint = $enc_ascii->encode(substr($_[0],0,0));
    # untaint the string to work around a Perl 5.8.0 taint bug
    # where Encode::encode fills up all available memory
    # when given a tainted string with a non-encodeable character
    untaint_inplace($_[0]);
    $_[0] = $enc_utf8->encode($_[0], 0);  # convert to octets
  }
  local($1);
  $_[0] =~ s/([^\040-\133\135-\176])/  # and \240-\376 ?
            exists($quote_controls_map{$1}) ? $quote_controls_map{$1} :
                 sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/egs;
  $_[0] .= $taint;
  1;
}

# 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 = shift;
    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' ? @$_ : $_), @_));
# do_log(5,'add_entropy: %s',$s);
  $entropy->add($s);
}

sub fetch_entropy_bytes($) {
  my($n) = @_;  # 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($) {
  my($required_bytes) = @_;
  my $result = '';
  my $fname = '/dev/urandom';  # nonblocking device!
  if ($required_bytes > 0) {
    my $fh = IO::File->new;
    $fh->open($fname,'<') or die "Can't open $fname: $!";
    binmode($fh,':bytes') or die "Can't cancel :utf8 mode: $!";
    my $nbytes = $fh->read($result, $required_bytes);
    defined $nbytes  or die "Error reading from $fname: $!";
    $nbytes >= $required_bytes  or die "Less data than requested: $!";
    $fh->close or die "Error closing $fname: $!";
  }
  $result;
}

# 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 {
    $random_bytes = read_random(16);  1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    do_log(0, 'read_random error: %s', $eval_stat);
  };
  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 (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
    $id_b64 = substr($id_b64, 0, $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);
  }
  my $secret_b64 = encode_base64($secret_bin,'');  # $mail_id_size_bits/6 chars
  $secret_bin = 'X' x length($secret_bin);  # can't hurt to be conservative
  $id_b64     =~ tr{+/}{-_};  # base64 -> RFC 4648 base64url [A-Za-z0-9-_]
  $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
    $password =
      sprintf('%04d', unpack('S',fetch_entropy_bytes(2)) % 10000);
  }
  $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],
    ['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 since start)
    ['sysContact',  'STR', $snmp_contact],
    ['sysName',     'STR', $myhostname],
    ['sysLocation', 'STR', $snmp_location],
    ['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 = shift;
    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
#
sub do_log($$;@) {   # my($level,$errmsg,@args) = @_;
  my $level = shift;
# if (ll($level)) {  # inline and reorder 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 = shift;
    # treat $errmsg as sprintf format string if additional args are provided
    $errmsg = sprintf($errmsg,@_)  if @_;
    sanitize_str_inplace($errmsg);
    $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 = shift  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.7;
      $timer_interval *= $allowed_share;
    } elsif ($allowed_share <= 0) {
      $timer_interval = 0;
    } elsif ($allowed_share >= 1) {
      # leave it unchanged
    } else {
      $timer_interval *= $allowed_share;
    }
    $reserve = 3  if !defined $reserve;
    if ($reserve > 0 && $timer_interval > $time_to_deadline - $reserve) {
      $timer_interval = $time_to_deadline - $reserve;
    }
    if ($timer_interval < 8) {  # try to be generous
      $timer_interval = max(4, 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) = @_;
  $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) = @_;
  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) = @_;
  !defined($arg) ? 'undef'
  : !ref($arg) ? '"'.$arg.'"'
  : ref($arg) eq 'ARRAY' ?
      '[' . join(',', map(fmt_struct($_),@$arg)) . ']'
  : ref($arg) 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) = @_; local($1);
  $str =~ s/([%~\000\200])/sprintf('%%%02X',ord($1))/egs;
  $str;
}

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

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

# accepts either a single contents category (a string: "maj,min" or "maj"),
# or a list of contents categories, in which case only the first element
# is considered; returns a passed pair: (major_ccat, minor_ccat)
#
sub ccat_split($) {
  my($ccat) = @_; my $major; 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) = @_; 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(/,/, shift, -1);
  my($b_maj,$b_min) = split(/,/, shift, -1);
  $a_maj == $b_maj ? $a_min <=> $b_min : $a_maj <=> $b_maj;
}

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

# get a list of settings corresponding to all listed contents categories,
# ordered from the most important category to the least;  @ccat is a list of
# relevant contents categories for which a query is made, it MUST already be
# sorted in descending order;  this is a classical subroutine, not a method!
#
sub setting_by_given_contents_category_all($@) {
  my($ccat,@settings_href_list) = @_; my(@r);
  if (@settings_href_list) {
    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;
      }
    }
    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 (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) 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 = '';
  while (($nbytes = sysread($fh, $$strref, 32768, length $$strref)) > 0) { }
  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) = @_;
  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;
# }

#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.
# 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]+ | . )/gsx) {
      if ($t eq '#') { $trailing_comment = 1; last }
      if (!$at_rhs && $t =~ /^[ \t]+\z/) { $at_rhs = 1 }
      else { ($at_rhs ? $rhs : $lhs) .= $t }
    }
    $rhs =~ s/[ \t]+\z//  if $trailing_comment ||
                             $trim_trailing_space_in_lookup_result_fields;
    next  if $lhs eq '' && $rhs eq '';
    my($source_route,$localpart,$domain) =
                      Amavis::rfc2821_2822_Tools::parse_quoted_rfc2821($lhs,1);
    $localpart = lc($localpart)  if !$lpcs;
    my $addr = $localpart . lc($domain);
    $hashref->{$addr} = $rhs eq '' ? 1 : $rhs;
    # do_log(5, 'read_hash: address: <%s>: %s', $addr, $hashref->{$addr});
  }
  defined $ln || $! == 0  or   # returning EBADF at EOF is a perl bug
    $! == EBADF ? do_log(0,'Error reading from %s: %s', $filename,$!)
                : die "Error reading from $filename: $!";
  $inp->close or die "Error closing $filename: $!";
  $hashref;
}

sub read_array(@) {
  unshift(@_,[])  if !ref $_[0];  # first argument is optional, defaults to []
  my($arrref, $filename, $keep_case) = @_;
  my $inp = IO::File->new;
  $inp->open($filename,'<') or die "Can't open file $filename for reading: $!";
  my $ln;
  for ($! = 0; defined($ln=$inp->getline); $! = 0) {
    chomp($ln); my $lhs = '';
    # carefully handle comments, '#' within "" does not count as a comment
    for my $t ( $ln =~ /\G ( " (?: \\. | [^"\\] )* " |
                             [^#" \t]+ | [ \t]+ | . )/gsx) {
      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) = @_;
  do_log(0, 'dump_hash: %s => %s', $_, $hr->{$_})  for (sort keys %$hr);
}

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

# (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]+ | . /gsx) {  # 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 defined $conn;
        $relayhost = "[$client_ip]"  if defined $client_ip && $client_ip ne '';
      }
      if ($relayport eq '*') {
        my $socket_port;  $socket_port = $conn->socket_port if defined $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.316';
  @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;
    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: $!";
    } or 1;  # ignore failures, make perlcritic happy
    my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    eval {
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      open_log();  # oops, exec failed, we will need logging after all...
      # we're in trouble if stderr was attached to a terminal, but no longer is
      do_log_safe(-1,"run_command: child process [%s]: %s", $$,$err);
    } or 1;  # ignore failures, make perlcritic happy
    { # no warnings;
      POSIX::_exit(6);  # avoid END and destructor processing
      kill('KILL',$$); exit 1;   # still kicking? die!
    }
  }
  # parent
  ll(5) && do_log(5,"run_command: [%s] %s", $pid,$msg);
  $child_out_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

# Run a specified command as a subprocess. Return a file handle open for
# WRITING to the subprocess, utf8 mode canceled and autoflush turned 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;
    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: $!";
    } or 1;  # ignore failures, make perlcritic happy
    my $err = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    eval {
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my $i = $interrupt; $interrupt = ''; die $i }
      open_log();  # oops, exec failed, we will need logging after all...
      # we're in trouble if stderr was attached to a terminal, but no longer is
      do_log_safe(-1,"run_command_consumer: child process [%s]: %s", $$,$err);
    } or 1;  # ignore failures, make perlcritic happy
    { # no warnings;
      POSIX::_exit(6);  # avoid END and destructor processing
      kill('KILL',$$); exit 1;   # still kicking? die!
    }
  }
  # parent
  ll(5) && do_log(5,"run_command_consumer: [%s] %s", $pid,$msg);
  $child_in_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  $proc_fh->autoflush(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(6);  # avoid END and destructor processing in a subprocess
  }
  # parent
  ll(5) && do_log(5,"run_as_subprocess: spawned a subprocess [%s]", $pid);
  $child_out_fh->close
    or die "Parent failed to close child side of the pipe: $!";
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  prolong_timer('run_as_subprocess');  # 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) {
    $result = substr($result,0,$results_max_size) . "...";
  }
  if (defined $eval_stat) {  # read error or timeout; abort the subprocess
    chomp $eval_stat;
    undef $_[0];  # release the caller's copy of $proc_fh
    kill_proc($pid,$what,1,$proc_fh, "on reading: $eval_stat") if defined $pid;
    undef $proc_fh; undef $pid;
    die "collect_results - reading aborted: $eval_stat";
  }
  # normal subprocess exit, close pipe, collect exit status
  $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.316';
  @ISA = qw(Exporter);
  @EXPORT = qw(
    &rfc2822_timestamp &iso8601_timestamp &iso8601_utc_timestamp
    &iso8601_week &iso8601_yearweek &iso8601_year_and_week &iso8601_weekday
    &format_time_interval &make_received_header_field &parse_received
    &fish_out_ip_from_received &parse_message_id
    &split_address &split_localpart &replace_addr_fields &make_query_keys
    &quote_rfc2821_local &qquote_rfc2821_local
    &parse_quoted_rfc2821 &unquote_rfc2821_local &parse_address_list
    &wrap_string &wrap_smtp_resp &one_response_for_all
    &EX_OK &EX_NOUSER &EX_UNAVAILABLE &EX_TEMPFAIL &EX_NOPERM);
  import Amavis::Conf qw(:platform c cr ca $myproduct_name);
  import Amavis::Util qw(ll do_log unique_ref unique_list);
}
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 2822 date format.
# Works also for non-full-hour zone offsets, and on systems where strftime
# cannot return TZ offset as a number;  (c) Mark Martinec, GPL
#
sub get_zone_offset($) {
  my $t = int(shift);
  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) = @_;
  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 numeric time (seconds since 1970-01-01T00:00Z),
# provide date-time timestamp (local time) as specified in ISO 8601 (EN 28601)
#
sub iso8601_timestamp($;$$$) {
  my($t,$suppress_zone,$dtseparator,$with_field_separators) = @_;
  # can't use %z because some systems do not support it (is treated as %Z)
  my $fmt = $with_field_separators ? "%Y-%m-%dT%H:%M:%S" : "%Y%m%dT%H%M%S";
  $fmt =~ s/T/$dtseparator/  if defined $dtseparator;
  my $s = strftime($fmt,localtime(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) = @_;
  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 .= '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) = @_;
  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) = @_;
  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(shift);  $wn;
}

sub iso8601_yearweek($) {
  my($y,$wn) = iso8601_year_and_week(shift);  $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) = @_; ((localtime($unix_time))[6] + 6) % 7 + 1;
}

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

sub make_received_header_field($$) {
  my($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 /:.*:/ && !/^IPv6:/is;
  }
  my $tls = $msginfo->tls_cipher;
  my $s = sprintf("from %s%s%s\n by %s%s (%s, %s)",
    $conn->smtp_helo eq '' ? 'unknown' : $conn->smtp_helo,
    $client_ip eq '' ? '' : " ([$client_ip])",
    !defined $tls    ? '' : " (using TLS with cipher $tls)",
    c('localhost_name'),
    $socket_ip eq '' ? '' : sprintf(" (%s [%s])", c('myhostname'), $socket_ip),
    $myproduct_name,
    $conn->socket_port eq '' ? 'unix socket' : "port ".$conn->socket_port);
  $s .= "\n with $smtp_proto"  if $smtp_proto=~/^(ES|S|L)MTPS?A?\z/i; #RFC 3848
  $s .= "\n id $id"  if defined $id && $id ne '';
  # do not disclose recipients if more than one
  $s .= "\n for " . qquote_rfc2821_local(@$recips)  if @$recips == 1;
  $s .= ";\n " . rfc2822_timestamp($msginfo->rx_time);
  $s =~ s/\n//g  if !$folded;
  $s;
}

# parse Received header field according to 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, must contain a colon
           /\[ (?: IPv6: )?  [0-9a-f]{0,4}
               (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,9} \]/xi) {}
  # elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /x) {}
    elsif (/^(?: localhost | ( [a-z0-9_\/+-]{1,63} \. )+ [a-z-]{2,} )\b/xi) {}
    else {
      my $fc = $f;  $fc =~ s/-tcp\z/-com/;
      $fld{$fc} = ''  if !defined $fld{$fc};
      $fld{$fc} = $_ . (/[ \t]\z/||$fld{$fc}=~/^[ \t]/?'':' ') .$fld{$fc};
      delete $fld{$f};
    }
  }
  for (values %fld) { s/[ \t]+\z//; s/^[ \t]+// }
# for my $f (sort {$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) = @_;
  my $fields_ref = parse_received($received);
  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} )? \] /x) {
      $ip = $1;  last;
    } elsif (/\[ [^:\]]* : [^\]]* \]/x &&  # triage, must contain a colon
             /\[ ( (?: IPv6: )?  [0-9a-f]{0,4}
                   (?: : [0-9a-f]{0,4} | \. [0-9]{1,3} ){2,9} ) \]/xi) {
      $ip = $1;  last;
    } elsif (/ (?: ^ | \D ) ( \d{1,3} (?: \. \d{1,3}){3}) (?! [0-9.] ) /x) {
      $ip = $1;  last;
    }
  }
  return undef  if !defined $ip;  # must return undef even in a list context!
  $ip =~ s/^IPv6://i;  # discard 'IPv6:' prefix if any
  do_log(5, "fish_out_ip_from_received: %s", $ip);
  $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) = @_;  local($1,$2);
  $mailbox =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\]\\] ){0,999} (?: \] | \z)
                              |  [^\[\@] )*
                       ) \z/xs ? ($1, $2) : ($mailbox, '');
}

# split_localpart() splits localpart of an e-mail address at the first
# occurrence of the address extension delimiter character. (based on
# equivalent routine in Postfix)
#
# Reserved addresses are not split: postmaster, mailer-daemon,
# double-bounce. Addresses that begin with owner-, or addresses
# that end in -request are not split when the owner_request_special
# parameter is set.
#
sub split_localpart($$) {
  my($localpart, $delimiter) = @_;
  my $owner_request_special = 1;  # configurable ???
  my $extension; local($1,$2);
  if ($localpart =~ /^(postmaster|mailer-daemon|double-bounce)\z/i) {
    # do not split these, regardless of what the delimiter is
  } elsif ($delimiter eq '-' && $owner_request_special &&
           $localpart =~ /^owner-.|.-request\z/si) {
    # don't split owner-foo or foo-request
  } elsif ($localpart =~ /^(.+?)(\Q$delimiter\E.*)\z/s) {
    ($localpart, $extension) = ($1, $2);  # extension includes a delimiter
    # do not split the address if the result would have a null localpart
  }
  ($localpart, $extension);
}

# replace localpart/extension/domain fields of an original email address
# with nonempty fields of a replacement
#
sub replace_addr_fields($$;$) {
  my($orig_addr, $repl_addr, $delim) = @_;
  my($localpart_o, $domain_o, $ext_o, $localpart_r, $domain_r, $ext_r);
  ($localpart_o,$domain_o) = split_address($orig_addr);
  ($localpart_r,$domain_r) = split_address($repl_addr);
  $localpart_r = $localpart_o  if $localpart_r eq '';
  $domain_r    = $domain_o     if $domain_r    eq '';
  if (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) = @_;
  $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]+ | . )/gsx ) {
    if    ($t =~ /^<.*>\z/) { push(@message_id,$t) }
    elsif ($t =~ /^[ \t]*\z/) {}   # ignore FWS
    elsif ($t =~ /^\(.*\)\z/)      # ignore CFWS
      { do_log(2, "parse_message_id ignored comment: /%s/ in %s", $t,$str) }
    else { $garbage = 1 }
  }
  if (@message_id > 1) {
    @message_id = unique_list(\@message_id);  # remove possible duplicates
  } elsif ($garbage && !@message_id) {
    local($_) = $str; s/^[ \t]+//; s/[ \t\n]+\z//;  # trim and sanitize <...>
    s/^<//; s/>\z//; s/>/_/g; $_ = '<'.$_.'>'; @message_id = ($_);
    do_log(5, "parse_message_id sanitizing garbage: /%s/ to %s", $str,$_);
  }
  @message_id;
}

# For a given email address (e.g. for User+Foo@sub.exAMPLE.CoM)
# prepare and return a list of lookup keys in the following order:
#   User+Foo@sub.exAMPLE.COM   (as-is, no lowercasing)
#   user+foo@sub.example.com
#   user@sub.example.com (only if $recipient_delimiter nonempty)
#   user+foo(@) (only if $include_bare_user)
#   user(@)     (only if $include_bare_user and $recipient_delimiter nonempty)
#   (@)sub.example.com
#   (@).sub.example.com
#   (@).example.com
#   (@).com
#   (@).
# Note about (@): if $at_with_user is true the user-only keys (without domain)
# get an '@' character appended (e.g. 'user+foo@'). Usual for lookup_hash.
# If $at_with_user is false the domain-only (without localpart) keys
# get a '@' prepended (e.g. '@.example.com'). Usual for SQL and LDAP lookups.
#
# The domain part is lowercased in all but the first item in the resulting
# list; the localpart is lowercased iff $localpart_is_case_sensitive is true.
#
sub make_query_keys($$$;$) {
  my($addr,$at_with_user,$include_bare_user,$append_string) = @_;
  my($localpart,$domain) = split_address($addr); $domain = lc($domain);
  my $saved_full_localpart = $localpart;
  $localpart = lc($localpart)  if !c('localpart_is_case_sensitive');
  # chop off leading @, and trailing dots
  local($1);
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  my $extension; my $delim = c('recipient_delimiter');
  if ($delim ne '') {
    ($localpart,$extension) = split_localpart($localpart,$delim);
    # extension includes a delimiter since amavisd-new-2.5.0!
  }
  $extension = ''  if !defined $extension;   # mute warnings
  my($append_to_user,$prepend_to_domain) = $at_with_user ? ('@','') : ('','@');
  my(@keys);  # a list of query keys
  push(@keys, $addr);                        # as is
  push(@keys, $localpart.$extension.'@'.$domain)
    if $extension ne '';                     # user+foo@example.com
  push(@keys, $localpart.'@'.$domain);       # user@example.com
  if ($include_bare_user) {  # typically enabled for local users only
    push(@keys, $localpart.$extension.$append_to_user)
      if $extension ne '';                   # user+foo(@)
    push(@keys, $localpart.$append_to_user); # user(@)
  }
  push(@keys, $prepend_to_domain.$domain);   # (@)sub.example.com
  if ($domain =~ /\[/) {  # don't split address literals
    push(@keys, $prepend_to_domain.'.');     # (@).
  } else {
    my(@dkeys); my $d = $domain;
    for (;;) {            # (@).sub.example.com (@).example.com (@).com (@).
      push(@dkeys, $prepend_to_domain.'.'.$d);
      last  if $d eq '';
      $d = ($d =~ /^([^.]*)\.(.*)\z/s) ? $2 : '';
    }
    @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 (lowercased unconditionally)
  ];
  ($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 (ex RFC 2821).
#
sub quote_rfc2821_local($) {
  my($mailbox) = @_;
  # atext: any character except controls, SP, and specials (RFC 5321/RFC 5322)
  my $atext = "a-zA-Z0-9!#\$%&'*/=?^_`{|}~+-";
  # my $specials = '()<>\[\]\\\\@:;,."';
  my($localpart,$domain) = split_address($mailbox);
  if ($localpart !~ /^[$atext]+(\.[$atext]+)*\z/so) {  # not dot-atom, needs q.
    local($1);  # qcontent = qtext / quoted-pair
    $localpart =~ s/([\000-\037\177-\377"\\])/\\$1/g;  # quote non-qtext
    $localpart = '"'.$localpart.'"';  # make it a qcontent
#   Postfix hates  ""@domain  but is not so harsh on  @domain
#   Late breaking news: don't bother, both forms are rejected by Postfix
#   when strict_rfc821_envelopes=yes, and both are accepted otherwise
  }
  # we used to strip off empty domain (just '@') unconditionally, but this
  # leads Postfix to interpret an address with a '@' in the quoted local part
  # e.g. <"h@example.net"@> as <hhh@example.net> (subject to Postfix setting
  # 'resolve_dequoted_address'), which is not what the sender requested;
  # we no longer do that if localpart contains an '@':
  $domain = ''  if $domain eq '@' && $localpart =~ /\@/;
  $localpart . $domain;
}

# wraps the result of quote_rfc2821_local into angle brackets <...> ;
# If given a list, it returns a list (possibly converted to
# comma-separated scalar if invoked in scalar context), quoting each element;
#
sub qquote_rfc2821_local(@) {
  my(@r) = map($_ eq '' ? '<>' : ('<'.quote_rfc2821_local($_).'>'), @_);
  wantarray ? @r : join(', ', @r);
}

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

# unquote_rfc2821_local() strips away the quoting from the local part
# of an external (quoted) mailbox address, and returns internal (unquoted)
# mailbox address, as per 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) = @_;
  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.  A header field 'From' accepts a 'mailbox-list'
# syntax (which is similar, but does not allow groups);  a header field
# 'Sender' accepts a 'mailbox' syntax, i.e. only one address and not a group.
#
use vars qw($s $p @addresses);
sub flush_a() {
  $s =~ s/^[ \t]+//s; $s =~ s/[ \t]\z//s;  # trim
  $p =~ s/^[ \t]+//s; $p =~ s/[ \t]\z//s;
  if ($p ne '') { $p =~ s/^<//; $p =~ s/>\z//; push(@addresses,$p) }
  elsif ($s ne '') { push(@addresses,$s) }
  $p = ''; $s = '';
}
sub parse_address_list($) {
  local($_) = $_[0];
  local($1); s/\n(?=[ \t])//gs; s/\n+\z//s;  # unfold, chomp
  my $str_l = length($_); $p = ''; $s = ''; @addresses = ();
  my($comm_lvl, $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]+ )/gsx)
    { $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] )/gsx;
  }
  # 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) = @_;
  # RFC 5321: 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) = @_;
  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.316';
  @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] }gxse;
        # bring taintedness of input to the result
        $r .= substr($addr,0,0)  if $any;
      }
      push(@result,$r); push(@matchingkey,$key);
      last  if !$get_all;
    }
  }
  if (!ll(5)) {
    # don't bother preparing log report which will not be printed
  } elsif (!@result) {
    do_log(5, "lookup_re(%s), no matches", fmt_struct($addr));
  } else {  # pretty logging
    my(%esc) = (r => "\r", n => "\n", f => "\f", b => "\b",
                e => "\e", a => "\a", t => "\t");
    my(@mk) = @matchingkey;
    for my $mk (@mk)  # undo the \-quoting, will be redone by logging routines
      { $mk =~ s{ \\(.) }{ exists($esc{$1}) ? $esc{$1} : $1 }egsx }
    if (!$get_all) {  # first match wins
      do_log(5, 'lookup_re(%s) matches key "%s", result=%s',
                fmt_struct($addr), $mk[0], fmt_struct($result[0]));
    } else {  # want all matches
      do_log(5, "lookup_re(%s) matches keys: %s", fmt_struct($addr),
          join(', ', map {sprintf('"%s"=>%s', $mk[$_],fmt_struct($result[$_]))}
                         (0..$#result)));
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $have_patricia);
  $VERSION = '2.316';
  @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 triple 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)
#
sub ip_to_vec($;$) {
  my($ip,$allow_mask) = @_;
  my $ip_len; my @ip_fields;
  local($1,$2,$3,$4,$5,$6);
  $ip =~ s/^[ \t]+//; $ip =~ s/[ \t\r\n]+\z//s;  # trim
  my $ipa = $ip;
  ($ipa,$ip_len) = ($1,$2)  if $allow_mask && $ip =~ m{^([^/]*)/(.*)\z}s;
  $ipa = $1  if $ipa =~ m{^ \[ (.*) \] \z}xs;  # discard optional brackets
  $ipa =~ s/%[A-Z0-9:._-]+\z//si;        # discard interface specification
  if ($ipa =~ m{^(IPv6:)?(.*:)(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z}si){
    # IPv6 alternative form x:x:x:x:x:x:d.d.d.d
    my(@d) = ($3,$4,$5,$6);
    !grep($_ > 255, @d)
      or die "Invalid decimal field value in IPv6 address: [$ip]\n";
    $ipa = $2 . sprintf('%02X%02X:%02X%02X', @d);
  } elsif ($ipa =~ m{^\d{1,3}(?:\.\d{1,3}){0,3}\z}) {  # IPv4 form
    my(@d) = split(/\./,$ipa,-1);
    !grep($_ > 255, @d)
      or die "Invalid field value in IPv4 address: [$ip]\n";
    defined($ip_len) || @d==4
      or die "IPv4 address [$ip] contains fewer than 4 fields\n";
    $ipa = '::FFFF:' . sprintf('%02X%02X:%02X%02X', @d);  # IPv4-mapped IPv6
    if (!defined($ip_len)) { $ip_len = 32;   # no length, defaults to /32
    } elsif ($ip_len =~ /^\d{1,9}\z/) {      # /n, IPv4 CIDR notation
    } elsif ($ip_len =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\z/) {
      !grep($_ > 255, ($1,$2,$3,$4))
        or die "Illegal field value in IPv4 mask: [$ip]\n";
      my $mask1 = pack('C4', $1,$2,$3,$4);  # /m.m.m.m
      my $len = unpack('%b*', $mask1);      # count ones
      my $mask2 = pack('B32', '1' x $len);  # reconstruct mask from count
      $mask1 eq $mask2
        or die "IPv4 mask not representing 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
  }
  $ipa =~ s/^IPv6://i;
  # now we presumably have an IPv6 compressed or preferred form x:x:x:x:x:x:x:x
  if ($ipa !~ /^(.*?)::(.*)\z/s) {  # zero-compressing form used?
    @ip_fields = split(/:/,$ipa,-1);  # no, have preferred form
  } else {                          # expand zero-compressing form
    my($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 and die "IPv6 address [$ip] contains fewer than 8 fields\n";
  @ip_fields>8 and die "IPv6 address [$ip] contains more than 8 fields\n";
  !grep(!/^[0-9a-zA-Z]{1,4}\z/, @ip_fields)  # this is quite slow
    or die "Invalid syntax of IPv6 address: [$ip]\n";
  my $vec = pack('n8', map(hex($_),@ip_fields));
  if (!defined($ip_len)) { $ip_len = 128 }
  elsif ($ip_len !~ /^\d{1,3}\z/)
    { die "Invalid prefix length syntax in IP address: [$ip]\n" }
  elsif ($ip_len > 128)
    { die "IPv6 network prefix length greater than 128: [$ip]\n" }
  my $mask = pack('B128', '1' x $ip_len);
# do_log(5, "ip_to_vec: %s => %s/%d\n", $ip,unpack('B*',$vec),$ip_len);
  ($vec,$mask,$ip_len);
}

use vars qw($ip_mapd_vec $ip_mapd_mask $ip_6to4_vec $ip_6to4_mask);
BEGIN {
  ($ip_mapd_vec, $ip_mapd_mask) = ip_to_vec('::FFFF:0:0/96',1);  # IPv4-mapped
  ($ip_6to4_vec, $ip_6to4_mask) = ip_to_vec('2002::/16',1);   # 6to4, RFC 3056
  $ip_mapd_vec = $ip_mapd_vec & $ip_mapd_mask;  # just in case
  $ip_6to4_vec = $ip_6to4_vec & $ip_6to4_mask;  # just in case
}

# 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) = @_;
  my $have_ipv6;
  if ($ip =~ s/^IPv6://i) { $have_ipv6 = 1 }
  elsif ($ip =~ /:.*:/)   { $have_ipv6 = 1 }
  if ($have_ipv6 && $ip =~ /^[0:]+:ffff:/i) {  # triage for IPv4-mapped
    my($ip_vec,$ip_mask);
    if (eval { ($ip_vec,$ip_mask) = ip_to_vec($ip,0); 1 }) {  # valid IP addr
      if (($ip_vec & $ip_mapd_mask) eq $ip_mapd_vec) {  # IPv4-mapped?
        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;
      }
    }
  }
  lc $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.
#
# 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).
#
# The presence of a character '!' prepended to a list member decides
# whether the result will be true (without a '!') or false (with '!')
# in case this list member matches and terminates the search.
#
# Because search stops at the first match, it only makes sense
# to place more specific patterns before the more general ones.
#
# For IPv4 a network address can be specified in classless notation
# n.n.n.n/k, or using a mask n.n.n.n/m.m.m.m . Missing mask implies /32,
# i.e. a host address. For IPv6 addresses all RFC 3513 forms are allowed.
# See also comments at ip_to_vec().
#
# Although not a special case, it is good to remember that '::/0'
# always matches any IPv4 or IPv6 address (even syntactically invalid address).
#
# The '0/0' is equivalent to '::FFFF:0:0/96' and matches any syntactically
# valid IPv4 address (including IPv4-mapped IPv6 addresses), but not other
# IPv6 addresses!
#
# Example
#   given: @acl = qw( !192.168.1.12 172.16.3.3 !172.16.3.0/255.255.255.0
#                     10.0.0.0/8 172.16.0.0/12 192.168.0.0/16
#                     !0.0.0.0/8 !:: 127.0.0.0/8 ::1 );
#   matches 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 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::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
#
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;
use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.316';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&lookup &lookup2 &lookup_hash &lookup_acl);
  import Amavis::Util qw(ll do_log fmt_struct unique_list);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools qw(split_address make_query_keys);
}
use subs @EXPORT_OK;

# lookup_hash() performs a lookup for an e-mail address against a hash map.
# If a match is found (a hash key exists in the Perl hash) the function returns
# whatever the map returns, otherwise undef is returned. First match wins,
# aborting further search sequence.
#
sub lookup_hash($$;$%) {
  my($addr, $hash_ref,$get_all,%options) = @_;
  ref($hash_ref) eq 'HASH'
    or die "lookup_hash: arg2 must be a hash ref: $hash_ref";
  local($1,$2,$3,$4); my(@matchingkey,@result); my $append_string;
  $append_string = $options{AppendStr}  if 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] }gxse;
      # bring taintedness of input to the result
      $r .= substr($addr,0,0)  if $any;
    }
  }
  if (!ll(5)) {
    # only bother with logging when needed
  } elsif (!@result) {
    do_log(5,"lookup_hash(%s), no matches", $addr);
  } elsif (!$get_all) {  # first match wins
    do_log(5,'lookup_hash(%s) matches key "%s", result=%s',
              $addr, $matchingkey[0], !defined($result[0])?'undef':$result[0]);
  } else {  # want all matches
    do_log(5,"lookup_hash(%s) matches keys: %s", $addr,
              join(', ', map {sprintf('"%s"=>%s',$matchingkey[$_],$result[$_])}
                             (0..$#result)) );
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

# lookup_acl() performs a lookup for an e-mail address against
# access control list.
#
# The supplied e-mail address is compared with each member of the
# lookup list in turn, the first match wins (terminates the search),
# and its value decides whether the result is true (yes, permit, pass)
# or false (no, deny, drop). Falling through without a match produces
# false (undef). Search is always case-insensitive on domain part,
# local part matching depends on $localpart_is_case_sensitive setting.
#
# NOTE: lookup_acl is not aware of address extensions and they are
# not handled specially!
#
# If a list element contains a '@', the full e-mail address is compared,
# otherwise if a list element has a leading dot, the domain name part is
# matched only, and the domain as well as its subdomains can match. If there
# is no leading dot, the domain must match exactly (subdomains do not match).
#
# The presence of a character '!' prepended to a list element decides
# whether the result will be true (without a '!') or false (with '!')
# in case where this list element matches and terminates the search.
#
# Because search stops at the first match, it only makes sense
# to place more specific patterns before the more general ones.
#
# Although not a special case, it is good to remember that '.' always matches,
# so a '.' would stop the search and return true, whereas '!.' would stop the
# search and return false (0).
#
# Examples:
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'me.ac.uk' matches me.ac.uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'you.ac.uk' matches .ac.uk, returns false (because of '!') and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'them.co.uk' matches .uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'some.com' does not match anything, falls through and returns false (undef)
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk !. )
#   'some.com' similar to previous, except it returns 0 instead of undef,
#   which would only make a difference if this ACL is not the last argument
#   in a call to lookup(), because a defined result stops further lookups
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk . )
#   'some.com' matches catchall ".", and returns true. The ".uk" is redundant
#
# more complex example: @acl = qw(
#   !The.Boss@dept1.xxx.com .dept1.xxx.com
#   .dept2.xxx.com .dept3.xxx.com lab.dept4.xxx.com
#   sub.xxx.com !.sub.xxx.com
#   me.d.aaa.com him.d.aaa.com !.d.aaa.com .aaa.com
# );
#
sub lookup_acl($$%) {
  my($addr, $acl_ref,%options) = @_;
  ref($acl_ref) eq 'ARRAY'
    or die "lookup_acl: arg2 must be a list ref: $acl_ref";
  return  if !@$acl_ref;  # empty list can't match anything
  my $lpcs = c('localpart_is_case_sensitive');
  my($localpart,$domain) = split_address($addr); $domain = lc($domain);
  $localpart = lc($localpart)  if !$lpcs;
  local($1,$2);
  # chop off leading @ and trailing dots
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  $domain .= $options{AppendStr}  if 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.316';
  @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/sx ? \"$1"  # SpamAssassin-compatible
    : $_ }
    $$str_ref =~ /\G \# | \[ [?~\@:="]? | "\] | \] | \| | % \#? . | \\ [^0-7] |
                  \\ [0-7]{1,3} | _ [A-Z]+ (?: \( [^)]* \) )? _ |
                  [^\[\]\\|%\n#"_]+ | [^\n]+? | \n /gsx;
  $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 (ref($s) eq 'Amavis::Expand') {  # expand a dynamically defined macro
        my(@margs) = ($name);  # no arguments beyond %0
        my(@res) = map(!ref || $$_ !~ /^%([0-9])\z/ ? $_
                         : ref($margs[$1]) ? @{$margs[$1]} : (), @$s);
        $s = tokens_list_to_str(\@res);
      } elsif (ref($s) eq 'CODE') {
        if (exists($builtins_cached{$name})) {
          $s = $builtins_cached{$name};
        } else {
          while (ref($s) eq 'CODE') { $s = &$s($name) }
          $builtins_cached{$name} = $s;
        }
      }
      my $ind = 0;
      for my $val (ref($s) ? @$s : $s) {  # do substitutions in the body
        push(@result, @$sep_r)  if ++$ind > 1 && ref($sep_r);
        push(@result, map(ref && $$_ eq "%$cvar" ? $val : $_, @$body_r));
      }
    }
  } elsif ($macro_type == $lx_lbE) {  # define a new macro
    my $name = tokens_list_to_str(shift(@args));   # first arg is a macro name
    $name =~ s/^[ \t\n]+//; $name =~ s/[ \t\n]+\z//;  # trim whitespace on name
    delete $builtins_cached{$name};
    $builtins_href->{$name} = Amavis::Expand->newmacro(@{$args[0]});
  } elsif ($macro_type == $lx_lbA || $macro_type == $lx_lbC ||     # macro call
           $$macro_type =~ /^%(\#)?(.)\z/s) {
    my $name; my $cardinality_only = 0;
    if ($macro_type == $lx_lbA || $macro_type == $lx_lbC) {
      $name = tokens_list_to_str($args[0]);  # arg %0 is a macro name
      $name =~ s/^[ \t\n]+//; $name =~ s/[ \t\n]+\z//;  # trim whitespace
    } else {  # simple macro call %x or %#x
      $name = $2;
      $cardinality_only = 1  if defined $1;
    }
    my $s = $builtins_href->{$name};
    if (!ref($s)) {  # macro expands to a plain string
      if (!$cardinality_only) { @result = $s }
      else { @result = $s !~ /^\s*\z/ ? 1 : 0 };  # %#x => nonwhite=1, other 0
    } elsif (ref($s) eq 'Amavis::Expand') {  # dynamically defined macro
      $args[0] = $name;  # replace name with a stringified and trimmed form
      # expanding a dynamically-defined macro produces a list of tokens;
      # formal argument lexels %0, %1, ... %9 are replaced by actual arguments
      @result = map(!ref || $$_ !~ /^%([0-9])\z/ ? $_
                      : ref($args[$1]) ? @{$args[$1]} : (), @$s);
      if ($cardinality_only) {  # macro call form %#x
        @result = tokens_list_to_str(\@result) !~ /^\s*\z/ ? 1 : 0;
      }
    } else {  # subroutine or array ref
      if (ref($s) eq 'CODE') {
        if (exists($builtins_cached{$name}) && @args <= 1) {
          $s = $builtins_cached{$name};
        } elsif (@args <= 1) {
          while (ref($s) eq 'CODE') { $s = &$s($name) }  # callback
          $builtins_cached{$name} = $s;
        } else {
          shift(@args);  # discard original form of a macro name
          while (ref($s) eq 'CODE')  # subroutine callback
            { $s = &$s($name, map(tokens_list_to_str($_), @args)) }
        }
      }
      if ($cardinality_only) {  # macro call form %#x
        # for array: number of elements; for scalar: nonwhite=1, other 0
        @result = ref($s) ? scalar(@$s) : $s !~ /^\s*\z/ ? 1 : 0;
      } else {  # macro call %x evaluates to the value of macro x
        @result = ref($s) ? join(', ',@$s) : $s;
      }
    }
  }
  \@result;
}

sub expand($$) {
  my $str_ref       = shift;  # a ref to a source string to be macro expanded;
  my $builtins_href = shift;  # a hashref, mapping builtin macro names
                              # to macro values: strings or array refs
  my(@tokens);
  if (ref($str_ref) eq 'ARRAY') { @tokens = @$str_ref }
  else { tokenize($str_ref,\@tokens) }
  my $call_level = 0; my $quote_level = 0;
  my(@arg);  # stack of arguments lists to nested calls, [0] is top of stack
  my(@macro_type); # call stack of macro types (leading lexels) of nested calls
  my(@implied_q);  # call stack: is implied quoting currently active?
                   #   0 (not active) or 1 (active); element [0] stack top
  my(@open_quote); # quoting stack: opening quote lexel for each quoting level
  %builtins_cached = (); my $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/sx) {
      # neutral simple SA-like macro call, $1 is name, $2 is a single! argument
      my $result_ref = evalmacro($lx_lbC, $builtins_href, [$1],
                                 !defined($2) ? () : [$2] );
      if (defined $whereto) { push(@$whereto, @$result_ref) }
      else { $output_str .= tokens_list_to_str($result_ref) }
    } else {  # misplaced top-level lexical element
      if (defined $whereto) { push(@$whereto,$t) } else { $output_str .= $$t }
    }
  }
  %builtins_cached = ();  # 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.316';
  @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) = @_;
  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
  my $self=shift; !@_ ? $self->{tempdir_path} : ($self->{tempdir_path}=shift)
}
sub fh {        # email.txt file handle
  my $self=shift; !@_ ? $self->{fh_pers} : ($self->{fh_pers}=shift);
}
sub empty {     # whether the directory is empty
  my $self=shift; !@_ ? $self->{empty} : ($self->{empty}=shift)
}
sub preserve {  # whether to preserve directory when current task is done
  my $self=shift; !@_ ? $self->{preserve} : ($self->{preserve}=shift);
}

# Clean up the tempdir on shutdown
#
sub DESTROY {
  my $self = shift;
  local($@,$!,$_); 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) = @_;
  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) = @_;
  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) = @_;
  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 = shift;
  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 = shift;
  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) = @_;
  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);
            $inbuf = substr($inbuf, 0, $k >= 0 ? $k+1 : $size_limit-$pos);
            $beyond_limit = 1;
          }
          $pos += $nread;
          my $k = $#array + 1;  # insertion point
          push(@array, split(/^/m, $inbuf, -1));
          if (defined $carry) { $array[$k] = $carry.$array[$k]; $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.316';
  @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 = shift;
  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 = shift; local($@,$!,$_);
  # ignore failure, make perlcritic happy
  if (ref $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 = shift;  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.316';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform);
  import Amavis::Util qw(ll do_log min max minmax);
}

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%s", $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 =~ /^(?: \[ ([^\]]*) \] | ([^:]*) ) : ([^:]*)/sx) {
    # 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/sx) {
    $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 %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 UNIX socket $socketname: $!\n";
    $self->{last_event} = 'new-unix';

  } else {
    my $module = $have_socket_ip ? 'IO::Socket::IP'
               : $have_inet4 && (!$have_inet6 ||
                   $peeraddress=~/^\d+\.\d+\.\d+\.\d+\z/) ? 'IO::Socket::INET'
               : 'IO::Socket::INET6';
    my $local_sock_displ = '';
    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",
                      $module, $peeraddress, $peerport, $timeout_displ,
                      $blocking ? '' : ', nonblocking',
                      $local_sock_displ eq '' ? ''
                                              : ', local '.$local_sock_displ);
    if ($have_socket_ip) {  # $module eq 'IO::Socket::IP'
      # inet or inet6 socket, let IO::Socket::IP handle dirty details
      $sock = IO::Socket::IP->new(%args);
      # note: the IO::Socket::IP constructor provides error message in $@
      $sock or die "Can't connect to socket $socketname using $module: $@\n";
    } elsif ($module eq 'IO::Socket::INET') {  # inet socket (IPv4)
      $sock = IO::Socket::INET->new(%args);
      $sock or die "Can't connect to socket $socketname using $module: $!\n";
    } else {  # inet6 socket: no inet or IPv6 or unknown addr family
      $sock = IO::Socket::INET6->new(%args);
      $sock or die "Can't connect to socket $socketname using $module: $!\n";
    }
    $self->{last_event} = 'new-'.$module;
  }
  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,
             "Error flushing socket on 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,
                       "Error closing socket on 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
  { my $self=shift; !@_ ? $self->{socketname} : ($self->{socketname}=shift) }

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

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

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

sub eof
  { my $self=shift; $self->{inpeof} && $self->{inp} eq '' ? 1 : 0 }

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=shift; $self->rw_loop(0,1) if $self->{out} ne ''; 1 }

sub out_buff_large
  { my $self=shift; 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) = @_;
  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) = @_;
  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,%params) = @_;
  $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,"Error on socket: %s",$msg) },
    %params,
  ) or die "Error upgrading socket to SSL: ".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.316';
  @ISA = qw(Exporter);
}

sub new
  { my($class) = @_; bless {}, $class }
sub client_ip      # client IP address (immediate SMTP client, i.e. our MTA)
  { my $self=shift; !@_ ? $self->{client_ip}  : ($self->{client_ip}=shift) }
sub socket_ip      # IP address of our interface that received connection
  { my $self=shift; !@_ ? $self->{socket_ip}  : ($self->{socket_ip}=shift) }
sub socket_port    # TCP port of our interface that received connection
  { my $self=shift; !@_ ? $self->{socket_port}: ($self->{socket_port}=shift) }
sub socket_proto   # TCP/UNIX
  { my $self=shift; !@_ ? $self->{socket_proto}:($self->{socket_proto}=shift)}
sub socket_path    # socket path, UNIX sockets only
  { my $self=shift; !@_ ? $self->{socket_path}: ($self->{socket_path}=shift)}
# RFC 3848
sub appl_proto     # SMTP/ESMTP(A|S|SA)/LMTP(A|S|SA) / AM.PDP/AM.CL/QMQP/QMQPqq
  { my $self=shift; !@_ ? $self->{appl_proto} : ($self->{appl_proto}=shift) }
sub smtp_helo      # (E)SMTP HELO/EHLO parameter
  { my $self=shift; !@_ ? $self->{smtp_helo}  : ($self->{smtp_helo}=shift) }

1;

#
package Amavis::In::Message::PerRecip;

use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.316';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform);
  import Amavis::Util qw(setting_by_given_contents_category_all
                         setting_by_given_contents_category cmp_ccat);
}

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

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

sub recip_final_addr {  # return recip_addr_modified if set, else recip_addr
  my $self = shift;
  my $newaddr = $self->recip_addr_modified;
  defined $newaddr ? $newaddr : $self->recip_addr;
}

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

# add new findings to the contents_category list
#
sub add_contents_category {
  my($self, $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.316';
  @ISA = qw(Exporter);
  import Amavis::Conf qw(:platform);
  import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp quote_rfc2821_local
                                       qquote_rfc2821_local);
  import Amavis::Util qw(orcpt_encode ll do_log);
  import Amavis::In::Message::PerRecip;
}

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

# new style of providing additional information from checkers
sub supplementary_info {  # holds a hash of tag/value pairs, 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(orcpt_encode($per_recip_obj->recip_addr_smtp))
        if $set_dsn_orcpt_too;
      $per_recip_obj->recip_destiny(D_PASS);  # default is Pass
      $per_recip_obj } @{$recips_list_ref} ]);
  }
  return  if !defined wantarray;  # don't bother
  # return listref of recipient addresses
  [ map($_->recip_addr, @{$self->per_recip_data}) ];
}

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

# return a j-th header field with a given field name, along with its index
# 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($field_ind, $field, $all_fields, $hfield_indices);
  $hfield_indices =  # arrayref of h.field indices for a given h.field name
    $self->orig_header_fields->{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.316';
  @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_ascii safe_encode_utf8);
}
use MIME::Words;
use Errno qw(EBADF);

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

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

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

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

# now a synonym for append_header_above_received()  (old semantics: prepend
# or append, depending on setting of $append_header_fields_to_bottom)
#
sub add_header($$$;$) {
  my($self, $field_name, $field_body, $structured) = @_;
  push(@{$self->{addrcvd}}, hdr($field_name,$field_body,$structured));
}

# delete all header fields with 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, $structured) = @_;
  # $field_edit_sub will be called with 2 args: a field name and a field body;
  # It should return a pair consisting of a replacement field body (no field
  # name and no colon, with or without a trailing NL), and a boolean 'verbatim'
  # (false in its absence). An undefined replacement field body indicates a
  # deletion of the entire header field. A value true in the second returned
  # element indicates that a verbatim replacement is desired (i.e. no other
  # changes are allowed on a replacement body such as folding or encoding).
  !defined($field_edit_sub) || ref($field_edit_sub) eq 'CODE'
    or die "edit_header: arg#3 must be undef or a subroutine ref";
  $field_name = lc($field_name);
  if (!exists($self->{edit}{$field_name})) {
    $self->{edit}{$field_name} = [$field_edit_sub];
  } else {
    do_log(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 characters, and SHOULD be no more than 78 characters, excluding
# the CRLF). $structured==0 indicates an unstructured header field,
# folding may be inserted at any existing whitespace character position;
# $structured==1 indicates that folding is only allowed at positions
# indicated by \n in the provided header body, original \n will be removed.
# With $structured==2 folding is preserved, wrapping step is skipped.
#
sub hdr($$$;$) {
  my($field_name, $field_body, $structured, $wrap_char) = @_;
  $wrap_char = "\t"  if !defined $wrap_char;
  local($1);
  if ($field_name =~ /^ (?: Subject\z | Comments\z |
                            X- (?! Envelope- (?:From|To)\z ) )/six &&
      $field_body !~ /^[\t\n\040-\176]*\z/  # not all printable (or TAB or LF)
  ) {  # encode according to RFC 2047
    # actually RFC 2047 also allows encoded-words in rfc822 extension
    # message header fields (now: optional header fields), within comments
    # in structured header fields, or within 'phrase' (e.g. in From, To, Cc);
    # we are being sloppy here!
    $field_body =~ s/\n(?=[ \t])//gs;  # unfold
    chomp($field_body);
    my $field_body_octets;
    my $chset = c('hdr_encoding');  my $qb = c('hdr_encoding_qb');
    $field_body_octets = safe_encode($chset, $field_body);
#   do_log(5, "hdr - UTF-8 body:  %s", $field_body);
#   do_log(5, "hdr - body octets: %s", $field_body_octets);
    my $encoder_func = uc($qb) eq 'Q' ? \&q_encode
                                      : \&MIME::Words::encode_mimeword;
    $field_body = join("\n", map { /^[\001-\011\013\014\016-\177]*\z/ ? $_
                                     : &$encoder_func($_,$qb,$chset) }
                                 split(/\n/, $field_body_octets, -1));
  } else {  # supposed to be in plain ASCII, let's make sure it is
    $field_body = safe_encode_ascii($field_body);
  }
  $field_name = safe_encode_ascii($field_name);
  my $str = $field_name . ':';
  $str .= ' '  if $field_body =~ /^[^ \t]/;  # 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($_,0,998-3).'...'; $trunc = 1 } }
    if ($trunc) {
      do_log(0, "INFO: truncating long header field (len=%d): %s[...]",
             length($str), substr($str,0,100) );
      $str = join("\n",@lines);
    }
  }
  $str =~ 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);
            chomp($curr_head); $curr_head .= "\n";
            $curr_head =~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s;
            $field_body = $2; chomp($field_body);  # carry to next iteration
          }
        }
      }
      if (defined $curr_head) {
        if ($fix_bare_cr) { # sanitize header sect. by removing CR characters
          $curr_head =~ tr/\r//d  and $ill_bare_cr++;
        }
        if ($fix_whitespace_lines) {  # unfold illegal all-whitespace lines
          $curr_head =~ s/\n(?=[ \t]*\n)//g  and $ill_white_cnt++;
        }
        if ($fix_long_header_lines) {  # truncate long header lines to 998 ch
          $curr_head =~ s{^(.{995}).{4,}$}{$1...}mg  and $ill_long_cnt++;
        }
        # 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.316';
  @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.316';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&parse_ip_address_from_received &first_received_from);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Util qw(ll do_log unique_list);
  import Amavis::rfc2821_2822_Tools qw(
                   split_address parse_received fish_out_ip_from_received);
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Lookup::IP qw(lookup_ip_acl);
}
use subs @EXPORT_OK;

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


# Try to extract sender's IP address from the Received trace.
# When $search_top_down is true: search top-down, use first valid IP address;
# otherwise, search bottom-up, use the first *public* IP address from the trace
#
use vars qw(@nonhostlocalnetworks_maps @publicnetworks_maps);
sub parse_ip_address_from_received($;$) {
  my($msginfo,$search_top_down) = @_;
  @publicnetworks_maps = (
    Amavis::Lookup::Label->new('publicnetworks'),
    Amavis::Lookup::IP->new(qw(
      !0.0.0.0/8 !127.0.0.0/8 !169.254.0.0/16 !:: !::1 !FE80::/10
      !172.16.0.0/12 !192.168.0.0/16 !10.0.0.0/8 !FEC0::/10
      !192.88.99.0/24 !240.0.0.0/4 !224.0.0.0/4 !FF00::/8
      ::FFFF:0:0/96 ::/0)) )  if !@publicnetworks_maps;
      # RFC 5735 (ex RFC 3330), RFC 3513
  my $received_from_ip;
  my(@search_list) = $search_top_down ? (0,1)  # the topmost two Received flds
               : (-1,-2,-3,-4,-5,-6);  # bottom-up, first six chronologically
  for my $j (@search_list) {  # walk through a list of Received field indices
    my $r = $msginfo->get_header_field_body('received',$j);
    last  if !defined $r;
    $received_from_ip = fish_out_ip_from_received($r);
    if ($received_from_ip ne '') {
      last  if $search_top_down;  # any valid address would do
      my($is_public,$fullkey,$err) =
        lookup_ip_acl($received_from_ip,@publicnetworks_maps);
      last  if (!defined($err) || $err eq '') && $is_public;
    }
  }
  do_log(5, "parse_ip_address_from_received: %s", $received_from_ip);
  $received_from_ip;
}

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.316';
  @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));
  do_log(4,"Original mail size: %d; quota set to: %d bytes",
           $mail_size,$avail_quota);
  # create object
  bless {
    num_of_issued_names => 0,  first_issued_ind => 1,  last_issued_ind => 0,
    maxfiles => $maxfiles,  # undef disables limit
    objlist => [],
  }, $class;
}

sub parts_list_reset($) {  # clear a list of recently issued names
  my $self = shift;
  $self->{num_of_issued_names} = 0;
  $self->{first_issued_ind} = $self->{last_issued_ind} + 1;
  $self->{objlist} = [];
}

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

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

sub generate_new_num($$) {  # make-up a new number for a file and return it
  my($self, $ignore_limit) = @_;
  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.316';
  @ISA = qw(Exporter);
  import Amavis::Util qw(ll do_log);
}

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

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

sub number
  { my $self=shift; !@_ ? $self->{number}   : ($self->{number}=shift) };
sub dir_name
  { my $self=shift; !@_ ? $self->{dir_name} : ($self->{dir_name}=shift) };
sub parent
  { my $self=shift; !@_ ? $self->{parent}   : ($self->{parent}=shift) };
sub children
  { my $self=shift; !@_ ? $self->{children}||[] : ($self->{children}=shift) };
sub mime_placement    # part location within a MIME tree, e.g. "1/1/3"
  { my $self=shift; !@_ ? $self->{place}    : ($self->{place}=shift) };
sub type_short        # string or a ref to a list of strings, case sensitive
  { my $self=shift; !@_ ? $self->{ty_short} : ($self->{ty_short}=shift) };
sub type_long
  { my $self=shift; !@_ ? $self->{ty_long}  : ($self->{ty_long}=shift) };
sub type_declared
  { my $self=shift; !@_ ? $self->{ty_decl}  : ($self->{ty_decl}=shift) };
sub name_declared     # string or a ref to a list of strings
  { my $self=shift; !@_ ? $self->{nm_decl}  : ($self->{nm_decl}=shift) };
sub report_type       # a string, e.g. 'delivery-status', RFC 3462
  { my $self=shift; !@_ ? $self->{rep_typ}  : ($self->{rep_typ}=shift) };
sub size
  { my $self=shift; !@_ ? $self->{size}     : ($self->{size}=shift) };
sub exists
  { my $self=shift; !@_ ? $self->{exists}   : ($self->{exists}=shift) };
sub attributes        # listref of characters representing attributes
  { my $self=shift; !@_ ? $self->{attr}     : ($self->{attr}=shift) };
sub attributes_add {  # U=undecodable, C=crypted, D=directory,S=special,L=link
  my $self = shift; my $a = $self->{attr} || [];
  for my $arg (@_) { push(@$a,$arg)  if $arg ne '' && !grep($_ eq $arg, @$a) }
  $self->{attr} = $a;
};

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

sub full_name {
  my $self = shift; my $d = $self->dir_name;
  !defined($d) ? undef : $d.'/'.$self->base_name;
}

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

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.316';
  @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.316';
  @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
                         sanitize_str);
  import Amavis::Conf qw(:platform %banned_rules c cr ca);
  import Amavis::Lookup qw(lookup lookup2);
}
use subs @EXPORT_OK;

sub check_header_validity($) {
  my($msginfo) = @_;
  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_missing,$t_multiple) =
    !$allowed_tests ? () : @$allowed_tests{'syntax','empty','long','control',
                                           '8bit','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;-\176]+)[ \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";
        $pre = ''; $mid = ''; $post = $curr_head;
        $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) {
      $mid = $1; $msg1 = "Header line longer than 998 characters";
      $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 =~ /([\200-\377])/gs) {
      $mid = $1; $msg1 = "Non-encoded 8-bit data";
      $minor_badh_category = max(2, $minor_badh_category);
    } elsif ($t_8bit && $curr_head =~ /([^\000-\377])/gs) {
      $mid = $1; $msg1 = "Non-encoded Unicode character";  # should not happen
      $minor_badh_category = max(2, $minor_badh_category);
    }
    if (defined $msg1) {
      $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);
      if (length($mid)  > 20) { $mid  = substr($mid, 0,15) . '[...]' }
      if (length($post) > 20) { $post = substr($post,0,15) . '[...]' }
      if (length($pre)-length($field_name)-2 > 50-length($post)) {
        $pre = $field_name . ': ...'
               . substr($pre, length($pre) - (45-length($post)));
      }
      $msg1 .= sprintf(" (char %02X hex)", ord($mid))  if length($mid)==1;
      $msg2 = sanitize_str($pre . $mid . $post);
      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);
    }
  }
  if (!@bad)
    { do_log(5,"check_header: %d, OK", $minor_badh_category) }
  elsif (ll(2))
    { do_log(2,"check_header: %d, %s", $minor_badh_category, $_)  for @bad }
  (\@bad, $minor_badh_category);
}

sub check_for_banned_names($) {
  my($msginfo) = @_;
  do_log(3, "Checking for banned types and filenames");
  my $bfnmr = ca('banned_filename_maps');  # two-level map: recip, partname
  my(@recip_tables);  # a list of records describing banned tables for recips
  my $any_table_in_recip_tables = 0;  my $any_not_bypassed = 0;
  for my $r (@{$msginfo->per_recip_data}) {
    my $recip = $r->recip_addr;
    my(@tables,@tables_m);  # list of banned lookup tables for this recipient
    if (!$r->bypass_banned_checks) {  # not bypassed
      $any_not_bypassed = 1;
      my($t_ref,$m_ref) = lookup2(1,$recip,$bfnmr);
      if (defined $t_ref) {
        for my $ti (0..$#$t_ref) { # collect all relevant tables for each recip
          my $t = $t_ref->[$ti];
          # an entry may be a ref to a list of lookup tables, or a comma- or
          # whitespace-separated list of table names (suitable for SQL),
          # which are mapped to actual lookup tables through %banned_rules
          if (!defined($t)) {
            # ignore
          } elsif (ref($t) eq 'ARRAY') {  # a list of actual lookup tables
            push(@tables, @$t);
            push(@tables_m, ($m_ref->[$ti]) x @$t);
          } else {  # a list of rules _names_, to be mapped via %banned_rules
            my(@names);
            my(@rawnames) = grep(!/^[, ]*\z/,
                                 ($t =~ /\G (?: " (?: \\. | [^"\\] ){0,999} "
                                              | [^, ] )+ | [, ]+/gsx));
            # in principle quoted strings could be used
            # to construct lookup tables on-the-fly (not implemented)
            for my $n (@rawnames) {  # collect only valid names
              if (!exists($banned_rules{$n})) {
                do_log(2,"INFO: unknown banned table name %s, recip=%s",
                         $n,$recip);
              } elsif (!defined($banned_rules{$n})) {  # ignore undef
              } else { push(@names,$n) }
            }
            ll(3) && do_log(3,"collect banned table[%d]: %s, tables: %s",
              $ti,$recip, join(', ',map($_.'=>'.$banned_rules{$_}, @names)));
            if (@names) {  # any known and valid table names?
              push(@tables, map($banned_rules{$_}, @names));
              push(@tables_m, ($m_ref->[$ti]) x @names);
            }
          }
        }
      }
    }
    push(@recip_tables, { r => $r, recip => $recip,
                          tables => \@tables, tables_m => \@tables_m } );
    $any_table_in_recip_tables=1  if @tables;
  }
  my $bnpre = cr('banned_namepath_re');
  $bnpre = $$bnpre  if ref($bnpre) eq 'REF';  # allow one level of indirection
  if (!$any_not_bypassed) {
    do_log(3,"skipping banned check: all recipients bypass banned checks");
  } elsif (!$any_table_in_recip_tables && !ref($bnpre)) {
    do_log(3,"skipping banned check: no applicable lookup tables");
  } else {
    do_log(4,"starting banned checks - traversing message structure tree");
    my $parts_root = $msginfo->parts_root;
    my $part;
    for (my(@unvisited)=($parts_root);
         @unvisited and $part=shift(@unvisited);
         push(@unvisited,@{$part->children}))
    { # traverse decomposed parts tree breadth-first
      my(@path) = @{$part->path};
      next  if @path <= 1;
      shift(@path);  # ignore place-holder root node
      next  if @{$part->children};  # ignore non-leaf nodes
      my(@descr_trad);  # a part path: list of predecessors of a message part
      my(@descr);  # same, but in form suitable for check on banned_namepath_re
      for my $p (@path) {
        my(@k,$n);
        $n = $p->base_name;
        if ($n ne '') { $n=~s/[\t\n]/ /g; push(@k,"P=$n") }
        $n = $p->mime_placement;
        if ($n ne '') { $n=~s/[\t\n]/ /g; push(@k,"L=$n") }
        $n = $p->type_declared;
        $n = [$n]  if !ref($n);
        for (@$n) {if ($_ ne ''){my $m=$_; $m=~s/[\t\n]/ /g; push(@k,"M=$m")}}
        $n = $p->type_short;
        $n = [$n]  if !ref($n);
        for (@$n) {if (defined($_) && $_ ne '')
                     {my $m=$_; $m=~s/[\t\n]/ /g; push(@k,"T=$m")} }
        $n = $p->name_declared;
        $n = [$n]  if !ref($n);
        for (@$n) {if (defined($_) && $_ ne '')
                     {my $m=$_; $m=~s/[\t\n]/ /g; push(@k,"N=$m")} }
        $n = $p->attributes;
        $n = [$n]  if !ref($n);
        for (@$n) {if (defined($_) && $_ ne '')
                     {my $m=$_; $m=~s/[\t\n]/ /g; push(@k,"A=$m")} }
        push(@descr, join("\t",@k));
        push(@descr_trad, [map { local($1,$2);
             /^([a-zA-Z0-9])=(.*)\z/s; my($key_what,$key_val) = ($1,$2);
             $key_what eq 'M' || $key_what eq 'N' ? $key_val
           : $key_what eq 'T' ? ('.'.$key_val)  # prepend a dot (compatibility)
           : $key_what eq 'A' && $key_val eq 'U' ? 'UNDECIPHERABLE' : ()} @k]);
      }
      # we have obtained a description of a part as a list of its predecessors
      # in a message structure including the part itself at the end of the list
      my $key_val_str = join(' | ',@descr);  $key_val_str =~ s/\t/,/g;
      my $key_val_trad_str = join(' | ', map(join(',',@$_), @descr_trad));
      # simplified result to be presented in 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 }egsx;
          do_log($result?1:3, 'p.path%s %s: "%s"%s',
                           !$result?'':" BANNED:$result", $recip, $key_val_str,
                           !defined $result ? '' : ", matching_key=\"$mk\"");
        }
        my $a;
        if ($result) {  # the part being tested is banned for this recipient
          $a = $r->banned_parts    || [];
          push(@$a,$part_descr_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* \) /gsx;
          $a = $r->banning_rule_comment || [];
          push(@$a, @comments ? join(' ',@comments) : $matchingkey);
          $r->banning_rule_comment($a);
          if (!defined($r->banning_reason_short)) {  # just the first
            my $s = $part_name;
            $s =~ s/[ \t]{6,}/ ... /g;  # compact whitespace
            $s = join(' ',@comments) . ':' . $s  if @comments;
            $r->banning_reason_short($s);
          }
        }
      }
    # last  if !grep(!$_->{result}, @recip_tables);  # stop if all recips true
    } # endfor: message tree traversal
  } # endif: doing parts checking
}

1;

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.316';
  @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_encode safe_encode_ascii safe_encode_utf8);
  import Amavis::Unpackers::NewFilename qw(consumed_bytes);
}
use subs @EXPORT_OK;

use Errno qw(ENOENT EACCES);
use IO::File qw(O_CREAT O_EXCL O_WRONLY);
use MIME::Parser;
use MIME::Words;
# 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)
    my $fn = $body->path; my $size;
    if (!defined($fn)) {
      $size = length($body->as_string);
    } else {
      my $msg; my $errn = lstat($fn) ? 0 : 0+$!;
      if ($errn == ENOENT) { $msg = "does not exist" }
      elsif ($errn) { $msg = "is inaccessible: $!" }
      elsif (!-r _) { $msg = "is not readable" }
      elsif (!-f _) { $msg = "is not a regular file" }
      else {
        $size = -s _;
        do_log(4,"mime_traverse: file %s is empty", $fn)  if $size==0;
      }
      do_log(-1,"WARN: mime_traverse: file %s %s", $fn,$msg)  if defined $msg;
    }
    consumed_bytes($size, 'mime_decode', 0, 1);
    # retrieve Amavis::Unpackers::Part object (if any), stashed into head obj
    $part = Amavis::Unpackers::OurFiler::get_amavisd_part($head);
    if (defined $part) {
      $part->size($size);
      if (defined($size) && $size==0)
        { $part->type_short('empty'); $part->type_long('empty') }
      ll(2) && do_log(2, "%s %s Content-Type: %s, size: %d B, name: %s",
                      $part->base_name, $placement, $mt, $size,
                      $entity->head->recommended_filename);
      my $old_parent_obj = $part->parent;
      if ($parent_obj ne $old_parent_obj) {  # reparent if necessary
        ll(5) && do_log(5,"reparenting %s from %s to %s", $part->base_name,
                          $old_parent_obj->base_name, $parent_obj->base_name);
        my $ch_ref = $old_parent_obj->children;
        $old_parent_obj->children([grep($_ ne $part, @$ch_ref)]);
        $ch_ref = $parent_obj->children;
        push(@$ch_ref,$part); $parent_obj->children($ch_ref);
        $part->parent($parent_obj);
      }
    }
  }
  if (defined $part) {
    $part->mime_placement($placement);
    $part->type_declared($mt eq $et ? $mt : [$mt, $et]);
    $part->attributes_add('U','C')  if $mt =~ m{/encrypted}i ||
                                       $et =~ m{/encrypted}i;
    my %rn_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;
          $encoding = 'ISO-8859-1'  if !defined $encoding || $encoding eq '';
          $encoding =~ s/\*[^*]*\z//;  # 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');
    if (defined $val && $val ne '') {
      # $val = safe_encode_utf8($val);
      $part->report_type($val);
    }
  }
  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 messages
  $parser->extract_nested_messages(0);
# $parser->extract_nested_messages("NEST");  # parse embedded message/rfc822
    # "NEST" complains with "part did not end with expected boundary" when
    # the outer message is message/partial and the inner message is chopped
  $parser->extract_uuencode(1);              # to enable or not to enable ???
  $parser->max_parts($MAXFILES)  if 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;
    $mime_err = substr($mime_err,0,250) . '[...]'  if length($mime_err) > 250;
    do_log(1, "WARN: MIME::Parser %s", $mime_err)  if $mime_err ne '';
  } elsif (!defined($entity)) {
    $mime_err = "Unable to parse, perhaps message contains too many parts";
    do_log(1, "WARN: MIME::Parser %s", $mime_err);
    $entity = '';
  }
  mime_traverse($entity, $tempdir, $parent_obj, 0, '1')  if $entity;
  section_time('mime_decode');
  ($entity, $mime_err);
}

1;

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

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

use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.316';
  @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.316';
  @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
                  safe_encode safe_encode_ascii safe_encode_utf8
                  untaint untaint_inplace make_password
                  orcpt_decode xtext_decode ccat_split ccat_maj);
  import Amavis::Timing qw(section_time);
  import Amavis::Conf qw(:platform :confvars c cr ca);
  import Amavis::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 ();
# use Encode;  # Perl 5.8  UTF-8 support

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

# 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 }egs;
    $_ = $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 hide it
    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)}i) {
    my $multipart_cnt = 0;
    $multipart_cnt++  if $mail_as_string_ref;
    $multipart_cnt++  if defined $msginfo &&
                        ($attach_orig_headers || $attach_orig_message);
    $mime_type = 'multipart/mixed'  if $multipart_cnt > 1;
  }
  my($entity,$m_hdr,$m_body);
  if (!$mail_as_string_ref) {
    # no plain text part
  } elsif ($$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/sx
    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);
    }
  }
  $m_body = safe_encode(c('bdy_encoding'), $m_body)  if defined $m_body;
  # make sure _our_ source line number is reported in case of failure
  my $multipart_cnt = 0;
  eval {
    $entity = MIME::Entity->build(
      Type => defined $mime_type ? $mime_type : 'multipart/mixed',
      Encoding => '7bit', '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);
        my $str = hdr($fhead,$fbody,0,' ');  # encode, wrap, ...
        # re-split the result
        ($fhead,$fbody) = ($1,$2)  if $str =~ /^([^:]*):[ \t]*(.*)\z/s;
        chomp($fbody);
        do_log(5, "build_mime_entity %s: %s", $fhead,$fbody);
        eval {  # make sure _our_ source line number is reported on failure
          $head->replace($fhead,$fbody);  1;
        } or do {
          $@ = "errno=$!"  if $@ eq '';  chomp $@;
          die $@  if $@ =~ /^timed out\b/;  # resignal timeout
          die sprintf("%s header field '%s: %s'",
                      ($@ eq '' ? "invalid" : "$@, "), $fhead,$fbody);
        };
      }
    }
  }
  my(@prefix_lines);
  if (defined $m_body) {
    if ($flat && $attach_orig_message) {
      my($pos,$j);  # split $m_body into lines, retaining each \n
      for ($pos=0; ($j=index($m_body,"\n",$pos)) >= 0; $pos = $j+1)
        { push(@prefix_lines, substr($m_body,$pos,$j-$pos+1)) }
      push(@prefix_lines, substr($m_body,$pos))  if $pos < length($m_body);
    } else {
      eval {  # make sure _our_ source line number is reported on failure
        $entity->attach(
          Type => 'text/plain', Data => $m_body,
          Encoding => '-SUGGEST', Charset => c('bdy_encoding'),
        );  $multipart_cnt++; 1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        die $eval_stat;
      };
    }
  }
  # prepend a Return-Path to make available the envelope sender address
  push(@prefix_lines, "\n")  if @prefix_lines;  # separates text from a message
  push(@prefix_lines, sprintf("Return-Path: %s\n", $msginfo->sender_smtp));

  if (defined $msginfo && $attach_orig_headers && !$attach_orig_message) {
    # attach a header section only
    do_log(4, "build_mime_entity: attaching just original header section");
    eval {  # make sure _our_ source line number is reported on failure
      $entity->attach(
        Type => $flat ? 'text/plain' : 'text/rfc822-headers',  # RFC 3462
        Encoding => $msginfo->header_8bit ? '8bit' : '7bit',
        Data => [@prefix_lines, @{$msginfo->orig_header}],
        Disposition => 'inline',  Filename => 'header',
        Description => 'Message header section',
      );  $multipart_cnt++; 1;
    } or do {
      my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
      die $eval_stat;
    };

  } 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 hide it
      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: $!";
      }
      eval {  # make sure _our_ source line number is reported on failure
        my $att = $entity->attach(  # RFC 2046
          Type => $flat ? 'text/plain' : 'message/rfc822',
          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,
          $flat ? () : (Disposition => 'attachment', Filename => 'message',
                        Description => 'Original message'),
        );
        # 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 3462 (ex 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;
  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
  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 $txt_recip = '';  # per-recipient part of dsn text according to RFC 3464
  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($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 (defined($msginfo->is_bulk) &&
             ccat_maj($r->contents_category) > CC_CLEAN) {
      $suppressed = 1;
      do_log(3, "DSN: FILTER %s %s, suppressed, bulk mail (%s), <%s> -> <%s>",
                $smtp_resp_code,$ccat_name,$msginfo->is_bulk,$sender,$recip);
    } elsif ($os_fingerprint =~ /^Windows\b/ &&   # hard-coded limits!
             !$msginfo->dkim_envsender_sig   &&   # a hack
             $spam_level >=
               ($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) {
        my($addr_type,$orcpt) = orcpt_decode($dsn_orcpt);
        $txt_recip .= "Original-Recipient: " .
                      sanitize_str($addr_type.';'.$orcpt) . "\n";
      }
      my $remote_mta = $r->recip_remote_mta;
      if (!defined($dsn_orcpt) && $remote_mta ne '' &&
          $r->recip_final_addr ne $recip) {
        $txt_recip .= "X-NextToLast-Final-Recipient: rfc822;" .
                      quote_rfc2821_local($recip) . "\n";
        $txt_recip .= "Final-Recipient: rfc822;" .
                      quote_rfc2821_local($r->recip_final_addr) . "\n";
      } else {
        $txt_recip .= "Final-Recipient: rfc822;" .
                      quote_rfc2821_local($recip) . "\n";
      }
      local($1,$2,$3);  my($smtp_resp_code,$smtp_resp_enhcode,$smtp_resp_msg);
      if ($smtp_resp =~ /^ (\d{3}) [ \t-] [ \t]* ([245] \. \d{1,3} \. \d{1,3})?
                           \s* (.*) \z/xs) {
        ($smtp_resp_code, $smtp_resp_enhcode, $smtp_resp_msg) = ($1,$2,$3);
      } else {
        $smtp_resp_msg = $smtp_resp;
      }
      if ($smtp_resp_enhcode eq '' && $smtp_resp_class =~ /^([245])\z/) {
        $smtp_resp_enhcode = "$1.0.0";
      }
      my $action;  # failed / relayed / delivered / expanded
      if ($recip_done == 2) {  # truly forwarded to MTA
        $action = $smtp_resp_class eq '5' ? 'failed'     # remote reject
                : $smtp_resp_class ne '2' ? undef        # shouldn't happen
                : !$dsn_passed_on ? 'relayed'   # relayed to non-conforming MTA
                : $warn_sender ? 'delayed'  # disguised as a DELAY notification
                : undef;  # shouldn't happen
      } elsif ($recip_done == 1) { # faked delivery to bit bucket or quarantine
        $action = $smtp_resp_class eq '5' ? 'failed'     # local reject
                : $smtp_resp_class eq '2' ? 'delivered'  # discard / bit bucket
                : undef;  # shouldn't happen
      } elsif (!defined($recip_done) || $recip_done == 0) {
        $action = $smtp_resp_class eq '2' ? 'relayed'  #????
                : undef;  # shouldn't happen
      }
      defined $action  or die "Assert failed: $smtp_resp, $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";
      $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
  if ( $is_arf || $is_plain || $is_attach ||
      ($is_dsn && ($any_succ || $any_fail || $any_delayed)) ) {
    my(@hdr_to) = defined $notif_recips ? qquote_rfc2821_local(@$notif_recips)
                                : map($_->recip_addr_smtp, @$per_recip_data);
    my $hdr_from = $msginfo->setting_by_contents_category(
                              $is_dsn ? cr('hdrfrom_notify_sender_by_ccat') :
            $request_type eq 'report' ? cr('hdrfrom_notify_report_by_ccat') :
                                        cr('hdrfrom_notify_release_by_ccat') );
    $hdr_from = expand_variables($hdr_from);
    # use the provided template text
    my(%mybuiltins) = %$builtins_ref;  # make a local copy
    # not really needed, these header fields are overridden later
    $mybuiltins{'f'} = $hdr_from;
    $mybuiltins{'T'} = \@hdr_to;
    $mybuiltins{'d'} = $rfc2822_dsn_time;
    $mybuiltins{'report_format'} = $msg_format;
    $mybuiltins{'feedback_type'} = $feedback_type;

    # 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);
    my $report_entity = build_mime_entity($report_str_ref, $msginfo,
      $is_dsn ? 'multipart/report; report-type=delivery-status' :
      $is_arf ? 'multipart/report; report-type=feedback-report' :
                'multipart/mixed',
      $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 $@ };

    my $dsn_envid = $msginfo->dsn_envid;  # ENVID is encoded as xtext: RFC 3461
    $dsn_envid = sanitize_str(xtext_decode($dsn_envid))  if defined $dsn_envid;
    my $txt_msg = '';  # per-message part of a report
    if ($is_arf) {  # abuse report format - 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; " . c('myhostname') . "\n";
      # optional fields:
      $txt_msg .= "Arrival-Date: ". rfc2822_timestamp($msginfo->rx_time) ."\n";
      my $cl_ip_addr = $msginfo->client_addr;
      $cl_ip_addr = 'IPv6:'.$cl_ip_addr  if $cl_ip_addr =~ /:.*:/ &&
                                            $cl_ip_addr !~ /^IPv6:/i;
      $txt_msg .= "Source-IP: $cl_ip_addr\n"  if defined $cl_ip_addr;
      # 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;
      $txt_msg .= "Original-Envelope-Id: $dsn_envid\n"  if defined $dsn_envid;
      $txt_msg .= "Original-Mail-From: " . $msginfo->sender_smtp . "\n";
      for my $r (@$per_recip_data)
        { $txt_msg .= "Original-Rcpt-To: " . $r->recip_addr_smtp . "\n" }
      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
    } elsif ($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; " . c('myhostname') . "\n";
      $txt_msg .= "Received-From-MTA: smtp; $from_mta ([$client_ip])\n"
        if $from_mta ne '';
      $txt_msg .= "Arrival-Date: ". rfc2822_timestamp($msginfo->rx_time) ."\n";
      $txt_msg .= "Original-Envelope-Id: $dsn_envid\n"  if defined $dsn_envid;
    }
    if ($is_dsn || $is_arf) {  # attach a delivery-status or a feedback-report
      eval {  # make sure our source line number is reported in case of failure
        $report_entity->add_part(
          MIME::Entity->build(Top => 0,
            Type => $is_dsn ? 'message/delivery-status'
                            : 'message/feedback-report',
            Encoding => '7bit',  Disposition => 'inline',
            Filename => $is_arf ? 'arf_status' : 'dsn_status',
            Description => $is_arf      ? "\u$feedback_type report" :
                           $any_fail    ? 'Delivery error report' :
                           $any_delayed ? 'Delivery delay report' :
                                          'Delivery report',
            Data => $txt_msg.$txt_recip),
          1);  # insert as a second mime part (at offset 1)
        1;
      } or do {
        my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        die $eval_stat;
      };
    }
    my $mailfrom = $is_dsn ? ''  # DSN envelope sender must be empty
                 : unquote_rfc2821_local( (parse_address_list($hdr_from))[0] );
    $notification = Amavis::In::Message->new;
    $notification->rx_time($dsn_time);
    $notification->log_id($msginfo->log_id);
    $notification->partition_tag($msginfo->partition_tag);
    $notification->conn_obj($msginfo->conn_obj);
    $notification->originating(
      ($request_type eq 'dsn' || $request_type eq 'report') ? 1 : 0);
  # $notification->body_type('7BIT');
    $notification->mail_text($report_entity);
    $notification->sender($mailfrom);
    $notification->sender_smtp(qquote_rfc2821_local($mailfrom));
    $notification->auth_submitter('<>');
    $notification->auth_user(c('amavis_auth_user'));
    $notification->auth_pass(c('amavis_auth_pass'));
    if (defined $hdr_from) {
      my(@rfc2822_from) = map(unquote_rfc2821_local($_),
                              parse_address_list($hdr_from));
      $notification->rfc2822_from($rfc2822_from[0]);
    }
    my $bcc;
    if ($request_type eq 'dsn' || $request_type eq 'report') {
      $bcc = $msginfo->setting_by_contents_category(cr('dsn_bcc_by_ccat'));
    }
    $notification->recips([(defined $notif_recips ? @$notif_recips
                              : map($_->recip_addr, @$per_recip_data)),
                            defined $bcc && $bcc ne '' ? $bcc : () ], 1);
    my $notif_m = c('notify_method');
    $_->delivery_method($notif_m)  for @{$notification->per_recip_data};
  }
  # $suppressed is true if DNS would be needed, but either the sender requested
  #   that DSN is not to be sent, or it is believed the bounce would not reach
  #   the correct sender (faked sender with viruses or spam);
  # $notification is undef if DSN is not needed
  ($notification,$suppressed);
}

# Return a triple of arrayrefs of quoted recipient addresses (the first lists
# recipients with successful delivery status, the second lists all the rest),
# plus a list of short per-recipient delivery reports for failed deliveries,
# that can be used in the first MIME part (the free text format) of delivery
# status notifications.
#
sub delivery_short_report($) {
  my($msginfo) = @_;
  my(@succ_recips, @failed_recips, @failed_recips_full);
  for my $r (@{$msginfo->per_recip_data}) {
    my $remote_mta  = $r->recip_remote_mta;
    my $smtp_resp   = $r->recip_smtp_response;
    my $qrecip_addr = scalar(qquote_rfc2821_local($r->recip_addr));
    if ($r->recip_destiny == D_PASS && ($smtp_resp=~/^2/ || !$r->recip_done)) {
      push(@succ_recips, $qrecip_addr);
    } else {
      push(@failed_recips, $qrecip_addr);
      push(@failed_recips_full, sprintf("%s:%s\n   %s", $qrecip_addr,
        (!defined($remote_mta)||$remote_mta eq '' ?'' :" [$remote_mta] said:"),
        $smtp_resp));
    }
  }
  (\@succ_recips, \@failed_recips, \@failed_recips_full);
}

# Build a new MIME::Entity object based on the original mail, but hopefully
# safer to mail readers: conventional mail header fields are retained,
# original mail becomes an attachment of type 'message/rfc822'.
# Text in $first_part becomes the first MIME part of type 'text/plain',
# $first_part may be a scalar 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 \177
      $field_body =~ s{ ( [^\001-\014\016-\177] ) }
                      { sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o',
                                ord($1)) }gsxe;
      # protect NL in illegal all-whitespace continuation lines
      $field_body =~ s{\n([ \t]*)(?=\n)}{\\012$1}gs;
      $field_body =~ s{^(.{995}).{4,}$}{$1...}mg;  # truncate lines to 998
      chomp($field_body);    # note that field body is already folded
      if (lc($field_name) eq 'subject') {
        # needs to be inserted directly into new header section so that it
        # can be subjected to header edits, like inserting ***UNCHECKED***
        eval { $new_entity->head->add($field_name,$field_body); 1 }
          or do {chomp $@; die $@};
      } else {
        $hdr_edits->append_header($field_name,$field_body,2);
      }
    }
  }
  eval {
    $new_entity->attach(
      Type => 'text/plain',
      Encoding => '-SUGGEST', Charset => c('bdy_encoding'),
      Data => $first_part);
    1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die $eval_stat;
  };
  # prepend a Return-Path to make available the envelope sender address
  my $rp = sprintf("Return-Path: %s\n", $msginfo->sender_smtp);
  my $orig_mail_as_body;
  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 => '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->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(0);  # let's make it explicit; disables DKIM signing
  $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 && /^Return-Path:/si) {
      } elsif (!$bsmtp && /^Delivered-To:/si) {
      } elsif (!$bsmtp && /^X-Envelope-From:[ \t]*(.*)$/si) {
        if (!defined $sender) {
          my(@addr_list) = parse_address_list($1);
          @addr_list >= 1  or die "Address missing in X-Envelope-From";
          @addr_list <= 1  or die "More than one address in X-Envelope-From";
          $sender = unquote_rfc2821_local($addr_list[0]);
        }
      } elsif (!$bsmtp && /^X-Envelope-To:[ \t]*(.*)$/si) {
        my(@addr_list) = parse_address_list($1);
        push(@recips_all, map(unquote_rfc2821_local($_), @addr_list));
      } elsif (!$bsmtp && /^X-Envelope-To-Blocked:[ \t]*(.*)$/si) {
        my(@addr_list) = parse_address_list($1);
        push(@recips_blocked, map(unquote_rfc2821_local($_), @addr_list));
        $have_recips_blocked = 1;
      } elsif (/^X-Quarantine-ID:[ \t]*(.*)$/si) {
        $qid = $1;   $qid = $1 if $qid =~ /^<(.*)>\z/s;
      } elsif (!$reporting && /^X-Amavis-(?:Hold|Alert|Modified|PenPals|
                                            PolicyBank|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, $Amavis::Conf::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'));
    $hdrfrom_recip = expand_variables($hdrfrom_recip);
    if ($msginfo->requested_by eq '') {
      $hdr_edits->add_header('Resent-From', $hdrfrom_recip);
    } else {
      $hdr_edits->add_header('Resent-From',
                             qquote_rfc2821_local($msginfo->requested_by));
      $hdr_edits->add_header('Resent-Sender',
                             $hdrfrom_recip)  if $hdrfrom_recip ne '';
    }
    my $prd = $msginfo->per_recip_data;
    $hdr_edits->add_header('Resent-To',
                           $prd && @$prd==1 ? $prd->[0]->recip_addr_smtp
                                            : 'undisclosed-recipients:;');
    $hdr_edits->add_header('Resent-Date', # time of the release
                  rfc2822_timestamp($msginfo->rx_time));
    $hdr_edits->add_header('Resent-Message-ID',
               sprintf('<QRR%s@%s>', $msginfo->mail_id||'', c('myhostname')) );
  }
  $hdr_edits->add_header('Received', make_received_header_field($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;
    # leave recip_addr and recip_addr_smtp undefined!
    $recip_obj->recip_addr_modified($bcc);
    $recip_obj->recip_destiny(D_PASS);
    $recip_obj->dsn_notify(['NEVER']);
    $recip_obj->add_contents_category(CC_CLEAN,0);
    $msginfo->per_recip_data([@{$msginfo->per_recip_data}, $recip_obj]);
    do_log(2,"adding recipient - always_bcc: %s", $bcc);
  }
  $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 regexps
use strict;
use re 'taint';

BEGIN {
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.316';
  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
                         sanitize_str debug_oneshot am_id
                         safe_encode safe_encode_ascii safe_encode_utf8
                         safe_decode proto_decode
                         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 orcpt_encode);
  import Amavis::ProcControl qw(exit_status_str proc_status_ok
                         cloexec run_command collect_results);
  import Amavis::Log qw(open_log close_log collect_log_stats);
  import Amavis::Timing qw(section_time get_time_so_far);
  import Amavis::rfc2821_2822_Tools;
  import Amavis::Lookup qw(lookup lookup2);
  import Amavis::Lookup::IP qw(lookup_ip_acl normalize_ip_addr);
  import Amavis::Out;
  import Amavis::Out::EditHeader;
  import Amavis::UnmangleSender qw(parse_ip_address_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);
use POSIX qw(locale_h);
use IO::Handle;
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Time::HiRes ();
# body digest, either MD5 or SHA-1 (or perhaps SHA-256)
#use Digest::SHA;
use Digest::MD5;
use Net::Server 0.87;  # need Net::Server::PreForkSimple::done
use MIME::Base64;

use vars qw(
  $extra_code_zmq $extra_code_db
  $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);
use vars qw($av_output @virusname @detecting_scanners
            $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($warm_restart);      # 1: warm (reload),  0: cold start (restart)

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 get_rusage() {
  my $usage;
  if (Unix::Getrusage->UNIVERSAL::can("getrusage")) {
    $usage = Unix::Getrusage::getrusage();
    # ru_minflt   no. of page faults serviced without I/O activity
    # ru_majflt   no. of page faults that required I/O activity
    # ru_nswap    no. of times a process was swapped out
    # ru_inblock  no. of times a file system had to perform input
    # ru_oublock  no. of times a file system had to perform output
    # ru_msgsnd   no. of IPC messages sent
    # ru_msgrcv   no. of IPC messages received
    # ru_nsignals no. of signals delivered
    # ru_nvcsw    no. of voluntary context switches
    # ru_nivcsw   no. of involuntary context switches
    # ru_maxrss   [kB] maximum resident set size utilized
    # ru_ixrss    [kBtics] integral of mem used by the shared text segment
    # ru_idrss    [kBtics] integral of unshared mem in the data segment
    # ru_isrss    [kBtics] integral of unshared mem in the stack segment
    # ru_utime    [s] time spent executing in user mode
    # ru_stime    [s] time spent in the system on behalf of the process
  }
  $usage;
}

# report process resource usage, data from a system service getrusage(2)
#
sub report_rusage() {
  my $usage = get_rusage();
  if ($usage) {
    my(@order) = qw(minflt majflt nswap inblock oublock msgsnd msgrcv nsignals
                    nvcsw nivcsw maxrss ixrss idrss isrss utime stime);
    my(@result) = map($_.'='.$usage->{'ru_'.$_}, @order);   # known
    delete $usage->{'ru_'.$_}  for @order;
    push(@result, map($_.'='.$usage->{$_}, keys %$usage));  # any other?
    do_log(2,"RUSAGE: %s", join(', ',@result));
  }
}

sub macro_rusage {
  my($msginfo,$recip_index,$name,$arg) = @_;
  my $usage = get_rusage();
  !$usage || !defined($usage->{$arg}) ? '' : $usage->{$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 defined $spam_tests;
    }
  } else {
    my(%all_spam_tests);
    for my $r (@$per_recip_data) {
      my $spam_tests = $r->spam_tests;
      if (defined $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 = $slc eq '' || !defined $sl_min ? '' : $slc x min(50,$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 named header field from a message
#
sub macro_header_field {
  my($msginfo,$name,$header_field_name,$limit,$hf_index) = @_;
  undef $hf_index  if $hf_index !~ /^[+-]?\d+\z/;  # defaults to last
  local($_) = $msginfo->get_header_field_body($header_field_name,$hf_index);
  if (defined $_) {  # unfold, trim, protect CR, LF, \000 and \200
    chomp; s/\n(?=[ \t])//gs; s/^[ \t]+//; s/[ \t\n]+\z//;
    if ($header_field_name =~
        /^(?:Message-ID|Resent-Message-ID|In-Reply-To|References)\z/i) {
      $_ = join(' ',parse_message_id($_))  if $_ ne '';  # strip CFWS
    }
    s{([\r\n\000\200])}{sprintf("\\%03o",ord($1))}eg;
  };
  !defined($limit) || $limit =~ /^\s+\z/ ||
    $limit < 6 || length($_) <= $limit ? $_ : substr($_,0,$limit-5) . '[...]';
};

sub dkim_test {
  my($name,$which) = @_;
  my $w = lc($which);
  my $sigs_ref = $MSGINFO->dkim_signatures_valid;
  $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 = lc($sig->domain);
      for (@acceptable_sdid) {
        my $ad = !defined $_ ? '' : lc($_);
        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 = $1;
          if ($sdid eq $d || $sdid =~ /\.\Q$d\E\z/s) { $matches = 1; last }
        } else {
          if ($sdid eq $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 {c('myhostname')},  # fqdn name of this host
    HOSTNAME => sub {c('myhostname')},
    l => sub {$MSGINFO->originating ? 1 : undef}, # our client (mynets/roaming)
    s => sub {$MSGINFO->sender_smtp}, # orig. unmodified env. sender addr in <>
    S => sub {$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 {macro_header_field($MSGINFO,'header','Message-ID')},
    r => sub {macro_header_field($MSGINFO,'header','Resent-Message-ID')},
    j => sub {macro_header_field($MSGINFO,'header','Subject')},
    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 => sub {macro_header_field($MSGINFO,@_)},
    HEADER       => sub {macro_header_field($MSGINFO,@_)},
    useragent =>  # argument: 'name' or 'body', or empty to return entire field
      sub { my($macro_name,$which_part) = @_;  my($head,$body);
            $body = macro_header_field($MSGINFO,'header', $head='User-Agent');
            $body = macro_header_field($MSGINFO,'header', $head='X-Mailer')
              if !defined $body;
            !defined($body) ? undef
            : lc($which_part) eq 'name' ? $head
            : lc($which_part) eq 'body' ? $body : "$head: $body";
          },
    ccat =>
      sub {  # 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
    mail_id => sub {$MSGINFO->mail_id}, # synonym for %i, base64url (RFC 4648)
    secret_id => sub {$MSGINFO->secret_id}, # mail_id's counterpart, base64url
    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) },
    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},
    W => sub {\@detecting_scanners}, # list of av scanners detecting a virus
    H => sub {[map(split(/\n/,$_), @{$MSGINFO->orig_header})]}, # arry of lines
    A       => sub {[split(/\r?\n/, $MSGINFO->spam_summary)]}, # SA report text
    SUMMARY => sub {$MSGINFO->spam_summary},
    REPORT  => sub {sanitize_str($MSGINFO->spam_report,1)}, #contains any octet
    TESTSSCORES => sub {macro_tests($MSGINFO,undef,@_)}, # tests with scores
    TESTS       => sub {macro_tests($MSGINFO,undef,@_)}, # tests without scores
    z => sub {$MSGINFO->msg_size}, #mail size as defined by RFC 1870, or approx
    t => sub { # first entry in the Received trace
               sanitize_str(first_received_from($MSGINFO)) },
    e => sub { # first valid public IP in the Received trace - expensive! #**
               sanitize_str(parse_ip_address_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) },
    remote_mta    => sub { unique_ref(map($_->recip_remote_mta,
                                          @{$MSGINFO->per_recip_data})) },
    smtp_response => sub { unique_ref(map($_->recip_smtp_response,
                                          @{$MSGINFO->per_recip_data})) },
    remote_mta_smtp_response =>
                     sub { unique_ref(map($_->recip_remote_mta_smtp_response,
                                          @{$MSGINFO->per_recip_data})) },
    REMOTEHOSTADDR =>  # where the request was sent from
            sub { my $c = $MSGINFO->conn_obj; !$c ? '' : $c->client_ip },
    REMOTEHOSTNAME =>
            sub { my $c = $MSGINFO->conn_obj;
                  my $ip = !$c ? '' : $c->client_ip;
                  $ip ne '' ? "[$ip]" : 'localhost' },
#   VERSION    => Mail::SpamAssassin->Version,       # SA version
#   SUBVERSION => $Mail::SpamAssassin::SUB_VERSION,  # SA sub-version/revision
    AUTOLEARN       => sub {$MSGINFO->supplementary_info('AUTOLEARN')},
    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     } @_)},
    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 } @_)},
    mime2utf8 => sub { # convert to UTF-8 octets, truncate to $max_len if given
      my($nm,$str,$max_len,$both_if_diff) = @_;
      if (!defined $str || $str eq '') {
        $str = '';
      } else {
        eval {
          my $chars = safe_decode('MIME-Header',$str); # logical characters
          my $octets = safe_encode_utf8($chars);  # bytes, UTF-8 encoded
          if (defined $max_len && $max_len > 0 && length($octets) > $max_len) {
            local($1);
            if ($octets =~ /^(.{0,$max_len})(?=[\x00-\x7F\xC0-\xFF]|\z)/s) {
              $octets = $1;  # cleanly chop a UTF-8 byte sequence, RFC 3629
            }
          }
          if (!$both_if_diff) {
            $str = $octets;
          } else {
            # only compare the visi