view release on metacpan or  search on metacpan

lib/Mail/Procmail.pm  view on Meta::CPAN

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!

=head1 NAME

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

=head1 SYNOPSIS

    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);

=head1 DESCRIPTION

F<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 C<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.

C<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 F<.forward> or F<.procmailrc> file, or similar.

=head1 DIFFERENCES WITH MAIL::AUDIT

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

=over

=item General

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

=item Delivery

Each of the delivery methods is able to continue (except
I<pm_reject> and I<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.

lib/Mail/Procmail.pm  view on Meta::CPAN

	    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 : '';
}

=head2 pm_gethdr_raw

Like pm_gethdr, but without whitespace cleanup.

=cut

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 : '';
}

=head2 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

=cut

sub pm_body {
    $m_obj->body;
}

=head2 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
C<.lock> extension, is I<not> supported.

Example:

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

Attributes:

=over

=item *

continue

If true, processing will continue after delivery. Otherwise the
program will exit with a DELIVERED status.

=back

=cut

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")) {