File Coverage

blib/lib/Email/Received.pm

Criterion	Covered	Total	%
statement	109	553	19.7
branch	47	294	15.9
condition	2	12	16.6
subroutine	12	14	85.7
pod	0	4	0.0
total	170	877	19.3

package Email::Received;
use 5.006;
use strict;
use warnings;
use constant DEBUG => 0;

require Exporter;
use base 'Exporter';
our @EXPORT = qw( parse_received);
our $VERSION = '1.00';
use Email::Received::Constants;
my $IP_ADDRESS = IP_ADDRESS;
my $LOCALHOST = LOCALHOST;
use Regexp::Common qw/net/;

# So the plan - man, this is so evil - is to make parse_received on the
# fly from the rules below.
*parse_received = generate_parse_received( unparse_rules(parse_rules()));

sub tidy_up {
    my $r = shift;
    no warnings;
    #print "Tidy up called for $_\n";
    $r->{envfrom} =~ s/^\s*<*//gs; $r->{envfrom} =~ s/>*\s*$//gs;
    $r->{by} =~ s/\;$//;
    if ($r->{ip} =~ /($RE{net}{IPv4})/) { $r->{ip} = $1 } else { return }

    exists $r->{$_} and $r->{$_} =~ s/[\s\0\#\[\]\(\)\<\>\|]/!/gs for qw/ip rdns helo by ident envfrom /;
    delete $r->{rdns} if lc $r->{rdns} eq "unknown";
    return $r;
}

sub generate_parse_received {
    my $code = shift;
    $code = q|sub {
    local $_ = shift;
    s/\s+/ /gs;
    #print "Got $_\n";
    my $r = {};
|.
$code. q/
#print "Dropped off the end\n";
return tidy_up($r);
    }
/;
    my $subref = eval $code;
    die "Couldn't create subroutine: $@" if $@;
    return $subref;
}

=head1 NAME

Email::Received - Parse an email Received: header

=head1 SYNOPSIS

  use Email::Received;

  for ($mail->header("Received")) {
    my $data = parse_received($_);
    return "SPAM" if rbl_lookup($data->{ip});
  }

=head1 DESCRIPTION

This module is a Perl Email Project rewrite of SpamAssassin's email
header parser. We did this so that the great work they did in analysing
pretty much every possible Received header format could be used in
applications other than SpamAssassin itself.

The module provides one function, C, which takes a
single Received line. It then produces either nothing, if the line is
unparsable, a hash reference like this:

    { reason => "gateway noise" }

if the line should be ignored for some good reason, and one like this:

   { ip => '64.12.136.4', id => '875522', by => 'xxx.com',
     helo => 'imo-m01.mx.aol.com' }

if it parsed the message. Possible keys are:

    ip rdns helo ident envfrom auth by id

=head1 RULE FORMAT

Where SpamAssassin used a big static subroutine full of regular expressions
to parse the data, we build up a big subroutine full of regular expressions
dynamically from a set of rules. The rules are stored at the bottom of
this module. The basic format for a rule looks like this:

    ((var=~)?/REGEXP/)? [ACTION; ]+

The C is either C, C,
C or C.

One control structure is provided, which is basically an C statement:

    GIVEN (NOT)? /REGEXP/ {
        ACTION+
    }

=head2 EXPORT

parse_received

=head1 SEE ALSO

L, from which the
rules and some of the IP address matching constants were blatantly
stolen. Thanks, guys, for doing such a comprehensive job!

=head1 AUTHOR

simon, Esimon@E

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006 by simon

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.7 or,
at your option, any later version of Perl 5 you may have available.


=cut

use Text::Balanced qw(extract_quotelike);
sub parse_rules {
    my $in_given = shift;
    my $tree = [];
    while () {
        chomp; s/^\s+//;
        s/^#.*//; next unless /\S/;
        if (/^}\s*$/) {
            return $tree if $in_given;
            die "Syntax error on line $.: superfluous close bracket\n";
        }
        if (s/^GIVEN\s+//) {
            my $inverse = s/^NOT\s+//;
            my $referent = s/^(\S+)=~//?$1:"";
            my $re;
            unless ($re= extract_quotelike($_)) {
                die "Syntax error on line $.: given has no expression\n";
            }
            die "Syntax error on line $.: improper given\n" unless /\s*{\s*$/;
            my $subtree = parse_rules(1); # Let the reader understand!
            push @$tree, {given => $re,
                          ($referent ? (referent => $referent) : ()),
                          subtree => $subtree, inverse => $inverse };
            next;
        }
        my $referent;
        $referent = $1 if s/^(\S+)=~//;
        my $current = {};
        if (DEBUG) { $current->{line} = "$.: $_"; }
        if (my $re= extract_quotelike($_)) {
            $current->{regexp} = $re;
            $current->{referent} = $referent if $referent;
        } elsif($referent) { die "Syntax error on line $.: Referent with no regexp!\n"; }
        # At this point we want a set of commands delimited with
        # semicolons
        my @actions;
        while ($_) {
            s/^\s+// and next;
            if (s/^SET (\w+)\s*((?:\|\|)?=)\s*(.*?);//) {
                push @actions, { action => "SET", variable => $1, value => $3, operator => $2 };
                next;
            }elsif (s/^IGNORE\s*//) {
                my $reason = extract_quotelike($_);
                die "No semicolon after reason? on line $.\n" unless s/^\s*;//;
                push @actions, { action => "IGNORE", reason => $reason};
                next;
            } elsif (s/^(DONE|UNPARSABLE)\s*;//) {
                push @actions, { action => $1 };
                next;
            }
            die "Can't parse action '$_' at line $.\n";
        }
        if (@actions) { $current->{actions} = \@actions }
        push @$tree, $current;
    }
    return $tree;
}

sub unparse_rules {
    my $tree = shift;
    my $level = shift||0;
    my $output;
    for (@$tree) {
        $output .= " " x ($level * 5);
        if ($_->{given}) {
            #$output .= "print q{Trying given $_->{given} against |}.\$_.qq{|\n};\n";
            $output .= $_->{inverse} ? "unless " : "if ";
            $output .= "(";
            $output .= '$r->{'.$_->{referent}."}=~" if $_->{referent};
            $output .= $_->{given}.") {\n";
            #$output .= "print q{In given\n};\n";
            $output .= unparse_rules($_->{subtree}, $level+1);
            $output .= " " x ($level * 5);
            $output .= "}\n";
            #$output .= "print qq{Given over\n};\n";
            next;
        }
        if ($_->{regexp}) {
            #$output .= "print qq{Trying regexp }.q{$_->{regexp}}.qq{\n};";
            $output .= 'if (';
            $output .= '$r->{'.$_->{referent}."}=~" if $_->{referent};
            $output .= $_->{regexp}.") {\n";
        } else { $output .= "do { \n"; }
        $level++;
        if (DEBUG) {
            $output .= " " x ($level * 5);
            $output .= 'push @{$r->{rules_fired}}, q{'.$_->{line}."};\n";
        }
        for (@{$_->{actions}||[]}) {
            $output .= " " x ($level * 5);
            if ($_->{action} eq "DONE") { $output .= "return tidy_up(\$r)" }
            elsif ($_->{action} eq "UNPARSABLE") { $output .= "return" }
            elsif ($_->{action} eq "IGNORE") {
                $output .= 'return ';
                if ($_->{reason}) { $output .= "{reason => $_->{reason} }" };
            } elsif ($_->{action} eq "SET") {
                $output .= '$r->{'.$_->{variable}."} ".$_->{operator} . " ".$_->{value} }
            else { die "Couldn't unparse action!\n" }
            $output .= ";\n";
        }
        $level--;
        $output .= " " x ($level * 5);
        $output .= "};\n";
    }
    return $output;
}
__DATA__