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              
389             # recursively list the files of the subdirectories, with the full paths
390              
391             sub _Recursively_List_Files_With_Paths
392             {
393 0     0   0   my ( $p_directory, $p_files_ref ) = @_;
394              
395 0         0   foreach my $dirent ( _Read_Dirents( $p_directory ) )
396               {
397 0 0 0     0     next if $dirent eq '.' or $dirent eq '..';
398              
399 0         0     my $path = Build_Path( $p_directory, $dirent );
400              
401 0 0       0     if ( -d $path )
402                 {
403 0         0       _Recursively_List_Files_With_Paths( $path, $p_files_ref );
404                 }
405                 else
406                 {
407 0         0       push( @$p_files_ref, $path );
408                 }
409               }
410             }
411              
412              
413              
414             # remove a directory and all subdirectories and files
415              
416             sub _Recursively_Remove_Directory
417             {
418 153     153   1448   my ( $p_root ) = @_;
419              
420 153 100       2715   return unless -d $p_root;
421              
422 152         5398   foreach my $dirent ( _Read_Dirents( $p_root ) )
423               {
424 462 100 100     12302     next if $dirent eq '.' or $dirent eq '..';
425              
426 158         1833     my $path = Build_Path( $p_root, $dirent );
427              
428 158 100       32147     if ( -d $path )
429                 {
430 128         1605       _Recursively_Remove_Directory( $path );
431                 }
432                 else
433                 {
434 30         302       _Remove_File( _Untaint_Path( $path ) );
435                 }
436               }
437              
438 152         1843   _Remove_Directory( _Untaint_Path( $p_root ) );
439             }
440              
441              
442              
443             # walk down a directory structure and total the size of the files
444             # contained therein.
445              
446             sub _Recursive_Directory_Size
447             {
448 0     0   0   my ( $p_directory ) = @_;
449              
450 0         0   Assert_Defined( $p_directory );
451              
452 0 0       0   return 0 unless -d $p_directory;
453              
454 0         0   my $size = 0;
455              
456 0         0   foreach my $dirent ( _Read_Dirents( $p_directory ) )
457               {
458 0 0 0     0     next if $dirent eq '.' or $dirent eq '..';
459              
460 0         0     my $path = Build_Path( $p_directory, $dirent );
461              
462 0 0       0     if ( -d $path )
463                 {
464 0         0       $size += _Recursive_Directory_Size( $path );
465                 }
466                 else
467                 {
468 0         0       $size += -s $path;
469                 }
470               }
471              
472 0         0   return $size;
473             }
474              
475              
476             # Untaint a file path
477              
478             sub _Untaint_Path
479             {
480 1697     1697   39176   my ( $p_path ) = @_;
481              
482 1697         36351   return _Untaint_String( $p_path, $UNTAINTED_PATH_REGEX );
483             }
484              
485              
486             # Untaint a string
487              
488             sub _Untaint_String
489             {
490 1697     1697   29307   my ( $p_string, $p_untainted_regex ) = @_;
491              
492 1697         35037   Assert_Defined( $p_string );
493 1697         25300   Assert_Defined( $p_untainted_regex );
494              
495 1697         38672   my ( $untainted_string ) = $p_string =~ /$p_untainted_regex/;
496              
497 1697 50 33     42464   if ( not defined $untainted_string || $untainted_string ne $p_string )
498               {
499 0         0     throw Error::Simple( "String $p_string contains possible taint" );
500               }
501              
502 1697         126878   return $untainted_string;
503             }
504              
505              
506             # create a directory with the optional umask if it doesn't already
507             # exist
508              
509             sub _Make_Path
510             {
511 86     86   896   my ( $p_path, $p_optional_new_umask ) = @_;
512              
513 86         2935   my ( $volume, $directory, $filename ) = File::Spec->splitpath( $p_path );
514              
515 86 50 33     6798   if ( defined $directory and defined $volume )
516               {
517 86         3715     $directory = File::Spec->catpath( $volume, $directory, "" );
518               }
519              
520 86 100 66     7599   if ( defined $directory and not -d $directory )
521               {
522 43         436     _Create_Directory( $directory, $p_optional_new_umask );
523               }
524             }
525              
526              
527             # return a list of the first $depth letters in the $word
528              
529             sub _Split_Word
530             {
531 528     528   5517   my ( $p_word, $p_depth ) = @_;
532              
533 528         8605   Assert_Defined( $p_word );
534 528         8583   Assert_Defined( $p_depth );
535              
536 528         7140   my @split_word_list;
537              
538               for ( my $i = 0; $i < $p_depth; $i++ )
539               {
540 1584         37087     push ( @split_word_list, substr( $p_word, $i, 1 ) );
541 528         6620   }
542              
543 528         11059   return @split_word_list;
544             }
545              
546              
547             # write a file atomically
548              
549             sub _Write_File
550             {
551 86     86   883   my ( $p_path, $p_data_ref, $p_optional_mode, $p_optional_umask ) = @_;
552              
553 86         1099   Assert_Defined( $p_path );
554 86         1130   Assert_Defined( $p_data_ref );
555              
556 86 50       1900   my $old_umask = umask if $p_optional_umask;
557              
558 86 50       11687   umask( $p_optional_umask ) if $p_optional_umask;
559              
560 86         1241   my ( $volume, $directory, $filename ) = File::Spec->splitpath( $p_path );
561              
562 86 50 33     9318   if ( defined $directory and defined $volume )
563               {
564 86         1096     $directory = File::Spec->catpath( $volume, $directory, "" );
565               }
566              
567 86         5492   my ( $temp_fh, $temp_filename ) = tempfile( DIR => $directory );
568              
569 86         204226   binmode( $temp_fh );
570              
571 86         1598   print $temp_fh $$p_data_ref;
572              
573 86         93427   close( $temp_fh );
574              
575 86 50       2136   -e $temp_filename or
576                 throw Error::Simple( "Temp file '$temp_filename' does not exist: $!" );
577               
578 86 50       28098   rename( $temp_filename, _Untaint_Path( $p_path ) ) or
579                 throw Error::Simple( "Couldn't rename $temp_filename to $p_path: $!" );
580              
581 86 50       2215   if ( -e $temp_filename )
582               {
583 0         0     _Remove_File( $temp_filename );
584 0         0     warn( "Temp file '$temp_filename' shouldn't still exist" );
585               }
586              
587 86   50     1499   $p_optional_mode ||= 0666 - umask( );
588              
589 86         1081   chmod( $p_optional_mode, _Untaint_Path($p_path) );
590              
591 86 50       1451   umask( $old_umask ) if $old_umask;
592             }
593              
594              
595             sub _get_key_for_unique_key
596             {
597 60     60   932   my ( $self, $p_namespace, $p_unique_key ) = @_;
598              
599 60         612   return $self->_read_data( $self->_path_to_unique_key( $p_namespace,
600                                                                     $p_unique_key ) )->[0];
601             }
602              
603              
604             sub _get_unique_keys
605             {
606 45     45   444   my ( $self, $p_namespace ) = @_;
607              
608 45         487   Assert_Defined( $p_namespace );
609              
610 45         368   my @unique_keys;
611              
612 45         496   _Recursively_List_Files( Build_Path( $self->get_root( ), $p_namespace ),
613                                        \@unique_keys );
614              
615 45         719   return @unique_keys;
616             }
617              
618              
619             sub _path_to_key
620             {
621 468     468   7554   my ( $self, $p_namespace, $p_key ) = @_;
622              
623 468         5212   Assert_Defined( $p_namespace );
624 468         8618   Assert_Defined( $p_key );
625              
626 468         8451   return $self->_path_to_unique_key( $p_namespace,
627                                                  _Build_Unique_Key( $p_key ) );
628             }
629              
630              
631             sub _path_to_unique_key
632             {
633 528     528   7342   my ( $self, $p_namespace, $p_unique_key ) = @_;
634              
635 528         7044   Assert_Defined( $p_unique_key );
636 528         13354   Assert_Defined( $p_namespace );
637              
638 528         5874   return Build_Path( $self->get_root( ),
639                                  $p_namespace,
640                                  _Split_Word( $p_unique_key, $self->get_depth( ) ),
641                                  $p_unique_key );
642             }
643              
644             # the data is returned as reference to an array ( key, data )
645              
646             sub _read_data
647             {
648 177     177   4828   my ( $self, $p_path ) = @_;
649              
650 177         2031   Assert_Defined( $p_path );
651              
652 177 100       2962   my $frozen_data_ref = _Read_File_Without_Time_Modification( $p_path ) or
653                 return [ undef, undef ];
654              
655 151         3099   my $data_ref = eval{ Thaw_Data( $$frozen_data_ref ) };
  151         9218  
656               
657 151 50 33     27344   if ( $@ || ( ref( $data_ref ) ne 'ARRAY' ) )
658               {
659 0         0     unlink _Untaint_Path( $p_path );
660 0         0     return [ undef, undef ];
661               }
662               else
663               {
664 151         2464     return $data_ref;
665               }
666             }
667              
668              
669             # the data is passed as reference to an array ( key, data )
670              
671             sub _write_data
672             {
673 86     86   888   my ( $self, $p_path, $p_data ) = @_;
674              
675 86         950   Assert_Defined( $p_path );
676 86         893   Assert_Defined( $p_data );
677              
678 86         869   _Make_Path( $p_path, $self->get_directory_umask( ) );
679              
680 86         7439   my $frozen_file = Freeze_Data( $p_data );
681              
682 86         960   _Write_File( $p_path, \$frozen_file );
683             }
684              
685              
686             1;
687              
688              
689             __END__
690            
691             =pod
692            
693             =head1 NAME
694            
695             Cache::FileBackend -- a filesystem based persistance mechanism
696            
697             =head1 DESCRIPTION
698            
699             The FileBackend class is used to persist data to the filesystem
700            
701             =head1 SYNOPSIS
702            
703             my $backend = new Cache::FileBackend( '/tmp/FileCache', 3, 000 );
704            
705             See Cache::Backend for the usage synopsis.
706            
707             $backend->store( 'namespace', 'foo', 'bar' );
708            
709             my $bar = $backend->restore( 'namespace', 'foo' );
710            
711             my $size_of_bar = $backend->get_size( 'namespace', 'foo' );
712            
713             foreach my $key ( $backend->get_keys( 'namespace' ) )
714             {
715             $backend->delete_key( 'namespace', $key );
716             }
717            
718             foreach my $namespace ( $backend->get_namespaces( ) )
719             {
720             $backend->delete_namespace( $namespace );
721             }
722            
723             =head1 METHODS
724            
725             See Cache::Backend for the API documentation.
726            
727             =over
728            
729             =item B<new( $root, $depth, $directory_umask )>
730            
731             Construct a new FileBackend that writes data to the I<$root>
732             directory, automatically creates subdirectories I<$depth> levels deep,
733             and uses the umask of I<$directory_umask> when creating directories.
734            
735             =back
736            
737             =head1 PROPERTIES
738            
739             =over
740            
741             =item B<(get|set)_root>
742            
743             The location of the parent directory in which to store the files
744            
745             =item B<(get|set)_depth>
746            
747             The branching factor of the subdirectories created to store the files
748            
749             =item B<(get|set)_directory_umask>
750            
751             The umask to be used when creating directories
752            
753             =back
754            
755             =head1 SEE ALSO
756            
757             Cache::Backend, Cache::MemoryBackend, Cache::SharedMemoryBackend
758            
759             =head1 AUTHOR
760            
761             Original author: DeWitt Clinton <dewitt@unto.net>
762            
763             Last author: $Author: dclinton $
764            
765             Copyright (C) 2001-2003 DeWitt Clinton
766            
767             =cut
768