] [ -l ]\n".
"\t[ -b ] [ -t ] [ -w ]\n".
"\t[ -N ] [ -n ]\n".
"\t[ -c ] [ ... ]\n".
"The 's' option shows sender domain counts.\n".
"The 'p' option shows address counts by for parent domains.\n".
"Parent domains are shown with a leading '.' before the domain name.\n".
"Parent domains are only shown if the the domain is not a TLD, and at\n".
"least (default 5) subdomains are shown in the output.\n\n".
"The bucket age ranges in units of minutes are\n".
"[0,1), [1,2), [2,4), [4,8), [8, 16), ... i.e.:\n".
"\tthe first bucket is [0, bucket_time) minutes\n".
"\tthe second bucket is [bucket_time, 2*bucket_time) minutes\n".
"\tthe third bucket is [2*bucket_time, 4*bucket_time) minutes...\n".
"'-l' makes the ages linear, the number of buckets shown is \n\n".
"The default summary is for the incoming and active queues. An explicit\n".
"list of queue names can be given on the command line. Non-absolute queue\n".
"names are interpreted relative to the Postfix queue directory. Use\n".
" to specify a non-default Postfix instance. Values of\n".
"the main.cf queue_directory parameter that use variable expansions are\n".
"not supported. If necessary, use explicit absolute paths for all queues.\n";
};
getopts("lhc:psw:b:t:m:n:N:", \%opts);
warn "Help message" if (exists $opts{"h"});
@qlist = @ARGV if (@ARGV > 0);
# The -c option specifies the configuration directory,
# it is not used if all queue names are absolute.
#
foreach (@qlist) {
next if (m{^/});
$ENV{q{MAIL_CONFIG}} = $opts{"c"} if (exists $opts{"c"});
chomp(my $qdir = qx{postconf -h queue_directory});
die "$0: postconf failed\n" if ($? != 0);
warn "'queue_directory' variable expansion not supported: $qdir\n"
if ($qdir =~ /\$/);
chdir($qdir) or die "$0: chdir($qdir): $!\n";
last;
}
};
$width = $opts{"w"} if (exists $opts{"w"} && $opts{"w"} > 80);
$bnum = $opts{"b"} if (exists $opts{"b"} && $opts{"b"} > 0);
$tick = $opts{"t"} if (exists $opts{"t"} && $opts{"t"} > 0);
$minsub = $opts{"m"} if (exists $opts{"m"} && $opts{"m"} > 0);
if ( -t STDOUT ) {
$batch_msg_count = 1000 unless defined($batch_msg_count = $opts{"N"});
$batch_top_domains = 20 unless defined ($batch_top_domains = $opts{"n"});
$cls = `clear`;
} else {
$batch_msg_count = 0;
$batch_top_domains = 0;
$cls = "";
}
sub rec_get {
my ($h) = @_;
my $r = getc($h) || return;
my $l = 0;
my $shift = 0;
while (defined(my $lb = getc($h))) {
my $o = ord($lb);
$l |= ($o & 0x7f) << $shift ;
last if (($o & 0x80) == 0);
$shift += 7;
return if ($shift > 14); # XXX: max rec len of 2097151
}
my $d = "";
return unless ($l == 0 || read($h,$d,$l) == $l);
($r, $l, $d);
}
sub qenv {
my ($qfile) = @_;
return unless $qfile =~ m{(^|/)[A-Za-z0-9]{6,}$};
my @st = lstat($qfile);
return unless (@st > 0 && -f _ && (($st[2] & 0733) == 0700));
my $h = new IO::File($qfile, "r") || return;
my ($t, $s, @r, $dlen);
my ($r, $l, $d) = rec_get($h);
if ($r eq "C") {
# XXX: Sanity check, the first record type is REC_TYPE_SIZE (C)
# if the file is proper queue file written by "cleanup", in
# this case the second record is always REC_TYPE_TIME.
#
$dlen = $1 if ($d =~ /^\s*(\d+)\s+\d+\s+\d+/);
($r, $l, $d) = rec_get($h);
return unless (defined $r && $r eq "T");
($t) = split(/\s+/, $d);
} elsif ($r eq "S" || $r eq "F") {
# For embryonic queue files in the "maildrop" directory the first
# record is either a REC_TYPE_FULL (F) followed by REC_TYPE_FROM
# or an immediate REC_TYPE_FROM (S). In either case there is no
# REC_TYPE_TIME and we get the timestamp via lstat().
#
$t = $st[9];
if ($r ne "S") {
($r, $l, $d) = rec_get($h);
return unless (defined $r && $r eq "S");
}
$s = $d;
} else {
# XXX: Not a valid queue file!
#
return undef;
}
while (my ($r, $l, $d) = rec_get($h)) {
if ($r eq "p" && $d > 0) {
seek($h, $d, 0) or return (); # follow pointer
}
if ($r eq "R") { push(@r, $d); }
elsif ($r eq "S") { $s = $d; }
elsif ($r eq "M") {
last unless (defined($s));
if (defined($dlen)) {
seek($h, $dlen, 1) or return (); # skip content
($r, $l, $d) = rec_get($h);
} else {
while ((($r, $l, $d) = rec_get($h)) && ($r =~ /^[NLp]$/)) {
if ($r eq "p" && $d > 0) {
seek($h, $d, 0) or return (); # follow pointer
}
}
}
return unless (defined($r) && $r eq "X");
}
elsif ($r eq "E") {
last unless (defined($t) && defined($s) && @r);
return ($t, $s, @r);
}
}
return ();
}
# bucket 0 is the total over all the buckets.
# buckets 1 to $bnum contain the age breakdown.
#
sub bucket {
my ($qt, $now) = @_;
my $m = ($now - $qt) / (60 * $tick);
return 1 if ($m < 1);
my $b = $opts{"l"} ? int($m+1) : 2 + int(log($m) / log(2));
$b < $bnum ? $b : $bnum;
}
# Collate by age of message in the selected queues.
#
my $msgs;
sub wanted {
if (my ($t, $s, @r) = qenv($_)) {
my $b = bucket($t, $now);
foreach my $a (map {lc($_)} ($opts{"s"} ? ($s) : @r)) {
++$q{"TOTAL"}->[0];
++$q{"TOTAL"}->[$b];
$a = "MAILER-DAEMON" if ($a eq "");
$a =~ s/.*\@//;
$a =~ s/\.\././g;
$a =~ s/\.?(.+?)\.?$/$1/;
my $new = 0;
do {
my $old = (++$q{$a}->[0] > 1);
++$q{$a}->[$b];
++$sub{$a} if ($new);
$new = ! $old;
} while ($opts{"p"} && $a =~ s/^(?:\.)?[^.]+\.(.*\.)/.$1/);
}
if ($batch_msg_count > 0 && ++$msgs % $batch_msg_count == 0) {
results();
}
}
}
my @heads;
my $fmt;
my $dw;
sub pdomain {
my ($d, @count) = @_;
foreach ((0 .. $bnum)) { $count[$_] ||= 0; }
my $len = length($d);
if ($len > $dw) {
if (substr($d, 0, 1) eq ".") {
print ".+",substr($d, $len-$dw+2, $dw-2);
} else {
print "+",substr($d, $len-$dw+1, $dw-1);
}
} else {
print (" " x ($dw - $len), $d);
}
printf "$fmt\n", @count;
}
sub results {
@heads = ();
$dw = $width;
$fmt = "";
for (my $i = 0, my $t = 0; $i <= $bnum; ) {
$q{"TOTAL"}->[$i] ||= 0;
my $l = length($q{"TOTAL"}->[$i]);
my $h = ($i == 0) ? "T" : $t;
$l = length($h) if (length($h) >= $l);
$l = ($l > 2) ? $l + 1 : 3;
push(@heads, $h);
$fmt .= sprintf "%%%ds", $l;
$dw -= $l;
if (++$i < $bnum) { $t += ($t && !$opts{"l"}) ? $t : $tick; } else { $t = "$t+"; }
}
$dw = $dwidth if ($dw < $dwidth);
print $cls if ($batch_msg_count > 0);
# Print headings
#
pdomain("", @heads);
my $n = 0;
# Show per-domain totals
#
foreach my $d (sort { $q{$b}->[0] <=> $q{$a}->[0] ||
length($a) <=> length($b) } keys %q) {
# Skip parent domains with < $minsub subdomains.
#
next if ($d =~ /^\./ && $sub{$d} < $minsub);
last if ($batch_top_domains > 0 && ++$n > $batch_top_domains);
pdomain($d, @{$q{$d}});
}
}
find(\&wanted, @qlist);
results();