File Coverage

blib/lib/Cache/FileBackend.pm
Criterion Covered Total %
statement 204 228 89.5
branch 43 76 56.6
condition 17 35 48.6
subroutine 41 43 95.3
pod 1 14 7.1
total 306 396 77.3


line stmt bran cond sub pod time code
1             ######################################################################
2             # $Id: FileBackend.pm,v 1.28 2005/07/13 22:29:33 dclinton Exp $
3             # Copyright (C) 2001-2003 DeWitt Clinton All Rights Reserved
4             #
5             # Software distributed under the License is distributed on an "AS
6             # IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or
7             # implied. See the License for the specific language governing
8             # rights and limitations under the License.
9             ######################################################################
10              
11             package Cache::FileBackend;
12              
13 2     2   34 use strict;
  2         28  
  2         31  
14 2     2   87 use Cache::CacheUtils qw( Assert_Defined Build_Path Freeze_Data Thaw_Data );
  2         19  
  2         34  
15 2     2   167 use Digest::SHA1 qw( sha1_hex );
  2         47  
  2         38  
16 2     2   41 use Error;
  2         18  
  2         30  
17 2     2   31 use File::Path qw( mkpath );
  2         17  
  2         40  
18 2     2   110 use File::Temp qw( tempfile );
  2         21  
  2         79  
19              
20              
21             # the file mode for new directories, which will be modified by the
22             # current umask
23              
24             my $DIRECTORY_MODE = 0777;
25              
26              
27             # regex for untainting directory and file paths. since all paths are
28             # generated by us or come from user via API, a tautological regex
29             # suffices.
30              
31             my $UNTAINTED_PATH_REGEX = '^(.*)$';
32              
33              
34             sub new
35             {
36 68     68 1 813   my ( $proto, $p_root, $p_depth, $p_directory_umask ) = @_;
37 68   33     971   my $class = ref( $proto ) || $proto;
38 68         749   my $self = {};
39 68         783   $self = bless( $self, $class );
40 68         801   $self->set_root( $p_root );
41 68         769   $self->set_depth( $p_depth );
42 68         698   $self->set_directory_umask( $p_directory_umask );
43 68         999   return $self;
44             }
45              
46              
47             sub delete_key
48             {
49 27     27 0 322   my ( $self, $p_namespace, $p_key ) = @_;
50              
51 27         297   Assert_Defined( $p_namespace );
52 27         287   Assert_Defined( $p_key );
53              
54 27         287   _Remove_File( $self->_path_to_key( $p_namespace, $p_key ) );
55             }
56              
57              
58             sub delete_namespace
59             {
60 25     25 0 305   my ( $self, $p_namespace ) = @_;
61              
62 25         289   Assert_Defined( $p_namespace );
63              
64 25         2244   _Recursively_Remove_Directory( Build_Path( $self->get_root( ),
65                                                          $p_namespace ) );
66             }
67              
68              
69             sub get_keys
70             {
71 45     45 0 446   my ( $self, $p_namespace ) = @_;
72              
73 45         648   Assert_Defined( $p_namespace );
74              
75 45         379   my @keys;
76              
77 45         499   foreach my $unique_key ( $self->_get_unique_keys( $p_namespace ) )
78               {
79 60 50       1592     my $key = $self->_get_key_for_unique_key( $p_namespace, $unique_key ) or
80                   next;
81              
82 60         3402     push( @keys, $key );
83               }
84              
85 45         809   return @keys;
86              
87             }
88              
89              
90             sub get_namespaces
91             {
92 36     36 0 364   my ( $self ) = @_;
93              
94 36         288   my @namespaces;
95              
96 36         443   _List_Subdirectories( $self->get_root( ), \@namespaces );
97              
98 36         571   return @namespaces;
99             }
100              
101              
102             sub get_size
103             {
104 119     119 0 1712   my ( $self, $p_namespace, $p_key ) = @_;
105              
106 119         1820   Assert_Defined( $p_namespace );
107 119         2015   Assert_Defined( $p_key );
108              
109 119 50       1357   if ( -e $self->_path_to_key( $p_namespace, $p_key ) )
110               {
111 119         1351     return -s $self->_path_to_key( $p_namespace, $p_key );
112              
113               }
114               else
115               {
116 0         0     return 0;
117               }
118             }
119              
120              
121             sub restore
122             {
123 117     117 0 1226   my ( $self, $p_namespace, $p_key ) = @_;
124              
125 117         1244   Assert_Defined( $p_namespace );
126 117         2987   Assert_Defined( $p_key );
127              
128 117         1406   return $self->_read_data( $self->_path_to_key($p_namespace, $p_key) )->[1];
129             }
130              
131              
132             sub store
133             {
134 86     86 0 10600   my ( $self, $p_namespace, $p_key, $p_data ) = @_;
135              
136 86         988   Assert_Defined( $p_namespace );
137 86         903   Assert_Defined( $p_key );
138              
139 86         980   $self->_write_data( $self->_path_to_key( $p_namespace, $p_key ),
140                                   [ $p_key, $p_data ] );
141              
142             }
143              
144              
145             sub get_depth
146             {
147 528     528 0 25065   my ( $self ) = @_;
148              
149 528         21731   return $self->{_Depth};
150             }
151              
152              
153             sub set_depth
154             {
155 68     68 0 671   my ( $self, $depth ) = @_;
156              
157 68         1509   $self->{_Depth} = $depth;
158             }
159              
160              
161             sub get_root
162             {
163 634     634 0 6864   my ( $self ) = @_;
164              
165 634         21503   return $self->{_Root};
166             }
167              
168              
169             sub set_root
170             {
171 68     68 0 639   my ( $self, $root ) = @_;
172              
173 68         1056   $self->{_Root} = $root;
174             }
175              
176              
177             sub get_directory_umask
178             {
179 86     86 0 739   my ( $self ) = @_;
180              
181 86         984   return $self->{_Directory_Umask};
182             }
183              
184              
185             sub set_directory_umask
186             {
187 68     68 0 612   my ( $self, $directory_umask ) = @_;
188              
189 68         673   $self->{_Directory_Umask} = $directory_umask;
190             }
191              
192              
193             # Take an human readable key, and create a unique key from it
194              
195             sub _Build_Unique_Key
196             {
197 468     468   7901   my ( $p_key ) = @_;
198              
199 468         10107   Assert_Defined( $p_key );
200              
201 468         10194   return sha1_hex( $p_key );
202             }
203              
204              
205             # create a directory with optional mask, building subdirectories as
206             # needed.
207              
208             sub _Create_Directory
209             {
210 43     43   399   my ( $p_directory, $p_optional_new_umask ) = @_;
211              
212 43         455   Assert_Defined( $p_directory );
213              
214 43 50       691   my $old_umask = umask( ) if defined $p_optional_new_umask;
215              
216 43 50       961   umask( $p_optional_new_umask ) if defined $p_optional_new_umask;
217              
218 43         437   my $directory = _Untaint_Path( $p_directory );
219              
220 43         509   $directory =~ s|/$||;
221              
222 43         616   mkpath( $directory, 0, $DIRECTORY_MODE );
223              
224 43 50       154373   -d $directory or
225                 throw Error::Simple( "Couldn't create directory: $directory: $!" );
226              
227 43 50       1079   umask( $old_umask ) if defined $old_umask;
228             }
229              
230              
231              
232             # list the names of the subdirectories in a given directory, without the
233             # full path
234              
235             sub _List_Subdirectories
236             {
237 36     36   368   my ( $p_directory, $p_subdirectories_ref ) = @_;
238              
239 36         436   foreach my $dirent ( _Read_Dirents( $p_directory ) )
240               {
241 104 100 100     1686     next if $dirent eq '.' or $dirent eq '..';
242              
243 32         362     my $path = Build_Path( $p_directory, $dirent );
244              
245 32 50       594     next unless -d $path;
246              
247 32         411     push( @$p_subdirectories_ref, $dirent );
248               }
249             }
250              
251              
252             # read the dirents from a directory
253              
254             sub _Read_Dirents
255             {
256 429     429   6083   my ( $p_directory ) = @_;
257              
258 429         8896   Assert_Defined( $p_directory );
259              
260 429 50       10348   -d $p_directory or
261                 return ( );
262              
263 429         15125   local *Dir;
264              
265 429 50       8037   opendir( Dir, _Untaint_Path( $p_directory ) ) or
266                 throw Error::Simple( "Couldn't open directory $p_directory: $!" );
267              
268 429         188346   my @dirents = readdir( Dir );
269              
270 429 50       7888   closedir( Dir ) or
271                 throw Error::Simple( "Couldn't close directory $p_directory: $!" );
272              
273 429         8762   return @dirents;
274             }
275              
276              
277             # read in a file. returns a reference to the data read
278              
279             sub _Read_File
280             {
281 151     151   1984   my ( $p_path ) = @_;
282              
283 151         1626   Assert_Defined( $p_path );
284              
285 151         1412   local *File;
286              
287 151 50       1703   open( File, _Untaint_Path( $p_path ) ) or
288                 return undef;
289              
290 151         5051   binmode( File );
291              
292 151         2051   local $/ = undef;
293              
294 151         2529   my $data_ref;
295              
296 151         20568   $$data_ref = <File>;
297              
298 151         9896   close( File );
299              
300 151         4133   return $data_ref;
301             }
302              
303              
304             # read in a file. returns a reference to the data read, without
305             # modifying the last accessed time
306              
307             sub _Read_File_Without_Time_Modification
308             {
309 177     177   1677   my ( $p_path ) = @_;
310              
311 177         1915   Assert_Defined( $p_path );
312              
313 177 100       15565   -e $p_path or
314                 return undef;
315              
316 151         17883   my ( $file_access_time, $file_modified_time ) =
317                 ( stat( _Untaint_Path( $p_path ) ) )[8,9];
318              
319 151         1884   my $data_ref = _Read_File( $p_path );
320              
321 151         5253   utime( $file_access_time, $file_modified_time, _Untaint_Path( $p_path ) );
322              
323 151         6382   return $data_ref;
324             }
325              
326              
327             # remove a file
328              
329             sub _Remove_File
330             {
331 57     57   519   my ( $p_path ) = @_;
332              
333 57         1644   Assert_Defined( $p_path );
334              
335 57 50       533   if ( -f _Untaint_Path( $p_path ) )
336               {
337             # We don't catch the error, because this may fail if two
338             # processes are in a race and try to remove the object
339              
340 57         1691     unlink( _Untaint_Path( $p_path ) );
341               }
342             }
343              
344              
345             # remove a directory
346              
347             sub _Remove_Directory
348             {
349 152     152   1781   my ( $p_directory ) = @_;
350              
351 152         5819   Assert_Defined( $p_directory );
352              
353 152 50       1731   if ( -d _Untaint_Path( $p_directory ) )
354               {
355             # We don't catch the error, because this may fail if two
356             # processes are in a race and try to remove the object
357              
358 152         2007     rmdir( _Untaint_Path( $p_directory ) );
359               }
360             }
361              
362              
363             # recursively list the files of the subdirectories, without the full paths
364              
365             sub _Recursively_List_Files
366             {
367 249     249   2439   my ( $p_directory, $p_files_ref ) = @_;
368              
369 249 100       9863   return unless -d $p_directory;
370              
371 241         11058   foreach my $dirent ( _Read_Dirents( $p_directory ) )
372               {
373 746 100 100     23894     next if $dirent eq '.' or $dirent eq '..';
374              
375 264         5057     my $path = Build_Path( $p_directory, $dirent );
376              
377 264 100       7348     if ( -d $path )
378                 {
379 204         5191       _Recursively_List_Files( $path, $p_files_ref );
380                 }
381                 else
382                 {
383 60         6116       push( @$p_files_ref, $dirent );
384                 }
385               }
386             }
387              
388