Permalink
Fetching contributors…
Cannot retrieve contributors at this time
executable file 110 lines (92 sloc) 3.38 KB
#!/usr/bin/perl
# PODNAME: proc2ma
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 = "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.02
=head1 BUGS
Infinite
=head1 SEE ALSO
F<procmail>, F<Mail::Audit>.