File Coverage

blib/lib/Email/Filter.pm

Criterion	Covered	Total	%
statement	63	88	71.5
branch	9	24	37.5
condition	2	11	18.1
subroutine	16	24	66.6
pod	9	13	69.2
total	99	160	61.8

use strict;
package Email::Filter 1.035;
# ABSTRACT: Library for creating easy email filters

use Email::LocalDelivery;
use Email::Simple;
use Class::Trigger;
use IPC::Run qw(run);

use constant DELIVERED => 0;
use constant TEMPFAIL  => 75;
use constant REJECTED  => 100;

#pod =head1 SYNOPSIS
#pod
#pod     use Email::Filter;
#pod     my $mail = Email::Filter->new(emergency => "~/emergency_mbox");
#pod     $mail->pipe("listgate", "p5p")         if $mail->from =~ /perl5-porters/;
#pod     $mail->accept("perl")                  if $mail->from =~ /perl/;
#pod     $mail->reject("We do not accept spam") if $mail->subject =~ /enlarge/;
#pod     $mail->ignore                          if $mail->subject =~ /boring/i;
#pod     ...
#pod     $mail->exit(0);
#pod     $mail->accept("~/Mail/Archive/backup");
#pod     $mail->exit(1);
#pod     $mail->accept()
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module replaces C or C, and allows you to write
#pod programs describing how your mail should be filtered.
#pod
#pod =head1 TRIGGERS
#pod
#pod Users of C will note that this class is much leaner than
#pod the one it replaces. For instance, it has no logging; the concept of
#pod "local options" has gone away, and so on. This is a deliberate design
#pod decision to make the class as simple and maintainable as possible.
#pod
#pod To make up for this, however, C contains a trigger
#pod mechanism provided by L, to allow you to add your own
#pod functionality. You do this by calling the C method:
#pod
#pod     Email::Filter->add_trigger( after_accept => \&log_accept );
#pod
#pod Hopefully this will also help subclassers.
#pod
#pod The methods below will list which triggers they provide.
#pod
#pod =head1 ERROR RECOVERY
#pod
#pod If something bad happens during the C or C method, or
#pod the C object gets destroyed without being properly
#pod handled, then a fail-safe error recovery process is called. This first
#pod checks for the existence of the C setting, and tries to
#pod deliver to that mailbox. If there is no emergency mailbox or that
#pod delivery failed, then the program will either exit with a temporary
#pod failure error code, queuing the mail for redelivery later, or produce a
#pod warning to standard error, depending on the status of the C
#pod setting.
#pod
#pod =cut

sub done_ok {
    my $self = shift;
    $self->{delivered} = 1;
    exit DELIVERED unless $self->{noexit};
}

sub fail_badly {
    my $self = shift;
    $self->{giveup} = 1; # Don't get caught by DESTROY
    exit TEMPFAIL unless $self->{noexit};
    warn "Message ".$self->simple->header("Message-ID").
          "was never handled properly\n";
}

sub fail_gracefully {
    my $self = shift;
    our $FAILING_GRACEFULLY;
    if ($self->{emergency} and ! $FAILING_GRACEFULLY) {
      local $FAILING_GRACEFULLY = 1;
      $self->done_ok if $self->accept($self->{emergency});
    }
    $self->fail_badly;
}

sub DESTROY {
    my $self = shift;
    return if $self->{delivered}   # All OK.
           or $self->{giveup}      # Tried emergency, didn't work.
           or !$self->{emergency}; # Not much we can do.
    $self->fail_gracefully();
}

#pod =method new
#pod
#pod     Email::Filter->new();                # Read from STDIN
#pod     Email::Filter->new(data => $string); # Read from string
#pod
#pod     Email::Filter->new(emergency => "~simon/urgh");
#pod     # Deliver here in case of error
#pod
#pod This takes an email either from standard input, the usual case when
#pod called as a mail filter, or from a string.
#pod
#pod You may also provide an "emergency" option, which is a filename to
#pod deliver the mail to if it couldn't, for some reason, be handled
#pod properly.
#pod
#pod =over 3
#pod
#pod =item Hint
#pod
#pod If you put your constructor in a C block, like so:
#pod
#pod     use Email::Filter;
#pod     BEGIN { $item = Email::Filter->new(emergency => "~simon/urgh"); }
#pod
#pod right at the top of your mail filter script, you'll even be protected
#pod from losing mail even in the case of syntax errors in your script. How
#pod neat is that?
#pod
#pod =back
#pod
#pod This method provides the C trigger, called once an object is
#pod instantiated.
#pod
#pod =cut

sub new {
    my $class = shift;
    my %stuff = @_;
    my $data;

    {
      local $/;
      $data = exists $stuff{data} ? $stuff{data} : scalar ;
      # shave any leading From_ line
      $data =~ s/^From .*?[\x0a\x0d]//
    }

    my $obj = bless {
        mail       => Email::Simple->new($data),
        emergency  => $stuff{emergency},
        noexit     => ($stuff{noexit} || 0)
    }, $class;
    $obj->call_trigger("new");
    return $obj;
}

#pod =method exit
#pod
#pod     $mail->exit(1|0);
#pod
#pod Sets or clears the 'exit' flag which determines whether or not the
#pod following methods exit after successful completion.
#pod
#pod The sense-inverted 'noexit' method is also provided for backwards
#pod compatibility with C, but setting "noexit" to "yes" got a
#pod bit mind-bending after a while.
#pod
#pod =cut

sub exit { $_[0]->{noexit} = !$_[1]; }
sub noexit { $_[0]->{noexit} = $_[1]; }

#pod =method simple
#pod
#pod     $mail->simple();
#pod
#pod Gets and sets the underlying C object for this filter;
#pod see L for more details.
#pod
#pod =cut

sub simple {
    my ($filter, $mail) = @_;
    if ($mail) { $filter->{mail} = $mail; }
    return $filter->{mail};
}

#pod =method header
#pod
#pod     $mail->header("X-Something")
#pod
#pod Returns the specified mail headers. In scalar context, returns the
#pod first such header; in list context, returns them all.
#pod
#pod =cut

sub header { my ($mail, $head) = @_; $mail->simple->header($head); }

#pod =method body
#pod
#pod     $mail->body()
#pod
#pod Returns the body text of the email
#pod
#pod =cut

sub body { $_[0]->simple->body }

#pod =method from
#pod
#pod =method to
#pod
#pod =method cc
#pod
#pod =method bcc
#pod
#pod =method subject
#pod
#pod =method received
#pod
#pod     $mail->()
#pod
#pod Convenience accessors for C
#pod
#pod =cut

{   no strict 'refs';
    for my $head (qw(From To CC Bcc Subject Received)) {
        *{lc $head} = sub { $_[0]->header($head) }
    }
}

#pod =method ignore
#pod
#pod Ignores this mail, exiting unconditionally unless C has been set
#pod to false.
#pod
#pod This method provides the "ignore" trigger.
#pod
#pod =cut

sub ignore {
    $_[0]->call_trigger("ignore");
    $_[0]->done_ok;
}

#pod =method accept
#pod
#pod     $mail->accept();
#pod     $mail->accept(@where);
#pod
#pod Accepts the mail into a given mailbox or mailboxes.
#pod Unix C<~/> and C<~user/> prefices are resolved. If no mailbox is given,
#pod the default is determined according to L:
#pod C<$ENV{MAIL}>, F, F, or
#pod F<~you/Maildir/>.
#pod
#pod This provides the C and C triggers, and
#pod exits unless C has been set to false.  They are passed a reference to the
#pod C<@where> array.
#pod
#pod =cut

sub accept {
    my ($self, @where) = @_;
    $self->call_trigger("before_accept", \@where);
    # Unparsing and reparsing is so fast we prefer to do that in order
    # to keep to LocalDelivery's clean interface.
    if (Email::LocalDelivery->deliver($self->simple->as_string, @where)) {
        $self->call_trigger("after_accept", \@where);
        $self->done_ok;
    } else {
        $self->fail_gracefully();
    }
}

#pod =method reject
#pod
#pod     $mail->reject("Go away!");
#pod
#pod This rejects the email; if called in a pipe from a mail transport agent, (such
#pod as in a F<~/.forward> file) the mail will be bounced back to the sender as
#pod undeliverable. If a reason is given, this will be included in the bounce.
#pod
#pod This calls the C trigger. C has no effect here.
#pod
#pod =cut

sub reject {
    my $self = shift;
    $self->call_trigger("reject");
    $self->{delivered} = 1;
    $! = REJECTED; die @_,"\n";
}

#pod =method pipe
#pod
#pod     $mail->pipe(qw[sendmail foo\@bar.com]);
#pod
#pod Pipes the mail to an external program, returning the standard output
#pod from that program if C has been set to false. The program and each
#pod of its arguments must be supplied in a list. This allows you to do
#pod things like:
#pod
#pod     $mail->exit(0);
#pod     $mail->simple(Email::Simple->new($mail->pipe("spamassassin")));
#pod     $mail->exit(1);
#pod
#pod in the absence of decent C support.
#pod
#pod If the program returns a non-zero exit code, the behaviour is dependent
#pod on the status of the C flag. If this flag is set to true (the
#pod default), then C tries to recover. (See L)
#pod If not, nothing is returned.
#pod
#pod If the last argument to C is a reference to a hash, it is taken to
#pod contain parameters to modify how C itself behaves.  The only useful
#pod parameter at this time is:
#pod
#pod   header_only - only pipe the header, not the body
#pod
#pod =cut

sub pipe {
    my ($self, @program) = @_;
    my $arg;
    $arg = (ref $program[-1] eq 'HASH') ? (pop @program) : {};

    my $stdout;

    my $string = $arg->{header_only}
               ? $self->simple->header_obj->as_string
               : $self->simple->as_string;

    $self->call_trigger("pipe", \@program, $arg);
    if (eval {run(\@program, \$string, \$stdout)} ) {
        $self->done_ok;
        return $stdout;
    }
    $self->fail_gracefully() unless $self->{noexit};
    return;
}

1;

__END__