#!/usr/bin/perl -w

$/ = ""; $\ = "\n";
$fields = join "|", qw( From To Cc X-Mailer X-Operating-System );
$mss = '\s*(?:\(.*\)|\[.*\]|\d+\.\S+|Version|Build|[-,])\s*$';

$eomseen = 1;
while (<>) {
    if ($eomseen && m/^From /) { ($header, $eomseen) = (1,0); $t++ }
    elsif (m/^$/m) { ($header, $eomseen) = (0,1) }
    else { $eomseen = 0 }
    next unless $header;
    s/\n\s+/ /g; # Unix mailboxes are such a beauty...
    # RFC 822 states header field names match [!-9;-~]+
    # while (m/^([!-9;-~]+):\s+(.*)/mg) { push @{$msg{$1}}, $2 }
    while (m/^((?:$fields)):\s+(.*)/mg) {
        ($key, $val) = ($1, $2);
        if ($key eq "From") {
            # This is not RFC 822 complaint. 
            if ($val =~ m/<([^@]+)\@([-a-z0-9.]+)>$/i ||
                $val =~ m/^([^@]+)\@([-a-z0-9.]+)/i) {
                map { tr/A-Z/a-z/ } (($usr, $dom) = ($1, $2)); 
                $from{"$usr\@$dom"}++;
                $tld{$1}++ if ($dom =~ m/\.(...)$/ || $dom =~ m/([^.]+\...)$/);
                $domain{$1}++ if ($dom =~ m/([^.]+(?:\.[^.]+){1,3})$/);
            }
        } elsif ($key eq "To" || $key eq "Cc") {
            foreach (split ',\s*', $val) {
                # This is not RFC 822 complaint. 
                if (m/<([^@]+)\@([-a-z0-9.]+)>$/i ||
                    m/^([^@]+)\@([-a-z0-9.]+)/i) {
                    map { tr/A-Z/a-z/ } (($usr, $dom) = ($1, $2)); 
                    $to{"$usr\@$dom"}++;
                }
            }
        } elsif ($key eq "X-Mailer") {
            while ($val =~ s/$mss//g) {}
            # This sucks!  Why do I have to special case this sh!t?
            $val = $& if $val =~ m/(?:Outlook|Eudora|Mozilla)/;
            $mailer{$val}++;
        }
    }
}

foreach $r (\%from, \%tld, \%domain, \%to, \%mailer) {
    print "-"x72;
    foreach (sort { -($r->{$a} <=> $r->{$b}) || $a cmp $b } keys %{$r}) {
        use integer;
        print "$_: $r->{$_} (", $r->{$_}*100/$t, "%)";
    }
}