File Coverage

blib/lib/Email/Fingerprint.pm

Criterion	Covered	Total	%
statement	164	165	99.3
branch	40	42	95.2
condition	13	15	86.6
subroutine	37	37	100.0
pod	8	8	100.0
total	262	267	98.1

package Email::Fingerprint;

use warnings;
use strict;

use Class::Std;

use Carp qw( croak );
use overload;
use Mail::Header;
use Scalar::Util qw( blessed reftype );
use List::MoreUtils qw( apply );

=head1 NAME

Email::Fingerprint - Calculate a digest for recognizing duplicate emails

=head1 VERSION

Version 0.49

=cut

our $VERSION = '0.49';

=head1 SYNOPSIS

Email::Fingerprint calculates a checksum that uniquely identifies an email,
for use in spotting duplicate messages. The checksum is based on: the
Message-ID: header; or if it doesn't exist, on the Date:, From:,
To: and Cc: headers together; or if those don't exist, on the body of the
message.

    use Email::Fingerprint;

    my $foo = Email::Fingerprint->new();
    ...

=head1 ATTRIBUTES

=cut

my %header          : ATTR( :get );         # Header and body are
my %body            : ATTR( :get );           # read-only fields
my %input           : ATTR( :init_arg :get :default(0) );
my %strict_checking : ATTR( :name  :default(0) );
my %checksum        : ATTR( :get :default('unpack') );

=head1 FUNCTIONS

=head2 new

    $fp = new Email::Fingerprint({
        input           => \*INPUT,         # Or $string, \@lines, etc.
        checksum        => "Digest::SHA",   # Or "Digest::MD5", etc.
        strict_checking => 1,               # If true, use message bodies
        %mail_header_opts,
    });

Create a new fingerprinting object. If the C option is used,
C attempts to intelligently read the email message
given by that option, whether it's a string, an array of lines or a
filehandle.

If C<$opts{checksum}> is not supplied, then C will use
the first checksum module that it finds. If it finds no modules, it will
use C in a ghastly manner you don't want to think about.

Any C<%opts> are also passed along to Cnew>; see the
perldoc for C options.

=cut

sub BUILD {
    my ( $self, $ident, $args ) = @_;

    $self->set_checksum( $args->{checksum} || 'unpack' );

    # Try to be "smart" and input the message by hook or by crook.
    # Here we do something slightly nasty, and let Mail::Header see our
    # args.
    $self->read( $args->{input}, $args ) if exists $args->{input};
}

=head2 checksum

    # Uses original/default settings to take checksum
    $checksum = $fp->checksum;

    # Can use any options accepted by constructor
    $options  = {
        input           => \*INPUT,         # Or $string, \@lines, etc.
        checksum        => "Digest::SHA",   # Or "Digest::MD5", etc.
        strict_checking => 1,               # If true, use message bodies
        %mail_header_opts,
    };

    # Overrides one or more original/default settings
    $checksum = $fp->checksum($options);

Calculates the actual email fingerprint. The optional hashref
argument will permanently override the object's previous settings.

=cut

sub checksum {
    my $self = shift;
    my %opts = %{ shift || {} };

    # Optionally override strict checking
    $self->set_strict_checking($opts{strict_checking})
        if exists $opts{strict_checking};

    # Optionally override the checksum to use
    $self->set_checksum($opts{checksum}) if exists $opts{checksum};

    # Optionally read a new email message
    $self->read( $opts{input}, \%opts ) if exists $opts{input};

    # It's an error to call checksum without first loading a message.
    croak "No mesage loaded for checksum" unless $self->message_loaded;

    my $module = $self->get_checksum;
    my $header = $self->_extract_headers;
    my $body   = $self->get_strict_checking ? $self->_extract_body : "";

    # Only here for backward compatibility!
    if ( not $module or $module eq 'unpack' ) {
        return unpack("%32C*", $header . $body);
    }

    my $digest = $module->new;

    $digest->add( $header . $body );

    return $digest->hexdigest;
}

=head2 read

  $fingerprint->read_string( $email );
  $fingerprint->read_string( $email, \%mh_args );

Accepts the email message C<$email> and attempts to read it
intelligently, distinguishing strings, array references and file
handles.  If supplied, the optional hash reference is passed on to
Mail::Header.

=cut

sub read {
    my ( $self, $input, $mh_args ) = @_;

    if ( not ref $input ) {

        # Simple case: scalars are treated as strings.
        return $self->read_string( $input );
    }
    elsif ( ref $input eq 'ARRAY' ) {

        # Another simple case: array references
        return $self->read_arrayref( $input, $mh_args );
    }
    elsif ( reftype $input eq 'GLOB' ) {

        # Also simple: filehandle. Using Scalar::Util::reftype()
        # instead of ref() quietly does the right thing, e.g., for
        # FileHandle objects, which are blessed GLOB references.
        return $self->read_filehandle( $input, $mh_args );
    }

    # If execution gets this far, $input had better be an object.
    # None of Perl's other types are supported.
    if ( not blessed $input ) {
        croak "Unknown input type: ", ref $input;
    }

    if ( overload::Method( $input, '""' ) ) {

        # Treat it as a string
        return $self->read_string( $input, $mh_args );
    }
    elsif ( overload::Method( $input, '<>' ) ) {

        # Treat it as a filehandle
        return $self->read_filehandle( $input, $mh_args );
    }

    # OK, I give up.
    croak "Unknown input type: ", ref $input;
}

=head2 read_string

  $fingerprint->read_string( $email_string );
  $fingerprint->read_string( $email_string, \%mh_args );

Accepts the email message C<$email_string> and prepares it for
checksum computation. If supplied, the optional hashref is passed
on to Mail::Header.

=cut

sub read_string {
    my ( $self, $message, $mh_args ) = @_;

    # Split the stringified message into an array of lines.  We can't use
    # split(/\n/,$input); that would discard trailing blank lines.
    $message = [ "$message" =~ m{ ( ^ [^\n]* \n? ) }xmg ];

    # Now delegate
    return $self->read_arrayref( $message, $mh_args );
}

=head2 read_filehandle

  $fingerprint->read_filehandle( $email_fh );
  $fingerprint->read_filehandle( $email_fh, \%mh_args );

Accepts the email message C<$email_fh> and prepares it for checksum
computation. If supplied, the optional hashref is passed on to
Mail::Header.

=cut

sub read_filehandle {
    my ( $self, $message, $mh_args ) = @_;

    # Slurp everything into an arrayref
    $message = [ <$message> ];

    # Now delegate
    return $self->read_arrayref( $message, $mh_args );
}

=head2 read_arrayref

  $fingerprint->read_arrayref( \@email_lines );
  $fingerprint->read_arrayref( \@email_lines, \%mh_args );

Accepts the email message C<\@email_lines> and prepares it for
checksum computation. If supplied, the optional hashref is passed
on to Mail::Header.

=cut

sub read_arrayref {
    my ( $self, $message, $mh_args ) = @_;
    $mh_args ||= {};

    # Prepare args to pass on to Mail::Header constructor. The ordering
    # below causes $mh_args to override the default settings in this
    # hashref.
    $mh_args = {
        Modify   => 0,          # Don't mess with the header.
        MailFrom => 'IGNORE',   # Accept message in mbox format.
        %$mh_args,
    };

    # Initializations. This is the ONLY method that sets the
    # "input" and "header" fields.
    $header{ ident $self } = Mail::Header->new( $message, %$mh_args );
    $input{ ident $self }  = $message;
    delete $body{ ident $self };
}

=head2 message_loaded

Returns true if an email message has been loaded and is ready for checksum,
or false if no message has been loaded or an error has occurred.

=cut

sub message_loaded {
    my $self = shift;

    return defined $self->get_header ? 1 : 0;
}

=head2 set_checksum

Specifies the checksum method to be used.

=cut

sub set_checksum {
    my ( $self, $checksum )  = @_;
    $checksum{ ident $self } = $checksum;

    return if not $checksum or $checksum eq 'unpack';

    eval "use $checksum";   ## no critic
    croak "Invalid checksum: $checksum\n" if $@;
}

=head1 INTERNAL METHODS

=head2 BUILD

A constructor helper method called from the C framework. To
execute C, use C.

=head2 _extract_headers

Extract the Message-ID: header. If that does not exist, extract
the Date:, From:, To: and Cc: headers. If those do not exist, then
force strict checking so that the message body will be
fingerprinted.

=cut

sub _extract_headers :RESTRICTED {
    my $self = shift;

    my $raw  = $self->get_header->header_hashref;

    my %headers;

    my $extracted_headers = "";

    map { my $key = lc( $_ ); $headers{$key} = $raw->{$_} } keys %$raw;

    if (defined $headers{'message-id'}) {
        $extracted_headers .= $self->_concat( $headers{'message-id'} );
    }
    else {
        foreach my $h ('date', 'from', 'to', 'cc') {
            next unless exists $headers{$h};

            $extracted_headers .= $self->_concat( $headers{$h}, "$h:" );
        }
    }

    $self->set_strict_checking(1) unless $extracted_headers;
    return $extracted_headers;
}

=head2 _extract_body

    $body = $fp->_extract_body;

Gets the body of the message, as a string. Line-endings are preserved, so
the body can, e.g., be printed.

This method must only be called after a message has been read. No
validation is done in the method itself, so this is the user's
responsibility.

=cut

sub _extract_body :RESTRICTED {

    my $self = shift;

    # Use the cached body, if any
    my $body = $self->get_body;
    return $body if defined $body;

    my $input = $self->get_input;

    # Copy the message. We don't want to munge the original!
    my @message = @$input;

    my $line;

    # Discard the RFC822 header. Perhaps not as bullet-proof
    # as it could be...
    do { $line = shift @message } while ( $line and $line !~ m{ ^$ }xmsg );

    $body .= join "", @message;

    # Cache the body for reuse. This is the ONLY method that sets the
    # "body" field.
    $body{ident $self} = $body;

    return $body;
}

=head2 _concat

  @headers = qw( [e-mail] [e-mail] );
  $delim   = 'To:';
  $string  = $fp->_concat( \@headers, $delim );

  # $string is now 'To:[e-mail]:[e-mail]'

Returns the concatenation of C<\@headers>, with C<$delim> prepended
to each element of C<\@headers>. If C<$delim> is omitted, the empty
string is used. C<\@headers> elements are all chomped before
concatenation.

=cut

sub _concat :PRIVATE {
    my $self  = shift;
    my $data  = shift;
    my $delim = shift || "";

    return $delim . join($delim, apply {chomp } @$data);
}

=head1 AUTHOR

Len Budney, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
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

L

=item * CPAN Ratings

L

=item * RT: CPAN's request tracker

L

=item * Search CPAN

L

=back

=head1 SEE ALSO

See B for options governing the parsing of email headers.

=head1 ACKNOWLEDGEMENTS

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

=head1 COPYRIGHT & LICENSE

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.

=cut

1; # End of Email::Fingerprint