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