Contents of /trunk/amavis/bin/amavisd-new

#!/usr/bin/perl -T

#------------------------------------------------------------------------------
# This is amavisd-new.
# It is an interface between message transfer agent (MTA) and virus
# scanners and/or spam scanners, functioning as a mail content filter.
#
# It is a performance-enhanced and feature-enriched version of amavisd
# (which in turn is a daemonized version of AMaViS), initially based
# on amavisd-snapshot-20020300).
#
# All work since amavisd-snapshot-20020300:
#   Copyright (C) 2002,2003,2004,2005  Mark Martinec,  All Rights Reserved.
# with contributions from the amavis-* mailing lists and individuals,
# as acknowledged in the release notes.
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

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

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

#------------------------------------------------------------------------------
#Index of packages in this file
#  Amavis::Boot
#  Amavis::Conf
#  Amavis::Lock
#  Amavis::Log
#  Amavis::Timing
#  Amavis::Util
#  Amavis::rfc2821_2822_Tools
#  Amavis::Lookup::RE
#  Amavis::Lookup::IP
#  Amavis::Lookup::Label
#  Amavis::Lookup
#  Amavis::Expand
#  Amavis::IO::Zlib
#  Amavis::In::Connection
#  Amavis::In::Message::PerRecip
#  Amavis::In::Message
#  Amavis::Out::EditHeader
#  Amavis::Out::Local
#  Amavis::Out
#  Amavis::UnmangleSender
#  Amavis::Unpackers::NewFilename
#  Amavis::Unpackers::Part
#  Amavis::Unpackers::OurFiler
#  Amavis::Unpackers::Validity
#  Amavis::Unpackers::MIME
#  Amavis::Notify
#  Amavis::Cache
#  Amavis
#optionally compiled-in packages: ---------------------------------------------
#  Amavis::DB::SNMP
#  Amavis::DB
#  Amavis::Cache
#  Amavis::Out::SQL::Connection
#  Amavis::Out::SQL::Log
#  Amavis::IO::SQL
#  Amavis::Out::SQL::Quarantine
#  Amavis::Lookup::SQLfield
#  Amavis::Lookup::SQL
#  Amavis::LDAP::Connection
#  Amavis::Lookup::LDAP
#  Amavis::Lookup::LDAPattr
#  Amavis::In::AMCL
#  Amavis::In::SMTP
#  Amavis::AV
#  Amavis::SpamControl
#  Amavis::Unpackers
#------------------------------------------------------------------------------

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

# Fetch all required modules (or nicely report missing ones), and compile them
# once-and-for-all at the parent process, so that forked children can inherit
# and share already compiled code in memory. Children will still need to 'use'
# modules if they want to inherit from their name space.
#
sub fetch_modules($$@) {
  my($reason, $required, @modules) = @_;
  my(@missing);
  for my $m (@modules) {
    local($_) = $m;
    $_ .= /^auto::/ ? '.al' : '.pm'  if !/\.(pm|pl|al)\z/;
    s[::][/]g;
    eval { require $_ } or push(@missing, $m);
  }
  die "ERROR: MISSING $reason:\n" . join('', map { "  $_\n" } @missing)
    if $required && @missing;
  \@missing;
}

BEGIN {
  fetch_modules('REQUIRED BASIC MODULES', 1, qw(
    Exporter POSIX Fcntl Socket Errno Carp Time::HiRes
    IO::Handle IO::File IO::Socket IO::Socket::UNIX IO::Socket::INET
    IO::Wrap IO::Stringy Digest::MD5 Unix::Syslog File::Basename
    Mail::Field Mail::Address Mail::Header Mail::Internet Compress::Zlib
    MIME::Base64 MIME::QuotedPrint MIME::Words
    MIME::Head MIME::Body MIME::Entity MIME::Parser MIME::Decoder
    MIME::Decoder::Base64 MIME::Decoder::Binary MIME::Decoder::QuotedPrint
    MIME::Decoder::NBit MIME::Decoder::UU MIME::Decoder::Gzip64
    Net::Cmd Net::SMTP Net::Server Net::Server::PreForkSimple
  ));
  # with earlier versions of Perl one may need to add additional modules
  # to the list, such as: auto::POSIX::setgid auto::POSIX::setuid ...
  fetch_modules('OPTIONAL BASIC MODULES', 0, qw(
    Carp::Heavy auto::POSIX::setgid auto::POSIX::setuid
    MIME::Decoder::BinHex
  ));
}

1;

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

# prototypes
sub D_REJECT();
sub D_BOUNCE();
sub D_DISCARD();
sub D_PASS();

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.043';
  @ISA = qw(Exporter);
  %EXPORT_TAGS = (
    'dynamic_confvars' => [qw(
      $policy_bank_name $protocol @inet_acl
      $log_level $log_templ $log_recip_templ $forward_method $notify_method

      $amavis_auth_user $amavis_auth_pass $auth_reauthenticate_forwarded
      $auth_required_out $auth_required_inp $auth_required_release
      @auth_mech_avail
      $local_client_bind_address
      $localhost_name $smtpd_greeting_banner $smtpd_quit_banner
      $smtpd_message_size_limit

      $final_virus_destiny $final_spam_destiny
      $final_banned_destiny $final_bad_header_destiny
      $warnvirussender $warnspamsender $warnbannedsender $warnbadhsender
      $warn_offsite

      @av_scanners @av_scanners_backup $first_infected_stops_scan
      $bypass_decode_parts @decoders

      $defang_virus $defang_banned $defang_spam
      $defang_bad_header $defang_undecipherable $defang_all
      $undecipherable_subject_tag
      $sa_spam_report_header $sa_spam_level_char
      $sa_mail_body_size_limit

      $localpart_is_case_sensitive
      $recipient_delimiter $replace_existing_extension
      $hdr_encoding $bdy_encoding $hdr_encoding_qb
      $notify_xmailer_header $X_HEADER_TAG $X_HEADER_LINE
      $remove_existing_x_scanned_headers $remove_existing_spam_headers

      $hdrfrom_notify_sender $hdrfrom_notify_recip
      $hdrfrom_notify_admin $hdrfrom_notify_spamadmin
      $mailfrom_notify_sender $mailfrom_notify_recip
      $mailfrom_notify_admin $mailfrom_notify_spamadmin
      $mailfrom_to_quarantine
      $virus_quarantine_method $spam_quarantine_method
      $banned_files_quarantine_method $bad_header_quarantine_method
      %local_delivery_aliases

      $notify_sender_templ
      $notify_virus_sender_templ $notify_spam_sender_templ
      $notify_virus_admin_templ  $notify_spam_admin_templ
      $notify_virus_recips_templ $notify_spam_recips_templ

      $banned_namepath_re
      $per_recip_whitelist_sender_lookup_tables
      $per_recip_blacklist_sender_lookup_tables

      %sql_clause

      @local_domains_maps @mynetworks_maps
      @bypass_virus_checks_maps @bypass_spam_checks_maps
      @bypass_banned_checks_maps @bypass_header_checks_maps
      @virus_lovers_maps @spam_lovers_maps
      @banned_files_lovers_maps @bad_header_lovers_maps
      @warnvirusrecip_maps @warnbannedrecip_maps @warnbadhrecip_maps
      @newvirus_admin_maps @virus_admin_maps
      @banned_admin_maps @bad_header_admin_maps @spam_admin_maps
      @virus_quarantine_to_maps
      @banned_quarantine_to_maps @bad_header_quarantine_to_maps
      @spam_quarantine_to_maps @spam_quarantine_bysender_to_maps
      @banned_filename_maps
      @spam_tag_level_maps @spam_tag2_level_maps @spam_kill_level_maps
      @spam_dsn_cutoff_level_maps @spam_quarantine_cutoff_level_maps
      @spam_modifies_subj_maps @spam_subject_tag_maps @spam_subject_tag2_maps
      @whitelist_sender_maps @blacklist_sender_maps @score_sender_maps
      @message_size_limit_maps
      @addr_extension_virus_maps  @addr_extension_spam_maps
      @addr_extension_banned_maps @addr_extension_bad_header_maps
      @debug_sender_maps %recipient_policy_bank_map %recipient_policy_bank_re_map $sa_site_rules_filename
    )],
    'confvars' => [qw(
      $myproduct_name $myversion_id $myversion_id_numeric $myversion_date
      $myversion $myhostname
      $MYHOME $TEMPBASE $QUARANTINEDIR $quarantine_subdir_levels
      $daemonize $pid_file $lock_file $db_home
      $enable_db $enable_global_cache
      $daemon_user $daemon_group $daemon_chroot_dir $path
      $DEBUG $DO_SYSLOG $SYSLOG_LEVEL $LOGFILE
      $max_servers $max_requests $child_timeout
      %current_policy_bank %policy_bank %interface_policy
      $unix_socketname $inet_socket_port $inet_socket_bind
      $insert_received_line $relayhost_is_client $smtpd_recipient_limit
      $MAXLEVELS $MAXFILES
      $MIN_EXPANSION_QUOTA $MIN_EXPANSION_FACTOR
      $MAX_EXPANSION_QUOTA $MAX_EXPANSION_FACTOR
      @lookup_sql_dsn @storage_sql_dsn
      $virus_check_negative_ttl $virus_check_positive_ttl
      $spam_check_negative_ttl $spam_check_positive_ttl
      $enable_ldap $default_ldap
      @keep_decoded_original_maps @map_full_type_to_short_type_maps
      @viruses_that_fake_sender_maps %banned_rules
      $file %recipient_policy_bank_map %recipient_policy_bank_re_map $sa_site_rules_filename
    )],
    'sa' => [qw(
      $helpers_home $dspam
      $sa_local_tests_only $sa_auto_whitelist $sa_timeout $sa_debug
      $sa_site_rules_filename
    )],
    'platform' => [qw(
      $can_truncate $unicode_aware $eol
      &D_REJECT &D_BOUNCE &D_DISCARD &D_PASS
    )],

    # other variables settable by user in amavisd.conf,
    # but not directly accessible by the program
    'hidden_confvars' => [qw(
      $mydomain
    )],

    # legacy variables, predeclared for compatibility of amavisd.conf
    # The rest of the program does not use them directly and they should not be
    # visible in other modules, but may be referenced through @*_maps variables
    'legacy_confvars' => [qw(
      %local_domains @local_domains_acl $local_domains_re @mynetworks
      %bypass_virus_checks @bypass_virus_checks_acl $bypass_virus_checks_re
      %bypass_spam_checks @bypass_spam_checks_acl $bypass_spam_checks_re
      %bypass_banned_checks @bypass_banned_checks_acl $bypass_banned_checks_re
      %bypass_header_checks @bypass_header_checks_acl $bypass_header_checks_re
      %virus_lovers @virus_lovers_acl $virus_lovers_re
      %spam_lovers @spam_lovers_acl $spam_lovers_re
      %banned_files_lovers @banned_files_lovers_acl $banned_files_lovers_re
      %bad_header_lovers @bad_header_lovers_acl $bad_header_lovers_re
      %virus_admin %spam_admin
      $newvirus_admin $virus_admin $banned_admin $bad_header_admin $spam_admin
      $warnvirusrecip $warnbannedrecip $warnbadhrecip
      $virus_quarantine_to $banned_quarantine_to $bad_header_quarantine_to
      $spam_quarantine_to $spam_quarantine_bysender_to
      $keep_decoded_original_re $map_full_type_to_short_type_re
      $banned_filename_re $viruses_that_fake_sender_re
      $sa_tag_level_deflt $sa_tag2_level_deflt $sa_kill_level_deflt
      $sa_dsn_cutoff_level $sa_quarantine_cutoff_level
      $sa_spam_modifies_subj $sa_spam_subject_tag1 $sa_spam_subject_tag
      %whitelist_sender @whitelist_sender_acl $whitelist_sender_re
      %blacklist_sender @blacklist_sender_acl $blacklist_sender_re
      $addr_extension_virus $addr_extension_spam
      $addr_extension_banned $addr_extension_bad_header
      $sql_select_policy $sql_select_white_black_list
      $gets_addr_in_quoted_form @debug_sender_acl
      $arc $bzip2 $lzop $lha $unarj $gzip $uncompress $unfreeze
      $unrar $zoo $pax $cpio $ar $rpm2cpio $cabextract $ripole $tnef
      $gunzip $bunzip2 $unlzop
    )],
  );
  Exporter::export_tags qw(dynamic_confvars confvars sa platform
                           hidden_confvars legacy_confvars);
} # BEGIN

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

use vars @EXPORT;

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

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

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

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

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

$myproduct_name = 'amavisd-new';
$myversion_id = '2.3.3'; $myversion_date = '20050822';

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

$eol = "\n";  # native record separator in files: LF or CRLF or even CR
$unicode_aware = $]>=5.008 && length("\x{263a}")==1 && eval { require Encode };

# serves only as a quick default for other configuration settings
$MYHOME   = '/var/amavis';
$mydomain = '!change-mydomain-variable!.example.com';#intentionally bad default

# Create debugging output - true: log to stderr; false: log to syslog/file
$DEBUG = 0;

# Cause Net::Server parameters 'background' and 'setsid' to be set,
# resulting in the program to detach itself from the terminal
$daemonize = 1;

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

$child_timeout = 8*60; # abort child if it does not complete each task in n sec

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

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

# Customizable notification messages, logging

$SYSLOG_LEVEL = 'mail.debug';

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

# Where to find SQL server(s) and database to support SQL lookups?
# A list of triples: (dsn,user,passw). Specify more than one
# for multiple (backup) SQL servers.
#
#@storage_sql_dsn =
#@lookup_sql_dsn =
#   ( ['DBI:mysql:mail:host1', 'some-username1', 'some-password1'],
#     ['DBI:mysql:mail:host2', 'some-username2', 'some-password2'] );

# The SQL select clause to fetch per-recipient policy settings
# The %k will be replaced by a comma-separated list of query addresses
# (e.g. full address, domain only, catchall).  Use ORDER, if there
# is a chance that multiple records will match - the first match wins
# If field names are not unique (e.g. 'id'), the later field overwrites the
# earlier in a hash returned by lookup, which is why we use '*,users.id'.
$sql_select_policy =
  'SELECT *,users.id FROM users LEFT JOIN policy ON users.policy_id=policy.id'.
  ' WHERE users.email IN (%k) ORDER BY users.priority DESC';

# The SQL select clause to check sender in per-recipient whitelist/blacklist
# The first SELECT argument '?' will be users.id from recipient SQL lookup,
# the %k will be sender addresses (e.g. full address, domain only, catchall).
# Only the first occurrence of '?' will be replaced by users.id, subsequent
# occurrences of '?' will see empty string as an argument. There can be zero
# or more occurrences of %k, lookup keys will be multiplied accordingly.
# Up until version 2.2.0 the '?' had to be placed before the '%k';
# starting with 2.2.1 this restriction is lifted.
$sql_select_white_black_list =
  'SELECT wb FROM wblist LEFT JOIN mailaddr ON wblist.sid=mailaddr.id'.
  ' WHERE (wblist.rid=?) AND (mailaddr.email IN (%k))'.
  ' ORDER BY mailaddr.priority DESC';

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

#
# Receiving mail related

# $unix_socketname = '/var/amavis/amavisd.sock'; # traditional amavis client protocol
# $inet_socket_port = 10024;      # accept SMTP on this TCP port
# $inet_socket_port = [10024,10026,10027];  # ...possibly on more than one
$inet_socket_bind = '127.0.0.1';  # limit socket bind to loopback interface

@inet_acl   = qw( 127.0.0.1   [::1] );  # allow SMTP access only from localhost
@mynetworks = qw( 127.0.0.0/8 [::1] [FE80::]/10 [FEC0::]/10
                  10.0.0.0/8 172.16.0.0/12 192.168.0.0/16 );

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

#old defaults:
# $virus_quarantine_method        = 'local:virus-%i-%n';
# $spam_quarantine_method         = 'local:spam-%b-%i-%n.gz';
# $banned_files_quarantine_method = 'local:banned-%i-%n';
# $bad_header_quarantine_method   = 'local:badh-%i-%n';

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

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

# encoding (charset in MIME terminology)
# to be used in RFC 2047-encoded ...
$hdr_encoding = 'iso-8859-1';  # ... header field bodies
$bdy_encoding = 'iso-8859-1';  # ... notification body text

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

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

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

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

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

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

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

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

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

$banned_admin     = \@virus_admin_maps;  # compatibility
$bad_header_admin = \@virus_admin_maps;  # compatibility

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

# quarantine directory or mailbox file or empty
#   (only used if $virus_quarantine_to specifies direct local delivery)
$QUARANTINEDIR = undef;  # no quarantine unless overridden by config

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

# string to prepend to Subject header field when message qualifies as spam
# $sa_spam_subject_tag1 = undef;  # example: '***possible SPAM*** '
# $sa_spam_subject_tag  = undef;  # example: '***SPAM*** '
$sa_spam_modifies_subj = 1;       # true for compatibility; can be a
                                  # lookup table indicating per-recip settings
$sa_spam_level_char = '*';  # character to be used in X-Spam-Level bar;
                            # empty or undef disables adding this header field
# $sa_spam_report_header = undef; # insert X-Spam-Report header field?
$sa_local_tests_only = 0;
$sa_debug = undef;
$sa_timeout = 30;           # timeout in seconds for a call to SpamAssassin

# MIME defanging is only done when enabled and malware is allowed to pass
# $defang_virus = undef;
# $defang_banned = undef;
# $defang_spam = undef;
# $defang_bad_header = undef;
# $defang_undecipherable = undef;
# $defang_all = undef;

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

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

# See amavisd.conf and README.lookups for details.

# What to do with the message (this is independent of quarantining):
#   Reject:  tell MTA to generate a non-delivery notification,  MTA gets 5xx
#   Bounce:  generate a non-delivery notification by ourselves, MTA gets 250
#   Discard: drop the message and pretend it was delivered,     MTA gets 250
#   Pass:    deliver/accept the message
#
# Bounce and Reject are similar: in both cases sender gets a non-delivery
# notification, either generated by amavisd-new, or by MTA. The notification
# issued by amavisd-new may be more informative, while on the other hand
# MTA may be able to do a true reject on the original SMTP session
# (e.g. with sendmail milter), or else it just generates normal non-delivery
# notification / bounce (e.g. with Postfix, Exim). As a consequence,
# with Postfix and Exim and dual-sendmail setup the Bounce is more informative
# than Reject, but sendmail-milter users may prefer Reject.
#
# Bounce and Discard are similar: in both cases amavisd-new confirms
# to MTA the message reception with success code 250. The difference is
# in sender notification: Bounce sends a non-delivery notification to sender,
# Discard does not, the message is silently dropped. Quarantine and
# admin notifications are not affected by any of these settings.
#
# COMPATIBITITY NOTE: the separation of *_destiny values into
#   D_BOUNCE, D_REJECT, D_DISCARD and D_PASS made settings $warnvirussender
#   and $warnspamsender only still useful with D_PASS. The combination of
#   D_DISCARD + $warn*sender=1 is mapped into D_BOUNCE for compatibility.

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

# The following symbolic constants can be used in *destiny settings:
#
# D_PASS     mail will pass to recipients, regardless of contents;
#
# D_DISCARD  mail will not be delivered to its recipients, sender will NOT be
#            notified. Effectively we lose mail (but it will be quarantined
#            unless disabled).
#
# D_BOUNCE   mail will not be delivered to its recipients, a non-delivery
#            notification (bounce) will be sent to the sender by amavisd-new;
#            Exception: bounce (DSN) will not be sent if a virus name matches
#            $viruses_that_fake_sender_maps, or to messages from mailing lists
#            (Precedence: bulk|list|junk), or for spam exceeding
#            spam_dsn_cutoff_level
#
# D_REJECT   mail will not be delivered to its recipients, sender should
#            preferably get a reject, e.g. SMTP permanent reject response
#            (e.g. with milter), or non-delivery notification from MTA
#            (e.g. Postfix). If this is not possible (e.g. different recipients
#            have different tolerances to bad mail contents and not using LMTP)
#            amavisd-new sends a bounce by itself (same as D_BOUNCE).
#
# Notes:
#   D_REJECT and D_BOUNCE are similar, the difference is in who is responsible
#            for informing the sender about non-delivery, and how informative
#            the notification can be (amavisd-new knows more than MTA);
#   With D_REJECT, MTA may reject original SMTP, or send DSN (delivery status
#            notification, colloquially called 'bounce') - depending on MTA;
#            Best suited for sendmail milter, especially for spam.
#   With D_BOUNCE, amavisd-new (not MTA) sends DSN (can better explain the
#            reason for mail non-delivery but unable to reject the original
#            SMTP session, and is in position to suppress DSN if considered
#            unsuitable). Best suited for Postfix and other dual-MTA setups.

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

# If you decide to pass viruses (or spam) to certain users using
# @virus_lovers_maps, (or @spam_lovers_maps), or $final_virus_destiny=D_PASS
# ($final_spam_destiny=D_PASS), you can set the variable $addr_extension_virus
# ($addr_extension_spam) to some string, and the recipient address will have
# this string appended as an address extension to the local-part of the
# address. This extension can be used by final local delivery agent to place
# such mail in different folders. Leave these variables undefined or empty
# strings to prevent appending address extensions. Setting has no effect
# on users which will not be receiving viruses (spam). Recipients which
# do not match access lists in @local_domains_maps are not affected (i.e.
# non-local recipients do not get address extension appended).
#
# LDAs usually default to stripping away address extension if no special
# handling for it is specified, so having this option enabled normally
# does no harm, provided the $recipients_delimiter character matches
# the setting at the final MTA's local delivery agent (LDA).
#
# $addr_extension_virus  = 'virus';  # for example
# $addr_extension_spam   = 'spam';
# $addr_extension_banned = 'banned';
# $addr_extension_bad_header = 'badh';

# Delimiter between local part of the recipient address and address extension
# (which can optionally be added, see variables $addr_extension_virus and
# $addr_extension_spam). E.g. recipient address <user@domain.example> gets
# changed to <user+virus@domain.example>.
#
# Delimiter should match equivalent (final) MTA delimiter setting.
# (e.g. for Postfix add 'recipient_delimiter = +' to main.cf).
# Setting it to an empty string or to undef disables this feature
# regardless of $addr_extension_virus and $addr_extension_spam settings.

# $recipient_delimiter = '+';
$replace_existing_extension = 1;   # true: replace ext; false: append ext

# Affects matching of localpart of e-mail addresses (left of '@')
# in lookups: true = case sensitive, false = case insensitive
$localpart_is_case_sensitive = 0;

# first match wins, more specific entries should precede general ones!
# the result may be a string or a ref to a list of strings;
# see also sub decompose_part()
$map_full_type_to_short_type_re = Amavis::Lookup::RE->new(
  [qr/^empty\z/                       => 'empty'],
  [qr/^directory\z/                   => 'dir'],
  [qr/^can't (stat|read)\b/           => 'dat'],  # file(1) diagnostics
  [qr/^cannot open\b/                 => 'dat'],  # file(1) diagnostics
  [qr/^ERROR: Corrupted\b/            => 'dat'],  # file(1) diagnostics
  [qr/can't read magic file|couldn't find any magic files/ => 'dat'],
  [qr/^data\z/                        => 'dat'],

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

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

  [qr/^JPEG image data\b/             =>['image','jpg'] ],
  [qr/^GIF image data\b/              =>['image','gif'] ],
  [qr/^PNG image data\b/              =>['image','png'] ],
  [qr/^TIFF image data\b/             =>['image','tif'] ],
  [qr/^PCX\b.*\bimage data\b/         =>['image','pcx'] ],
  [qr/^PC bitmap data\b/              =>['image','bmp'] ],

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

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

  [qr/^frozen\b/                      => 'F'],
  [qr/^gzip compressed\b/             => 'gz'],
  [qr/^bzip compressed\b/             => 'bz'],
  [qr/^bzip2 compressed\b/            => 'bz2'],
  [qr/^lzop compressed\b/             => 'lzo'],
  [qr/^compress'd/                    => 'Z'],
  [qr/^Zip archive\b/i                => 'zip'],
  [qr/^RAR archive\b/i                => 'rar'],
  [qr/^LHa.*\barchive\b/i             => 'lha'],  # (also known as .lzh)
  [qr/^ARC archive\b/i                => 'arc'],
  [qr/^ARJ archive\b/i                => 'arj'],
  [qr/^Zoo archive\b/i                => 'zoo'],
  [qr/^(\S+\s+)?tar archive\b/i       => 'tar'],
  [qr/^(\S+\s+)?cpio archive\b/i      => 'cpio'],
  [qr/^Debian binary package\b/i      => 'deb'],  # standard Unix archive (ar)
  [qr/^current ar archive\b/i         => 'a'],    # standard Unix archive (ar)
  [qr/^RPM\b/                         => 'rpm'],
  [qr/^(Transport Neutral Encapsulation Format|TNEF)\b/i => 'tnef'],
  [qr/^Microsoft cabinet file\b/      => 'cab'],

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

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

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

);

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

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

# Define alias names or shortcuts in this module to make it simpler
# to call these routines from amavisd.conf
*read_text       = \&Amavis::Util::read_text;
*read_l10n_templates = \&Amavis::Util::read_l10n_templates;
*read_hash       = \&Amavis::Util::read_hash;
*read_array      = \&Amavis::Util::read_array;
*dump_hash       = \&Amavis::Util::dump_hash;
*dump_array      = \&Amavis::Util::dump_array;
*ask_daemon      = \&Amavis::AV::ask_daemon;
*sophos_savi     = \&Amavis::AV::ask_sophos_savi;
*ask_clamav      = \&Amavis::AV::ask_clamav;
*do_mime_decode  = \&Amavis::Unpackers::do_mime_decode;
*do_ascii        = \&Amavis::Unpackers::do_ascii;
*do_uncompress   = \&Amavis::Unpackers::do_uncompress;
*do_gunzip       = \&Amavis::Unpackers::do_gunzip;
*do_pax_cpio     = \&Amavis::Unpackers::do_pax_cpio;
*do_tar          = \&Amavis::Unpackers::do_tar;
*do_ar           = \&Amavis::Unpackers::do_ar;
*do_unzip        = \&Amavis::Unpackers::do_unzip;
*do_unrar        = \&Amavis::Unpackers::do_unrar;
*do_unarj        = \&Amavis::Unpackers::do_unarj;
*do_arc          = \&Amavis::Unpackers::do_arc;
*do_zoo          = \&Amavis::Unpackers::do_zoo;
*do_lha          = \&Amavis::Unpackers::do_lha;
*do_ole          = \&Amavis::Unpackers::do_ole;
*do_cabextract   = \&Amavis::Unpackers::do_cabextract;
*do_tnef_ext     = \&Amavis::Unpackers::do_tnef_ext;
*do_tnef         = \&Amavis::Unpackers::do_tnef;
*do_executable   = \&Amavis::Unpackers::do_executable;
sub new_RE { Amavis::Lookup::RE->new(@_) }

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

sub build_default_maps() {
  @local_domains_maps = (
    \%local_domains, \@local_domains_acl, \$local_domains_re);
  @mynetworks_maps = (\@mynetworks);
  @bypass_virus_checks_maps = (
    \%bypass_virus_checks, \@bypass_virus_checks_acl, \$bypass_virus_checks_re);
  @bypass_spam_checks_maps = (
    \%bypass_spam_checks, \@bypass_spam_checks_acl, \$bypass_spam_checks_re);
  @bypass_banned_checks_maps = (
    \%bypass_banned_checks, \@bypass_banned_checks_acl, \$bypass_banned_checks_re);
  @bypass_header_checks_maps = (
    \%bypass_header_checks, \@bypass_header_checks_acl, \$bypass_header_checks_re);
  @virus_lovers_maps = (
    \%virus_lovers, \@virus_lovers_acl, \$virus_lovers_re);
  @spam_lovers_maps = (
    \%spam_lovers, \@spam_lovers_acl, \$spam_lovers_re);
  @banned_files_lovers_maps = (
    \%banned_files_lovers, \@banned_files_lovers_acl, \$banned_files_lovers_re);
  @bad_header_lovers_maps = (
    \%bad_header_lovers, \@bad_header_lovers_acl, \$bad_header_lovers_re);
  @warnvirusrecip_maps  = (\$warnvirusrecip);
  @warnbannedrecip_maps = (\$warnbannedrecip);
  @warnbadhrecip_maps   = (\$warnbadhrecip);
  @newvirus_admin_maps  = (\$newvirus_admin);
  @virus_admin_maps     = (\%virus_admin, \$virus_admin);
  @banned_admin_maps    = (\$banned_admin);
  @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);
  @bad_header_quarantine_to_maps = (\$bad_header_quarantine_to);
  @spam_quarantine_to_maps = (\$spam_quarantine_to);
  @spam_quarantine_bysender_to_maps = (\$spam_quarantine_bysender_to);
  @keep_decoded_original_maps = (\$keep_decoded_original_re);
  @map_full_type_to_short_type_maps = (\$map_full_type_to_short_type_re);
# @banned_filename_maps = ( {'.' => [$banned_filename_re]} );
# @banned_filename_maps = ( {'.' => 'DEFAULT'} );#names mapped by %banned_rules
  @banned_filename_maps = ( 'DEFAULT' );  # same as previous, but shorter
  @viruses_that_fake_sender_maps = (\$viruses_that_fake_sender_re, 1);
  @spam_tag_level_maps  = (\$sa_tag_level_deflt);
  @spam_tag2_level_maps = (\$sa_tag2_level_deflt);
  @spam_kill_level_maps = (\$sa_kill_level_deflt);
  @spam_dsn_cutoff_level_maps = (\$sa_dsn_cutoff_level);
  @spam_quarantine_cutoff_level_maps = (\$sa_quarantine_cutoff_level);
  @spam_modifies_subj_maps = (\$sa_spam_modifies_subj);
  @spam_subject_tag_maps   = (\$sa_spam_subject_tag1);  # note: inconsistent
  @spam_subject_tag2_maps  = (\$sa_spam_subject_tag);   # note: inconsistent
  @whitelist_sender_maps = (
    \%whitelist_sender, \@whitelist_sender_acl, \$whitelist_sender_re);
  @blacklist_sender_maps = (
    \%blacklist_sender, \@blacklist_sender_acl, \$blacklist_sender_re);
  @score_sender_maps = ();  # new variable, no backwards compatibility needed
  @message_size_limit_maps = ();  # new variable
  @addr_extension_virus_maps  = (\$addr_extension_virus);
  @addr_extension_spam_maps   = (\$addr_extension_spam);
  @addr_extension_banned_maps = (\$addr_extension_banned);
  @addr_extension_bad_header_maps = (\$addr_extension_bad_header);
  @debug_sender_maps = (\@debug_sender_acl);
}

# prepend a lookup table label object for logging purposes
sub label_default_maps() {
  for my $varname (qw(
    @local_domains_maps @mynetworks_maps
    @bypass_virus_checks_maps @bypass_spam_checks_maps
    @bypass_banned_checks_maps @bypass_header_checks_maps
    @virus_lovers_maps @spam_lovers_maps
    @banned_files_lovers_maps @bad_header_lovers_maps
    @warnvirusrecip_maps @warnbannedrecip_maps @warnbadhrecip_maps
    @newvirus_admin_maps @virus_admin_maps
    @banned_admin_maps @bad_header_admin_maps @spam_admin_maps
    @virus_quarantine_to_maps
    @banned_quarantine_to_maps @bad_header_quarantine_to_maps
    @spam_quarantine_to_maps @spam_quarantine_bysender_to_maps
    @keep_decoded_original_maps @map_full_type_to_short_type_maps
    @banned_filename_maps
    @viruses_that_fake_sender_maps
    @spam_tag_level_maps @spam_tag2_level_maps @spam_kill_level_maps
    @spam_dsn_cutoff_level_maps @spam_quarantine_cutoff_level_maps
    @spam_modifies_subj_maps @spam_subject_tag_maps @spam_subject_tag2_maps
    @whitelist_sender_maps @blacklist_sender_maps @score_sender_maps
    @message_size_limit_maps
    @addr_extension_virus_maps @addr_extension_spam_maps
    @addr_extension_banned_maps @addr_extension_bad_header_maps
    @debug_sender_maps ))
  {
    my($g) = $varname; $g =~ s{\@}{Amavis::Conf::};  # qualified variable name
    my($label) = $varname; $label=~s/^\@//; $label=~s/_maps$//;
    { no strict 'refs';
      unshift(@$g,  # NOTE: a symbolic reference
              Amavis::Lookup::Label->new($label))  if @$g;  # no label if empty
    }
  }
}

# read and evaluate configuration files (one or more)
sub read_config(@) {
  my(@config_files) = @_;
  for my $config_file (@config_files) {
    my($msg);
    my($errn) = stat($config_file) ? 0 : 0+$!;
    if    ($errn == ENOENT) { $msg = "does not exist" }
    elsif ($errn)      { $msg = "is inaccessible: $!" }
    elsif (-d _)       { $msg = "is a directory" }
    elsif (!-f _)      { $msg = "is not a regular file" }
    elsif ($> && -o _) { $msg = "is owned by EUID $>, should be owned by root"}
    elsif ($> && -w _) { $msg = "is writable by EUID $>, EGID $)" }
    if (defined $msg)  { die "Config file \"$config_file\" $msg," }
    $! = 0;
    if (defined(do $config_file)) {}
    elsif ($@ ne '') { die "Error in config file \"$config_file\": $@" }
    elsif ($! != 0)  { die "Error reading config file \"$config_file\": $!" }
  }
  $daemon_chroot_dir = ''
    if !defined $daemon_chroot_dir || $daemon_chroot_dir eq '/';
  # provide some sensible defaults for essential settings (post-defaults)
  $TEMPBASE     = $MYHOME                   if !defined $TEMPBASE;
  $helpers_home = $MYHOME                   if !defined $helpers_home;
  $db_home      = "$MYHOME/db"              if !defined $db_home;
  $lock_file    = "$MYHOME/amavisd.lock"    if !defined $lock_file;
  $pid_file     = "$MYHOME/amavisd.pid"     if !defined $pid_file;

  $X_HEADER_TAG = 'X-Virus-Scanned'               if !defined $X_HEADER_TAG;
  $X_HEADER_LINE= "$myproduct_name at $mydomain"  if !defined $X_HEADER_LINE;

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

  my($pname) = "\"Content-filter at $myhostname\"";
  $hdrfrom_notify_sender = "$pname <postmaster\@$myhostname>"
    if !defined $hdrfrom_notify_sender;
  $hdrfrom_notify_recip = $mailfrom_notify_recip ne ''
    ? "$pname <$mailfrom_notify_recip>"
    : $hdrfrom_notify_sender  if !defined $hdrfrom_notify_recip;
  $hdrfrom_notify_admin = $mailfrom_notify_admin ne ''
    ? "$pname <$mailfrom_notify_admin>"
    : $hdrfrom_notify_sender  if !defined $hdrfrom_notify_admin;
  $hdrfrom_notify_spamadmin = $mailfrom_notify_spamadmin ne ''
    ? "$pname <$mailfrom_notify_spamadmin>"
    : $hdrfrom_notify_sender  if !defined $hdrfrom_notify_spamadmin;

  # compatibility with deprecated $warn*sender and old *_destiny values
  # map old values <0, =0, >0 into D_REJECT/D_BOUNCE, D_DISCARD, D_PASS
  for ($final_virus_destiny, $final_banned_destiny, $final_spam_destiny) {
    if ($_ > 0) { $_ = D_PASS }
    elsif ($_ < 0 && $_ != D_BOUNCE && $_ != D_REJECT) {  # compatibility
      # favour Reject with sendmail milter, Bounce with others
      $_ = c('forward_method') eq '' ? D_REJECT : D_BOUNCE;
    }
  }
  if ($final_virus_destiny == D_DISCARD && c('warnvirussender') )
    { $final_virus_destiny = D_BOUNCE }
  if ($final_spam_destiny == D_DISCARD && c('warnspamsender') )
    { $final_spam_destiny = D_BOUNCE }
  if ($final_banned_destiny == D_DISCARD && c('warnbannedsender') )
    { $final_banned_destiny = D_BOUNCE }
  if ($final_bad_header_destiny == D_DISCARD && c('warnbadhsender') )
    { $final_bad_header_destiny = D_BOUNCE }
  if (!%banned_rules) {
    # an associative array mapping a rule name
    # to a single 'banned names/types' lookup table
    %banned_rules = ('DEFAULT'=>$banned_filename_re);  # backwards compatibile
  }
}

1;

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

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

use subs @EXPORT;

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

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

1;

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

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

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

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

use vars qw($loghandle);  # log file handle
use vars qw($myname);
use vars qw($syslog_facility $syslog_priority %syslog_priority);
use vars qw($log_to_stderr $do_syslog $logfile);

sub init($$$$) {
  my($syslog_level);
  ($log_to_stderr, $do_syslog, $syslog_level, $logfile) = @_;

  $myname = $0;
  if ($syslog_level =~ /^\s*([a-z0-9]+)\.([a-z0-9]+)\s*\z/i) {
    $syslog_facility = eval("LOG_\U$1");
    $syslog_priority = eval("LOG_\U$2");
  }
  $syslog_facility = LOG_DAEMON   if $syslog_facility !~ /^\d+\z/;
  $syslog_priority = LOG_WARNING  if $syslog_priority !~ /^\d+\z/;
  open_log();
  if (!$do_syslog && $logfile eq '')
    { print STDERR "Logging to STDERR (no \$LOGFILE and no \$DO_SYSLOG)\n" }
  my($msg) = "starting.  $myname at $myhostname $myversion";
  $msg .= ", eol=\"$eol\""            if $eol ne "\n";
  $msg .= ", Unicode aware"           if $unicode_aware;
  $msg .= ", LC_ALL=$ENV{LC_ALL}"     if $ENV{LC_ALL}   ne '';
  $msg .= ", LC_TYPE=$ENV{LC_TYPE}"   if $ENV{LC_TYPE}  ne '';
  $msg .= ", LC_CTYPE=$ENV{LC_CTYPE}" if $ENV{LC_CTYPE} ne '';
  $msg .= ", LANG=$ENV{LANG}"         if $ENV{LANG}     ne '';
  write_log(0, $msg, undef);
}

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

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

# Log either to syslog or to a file
sub write_log($$$) {
  my($level,$errmsg,$am_id) = @_;

  $am_id = !defined $am_id ? '' : "($am_id) ";
  $errmsg = Amavis::Util::sanitize_str($errmsg);
# my($old_locale) = POSIX::setlocale(LC_TIME,"C");  # English dates required!
# if (length($errmsg) > 2000) {  # crop at some arbitrary limit (< LINE_MAX)
#   $errmsg = substr($errmsg,0,2000) . "...";
# }
  if ($do_syslog && !$log_to_stderr) {
    my($prio) = $syslog_priority;  # never go below this priority level
    # syslog priorities: DEBUG, INFO, NOTICE, WARNING, ERR, CRIT, ALERT, EMERG
    if    ($level <= -3) { $prio = LOG_CRIT    if $prio > LOG_CRIT    }
    elsif ($level <= -2) { $prio = LOG_ERR     if $prio > LOG_ERR     }
    elsif ($level <= -1) { $prio = LOG_WARNING if $prio > LOG_WARNING }
    elsif ($level <=  0) { $prio = LOG_NOTICE  if $prio > LOG_NOTICE  }
    elsif ($level <=  2) { $prio = LOG_INFO    if $prio > LOG_INFO    }
    else                 { $prio = LOG_DEBUG   if $prio > LOG_DEBUG   }
    my($pre) = '';
    my($logline_size) = 980;  # less than  (1023 - prefix)
    while (length($am_id)+length($pre)+length($errmsg) > $logline_size) {
      my($avail) = $logline_size - length($am_id . $pre . "...");
      syslog($prio, "%s", $am_id . $pre . substr($errmsg,0,$avail) . "...");
      $pre = "...";
      $errmsg = substr($errmsg, $avail);
    }
    syslog($prio, "%s", $am_id . $pre . $errmsg);
  } else {
    my($prefix) = sprintf("%s %s %s[%s]: ",      # prepare syslog-alike prefix
               strftime("%b %e %H:%M:%S",localtime), $myhostname, $myname, $$);
    if (defined $loghandle && !$log_to_stderr) {
      lock($loghandle);
      seek($loghandle,0,2) or die "Can't position log file to its tail: $!";
      $loghandle->print($prefix, $am_id, $errmsg, $eol)
        or die "Error writing to log file: $!";
      unlock($loghandle);
    } else {
      print STDERR $prefix, $am_id, $errmsg, $eol
        or die "Error writing to STDERR: $!";
    }
  }
# POSIX::setlocale(LC_TIME, $old_locale);
}

sub log_fd() {
  $log_to_stderr ? fileno(STDERR)
  : $do_syslog ? undef  # how to obtain fd on syslog?
  : defined $loghandle ? $loghandle->fileno : fileno(STDERR);
}

1;

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

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

use Time::HiRes 1.49 ();

use vars qw(@timing);

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

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

# returns a string - a report of elapsed time by section
sub report() {
  section_time('rundown');
  my($notneeded, $t0) = (shift(@timing), shift(@timing));
  my($total) = $t0 <= 0 ? 0 : $timing[$#timing] - $t0;
  if ($total < 0.0000001) { $total = 0.0000001 }
  my(@sections); my($t00) = $t0;
  while (@timing) {
    my($section, $t) = (shift(@timing), shift(@timing));
    my($dt)   = $t <= $t0  ? 0 : $t-$t0;   # handle possible clock jumps
    my($dt_c) = $t <= $t00 ? 0 : $t-$t00;  # handle possible clock jumps
    my($dtp)   = $dt   >= $total ? 100 : $dt*100.0/$total;    # this event
    my($dtp_c) = $dt_c >= $total ? 100 : $dt_c*100.0/$total;  # cumulative
    push(@sections, sprintf("%s: %.0f (%.0f%%)%.0f",
                            $section, $dt*1000, $dtp, $dtp_c));
    $t0 = $t;
  }
  sprintf("TIMING [total %.0f ms] - %s", $total * 1000, join(", ",@sections));
}

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

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

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

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

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

sub report_load() {
  return  if $t_busy_cum + $t_idle_cum <= 0;
  Amavis::Util::do_log(3, 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 {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.043';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&untaint &min &max &safe_encode &safe_decode &q_encode
                  &snmp_count &snmp_counters_init &snmp_counters_get
                  &am_id &new_am_id &ll &do_log &debug_oneshot
                  &add_entropy &fetch_entropy &generate_mail_id
                  &retcode &exit_status_str &prolong_timer
                  &sanitize_str &fmt_struct &strip_tempdir &rmdir_recursively
                  &read_text &read_l10n_templates &read_hash &read_array
                  &dump_hash &dump_array &run_command &run_command_consumer);
}
use subs @EXPORT_OK;
use POSIX qw(WIFEXITED WIFSIGNALED WIFSTOPPED
             WEXITSTATUS WTERMSIG WSTOPSIG);
use Errno qw(ENOENT EACCES);
use Digest::MD5 2.22;  # need 'clone' method
# use Encode;  # Perl 5.8  UTF-8 support

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

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

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

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

# A wrapper for Encode::encode, avoiding a bug in Perl 5.8.0 which causes
# Encode::encode to loop and fill memory when given a tainted string
# 
# hmh@d.o : in Debian's 5.8.4-2, trying to restore the taintedness
# actually causes perl to somehow lose track of the encoding and it
# completely breaks this sub.  OTOH, perl does loop eating up memory
# on tainted strings, so we will have to lose taint state for now.
sub safe_encode($$;$) {
  if (!$unicode_aware) { $_[1] }  # just return the second argument
  else {
    my($encoding,$str,$check) = @_;
    $check = 0  if !defined($check);
    $str = untaint(\$str);
    return Encode::encode($encoding, $str, $check);  # reattach taintedness
#    # taintedness of the string, with UTF-8 flag unconditionally off
#    my($taint) = Encode::encode('ascii',substr($str,0,0));
#    $taint . Encode::encode($encoding,untaint($str),$check);  # preserve taint
  }
}

sub safe_decode($$;$) {
  if (!$unicode_aware) { $_[1] }  # just return the second argument
  else {
    my($encoding,$str,$check) = @_;
    $check = 0  if !defined($check);
    my($taint) = substr($str,0,0);  # taintedness of the string
    $taint . Encode::decode($encoding,untaint($str),$check);  # preserve taint
  }
}

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

# Set or get Amavis internal message id.
# This message id performs a similar function as queue-id in MTA responses.
# It may only be used in generating text part of SMTP responses,
# or in generating log entries. It is only unique within a limited timespan.
use vars qw($amavis_task_id);  # internal message id (accessible via &am_id)

sub am_id(;$) {
  if (@_) {                    # set, if argument present
    $amavis_task_id = shift;
    $0 = "amavisd ($amavis_task_id)";
  }
  $amavis_task_id;             # return current value
}

sub new_am_id($;$$) {
  my($str, $cnt, $seq) = @_;
  my($id);
  $id = defined $str ? $str : sprintf("%05d", $$);
  $id .= sprintf("-%02d", $cnt)  if defined $cnt;
  $id .= "-$seq"  if defined $seq && $seq > 1;
  am_id($id);
}

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

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

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

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

use vars qw($debug_oneshot);
sub debug_oneshot(;$$) {
  if (@_) {
    my($new_debug_oneshot) = shift;
    if (($new_debug_oneshot ? 1 : 0) != ($debug_oneshot ? 1 : 0)) {
      do_log(0, "DEBUG_ONESHOT: TURNED ".($new_debug_oneshot ? "ON" : "OFF"));
      do_log(0, shift)  if @_;  # caller-provided extra log entry, usually
                                # the one that caused debug_oneshot call
    }
    $debug_oneshot = $new_debug_oneshot;
  }
  $debug_oneshot;
}

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

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

sub retcode($) {  # (this subroutine is being phased out)
  my $code = shift;
  return WEXITSTATUS($code)    if WIFEXITED($code);
  return 128 + WTERMSIG($code) if WIFSIGNALED($code);
  return 255;
}

# map process termination status number to a string, and append optional
# user error mesage, returning the resulting string
sub exit_status_str($;$) {
  my($stat,$err) = @_; my($str);
  if (WIFEXITED($stat)) {
    $str = sprintf("exit %d", WEXITSTATUS($stat));
  } elsif (WIFSTOPPED($stat)) {
    $str = sprintf("stopped, signal %d", WSTOPSIG($stat));
  } else {
    $str = sprintf("DIED on signal %d (%04x)", WTERMSIG($stat),$stat);
  }
  $str .= ', '.$err  if defined $err && $err ne '';
  $str;
}

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

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

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

# Checks tempdir after being cleaned.
# It may only contain subdirectory 'parts' and file email.txt, nothing else.
#
sub check_tempdir($) {
  my($dir) = shift;
  local(*DIR); opendir(DIR,$dir) or die "Can't open directory $dir: $!";
  eval {
    undef $!, my($f);
    while (defined($f = readdir(DIR))) {
      if (!-d ("$dir/$f")) {
        die "Unexpected file $dir/$f"  if $f ne 'email.txt';
      } elsif ($f eq '.' || $f eq '..' || $f eq 'parts') {
      } else {
        die "Unexpected subdirectory $dir/$f";
      }
    }
  # $!==0 or die "Error reading directory $dir: $!";
  };
  closedir(DIR) or die "Error closing directory $dir: $!";
  if ($@ ne '') { chomp($@); die "check_tempdir: $@\n" }
  1;
}

# Remove all files and subdirectories from the temporary directory, leaving
# only the directory itself, file email.txt, and empty subdirectory ./parts .
# Leaving directories for reuse represents an important saving in time,
# as directory creation + deletion is quite an expensive operation,
# requiring atomic file system operation, including flushing buffers to disk.
#
sub strip_tempdir($) {
  my($dir) = shift;
  do_log(4, "strip_tempdir: $dir");
  my($errn) = lstat("$dir/parts") ? 0 : 0+$!;
  if ($errn == ENOENT) {}  # fine, no such directory
  elsif ($errn != 0) { die "strip_tempdir: error accessing $dir/parts: $!" }
  elsif ( -l _) { die "strip_tempdir: $dir/parts is a symbolic link" }
  elsif (!-d _) { die "strip_tempdir: $dir/parts is not a directory" }
  else { rmdir_recursively("$dir/parts", 1) }
  # All done. Check for any remains in the top directory just in case
  check_tempdir($dir);
  1;
}

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

# read a multiline string from a file - may be called from amavisd.conf
sub read_text($;$) {
  my($filename, $encoding) = @_;
  my($inp) = IO::File->new;
  $inp->open($filename,'<') or die "Can't open file $filename for reading: $!";
  if ($unicode_aware && $encoding ne '') {
    binmode($inp, ":encoding($encoding)")
      or die "Can't set :encoding($encoding) on file $filename: $!";
  }
  my($str) = '';  # must not be undef, work around a Perl UTF8 bug
  my($nbytes,$buff);
  while (($nbytes=$inp->read($buff,16384)) > 0) { $str .= $buff }
  defined $nbytes or die "Error reading from $filename: $!";
  $inp->close or die "Error closing $filename: $!";
  $str;
}

# attempt to read all user-visible replies from a l10n dir
# This function auto-fills $notify_sender_templ, $notify_virus_sender_templ,
# $notify_virus_admin_templ, $notify_virus_recips_templ,
# $notify_spam_sender_templ and $notify_spam_admin_templ from files named
# template-dsn.txt, template-virus-sender.txt, template-virus-admin.txt,
# template-virus-recipient.txt, template-spam-sender.txt,
# template-spam-admin.txt.  If this is available, it uses the charset
# file to do automatic charset conversion. Used by the Debian distribution.
sub read_l10n_templates($;$) {
  my($dir) = @_;
  if (@_ > 1)  # compatibility with Debian
    { my($l10nlang, $l10nbase) = @_; $dir = "$l10nbase/$l10nlang" }
  my($file_chset) = Amavis::Util::read_text("$dir/charset");
  if ($file_chset =~ m{^(?:#[^\n]*\n)*([^./\n\s]+)(\s*[#\n].*)?$}s) {
    $file_chset = untaint($1);
  } else {
    die "Invalid charset $file_chset\n";
  }
  $Amavis::Conf::notify_sender_templ =
    Amavis::Util::read_text("$dir/template-dsn.txt", $file_chset);
  $Amavis::Conf::notify_virus_sender_templ =
    Amavis::Util::read_text("$dir/template-virus-sender.txt", $file_chset);
  $Amavis::Conf::notify_virus_admin_templ =
    Amavis::Util::read_text("$dir/template-virus-admin.txt", $file_chset);
  $Amavis::Conf::notify_virus_recips_templ =
    Amavis::Util::read_text("$dir/template-virus-recipient.txt", $file_chset);
  $Amavis::Conf::notify_spam_sender_templ =
    Amavis::Util::read_text("$dir/template-spam-sender.txt", $file_chset);
  $Amavis::Conf::notify_spam_admin_templ =
    Amavis::Util::read_text("$dir/template-spam-admin.txt", $file_chset);
}

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

# read a lookup associative array (Perl hash) from a file - may be called
# from amavisd.conf
#
# Format: one key per line, anything from '#' to the end of line
# is considered a comment, but '#' within correctly quoted rfc2821
# addresses is not treated as a comment (e.g. a hash sign within
# "strange # \"foo\" address"@example.com is part of the string).
# Lines may contain a pair: key value, separated by whitespace, or key only,
# in which case a value 1 is implied. Trailing whitespace is discarded,
# empty lines (containing only whitespace and comment) are ignored.
# Addresses (lefthand-side) are converted from rfc2821-quoted form
# into internal (raw) form and inserted as keys into a given hash.
# NOTE: the format is partly compatible with Postfix maps (not aliases):
#   no continuation lines are honoured, Postfix maps do not allow
#   rfc2821-quoted addresses containing whitespace, Postfix only allows
#   comments starting at the beginning of a line.
#
# The $hashref argument is returned for convenience, so that one can do
# for example:
#   $per_recip_whitelist_sender_lookup_tables = {
#     '.my1.example.com' => read_hash({},'/var/amavis/my1-example-com.wl'),
#     '.my2.example.com' => read_hash({},'/var/amavis/my2-example-com.wl') }
# or even simpler:
#   $per_recip_whitelist_sender_lookup_tables = {
#     '.my1.example.com' => read_hash('/var/amavis/my1-example-com.wl'),
#     '.my2.example.com' => read_hash('/var/amavis/my2-example-com.wl') }
#
sub read_hash(@) {
  unshift(@_,{})  if !ref $_[0];  # first argument is optional, defaults to {}
  my($hashref, $filename, $keep_case) = @_;
  my($lpcs) = c('localpart_is_case_sensitive');
  my($inp) = IO::File->new;
  $inp->open($filename,'<') or die "Can't open file $filename for reading: $!";
  my($ln);
  for (undef $!; defined($ln=$inp->getline); undef $!) {
    chomp($ln);
    # carefully handle comments, '#' within "" does not count as a comment
    my($lhs) = ''; my($rhs) = ''; my($at_rhs) = 0;
    for my $t ( $ln =~ /\G ( " (?: \\. | [^"\\] )* " |
                             [^#" \t]+ | [ \t]+ | . )/gcsx) {
      last  if $t eq '#';
      if (!$at_rhs && $t =~ /^[ \t]+\z/) { $at_rhs = 1 }
      else { ($at_rhs ? $rhs : $lhs) .= $t }
    }
    $rhs =~ s/[ \t]+\z//;  # trim trailing whitespace
    next  if $lhs eq '' && $rhs eq '';
    my($addr) = Amavis::rfc2821_2822_Tools::unquote_rfc2821_local($lhs);
    my($localpart,$domain) = Amavis::rfc2821_2822_Tools::split_address($addr);
    $localpart = lc($localpart)  if !$lpcs;
    $addr = $localpart . lc($domain);
    $hashref->{$addr} = $rhs eq '' ? 1 : $rhs;
    # do_log(5, "read_hash: address: <$addr>: ".$hashref->{$addr});
  }
  defined $ln || $!==0  or die "Error reading from $filename: $!";
  $inp->close or die "Error closing $filename: $!";
  $hashref;
}

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

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

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


# Run specified command as a subprocess. Return a file handle open for
sub run_command($$@) {
  my($stdin_from, $stderr_to, $cmd, @args) = @_;
  my($cmd_text) = join(' ', $cmd, @args);
  $stdin_from = '/dev/null'  if $stdin_from eq '';
  $stderr_to  = '/dev/null'  if defined($stderr_to) && $stderr_to eq '';
  my($msg) = join(' ', $cmd, @args, "<$stdin_from",
                  $stderr_to eq '' ? () : "2>$stderr_to");
# $^F == 2  or do_log(-1,"run_command: SYSTEM_FD_MAX not 2: %d", $^F);
  my($pid); my($proc_fh) = IO::File->new;
  eval {
    $pid = $proc_fh->open('-|');  1;  # fork, catching errors
  } or do {
    my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    die "run_command (open pipe): $eval_stat";
  };
  defined($pid) or die "run_command: can't fork: $!";
  if (!$pid) {  # child
    alarm(0); my($interrupt) = '';
    my($h1) = sub { $interrupt = $_[0] };
    my($h2) = sub { die "Received signal ".$_[0] };
    @SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)} = ($h1) x 7;
    eval {  # die must be caught, otherwise we end up with two running daemons
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
#     use Devel::Symdump ();
#     my($dumpobj) = Devel::Symdump->rnew;
#     for my $k ($dumpobj->ios) {
#       no strict 'refs';  my($fn) = fileno($k);
#       if (!defined($fn)) { do_log(2, "not open %s", $k) }
#       elsif ($fn == 1 || $fn == 2) { do_log(2, "KEEP %s, fileno=%s",$k,$fn) }
#       else { $! = 0;
#         close(*{$k}{IO}) and do_log(2, "DID CLOSE %s (fileno=%s)", $k,$fn);
#       }
#     }
      release_parent_resources();
      open_on_specific_fd(0,$stdin_from,&POSIX::O_RDONLY,0);
      open_on_specific_fd(2,$stderr_to,&POSIX::O_WRONLY,0) if $stderr_to ne '';
#     eval { close_log() };  # may have been closed by open_on_specific_fd
      # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
      exec {$cmd} ($cmd,@args);
      die "run_command: failed to exec $cmd_text: $!";
    };
    my($err) = $@ ne '' ? $@ : "errno=$!";  chomp $err;
    eval {
      local(@SIG{qw(INT HUP TERM TSTP QUIT USR1 USR2)}) = ($h2) x 7;
      if ($interrupt ne '') { my($i) = $interrupt; $interrupt = ''; die $i }
      open_log();  # oops, exec failed, we will need logging after all...
      # we're in trouble if stderr was attached to a terminal, but no longer is
      do_log(-1,sprintf("run_command: child process [%s]: %s", $$,$err));
    };
    { no warnings;
      POSIX::_exit(8);  # avoid END and destructor processing
      kill('KILL',$$); exit 1;   # still kicking? die!
    }
  }
  # parent
  ll(5) && do_log(5,sprintf("run_command: [%s] %s", $pid,$msg));
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

# 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;
# this subroutine is usually called from a forked process prior to exec
sub open_on_specific_fd($$$$) {
  my($fd_target,$fname,$flags,$mode) = @_;
  my($fd_got);  # fd directy given as argument, or obtained from POSIX::open
  my($logging_safe) = 0;
  if (ll(5)) {
    # crude attempt to prevent a forked process from writing log records
    # to its parent process on STDOUT or STDERR
    my($log_fd) = log_fd();
    $logging_safe = 1  if !defined($log_fd) || $log_fd > 2;
  }
  local($1);
  if ($fname =~ /^&=?(\d+)\z/) { $fd_got = $1 }  # fd directly specified
  my($flags_displayed) = $flags == &POSIX::O_RDONLY ? '<'
                       : $flags == &POSIX::O_WRONLY ? '>' : $flags;
  if (!defined($fd_got) || $fd_got != $fd_target) {
    # close whatever is on a target descriptor but don't shoot self in the foot
    # with Net::Server <= 0.90 fd0 was main::stdin, but no longer is in 0.91
    do_log(5, sprintf("open_on_specific_fd: target fd%s closing, to become %s %s",
              $fd_target,$flags_displayed,$fname))  if $logging_safe;
    # it pays off to close explicitly, with some luck open will get a target fd
    POSIX::close($fd_target);  # ignore error, we may have just closed a log
  }
  if (!defined($fd_got)) {  # file name was given, not a descriptor
    $fd_got = POSIX::open($fname,$flags,$mode);
    defined $fd_got or die "Can't open $fname: $!";
    $fd_got = 0 + $fd_got;  # turn into numeric, avoid: "0 but true"
  }
  if ($fd_got != $fd_target) {  # dup, ensuring we get a specified descriptor
    eval {  # we may have been left without a log file descriptor, must not die
      do_log(5, sprintf("open_on_specific_fd: target fd%s dup2 from fd%s %s %s",
                $fd_target,$fd_got,$flags_displayed,$fname))  if $logging_safe;
    };
    # POSIX mandates we got the lowest fd available (but some kernels have
    # bugs), let's be explicit that we require a specified file descriptor
    defined POSIX::dup2($fd_got,$fd_target)
      or die "Can't dup2 from $fd_got to $fd_target: $!";
    if ($fd_got > 2) {  # let's get rid of the original fd, unless 0,1,2
      my($err); defined POSIX::close($fd_got) or $err = $!;
      $err = defined $err ? ": $err" : '';
      eval {  # we may have been left without a log file descriptor, don't die
        do_log(5, sprintf("open_on_specific_fd: source fd%s closed%s",
                  $fd_got,$err))  if $logging_safe;
      };
    }
  }
  $fd_got;
}

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

# WRITING to the subprocess. Use IO::Handle to ensure the subprocess
# will be automatically reclaimed in case of failure.
#
sub run_command_consumer($$@) {
  my($stdout_to, $stderr_to, $cmd, @args) = @_;
  my($cmd_text) = join(' ', $cmd, @args);
  $stdout_to = '/dev/null'  if $stdout_to eq '';
  my($msg) = join(' ', $cmd, @args, ">$stdout_to");
  $msg .= " 2>$stderr_to"  if $stderr_to ne '';
  my($pid); my($proc_fh) = IO::File->new;
  eval { $pid = $proc_fh->open('|-') };  # fork, catching errors
  if ($@ ne '') { chomp($@); die "run_command_consumer (open pipe): $@" }
  defined($pid) or die "run_command_consumer: can't fork: $!";
  if (!$pid) {                           # child
    eval {  # must not use die in forked process, or we end up with
            # two running daemons! Close unneeded files.
#     $sql_dataset_conn_lookups->dbh_inactive(1)  if $sql_dataset_conn_lookups;
#     $sql_dataset_conn_storage->dbh_inactive(1)  if $sql_dataset_conn_storage;
#     $sql_dataset_conn_lookups = $sql_dataset_conn_storage = undef;
      close_log();
      close(main::stderr) or die "Error closing main::stderr: $!";
      close(main::stdout) or die "Error closing main::stdout: $!";
      close(main::STDOUT) or die "Error closing main::STDOUT: $!";
      open(STDOUT, ">$stdout_to")
        or die "Can't reopen STDOUT on $stdout_to: $!";
      fileno(STDOUT) == 1
        or die ("run_command_consumer: STDOUT not fd1: ".fileno(STDOUT));
      if ($stderr_to ne '') {
        close(STDERR) or die "Error closing STDERR: $!";
        open(STDERR, ">$stderr_to")
          or die "Can't open STDERR to $stderr_to: $!";
        fileno(STDERR) == 2
          or die ("run_command_consumer: STDERR not fd2: ".fileno(STDERR));
      }
      # BEWARE of Perl older that 5.6.0: sockets and pipes were not FD_CLOEXEC
      { no warnings;
        exec {$cmd} ($cmd,@args) or die "Failed to exec $cmd_text: $!";
      }
    };
    my($err) = $@; chomp($err);
    eval {
      open_log();  # oops, exec failed, we will need logging after all...
      do_log(-2,"run_command_consumer: child process [$$]: $err\n");
    };
    { no warnings;
      POSIX::_exit(1);  # avoid END and destructor processing
      kill('KILL',$$)   # still kicking? die!
        or do_log(-3,"run_command_consumer: TROUBLE - Panic1, can't die: $!");
      do_log(-3,"run_command_consumer: TROUBLE - Panic2, can't die");
      exit 1;           # better safe than sorry
                        # NOTREACHED
    }
  }
  # parent
  do_log(5,"run_command_consumer: [$pid] $msg");
  binmode($proc_fh) or die "Can't set pipe to binmode: $!";  # dflt Perl 5.8.1
  ($proc_fh, $pid);  # return pipe file handle to the subprocess and its PID
}

1;

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

BEGIN {
  use Exporter ();
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.043';
  @ISA = qw(Exporter);
  @EXPORT = qw(
    &iso8601_timestamp &iso8601_utc_timestamp &rfc2822_timestamp
    &received_line &parse_received
    &fish_out_ip_from_received &split_address &split_localpart &make_query_keys
    &quote_rfc2821_local &qquote_rfc2821_local &unquote_rfc2821_local
    &one_response_for_all
    &EX_OK &EX_NOUSER &EX_UNAVAILABLE &EX_TEMPFAIL &EX_NOPERM);
}
use subs @EXPORT;

use POSIX qw(locale_h strftime);

BEGIN {
  eval { require 'sysexits.ph' };  # try to use the installed version
  # define the most important constants if undefined
  do { sub EX_OK()           {0} } unless defined(&EX_OK);
  do { sub EX_NOUSER()      {67} } unless defined(&EX_NOUSER);
  do { sub EX_UNAVAILABLE() {69} } unless defined(&EX_UNAVAILABLE);
  do { sub EX_TEMPFAIL()    {75} } unless defined(&EX_TEMPFAIL);
  do { sub EX_NOPERM()      {77} } unless defined(&EX_NOPERM);
}

BEGIN {
  import Amavis::Conf qw(:platform $myhostname c cr ca);
  import Amavis::Util qw(ll do_log);
}

# Given a Unix time, return the local time zone offset at that time
# as a string +HHMM or -HHMM, appropriate for the RFC2822 date format.
# Works also for non-full-hour zone offsets, and on systems where strftime
# can not return TZ offset as a number;  (c) Mark Martinec, GPL
#
sub get_zone_offset($) {
  my($t) = @_;
  my($d) = 0;   # local zone offset in seconds
  for (1..3) {  # match the date (with a safety loop limit just in case)
    my($r) = sprintf("%04d%02d%02d", (localtime($t))[5, 4, 3]) cmp
             sprintf("%04d%02d%02d", (gmtime($t + $d))[5, 4, 3]);
    if ($r == 0) { last } else { $d += $r * 24 * 3600 }
  }
  my($sl,$su) = (0,0);
  for ((localtime($t))[2,1,0])   { $sl = $sl * 60 + $_ }
  for ((gmtime($t + $d))[2,1,0]) { $su = $su * 60 + $_ }
  $d += $sl - $su;  # add HMS difference (in seconds)
  my($sign) = $d >= 0 ? '+' : '-';
  $d = -$d  if $d < 0;
  $d = int(($d + 30) / 60.0);  # give minutes, rounded
  sprintf("%s%02d%02d", $sign, int($d / 60), $d % 60);
}

# Given a Unix numeric time (seconds since 1970-01-01T00:00Z),
# provide date-time timestamp (local time) as specified in ISO 8601 (EN 28601)
#
sub iso8601_timestamp($;$$) {
  my($t,$suppress_zone,$separator) = @_;
  # can't use %z because some systems do not support it (is treated as %Z)
  my($s) = strftime("%Y%m%dT%H%M%S", localtime($t));
  $s =~ s/T/$separator/  if defined $separator;
  $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,$separator) = @_;
  my($s) = strftime("%Y%m%dT%H%M%S", gmtime($t));
  $s =~ s/T/$separator/  if defined $separator;
  $s .= 'Z'  unless $suppress_zone;
  $s;
}

# Given a Unix time, provide date-time timestamp as specified in RFC 2822
# (local time), to be used in header fields such as 'Date:' and 'Received:'
#
sub rfc2822_timestamp($) {
  my($t) = @_;
  my(@lt) = localtime($t);
  # can't use %z because some systems do not support it (is treated as %Z)
# my($old_locale) = POSIX::setlocale(LC_TIME,"C");  # English dates required!
  my($zone_name) = strftime("%Z",@lt);
  my($s) = strftime("%a, %e %b %Y %H:%M:%S ", @lt);
  $s .= get_zone_offset($t);
  $s .= " (" . $zone_name . ")"  if $zone_name !~ /^\s*\z/;
# POSIX::setlocale(LC_TIME, $old_locale);  # restore the locale
  $s;
}

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

sub parse_received($) {
  my($received) = @_;
  local($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11);
  $received =~ s/\n([ \t])/$1/g;  # unfold
  $received =~ s/[\n\r]//g;       # delete remaining newlines if any
  my(%fields);
  while ($received =~ m{\G\s*
            ( \b(from|by) \s+ ( (?: \[ (?: \\. | [^\]\\] )* \] | [^;\s\[] )+ )
              (?: \s* \( (?: ( [^\s\[]+ ) \s+ )?
                         \[ ( (?: \\. | [^\]\\] )* ) \] \s*
                      \) )?
              (?: .*? ) (?= \(|;|\z|\b(?:from|by|via|with|id|for)\b )  # junk
            | \b(via|with|id|for) \s+
              ( (?:  "  (?: \\. | [^"\\]  )* "
                  |  \[ (?: \\. | [^\]\\] )* \]
                  |  \\. | [0-9a-z]+ | .    # greedy words avoid deep recursion
                )+? (?= \(|;|\z|\b(?:from|by|via|with|id|for)\b ) )
            | (;) \s* ( .*? ) \s* \z                                   # time
            | (.*?) (?= \(|;|\z|\b(?:from|by|via|with|id|for)\b )      # junk
            ) ( (?: \s+ | (?: \( (?: \\. | [^)\\] )* \) ) )* ) }xgcsi)
  {
    my($v1, $v2, $v3, $comment) = ('') x 4;
    my($item, $field) = ($1, lc($2 || $6 || $8));
    $field = ''  if !defined($field);  # mute a warning about uninit. value
    if ($field eq 'from' || $field eq 'by') {
      ($v1, $v2, $v3, $comment) = ($3, $4, $5, $11);
    } elsif ($field eq ';') {  # time
      ($v1, $comment) = ($9, $11);
    } elsif (!defined($10) || $10 eq '') {  # via|with|id|for
      ($v1, $comment) = ($7, $11);
    } else {                   # junk
      ($v1, $comment) = ($10, $11);
    }
    $comment =~ s/^\s+//;
    $comment =~ s/\s+\z//;
    $item    =~ s/^\Q$field\E\s*//i;
    if (!exists $fields{$field}) {
      $fields{$field} = [$item, $v1, $v2, $v3, $comment];
      ll(5) && do_log(5, sprintf("parse_received: %s = %s/%s/%s/%s",
                              map { !defined($_) ? '' : length($_) <= 50 ? $_
                                    : substr($_,0,50)."..." }
                              ($field, @{$fields{$field}}) ))  if $field ne '';
    }
  }
  \%fields;
}

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

# Splits unquoted fully qualified e-mail address, or an address
# with missing domain part. Returns a pair: (localpart, domain).
# The domain part (if nonempty) includes the '@' as the first character.
# If the syntax is badly broken, everything ends up as the localpart.
# The domain part can be an address literal, as specified by rfc2822.
# Does not handle explicit route paths.
#
sub split_address($) {
  my($mailbox) = @_;
  $mailbox =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\]\\] )*  \]
                                 |  [^@"<>\[\]\\\s] )*
                       ) \z/xs ? ($1, $2) : ($mailbox, '');
}

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

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

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

# quote_rfc2821_local() quotes the local part of a mailbox address
# (given in internal (unquoted) form), and returns external (quoted)
# mailbox address, as per rfc2821.
#
# Internal (unquoted) form is used internally by amavisd-new and other mail sw,
# external (quoted) form is used in SMTP commands and message headers.
#
# The quote_rfc2821_local() conversion is necessary because addresses
# we get from certain MTAs are raw, with stripped-off quoting.
# To re-insert message back via SMTP, the local-part of the address needs
# to be quoted again if it contains reserved characters or otherwise
# does not obey the dot-atom syntax, as specified in rfc2821.
# Failing to do that gets us into trouble: amavis accepts message from MTA,
# but is unable to hand it back to MTA after checking, receiving
# '501 Bad address syntax' with every attempt.
#
sub quote_rfc2821_local($) {
  my($mailbox) = @_;
  # atext: any character except controls, SP, and specials (rfc2821/rfc2822)
  my($atext) = "a-zA-Z0-9!#\$%&'*/=?^_`{|}~+-";
  # my($specials) = '()<>\[\]\\\\@:;,."';
  my($localpart,$domain) = split_address($mailbox);
  if ($localpart !~ /^[$atext]+(\.[$atext]+)*\z/so) {  # not dot-atom
    $localpart =~ s/(["\\])/\\$1/g;                    # quoted-pair
    # special case: Postfix hates  ""@domain  but is not so harsh on  @domain
    $localpart = '"'.$localpart.'"'  if $localpart ne '';  # make it a qcontent
  }
  $domain = ''  if $domain eq '@';        # strip off empty domain entirely
  $localpart . $domain;
}

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

# unquote_rfc2821_local() strips away the quoting from the local part
# of an external (quoted) mailbox address, and returns internal (unquoted)
# mailbox address, as per rfc2821.
#
# Internal (unquoted) form is used internally by amavisd-new and other mail sw,
# external (quoted) form is used in SMTP commands and message headers.
#
sub unquote_rfc2821_local($) {
  my($mailbox) = @_;
  # the angle-bracket stripping is not really a duty of this subroutine,
  # as it should have been already done elsewhere, but for the time being
  # we do it here:
  $mailbox = $1  if $mailbox =~ /^ \s* < ( .* ) > \s* \z/xs;
  my($localpart,$domain) = split_address($mailbox);
  $localpart =~ s/ " | \\ (.) | \\ \z /$1/xsg;  # unquote quoted-pairs
  $localpart . $domain;
}

# Prepare a single SMTP response and an exit status as per sysexits.h
# from individual per-recipient response codes, taking into account
# sendmail milter specifics. Returns a triple: (smtp response, exit status,
# an indication whether DSN is needed).
#
sub one_response_for_all($$$) {
  my($msginfo, $dsn_per_recip_capable, $am_id) = @_;
  my($smtp_resp, $exit_code, $dsn_needed);

  my($delivery_method) = $msginfo->delivery_method;
  my($sender)          = $msginfo->sender;
  my($per_recip_data)  = $msginfo->per_recip_data;
  my($any_not_done)    = scalar(grep { !$_->recip_done } @$per_recip_data);
  if ($delivery_method ne '' && $any_not_done)
    { die "Explicit forwarding, but not all recips done" }
  if (!@$per_recip_data) {  # no recipients, nothing to do
    $smtp_resp = "250 2.5.0 Ok, id=$am_id"; $exit_code = EX_OK;
    do_log(5, "one_response_for_all <$sender>: no recipients, '$smtp_resp'");
  }
  if (!defined $smtp_resp) {
    for my $r (@$per_recip_data) {  # any 4xx code ?
      if ($r->recip_smtp_response =~ /^4/)  # pick the first 4xx code
        { $smtp_resp = $r->recip_smtp_response; last }
    }
    if (!defined $smtp_resp) {
      for my $r (@$per_recip_data) {        # any invalid code ?
        if ($r->recip_done && $r->recip_smtp_response !~ /^[245]/) {
          $smtp_resp = '451 4.5.0 Bad SMTP response code??? "'
                       . $r->recip_smtp_response . '"';
          last;                             # pick the first
        }
      }
    }
    if (defined $smtp_resp) {
      $exit_code = EX_TEMPFAIL;
      do_log(5, "one_response_for_all <$sender>: 4xx found, '$smtp_resp'");
    }
  }
  # NOTE: a 2xx SMTP response code is set both by internal Discard
  # and by a genuine successful delivery. To distinguish between the two
  # we need to check $r->recip_destiny as well.
  #
  if (!defined $smtp_resp) {
    # if destiny for _all_ recipients is D_DISCARD, give Discard
    my($notall);
    for my $r (@$per_recip_data) {
      if ($r->recip_destiny == D_DISCARD)  # pick the first DISCARD code
        { $smtp_resp = $r->recip_smtp_response  if !defined $smtp_resp }
      else { $notall++; last }  # one is not a discard, nogood
    }
    if ($notall) { $smtp_resp = undef }
    if (defined $smtp_resp) {
      # helper program will interpret 99 as discard
      $exit_code = $delivery_method eq '' ? 99 : EX_OK;
      do_log(5, "one_response_for_all <$sender>: all DISCARD, '$smtp_resp'");
    }
  }
  if (!defined $smtp_resp) {
    # destiny for _all_ recipients is Discard or Reject, give 5xx
    # (and there is at least one Reject)
    my($notall, $done_level);
    my($bounce_cnt) = 0;
    for my $r (@$per_recip_data) {
      my($dest, $resp) = ($r->recip_destiny, $r->recip_smtp_response);
      if ($dest == D_DISCARD) {
        # ok, this one is discard, let's see the rest
      } elsif ($resp =~ /^5/ && $dest != D_BOUNCE) {
        # prefer to report SMTP response code of genuine rejects
        # from MTA, over internal rejects by content filters
        if (!defined $smtp_resp || $r->recip_done > $done_level)
          { $smtp_resp = $resp; $done_level = $r->recip_done }
      } else { $notall++; last }  # one is Pass or Bounce, nogood
    }
    if ($notall) { $smtp_resp = undef }
    if (defined $smtp_resp) {
      $exit_code = EX_UNAVAILABLE;
      do_log(5, "one_response_for_all <$sender>: REJECTs, '$smtp_resp'");
    }
  }
  if (!defined $smtp_resp) {
    # mixed destiny => 2xx, but generate dsn for bounces and rejects
    my($rej_cnt) = 0; my($bounce_cnt) = 0; my($drop_cnt) = 0;
    for my $r (@$per_recip_data) {
      my($dest, $resp) = ($r->recip_destiny, $r->recip_smtp_response);
      if ($resp =~ /^2/ && $dest == D_PASS)  # genuine successful delivery
        { $smtp_resp = $resp  if !defined $smtp_resp }
      $drop_cnt++  if $dest == D_DISCARD;
      if ($resp =~ /^5/)
        { if ($dest == D_BOUNCE) { $bounce_cnt++ } else { $rej_cnt++ } }
    }
    $exit_code = EX_OK;
    if (!defined $smtp_resp) {                 # no genuine Pass/2xx
        # declare success, we'll handle bounce
      $smtp_resp = "250 2.5.0 Ok, id=$am_id";
      if ($any_not_done) { $smtp_resp .= ", continue delivery" }
      elsif ($delivery_method eq '') { $exit_code = 99 }  # milter DISCARD
    }
    if ($rej_cnt + $bounce_cnt + $drop_cnt > 0) {
      $smtp_resp .= ", ";
      $smtp_resp .= "but "  if $rej_cnt+$bounce_cnt+$drop_cnt<@$per_recip_data;
      $smtp_resp .= join ", and ",
        map { my($cnt, $nm) = @$_;
              !$cnt ? () : $cnt == @$per_recip_data ? $nm : "$cnt $nm"
        } ([$rej_cnt,'REJECT'], [$bounce_cnt,'BOUNCE'], [$drop_cnt,'DISCARD']);
    }
    $dsn_needed =
      ($bounce_cnt > 0 || ($rej_cnt > 0 && !$dsn_per_recip_capable)) ? 1 : 0;
    ll(5) && do_log(5,"one_response_for_all <$sender>: "
             . ($rej_cnt + $bounce_cnt + $drop_cnt > 0 ? 'mixed' : 'success')
             . ", r=$rej_cnt,b=$bounce_cnt,d=$drop_cnt"
             . ", dsn_needed=$dsn_needed, '$smtp_resp'");
  }
  ($smtp_resp, $exit_code, $dsn_needed);
}

1;

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

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

# Make an object out of the supplied lookup list
# to make it distinguishable from simple ACL array
sub new($$) { my($class) = shift; bless [@_], $class }

# lookup_re() performs a lookup for an e-mail address or other key string
# against a list made up of regular expressions.
#
# A full unmodified e-mail address is always used, so splitting to localpart
# and domain or lowercasing is NOT performed. The regexp is powerful enough
# that this can be accomplished by its mechanisms. The routine is useful for
# other RE tests besides the usual e-mail addresses, such as looking for
# banned file names.
#
# Each element of the list can be ref to a pair, or directly a regexp
# ('Regexp' object created by a qr operator, or just a (less efficient)
# string containing a regular expression). If it is a pair, the first
# element is treated as a regexp, and the second provides a value in case
# the regexp matches. If not a pair, the implied result of a match is 1.
#
# The regular expression is taken as-is, no implicit anchoring or setting
# case insensitivity is done, so do use a qr'(?i)^user@example\.com$',
# and not a sloppy qr'user@example.com', which can easily backfire.
# Also, if qr is used with a delimiter other than ' (apostrophe), make sure
# to quote the @ and $ .
#
# The pattern allows for capturing of parenthesized substrings, which can
# then be referenced from the result string using the $1, $2, ... notation,
# as with the Perl m// operator. The number after a $ may be a multi-digit
# decimal number. To avoid possible ambiguity the ${n} or $(n) form may be used
# Substring numbering starts with 1. Nonexistent references evaluate to empty
# strings. If any substitution is done, the result inherits the taintedness
# of $addr. Keep in mind that $ and @ characters needs to be backslash-quoted
# in qq() strings. Example:
#   $virus_quarantine_to = new_RE(
#     [ qr'^(.*)@example\.com$'i => 'virus-${1}@example.com' ],
#     [ qr'^(.*)(@[^@]*)?$'i     => 'virus-${1}${2}' ] );
#
# Example (equivalent to the example in lookup_acl):
#    $acl_re = Amavis::Lookup::RE->new(
#                       qr'@me\.ac\.uk$'i, [qr'[@.]ac\.uk$'i=>0], qr'\.uk$'i );
#    ($r,$k) = $acl_re->lookup_re('user@me.ac.uk');
# or $r = lookup(0, 'user@me.ac.uk', $acl_re);
#
# 'user@me.ac.uk'   matches me.ac.uk, returns true and search stops
# 'user@you.ac.uk'  matches .ac.uk, returns false (because of =>0) and search stops
# 'user@them.co.uk' matches .uk, returns true and search stops
# 'user@some.com'   does not match anything, falls through and returns false (undef)
#
# As a special allowance, the $addr argument may be a ref to a list of search
# keys. At each step in traversing the supplied regexp list, all elements of
# @$addr are tried. If any of them matches, the search stops. This is currently
# used in banned names lookups, where all attributes of a part are given as a
# list @$addr.

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

1;

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

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

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

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

# lookup_ip_acl() performs a lookup for an IPv4 or IPv6 address
# against access control list or a hash of network or host addresses.
#
# IP address is compared to each member of an access list in turn,
# the first match wins (terminates the search), and its value decides
# whether the result is true (yes, permit, pass) or false (no, deny, drop).
# Falling through without a match produces false (undef).
#
# The presence of character '!' prepended to a list member decides
# whether the result will be true (without a '!') or false (with '!')
# in case this list member matches and terminates the search.
#
# Because search stops at the first match, it only makes sense
# to place more specific patterns before the more general ones.
#
# For IPv4 a network address can be specified in classless notation
# n.n.n.n/k, or using a mask n.n.n.n/m.m.m.m . Missing mask implies /32,
# i.e. a host address. For IPv6 addresses all rfc3513 forms are allowed.
# See also comments at ip_to_vec().
#
# Although not a special case, it is good to remember that '::/0'
# always matches any IPv4 or IPv6 address (even syntactically invalid address).
#
# The '0/0' is equivalent to '::FFFF:0:0/96' and matches any syntactically
# valid IPv4 address (including IPv4-mapped IPv6 addresses), but not other
# IPv6 addresses!
#
# Example
#   given: @acl = qw( !192.168.1.12 172.16.3.3 !172.16.3.0/255.255.255.0
#                     10.0.0.0/8 172.16.0.0/12 192.168.0.0/16
#                     !0.0.0.0/8 !:: 127.0.0.0/8 ::1 );
#   matches rfc1918 private address space except host 192.168.1.12
#   and net 172.16.3/24 (but host 172.16.3.3 within 172.16.3/24 still matches).
#   In addition, the 'unspecified' (null, i.e. all zeros) IPv4 and IPv6
#   addresses return false, and IPv4 and IPv6 loopback addresses match
#   and return true.
#
# If the supplied lookup table is a hash reference, match a canonical IP
# address: dot-quad IPv4, or preferred IPv6 form, against hash keys. For IPv4
# addresses a simple classful subnet specification is allowed in hash keys
# by truncating trailing bytes from the looked up IPv4 address. A syntactically
# invalid IP address can only match a hash entry with an undef key.
#
sub lookup_ip_acl($@) {
  my($ip, @nets_ref) = @_;
  my($ip_vec,$ip_mask) = eval { ip_to_vec($ip,0) }; my($eval_stat) = $@;
  my($label,$fullkey,$result); my($found) = 0;
  for my $tb (@nets_ref) {
    my($t) = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
    if (!ref($t) || ref($t) eq 'SCALAR') {   # a scalar always matches
      my($r) = ref($t) ? $$t : $t;  # allow direct or indirect reference
      $result = $r; $fullkey = "(constant:$r)";
      $found++  if defined $result;
    } elsif (ref($t) eq 'HASH') {
      if (!defined $ip_vec) {  # syntactically invalid IP address
        $fullkey = undef; $result = $t->{$fullkey};
        $found++  if defined $result;
      } else {      # valid IP address
        # match the canonical IP address: dot-quad IPv4, or preferred IPv6 form
        my($ip_c);  # IP address in the canonical form: x:x:x:x:x:x:x:x
        my($ip_dq); # IPv4 in a dotted-quad form if IPv4-mapped, or undef
        $ip_c = join(':', map {sprintf('%04x',$_)} unpack('n8',$ip_vec));
        my($ipv4_vec,$ipv4_mask) = ip_to_vec('::FFFF:0:0/96',1);
        if ( ($ip_vec & $ipv4_mask) eq ($ipv4_vec & $ipv4_mask) ) {
          # is an IPv4-mapped IPv6 address, format it in a dot-quad form
          $ip_dq = join('.', unpack('C4',substr($ip_vec,12,4))); # last 32 bits
        }
        do_log(5, "lookup_ip_acl keys: \"$ip_dq\", \"$ip_c\"");
        if (defined $ip_dq) {  # try dot-quad if applicable
          for (my(@f)=split(/\./,$ip_dq); @f && !$found; $#f--) {
            $fullkey = join('.',@f); $result = $t->{$fullkey};
            $found++  if defined $result;
          }
        }
        if (!$found) {         # try the 'preferred IPv6 form'
          $fullkey = $ip_c; $result = $t->{$fullkey};
          $found++  if defined $result;
        }
      }
    } elsif (ref($t) eq 'ARRAY') {
      my($key, $acl_ip_vec, $acl_mask, $acl_mask_len);
      for my $net (@$t) {
        $fullkey = $key = $net; $result = 1;
        if ($key =~ /^(!+)(.*)\z/s) {  # starts with exclamation mark(s)
          $key = $2;
          $result = 1 - $result  if (length($1) & 1);  # negate if odd
        }
        ($acl_ip_vec, $acl_mask, $acl_mask_len) = ip_to_vec($key,1);
        if ($acl_mask_len == 0) { $found++ }  # even invalid address matches /0
        elsif (!defined($ip_vec)) {}     # no other matches for invalid address
        elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found++ }
        last  if $found;
      }
    } elsif ($t->isa('Amavis::Lookup::IP')) {  # pre-parsed IP lookup array obj
      my($acl_ip_vec, $acl_mask, $acl_mask_len);
      for my $e (@$t) {
        ($fullkey, $acl_ip_vec, $acl_mask, $acl_mask_len, $result) = @$e;
        if ($acl_mask_len == 0) { $found++ }  # even invalid address matches /0
        elsif (!defined($ip_vec)) {}     # no other matches for invalid address
        elsif (($ip_vec & $acl_mask) eq ($acl_ip_vec & $acl_mask)) { $found++ }
        last  if $found;
      }
    } elsif ($t->isa('Amavis::Lookup::Label')) {  # logging label
      # just a convenience for logging purposes, not a real lookup method
      $label = $t->display;  # grab the name, and proceed with the next table
    } else {
      die "TROUBLE: lookup table is an unknown object: " . ref($t);
    }
    last  if $found;
  }
  $fullkey = $result = undef  if !$found;
  if ($label ne '') { $label = " ($label)" }
  ll(4) && do_log(4, "lookup_ip_acl$label: key=\"$ip\""
         . (!$found ? ", no match" : " matches \"$fullkey\", result=$result"));
  if ($eval_stat eq '') { $eval_stat = undef }
  else {
    chomp($eval_stat); $eval_stat = "lookup_ip_acl$label: $eval_stat";
    do_log(2, $eval_stat);
  }
  !wantarray ? $result : ($result, $fullkey, $eval_stat);
}

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

1;

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

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

1;

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

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

BEGIN {
  import Amavis::Util qw(ll do_log fmt_struct);
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::rfc2821_2822_Tools qw(split_address make_query_keys);
}

# lookup_hash() performs a lookup for an e-mail address against a hash map.
# If a match is found (a hash key exists in the Perl hash) the function returns
# whatever the map returns, otherwise undef is returned. First match wins,
# aborting further search sequence.
#
sub lookup_hash($$;$) {
  my($addr, $hash_ref,$get_all) = @_;
  (ref($hash_ref) eq 'HASH')
    or die "lookup_hash: arg2 must be a hash ref: $hash_ref";
  local($1,$2,$3,$4); my(@matchingkey,@result);
  my($keys_ref,$rhs_ref) = make_query_keys($addr,1,1);
  for my $key (@$keys_ref) {   # do the search
    if (exists $$hash_ref{$key}) {  # got it
      push(@result,$$hash_ref{$key}); push(@matchingkey,$key);
      last  if !$get_all;
    }
  }
  # do the right-hand side replacements if any $n, ${n} or $(n) is specified
  for my $r (@result) {  # remember that $r is just an alias to array elements
    if (!ref($r) && $r=~/\$/) {  # is a plain string containing a '$'
      my($any) = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                        { my($j)=$2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }gxse;
      # bring taintedness of input to the result
      $r .= substr($addr,0,0)  if $any;
    }
  }
  if (!ll(5)) {
    # only bother with logging when needed
  } elsif (!@result) {
    do_log(5,"lookup_hash($addr), no matches");
  } elsif (!$get_all) {  # first match wins
    do_log(5,sprintf('lookup_hash(%s) matches key "%s", result=%s',
                      $addr,$matchingkey[0],$result[0]));
  } else {  # want all matches
    do_log(5,"lookup_hash($addr) matches keys: ".
             join(', ', map {sprintf('"%s"=>%s',$matchingkey[$_],$result[$_])}
                            (0..$#result)));
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

# lookup_acl() performs a lookup for an e-mail address against
# access control list.
#
# The supplied e-mail address is compared with each member of the
# lookup list in turn, the first match wins (terminates the search),
# and its value decides whether the result is true (yes, permit, pass)
# or false (no, deny, drop). Falling through without a match
# produces false (undef). Search is case-insensitive.
#
# lookup_acl is not aware of address extensions and they are not
# handled specially.
#
# If a list element contains a '@', the full e-mail address is compared,
# otherwise if a list element has a leading dot, the domain name part is
# matched only, and the domain as well as its subdomains can match. If there
# is no leading dot, the domain must match exactly (subdomains do not match).
#
# The presence of character '!' prepended to a list element decides
# whether the result will be true (without a '!') or false (with '!')
# in case this list element matches and terminates the search.
#
# Because search stops at the first match, it only makes sense
# to place more specific patterns before the more general ones.
#
# Although not a special case, it is good to remember that '.' always matches,
# so a '.' would stop the search and return true, whereas '!.' would stop the
# search and return false (0).
#
# Examples:
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'me.ac.uk' matches me.ac.uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'you.ac.uk' matches .ac.uk, returns false (because of '!') and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'them.co.uk' matches .uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'some.com' does not match anything, falls through and returns false (undef)
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk !. )
#   'some.com' similar to previous, except it returns 0 instead of undef,
#   which would only make a difference if this ACL is not the last argument
#   in a call to lookup()
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk . )
#   'some.com' matches catchall ".", and returns true. The ".uk" is redundant
#
# more complex example: @acl = qw(
#   !The.Boss@dept1.xxx.com .dept1.xxx.com
#   .dept2.xxx.com .dept3.xxx.com lab.dept4.xxx.com
#   sub.xxx.com !.sub.xxx.com
#   me.d.aaa.com him.d.aaa.com !.d.aaa.com .aaa.com
# );

sub lookup_acl($$) {
  my($addr, $acl_ref) = @_;
  (ref($acl_ref) eq 'ARRAY')
    or die "lookup_acl: arg2 must be a list ref: $acl_ref";
  return undef  if !@$acl_ref;  # empty list can't match anything
  my($lpcs) = c('localpart_is_case_sensitive');
  my($localpart,$domain) = split_address($addr); $domain = lc($domain);
  $localpart = lc($localpart)  if !$lpcs;
  local($1,$2);
  # chop off leading @ and trailing dots
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  my($lcaddr) = $localpart . '@' . $domain;
  my($matchingkey, $result); my($found) = 0;
  for my $e (@$acl_ref) {
    $result = 1; $matchingkey = $e; my($key) = $e;
    if ($key =~ /^(!+)(.*)\z/s) {      # starts with an exclamation mark(s)
      $key = $2;
      $result = 1-$result  if (length($1) & 1);  # negate if odd
    }
    if ($key =~ /^(.*?)\@([^@]*)\z/s) {   # contains '@', check full address
      $found++  if $localpart eq ($lpcs?$1:lc($1)) && $domain eq lc($2);
    } elsif ($key =~ /^\.(.*)\z/s) {   # leading dot: domain or subdomain
      my($key_t) = lc($1);
      $found++  if $domain eq $key_t || $domain =~ /(\.|\z)\Q$key_t\E\z/s;
    } else {                           # match domain (but not its subdomains)
      $found++  if $domain eq lc($key);
    }
    last  if $found;
  }
  $matchingkey = $result = undef  if !$found;
  do_log(5, "lookup_acl($addr)".
    (!$found?", no match":" matches key \"$matchingkey\", result=$result"));
  !wantarray ? $result : ($result, $matchingkey);
}

# Perform a lookup for an e-mail address against any number of supplied maps:
# - SQL map,
# - LDAP map,
# - hash map (associative array),
# - (access control) list,
# - a list of regular expressions (an Amavis::Lookup::RE object),
# - a (defined) scalar always matches, and returns itself as the 'map' value
#   (useful as a catchall for final 'pass' or 'fail');
# (see lookup_hash, lookup_acl, lookup_sql and lookup_ldap for details).
#
# when $get_all is 0 (the common usage):
#   If a match is found (a defined value), returns whatever the map returns,
#   otherwise returns undef. FIRST match aborts further search sequence.
# when $get_all is true:
#   Collects a list of results from ALL matching tables, and within each
#   table from ALL matching key. Returns a ref to the a list of results
#   (and a ref to a list of matching keys if returning a pair).
#   The first element of both lists is supposed to be what lookup() would
#   have returned if $get_all were 0. The order of returned elements
#   corresponds to the order of the search.
#
sub lookup($$@) {
  my($get_all, $addr, @tables) = @_;
  my($label, @result,@matchingkey);
  for my $tb (@tables) {
    my($t) = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
    if (!ref($t) || ref($t) eq 'SCALAR') {   # a scalar always matches
      my($r) = ref($t) ? $$t : $t;  # allow direct or indirect reference
      if (defined $r) {
        do_log(5,"lookup: (scalar) matches, result=\"$r\"");
        push(@result,$r); push(@matchingkey,"(constant:$r)");
      }
    } elsif (ref($t) eq 'HASH') {
      my($r,$mk) = lookup_hash($addr,$t,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif (ref($t) eq 'ARRAY') {
      my($r,$mk) = lookup_acl($addr,$t);
      if (defined $r)   { push(@result,$r);  push(@matchingkey,$mk)  }
    } elsif ($t->isa('Amavis::Lookup::Label')) {  # logging label
      # just a convenience for logging purposes, not a real lookup method
      $label = $t->display;  # grab the name, and proceed with the next table
    } elsif ($t->isa('Amavis::Lookup::RE')) {
      my($r,$mk) = $t->lookup_re($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::SQL')) {
      my($r,$mk) = $t->lookup_sql($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::SQLfield')) {
      my($r,$mk) = $t->lookup_sql_field($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::LDAP')) {
      my($r,$mk) = $t->lookup_ldap($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk) }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::LDAPattr')) {
      my($r,$mk) = $t->lookup_ldap_attr($addr,$get_all);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk) }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } else {
      die "TROUBLE: lookup table is an unknown object: " . ref($t);
    }
    last  if @result && !$get_all;
  }
  # pretty logging
  if (ll(4)) {  # only bother preparing log report which will be printed
    if (defined $label && $label ne '') { $label = " ($label)" }
    if (!@tables) {
      do_log(4,sprintf("lookup%s => undef, %s, no lookup tables",
                       $label, fmt_struct($addr)));
    } elsif (!@result) {
      do_log(4,sprintf("lookup%s => undef, %s does not match",
                       $label, fmt_struct($addr)));
    } elsif (!$get_all) {  # first match wins
      do_log(4,sprintf(
        '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,sprintf('lookup%s, %d matches for %s, results: %s',
        $label, scalar(@result), fmt_struct($addr),
        join(', ',map { sprintf('"%s"=>%s',
                                $matchingkey[$_], fmt_struct($result[$_]))
                      } (0..$#result) )));
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;

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

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

# Given a string reference and a hashref of predefined (builtin) macros,
# expand() performs a macro expansion and returns a ref to the resulting string
#
# This is a simple, yet fully fledged macro processor with proper lexical
# analysis, call stack, implied quoting levels, user supplied builtin macros,
# two builtin flow-control macros: selector and iterator, plus a macro #,
# which discards input tokens until NEWLINE (like 'dnl' in m4).
# Also recognized are the usual \c and \nnn forms for specifying special
# characters, where c can be any of: r, n, f, b, e, a, t.  Lexical analysis
# of the input string is performed only once, macro result values are not
# in danger of being lexically re-parsed and are treated as plain characters,
# loosing any special meaning they might have. No new macros can be defined
# by processing input string (at least in this version).
#
# Simple caller-provided macros have a single character name (usually a letter)
# and can evaluate to a string (possibly empty or undef), or an array of
# strings. It can also be a subroutine reference, in which case the subroutine
# will be called whenever macro value is needed. The subroutine must return
# a scalar: a string, or an array reference. The result will be treated as if
# it were specified directly.
#
# Two forms of simple macro calls are known: %x and %#x (where x is a single
# letter macro name, i.e. a key in a user-supplied associative array):
#   %x   evaluates to the hash value associated with the name x;
#        if the value is an array ref, the result is a single concatenated
#        string of values separated with comma-space pairs;
#   %#x  evaluates to a number: if a macro value is a scalar, returns 0
#        for all-whitespace value, and 1 otherwise. If a value is an array ref,
#        evaluates to the number of elements in the array.
# A macro is evaluated only in nonquoted context, i.e. top-level text or in
# the first argument of a top-level selector (see below). A literal percent
# character can be produced by %% or \%.
#
# More powerful expansion is provided by two builtin macros, using syntax:
#   [? arg1 | arg2 | ... ]    a selector
#   [  arg1 | arg2 | ... ]    an iterator
# where [, [?, | and ] are required tokens. To take away the special meaning
# of these characters they can be quoted by a backslash, e.g. \[ or \\ .
# Arguments are arbitrary text, possibly multiline, whitespace counts.
# Nested macro calls are permitted, proper bracket nesting must be observed.
#
# SELECTOR lets its first argument be evaluated immediately, and implicitly
# protects the remaining arguments. The evaluated first argument chooses which
# of the remaining arguments is selected as a result value. The chosen result
# is only then evaluated, remaining arguments are discarded without evaluation.
# The first argument is usually a number (with optional leading and trailing
# whitespace). If it is a non-numeric string, it is treated as 0 for
# all-whitespace, and as 1 otherwise. Value 0 selects the very next (second)
# argument, value 1 selects the one after it, etc. If the value is greater than
# the number of available arguments, the last one (unless it is the only one)
# is selected. If there is only one (the first) alternative available but the
# value is greater than 0, an empty string is returned.
#   Examples:
#     [? 2   | zero | one | two | three ]  -> two
#     [? foo | none | any | two | three ]  -> any
#     [? 24  | 0    | one | many ]         -> many
#     [? 2   |No recipients]               -> (empty string)
#     [? %#R |No recipients|One recipient|%#R recipients]
#     [? %q  |No quarantine|Quarantined as %q]
# Note that a selector macro call can be considered a form of if-then-else,
# except that the 'then' and 'else' parts are swapped!
#
# ITERATOR in its full form takes three arguments (and ignores any extra
# arguments after that):
#     [ %x | body-usually-containing-%x | separator ]
# All iterator's arguments are implicitly quoted, iterator performs its own
# substitutions on provided arguments, as described below. The result of an
# iterator call is a body (the second argument) repeated as many times as
# there are elements in the array denoted by the first argument. In each
# instance of a body all occurrences of a token %x in the body are replaced
# with each consecutive element of the array. Resulting body instances are
# then glued together with a string given as the third argument. The result
# is finally evaluated as any top-level text for possible further expansion.
#
# There are two simplified forms of iterator call:
#     [ body | separator ]
# or  [ body ]
# where missing separator is considered a null string, and a missing formal
# argument name is obtained by looking for the first token of the form %x
# in the body. If there is no formal argument specified (neither explicitly
# nor in the body), the result is an empty string, which is potentially useful
# as a null lexical separator.
#
#   Examples:
#     [%V| ]     a space-separated list of virus names
#
#     [%V|\n]    a newline-separated list of virus names
#
#     [%V|
#     ]          same thing: a newline-separated list of virus names
#
#     [
#         %V]    a list of virus names, each preceeded by NL and spaces
#
#     [ %R |%s --> <%R>|, ]  a comma-space separated list of sender/recipient
#                name pairs where recipient is iterated over the list
#                of recipients. (Only the (first) token %x in the first
#                argument is significant, other characters are ignored.)
#
#     [%V|[%R|%R + %V|, ]|; ]  produce all combinations of %R + %V elements
#
# A combined example:
#     [? %#C |#|Cc: [<%C>|, ]]
#     [? %#C ||Cc: [<%C>|, ]\n]#     ... same thing
# evaluates to an empty string if there are no elements in the %C array,
# otherwise it evaluates to a line:  Cc: <addr1>, <addr2>, ...\n
# The '#' removes input characters until and including newline after it.
# It can be used for clarity to allow newlines be placed in the source text
# but not resulting in empty lines in the expanded text. In the second example
# above, a backslash at the end of the line would achieve the same result,
# although the method is different: \NEWLINE is removed during initial lexical
# analysis, while # is an internal macro which, when called, actively discards
# tokens following it, until NEWLINE (or end of input) is encountered.
# Whitespace (including newlines) around the first argument %#C of selector
# call is ignored and can be used for clarity.
#
# These all produce the same result:
#     To: [%T|%T|, ]
#     To: [%T|, ]
#     To: %T
#
# See further practical examples in the supplied notification messages;
# see also README.customize file.
#
#   Author: Mark Martinec <Mark.Martinec@ijs.si>, 2002
#
sub expand($$) {
  my($str_ref)       = shift;  # a ref to a source string to be macro expanded;
  my($builtins_href) = shift;  # a hashref, mapping builtin macro names (single
                               # char) to macro values: strings or array refs
  my($lex_lbr, $lex_lbrq, $lex_rbr, $lex_sep, $lex_h) =
    \('[', '[?', ']', '|', '#');  # lexical elements to be used as references
  my(%lexmap);  # maps string to reference in order to protect lexels
  for (keys(%$builtins_href))
    { $lexmap{"%$_"} = \"%$_"; $lexmap{"%#$_"} = \"%#$_" }
  for ($lex_lbr, $lex_lbrq, $lex_rbr, $lex_sep, $lex_h) { $lexmap{$$_} = $_ }
  # parse lexically
  my(@tokens) = $$str_ref =~ /\G \# | \[\?? | [\]|] | % \#? . | \\ [^0-7] |
                          \\ [0-7]{1,3} | [^\[\]\\|%\n#]+ | [^\n]+? | \n /gcsx;
  # replace lexical element strings with object references,
  # unquote backslash-quoted characters and %%, and drop backslash-newlines
  my(%esc) = (r => "\r", n => "\n", f => "\f", b => "\b",
              e => "\e", a => "\a", t => "\t");
  for (@tokens) {
    if (exists $lexmap{$_}) { $_ = $lexmap{$_} }       # replace with refs
    elsif ($_ eq "\\\n")    { $_ = '' }                # drop \NEWLINE
    elsif (/^%(%)\z/)       { $_ = $1 }                #  %% -> %
    elsif (/^(%#?.)\z/s)    { $_ = \$1 }               # unknown builtins
    elsif (/^\\([0-7]{1,3})\z/) { $_ = chr(oct($1)) }  # \nnn
    elsif (/^\\(.)\z/s)     { $_ = (exists($esc{$1}) ? $esc{$1} : $1) }
  }
  my($call_level) = 0; my($quote_level) = 0; my(@macro_type, @arg);
  my(%builtins_cached); my($output_str) = ''; my($whereto) = \$output_str;
  while (@tokens) {
    my($t) = shift(@tokens);
    if ($t eq '') {                                    # ignore leftovers
    } elsif ($quote_level>0 && ref($t) && ($t == $lex_lbr || $t == $lex_lbrq)){
      $quote_level++;
      ref($whereto) eq 'ARRAY' ? push(@$whereto, $t) : ($$whereto .= $t);
    } elsif (ref($t) && $t == $lex_lbr) {   # begin iterator macro call
      $quote_level++; $call_level++;
      unshift(@arg, [[]]); unshift(@macro_type, ''); $whereto = $arg[0][0];
    } elsif (ref($t) && $t == $lex_lbrq) {  # begin selector macro call
      $call_level++; unshift(@arg, [[]]); unshift(@macro_type, '');
      $whereto = $arg[0][0]; $macro_type[0] = 'select';
    } elsif ($quote_level > 1 && ref($t) && $t == $lex_rbr) {
      $quote_level--;
      ref($whereto) eq 'ARRAY' ? push(@$whereto, $t) : ($$whereto .= $t);
    } elsif ($call_level > 0 && ref($t) && $t == $lex_sep) {  # next argument
      if ($quote_level == 0 && $macro_type[0] eq 'select' && @{$arg[0]} == 1) {
        $quote_level++;
      }
      if ($quote_level == 1) {
        unshift(@{$arg[0]}, []); $whereto = $arg[0][0];  # begin next arg
      } else {
        ref($whereto) eq 'ARRAY' ? push(@$whereto, $t) : ($$whereto .= $t);
      }
    } elsif ($quote_level > 0 && ref($t) && $t == $lex_rbr) {
      $quote_level--;  # quote level just dropped to 0, this is now a call
      $call_level--  if $call_level > 0;
      my(@result);
      if ($macro_type[0] eq 'select') {
        my($sel, @alternatives) = reverse @{$arg[0]};  # list of refs
        # turn reference into a string, avoid warnings about uninitialized val.
        $sel = !ref($sel) ? '' : join('', map {defined $_ ? $_ : ''} @$sel);
        if    ($sel =~ /^\s*\z/)         { $sel = 0 }
        elsif ($sel =~ /^\s*(\d+)\s*\z/) { $sel = 0+$1 }  # make numeric
        else { $sel = 1 }
        # provide an empty second alternative if we only have one specified
        push(@alternatives, [])  if @alternatives < 2 && $sel > 0;
        if ($sel < 0) { $sel = 0 }
        elsif ($sel > $#alternatives) { $sel = $#alternatives }
        @result = @{$alternatives[$sel]};
      } else {                                         # iterator
        my($cvar_r, $sep_r, $body_r, $cvar);  # give meaning to arguments
        if (@{$arg[0]} >= 3) { ($cvar_r,$body_r,$sep_r) = reverse @{$arg[0]} }
        else { ($body_r, $sep_r) = reverse @{$arg[0]}; $cvar_r = $body_r }
        # find the formal argument name (iterator)
        for (@$cvar_r) {
          if (ref && $$_ =~ /^%(.)\z/s) { $cvar = $1; last }
        }
        if (exists($builtins_href->{$cvar})) {
          my($values_r);
          if (exists($builtins_cached{$cvar})) {
            $values_r = $builtins_cached{$cvar};
          } else {
            $values_r = $builtins_href->{$cvar};
            while (ref($values_r) eq 'CODE') { $values_r = &$values_r }
            $builtins_cached{$cvar} = $values_r;
          }
          $values_r = [$values_r]  if !ref($values_r);
          my($ind);
          my($re) = qr/^%\Q$cvar\E\z/;
          for my $val (@$values_r) {
            push(@result, @$sep_r)  if ++$ind > 1 && ref($sep_r);
            push(@result, map { (ref && $$_ =~ /$re/) ? $val : $_ } @$body_r);
          }
        }
      }
      shift(@macro_type);  # pop the call stack
      shift(@arg);
      $whereto = $call_level > 0 ? $arg[0][0] : \$output_str;
      unshift(@tokens, @result);  # active macro call, evaluate result
    } else {  # quoted, plain string, simple macro call, or a misplaced token
      my($s) = '';
      if ($quote_level > 0 || !ref($t)) {
        $s = $t;  # quoted or string
      } elsif ($t == $lex_h) {  # discard tokens to (and including) newline
        while (@tokens) { last  if shift(@tokens) eq "\n" }
      } elsif ($$t =~ /^%(\#)?(.)\z/s) {  # macro call  %#x or %x
        my($num,$m) = ($1,$2);
        if (!exists($builtins_href->{$m})) { $s = '' }  # no such
        elsif (exists($builtins_cached{$m})) { $s = $builtins_cached{$m} }
        else {
          $s = $builtins_href->{$m};
          while (ref($s) eq 'CODE') { $s = &$s }  # subroutine callback
          $builtins_cached{$m} = $s;
        }
        if (defined $num && $num eq '#') {  # macro call form %#x
          # for array: number of elements; for scalar: nonwhite=1, other 0
          $s = ref($s) ? @$s : $s !~ /^\s*\z/ ? 1 : 0;
        } else {  # macro call %x evaluates to the value of macro x
          $s = join(', ', @$s)  if ref $s;
        }
      } else { $s = $$t }  # misplaced token, e.g. a top level | or ]
      ref($whereto) eq 'ARRAY' ? push(@$whereto, $s) : ($$whereto .= $s);
    }
  }
  \$output_str;
}

1;

#
package Amavis::IO::Zlib;

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

use strict;
use re 'taint';

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

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

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

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

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

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

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

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

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

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

1;

#
package Amavis::In::Connection;

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

use strict;
use re 'taint';

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

sub new
  { my($class) = @_; bless {}, $class }
sub client_ip       # client IP address (immediate SMTP client, i.e. our MTA)
  { my($self)=shift; !@_ ? $self->{client_ip} : ($self->{client_ip}=shift) }
sub socket_ip       # IP address of our interface that received connection
  { my($self)=shift; !@_ ? $self->{socket_ip} : ($self->{socket_ip}=shift) }
sub socket_port     # TCP port of our interface that received connection
  { my($self)=shift; !@_ ? $self->{socket_port}:($self->{socket_port}=shift) }
sub proto           # TCP/UNIX
  { my($self)=shift; !@_ ? $self->{proto}     : ($self->{proto}=shift) }
sub smtp_proto      # SMTP/ESMTP(A|S|SA)/LMTP(A|S|SA) # rfc3848, or QMQP/QMQPqq
  { my($self)=shift; !@_ ? $self->{smtp_proto}: ($self->{smtp_proto}=shift) }
sub smtp_helo       # (E)SMTP HELO/EHLO parameter
  { my($self)=shift; !@_ ? $self->{smtp_helo} : ($self->{smtp_helo}=shift) }

1;

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

use strict;
use re 'taint';

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

# per-recipient data are kept in an array of n-tuples:
#   (recipient-address, destiny, done, smtp-response-text, remote-mta, ...)
sub new     # NOTE: this class is a list for historical reasons, not a hash
  { my($class) = @_; bless [(undef) x 15], $class }

# subs to set or access individual elements of a n-tuple by name
sub recip_addr       # raw (unquoted) recipient envelope e-mail address
  { my($self)=shift; !@_ ? $$self[0] : ($$self[0]=shift) }
sub recip_addr_modified  # recip. addr. with possible addr. extension inserted
  { my($self)=shift; !@_ ? $$self[1] : ($$self[1]=shift) }
sub recip_destiny    # D_REJECT, D_BOUNCE, D_DISCARD, D_PASS
  { my($self)=shift; !@_ ? $$self[2] : ($$self[2]=shift) }
sub recip_done       # false: not done, true: done (1: faked, 2: truly sent)
  { my($self)=shift; !@_ ? $$self[3] : ($$self[3]=shift) }
sub recip_smtp_response # rfc2821 response (3-digit + enhanced resp + text)
  { my($self)=shift; !@_ ? $$self[4] : ($$self[4]=shift) }
sub recip_remote_mta_smtp_response  # smtp response as issued by remote MTA
  { my($self)=shift; !@_ ? $$self[5] : ($$self[5]=shift) }
sub recip_remote_mta # remote MTA that issued the smtp response
  { my($self)=shift; !@_ ? $$self[6] : ($$self[6]=shift) }
sub recip_mbxname    # mailbox name or file when known (local:, bsmtp: or sql:)
  { my($self)=shift; !@_ ? $$self[7] : ($$self[7]=shift) }
sub recip_whitelisted_sender  # recip considers this sender whitelisted (> 0)
  { my($self)=shift; !@_ ? $$self[8] : ($$self[8]=shift) }
sub recip_blacklisted_sender  # recip considers this sender blacklisted
  { my($self)=shift; !@_ ? $$self[9] : ($$self[9]=shift) }
sub recip_score_boost  # recip adds penalty spam points to the final score
  { my($self)=shift; !@_ ? $$self[10] : ($$self[10]=shift) }
sub infected        # contains a virus (1); check bypassed (undef); clean (0)
  { my($self)=shift; !@_ ? $$self[11] : ($$self[11]=shift) }
sub banned_parts    # banned part descriptions (ref to a list of banned parts)
  { my($self)=shift; !@_ ? $$self[12] : ($$self[12]=shift) }
sub banned_keys     # keys of matching banned rules (a ref to a list)
  { my($self)=shift; !@_ ? $$self[13] : ($$self[13]=shift) }
sub banned_rhs      # right-hand side of matching rules (a ref to a list)
  { my($self)=shift; !@_ ? $$self[14] : ($$self[14]=shift) }

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

1;

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

use strict;
use re 'taint';

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

BEGIN {
  import Amavis::Conf qw(:platform);
  import Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp);
  import Amavis::In::Message::PerRecip;
}

sub new
  { my($class) = @_; bless {}, $class }
sub rx_time         # Unix time (s since epoch) of message reception by amavisd
  { my($self)=shift; !@_ ? $self->{rx_time}    : ($self->{rx_time}=shift) }
sub client_addr     # original client IP addr, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_ip} : ($self->{cli_ip}=shift) }
sub client_name     # orig. client DNS name, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_name} : ($self->{cli_name}=shift) }
sub client_proto     # orig. client protocol, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_proto} : ($self->{cli_proto}=shift) }
sub client_helo     # orig. client EHLO name, obtained from XFORWARD or milter
  { my($self)=shift; !@_ ? $self->{cli_helo} : ($self->{cli_helo}=shift) }
sub queue_id        # MTA queue ID of message if known (Courier, milter/AM.PDP)
  { my($self)=shift; !@_ ? $self->{queue_id}   : ($self->{queue_id}=shift) }
sub mail_id         # some long-term unique id of the message on this system
  { my($self)=shift; !@_ ? $self->{mail_id}    : ($self->{mail_id}=shift) }
sub secret_id       # secret string to grant access to message with mail_id
  { my($self)=shift; !@_ ? $self->{secret_id}  : ($self->{secret_id}=shift) }
sub msg_size        # ESMTP SIZE value, later corrected by actual message size
  { my($self)=shift; !@_ ? $self->{msg_size}   : ($self->{msg_size}=shift) }
sub auth_user       # ESMTP AUTH username
  { my($self)=shift; !@_ ? $self->{auth_user}  : ($self->{auth_user}=shift) }
sub auth_pass       # ESMTP AUTH password
  { my($self)=shift; !@_ ? $self->{auth_pass}  : ($self->{auth_pass}=shift) }
sub auth_submitter  # ESMTP MAIL command AUTH option value (addr-spec or "<>")
  { my($self)=shift; !@_ ? $self->{auth_subm}  : ($self->{auth_subm}=shift) }
sub requested_by    # Resent-From addr who requested release from a quarantine
  { my($self)=shift; !@_ ? $self->{requested_by}:($self->{requested_by}=shift)}
sub body_type       # ESMTP BODY param (rfc1652: 7BIT, 8BITMIME) or BINARYMIME
  { my($self)=shift; !@_ ? $self->{body_type}  : ($self->{body_type}=shift) }
sub sender          # envelope sender
  { my($self)=shift; !@_ ? $self->{sender}     : ($self->{sender}=shift) }
sub sender_contact  # unmangled sender address or undef (e.g. believed faked)
  { my($self)=shift; !@_ ? $self->{sender_c}   : ($self->{sender_c}=shift) }
sub sender_source   # unmangled sender address or info from the trace
  { my($self)=shift; !@_ ? $self->{sender_src} : ($self->{sender_src}=shift) }
sub mime_entity     # MIME::Parser entity holding the message
  { my($self)=shift; !@_ ? $self->{mime_entity}: ($self->{mime_entity}=shift)}
sub parts_root      # Amavis::Unpackers::Part root object
  { my($self)=shift; !@_ ? $self->{parts_root}:  ($self->{parts_root}=shift)}
sub mail_text       # rfc2822 msg: (open) file handle, or MIME::Entity object
  { my($self)=shift; !@_ ? $self->{mail_text}  : ($self->{mail_text}=shift) }
sub mail_text_fn    # orig. mail filename or undef, e.g. mail_tempdir/email.txt
  { my($self)=shift; !@_ ? $self->{mail_text_fn} : ($self->{mail_text_fn}=shift) }
sub mail_tempdir    # work directory, under $TEMPBASE or supplied by client
  { my($self)=shift; !@_ ? $self->{mail_tempdir} : ($self->{mail_tempdir}=shift) }
sub header_edits    # Amavis::Out::EditHeader object or undef
  { my($self)=shift; !@_ ? $self->{hdr_edits}  : ($self->{hdr_edits}=shift) }
sub orig_header     # original header - an arrayref of lines, with trailing LF
  { my($self)=shift; !@_ ? $self->{orig_header}: ($self->{orig_header}=shift) }
sub orig_header_size # size of original header
  { my($self)=shift; !@_ ? $self->{orig_hdr_s} : ($self->{orig_hdr_s}=shift) }
sub orig_body_size  # size of original body
  { my($self)=shift; !@_ ? $self->{orig_bdy_s} : ($self->{orig_bdy_s}=shift) }
sub body_digest     # message digest of a message body (e.g. MD5 or SHA1)
  { my($self)=shift; !@_ ? $self->{body_digest}: ($self->{body_digest}=shift) }
sub quarantined_to  # list of quarantine mailbox names or addresses if quarantined
  { my($self)=shift; !@_ ? $self->{quarantine} : ($self->{quarantine}=shift) }
sub quar_type     # quarantine type: F/Z/B/Q/M (file/zipfile/bsmtp/sql/mailbox)
  { my($self)=shift; !@_ ? $self->{quar_type}  : ($self->{quar_type}=shift) }
sub dsn_sent        # delivery status notification was sent(1) or faked(2)
  { my($self)=shift; !@_ ? $self->{dsn_sent}   : ($self->{dsn_sent}=shift) }
sub delivery_method # delivery method, or empty for implicit delivery (milter)
  { my($self)=shift; !@_ ? $self->{delivery_method}:($self->{delivery_method}=shift)}
sub client_delete   # don't delete the tempdir, it is a client's reponsibility
  { my($self)=shift; !@_ ? $self->{client_delete}:($self->{client_delete}=shift)}
# credativ -jw
sub postfixid       # the original postfix queue id
  { my($self)=shift; !@_ ? $self->{postfixid}  : ($self->{postfixid}=shift) }
# credativ end

# The order of entries in the list is the original order in which
# recipient addresses (e.g. obtained via 'MAIL TO:') were received.
# Only the entries that were accepted (via SMTP response code 2xx)
# are placed in the list. The ORDER MUST BE PRESERVED and no recipients
# may be added or removed from the list! This is vital to be able
# to produce correct per-recipient responses to a LMTP client!
#
sub per_recip_data {  # get or set a listref of envelope recipient n-tuples
  my($self) = shift;
  # store a given listref of n-tuples (originals, not copies!)
  if (@_) { @{$self->{recips}} = @{$_[0]} }
  # return a listref to the original n-tuples,
  # caller may modify the data if he knows what he is doing
  $self->{recips};
}

sub recips {           # get or set a listref of envelope recipients
  my($self)=shift;
  if (@_) {  # store a copy of a given listref of recipient addresses
    # wrap scalars (strings) into n-tuples
    $self->per_recip_data([ map {
      my($per_recip_obj) = Amavis::In::Message::PerRecip->new;
      $per_recip_obj->recip_addr($_);
      $per_recip_obj->recip_destiny(D_PASS);  # default is Pass
      $per_recip_obj } @{$_[0]} ]);
  }
  return  if !defined wantarray;  # don't bother
  # return listref of recipient addresses
  [ map { $_->recip_addr } @{$self->per_recip_data} ];
}

1;

#
package Amavis::Out::EditHeader;

# Accumulates instructions on what lines need to be added to the message
# header, deleted, or how to change existing lines, then via a call
# to write_header() performs these edits on the fly.

use strict;
use re 'taint';

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

BEGIN {
  import Amavis::Conf qw(:platform c cr ca);
  import Amavis::Timing qw(section_time);
  import Amavis::Util qw(ll do_log safe_encode q_encode);
}
use MIME::Words;

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

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

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

sub delete_header($$) {
  my($self, $field_name) = @_;
  $self->{edit}{lc($field_name)} = undef;
}

sub edit_header($$$;$) {
  my($self, $field_name, $field_edit_sub, $structured) = @_;
  # $field_edit_sub will be called with 2 args: field name and field body;
  # it should return the replacement field body (no field name and colon),
  # with or without the trailing NL
  !defined($field_edit_sub) || ref($field_edit_sub) eq 'CODE'
    or die "edit_header: arg#3 must be undef or a subroutine ref";
  $self->{edit}{lc($field_name)} = $field_edit_sub;
}

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

# Insert space after colon if not present, RFC2047-encode if field body
# contains non-ASCII characters, fold long lines if needed,
# prepend space before each NL if missing, append NL if missing;
# Header fields with only spaces are not allowed.
# (rfc2822: Each line of characters MUST be no more than 998 characters,
# and SHOULD be no more than 78 characters, excluding the CRLF.
# '$structured' indicates that folding is only allowed at positions
# indicated by \n in the provided header body.
#
sub hdr($$;$) {
  my($field_name, $field_body, $structured) = @_;
  if ($field_name =~ /^(X-.*|Subject|Comments)\z/si &&
      $field_body =~ /[^\011\012\040-\176]/ #any nonprintable except TAB and LF
  ) { # encode according to RFC 2047
    $field_body =~ s/\n([ \t])/$1/g;  # unfold
    chomp($field_body);
    my($field_body_octets) = safe_encode(c('hdr_encoding'), $field_body);
    my($qb) = c('hdr_encoding_qb');
    if (uc($qb) eq 'Q') {
      $field_body = q_encode($field_body_octets, $qb, c('hdr_encoding'));
    } else {
      $field_body = MIME::Words::encode_mimeword($field_body_octets,
                                                 $qb, c('hdr_encoding'));
    }
  } else {  # supposed to be in plain ASCII, let's make sure it is
    $field_body = safe_encode('ascii', $field_body);
  }
  $field_name = safe_encode('ascii', $field_name);
  my($str) = $field_name . ':';
  $str .= ' '  if $field_body !~ /^[ \t]/;
  $str .= $field_body;
  $str =~ s/\n([^ \t\n])/\n $1/g;  # insert a space at line folds if missing
  $str =~ s/\n([ \t]*\n)+/\n/g;    # remove empty lines
  chomp($str);                     # chop off trailing NL if present
  if ($structured) {
    $str =~ s/[ \t]+/ /g;       # collapse spaces and tabs to a single space
    my(@sublines) = split(/\n/, $str, -1);
    $str = ''; my($s) = ''; my($s_l) = 0; my($s_il)=0;
    for (@sublines) {              # join shorter field sections
      if ($s !~ /^\s*\z/ && $s_l + $s_il + length($_) > 78) {
        $s_il = 8; # length of the initial tab
        $str .= "\n\t"  if $str ne '';
        $s =~ s/^[ \t]+//g; # remove leading and trailing whitespace
        $s =~ s/[ \t]+$//g;
        $str .= $s; $s = ''; $s_l = 0;
      }
      $s .= $_; $s_l += length($_);
    }
    if ($s !~ /^\s*\z/) {
      $str .= "\n\t"  if $str ne '';
      $s =~ s/^[ \t]+//g; # remove leading and trailing whitespace
      $s =~ s/[ \t]+$//g;
      $str .= $s;
    }
  } elsif (length($str) > 998) {
    # truncate the damn thing (to be done better)
    $str = substr($str,0,998);
  }
  $str .= "\n";  # append final NL
  do_log(5, "header: $str");
  $str;
}

# Copy mail header to the supplied method (line by line) while adding,
# removing, or changing certain header lines as required, and append
# an empty line (end-of-header). Returns number of original 'Received:'
# header fields to make simple loop detection possible (as required
# by rfc2821 section 6.2).
#
# Assumes input file is properly positioned, leaves it positioned
# at the beginning of the body.
#
sub write_header($$$) {
  my($self, $msg, $out_fh) = @_;
  my($is_mime) = ref($msg) && $msg->isa('MIME::Entity') ? 1 : 0;
  do_log(5,"write_header: $is_mime, $out_fh");
  $out_fh = IO::Wrap::wraphandle($out_fh);  # assure an IO::Handle-like obj
  my(@header);
  if ($is_mime) {
    @header = map { /^[ \t]*\n?\z/ ? ()   # remove empty lines, ensure NL
                                 : (/\n\z/ ? $_ : $_ . "\n") } @{$msg->header};
  }
  my($received_cnt) = 0; my($str) = '';
  for (@{$self->{prepend}}) { $str .= $_ }
  if ($str ne '') { $out_fh->print($str) or die "sending mail header1: $!" }
  if (!defined($msg)) {
    # existing header empty
  } else {
    push(@header, $eol)  if $is_mime;  # append empty line as end-of-header
    local($1,$2); my($curr_head,$next_head); my($illcnt) = 0; undef $!;
    while (defined($next_head = $is_mime ? shift @header : $msg->getline)) {
      if ($next_head =~ /^[ \t]/) { $curr_head .= $next_head }  # folded
      else {                                                    # new header
        if (!defined($curr_head)) {  # no previous complete header field
        } elsif ($curr_head !~ /^([!-9;-\176]+)[ \t]*:(.*)\z/s) {
          # invalid header, but we don't care
          $curr_head =~ s{\n [ \t]* (?= \n )}{}gsx  and $illcnt++;
          $out_fh->print($curr_head) or die "sending mail header4: $!";
        } else {                     # count, edit, or delete
            # obsolete rfc822 syntax allowed whitespace before colon
          my($field_name, $field_body) = ($1, $2);
          my($field_name_lc) = lc($field_name);
          $received_cnt++  if $field_name_lc eq 'received';
          if (!exists($self->{edit}{$field_name_lc})) { # unchanged
            # unfold illegal all-whitespace continuation lines
            $curr_head =~ s{\n [ \t]* (?= \n )}{}gsx  and $illcnt++;
            $out_fh->print($curr_head) or die "sending mail header5: $!";
          } else {
            my($edit) = $self->{edit}{$field_name_lc};
            if (defined($edit)) {    # edit, not delete
              chomp($field_body);
              ### $field_body =~ s/\n([ \t])/$1/g;   # unfold
              my($subst) = hdr($field_name, &$edit($field_name,$field_body));
              $subst =~ s{\n [ \t]* (?= \n )}{}gsx  and $illcnt++;
              $out_fh->print($subst) or die "sending mail header6: $!";
            }
          }
        }
        last  if $next_head eq $eol;  # end-of-header reached
        $curr_head = $next_head;
      }
      undef $!;
    }
    defined $next_head || $is_mime || $!==0
      or die "Error reading mail header: $!";
    do_log(0, "INFO: unfolded $illcnt illegal all-whitespace ".
              "continuation lines")  if $illcnt;
  }
  $str = '';
  for (@{$self->{append}}) { $str .= $_ }
  $str .= $eol;  # end of header - separator line
  $out_fh->print($str) or die "sending mail header7: $!";
  section_time('write-header');
  $received_cnt;
}
1;

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

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

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

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

use subs @EXPORT_OK;

# Deliver to local mailboxes only, ignore the rest: either to directory
# (maildir style), or file (Unix mbox).  (normally used as a quarantine method)
#
sub mail_to_local_mailbox(@) {
  my($via, $msginfo, $initial_submission, $filter) = @_;
  $via =~ /^local:(.*)\z/si or die "Bad local method: $via";
  my($via_arg) = $1;
  my(@per_recip_data) = grep { !$_->recip_done && (!$filter || &$filter($_)) }
                             @{$msginfo->per_recip_data};
  return 1  if !@per_recip_data;
  my($msg) = $msginfo->mail_text;      # a file handle or a MIME::Entity object
  if (defined($msg) && !$msg->isa('MIME::Entity')) {
    # at this point, we have no idea what the user gave us...
    # a globref? a FileHandle?
    $msg = IO::Wrap::wraphandle($msg); # now we have an IO::Handle-like obj
  }
  my($sender) = $msginfo->sender;
  for my $r (@per_recip_data) {
    # each recipient gets its own copy; these are not the original recipients
    my($recip) = $r->recip_final_addr;
    next  if $recip eq '';
    my($localpart,$domain) = split_address($recip);
    my($smtp_response);

    # %local_delivery_aliases emulates aliases map - this would otherwise
    # be done by MTA's local delivery agent if we gave the message to MTA.
    # This way we keep interface compatible with other mail delivery
    # methods. The hash value may be a ref to a pair of fixed strings,
    # or a subroutine ref (which must return such pair) to allow delayed
    # (lazy) evaluation when some part of the pair is not yet known
    # at initialization time.
    # If no matching entry is found, the key ($localpart) is treated as
    # a mailbox filename if nonempty, or else quarantining is skipped.

    my($mbxname, $suggested_filename);
    { # a block is used as a 'switch' statement - 'last' will exit from it
      my($ldar) = cr('local_delivery_aliases');  # a ref to a hash
      my($alias) = $ldar->{$localpart};
      if (ref($alias) eq 'ARRAY') {
        ($mbxname, $suggested_filename) = @$alias;
      } elsif (ref($alias) eq 'CODE') {  # lazy (delayed) evaluation
        ($mbxname, $suggested_filename) = &$alias;
      } elsif ($alias ne '') {
        ($mbxname, $suggested_filename) = ($alias, undef);
      } elsif (!exists $ldar->{$localpart}) {
        do_log(0, "no key '$localpart' in \%local_delivery_aliases, skip local delivery");
      }
      if ($mbxname eq '') {
        my($why) = !exists $ldar->{$localpart} ? 1 : $alias eq '' ? 2 : 3;
        do_log(2, "skip local delivery($why): <$sender> -> <$recip>");
        $smtp_response = "250 2.6.0 Ok, skip local delivery($why)";
        last;   # exit block, not the loop
      }
      my($ux);  # is it a UNIX-style mailbox?
      if (!-d $mbxname) {  # assume a filename (need not exist yet)
        $ux = 1;           # $mbxname is a UNIX-style mailbox (one file)
      } else {             # a directory
        $ux = 0;  # $mbxname is a directory (amavis/maildir style mailbox)
        my($explicitly_suggested_filename) = $suggested_filename ne '';
        if ($suggested_filename eq '')
          { $suggested_filename = $via_arg ne '' ? $via_arg : '%m' }
        $suggested_filename =~ s{%(.)}
          {  $1 eq 'b' ? $msginfo->body_digest
           : $1 eq 'm' ? $msginfo->mail_id
           : $1 eq 'i' ? iso8601_timestamp($msginfo->rx_time,1,'-')
           : $1 eq 'n' ? am_id()
           : $1 eq '%' ? '%' : '%'.$1 }egs;
        $mbxname = "$mbxname/$suggested_filename";
        if ($quarantine_subdir_levels>=1 && !$explicitly_suggested_filename) {
          # using a subdirectory structure to disperse quarantine files
          local($1,$2); my($subdir) = substr($msginfo->mail_id, 0, 1);
          $subdir=~/^[A-Z0-9]\z/i or die "Unexpected first char: $subdir";
          $mbxname =~ m{^ (.*/)? ([^/]+) \z}sx; my($path,$fname) = ($1,$2);
          $mbxname = "$path$subdir/$fname";  # resulting full filename
          my($errn) = stat("$path$subdir") ? 0 : 0+$!;
          if ($errn == ENOENT) {  # check/prepare a set of subdirectories
            do_log(2, "checking/creating quarantine subdirs under $path");
            for my $d ('A'..'Z','a'..'z','0'..'9') {
              $errn = stat("$path$d") ? 0 : 0+$!;
              if ($errn == ENOENT) {
                mkdir("$path$d", 0750) or die "Can't create dir $path$d: $!";
              }
            }
          }
        }
      }
      do_log(1, "local delivery: <$sender> -> <$recip>, mbx=$mbxname");
      my($mp,$pos,$pid);
      my($errn) = stat($mbxname) ? 0 : 0+$!;
      local $SIG{CHLD} = 'DEFAULT';
      local $SIG{PIPE} = 'IGNORE';  # write to broken pipe would throw a signal
      eval {                        # try to open the mailbox file for writing
        if (!$ux) {  # one mail per file, will create specified file
          if ($errn == ENOENT) {}   # good, no file, as expected
          elsif (!$errn && -f _)
            { die "File $mbxname already exists, refuse to overwrite" }
          else
            { die "File $mbxname exists??? Refuse to overwrite it, $!" }
          if ($mbxname =~ /\.gz\z/) {
            $mp = Amavis::IO::Zlib->new;
            $mp->open($mbxname,'wb')
              or die "Can't create gzip file $mbxname: $!";
          } else {
            $mp = IO::File->new;
            $mp->open($mbxname, O_CREAT|O_EXCL|O_WRONLY, 0640)
              or die "Can't create file $mbxname: $!";
            binmode($mp, ":bytes") or die "Can't cancel :utf8 mode: $!"
              if $unicode_aware;
          }
        } else {  # append to UNIX-style mailbox
                  # deliver only to non-executable regular files
          if ($errn == ENOENT) {
            $mp = IO::File->new;
            $mp->open($mbxname, O_CREAT|O_EXCL|O_WRONLY, 0640)
              or die "Can't create file $mbxname: $!";
          } elsif (!$errn && !-f _) {
            die "Mailbox $mbxname is not a regular file, refuse to deliver";
          } elsif (-x _ || -X _) {
            die "Mailbox file $mbxname is executable, refuse to deliver";
          } else {
            $mp = IO::File->new;
            $mp->open($mbxname,'>>',0640)
              or die "Can't append to $mbxname: $!";
          }
          binmode($mp, ":bytes") or die "Can't cancel