File Coverage

blib/lib/Email/Fingerprint/Cache.pm
Criterion Covered Total %
statement 79 79 100.0
branch 20 20 100.0
condition 10 10 100.0
subroutine 19 19 100.0
pod 10 10 100.0
total 138 138 100.0


line stmt bran cond sub pod time code
1             package Email::Fingerprint::Cache;
2 4     4   3778 use Class::Std;
  4         13193  
  4         51  
3              
4 4     4   835 use warnings;
  3         7  
  3         105  
5 4     4   338 use strict;
  3         6  
  3         134  
6              
7 4     4   25 use Carp qw( croak cluck );
  4         11  
  4         280  
8 4     4   514 use Scalar::Util qw( reftype blessed );
  3         7  
  3         1504  
9              
10             =head1 NAME
11              
12             Email::Fingerprint::Cache - Cache observed email fingerprints
13              
14             =head1 VERSION
15              
16             Version 0.01
17              
18             =cut
19              
20             our $VERSION = '0.01';
21              
22             =head1 SYNOPSIS
23              
24             use Email::Fingerprint::Cache;
25              
26             my %fingerprints; # To access cache contents
27              
28             # Create a cache
29             my $cache = new Email::Fingerprint::Cache(
30             backend => "AnyDBM",
31             hash => \%fingerprints,
32             file => $file, # Created if doesn't exist
33             ttl => 3600 * 24 * 7, # Purge records after one week
34             );
35              
36             # Prepare it for use
37             $cache->lock or die "Couldn't lock: $!"; # Waits for lock
38             $cache->open or die "Couldn't open: $!";
39              
40             # Work with fingerprints
41             for my (@message_fingerprints) {
42              
43             if ($fingerprints{$_}) {
44             print "Fingerprint found: $_\n";
45             next;
46             }
47              
48             my $now = time;
49             $fingerprints{$_} = $now;
50              
51             print "Fingerprint added: $_\n";
52             }
53              
54             # Get rid of old records
55             $cache->purge;
56              
57             # Print a listing of all fingerprints
58             $cache->dump;
59              
60             # Finish up
61             $cache->close;
62             $cache->unlock;
63              
64             =head1 ATTRIBUTES
65              
66             =cut
67              
68             my %hash :ATTR( :get ) = ();
69             my %ttl :ATTR( :name :default(604800) ) = ();
70             my %backend :ATTR( :init_arg :default('AnyDBM') ) = ();
71              
72             =head1 METHODS
73              
74             =head2 new
75              
76             my $fingerprint = new Email::Fingerprint::Cache(
77             file => $file, # Default: .maildups
78             backend => "AnyDBM", # Default: "AnyDBM"
79             ttl => $sec, # Default: 3600*24*7
80             hash => $ref, # Optional
81             );
82              
83             Returns a new Email::Fingerprint::Cache. The cache must still be opened
84             before it can be used.
85              
86             =head2 BUILD
87              
88             Internal helper method; never called directly by users.
89              
90             =cut
91              
92             sub BUILD {
93 16     16 1 194323 my ( $self, $ident, $args ) = @_;
94              
95             # Default hash is a fresh-n-tasty anonymous hash
96 15 100       88 $hash{$ident} = defined $args->{hash} ? $args->{hash} : {};
97              
98             # Backend will also need access to the hash
99 15         86 $args->{hash} = $hash{$ident};
100              
101             # Default backend is AnyDBM
102 16 100       75 my $backend = defined $args->{backend} ? $args->{backend} : 'AnyDBM';
103              
104             # Default cache file
105 16   100     77 $args->{file} ||= '.maildups';
106              
107             # Try accessing package as a subclass of Email::Fingerprint::Cache
108 16         198 my $package = __PACKAGE__ . "::" . $backend;
109 16     2   1929 eval "use $package"; ## no critic
  2         1208  
  2         4  
  2         44  
110              
111             # Try accessing package using the given name exactly. If this fails,
112             # we try constructing a backend anyway, in case the module is already
113             # imported--or, e.g., defined in the script file itself.
114 16 100       80 if ($@) {
115 5         28 $package = $backend;
116 5         294 eval "use $package"; ## no critic
117             }
118              
119 16         37 undef $backend;
120              
121             # Perhaps the correct module was loaded by our caller;
122             # try instantiating the backend even if the above steps
123             # all failed.
124 16         41 eval {
125 16         160 $backend = $package->new({
126             file => $args->{file},
127             hash => $args->{hash},
128             });
129             };
130              
131             # It's a fatal error if the backend doesn't load
132 16 100 100     4992 croak "Can't load backend module" if $@ or not $backend;
133              
134 14         79 $backend{$ident} = $backend;
135             }
136              
137             =head2 set_file
138              
139             $file = $cache->set_file( 'foo' ) or die "Failed to set filename";
140             # now $file eq 'foo.db' or 'foo.dir', etc., depending on the backend;
141             # it is almost certainly NOT 'foo'.
142              
143             Sets the file to be used for the cache. Returns the actual filename
144             on success; false on failure.
145              
146             The actual filename will probably differ from the 'foo', because
147             the backend will usually add an extension or otherwise munge it.
148              
149             C has I effect while the cache file is locked or open!
150              
151             =cut
152              
153             sub set_file {
154 6     6 1 27 my ($self, $file) = @_;
155              
156             # Validation
157 6 100       16 return if $self->get_backend->is_locked;
158 5 100       31 return if $self->get_backend->is_open;
159              
160             # OK, there's no harm in changing the file attribute
161 4         19 $self->get_backend->set_file($file);
162              
163 4         62 1;
164             }
165              
166             =head2 get_backend
167              
168             Returns the backend object for this cache.
169              
170             =cut
171              
172             sub get_backend :PRIVATE() {
173 72     72 1 1619 my $self = shift;
174 71         309 return $backend{ident $self};
175 4     4   491 }
  3         14  
  3         29  
176              
177             =head2 dump
178              
179             # Be a good citizen
180             $cache->lock;
181             $cache->open;
182              
183             $cache->dump;
184              
185             # Be a good neighbor
186             $cache->close;
187             $cache->unlock;
188              
189             Dump a human-readable version of the contents of the cache. Data is
190             printed in timestamp order.
191              
192             The cache I first be opened, and I first be locked.
193              
194             =cut
195              
196             sub dump {
197 2     2 1 32 my $self = shift;
198 2         67 my $hash = $self->get_hash;
199              
200 2         12416 for my $key ( sort { $hash->{$a} <=> $hash->{$b} } keys %$hash )
  55395         1323100  
201             {
202 5000         108455 my $value = $hash->{$key};
203 5000         58163 print "$value\t", scalar gmtime $value, "\t$key\n";
204             }
205             }
206              
207             =head2 open
208              
209             $cache->open or die;
210              
211             Open the cache file, and tie it to a hash. This is delegated to the
212             backend.
213              
214             =cut
215              
216             sub open {
217 9     10 1 3853 my $self = shift;
218              
219 9         37 return $self->_delegate( "open", @_ );
220             }
221              
222             =head2 close
223              
224             $cache->close;
225              
226             Close the cache file and untie the hash.
227              
228             =cut
229              
230             sub close {
231 9     10 1 6569 my $self = shift;
232              
233 9         145 return $self->_delegate( "close", @_ );
234             }
235              
236             =head2 lock
237              
238             $cache->lock or die; # returns immediately
239             $cache->lock( block => 1 ) or die; # Waits for a lock
240             $cache->lock( %opts ) or die; # Backend-specific options
241              
242             Lock the DB file to guarantee exclusive access.
243              
244             =cut
245              
246             sub lock {
247 6     7 1 1587 my $self = shift;
248              
249 6         25 return $self->_delegate( "lock", @_ );
250             }
251              
252             =head2 unlock
253              
254             $cache->unlock or warn "Unlock failed";
255              
256             Unlock the DB file.
257              
258             =cut
259              
260             sub unlock {
261 19     20 1 166755 my $self = shift;
262 19         95 return $self->_delegate( "unlock", @_ );
263             }
264              
265             =head2 purge
266              
267             $cache->purge; # Use default TTL
268             $cache->purge( ttl => 3600 ); # Everything older than 1 hour
269              
270             Purge the cache of old entries. This reduces the risk of false positives
271             from things like reused message IDs, but increases the risk of false
272             negatives.
273              
274             The default is one week. Dedicated spam-fighters might prefer to use a
275             longer TTL.
276              
277             =cut
278              
279             sub purge {
280 6     7 1 592 my $self = shift;
281 6         19 my %opts = @_;
282              
283 6         31 my $hash = $self->get_hash;
284 6 100       64 my $ttl = defined $opts{ttl} ? $opts{ttl} : $self->get_ttl;
285 6         17 my $now = time;
286              
287 6         39828 for my $key ( keys %$hash )
288             {
289 8104   100     55716 my $timestamp = $hash->{$key} || 0; # Also clobbers bad data like undef
290 8104 100       109790 delete $hash->{$key} if ($now - $timestamp) > $ttl;
291             }
292              
293 6         1660 1;
294             }
295              
296             =head2 DESTROY
297              
298             Clean up the module. If the hash is still tied, we warn the user and call
299             C on C<$self>.
300              
301             =head2 DEMOLISH
302              
303             Internal helper method, never called directly by user.
304              
305             =cut
306              
307             sub DEMOLISH {
308 15     16 1 259109 my $self = shift;
309              
310 15         57 my $backend = $self->get_backend;
311              
312             # Failing to close() the cache is bad: data won't be
313             # committed to disk.
314 15 100 100     111 if ( $backend and $backend->is_open )
315             {
316 2         52 cluck "Cache DESTROY()ed before it was close()ed";
317 2         1115 $self->close;
318             }
319              
320             # Failure to unlock() is rude, but we don't say anything.
321 15         61 $self->unlock;
322             }
323              
324             =head2 _delegate
325              
326             Delegate the specified method to the backend. Internal method.
327              
328             =cut
329              
330             sub _delegate :PRIVATE() {
331 43     43   106 my ($self, $method, @args) = @_;
332              
333 44         585 my $backend = $self->get_backend;
334 43 100       137 return unless $backend;
335              
336 41         222 return $backend->$method(@args);
337 3     4   2258 }
  4         442  
  3         13  
338              
339             =head1 AUTHOR
340              
341             Len Budney, C<< >>
342              
343             =head1 BUGS
344              
345             The C method assumes that Perl's C function returns
346             seconds since the UNIX epoch, 00:00:00 UTC, January 1, 1970. The
347             module will work on architectures with non-standard epochs, but the
348             automated tests will fail.
349              
350             Please report any bugs or feature requests to
351             C, or through the web interface at
352             L.
353             I will be notified, and then you'll automatically be notified of progress on
354             your bug as I make changes.
355              
356             =head1 SUPPORT
357              
358             You can find documentation for this module with the perldoc command.
359              
360             perldoc Email::Fingerprint::Cache
361              
362             You can also look for information at:
363              
364             =over 4
365              
366             =item * AnnoCPAN: Annotated CPAN documentation
367              
368             L
369              
370             =item * CPAN Ratings
371              
372             L
373              
374             =item * RT: CPAN's request tracker
375              
376             L
377              
378             =item * Search CPAN
379              
380             L
381              
382             =back
383              
384             =head1 ACKNOWLEDGEMENTS
385              
386             Email::Fingerprint::Cache is based on caching code in the
387             C script by Peter Samuel and available at
388             L.
389              
390             =head1 COPYRIGHT & LICENSE
391              
392             Copyright 2006-2011 Len Budney, all rights reserved.
393              
394             This program is free software; you can redistribute it and/or modify it
395             under the same terms as Perl itself.
396              
397             =cut
398              
399             1;