Alister West

home is where your code is ...
#!/usr/bin/env perl

=head1 NAME

    report-bounced.pl

=head1 SYNOPSIS

    report-bounced.pl [ --debug --dryrun ] /path/to/maildir  url_to_report

=head1 DESCRIPTION

    This script will open up $maildir/new, and recurse through the contained
    files. If an email has the following header:

    X-ww-id:

    We will grab the id value off that line ($id), and process the email to glean
    to_address, subject and body. Once all the emails are processed, we post the
    result to the given URL as 

    <bounces>
        <bounce id="$id" to="$to_adress" subject="$subject">
            <! [CDATA[
                $subject
            ]]>
        </bounce>
        <bounce> ... </bounce>
    </bounces>

=head1 AUTHOR

    Alister West - alisterwest.com

=cut

use strict;
use warnings;

use Cwd qw/abs_path/;
use Data::Dumper;
use HTTP::Request; 
use LWP::UserAgent; 
use Pod::Usage;
use XML::Simple;

$Data::Dumper::Terse=1;$Data::Dumper::Quotekeys=0;
$Data::Dumper::Indent=0;$Data::Dumper::Sortkeys=1;

sub debug($);


# Setup - Process commandline options
# -----------------------------------

my %opts = (
    maildir => '',
    url     => '',
    debug   => 0,
    dryrun  => 0,
);

foreach (@ARGV) {

    debug "ARG: $_";
    pod2usage(1) if $_ =~ /^(-h|--help|)$/;

    if ( $_ eq '--debug'  ) { $opts{debug}    = 1;  next; }
    if ( $_ eq '--dryrun' ) { $opts{dryrun}   = 1;  next; }
    if ( !$opts{maildir}  ) { $opts{maildir}  = $_; next; }
    if ( $opts{maildir} && !$opts{url} ) { $opts{url} = $_; next; }

}

pod2usage(1) if ! $opts{maildir} || ! $opts{url};

debug '  INPUTS:  '. Dumper(\%opts);


if($opts{maildir} !~ /Maildir/) {
    $opts{maildir} .= '/returned/Maildir/new' ;
    debug "  changed to look at 'returned' maildir by default ";
}

debug "$0 - inputs ok";


# Main
# -------------------------------
{

    my $bounces = find_bounces( $opts{maildir} );
    print "Got " . @$bounces ." bounces\n";

    my $xml = generate_report( $bounces );
    debug $xml;
    print  "XML is " . length( $xml ) ." chars\n";

    post_content_to( $xml, $opts{url} );


}
exit;





# Functions
# -------------------------------------------------------------------

sub debug($) { my $msg = shift; print "XXX $msg\n" if $opts{debug}; }



sub find_bounces {
# -------------------------------
#
    my $maildir = shift;

    my @bounces;

    # Get emails
    #
    opendir my $dh, "$maildir" or die "Can't opendir $maildir: $!";
    my @emails = grep { !/^\./ && -f "$maildir/$_" } readdir($dh);


    # Setup archive
    #
    my $archive = "$maildir/../archive";
    if ( ! -d "$archive" ) { 
        mkdir ("$archive", 0700) or die "mkdir $archive, 0700 : $!";
        debug "  Created $archive";
    }

    print ' - Found '. @emails ." emails\n";


    # Process emails
    #
    foreach my $email (@emails) {

        my $email_path = "$maildir/$email";
        open (my $fh, "<", "$email_path") or die "Cant open file $email_path: $!";
        my @contents = <$fh>;
        close $fh;

        debug '';
        debug "$email_path";

        # Grab headers from the email.
        #
        if( my ($id) = grep { /^X-ww-id: .*$/ } reverse @contents ) {
            $id =~ s/X-ww-id: (.*)/$1/;
            chomp $id;
            debug " - X-ww-id: $id";

            # Subject
            my ($subject) = grep { /^Subject:/ } reverse @contents;
            $subject =~ s/^Subject: (.*)/$1/;
            chomp $subject;

            # Address
            #
            my ($address) = grep { /^Return-Path:/ } @contents;
            $address =~ s/^Return-Path: (.*)/$1/;
            chomp $address;

            if(!$address or $address eq '<>') {
                ($address) = grep { /^To:/ } reverse @contents;
                $address =~ s/^To: (.*)/$1/;
                chomp $address;
            }

            $address =~ s/.*<(.*)>/$1/;

            debug " - '$address' - '$subject'";

            # Rember
            #
            push @bounces, { xid => $id, to => $address, subject => $subject, content => $subject };

        } 

        # Archive
        # - Can't die here or we loose the info of the files we've already moved.
        #
        unless ($opts{dryrun}){
            File::Copy::move( $email_path, $archive ) or warn "Archive $email -> $archive: $!";
            debug " - Archived $email";
        }

    }

    return \@bounces;
}


sub generate_report {
# -------------------------------
# Take a hash-array and turn it into xml.
#
    my $bounces = shift;

    # Use a library instead of handcoded XML
    # $xml = XMLout({ bounce => $bounces }, 
    #            RootName => 'bounces', 
    #            ValueAttr => ['xid','to','subject',], 
    #            AttrIndent => 1);

    # Spec called for CDATA tags, so handcoding..
    my $xml = "<bounces>\n";

    foreach my $bounce (@$bounces) {
        $xml .= qq/<bounce xid="$bounce->{xid}" to="$bounce->{to}" subject="$bounce->{subject}">\n/;
        $xml .= qq/<![CDATA[$bounce->{subject}]]>\n/;
        $xml .= qq{</bounce>\n};
    }

    $xml .= "</bounces>\n";

    # Test is valid xml.
    # my $hash = XMLin($xml, ForceArray => [ 'bounce', 'contents' ], );

    return $xml;
}


sub post_content_to {
# -------------------------------
# Post XML to a url.
#
    my ($content, $url) = @_;

    debug " Generating HTTP::Request to $url";

    my $req = HTTP::Request->new( "POST" => $url ); 
    $req->add_content($content); 

    debug "\n". $req->dump;
    #debug $req->as_string();

    my $ua = LWP::UserAgent->new(); 
    $ua->request($req) unless $opts{dryrun};
    print $opts{dryrun} ? "Would have " :'';
    print "Sent Report to $url\n\n";

}


no warnings 'void';
"The coffee made me do it!"
__END__
By Alister West