File Coverage

blib/lib/Email/Filter.pm

Criterion	Covered	Total	%
statement	63	88	71.5
branch	9	24	37.5
condition	3	11	27.2
subroutine	16	24	66.6
pod	9	13	69.2
total	100	160	62.5

use strict;
package Email::Filter;
{
  $Email::Filter::VERSION = '1.034';
}
# 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;


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


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


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


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


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


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


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


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


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


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


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__