# SPDX-License-Identifier: GPL-2.0-or-later

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

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT = qw(
    &rfc2822_timestamp &rfc2822_utc_timestamp
    &iso8601_timestamp &iso8601_utc_timestamp
    &iso8601_week &iso8601_yearweek &iso8601_year_and_week &iso8601_weekday
    &make_received_header_field &parse_received
    &fish_out_ip_from_received &parse_message_id
    &split_address &split_localpart &replace_addr_fields
    &clear_query_keys_cache &make_query_keys
    &quote_rfc2821_local &qquote_rfc2821_local
    &parse_quoted_rfc2821 &unquote_rfc2821_local &parse_address_list
    &wrap_string &wrap_smtp_resp &one_response_for_all
    &EX_OK &EX_NOUSER &EX_UNAVAILABLE &EX_TEMPFAIL &EX_NOPERM);
}
use subs @EXPORT;

use POSIX qw(locale_h strftime);

use Amavis::Conf qw(:platform c cr ca $myproduct_name);
use Amavis::Util qw(ll do_log unique_ref unique_list
                    safe_encode_utf8_inplace
                    idn_to_ascii idn_to_utf8 mail_addr_idn_to_ascii);

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

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

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

# Given a Unix time, provide date-time timestamp as specified in RFC 5322
# in a UTC time zone. See also RFC 3339 and RFC 6692.
#
sub rfc2822_utc_timestamp($) {
  my $t = $_[0];
  strftime("%a, %e %b %Y %H:%M:%S +0000 (UTC)", gmtime(int($t)));
}

# Given a Unix numeric time (seconds since 1970-01-01T00:00Z),
# provide date-time timestamp (local time) as specified in ISO 8601 (EN 28601)
# RFC 3339 is a subset of ISO 8601 and requires field separators "-" and ":".
#
sub iso8601_timestamp($;$$$) {
  my($t, $suppress_zone, $dtseparator, $with_field_separators) = @_;
  # can't use %z because some systems do not support it (is treated as %Z)
  my $fmt = $with_field_separators ? "%Y-%m-%dT%H:%M:%S" : "%Y%m%dT%H%M%S";
  $fmt =~ s/T/$dtseparator/  if defined $dtseparator;
  my $s = strftime($fmt,localtime(int($t)));
  $s .= get_zone_offset($t)  unless $suppress_zone;
  $s;
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

# For a given email address (e.g. for User+Foo@sub.exAMPLE.CoM)
# prepare and return a list of lookup keys in the following order:
#   User+Foo@sub.exAMPLE.COM   (as-is, no lowercasing, no ToASCII)
#   user+foo@sub.example.com
#   user@sub.example.com (only if $recipient_delimiter nonempty)
#   user+foo(@) (only if $include_bare_user)
#   user(@)     (only if $include_bare_user and $recipient_delimiter nonempty)
#   (@)sub.example.com
#   (@).sub.example.com
#   (@).example.com
#   (@).com
#   (@).
# Another example with EAI and international domain names (IDN):
#   Pingüino@Pájaro.Niño.exAMPLE.COM  (as-is, no lowercasing, no ToASCII)
#   pingüino@xn--pjaro-xqa.xn--nio-8ma.example.com
#   pingüino(@)                       (only if $include_bare_user)
#   (@)xn--pjaro-xqa.xn--nio-8ma.example.com
#   (@).xn--pjaro-xqa.xn--nio-8ma.example.com
#   (@).xn--pjaro-xqa.example.com
#   (@).example.com
#   (@).com
#   (@).
#
# Note about (@): if $at_with_user is true the user-only keys (without domain)
# get an '@' character appended (e.g. 'user+foo@'). Usual for lookup_hash.
# If $at_with_user is false the domain-only (without localpart) keys
# get a '@' prepended (e.g. '@.example.com'). Usual for SQL and LDAP lookups.
#
# The domain part is lowercased and IDN converted to ASCII in all but
# the first item in the resulting list; the localpart is lowercased
# iff $localpart_is_case_sensitive is true. The $addr may be a string
# of octets (assumed to be UTF-8 encoded), or a string of characters.
#
my %query_keys_cache;
sub clear_query_keys_cache() { %query_keys_cache = () }
sub make_query_keys($$$;$) {
  my($addr, $at_with_user, $include_bare_user, $append_string) = @_;
  safe_encode_utf8_inplace($addr);  # to octets (if not already)
  my $query_keys_slot = join("\x00",
                             $at_with_user?1:0, $include_bare_user?1:0,
                             $append_string, $addr);
  if (exists $query_keys_cache{$query_keys_slot}) {
    do_log(5,'query_keys: cached '.$addr);  # concat, knowing it's in octets
    return @{$query_keys_cache{$query_keys_slot}};  # ($keys_ref, $rhs)
  }
  my($localpart, $domain) = split_address($addr);
  my $saved_full_localpart = $localpart;
  $localpart = lc($localpart)  if !c('localpart_is_case_sensitive');
  # chop off leading @, and trailing dots
  local($1);
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  $domain = idn_to_ascii($domain)  if $domain ne '';  # lowercase, ToASCII
  my $extension; my $delim = c('recipient_delimiter');
  if ($delim ne '') {
    ($localpart,$extension) = split_localpart($localpart,$delim);
    # extension includes a delimiter since amavisd-new-2.5.0!
  }
  $extension = ''  if !defined $extension;   # mute warnings
  my($append_to_user,$prepend_to_domain) = $at_with_user ? ('@','') : ('','@');
  my(@keys);  # a list of query keys
  push(@keys, $addr);                        # as is
  push(@keys, $localpart.$extension.'@'.$domain)
    if $extension ne '';                     # user+foo@example.com
  push(@keys, $localpart.'@'.$domain);       # user@example.com
  if ($include_bare_user) {  # typically enabled for local users only
    push(@keys, $localpart.$extension.$append_to_user)
      if $extension ne '';                   # user+foo(@)
    push(@keys, $localpart.$append_to_user); # user(@)
  }
  push(@keys, $prepend_to_domain.$domain);   # (@)sub.example.com
  if ($domain =~ /\[/) {  # don't split address literals
    push(@keys, $prepend_to_domain.'.');     # (@).
  } else {
    my(@dkeys); my $d = $domain;
    for (;;) {            # (@).sub.example.com (@).example.com (@).com (@).
      push(@dkeys, $prepend_to_domain.'.'.$d);
      last  if $d eq '';
      $d = ($d =~ /^([^.]*)\.(.*)\z/s) ? $2 : '';
    }
    @dkeys = @dkeys[$#dkeys-19 .. $#dkeys]  if @dkeys > 20;  # sanity limit
    push(@keys, @dkeys);
  }
  if (defined $append_string && $append_string ne '') {
    $_ .= $append_string  for @keys;
  }
  my $keys_ref = unique_ref(\@keys);  # remove duplicates
  ll(5) && do_log(5,"query_keys: %s", join(', ',@$keys_ref));
  # the rhs replacement strings are similar to what would be obtained
  # by lookup_re() given the following regular expression:
  # /^( ( ( [^\@]*? ) ( \Q$delim\E [^\@]* )? ) (?: \@ (.*) ) )$/xs
  my $rhs = [   # a list of right-hand side replacement strings
    $addr,                  # $1 = User+Foo@Sub.Example.COM
    $saved_full_localpart,  # $2 = User+Foo
    $localpart,             # $3 = user  (lc if localpart_is_case_sensitive)
    $extension,             # $4 = +foo  (lc if localpart_is_case_sensitive)
    $domain,                # $5 = sub.example.com (lowercase, ToASCII)
  ];
  $query_keys_cache{$query_keys_slot} = [$keys_ref, $rhs];
  ($keys_ref, $rhs);
}

# quote_rfc2821_local() quotes the local part of a mailbox address
# (given in internal (unquoted) form), and returns external (quoted)
# mailbox address, as per RFC 5321 (ex RFC 2821).
#
# internal (unquoted) form is used internally by amavis and other mail sw,
# external (quoted) form is used in SMTP commands and in message header section
#
# To re-insert message back via SMTP, the local-part of the address needs
# to be quoted again if it contains reserved characters or otherwise
# does not obey the dot-atom syntax, as specified in RFC 5321 and RFC 6531.
#
sub quote_rfc2821_local($) {
  my $mailbox = $_[0];
  # RFC 5321/RFC 5322: atext: any character except controls, SP, and specials
  # RFC 6531 section 3.3: The definition of <atext> is extended to permit
  # both the RFC 5321 definition and a UTF-8 string.  That string MUST NOT
  # contain any of the ASCII graphics or control characters.
  # RFC 6531: atext     =/ UTF8-non-ascii
  #           qtextSMTP =/ UTF8-non-ascii
  # RFC 6532: UTF8-non-ascii = UTF8-2 / UTF8-3 / UTF8-4
  # RFC 3629 section 4: Syntax of UTF-8 Byte Sequences
  # non-atext: [\x00-\x20"(),.:;<>@\[\]\\\x7F]
  my $atext = "a-zA-Z0-9!\#\$%&'*/=?^_`{|}~+-";
  # my $specials = '()<>\[\]\\\\@:;,."';
  # HTML5 - 4.10.5.1.5 E-mail state (type=email):
  #   email = 1*( atext / "." ) "@" label *( "." label )
  #   i.e. localpart is: [a-zA-Z0-9.!#$%&'*+/=?^_`{|}~-]+
  my($localpart,$domain) = split_address($mailbox);
  if ($localpart =~ /^[$atext]+(?:\.[$atext]+)*\z/so) {
    # plain RFC 5321 dot-atom, no need for quoting
  } elsif ($localpart =~ /[\x80-\xBF\xC2-\xF4]/s &&  # triage, RFC 3629
           $localpart =~ /^ ( [$atext] |
                              [\xC2-\xDF][\x80-\xBF]{1} |
                              [\xE0-\xEF][\x80-\xBF]{2} |
                              [\xF0-\xF4][\x80-\xBF]{3}
                            )+
                            ( \. ( [$atext] |
                                   [\xC2-\xDF][\x80-\xBF]{1} |
                                   [\xE0-\xEF][\x80-\xBF]{2} |
                                   [\xF0-\xF4][\x80-\xBF]{3}
                                 )+
                            )* \z/xso) {
    # Extended RFC 6531 UTF-8 atext / dot-atom, no need for quoting.
    # The \xC0 and \xC1 could only be used for overlong encoding of basic
    # ASCII characters. Tolerate other non-shortest UTF-8 encodings here.
    # UTF-8 is restricted by RFC 3629 to end at U+10FFFF, this removed
    # all 5- and 6-byte sequences, and about half of the 4-byte sequences.
    # The RFC 5198 also prohibits "C1 Controls" (U+0080 through U+009F)
    # (i.e. in UTF-8: C2 80 .. C2 9F) for Net-Unicode.
  } else {  # needs quoting or is invalid
    local($1);  # qcontent = qtext / quoted-pair
    $localpart =~ s{ ( ["\\] ) }{\\$1}xgs;
    $localpart = '"'.$localpart.'"';  # non-qtext, make it a qcontent
#   Postfix hates  ""@domain  but is not so harsh on  @domain
#   Late breaking news: don't bother, both forms are rejected by Postfix
#   when strict_rfc821_envelopes=yes, and both are accepted otherwise
  }
  # we used to strip off empty domain (just '@') unconditionally, but this
  # leads Postfix to interpret an address with a '@' in the quoted local part
  # e.g. <"h@example.net"@> as <hhh@example.net> (subject to Postfix setting
  # 'resolve_dequoted_address'), which is not what the sender requested;
  # we no longer do that if localpart contains an '@':
  $domain = ''  if $domain eq '@' && $localpart =~ /\@/;
  $localpart . $domain;
}

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

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

# unquote_rfc2821_local() strips away the quoting from the local part
# of an external (quoted) mailbox address, and returns internal (unquoted)
# mailbox address, as per RFC 5321 (ex RFC 2821).
# Internal (unquoted) form is used internally by amavis and other mail sw,
# external (quoted) form is used in SMTP commands and in message header section
#
sub unquote_rfc2821_local($) {
  my $mailbox = $_[0];
  my($source_route,$localpart,$domain) = parse_quoted_rfc2821($mailbox,1);
  # make address with '@' in the localpart but no domain (like <"aa@bb.com"> )
  # distinguishable from <aa@bb.com> by representing it as aa@bb.com@ in
  # unquoted form; (it still obeys all regular rules, it is not a dirty trick)
  $domain = '@'  if $domain eq '' && $localpart ne '' && $localpart =~ /\@/;
  $localpart . $domain;
}

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

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

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

# wrap an SMTP response at each \n char according to RFC 5321 (ex RFC 2821),
# returning resulting lines as a listref
#
sub wrap_smtp_resp($) {
  my $resp = $_[0];
  # RFC 5321 section 4.5.3.1.5: The maximum total length of a
  # reply line including the reply code and the <CRLF> is 512 octets.
  # More information may be conveyed through multiple-line replies.
  my $max_len = 512-2; my(@result_list); local($1,$2,$3,$4);
  if ($resp !~ /^ ([1-5]\d\d) (\ |-|\z)
                ([245] \. \d{1,3} \. \d{1,3} (?: \ |\z) )?
                (.*) \z/xs)
    { die "wrap_smtp_resp: bad SMTP response code: '$resp'" }
  my($resp_code,$more,$enhanced,$tail) = ($1,$2,$3,$4);
  my $lead_len = length($resp_code) + 1 + length($enhanced);
  while (length($tail) > $max_len-$lead_len || $tail =~ /\n/) {
    # RFC 2034: When responses are continued across multiple lines
    # the same status code must appear at the beginning of the text
    # in each line of the response.
    my $head = substr($tail, 0, $max_len-$lead_len);
    if ($head =~ /^([^\n]*\n)/s) { $head = $1 }
    $tail = substr($tail,length($head)); chomp($head);
    push(@result_list, $resp_code.'-'.$enhanced.$head);
  }
  push(@result_list, $resp_code.' '.$enhanced.$tail);
  \@result_list;
}

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

1;