File Coverage

blib/lib/Mail/BIMI/CacheBackend/File.pm
Criterion Covered Total %
statement 43 43 100.0
branch 7 10 90.0
condition n/a
subroutine 9 9 100.0
pod 3 3 100.0
total 62 65 98.4


line stmt bran cond sub pod time code
1             package Mail::BIMI::CacheBackend::File;
2             # ABSTRACT: Cache handling
3             our $VERSION = '3.20210512'; # VERSION
4 29     29   476 use 5.20.0;
  29         135  
5 29     29   190 use Moose;
  29         147  
  29         271  
6 29     29   200936 use Mail::BIMI::Prelude;
  29         94  
  29         283  
7 29     29   8974 use File::Slurp qw{ read_file write_file };
  29         95  
  29         2029  
8 29     29   16217 use Sereal qw{encode_sereal decode_sereal};
  29         30378  
  29         12958  
9              
10             with 'Mail::BIMI::Role::CacheBackend';
11             has _cache_filename => ( is => 'ro', lazy => 1, builder => '_build_cache_filename' );
12              
13              
14              
15 19     19 1 36 sub get_from_cache($self) {
  19         43  
  19         31  
16 19         514 my $cache_file = $self->_cache_filename;
17 19 100       1100 return if !-e $cache_file;
18 9         314 my $raw = scalar read_file($self->_cache_filename);
19 9         1479 my $value = eval{ decode_sereal($raw) };
  9         213  
20 9 100       122 warn "Error reading from cache: $@" if $@;
21 9         33 return $value;
22             }
23              
24              
25 6     6 1 14 sub put_to_cache($self,$data) {
  6         14  
  6         14  
  6         16  
26 6         202 $self->parent->log_verbose('Writing '.(ref $self->parent).' to cache file '.$self->_cache_filename);
27 6         14 my $sereal_data = eval{ encode_sereal($data) };
  6         207  
28 6 50       23 warn "Error writing to cache: $@" if $@; # uncoverable branch
29 6 50       16 return unless $sereal_data; # uncoverable branch
30 6         173 write_file($self->_cache_filename,{atomic=>1},$sereal_data);
31             }
32              
33              
34 2     2 1 5 sub delete_cache($self) {
  2         6  
  2         4  
35 2 50       55 unlink $self->_cache_filename or warn "Unable to unlink cache file: $!";
36             }
37              
38 19     19   36 sub _build_cache_filename($self) {
  19         47  
  19         33  
39 19         498 my $cache_dir = $self->parent->bimi_object->options->cache_file_directory;
40 19         551 return $cache_dir.'mail-bimi-cache-'.$self->_cache_hash.'.cache';
41             }
42              
43             1;
44              
45             __END__
46              
47             =pod
48              
49             =encoding UTF-8
50              
51             =head1 NAME
52              
53             Mail::BIMI::CacheBackend::File - Cache handling
54              
55             =head1 VERSION
56              
57             version 3.20210512
58              
59             =head1 DESCRIPTION
60              
61             Cache worker role for File storage
62              
63             =head1 ATTRIBUTES
64              
65             These values are derived from lookups and verifications made based upon the input values, it is however possible to override these with other values should you wish to, for example, validate a record before it is published in DNS, or validate an Indicator which is only available locally
66              
67             =head2 parent
68              
69             is=ro required
70              
71             Parent class for cacheing
72              
73             =head1 CONSUMES
74              
75             =over 4
76              
77             =item * L<Mail::BIMI::Role::CacheBackend>
78              
79             =back
80              
81             =head1 EXTENDS
82              
83             =over 4
84              
85             =item * L<Moose::Object>
86              
87             =back
88              
89             =head1 METHODS
90              
91             =head2 I<get_from_cache()>
92              
93             Retrieve this class data from cache
94              
95             =head2 I<put_to_cache($data)>
96              
97             Put this classes data into the cache
98              
99             =head2 I<delete_cache>
100              
101             Delete the cache entry for this class
102              
103             =head1 REQUIRES
104              
105             =over 4
106              
107             =item * L<File::Slurp|File::Slurp>
108              
109             =item * L<Mail::BIMI::Prelude|Mail::BIMI::Prelude>
110              
111             =item * L<Moose|Moose>
112              
113             =item * L<Sereal|Sereal>
114              
115             =back
116              
117             =head1 AUTHOR
118              
119             Marc Bradshaw <marc@marcbradshaw.net>
120              
121             =head1 COPYRIGHT AND LICENSE
122              
123             This software is copyright (c) 2020 by Marc Bradshaw.
124              
125             This is free software; you can redistribute it and/or modify it under
126             the same terms as the Perl 5 programming language system itself.
127              
128             =cut