package Email::Fingerprint::App::EliminateDups;

use warnings;
use strict;

use Class::Std;

use Carp qw( croak );
use File::Basename;
use Getopt::Long;

use Email::Fingerprint;
use Email::Fingerprint::Cache;

=head1 NAME

Email::Fingerprint::App::EliminateDups - Implements eliminate-dups functionality

=head1 VERSION

Version 0.49


our $VERSION = '0.49';


See the manpage for C<eliminate-dups>. This module is not intended to be
used except by that script.


# Attributes

my %dbname      : ATTR( :get<dbname> );                 # Fingerprint DB name
my %cache       : ATTR( :get<cache> );                  # Actual fingerprint DB

my %dump        : ATTR( :get<dump>,     :default<0> );  # Dump cache contents
my %help        : ATTR( :get<help>,     :default<0> );  # Print usage
my %no_check    : ATTR( :get<no_check>, :default<0> );  # Only purge
my %no_purge    : ATTR( :get<no_purge>, :default<0> );  # Only check
my %strict      : ATTR( :get<strict>,   :default<0> );  # Include body

=head1 METHODS

=head2 new

  $app = new Email::Fingerprint::App::EliminateDups;

Create a new object. Takes no options.

=head2 BUILD

Internal helper method, not called by external users.

sub BUILD {
    my ($self, $obj_ID, $arg_ref) = @_;


=head2 run


Run the eliminate-dups application.


sub run {
    my $self = shift;

    $self->dump_cache;              # No-op if --dump wasn't specified
    $self->check_fingerprint;       # No-op if --no-check option was specified
    $self->purge_cache;             # No-op if --no-purge option was specified

    # Success
    exit 0;

=head2 open_cache

Initialize, open and lock the cache.


sub open_cache {
    my $self   = shift;
    my $cache  = $self->get_cache;
    my $dbname = $self->get_dbname || '';

    return $cache if $cache;

    # Initialize the cache
    $cache    = new Email::Fingerprint::Cache({
        file     => $dbname,

    # Validate
    if ( not $cache ) {
        $self->_exit_retry( "Couldn't initialize cache \"$dbname\"" );

    # Lock it
    if ( not $cache->lock( block => 1 ) ) {
        $self->_exit_retry( "Couldn't lock \"$dbname\": $!" );

    # Open it
    if ( not $cache->open ) {
        $self->_exit_retry( "Couldn't open \"$dbname\": $!" );

    $cache{ ident $self } = $cache;
    return $cache;

=head2 close_cache

Close and unlock the cache.


sub close_cache {
    my $self  = shift;
    my $cache = delete $cache{ ident $self };

    if ($cache) {


=head2 dump_cache

Conditionally dump the cache contents and exit.


sub dump_cache {
    my $self = shift;

    return unless $self->get_dump;
    return unless $self->get_cache;

    # Dump the contents of the hashfile in a human readable format

    exit 0;

=head2 check_fingerprint

Conditionally check the fingerprint of the message on STDIN.


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.
        exit 99;

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

=head2 purge_cache

Purge the cache of old entries.


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


=head2 _process_options

Process command-line options.


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

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


    $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


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.


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

         "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.


sub _exit_retry :PRIVATE {
    my ( $self, $message ) = @_;

    warn "$message\n";
    exit 111;

=head1 AUTHOR

Len Budney, C<< <lbudney at> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-email-fingerprint at>, or through the web interface at
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Email::Fingerprint

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation


=item * CPAN Ratings


=item * RT: CPAN's request tracker


=item * Search CPAN



=head1 SEE ALSO

See B<Mail::Header> for options governing the parsing of email headers.


Email::Fingerprint is based on the C<eliminate_dups> script by Peter Samuel
and available at L<>.


Copyright 2006-2011 Len Budney, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


1; # End of Email::Fingerprint