#! /usr/local/bin/perl
my @grammar;

my (%flags, $return);
use Parse::RecDescent;
$Parse::RecDescent::skip = '[ \t]*';

my $grammar = q{
        program: thing(s)
            { $return = join("\n", @{$item[1]})}
        thing: comment | recipe | assignment | blank
        blank : "\n"
            { $return = ""; }
        comment : /^#.*/
        assignment: /^(.*)=(.*)/
            { my $from=$1; 
              my $what; 
              ($what = $2) =~ s/\$(\w+)/\$ENV{$1}/g; 
              $return = "\$ENV{$from}=qq($what)"; }
        filename : /\w+/
        recipe : { %main::flags = undef; } <reject>
        recipe : ':0' flag(?) locallock(?) "\n" condition(s) action "\n"
            { 
              $return = "@{$item[2]}";
              $return .= "if (";
              $return .= join(" and\n\t", @{$item[5]});
              $return .= ")\n{". 
                        main::indent($item[6] . ($main::flags{c}?"":"\nexit 1;"))
              ."}\n"; }
              |  ':0' flag(?) locallock(?) "\n" action "\n" 
            { 
              $return = "@{$item[2]}".
                        main::indent($item[5] . ($main::flags{c}?"":"exit 1;")) }
        locallock : ':' filename(?)
                { die "Lock files not yet implemented\n"; $return = $item[2] || "def.lck" }
        flag: /[HBDAaEehbfcwWir]+/
                { main::parse_flags($item[1]); $return = $main::flags{E} ? " else " : ""; }
        foo : condition | action
        condition : /(?<!=\\\\)\*/ /[*!?<>\\$]?/ /.*/ "\n" ...foo
                { $return = main::parse_find($item[2], $item[3])}
        action : '|' /.*/ 
                    { $return = "\$item->pipe(\"$item[2]\");"; }
                | '!' /.*/
                    { $return = "\$item->resend(\'$item[2]\');"; }
                | '{' program '}' 
                    { $return = $item[2] } 
                | filename
                    { $return = "\$item->deliver(\"$item[1]\");" }
};      

my $parser = Parse::RecDescent->new($grammar) or die;
undef $/;
my $data = <ARGV>;
$data =~ s/#.*//g;
my $program = $parser->program($data);

print 'use Mail::Audit; my $item = new Mail::Audit;', "\n";
print $program;
print "\n\$item->accept()";

sub indent { my $thing = shift; $thing =~ s/^/\t/g; $thing }
sub parse_flags {
    %flags = map { $_ => 1 } split //, shift;
    if ($flags{E}) { $return = "\nelse "; } 
    warn "Sorry, \"A\" flag not yet implemented" if $flags{A};
    $return = "";
}
sub parse_find {
    my ($type, $pat) = @_;
    my $match;
    my $func; 
    if ($flags{H} or !$flags{B}) { $func = "\$item->header" } else { $func = "join ('', \$item->body)"; }
    if ($type eq "<" or $type eq ">") { 
        return $return = "length(\$item->$func()) $type $pat"; 
    }
    if ($type eq "!") { $match = '!~' } else { $match = '=~' }
    $return = "\$item->$func() $match /$pat/";
    $return .= "i" unless $flags{D};
    $return;
}

=head1 NAME

proc2ma - Procmail to Mail::Audit migrator. 

=head1 USAGE

    proc2ma .procmailrc > filter.pl

=head1 DESCRIPTION

This program is meant to aid users migrating from F<procmail> to
F<Mail::Audit>. It reads in F<procmail> F<.rc> files, and spits out
a first approximation to a F<Mail::Audit> filter which will perform the
same filtering. You'll need to edit it, of course, and there's still a
lot it can't do. But it'll give you a good start.

=head1 VERSION

0.01

=head1 BUGS

Infinite

=head1 SEE ALSO

F<procmail>, F<Mail::Audit>.