Mail::Procmail - Procmail-like facility for creating easy mail filters.

Mail-Procmail documentation Contained in the Mail-Procmail distribution.

Index

Code Index:

NAME

Top

Mail::Procmail - Procmail-like facility for creating easy mail filters.

SYNOPSIS

Top

    use Mail::Procmail;

    # Set up. Log everything up to log level 3.
    my $m_obj = pm_init ( loglevel  => 3 );

    # Pre-fetch some interesting headers.
    my $m_from		    = pm_gethdr("from");
    my $m_to		    = pm_gethdr("to");
    my $m_subject	    = pm_gethdr("subject");

    # Default mailbox.
    my $default = "/var/spool/mail/".getpwuid($>);

    pm_log(1, "Mail from $m_from");

    pm_ignore("Non-ASCII in subject")
      if $m_subject =~ /[\232-\355]{3}/;

    pm_resend("jojan")
      if $m_to =~ /jjk@/i;

    # Make sure I see these.
    pm_deliver($default, continue => 1)
      if $m_subject =~ /getopt(ions|(-|::)?long)/i;

    # And so on ...

    # Final delivery.
    pm_deliver($default);

DESCRIPTION

Top

procmail is a great mail filter program, but it has weird recipe format. It's pattern matching capabilities are basic and often insufficient. I wanted something flexible whereby I could filter my mail using the power of Perl.

I've been considering to write a procmail replacement in Perl for a while, but it was Simon Cozen's Mail::Audit module, and his article in The Perl Journal #18, that set it off.

I first started using Simon's great module, and then decided to write my own since I liked certain things to be done differently. And I couldn't wait for his updates.

Mail::Procmail allows a piece of email to be logged, examined, delivered into a mailbox, filtered, resent elsewhere, rejected, and so on. It is designed to allow you to easily create filter programs to stick in a .forward or .procmailrc file, or similar.

DIFFERENCES WITH MAIL::AUDIT

Top

Note that several changes are due to personal preferences and do not necessarily imply deficiencies in Mail::Audit.

General

Not object oriented. Procmail functionality typically involves one single message. All (relevant) functions are exported.

Delivery

Each of the delivery methods is able to continue (except pm_reject and pm_ignore).

Each of the delivery methods is able to pretend they did it (for testing a new filter).

No default file argument for mailbox delivery, since this is system dependent.

Each of the delivery methods logs the line number in the calling program so one can deduce which 'rule' caused the delivery.

Message IDs can be checked to suppress duplicate messages.

System commands can be executed for their side-effects.

pm_ignore logs a reason as well.

pm_reject will fake a "No such user" status to the mail transfer agent.

Logging

The logger function is exported as well. Logging is possible to a named file, STDOUT or STDERR.

Since several deliveries can take place in parallel, logging is protected against concurrent access, and a timestamp/pid is included in log messages.

A log reporting tool is included.

Robustness

Exit with TEMPFAIL instead of die in case of problems.

pm_pipe_to ignores SIGPIPE.

pm_pipe_to returns the command exit status if continuation is selected.

Commands and pipes can be protected against concurrent access using lockfiles.

EXPORTED ROUTINES

Top

Note that most delivery routines exit the program unless the attribute "continue=>1" is passed.

Also, the delivery routines log the line number in the calling program so it is easy to find out which 'rule' caused a specific delivery to take place.

pm_init

This routine performs the basic initialisation. It must be called once.

Example:

    pm_init (logfile => "my.log", loglevel => 3, test => 1);

Attributes:

pm_gethdr

This routine fetches the contents of a header. The result will have excess whitepace tidied up.

The header is reported using warn() if the debug attribute was passed (with a true value) to pm_init();

Example:

    $m_rcvd = pm_gethdr("received");	# get first (or only) Received: header
    $m_rcvd = pm_gethdr("received",2);	# get 3rd Received: header
    @m_rcvd = pm_gethdr("received");	# get all Received: headers

pm_gethdr_raw

Like pm_gethdr, but without whitespace cleanup.

pm_body

This routine fetches the body of a message, as a reference to an array of lines.

Example:

    $body = pm_body();			# ref of lines
    $body = join("", @{pm_body()});	# as one string

pm_deliver

This routine performs delivery to a Unix style mbox file, or maildir.

In case of an mbox file, the file is locked first by acquiring exclusive access. Note that older style locking, with a lockfile with .lock extension, is not supported.

Example:

    pm_deliver("/var/spool/mail/".getpwuid($>));

Attributes:

pm_pipe_to

This routine performs delivery to a command via a pipe.

Return the command exit status if the continue attribute is supplied. If execution is skipped due to test mode, the return value will be 0. See also attribute testalso below.

If the name of a lockfile is supplied, multiple deliveries are throttled.

Example:

    pm_pipe_to("my_filter", lockfile => "/tmp/pm.lock");

Attributes:

pm_command

Executes a system command for its side effects.

If the name of a lockfile is supplied, multiple executes are throttled. This would be required if the command manipulates external data in an otherwise unprotected manner.

Example:

    pm_command("grep foo some.dat > /tmp/pm.dat",
               lockfile => "/tmp/pm.dat.lock");

Attributes:

pm_resend

Send this message through to some other user.

Example:

    pm_resend("root");

Attributes:

pm_reject

Reject a message. The sender will get a mail back with the reason for the rejection (unless stderr has been redirected).

Example:

    pm_reject("Non-existent address");

pm_ignore

Ignore a message. The program will do nothing and just exit with a DELIVERED status. A descriptive text may be passed to log the reason for ignoring.

Example:

    pm_ignore("Another make money fast message");

pm_dupcheck

Check for duplicate messages. Reject the message if its message ID has already been received.

Example:

    pm_dupcheck(scalar(pm_gethdr("message-id")));

Attributes:

Warning: In the current implementation, the DBM file will grow unlimited. A separate tool will be supplied to expire old message IDs.

pm_lockfile

The program will try to get an exclusive lock using this file.

Example:

    $lock_id = pm_lockfile("my.mailbox.lock");

The lock id is returned, or undef on failure.

pm_unlockfile

Unlocks a lock acquired earlier using pm_lockfile().

Example:

    pm_unlockfile($lock_id);

If unlocking succeeds, the lock file is removed.

pm_log

Logging facility. If pm_init() was supplied the name of a log file, this file will be opened, created if necessary. Every log message written will get a timestamp attached. The log level (first argument) must be less than or equal to the loglevel attribute used with pm_init(). If not, this message will be skipped.

Example:

    pm_log(2,"Retrying");

pm_report

pm_report() produces a summary report from log files from Mail::Procmail applications.

Example:

    pm_report(logfile => "pmlog");

The report shows the deliveries, and the rules that caused the deliveries. For example:

  393  393  deliver[203]  /home/jv/Mail/perl5-porters.spool
  370  370  deliver[203]  /home/jv/Mail/perl6-language.spool
  174  174  deliver[203]  /home/jv/Mail/perl6-internals.spool
  160   81  deliver[311]  /var/spool/mail/jv
	46  deliver[337]
	23  deliver[363]
	10  deliver[165]

The first column is the total number of deliveries for this target. The second column is the number of deliveries triggered by the indicated rule. If more rules apply to a target, this line is followed by additional lines with an empty first and last column.

Attributes:

If no logfile attribute is passed, pm_report() reads all files supplied on the command line. This makes it straighforward to run from the command line:

    $ perl -MMail::Procmail -e 'pm_report()' syslog/pm_logs/*

USING WITH PROCMAIL

Top

The following lines at the start of .procmailrc will cause a copy of each incoming message to be saved in $HOME/syslog/mail, after which the procmail-pl is run as a TRAP program (see the procmailrc documentation). As a result, procmail will transfer the exit status of procmail-pl to the mail transfer agent that invoked procmail (e.g., sendmail, or postfix).

    LOGFILE=$HOME/syslog/procmail
    VERBOSE=off
    LOGABSTRACT=off
    EXITCODE=
    TRAP=$HOME/bin/procmail-pl

    :0:
    $HOME/syslog/mail

WARNING: procmail seems to have problems when $HOME/syslog/mail gets too big (over 50Mb). If you want to maintain a huge archive, you can specify excess extents, like this:

    :0:
    $HOME/syslog/mail-ext1

    :0:
    $HOME/syslog/mail-ext2

EXAMPLE

Top

An extensive example can be found in the examples directory of the Mail::Procmail kit.

SEE ALSO

Top

Mail::Internet

LockFile::Simple

procmail documentation.

AUTHOR

Top

Johan Vromans, Squirrel Consultancy <jvromans@squirrel.nl>

Some parts are shamelessly stolen from Mail::Audit by Simon Cozens <simon@cpan.org>, who admitted that he stole most of it from programs by Tom Christiansen.

COPYRIGHT and DISCLAIMER

Top

This program is Copyright 2000,2004 by Squirrel Consultancy. All rights reserved.

This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with Perl.

This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the Artistic License for more details.

Mail-Procmail documentation Contained in the Mail-Procmail distribution. 
my $RCS_Id = '$Id: Procmail.pm,v 1.24 2004-09-19 12:34:56+02 jv Exp jv $ ';

# Author          : Johan Vromans
# Created On      : Tue Aug  8 13:53:22 2000
# Last Modified By: Johan Vromans
# Last Modified On:
# Update Count    : 254
# Status          : Unknown, Use with caution!


################ Common stuff ################

package Mail::Procmail;

$VERSION = "1.08";

use strict;
use 5.005;
use vars qw(@ISA @EXPORT $pm_hostname);

my $verbose = 0;		# verbose processing
my $debug = 0;			# debugging
my $trace = 0;			# trace (show process)
my $test = 0;			# test mode.

my $logfile;			# log file
my $loglevel;			# log level

use Fcntl qw(:DEFAULT :flock);

use constant REJECTED	=> 67;	# fake "no such user"
use constant TEMPFAIL	=> 75;
use constant DELIVERED	=> 0;

use Sys::Hostname;
$pm_hostname = hostname;

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(
	     pm_init
	     pm_gethdr
	     pm_gethdr_raw
	     pm_body
	     pm_deliver
	     pm_reject
	     pm_resend
	     pm_pipe_to
	     pm_command
	     pm_ignore
	     pm_dupcheck
	     pm_lockfile
	     pm_unlockfile
	     pm_log
	     pm_report
	     $pm_hostname
	    );

################ The Process ################

use Mail::Internet;
use LockFile::Simple;

use Carp;

my $m_obj;			# the Mail::Internet object
my $m_head;			# its Mail::Header object


sub pm_init {

    my %atts = (
		logfile   => '',
		loglevel  => 0,
		fh	  => undef,
		verbose   => 0,
		trace     => 0,
		debug     => 0,
		test      => 0,
		@_);
    $debug     = delete $atts{debug};
    $trace     = delete $atts{trace};
    $test      = delete $atts{test};
    $verbose   = delete $atts{verbose};
    $logfile   = delete $atts{logfile};
    $loglevel  = delete $atts{loglevel};
    my $fh     = delete $atts{fh} || \*STDIN;

    $trace |= ($debug || $test);

    croak("Unprocessed attributes: ".join(" ",sort keys %atts))
      if %atts;

    $m_obj = Mail::Internet->new($fh);
    $m_head = $m_obj->head;  # Mail::Header

    $m_obj;
}


sub pm_gethdr {
    my ($hdr, $ix) = @_;
    my @ret;
    foreach my $val ( $m_head->get($hdr, $ix) ) {
	last unless defined $val;
	for ( $val ) {
	    s/^\s+//;
	    s/\s+$//;
	    s/\s+/ /g;
	    s/[\r\n]+$//;
	}
	if ( $debug ) {
	    $hdr =~ s/-(.)/"-".ucfirst($1)/ge;
	    warn (ucfirst($hdr), ": ", $val, "\n");
	}
	return $val unless wantarray;
	push (@ret, $val);
    }
    wantarray ? @ret : '';
}


sub pm_gethdr_raw {
    my ($hdr, $ix) = @_;
    my @ret;
    foreach my $val ( $m_head->get($hdr, $ix) ) {
	last unless defined $val;
	if ( $debug ) {
	    $hdr =~ s/-(.)/"-".ucfirst($1)/ge;
	    warn (ucfirst($hdr), ": ", $val, "\n");
	}
	return $val unless wantarray;
	push (@ret, $val);
    }
    wantarray ? @ret : '';
}


sub pm_body {
    $m_obj->body;
}


sub _pm_msg_size {
    length($m_obj->head->as_string || '') + length(join("", @{$m_obj->body}));
}

sub pm_deliver {
    my ($target, %atts) = @_;
    my $line = (caller(0))[2];
    pm_log(2, "deliver[$line]: $target "._pm_msg_size());

    # Is it a Maildir?
    if ( -d "$target/tmp" && -d "$target/new" ) {
	my $msg_file = "/${\time}.$$.$pm_hostname";
	my $tmp_path = "$target/tmp/$msg_file";
	my $new_path = "$target/new/$msg_file";
	pm_log(3,"Looks like maildir, writing to $new_path");

	# since mutt won't add a lines tag to maildir messages,
	# we'll add it here
	unless ( pm_gethdr("lines") ) {
	    my $body = $m_obj->body;
	    my $num_lines = @$body;
	    $m_head->add("Lines", $num_lines);
	    pm_log(4,"Adding Lines: $num_lines header");
	}
	my $tmp = _new_fh();
	unless (open ($tmp, ">$tmp_path") ) {
	    pm_log(0,"Couldn't open $tmp_path! $!");
	    exit TEMPFAIL;
	}
	print $tmp ($m_obj->as_mbox_string);
	close($tmp);

	unless ( $test ) {
	    unless (link($tmp_path, $new_path) ) {
		pm_log(0,"Couldn't link $tmp_path to $new_path : $!");
		exit TEMPFAIL;
	    }
	}
	unlink($tmp_path) or pm_log(1,"Couldn't unlink $tmp_path: $!");
    }
    else {
	# It's an mbox, I hope.
	my $fh = _new_fh();
	unless (open($fh, ">>$target")) {
	    pm_log(0,"Couldn't open $target! $!");
	    exit TEMPFAIL;
	}
	flock($fh, LOCK_EX)
	    or pm_log(1,"Couldn't get exclusive lock on $target");
	seek($fh, 0, 2);	# make sure we're still at the end
	print $fh ($m_obj->as_mbox_string) unless $test;
	flock($fh, LOCK_UN)
	    or pm_log(1,"Couldn't unlock on $target");
	close($fh);
    }
    exit DELIVERED unless $atts{continue};
}



sub pm_pipe_to {
    my ($target, %atts) = @_;
    my $line = (caller(0))[2];
    pm_log(2, "pipe_to[$line]: $target "._pm_msg_size());

    my $lock;
    my $lockfile = $atts{lockfile};
    $lock = pm_lockfile($lockfile) if $lockfile;
    local ($SIG{PIPE}) = 'IGNORE';
    my $ret = 0;
    eval {
	$ret = undef;
	my $pipe = _new_fh();
	open ($pipe, "|".$target)
	  && $m_obj->print($pipe)
	    && close ($pipe);
	$ret = $?;
    } unless $test && !$atts{testalso};

    pm_unlockfile($lock);
    $ret = 0 if $ret < 0;	# broken pipe
    pm_log (2, "pipe_to[$line]: command result = ".
	    (defined $ret ? sprintf("0x%x", $ret) : "undef").
	    ($! ? ", \$! = $!" : "").
	    ($@ ? ", \$@ = $@" : ""))
      unless defined $ret && $ret == 0;
    return $ret if $atts{continue};
    exit DELIVERED;
}


sub pm_command {
    my ($target, %atts) = @_;
    my $line = (caller(0))[2];
    pm_log(2, "command[$line]: $target "._pm_msg_size());

    my $lock;
    my $lockfile = $atts{lockfile};
    $lock = pm_lockfile($lockfile) if $lockfile;
    my $ret = 0;
    $ret = system($target) unless $atts{testalso};
    pm_unlockfile($lock);
    pm_log (2, "command[$line]: command result = ".
	    (defined $ret ? sprintf("0x%x", $ret) : "undef"))
      unless defined $ret && $ret == 0;
    $ret;
}


sub pm_resend {
    my ($target, %atts) = @_;
    my $line = (caller(0))[2];
    pm_log(2, "resend[$line]: $target "._pm_msg_size());
    $m_obj->smtpsend(To => $target) unless $test;
    exit DELIVERED unless $atts{continue};
}


sub pm_reject {
    my $reason = shift;
    my $line = (caller(0))[2];
    pm_log(2, "reject[$line]: $reason "._pm_msg_size());
    print STDERR ($reason, "\n") unless lc $logfile eq 'stderr';
    exit REJECTED;
}



sub pm_ignore {
    my $reason = shift;
    my $line = (caller(0))[2];
    pm_log(2, "ignore[$line]: $reason "._pm_msg_size());
    exit DELIVERED;
}


sub pm_dupcheck {
    my ($msgid) = shift;
    my (%atts) = (dbm => $ENV{HOME}."/.msgids",
		  retain => 14,
		  @_);
    my $dbm = $atts{dbm};

    my %msgid;
    my $dup = 0;
    if ( dbmopen(%msgid, $dbm, 0660) ) {
	my $tmp;
	if ( defined($tmp = $msgid{$msgid}) ) {
	    if ( ($msgid{$msgid} = time) - $tmp < $atts{retain}*24*60*60 ) {
		my $line = (caller(0))[2];
		pm_log(2, "dup[$line]: $msgid "._pm_msg_size());
		$dup++;
	    }
	}
	else {
	    $msgid{$msgid} = time;
	}
	dbmclose(%msgid)
	  or pm_log(0, "Error closing $dbm: $!");
    }
    else {
	pm_log(0, "Error opening $dbm: $!");
    }
    exit DELIVERED
      if $dup && !$atts{continue};
    $dup;
}


my $lockmgr;
sub pm_lockfile {
    my ($file) = @_;

    $lockmgr = LockFile::Simple->make(-hold => 600, -stale => 1,
				      -autoclean => 1, 
				      -wfunc => sub { pm_log(2,@_) },
				      -efunc => sub { pm_log(0,@_) },
				     )
      unless $lockmgr;

    $lockmgr->lock($file, "%f");
}


sub pm_unlockfile {
    shift->release if $_[0];
}


my $logfh;
sub pm_log {
    return unless $logfile;
    return if shift > $loglevel;

    # Use sysopen/syswrite for atomicity.
    unless ( $logfh ) {
	$logfh = _new_fh();
	print STDERR ("Opening logfile $logfile\n") if $debug;
	if ( lc($logfile) eq "stderr" ) {
	    open ($logfh, ">&STDERR");
	}
	elsif ( lc($logfile) eq "stdout" || $logfile eq "-" ) {
	    open ($logfh, ">&STDOUT");
	}
	else {
	    sysopen ($logfh, $logfile, O_WRONLY|O_CREAT|O_APPEND)
	      || print STDERR ("$logfile: $!\n");
	}
    }
    my @tm = localtime;
    my $msg = sprintf ("%04d%02d%02d%02d%02d%02d.%05d %s\n",
		       $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0],
		       $$, "@_");
    print STDERR ($msg) if $debug;
    syswrite ($logfh, $msg);
}

sub _new_fh {
    return if $] >= 5.006;	# 5.6 will take care itself
    require IO::File;
    IO::File->new();
}

################ Reporting ################


sub pm_report {

    my (%atts) = @_;
    my $logfile = delete($atts{logfile});

    local (@ARGV) = $logfile ? ($logfile) : @ARGV;

    my %tally;			# master array with data
    my $max1 = 0;		# max. delivery
    my $max2 = 0;		# max. delivery / rule
    my $max3 = 0;		# max length of rules
    my $recs = 0;		# records in file
    my $msgs = 0;		# messages
    my $dlvr = 0;		# deliveries

    while ( <> ) {
	$recs++;

	# Tally number of incoming messages.
	$msgs++, next if /^\d+\.\d+ Mail from/;

	# Skip non-deliveries.
	next unless /^\d+\.\d+ (\w+\[[^\]]+\]):\s+(.+)/;
	$dlvr++;

	# Update stats and keep track of max values.
	my $t;
	$max1 = $t if ($t = ++$tally{$2}->[0]) > $max1;
	$max2 = $t if ($t = ++$tally{$2}->[1]->{$1}) > $max2;
	$max3 = $t if ($t = length($1)) > $max3;
    }

    print STDOUT ("$recs records, $msgs messages, $dlvr deliveries.\n\n");

    # Construct format for report.
    $max1 = length($max1);
    $max2 = length($max2);
    my $fmt = "%${max1}s  %${max2}s  %-${max3}s  %s\n";

    # Sort on number of deliveries per target.
    foreach my $dest ( sort { $b->[1] <=> $a->[1] }
		          map { [ $_, $tally{$_}->[0], $tally{$_}->[1] ] }
			     keys %tally ) {
	my $first = 1;
	# Sort on deliveries per rule.
	foreach my $rule ( sort { $b->[1] <=> $a->[1] }
			      map { [ $_, $dest->[2]->{$_} ] }
			         keys %{$dest->[2]} ) {
	    printf STDOUT ($fmt,
			   ($first ? $dest->[1] : ""),
			   $rule->[1],
			   $rule->[0],
			   ($first ? $dest->[0] : ""));
	    $first = 0;
	}
    }

}


1;

# Local Variables:
# compile-command: "perl -wc -Mlib=$HOME/lib/perl5 Procmail.pm && install -m 0555 Procmail.pm $HOME/lib/perl5/Mail/Procmail.pm"
# End: