| Server IP : 85.214.239.14 / Your IP : 3.145.32.238 Web Server : Apache/2.4.62 (Debian) System : Linux h2886529.stratoserver.net 4.9.0 #1 SMP Tue Jan 9 19:45:01 MSK 2024 x86_64 User : www-data ( 33) PHP Version : 7.4.18 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals,pcntl_unshare, MySQL : OFF | cURL : OFF | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : OFF Directory : /proc/3/root/proc/2/task/2/root/proc/2/root/usr/share/perl5/Amavis/ |
Upload File : |
# 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
"e_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;