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


line stmt bran cond sub pod time code
1             package Email::Fingerprint;
2              
3 7     7   98670 use warnings;
  7         17  
  7         344  
4 7     7   39 use strict;
  7         11  
  7         222  
5              
6 7     7   19290 use Class::Std;
  7         204921  
  7         53  
7              
8 7     7   879 use Carp qw( croak );
  7         13  
  7         515  
9 7     7   38 use overload;
  7         12  
  7         66  
10 7     7   9782 use Mail::Header;
  7         46933  
  7         411  
11 7     7   169 use Scalar::Util qw( blessed reftype );
  7         15  
  7         1027  
12 7     7   7850 use List::MoreUtils qw( apply );
  7         9992  
  7         12313  
13              
14             =head1 NAME
15              
16             Email::Fingerprint - Calculate a digest for recognizing duplicate emails
17              
18             =head1 VERSION
19              
20             Version 0.47
21              
22             =cut
23              
24             our $VERSION = '0.47';
25              
26             =head1 SYNOPSIS
27              
28             Email::Fingerprint calculates a checksum that uniquely identifies an email,
29             for use in spotting duplicate messages. The checksum is based on: the
30             Message-ID: header; or if it doesn't exist, on the Date:, From:,
31             To: and Cc: headers together; or if those don't exist, on the body of the
32             message.
33              
34             use Email::Fingerprint;
35              
36             my $foo = Email::Fingerprint->new();
37             ...
38              
39             =head1 ATTRIBUTES
40              
41             =cut
42              
43             my %header : ATTR( :get
); # Header and body are
44             my %body : ATTR( :get ); # read-only fields
45             my %input : ATTR( :init_arg :get :default(0) );
46             my %strict_checking : ATTR( :name :default(0) );
47             my %checksum : ATTR( :get :default('unpack') );
48              
49             =head1 FUNCTIONS
50              
51             =head2 new
52              
53             $fp = new Email::Fingerprint({
54             input => \*INPUT, # Or $string, \@lines, etc.
55             checksum => "Digest::SHA", # Or "Digest::MD5", etc.
56             strict_checking => 1, # If true, use message bodies
57             %mail_header_opts,
58             });
59              
60             Create a new fingerprinting object. If the C option is used,
61             C attempts to intelligently read the email message
62             given by that option, whether it's a string, an array of lines or a
63             filehandle.
64              
65             If C<$opts{checksum}> is not supplied, then C will use
66             the first checksum module that it finds. If it finds no modules, it will
67             use C in a ghastly manner you don't want to think about.
68              
69             Any C<%opts> are also passed along to Cnew>; see the
70             perldoc for C options.
71              
72             =cut
73              
74             sub BUILD {
75 80     80 1 103277 my ( $self, $ident, $args ) = @_;
76              
77 80   100     412 $self->set_checksum( $args->{checksum} || 'unpack' );
78              
79             # Try to be "smart" and input the message by hook or by crook.
80             # Here we do something slightly nasty, and let Mail::Header see our
81             # args.
82 80 100       379 $self->read( $args->{input}, $args ) if exists $args->{input};
83             }
84              
85             =head2 checksum
86              
87             # Uses original/default settings to take checksum
88             $checksum = $fp->checksum;
89              
90             # Can use any options accepted by constructor
91             $options = {
92             input => \*INPUT, # Or $string, \@lines, etc.
93             checksum => "Digest::SHA", # Or "Digest::MD5", etc.
94             strict_checking => 1, # If true, use message bodies
95             %mail_header_opts,
96             };
97              
98             # Overrides one or more original/default settings
99             $checksum = $fp->checksum($options);
100              
101             Calculates the actual email fingerprint. The optional hashref
102             argument will permanently override the object's previous settings.
103              
104             =cut
105              
106             sub checksum {
107 142     142 1 47296 my $self = shift;
108 142 100       239 my %opts = %{ shift || {} };
  142         1166  
109              
110             # Optionally override strict checking
111 142 100       835 $self->set_strict_checking($opts{strict_checking})
112             if exists $opts{strict_checking};
113              
114             # Optionally override the checksum to use
115 142 100       820 $self->set_checksum($opts{checksum}) if exists $opts{checksum};
116              
117             # Optionally read a new email message
118 142 100       805 $self->read( $opts{input}, \%opts ) if exists $opts{input};
119              
120             # It's an error to call checksum without first loading a message.
121 142 100       409 croak "No mesage loaded for checksum" unless $self->message_loaded;
122              
123 141         2351 my $module = $self->get_checksum;
124 141         1209 my $header = $self->_extract_headers;
125 141 100       964 my $body = $self->get_strict_checking ? $self->_extract_body : "";
126              
127             # Only here for backward compatibility!
128 141 100 66     958 if ( not $module or $module eq 'unpack' ) {
129 123         1878 return unpack("%32C*", $header . $body);
130             }
131              
132 18         109 my $digest = $module->new;
133              
134 18         146 $digest->add( $header . $body );
135              
136 18         206 return $digest->hexdigest;
137             }
138              
139             =head2 read
140              
141             $fingerprint->read_string( $email );
142             $fingerprint->read_string( $email, \%mh_args );
143              
144             Accepts the email message C<$email> and attempts to read it
145             intelligently, distinguishing strings, array references and file
146             handles. If supplied, the optional hash reference is passed on to
147             Mail::Header.
148              
149             =cut
150              
151             sub read {
152 69     69 1 3854 my ( $self, $input, $mh_args ) = @_;
153              
154 69 100       569 if ( not ref $input ) {
    100          
    100          
155              
156             # Simple case: scalars are treated as strings.
157 26         103 return $self->read_string( $input );
158             }
159             elsif ( ref $input eq 'ARRAY' ) {
160              
161             # Another simple case: array references
162 26         93 return $self->read_arrayref( $input, $mh_args );
163             }
164             elsif ( reftype $input eq 'GLOB' ) {
165              
166             # Also simple: filehandle. Using Scalar::Util::reftype()
167             # instead of ref() quietly does the right thing, e.g., for
168             # FileHandle objects, which are blessed GLOB references.
169 13         84 return $self->read_filehandle( $input, $mh_args );
170             }
171              
172             # If execution gets this far, $input had better be an object.
173             # None of Perl's other types are supported.
174 4 100       21 if ( not blessed $input ) {
175 2         43 croak "Unknown input type: ", ref $input;
176             }
177              
178 2 100       13 if ( overload::Method( $input, '""' ) ) {
    50          
179              
180             # Treat it as a string
181 1         54 return $self->read_string( $input, $mh_args );
182             }
183             elsif ( overload::Method( $input, '<>' ) ) {
184              
185             # Treat it as a filehandle
186 0         0 return $self->read_filehandle( $input, $mh_args );
187             }
188              
189             # OK, I give up.
190 1         3995 croak "Unknown input type: ", ref $input;
191             }
192              
193             =head2 read_string
194              
195             $fingerprint->read_string( $email_string );
196             $fingerprint->read_string( $email_string, \%mh_args );
197              
198             Accepts the email message C<$email_string> and prepares it for
199             checksum computation. If supplied, the optional hashref is passed
200             on to Mail::Header.
201              
202             =cut
203              
204             sub read_string {
205 45     45 1 2480 my ( $self, $message, $mh_args ) = @_;
206              
207             # Split the stringified message into an array of lines. We can't use
208             # split(/\n/,$input); that would discard trailing blank lines.
209 45         26933 $message = [ "$message" =~ m{ ( ^ [^\n]* \n? ) }xmg ];
210              
211             # Now delegate
212 45         1070 return $self->read_arrayref( $message, $mh_args );
213             }
214              
215             =head2 read_filehandle
216              
217             $fingerprint->read_filehandle( $email_fh );
218             $fingerprint->read_filehandle( $email_fh, \%mh_args );
219              
220             Accepts the email message C<$email_fh> and prepares it for checksum
221             computation. If supplied, the optional hashref is passed on to
222             Mail::Header.
223              
224             =cut
225              
226             sub read_filehandle {
227 31     31 1 2297 my ( $self, $message, $mh_args ) = @_;
228              
229             # Slurp everything into an arrayref
230 31         6640 $message = [ <$message> ];
231              
232             # Now delegate
233 31         588 return $self->read_arrayref( $message, $mh_args );
234             }
235              
236             =head2 read_arrayref
237              
238             $fingerprint->read_arrayref( \@email_lines );
239             $fingerprint->read_arrayref( \@email_lines, \%mh_args );
240              
241             Accepts the email message C<\@email_lines> and prepares it for
242             checksum computation. If supplied, the optional hashref is passed
243             on to Mail::Header.
244              
245             =cut
246              
247             sub read_arrayref {
248 120     120 1 2560 my ( $self, $message, $mh_args ) = @_;
249 120   100     520 $mh_args ||= {};
250              
251             # Prepare args to pass on to Mail::Header constructor. The ordering
252             # below causes $mh_args to override the default settings in this
253             # hashref.
254 120         627 $mh_args = {
255             Modify => 0, # Don't mess with the header.
256             MailFrom => 'IGNORE', # Accept message in mbox format.
257             %$mh_args,
258             };
259              
260             # Initializations. This is the ONLY method that sets the
261             # "input" and "header" fields.
262 120         1034 $header{ ident $self } = Mail::Header->new( $message, %$mh_args );
263 120         284147 $input{ ident $self } = $message;
264 120         2978 delete $body{ ident $self };
265             }
266              
267             =head2 message_loaded
268              
269             Returns true if an email message has been loaded and is ready for checksum,
270             or false if no message has been loaded or an error has occurred.
271              
272             =cut
273              
274             sub message_loaded {
275 142     142 1 196 my $self = shift;
276              
277 142 100       606 return defined $self->get_header ? 1 : 0;
278             }
279              
280             =head2 set_checksum
281              
282             Specifies the checksum method to be used.
283              
284             =cut
285              
286             sub set_checksum {
287 122     122 1 222 my ( $self, $checksum ) = @_;
288 122         589 $checksum{ ident $self } = $checksum;
289              
290 122 100 66     1098 return if not $checksum or $checksum eq 'unpack';
291              
292 18     1   1785 eval "use $checksum"; ## no critic
  1     1   8  
  1     1   2  
  1     1   23  
  1     1   8  
  1     1   3  
  1     1   37  
  1     1   8  
  1     1   2  
  1     1   34  
  1     1   7  
  1     1   1  
  1     1   33  
  1     1   6  
  1     1   2  
  1     1   30  
  1     1   6  
  1     1   2  
  1         26  
  1         5  
  1         2  
  1         26  
  1         7  
  1         2  
  1         107  
  1         6  
  1         1  
  1         27  
  1         9  
  1         2  
  1         39  
  1         6  
  1         2  
  1         29  
  1         7  
  1         2  
  1         31  
  1         6  
  1         2  
  1         27  
  1         7  
  1         1  
  1         28  
  1         7  
  1         2  
  1         30  
  1         6  
  1         2  
  1         25  
  1         9  
  1         2  
  1         36  
  1         8  
  1         2  
  1         35  
293 18 50       71 croak "Invalid checksum: $checksum\n" if $@;
294             }
295              
296             =head1 INTERNAL METHODS
297              
298             =head2 BUILD
299              
300             A constructor helper method called from the C framework. To
301             execute C, use C.
302              
303             =head2 _extract_headers
304              
305             Extract the Message-ID: header. If that does not exist, extract
306             the Date:, From:, To: and Cc: headers. If those do not exist, then
307             force strict checking so that the message body will be
308             fingerprinted.
309              
310             =cut
311              
312             sub _extract_headers :RESTRICTED {
313 141         2992 my $self = shift;
314              
315 141         391 my $raw = $self->get_header->header_hashref;
316              
317 141         70314 my %headers;
318              
319 141         240 my $extracted_headers = "";
320              
321 141         1002 map { my $key = lc( $_ ); $headers{$key} = $raw->{$_} } keys %$raw;
  2054         2622  
  2054         5363  
322              
323 141 100       504 if (defined $headers{'message-id'}) {
324 93         448 $extracted_headers .= $self->_concat( $headers{'message-id'} );
325             }
326             else {
327 48         120 foreach my $h ('date', 'from', 'to', 'cc') {
328 192 100       798 next unless exists $headers{$h};
329              
330 38         175 $extracted_headers .= $self->_concat( $headers{$h}, "$h:" );
331             }
332             }
333              
334 141 100       776 $self->set_strict_checking(1) unless $extracted_headers;
335 141         1949 return $extracted_headers;
336 7     7   71 }
  7         16  
  7         72  
337              
338             =head2 _extract_body
339              
340             $body = $fp->_extract_body;
341              
342             Gets the body of the message, as a string. Line-endings are preserved, so
343             the body can, e.g., be printed.
344              
345             This method must only be called after a message has been read. No
346             validation is done in the method itself, so this is the user's
347             responsibility.
348              
349             =cut
350              
351             sub _extract_body :RESTRICTED {
352              
353 126         3250 my $self = shift;
354              
355             # Use the cached body, if any
356 126         433 my $body = $self->get_body;
357 126 100       753 return $body if defined $body;
358              
359 105         393 my $input = $self->get_input;
360              
361             # Copy the message. We don't want to munge the original!
362 105         7051 my @message = @$input;
363              
364 105         142 my $line;
365              
366             # Discard the RFC822 header. Perhaps not as bullet-proof
367             # as it could be...
368 105   100     136 do { $line = shift @message } while ( $line and $line !~ m{ ^$ }xmsg );
  37505         285863  
369              
370 105         341 $body .= join "", @message;
371              
372             # Cache the body for reuse. This is the ONLY method that sets the
373             # "body" field.
374 105         910 $body{ident $self} = $body;
375              
376 105         499 return $body;
377 7     7   5569 }
  7         17  
  7         117  
378              
379             =head2 _concat
380              
381             @headers = qw( foo@example.com bar@example.com );
382             $delim = 'To:';
383             $string = $fp->_concat( \@headers, $delim );
384              
385             # $string is now 'To:foo@example.comTo:bar@example.com'
386              
387             Returns the concatenation of C<\@headers>, with C<$delim> prepended
388             to each element of C<\@headers>. If C<$delim> is omitted, the empty
389             string is used. C<\@headers> elements are all chomped before
390             concatenation.
391              
392             =cut
393              
394             sub _concat :PRIVATE {
395 131         1085 my $self = shift;
396 131         304 my $data = shift;
397 131   100     503 my $delim = shift || "";
398              
399 131         1093 return $delim . join($delim, apply {chomp } @$data);
  131         806  
400 7     7   4023 }
  7         17  
  7         34  
401              
402             =head1 AUTHOR
403              
404             Len Budney, C<< >>
405              
406             =head1 BUGS
407              
408             Please report any bugs or feature requests to
409             C, or through the web interface at
410             L.
411             I will be notified, and then you'll automatically be notified of progress on
412             your bug as I make changes.
413              
414             =head1 SUPPORT
415              
416             You can find documentation for this module with the perldoc command.
417              
418             perldoc Email::Fingerprint
419              
420             You can also look for information at:
421              
422             =over 4
423              
424             =item * AnnoCPAN: Annotated CPAN documentation
425              
426             L
427              
428             =item * CPAN Ratings
429              
430             L
431              
432             =item * RT: CPAN's request tracker
433              
434             L
435              
436             =item * Search CPAN
437              
438             L
439              
440             =back
441              
442             =head1 SEE ALSO
443              
444             See B for options governing the parsing of email headers.
445              
446             =head1 ACKNOWLEDGEMENTS
447              
448             Email::Fingerprint is based on the C script by Peter Samuel
449             and available at L.
450              
451             =head1 COPYRIGHT & LICENSE
452              
453             Copyright 2006-2011 Len Budney, all rights reserved.
454              
455             This program is free software; you can redistribute it and/or modify it
456             under the same terms as Perl itself.
457              
458             =cut
459              
460             1; # End of Email::Fingerprint