File Coverage

blib/lib/Text/Template/Simple/Cache.pm
Criterion Covered Total %
statement 229 274 83.5
branch 70 132 53.0
condition 12 27 44.4
subroutine 28 30 93.3
pod 9 9 100.0
total 348 472 73.7


line stmt bran cond sub pod time code
1             ## no critic (ProhibitUnusedPrivateSubroutines)
2             package Text::Template::Simple::Cache;
3 62     62   375 use strict;
  62         204  
  62         7214  
4 62     62   474 use warnings;
  62         140  
  62         2215  
5              
6 62     62   405 use Carp qw( croak );
  62         136  
  62         3915  
7 62     62   364 use Text::Template::Simple::Constants qw(:all);
  62         125  
  62         49129  
8 62     62   715 use Text::Template::Simple::Util qw( DEBUG LOG ishref fatal );
  62         146  
  62         346359  
9              
10             our $VERSION = '0.86';
11              
12             my $CACHE = {}; # in-memory template cache
13              
14             sub new {
15 90     90 1 317 my $class = shift;
16 90   33     935 my $parent = shift || fatal('tts.cache.new.parent');
17 90         287 my $self = [undef];
18 90         291 bless $self, $class;
19 90         530 $self->[CACHE_PARENT] = $parent;
20 90         372 return $self;
21             }
22              
23             sub id {
24 716     716 1 2808 my $self = shift;
25 716         1090 my $val = shift;
26 716 100       2347 $self->[CACHE_PARENT][CID] = $val if $val;
27 716         2707 return $self->[CACHE_PARENT][CID];
28             }
29              
30             sub type {
31 10     10 1 24 my $self = shift;
32 10         31 my $parent = $self->[CACHE_PARENT];
33 10 100       98 return $parent->[CACHE] ? $parent->[CACHE_DIR] ? 'DISK'
    100          
34             : 'MEMORY'
35             : 'OFF';
36             }
37              
38             sub reset { ## no critic (ProhibitBuiltinHomonyms)
39 2     2 1 5 my $self = shift;
40 2         5 my $parent = $self->[CACHE_PARENT];
41 2         4 %{$CACHE} = ();
  2         25  
42              
43 2 50 33     30 if ( $parent->[CACHE] && $parent->[CACHE_DIR] ) {
44              
45 2         6 my $cdir = $parent->[CACHE_DIR];
46 2         15 require Symbol;
47 2         27 my $CDIRH = Symbol::gensym();
48 2 50       114 opendir $CDIRH, $cdir or fatal( 'tts.cache.opendir' => $cdir, $! );
49 2         10 require File::Spec;
50 2         6 my $ext = quotemeta CACHE_EXT;
51 2         2 my $file;
52              
53 2         23 while ( defined( $file = readdir $CDIRH ) ) {
54 6 100       84 if ( $file =~ m{ ( .* $ext) \z}xmsi ) {
55 2         41 $file = File::Spec->catfile( $parent->[CACHE_DIR], $1 );
56 2 50       15 LOG( UNLINK => $file ) if DEBUG;
57 2         309 unlink $file;
58             }
59             }
60              
61 2         25 closedir $CDIRH;
62             }
63 2         10 return 1;
64             }
65              
66             sub dumper {
67 20     20 1 44 my $self = shift;
68 20   50     73 my $type = shift || 'structure';
69 20   100     84 my $param = shift || {};
70 20 50       96 fatal('tts.cache.dumper.hash') if not ishref $param;
71 20         57 my %valid = map { ($_, $_) } qw( ids structure );
  40         159  
72 20 50       81 fatal('tts.cache.dumper.type', $type) if not $valid{ $type };
73 20         53 my $method = '_dump_' . $type;
74 20         90 return $self->$method( $param ); # TODO: modify the methods to accept HASH
75             }
76              
77             sub _dump_ids {
78 8     8   15 my $self = shift;
79 8         19 my $parent = $self->[CACHE_PARENT];
80 8         14 my $p = shift;
81 8   100     41 my $VAR = $p->{varname} || q{$} . q{CACHE_IDS};
82 8         13 my @rv;
83              
84 8 100       24 if ( $parent->[CACHE_DIR] ) {
85              
86 4         34 require File::Find;
87 4         21 require File::Spec;
88 4         10 my $ext = quotemeta CACHE_EXT;
89 4         74 my $re = qr{ (.+?) $ext \z }xms;
90 4         7 my($id, @list);
91              
92             File::Find::find(
93             {
94             no_chdir => 1,
95             wanted => sub {
96 8 100   8   295 if ( $_ =~ $re ) {
97 4         35 ($id = $1) =~ s{.*[\\/]}{}xms;
98 4         85 push @list, $id;
99             }
100             },
101             },
102 4         350 $parent->[CACHE_DIR]
103             );
104              
105 4         38 @rv = sort @list;
106              
107             }
108             else {
109 4         9 @rv = sort keys %{ $CACHE };
  4         18  
110             }
111              
112 8         49 require Data::Dumper;
113 8         64 my $d = Data::Dumper->new( [ \@rv ], [ $VAR ]);
114 8         256 return $d->Dump;
115             }
116              
117             sub _dump_structure {
118 12     12   23 my $self = shift;
119 12         33 my $parent = $self->[CACHE_PARENT];
120 12         23 my $p = shift;
121 12   100     64 my $VAR = $p->{varname} || q{$} . q{CACHE};
122 12 100       47 my $deparse = $p->{no_deparse} ? 0 : 1;
123 12         106 require Data::Dumper;
124 12         22 my $d;
125              
126 12 100       72 if ( $parent->[CACHE_DIR] ) {
127 6         31 $d = Data::Dumper->new( [ $self->_dump_disk_cache ], [ $VAR ] );
128             }
129             else {
130 6         67 $d = Data::Dumper->new( [ $CACHE ], [ $VAR ]);
131 6 100       286 if ( $deparse ) {
132 4 50       29 fatal('tts.cache.dumper' => $Data::Dumper::VERSION)
133             if !$d->can('Deparse');
134 4         91 $d->Deparse(1);
135             }
136             }
137              
138 12         323 my $str = eval { $d->Dump; };
  12         141  
139              
140 12 50       22276 if ( my $error = $@ ) {
141 0 0 0     0 if ( $deparse && $error =~ RE_DUMP_ERROR ) {
142 0         0 my $name = ref($self) . '::dump_cache';
143 0         0 warn "$name: An error occurred when dumping with deparse "
144             ."(are you under mod_perl?). Re-Dumping without deparse...\n";
145 0         0 warn "$error\n";
146 0         0 my $nd = Data::Dumper->new( [ $CACHE ], [ $VAR ]);
147 0         0 $nd->Deparse(0);
148 0         0 $str = $nd->Dump;
149             }
150             else {
151 0         0 croak $error;
152             }
153             }
154              
155 12         248 return $str;
156             }
157              
158             sub _dump_disk_cache {
159 6     6   48 require File::Find;
160 6         30 require File::Spec;
161 6         19 my $self = shift;
162 6         15 my $parent = $self->[CACHE_PARENT];
163 6         15 my $pattern = quotemeta DISK_CACHE_MARKER;
164 6         12 my $ext = quotemeta CACHE_EXT;
165 6         71 my $re = qr{(.+?) $ext \z}xms;
166 6         28 my(%disk_cache);
167              
168             my $process = sub {
169 12     12   26 my $file = $_;
170 12         83 my @match = $file =~ $re;
171 12 100       3278 return if ! @match;
172 6         36 (my $id = $match[0]) =~ s{.*[\\/]}{}xms;
173 6         36 my $content = $parent->io->slurp( File::Spec->canonpath($file) );
174 6         15 my $ok = 0; # reset
175 6         12 my $_temp = EMPTY_STRING; # reset
176              
177 6         89 foreach my $line ( split m{\n}xms, $content ) {
178 60 50       162 if ( $line =~ m{$pattern}xmso ) {
179 0         0 $ok = 1;
180 0         0 next;
181             }
182 60 50       132 next if not $ok;
183 0         0 $_temp .= $line;
184             }
185              
186 6         467 $disk_cache{ $id } = {
187             MTIME => (stat $file)[STAT_MTIME],
188             CODE => $_temp,
189             };
190 6         38 };
191              
192 6         730 File::Find::find(
193             {
194             no_chdir => 1,
195             wanted => $process,
196             },
197             $parent->[CACHE_DIR]
198             );
199 6         142 return \%disk_cache;
200             }
201              
202             sub size {
203 4     4 1 11 my $self = shift;
204 4         9 my $parent = $self->[CACHE_PARENT];
205              
206 4 50       17 return 0 if not $parent->[CACHE]; # calculate only if cache is enabled
207              
208 4 50       14 if ( my $cdir = $parent->[CACHE_DIR] ) { # disk cache
209 4         27 require File::Find;
210 4         8 my $total = 0;
211 4         9 my $ext = quotemeta CACHE_EXT;
212              
213             my $wanted = sub {
214 6 100   6   384 return if $_ !~ m{ $ext \z }xms; # only calculate "our" files
215 2         96 $total += (stat $_)[STAT_SIZE];
216 4         18 };
217              
218 4         364 File::Find::find( { wanted => $wanted, no_chdir => 1 }, $cdir );
219 4         37 return $total;
220              
221             }
222             else { # in-memory cache
223              
224 0         0 local $SIG{__DIE__};
225 0 0       0 if ( eval { require Devel::Size; 1; } ) {
  0         0  
  0         0  
226 0         0 my $dsv = Devel::Size->VERSION;
227 0 0       0 LOG( DEBUG => "Devel::Size v$dsv is loaded." ) if DEBUG;
228 0 0       0 fatal('tts.cache.develsize.buggy', $dsv) if $dsv < DEVEL_SIZE_VERSION;
229 0         0 my $size = eval { Devel::Size::total_size( $CACHE ) };
  0         0  
230 0 0       0 fatal('tts.cache.develsize.total', $@) if $@;
231 0         0 return $size;
232             }
233             else {
234 0         0 warn "Failed to load Devel::Size: $@\n";
235 0         0 return 0;
236             }
237              
238             }
239             }
240              
241             sub has {
242 24     24 1 73 my($self, @args ) = @_;
243 24 50       90 fatal('tts.cache.pformat') if @args % 2;
244 24         217 my %opt = @args;
245 24         46 my $parent = $self->[CACHE_PARENT];
246              
247 24 50       68 if ( not $parent->[CACHE] ) {
248 0 0       0 LOG( DEBUG => 'Cache is disabled!') if DEBUG;
249 0         0 return;
250             }
251              
252              
253 24         90 my $id = $parent->connector('Cache::ID')->new;
254 24 50       162 my $cid = $opt{id} ? $id->generate($opt{id} , 'custom')
    100          
255             : $opt{data} ? $id->generate($opt{data} )
256             : fatal('tts.cache.incache');
257              
258 24 100       82 if ( my $cdir = $parent->[CACHE_DIR] ) {
259 12         80 require File::Spec;
260 12 50       591 return -e File::Spec->catfile( $cdir, $cid . CACHE_EXT ) ? 1 : 0;
261             }
262             else {
263 12 50       71 return exists $CACHE->{ $cid } ? 1 : 0;
264             }
265             }
266              
267             sub _is_meta_version_old {
268 2     2   4 my $self = shift;
269 2         6 my $v = shift;
270 2 50       9 return 1 if ! $v; # no version? archaic then
271 2         38 my $pv = PARENT->VERSION;
272 2         10 foreach my $i ( $v, $pv ) {
273 4         12 $i =~ tr/_//d; # underscore versions cause warnings
274 4         17 $i += 0; # force number
275             }
276 2 50       13 return 1 if $v < $pv;
277 2         10 return;
278             }
279              
280             sub hit {
281             # TODO: return $CODE, $META;
282 18     18 1 38 my $self = shift;
283 18         39 my $cache_id = shift;
284 18   50     129 my $chkmt = shift || 0;
285              
286 18 100       83 my $method = $self->[CACHE_PARENT][CACHE_DIR] ? '_hit_disk' : '_hit_memory';
287 18         106 return $self->$method( $cache_id, $chkmt );
288             }
289              
290             sub _hit_memory {
291 10     10   25 my($self, $cache_id, $chkmt) = @_;
292 10 50       37 if ( $chkmt ) {
293 0   0     0 my $mtime = $CACHE->{$cache_id}{MTIME} || 0;
294 0 0       0 if ( $mtime != $chkmt ) {
295 0 0       0 LOG( MTIME_DIFF => "\tOLD: $mtime\n\t\tNEW: $chkmt" ) if DEBUG;
296 0         0 return; # i.e.: Update cache
297             }
298             }
299 10 50       47 LOG( MEM_CACHE => EMPTY_STRING ) if DEBUG;
300 10         59 return $CACHE->{$cache_id}->{CODE};
301             }
302              
303             sub _hit_disk {
304 8     8   38 my($self, $cache_id, $chkmt) = @_;
305 8         22 my $parent = $self->[CACHE_PARENT];
306 8         16 my $cdir = $parent->[CACHE_DIR];
307 8         66 require File::Spec;
308 8         190 my $cache = File::Spec->catfile( $cdir, $cache_id . CACHE_EXT );
309 8   66     404 my $ok = -e $cache && ! -d _ && -f _;
310 8 100       70 return if not $ok;
311              
312 2         9 my $disk_cache = $parent->io->slurp($cache);
313 2         6 my %meta;
314 2 50       19 if ( $disk_cache =~ m{ \A \#META: (.+?) \n }xms ) {
315 2         14 %meta = $self->_get_meta( $1 );
316 2 50       10 fatal('tts.cache.hit.meta', $@) if $@;
317             }
318 2 50       13 if ( $self->_is_meta_version_old( $meta{VERSION} ) ) {
319 0   0     0 my $id = $parent->[FILENAME] || $cache_id;
320 0         0 warn "(This messeage will only appear once) $id was compiled with"
321             .' an old version of ' . PARENT . ". Resetting cache.\n";
322 0         0 return;
323             }
324 2 50       11 if ( my $mtime = $meta{CHKMT} ) {
325 0 0       0 if ( $mtime != $chkmt ) {
326 0 0       0 LOG( MTIME_DIFF => "\tOLD: $mtime\n\t\tNEW: $chkmt") if DEBUG;
327 0         0 return; # i.e.: Update cache
328             }
329             }
330              
331 2         19 my($CODE, $error) = $parent->_wrap_compile($disk_cache);
332 2 50       11 $parent->[NEEDS_OBJECT] = $meta{NEEDS_OBJECT} if $meta{NEEDS_OBJECT};
333 2 50       15 $parent->[FAKER_SELF] = $meta{FAKER_SELF} if $meta{FAKER_SELF};
334              
335 2 50       11 fatal('tts.cache.hit.cache', $error) if $error;
336 2 50       12 LOG( FILE_CACHE => EMPTY_STRING ) if DEBUG;
337             #$parent->[COUNTER]++;
338 2         17 return $CODE;
339             }
340              
341             sub populate {
342 498     498 1 1499 my($self, $cache_id, $parsed, $chkmt) = @_;
343 498         1072 my $parent = $self->[CACHE_PARENT];
344 498 100       1731 my $target = ! $parent->[CACHE] ? '_populate_no_cache'
    100          
345             : $parent->[CACHE_DIR] ? '_populate_disk'
346             : '_populate_memory'
347             ;
348              
349 498         3935 my($CODE, $error) = $self->$target( $parsed, $cache_id, $chkmt );
350 498 50       4840 $self->_populate_error( $parsed, $cache_id, $error ) if $error;
351 498         1163 ++$parent->[COUNTER];
352 498         2079 return $CODE;
353             }
354              
355             sub _populate_error {
356 0     0   0 my($self, $parsed, $cache_id, $error) = @_;
357 0         0 my $parent = $self->[CACHE_PARENT];
358 0 0       0 croak $parent->[VERBOSE_ERRORS]
    0          
359             ? $parent->_mini_compiler(
360             $parent->_internal('compile_error'),
361             {
362             CID => $cache_id ? $cache_id : 'N/A',
363             ERROR => $error,
364             PARSED => $parsed,
365             TIDIED => $parent->_tidy( $parsed ),
366             }
367             )
368             : $error
369             ;
370             }
371              
372             sub _populate_no_cache {
373             # cache is disabled
374 484     484   1670 my($self, $parsed, $cache_id, $chkmt) = @_;
375 484         2576 my($CODE, $error) = $self->[CACHE_PARENT]->_wrap_compile($parsed);
376 484 50       2432 LOG( NC_POPUL => $cache_id ) if DEBUG >= DEBUG_LEVEL_INSANE;
377 484         2434 return $CODE, $error;
378             }
379              
380             sub _populate_memory {
381 8     8   21 my($self, $parsed, $cache_id, $chkmt) = @_;
382 8         28 my $parent = $self->[CACHE_PARENT];
383 8         26 my $c = $CACHE->{ $cache_id } = {}; # init
384 8         75 my($CODE, $error) = $parent->_wrap_compile($parsed);
385 8         26 $c->{CODE} = $CODE;
386 8 50       27 $c->{MTIME} = $chkmt if $chkmt;
387 8         25 $c->{NEEDS_OBJECT} = $parent->[NEEDS_OBJECT];
388 8         678 $c->{FAKER_SELF} = $parent->[FAKER_SELF];
389 8 50       139 LOG( MEM_POPUL => $cache_id ) if DEBUG >= DEBUG_LEVEL_INSANE;
390 8         30 return $CODE, $error;
391             }
392              
393             sub _populate_disk {
394 6     6   61 my($self, $parsed, $cache_id, $chkmt) = @_;
395              
396 6         45 require File::Spec;
397 6         32 require Fcntl;
398 6         4519 require IO::File;
399              
400 6         5065 my $parent = $self->[CACHE_PARENT];
401 6         170 my %meta = (
402             CHKMT => $chkmt,
403             NEEDS_OBJECT => $parent->[NEEDS_OBJECT],
404             FAKER_SELF => $parent->[FAKER_SELF],
405             VERSION => PARENT->VERSION,
406             );
407              
408 6         107 my $cache = File::Spec->catfile( $parent->[CACHE_DIR], $cache_id . CACHE_EXT);
409 6         49 my $fh = IO::File->new;
410 6 50       275 $fh->open($cache, '>') or fatal('tts.cache.populate.write', $cache, $!);
411 6         1069 flock $fh, Fcntl::LOCK_EX() if IS_FLOCK;
412 6         37 $parent->io->layer($fh);
413 6         76 my $warn = $parent->_mini_compiler(
414             $parent->_internal('disk_cache_comment'),
415             {
416             NAME => PARENT->class_id,
417             DATE => scalar localtime time,
418             }
419             );
420 6         33 my $ok = print { $fh } '#META:' . $self->_set_meta(\%meta) . "\n",
  6         39  
421             $warn,
422             $parsed;
423 6         368 flock $fh, Fcntl::LOCK_UN() if IS_FLOCK;
424 6 50       94 close $fh or croak "Unable to close filehandle: $!";
425 6 50       238 chmod(CACHE_FMODE, $cache) || fatal('tts.cache.populate.chmod');
426              
427 6         48 my($CODE, $error) = $parent->_wrap_compile($parsed);
428 6 50       29 LOG( DISK_POPUL => $cache_id ) if DEBUG >= DEBUG_LEVEL_INSANE;
429 6         53 return $CODE, $error;
430             }
431              
432             sub _get_meta {
433 2     2   6 my $self = shift;
434 2         6 my $raw = shift;
435 2         15 my %meta = map { split m{:}xms, $_ } split m{[|]}xms, $raw;
  8         29  
436 2         20 return %meta;
437             }
438              
439             sub _set_meta {
440 6     6   13 my $self = shift;
441 6         11 my $meta = shift;
442 6         16 my $rv = join q{|}, map { $_ . q{:} . $meta->{ $_ } } keys %{ $meta };
  24         90  
  6         26  
443 6         183 return $rv;
444             }
445              
446             sub DESTROY {
447 0     0     my $self = shift;
448 0 0         LOG( DESTROY => ref $self ) if DEBUG;
449 0           $self->[CACHE_PARENT] = undef;
450 0           @{$self} = ();
  0            
451 0           return;
452             }
453              
454             1;
455              
456             __END__
457              
458             =head1 NAME
459              
460             Text::Template::Simple::Cache - Cache manager
461              
462             =head1 SYNOPSIS
463              
464             TODO
465              
466             =head1 DESCRIPTION
467              
468             This document describes version C<0.86> of C<Text::Template::Simple::Cache>
469             released on C<5 March 2012>.
470              
471             Cache manager for C<Text::Template::Simple>.
472              
473             =head1 METHODS
474              
475             =head2 new PARENT_OBJECT
476              
477             Constructor. Accepts a C<Text::Template::Simple> object as the parameter.
478              
479             =head2 type
480              
481             Returns the type of the cache.
482              
483             =head2 reset
484              
485             Resets the in-memory cache and deletes all cache files,
486             if you are using a disk cache.
487              
488             =head2 dumper TYPE
489              
490             $template->cache->dumper( $type, \%opt );
491              
492             C<TYPE> can either be C<structure> or C<ids>.
493             C<dumper> accepts some arguments as a hashref:
494              
495             $template->cache->dumper( $type, \%opt );
496              
497             =over 4
498              
499             =item *
500              
501             varname
502              
503             Controls the name of the dumped structure.
504              
505             =item *
506              
507             no_deparse
508              
509             If you set this to a true value, deparsing will be disabled
510              
511             =back
512              
513             =head3 structure
514              
515             Returns a string version of the dumped in-memory or disk-cache.
516             Cache is dumped via L<Data::Dumper>. C<Deparse> option is enabled
517             for in-memory cache.
518              
519             Early versions of C<Data::Dumper> don' t have a C<Deparse>
520             method, so you may need to upgrade your C<Data::Dumper> or
521             disable deparse-ing if you want to use this method.
522              
523             =head3 ids
524              
525             Returns a list including the names (ids) of the templates in
526             the cache.
527              
528             =head2 id
529              
530             Gets/sets the cache id.
531              
532             =head2 size
533              
534             Returns the total cache (disk or memory) size in bytes. If
535             memory cache is used, then you must have L<Devel::Size> installed
536             on your system to get the size of the data structure inside memory.
537              
538             =head2 has data => TEMPLATE_DATA
539              
540             =head2 has id => TEMPLATE_ID
541              
542             This method can be called with C<data> or C<id> named parameter. If you
543             use the two together, C<id> will be used:
544              
545             if ( $template->cache->has( id => 'e369853df766fa44e1ed0ff613f563bd' ) ) {
546             print "ok!";
547             }
548              
549             or
550              
551             if ( $template->cache->has( data => q~Foo is <%=$bar%>~ ) ) {
552             print "ok!";
553             }
554              
555             =head2 hit
556              
557             TODO
558              
559             =head2 populate
560              
561             TODO
562              
563             =head1 AUTHOR
564              
565             Burak Gursoy <burak@cpan.org>.
566              
567             =head1 COPYRIGHT
568              
569             Copyright 2004 - 2012 Burak Gursoy. All rights reserved.
570              
571             =head1 LICENSE
572              
573             This library is free software; you can redistribute it and/or modify
574             it under the same terms as Perl itself, either Perl version 5.12.3 or,
575             at your option, any later version of Perl 5 you may have available.
576              
577             =cut