Something

#!/usr/bin/perl
#===============================================================================
#
#         FILE:  parse.pl
#
#        USAGE:  ./parse.pl 
#
#  DESCRIPTION:  ---
#
#      OPTIONS:  ---
# REQUIREMENTS:  ---
#       AUTHOR:  Jonas Lundgren (JL), <jonas@local.se>
#      VERSION:  0.1
#      CREATED:  06/29/06 08:37:23 CEST
#===============================================================================
#
#  This program is free software; you can redistribute it and/or modify 
#  it under the terms of the GNU General Public License as published by 
#  the Free Software Foundation; either version 2 of the License, or    
#  (at your option) any later version.                                  
#
#===============================================================================


use strict;
use warnings;

# Directory where to look for emails. (Matching filenames on this regexp: ^[^\.]\d+\.\w+_\d+\.
my $workdir = "/tmp/mail";
# Sort the resulting emails in a <email><tab><number_of_total_matches> list (If $print_sort is 0 it will just print all adresses from the array, even
# if that resluts in the same emailadress being printed more than once
my $print_sort = 1;
# Turn this on to get (_ALOT_) of debugging output.
my $debug = 0;

# If any line in an email matches any of these regexps, that mail is skipped
my @skip_matchs = ( 'X-Authentication-Warning:\s+.*:\s+\w+\s+set\s+sender\s+to\s+.*\s+using\s+-f',
                    'To prove that your message was sent by a human and not a computer, please',
                    'MIFABs mailadresser med namnet mifab\.se har bytts ut\.',
                    '^X-Greylist: Delayed for',
);

# Mail that match theses regexps are excluded from the list
my @emailaddr_skip = ( 'metro@woize.com',
);

# These are the regexps applied to all emails to get the bounce-addr, values between () are used as the mailaddr. (Evaluated from top to bottom,
# stopping at the first match (If that regexp match multiple lines in one email it will compare the 2 matches, if they are the same it will use it,
# otherwise it will just skip that email.
my @matches = ( 'X-CP-For:\s+([\w|\.|-]*@.*)$',
                'X-Failed-Recipients:\s+([\w|\.|-]*@.*)$',
                'X-Failed-Recipients:\s+<([\w|\.|-]*@.*)>$',
                'SMTP error from remote mail server after RCPT TO:<([\w|\.|-]*@.*)>:',
                '550 ([\w|\.|-]*@.*) unknown user account$FINALMATCH',
                'Diagnostic-Code:\s+\w+;\s+\d+\s+RCPT\sTO:<([\w|\.|-]*@.+)>',
                'Original-recipient:\s+\w+;\s*<([\w|\.|-]*@.*)>$',
                'Original-recipient:\s+\w+;\s*([\w|\.|-]*@.*)$',
                'Final-Recipient:\s+\w+;\s*<([\w|\.|-]*@.*)>$',
                'Final-Recipient:\s+\w+;\s*([\w|\.|-]*@.*)$',
                '^You have tried to reach ([\w|\.|-]*@.*)\.$',
                'Return-path:\s+<([\w|\.|-]*@.*)>$',
                '^From:\s+.*<([\w|\.|-]*@.*)>$FINALMATCH',
                '^From:\s+([\w|\.|-]*@.*)$FINALMATCH',
#                '(.*@.*)'
);


#---------------------------------------------------------------------------
#  MAIN
#---------------------------------------------------------------------------

my $i = 0;
my $sanity = 0;
my $firstmatch;
my $lastmatch;
my $skip_checked = 0;
my $did_skip = 0;
my $slurp;
my $cur_mail;
my %final_list_emails;
my @final_list_emails;
my @mails;
my @b_addrs = ();
my @b_match = ();

# Get a filelist from $workdir
opendir(DIRLIST, $workdir) || die "can't opendir $workdir: $!";
@mails = grep { /^[^\.]\d+\.\w+_\d+\./ } readdir(DIRLIST);
closedir(DIRLIST);

OUTER: foreach my $mail (@mails) {
    $i++;
    $did_skip = 0;
    $cur_mail = "$workdir/$mail";
    open(CUR_MAIL, "<", $cur_mail) or die "Can't open file: $cur_mail: $!";
    {
        local $/;
        $slurp = <CUR_MAIL>;
    }

    foreach my $skip (@skip_matchs) {
        if ($slurp =~ /$skip/) {
            print "WARNING: this mail matched the skip-regexp: $skip\n" if $debug;
            $did_skip = 1;
            next OUTER;
        }
    }

    print "Working on mail($i): $workdir/$mail\n" if $debug;
    foreach my $match (@matches) {
        if ($match =~ s/FINALMATCH//) {
            $firstmatch = 1;
        } else {
            $firstmatch = 0;
        }
        if ($match =~ s/LASTMATCH//) {
            $lastmatch = 1;
        } else {
            $lastmatch = 0;
        }

        @b_match = ();

        while (<CUR_MAIL>) {
            if (/$match/) {
                print "Trying regexp: /$match/\n" if $debug;
                if ($lastmatch) {
                    $b_match[0] = $1;
                } else {
                    push(@b_match, $1);
                    last if $firstmatch;
                }
                print "Matched regexp: /$match/\n" if $debug;
            }
        }

        if (scalar(@b_match) == 1) {
            print "$b_match[0]\n" if $debug;
            last;
        } elsif (scalar(@b_match) > 1) {
            # If all multimatched adresses are the same, it's probably correct!
            my $multi_truematch = 1;
            foreach (@b_match) {
                if ($_ ne $b_match[0]) {
                    print "$_ ne $b_match[0]\n" if $debug;
                    $multi_truematch = 0;
                }
            }
            if ($multi_truematch) {
                print "$b_match[0]\n" if $debug;
                last;
            } elsif ($debug) {
                print "WARNING: One regexp matched several(" . scalar(@b_match) . ") lines in one mail(#$i), BUG in regexp?\n";
                print "too many matches, press enter to go to next regexp on the same mail\n";
                <>;
            }
        }
        seek(CUR_MAIL, 0, 0);
    }

    # This code is run if there are no match at all on a mail (Even if it's due to a skip_match)
    if (scalar(@b_match) != 0) {
 
        my $blacklisted_email = 0;
        foreach (@emailaddr_skip) {
            $blacklisted_email = 1 if $b_match[0] eq $_;
        }
 
        if (!$blacklisted_email) {
            $final_list_emails{$b_match[0]} += 1;
            push(@final_list_emails, $b_match[0]);
        }
    } elsif ($debug) {
        print "No matches found\n";
        <>;
    }
}

if ($print_sort) {
    my @keys = sort { $final_list_emails{$a} <=> $final_list_emails{$b} } keys %final_list_emails;
    foreach my $key ( @keys ) {
        printf "%-40s %6d\n", $key, $final_list_emails{$key};
    }
} else {
    foreach (@final_list_emails) {
        print "$_\n";
    }
}