#!/usr/local/bin/perl -w
#
# AIM: Implements the PRA (Purported Responsible Address) algorithm
# described in Internet-Draft draft-ietf-marid-par-00.txt.
#
# USE: ./pra.pl <path-to-file>
#
# Requires: Perl.
#           mailTools-1.64
#
# LICENCE: trivial work, not patentable, not licenceable.
#
# WARNING: Microsoft claims a patent on the PRA algorithm.
# The author did not requested a licence.
#
# AURHOR: Mark Kramer <admin@asarian-host.net>

use Mail::Address;
use strict;

my $pra;
my $header;

sub gimme_pra {
    my @candidates;
    if (eval {((@candidates = Mail::Address -> parse (extract_header (@_))) == 1)}) {
        return (lc (pop (@candidates) -> address ()));
    } else {
        return undef;
    }
    sub extract_header {
       (my $header = (shift)) =~ s/\n\s+/\t/mg;
        $header =~ s/^[^:]*:\s*\n//mg;
        my $pra;
        if ($header =~ /^Resent-Sender: *(.+)/mi) {
            $pra = $1;
            return ($pra) if ($` !~ /^Resent-From: *(.+)(.|\n)*?^(Received|Return-Path):/mi);
        }
        if ($header =~ /^Resent-From: *(.+)/mi) {
            return ($1);
        } elsif ($header =~ /^Sender: *(.+)/mi) {
            $pra = $1;
            if (($header =~ s/^Sender: *(.+)//mgi) > 1) {
                return undef;
            } else {
                return ($pra);
            }
        } elsif ($header !~ /^From: *(.+)/mi) {
            return undef;
        } else {
            return ($1);
        }
    }
}

my $header_file = $ARGV[0] or die "Usage: $0 <file containing headers>";

if (open (HEADERS, $header_file)) {
    $header .= $_ while (<HEADERS>);
    close (HEADERS);
} else {
    die "Cannot open $header_file!\n";
}

if ($pra = gimme_pra ($header)) {
    print "$pra\n";
}
else {
    print "No PRA\n";
}

exit 0;