pflogsumm - Produce Postfix MTA logfile summary
-Copyright (C) 1998-2025 by James S. Seymour, Release 1.1.12
+Copyright (C) 1998-2025 by James S. Seymour, Release 1.1.13
=head1 SYNOPSIS
require v5.10.0;
use strict;
use locale;
+use feature 'state';
use Getopt::Long;
use List::Util qw(reduce);
use Time::Local;
my $haveConfigSimple = $@ ? 0 : 1;
my $mailqCmd = "mailq";
-my $release = "1.1.12";
+my $release = "1.1.13";
# Variables and constants used throughout pflogsumm
our (
'verbose-msg-detail' => { type => 'b' },
'verp-mung' => { type => 'i' }, # optional arg
'version' => { type => 'b' },
+ 'zero-fill' => { type => 'b' },
);
# Storage for actual values
if($opts{'debug'}) {
push(@{$qidTracker{$qid}{'status'}}, "\$cmd: $cmd, \$rejSubTyp: $rejSubTyp, --\$msgsRcvd");
++$qidTracker{$qid}{'lateRejects'};
+ print STDERR "dbg: late reject \$rcvdMsg{$qid}{'size'}: $rcvdMsg{$qid}{'size'}\n" if $rcvdMsg{$qid}{'size'};
}
--$msgsRcvd; # Late Reject: It will have already been counted as "Received," even though it ultimately is not
} elsif($rejSubTyp eq "warning") {
} elsif($cmd eq 'master') {
++$masterMsgs{(split(/^.*master.*: /, $logRmdr))[1]};
} elsif($cmd eq 'smtpd' || $cmd eq 'postscreen') {
- if((my $clientInfo = $logRmdr) =~ /\[\d+\]: \w+: client=(.+?)(?:,|$)/) {
+ if((my ($clientInfo)) = $logRmdr =~ /\[\d+\]: \w+: client=(.+?)(?:,|$)/) {
#
# Warning: this code in two places!
#
if($opts{'debug'}) {
push(@{$qidTracker{$qid}{'status'}}, "\$cmd: $cmd, \$rejSubTyp: $rejSubTyp, --\$msgsRcvd");
++$qidTracker{$qid}{'lateRejects'};
+ print STDERR "dbg: late reject \$rcvdMsg{$qid}{'size'}: $rcvdMsg{$qid}{'size'}\n" if $rcvdMsg{$qid}{'size'};
}
--$msgsRcvd # Late reject: It's been counted as received already
}
$addr = verp_mung($addr);
$addr = srs_mung($addr);
} else {
- $addr = "from=<>"
+ $addr = "from=<>";
}
$rcvdMsg{$qid}{'size'} = $size;
push(@{$msgDetail{$qid}}, $addr) if($opts{'extended-detail'});
# Avoid counting forwards
if($rcvdMsg{$qid}{'whence'}) {
# Get the domain out of the sender's address. If there is
- # none: Use the client domain/IP-address
+ # none (e.g.: "from=<>"): Use the client domain/IP-address
my $domAddr;
- unless((($domAddr = $addr) =~ s/^[^@]+\@(.+)$/$1/) == 1) {
- $domAddr = $rcvdMsg{$qid}{'whence'} eq "pickup"? $addr : $rcvdMsg{$qid}{'whence'};
+ if($addr eq 'from=<>' || ($domAddr = fold_domain($addr)) eq '') {
+ $domAddr = $rcvdMsg{$qid}{'whence'};
}
++$sendgDomCnt
unless(${$sendgDom{$domAddr}}[MSG_CNT_I]);
$addr =~ s/(@.+)/\L$1/ unless($opts{'ignore-case'});
$addr = lc($addr) if($opts{'ignore-case'});
$relay = lc($relay) if($opts{'ignore-case'});
- (my $domAddr = $addr) =~ s/^[^@]+\@//; # get domain only
+ my $domAddr = fold_domain($addr); # get domain only
if($status eq 'sent') {
# was it actually forwarded, rather than delivered?
- if((my $newQid) = ($toRmdr =~ /\(forwarded as ([^\)]+)\)/)) {
+ if(my ($newQid) = $toRmdr =~ /\(forwarded as ([^\)]+)\)/) {
push(@{$qidTracker{$qid}{'status'}}, "\$cmd: $cmd, \$status: $status, forwarded as new qid $1, ++\$msgsFwdd") if $opts{'debug'};
++$msgsFwdd;
delete($rcvdMsg{$qid}); # We're done with this
my ($deferredReas) = $logRmdr =~ /, status=deferred \(([^\)]+)/;
if(!defined($opts{'verbose-msg-detail'})) {
my ($host, $reason, $moreReason); # More ugliness :/
- unless((($host, $reason) = ($deferredReas =~ /^host (\S+) (?:said|refused to talk to me): ([^(]+)/)) ||
- (($host, $reason) = ($deferredReas =~ /^(?:delivery temporarily suspended: )?connect to (.+?(?::\d+)?): ([^)]+)$/)) ||
- (($host, $reason) = ($deferredReas =~ /^cannot (?:append to file|update mailbox) ([^:.]+)[:.] (.+)$/)) ||
- (($reason, $host, $moreReason) = ($deferredReas =~ /^.*(Name service error )for (?:domain |name=)?([^: ]+):? (.+)$/)) ||
- (($reason, $host, $moreReason) = ($deferredReas =~ /^((?:conversation|lost connection) )with (\S+) ((?:timed out )?while (receiving|sending) .+)$/)) ||
- (($reason, $host, $moreReason) = ($deferredReas =~ /^(delivery temporarily suspended: )connect to ([^:]+): (.+)$/))
+ unless((($host, $reason) = $deferredReas =~ /^host (\S+) (?:said|refused to talk to me): ([^(]+)/) ||
+ (($host, $reason) = $deferredReas =~ /^(?:delivery temporarily suspended: )?connect to (.+?(?::\d+)?): ([^\)]+)$/) ||
+ (($host, $reason) = $deferredReas =~ /^cannot (?:append to file|update mailbox) ([^:.]+)[:.] (.+)$/) ||
+ (($reason, $host, $moreReason) = $deferredReas =~ /^.*(Name service error )for (?:domain |name=)?([^: ]+):? (.+)$/) ||
+ (($reason, $host, $moreReason) = $deferredReas =~ /^((?:conversation|lost connection) )with (\S+) ((?:timed out )?while (receiving|sending) .+)$/) ||
+ (($reason, $host, $moreReason) = $deferredReas =~ /^(delivery temporarily suspended: )connect to ([^:]+): (.+)$/)
)
{
- $host = "unrecognized deferral reason(s)";
+ $host = "(unknown host)";
$reason = $deferredReas;
}
+ $host =~ s/:\d{2,3}$//; # Strip trailing port numbers
$reason .= $moreReason if($moreReason); # ick
# Finally...
return join '', @blocks;
}
- if ((my @octets = ($norm1 =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/)) == 4) {
+ if ((my @octets = $norm1 =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) == 4) {
# Dotted-quad IPv4 address
# Validate each octet is in range 0-255
for my $octet (@octets) {
($line =~ /^(?:<\d{1,3}>(?:[1-9]\d*\s+|\s*))?(\w{3}) {1,2}(\d{1,2}) (\d{2}):(\d{2}):(\d{2}) \S+ (.+)$/)) == 6)
{
return (undef) unless defined($msgMon = $monthNums{$monStr});
- #$msgMon = $monthNums{$monStr};
- #unless(defined($msgMon)) {
- # print "dbg: \$msgMon undefined from \$monStr: \"$monStr\"\n";
- # return (undef);
- #}
+
my ($currMon, $currYr) = (localtime($now))[4,5];
# If month in logfile line is > current month the logfile line must be from last year
--$currYr if($msgMon > $currMon);
return (undef); # Not a parsable line
}
-
# if there's a real hostname/domain: uses that. Otherwise uses
# the IP addr.
#
# N.B.: IP addr checking is not exhaustive
#
sub gimme_domain {
- $_ = $_[0];
- my $bracketRegex = '([^\s\[]+)\[((?:\d{1,3}\.){3}\d{1,3}|[\da-fA-F:]+(?:::(?:[\da-fA-F:]+)?)?|[\da-fA-F:]+:(?:\d{1,3}\.){3}\d{1,3})\]';
- my $slashSepRegex = '([^\s\/]+)\/((?:\d{1,3}\.){3}\d{1,3}|[\da-fA-F:]+(?:::(?:[\da-fA-F:]+)?)?|[\da-fA-F:]+:(?:\d{1,3}\.){3}\d{1,3})';
+ my $line = $_[0];
+
+ # Treat letters, digits, dot, hyphen, and underscore as "hostname-ish".
+ # Start only if we're NOT preceded by one of those (or we're at BOL).
+ state $HBOUND = qr/(?<![A-Za-z0-9._-])/;
+
+ state $HOST = qr/(?:unknown|localhost|(?:[a-z0-9-]+\.)+[a-z0-9-]+)/i;
+ state $IPv4 = qr/(?:\d{1,3}\.){3}\d{1,3}/;
+ state $IPv6 = qr/(?=[^\]]*:)[\da-f:]+(?:::(?:[\da-f:]+)?)?/i;
+
+ state $bracketRegex = qr/$HBOUND($HOST)\.?\[($IPv4|$IPv6:$IPv4|$IPv6)\]/i;
+ state $slashSepRegex = qr/$HBOUND($HOST)\.?\/($IPv4|\[?$IPv6:$IPv4\]?|\[?$IPv6\]?)/i;
# Rejects and so-on from postscreen pass these in
- my $addrOnlyRegex = '^\[((?:\d{1,3}\.){3}\d{1,3}|[\da-fA-F:]+(?:::(?:[\da-fA-F:]+)?)?|[\da-fA-F:]+:(?:\d{1,3}\.){3}\d{1,3})\]';
+ state $addrOnlyRegex = qr/^\[($IPv4|$IPv6:$IPv4|$IPv6)\]/i;
+ # For last-ditch effort to get at least an IP address
+ state $ipLastDitch = qr/($IPv4|$IPv6:$IPv4|$IPv6)/;
+
my ($fqdn, $ipaddr);
- unless(((($fqdn, $ipaddr) = /$bracketRegex/i) == 2) ||
- (($fqdn, $ipaddr) = /$slashSepRegex/i) == 2)
+ unless( (($fqdn, $ipaddr) = ($line =~ $bracketRegex)) ||
+ (($fqdn, $ipaddr) = ($line =~ $slashSepRegex)) ||
+ (($ipaddr) = ($line =~ $addrOnlyRegex)) )
{
- ($ipaddr) = /$addrOnlyRegex/i;
+ # One last-ditch effort to get at least an IP address
+ if ( $line =~ /\[$ipLastDitch\] | \/$ipLastDitch(?=$|\s|[\]\),;:])/x ) {
+ $ipaddr = $1 // $2;
+ }
}
$fqdn = "unknown" unless($fqdn);
$ipaddr = "unknown" unless($ipaddr);
+ $ipaddr =~ s/^\[|\]$//g;
return $ipaddr if($fqdn eq "unknown" || $fqdn =~ /\.(in-addr|ip6)\.arpa$/);
- my $domain = lc $fqdn;
+ return fold_domain($fqdn);
+}
- # Skip if no dot (single-label or malformed)
- return $domain unless $domain =~ /\./;
+#
+# "Fold" email addresses and FQDNs down to domain names
+#
+# Future enhancement: Strip surrounding "<>"s?
+#
+sub fold_domain {
+ my ($fqdn) = @_;
+ state %original_tlds;
+ return '' unless defined $fqdn;
- my @parts = split /\./, $domain;
- my $tld = $parts[-1];
- my $sld = $parts[-2];
- my %original_tlds = map { $_ => 1 } qw(com net org gov mil edu);
+ # Strip brackets, "user@", leading and trailing whitespace, lowercase
+ (my $domain = $fqdn) =~ s/^\s*<?(?:[^@]+\@)?([^\s>]+)>?\s*$/\L$1/;
- if ($original_tlds{$tld}) {
- # Collapse to second-level domain: example.com
- return "$sld.$tld";
- }
+ # Strip trailing "." (PTRs, etc.)
+ $domain =~ s/\.$//;
- # Otherwise elide leftmost: host.example.co.uk → example.co.uk
- # if more than 3 elements
- if (@parts > 3) {
- shift @parts;
- return join('.', @parts);
- } else {
- return $domain;
+ return $domain if $domain !~ /\./;
+
+ unless(%original_tlds) {
+ %original_tlds = map { $_ => 1 } qw(com net org gov mil edu);
}
+ my @parts = split /\./, $domain;
+ my ($sld,$tld) = @parts[-2,-1];
+
+ return "$sld.$tld" if $original_tlds{$tld};
+ return join('.', @parts[1..$#parts]) if @parts > 3; # elide leftmost once
+ return $domain;
}
# Return (value, units) for integer
# First: get everything following the "reject: ", etc. token
# Was an IPv6 problem here
($rejTyp, $rejFrom, $rejRmdr) =
- ($logLine =~ /^.* \b(?:reject(?:_warning)?|hold|discard): (\S+) from (\S+?): (.*)$/);
+ $logLine =~ /^.* \b(?:reject(?:_warning)?|hold|discard): (\S+) from (\S+?): (.*)$/;
print STDERR "\$rejTyp: \"$rejTyp\", \$rejReas: \"$rejReas\"\n" if($opts{'debug'} && defined $rejTyp && defined $rejReas);
# Next: get the reject "reason"
projects / sven / pflogsumm.git / commitdiff