#!/usr/bin/perl

use strict;

use Fcntl qw( O_RDWR O_CREAT O_EXCL );
use IO::Seekable qw( SEEK_SET );
use Mail::Box::Manager;
use MIME::Parser;

use constant TMPDIR => "/tmp/bounce_buffer";

PURGE:
{
    my %D;

    sub _dir ($) { my $d = $_[0]; -d( $d ) || ( $d =~ s|[^/]*$|| ); $d }

    sub _paths ($)
    {
        my $obj = $_[0];
        my $bh;

        if( $bh = $obj->bodyhandle() )    { $D{ _dir($bh->path()) }++ }
        foreach my $mem ( $obj->parts() ) { _paths( $mem )            }
    }

    sub _clean () { foreach my $d ( keys(%D) ) { rmdir($d) } }

    sub _purge ($)
    {
        my $obj = $_[0];

        if( UNIVERSAL::isa($obj,'MIME::Entity') )
        {
            _paths( $obj );
            $obj->purge();
        }
    }
}

#END { foreach ( @PURGE ) { _purge( $_ ) } _clean() }

sub _message_buffer ()
{
    my $fh;
    my $r = int( rand(1000) );
    my $n = sprintf( "/tmp/msgbuf.grep.$$.%02d", $r );

    sysopen( $fh, $n, O_RDWR|O_EXCL|O_CREAT, 0600 ) || die( "$n: $!\n" );
    unlink ( $n );

    return $fh;
}

sub _multi2text ($)
{
    # some broken mua's *cough* outlook *cough*
    # produce strange russian-doll like multiply nested MIME messages.
    my $x    = $_[0];
    while( $x && $x->mime_type() =~ /\bmultipart\b/i ) { $x = $x->parts(0) }
    return eval { $x->bodyhandle()->as_string() } || "";
}

sub _status_part ($)
{
    my $m = $_[0];
    my @x = ();
    my @y = ();

    if( $m && $m->mime_type() =~ m|\bmessage/delivery-status\b|i )
    {
        return eval { $m->bodyhandle()->as_string() };
    }

    if( $m->mime_type() =~ m|\bmultipart\b|i )
    {
        if( @x = $m->parts() )
        {
            return (@y = map { _status_part($_) } @x) ? $y[0] : ();
        }
        # bah, we have a geborken message:
        return
          join( "\n", map { @{$_ || []} } $m->preamble(), $m->epilogue() );
    }

    return ();
}

sub _grep ($$$)
{
    my $addr = $_[0];
    my $t    = $_[1];
    my $re   = $_[2];
    my $rv   = 0;

    while( $t =~ m/$re/g )
    {
        my $a = lc($1);
        ( $a !~ /@/ ) && ( $a =~ s/\+aea-/@/ );
        $rv += ( $addr->{$a} = 1 );
    }

    return $rv;
}

sub grep_bounced_addrs ($\%)
{
    my $mesg = $_[0];
    my $addr = $_[1];
    my $n    = _status_part( $mesg );
    my $t    = '';
    my $rv   = 0;

    if( $n )
    {
        #if( $n =~ /^Action:\s+fail/mis ) { warn("\nGREPPING\n")     }
        #else                             { warn("\nNOT GREPPING\n") }
        #warn( "STATUS:\n$n\n-----------------------------------\n" );

        if( ( $n =~ /^Action:\s+fail/mis                                 ) &&
            ( $n =~ /^(?:Orig|F)inal-Rec\S+ient:\s+(?:\S+;)?\s*(\S+)/mis )  )
        {
            $addr->{ lc($1) } = 1;
            return 1;
        }
    }

    my $t = _multi2text( $mesg );

    if( $t =~ /DO NOT NEED TO RESEND/i ) { return 0 }

    if( $t =~ /^\s*the postfix program\s*$(.*)/mis                           ||
        $t =~ /^\s*--.*?errors.*?--\s*$(.*?)^\s*--.*?transcript.*?--\s*$/mis ||
        $t =~ /^Hi. This is.*?qmail.*?Sorry.*?k out.(.*?)^--- [^\n]+copy/mis ||
        $t =~ /^Hi. This is.*?qmail.*?Sorry.*?k out.(.*)$/mis                 )
    {
        $rv =  _grep( $addr, $1, qr/^<(.*?)>[:\s]/m );
        $rv += _grep( $addr, $1, qr/^(\S+\@\S+) ACCOUNT/m );
        $rv += _grep( $addr, $1, qr/^\S+\@[A-Z0-9\.-]+\S*$/m );
    }
    elsif( $t =~ m'\bautomatically\b[^\n]+\(Exim\)\..*failed:\s*(.*?)^---'mis ||
           $t =~ m/address\(es\) failed:\s*$(.*?)^---/mis                     ||
           $t =~ m/address\(es\) failed:\s*$(.*)/mis                          ||
           $t =~ /----- the following .*? problems -----(.*?)^\s+---/mis       )
    {
        $rv = _grep( $addr, $1, qr/^\s*(\S+\@[A-Z0-9\.\-]+)\s*?$/mis );
    }
    elsif( $t =~ m'address\(es\).+\bfailure:(.*)'mis )
    {
        $rv = _grep( $addr, $1, qr/^\s+(\S+\@[A-Z0-9\.\-]+)\s*?$/mi );
    }
    elsif( $t =~ m/^550 (.*)$/mi )
    {
        $rv = _grep( $addr, $1, qr/<(.*?@.*?)>/i );
    }
    elsif( $t =~ m/did not reach.*?recipient\(s\):(.*)/mis       ||
           $t =~ m/recipient\(s\) could not be reached:(.*)/mis   )
    {
        $rv  = _grep( $addr, $1, qr/^'?(\S+\@[A-Z0-9\.\-]+)'?\s+on /mis );
        $rv += _grep( $addr, $1, qr/\bSMTP=(.*?);/mi );

        if( $t =~ /^Your message\b(.*?)^did not reach/mis )
        {
            $rv += _grep( $addr, $1, qr/^\s+To:\s+(\S+\@\S+)/mi );
        }
    }
    elsif ( $t =~ /^Delivery to the following recipients failed\.(.*)/mis )
    {
        $rv = _grep( $addr, $1, qr/^\s*?(\S+\+AEA-[A-Z0-9\.\-]+)\s*$/mis );
    }
    elsif ( $t =~ /^was not delivered to:\s*?^(.*?)^because:/mis )
    {
        $rv = _grep( $addr, $1, qr/^\s+(\S+@\S+)/mis );
    }
    elsif ( $t =~ /recipient was rejected\.(.*?)^Please reply to/mis )
    {
        $rv = _grep( $addr, $1, qr/^\s+Recipient:\s+<(.*?)>/mi );
    }
    elsif ( $t =~ /This message .*?\bundeliverable\b.*?reason:(.*)/mis )
    {
        $rv = _grep( $addr, $1, qr/\bSMTP <(.*?)>$/mi );
    }
    elsif ( $t =~ /returning\b.*?UNDELIVERED\.(.*?)\.$/mis )
    {
        $rv = _grep( $addr, $1, qr/addressed to ['<]?(\S+\@[^>'\s]+)[>']?/mi );
    }
    elsif( $t =~ /^\s*\|-+\s*failed\s+address.*?-+\|(.*?)^\s*(5\d\d\s|unknown)/mis )
    {
        $rv = _grep( $addr, $1, qr/<(.*?)>/ );
    }
    elsif( $t =~ /^\s*-+.*?address.*?permanent.*?error(.*?)transcript/mis )
    {
        $rv = _grep( $addr, $1, qr/<(.*?)>/ );
    }

    if( !$rv )
    {
        $rv = _grep( $addr, $t, qr/(?:^|\D)5\d\d\D.*?:\s+(\S+\@\S+)\s*$/mi )
    }

    return $rv;
}

MAIN:
{
    $^W = 0;
    my $bufh = _message_buffer();
    my $mua  = Mail::Box::Manager->new( trace => 'ERRORS', log => 'ERRORS' );
    my @mbox =
      map { $mua->open( $_, trace => 'ERRORS' ) } @ARGV;
    my $mime = MIME::Parser->new();
    my %addr = ();

    $mime->output_under( TMPDIR );

    foreach my $mbox ( @mbox )
    {
        my $max = $mbox->messages();
        print( STDERR "mailbox, $max messages:\n" );
        for( my $m = 1; $m < $max; $m++ )
        {
            seek( $bufh, 0, SEEK_SET );
            truncate( $bufh, 0 );
            printf( STDERR "\rmessage %05d...", $m );

            my $raw = $mbox->message( $m );
            $raw->print( $bufh );

            seek ( $bufh, 0, SEEK_SET );
            my $msg = $mime->parse( $bufh );

            my $a   = grep_bounced_addrs( $msg, %addr );

            printf( STDERR " scanned  : [$a addrs]" );
            _purge( $msg );
            if( $a > 0 ) { $raw->delete(1) }
        }
        print( STDERR "\n" );
        $mbox->close( force => 1 );
    }
    _clean();

    foreach ( keys(%addr) )
    {
        print( STDOUT $_, "\n" );
    }
};

__END__