#! /usr/bin/perl -w

use strict;
use IO::File;
use File::Find;
use Getopt::Long;

my %opts;		# Command line switches
my %q;			# domain counts for queues and buckets
my %sub;		# subdomain counts for parent domains
my $now = time;		# reference time
my $bnum = 10;		# deferred queue bucket count
my $width = 80;		# screen char width
my $dwidth = 18;	# min width of domain field
my $tick = 5; 		# minutes
my $minsub = 5;		# Show parent domains with at least $minsub subdomains

# The "p" option toggles the aggregation of counts by parent domain.
# The "s" option toggles the display of "sender" rather than the recipient.
#
GetOptions(\%opts, "c=s", "q=s@", "p", "s", "w=i", "b=i", "t=i", "m=i");

# The -c option specifies the configuration directory.
#
$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);
die "$0: 'queue_directory' variable expansion not supported: $qdir\n"
    if ($qdir =~ /\$/);
chdir($qdir) or die "$0: chdir($qdir): $!\n";

# The "-q queuename" option adds the named queue to the list of
# queues to be reported. By default the "incoming" and "active" queues
# are reported.
#
my @qlist = defined($opts{"q"}) ? @{$opts{"q"}} : qw(incoming active);

# The -w option specifies the output width, which must be at least 80.
#
$width = $opts{"w"} if (exists $opts{"w"} && $opts{"w"} > 80);

# The "-b" option specifies the number of deferred queue "buckets"
#
$bnum = $opts{"b"} if (exists $opts{"b"} && $opts{"b"} > 0);

# The "-t" option specifies the age limit in minutes of the first queue age
# "bucket". Each subsequent bucket has an age limit that is twice as large.
#
$tick = $opts{"t"} if (exists $opts{"t"} && $opts{"t"} > 0);

# The "-m" option specifies the minimum number of subdomains that a parent
# domain must have in order to appear in the parent domain output.
#
$minsub = $opts{"m"} if (exists $opts{"m"} && $opts{"m"} > 0);

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) = @_;
    my $h = new IO::File($qfile, "r") || return;
    my ($t, $s, @r, $dlen);
    while (my ($r, $l, $d) = rec_get($h)) {
	if ($r eq "C") { $dlen = $1 if $d =~ /^\s*(\d+)\s+\d+\s+\d+/; }
	elsif ($r eq "T") { $t = $d; }
	elsif ($r eq "S") { $s = $d; }
	elsif ($r eq "R") { push(@r, $d); }
	elsif ($r eq "M") { last unless defined $dlen; seek($h, $dlen, 1); }
	elsif ($r eq "E") { last; }
    }
    close($h);
    ($t, $s, @r);
}

# 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 = 2 + int(log($m) / log(2));
    $b < $bnum ? $b : $bnum;
}

# Potential queue files have mode 0700.
sub qfile {
    my ($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_[0]) or return;
    -f _ && (($mode & 0777) == 0700);
}

# Collate by age of message in the selected queues.
#
foreach $qdir (@qlist) {
    my $w = sub {
	if (qfile($_) && (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/.*\@\.*(.*[^.])?\.*$/$1/;
		$a =~ s/\.\././g;
		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/);
	    }
	}
    };
    find($w, $qdir);
}

my @heads;
my $fmt = "";
my $dw = $width;
my $t = 0;

for (my $i = 0; $i <= $bnum; ++$i, $t += $t ? $t : $tick) {
    $q{"TOTAL"}->[$i] ||= 0;
    my $l = length($q{"TOTAL"}->[$i]);
    my $h = ($i == 0) ? "T" : ($i == $bnum) ? "$t+" : $t;
    $l = length($h) if (length($h) >= $l);
    $l = ($l > 2) ? $l + 1 : 3;
    push(@heads, $h);
    $fmt .= sprintf "%%%ds", $l;
    $dw -= $l;
}
$dw = $dwidth if ($dw < $dwidth);

sub pdomain {
    my ($d, @count) = @_;
    $count[$_] ||= 0 foreach ((0 .. $bnum));
    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;
}

# Print headings
#
pdomain("", @heads);

# Show per-domain totals
#
foreach my $d (sort { $q{$b}->[0] <=> $q{$a}->[0] ||
		       length($a) <=> length($b) } keys %q) {

    # Skip parent domains < $minsub subdomains.
    #
    next if (substr($d, 0, 1) eq "." && $sub{$d} < $minsub);

    pdomain($d, @{$q{$d}});
}