view release on metacpan or  search on metacpan

lib/Email/Fingerprint/App/EliminateDups.pm  view on Meta::CPAN

    $self->close_cache;
    exit 0;
}

=head2 check_fingerprint

Conditionally check the fingerprint of the message on STDIN.

=cut

sub check_fingerprint {
    my $self = shift;

    return if $self->get_no_check;

    my $checksum =  new Email::Fingerprint({
        input           => \*STDIN,
        checksum        => "Digest::MD5",
        strict_checking => $self->get_strict,
    });

    my $fingerprint = $checksum->checksum;

    # If there's a match, suppress it with exit code 99.
    if (defined $self->get_cache->get_hash->{$fingerprint})
    {
        # Fingerprint matches. Tell qmail to stop current delivery.
        $self->close_cache;
        exit 99;
    }

    # Record the fingerprint
    $self->get_cache->get_hash->{$fingerprint} = time;
}

=head2 purge_cache

Purge the cache of old entries.

=cut

sub purge_cache {
    my $self = shift;
    
    return if $self->get_no_purge;

    $self->get_cache->purge;
}

=head2 _process_options

Process command-line options.

=cut

sub _process_options :PRIVATE {
    my ( $self, @args ) = @_;

    # Fool Getopt::Long. Sigh.
    local @ARGV = @args;

    $self->_init;

    $self->_die_usage if not GetOptions(
        "dump"      => \$dump{ident $self},
        "no-purge"  => \$no_purge{ident $self},
        "no-check"  => \$no_check{ident $self},
        "strict"    => \$strict{ident $self},
        "help"      => \$help{ident $self},
    );

    # Respond to calls for help
    $self->_die_usage if $self->get_help;

    # Set the filename. If omitted, a default is used.
    $dbname{ident $self} = shift @ARGV if @ARGV;
}

=head2 _init

Basic initializer. Called from C<BUILD> and also from
C<_process_options>.

=cut

sub _init :PRIVATE {
    my $self   = shift;
    my $obj_ID = ident $self;

    $dbname{$obj_ID}   = '.maildups';
    $self->close_cache; # A no-op if we don't have a cache yet

    $dump{$obj_ID}     = 0;
    $help{$obj_ID}     = 0;
    $no_purge{$obj_ID} = 0;
    $no_check{$obj_ID} = 0;
    $strict{$obj_ID}   = 0;
}

=head2 die_usage

Exit with a usage message.

=cut

sub _die_usage :PRIVATE {
    my $self     = shift;
    my $progname = basename $0;

    $self->_exit_retry(
         "usage:\t$progname [--strict] [--no-purge] [hashfile]\n"
       . "\t$progname [--dump] [hashfile]\n"
       . "\t$progname [--no-check] [hashfile]"
    );
}

=head2 _exit_retry

Exit with qmail's "temporary error" status code. This forces qmail to
abort delivery attempts and try again later.