File Coverage

lib/Petal/Cache/Disk.pm
Criterion Covered Total %
statement 51 82 62.2
branch 7 26 26.9
condition 5 21 23.8
subroutine 10 14 71.4
pod 0 9 0.0
total 73 152 48.0


line stmt bran cond sub pod time code
1             # ------------------------------------------------------------------
2             # Petal::Cache::Disk - Caches generated code on disk.
3             # ------------------------------------------------------------------
4             # Author: Jean-Michel Hiver
5             # Description: A simple cache module to avoid re-generating the Perl
6             # code from the template file every time
7             # ------------------------------------------------------------------
8             package Petal::Cache::Disk;
9 77     77   472 use strict;
  77         136  
  77         2147  
10 77     77   363 use warnings;
  77         119  
  77         1698  
11 77     77   360 use File::Spec;
  77         110  
  77         1676  
12 77     77   323 use Digest::MD5 qw /md5_hex/;
  77         127  
  77         3947  
13 77     77   422 use Carp;
  77         108  
  77         76419  
14              
15              
16             # kill silly warnings
17             sub sillyness
18             {
19 0 0   0 0 0 + $Petal::INPUT &&
20             + $Petal::OUTPUT;
21             }
22              
23              
24             # local $Petal::Cache::Disk::TMP_DIR =
25             # defaults to File::Spec->tmpdir;
26             our $TMP_DIR = File::Spec->tmpdir;
27              
28              
29             # local $Petal::Cache::Disk::PREFIX =
30             # defaults to 'petal_cache_'
31             our $PREFIX = 'petal_cache';
32              
33              
34             # $class->get ($file, $lang);
35             # --------------------
36             # Returns the cached data if its last modification time is more
37             # recent than the last modification time of the template
38             # Returns the code for template file $file, undef otherwise
39             sub get
40             {
41 4     4 0 9 my $class = shift;
42 4         5 my $file = shift;
43 4   50     54 my $lang = shift || '';
44 4         39 my $key = $class->compute_key ($file, $lang);
45 4 50       9 return $class->cached ($key) if ($class->is_ok ($file, $lang));
46 4         14 return;
47             }
48              
49              
50             # $class->set ($file, $code, $lang);
51             # ---------------------------
52             # Sets the cached code for $file + $lang
53             sub set
54             {
55 4     4 0 6 my $class = shift;
56 4         5 my $file = shift;
57 4         6 my $code = shift;
58 4   50     8 my $lang = shift || '';
59 4         11 my $key = $class->compute_key ($file, $lang);
60 4         8 my $tmp = $class->tmp;
61             {
62 4 50       6 if ($] > 5.007)
  4         11  
63             {
64 4 50 0     241 open FP, ">:utf8", "$tmp/$key" or ( Carp::cluck "Cannot write-open $tmp/$key ($!)" and return );
65             }
66             else
67             {
68 0 0 0     0 open FP, ">$tmp/$key" or ( Carp::cluck "Cannot write-open $tmp/$key ($!)" and return );
69             }
70            
71 4         45 print FP $code;
72 4         131 close FP;
73             }
74             }
75              
76              
77             # $class->is_ok ($file, $lang);
78             # ----------------------
79             # Returns TRUE if the cache is still fresh, FALSE otherwise.
80             sub is_ok
81             {
82 4     4 0 6 my $class = shift;
83 4         4 my $file = shift;
84 4   50     8 my $lang = shift || '';
85            
86 4         8 my $key = $class->compute_key ($file, $lang);
87 4         16 my $tmp = $class->tmp;
88 4         8 my $tmp_file = "$tmp/$key";
89 4 50       164 return unless (-e $tmp_file);
90            
91 0         0 my $cached_mtime = $class->cached_mtime ($file, $lang);
92 0         0 my $current_mtime = $class->current_mtime ($file);
93 0         0 return $cached_mtime >= $current_mtime;
94             }
95              
96              
97             # $class->compute_key ($file, $lang);
98             # ----------------------------
99             # Computes a cache 'key' for $file+$lang, which should be unique.
100             # (Well, currently an MD5 checksum is used, which is not
101             # *exactly* unique but which should be good enough)
102             sub compute_key
103             {
104 12     12 0 15 my $class = shift;
105 12         12 my $file = shift;
106 12   50     20 my $lang = shift || '';
107            
108 12         55 my $key = md5_hex ($file . ";$lang" . ";INPUT=" . $Petal::INPUT . ";OUTPUT=" . $Petal::OUTPUT);
109 12 50       37 $key = $PREFIX . "_" . $Petal::VERSION . "_" . $key if (defined $PREFIX);
110 12         20 return $key;
111             }
112              
113              
114             # $class->cached_mtime ($file, $lang);
115             # -----------------------------
116             # Returns the last modification date of the cached data
117             # for $file + $lang
118             sub cached_mtime
119             {
120 0     0 0 0 my $class = shift;
121 0         0 my $file = shift;
122 0   0     0 my $lang = shift || '';
123 0         0 my $key = $class->compute_key ($file, $lang);
124 0         0 my $tmp = $class->tmp;
125            
126 0         0 my $tmp_file = "$tmp/$key";
127 0         0 my $mtime = (stat($tmp_file))[9];
128 0         0 return $mtime;
129             }
130              
131              
132             # $class->current_mtime ($file);
133             # ------------------------------
134             # Returns the last modification date for $file
135             sub current_mtime
136             {
137 0     0 0 0 my $class = shift;
138 0         0 my $file = shift;
139 0         0 $file =~ s/#.*$//;
140 0         0 my $mtime = (stat($file))[9];
141 0         0 return $mtime;
142             }
143              
144              
145             # $class->cached ($key);
146             # ----------------------
147             # Returns the cached data for $key
148             sub cached
149             {
150 0     0 0 0 my $class = shift;
151 0         0 my $key = shift;
152 0         0 my $tmp = $class->tmp;
153 0         0 my $cached_filepath = $tmp . '/' . $key;
154            
155 0 0       0 (-e $cached_filepath) or return;
156              
157 0         0 my $res = undef;
158             {
159 0 0       0 if ($] > 5.007)
  0         0  
160             {
161 0 0 0     0 open FP, "<:utf8", "$tmp/$key" or ( Carp::cluck "Cannot read-open $tmp/$key ($!)" and return );
162             }
163             else
164             {
165 0 0 0     0 open FP, "<$tmp/$key" or ( Carp::cluck "Cannot read-open $tmp/$key ($!)" and return );
166             }
167            
168 0         0 $res = join '', ;
169 0         0 close FP;
170             }
171            
172 0         0 return $res;
173             }
174              
175              
176             # $class->tmp;
177             # ------------
178             # Returns the temp directory in which the cached data is kept.
179             sub tmp
180             {
181 8     8 0 10 my $class = shift;
182 8   33     14 $TMP_DIR ||= File::Spec->tmpdir;
183            
184 8 50       99 (-e $TMP_DIR) or confess "\$TMP_DIR '$TMP_DIR' does not exist";
185 8 50       79 (-d $TMP_DIR) or confess "\$TMP_DIR '$TMP_DIR' is not a directory";
186 8         38 $TMP_DIR =~ s/\/+$//;
187 8         26 return $TMP_DIR;
188             }
189              
190              
191             1;