File Coverage

lib/Template/Provider.pm
Criterion Covered Total %
statement 327 400 81.7
branch 155 246 63.0
condition 54 83 65.0
subroutine 35 38 92.1
pod 5 5 100.0
total 576 772 74.6


line stmt bran cond sub pod time code
1             #============================================================= -*-Perl-*-
2             #
3             # Template::Provider
4             #
5             # DESCRIPTION
6             # This module implements a class which handles the loading, compiling
7             # and caching of templates. Multiple Template::Provider objects can
8             # be stacked and queried in turn to effect a Chain-of-Command between
9             # them. A provider will attempt to return the requested template,
10             # an error (STATUS_ERROR) or decline to provide the template
11             # (STATUS_DECLINE), allowing subsequent providers to attempt to
12             # deliver it. See 'Design Patterns' for further details.
13             #
14             # AUTHORS
15             # Andy Wardley
16             #
17             # Refactored by Bill Moseley for v2.19 to add negative caching (i.e.
18             # tracking templates that are NOTFOUND so that we can decline quickly)
19             # and to provide better support for subclassing the provider.
20             #
21             # COPYRIGHT
22             # Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved.
23             #
24             # This module is free software; you can redistribute it and/or
25             # modify it under the same terms as Perl itself.
26             #
27             # WARNING:
28             # This code is ugly and contorted and is being totally re-written for TT3.
29             # In particular, we'll be throwing errors rather than messing around
30             # returning (value, status) pairs. With the benefit of hindsight, that
31             # was a really bad design decision on my part. I deserve to be knocked
32             # to the ground and kicked around a bit by hoards of angry TT developers
33             # for that one. Bill's refactoring has made the module easier to subclass,
34             # (so you can ease off the kicking now), but it really needs to be totally
35             # redesigned and rebuilt from the ground up along with the bits of TT that
36             # use it. -- abw 2007/04/27
37             #============================================================================
38              
39             package Template::Provider;
40              
41 85     85   2931 use strict;
  85         161  
  85         3137  
42 85     85   1178 use warnings;
  85         263  
  85         2876  
43 85     85   475 use base 'Template::Base';
  85         149  
  85         7241  
44 85     85   1353 use Template::Config;
  85         198  
  85         1861  
45 85     85   469 use Template::Constants;
  85         167  
  85         3221  
46 85     85   43071 use Template::Document;
  85         215  
  85         2280  
47 85     85   701 use File::Basename;
  85         163  
  85         9675  
48 85     85   522 use File::Spec;
  85         158  
  85         3104  
49              
50 85     85   562 use constant PREV => 0;
  85         145  
  85         5915  
51 85     85   467 use constant NAME => 1; # template name -- indexed by this name in LOOKUP
  85         161  
  85         3712  
52 85     85   422 use constant DATA => 2; # Compiled template
  85         169  
  85         4610  
53 85     85   451 use constant LOAD => 3; # mtime of template
  85         152  
  85         3715  
54 85     85   911 use constant NEXT => 4; # link to next item in cache linked list
  85         152  
  85         4245  
55 85     85   498 use constant STAT => 5; # Time last stat()ed
  85         791  
  85         24746  
56              
57             our $VERSION = 2.94;
58             our $DEBUG = 0 unless defined $DEBUG;
59             our $ERROR = '';
60              
61             # name of document class
62             our $DOCUMENT = 'Template::Document' unless defined $DOCUMENT;
63              
64             # maximum time between performing stat() on file to check staleness
65             our $STAT_TTL = 1 unless defined $STAT_TTL;
66              
67             # maximum number of directories in an INCLUDE_PATH, to prevent runaways
68             our $MAX_DIRS = 64 unless defined $MAX_DIRS;
69              
70             # UNICODE is supported in versions of Perl from 5.007 onwards
71             our $UNICODE = $] > 5.007 ? 1 : 0;
72              
73             my $boms = [
74             'UTF-8' => "\x{ef}\x{bb}\x{bf}",
75             'UTF-32BE' => "\x{0}\x{0}\x{fe}\x{ff}",
76             'UTF-32LE' => "\x{ff}\x{fe}\x{0}\x{0}",
77             'UTF-16BE' => "\x{fe}\x{ff}",
78             'UTF-16LE' => "\x{ff}\x{fe}",
79             ];
80              
81             # regex to match relative paths
82             our $RELATIVE_PATH = qr[(?:^|/)\.+/];
83              
84              
85             # hack so that 'use bytes' will compile on versions of Perl earlier than
86             # 5.6, even though we never call _decode_unicode() on those systems
87             BEGIN {
88 85 50   85   551026 if ($] < 5.006) {
89             package bytes;
90 0         0 $INC{'bytes.pm'} = 1;
91             }
92             }
93              
94              
95             #========================================================================
96             # -- PUBLIC METHODS --
97             #========================================================================
98              
99             #------------------------------------------------------------------------
100             # fetch($name)
101             #
102             # Returns a compiled template for the name specified by parameter.
103             # The template is returned from the internal cache if it exists, or
104             # loaded and then subsequently cached. The ABSOLUTE and RELATIVE
105             # configuration flags determine if absolute (e.g. '/something...')
106             # and/or relative (e.g. './something') paths should be honoured. The
107             # INCLUDE_PATH is otherwise used to find the named file. $name may
108             # also be a reference to a text string containing the template text,
109             # or a file handle from which the content is read. The compiled
110             # template is not cached in these latter cases given that there is no
111             # filename to cache under. A subsequent call to store($name,
112             # $compiled) can be made to cache the compiled template for future
113             # fetch() calls, if necessary.
114             #
115             # Returns a compiled template or (undef, STATUS_DECLINED) if the
116             # template could not be found. On error (e.g. the file was found
117             # but couldn't be read or parsed), the pair ($error, STATUS_ERROR)
118             # is returned. The TOLERANT configuration option can be set to
119             # downgrade any errors to STATUS_DECLINE.
120             #------------------------------------------------------------------------
121              
122             sub fetch {
123 1428     1428 1 2978 my ($self, $name) = @_;
124 1428         2060 my ($data, $error);
125              
126              
127 1428 100       6955 if (ref $name) {
    100          
    100          
128             # $name can be a reference to a scalar, GLOB or file handle
129 1198         4874 ($data, $error) = $self->_load($name);
130 1198 50       6382 ($data, $error) = $self->_compile($data)
131             unless $error;
132             $data = $data->{ data }
133 1198 100       8417 unless $error;
134             }
135             elsif (File::Spec->file_name_is_absolute($name)) {
136             # absolute paths (starting '/') allowed if ABSOLUTE set
137             ($data, $error) = $self->{ ABSOLUTE }
138             ? $self->_fetch($name)
139             : $self->{ TOLERANT }
140 31 100       148 ? (undef, Template::Constants::STATUS_DECLINED)
    100          
141             : ("$name: absolute paths are not allowed (set ABSOLUTE option)",
142             Template::Constants::STATUS_ERROR);
143             }
144             elsif ($name =~ m/$RELATIVE_PATH/o) {
145             # anything starting "./" is relative to cwd, allowed if RELATIVE set
146             ($data, $error) = $self->{ RELATIVE }
147             ? $self->_fetch($name)
148             : $self->{ TOLERANT }
149 7 100       45 ? (undef, Template::Constants::STATUS_DECLINED)
    100          
150             : ("$name: relative paths are not allowed (set RELATIVE option)",
151             Template::Constants::STATUS_ERROR);
152             }
153             else {
154             # otherwise, it's a file name relative to INCLUDE_PATH
155             ($data, $error) = $self->{ INCLUDE_PATH }
156 192 50       1466 ? $self->_fetch_path($name)
157             : (undef, Template::Constants::STATUS_DECLINED);
158             }
159              
160             # $self->_dump_cache()
161             # if $DEBUG > 1;
162              
163 1428         8252 return ($data, $error);
164             }
165              
166              
167             #------------------------------------------------------------------------
168             # store($name, $data)
169             #
170             # Store a compiled template ($data) in the cached as $name.
171             # Returns compiled template
172             #------------------------------------------------------------------------
173              
174             sub store {
175 103     103 1 252 my ($self, $name, $data) = @_;
176 103         657 $self->_store($name, {
177             data => $data,
178             load => 0,
179             });
180             }
181              
182              
183             #------------------------------------------------------------------------
184             # load($name)
185             #
186             # Load a template without parsing/compiling it, suitable for use with
187             # the INSERT directive. There's some duplication with fetch() and at
188             # some point this could be reworked to integrate them a little closer.
189             #------------------------------------------------------------------------
190              
191             sub load {
192 17     17 1 32 my ($self, $name) = @_;
193 17         22 my ($data, $error);
194 17         26 my $path = $name;
195              
196 17 100       203 if (File::Spec->file_name_is_absolute($name)) {
    100          
197             # absolute paths (starting '/') allowed if ABSOLUTE set
198             $error = "$name: absolute paths are not allowed (set ABSOLUTE option)"
199 3 100       14 unless $self->{ ABSOLUTE };
200             }
201             elsif ($name =~ m[$RELATIVE_PATH]o) {
202             # anything starting "./" is relative to cwd, allowed if RELATIVE set
203             $error = "$name: relative paths are not allowed (set RELATIVE option)"
204 2 100       11 unless $self->{ RELATIVE };
205             }
206             else {
207 12   50     96 INCPATH: {
208             # otherwise, it's a file name relative to INCLUDE_PATH
209 12         18 my $paths = $self->paths()
210             || return ($self->error(), Template::Constants::STATUS_ERROR);
211              
212 12         30 foreach my $dir (@$paths) {
213 13         208 $path = File::Spec->catfile($dir, $name);
214             last INCPATH
215 13 100       64 if $self->_template_modified($path);
216             }
217 2         5 undef $path; # not found
218             }
219             }
220              
221             # Now fetch the content
222 17 100 100     137 ($data, $error) = $self->_template_content($path)
223             if defined $path && !$error;
224              
225 17 100       60 if ($error) {
    100          
226             return $self->{ TOLERANT }
227 3 100       29 ? (undef, Template::Constants::STATUS_DECLINED)
228             : ($error, Template::Constants::STATUS_ERROR);
229             }
230             elsif (! defined $path) {
231 2         9 return (undef, Template::Constants::STATUS_DECLINED);
232             }
233             else {
234 12         55 return ($data, Template::Constants::STATUS_OK);
235             }
236             }
237              
238              
239              
240             #------------------------------------------------------------------------
241             # include_path(\@newpath)
242             #
243             # Accessor method for the INCLUDE_PATH setting. If called with an
244             # argument, this method will replace the existing INCLUDE_PATH with
245             # the new value.
246             #------------------------------------------------------------------------
247              
248             sub include_path {
249 0     0 1 0 my ($self, $path) = @_;
250 0 0       0 $self->{ INCLUDE_PATH } = $path if $path;
251 0         0 return $self->{ INCLUDE_PATH };
252             }
253              
254              
255             #------------------------------------------------------------------------
256             # paths()
257             #
258             # Evaluates the INCLUDE_PATH list, ignoring any blank entries, and
259             # calling and subroutine or object references to return dynamically
260             # generated path lists. Returns a reference to a new list of paths
261             # or undef on error.
262             #------------------------------------------------------------------------
263              
264             sub paths {
265 207     207 1 310 my $self = shift;
266 207         272 my @ipaths = @{ $self->{ INCLUDE_PATH } };
  207         722  
267 207         402 my (@opaths, $dpaths, $dir);
268 207         308 my $count = $MAX_DIRS;
269              
270 207   100     1431 while (@ipaths && --$count) {
271 405   50     1180 $dir = shift @ipaths || next;
272              
273             # $dir can be a sub or object ref which returns a reference
274             # to a dynamically generated list of search paths.
275              
276 405 100 66     1607 if (ref $dir eq 'CODE') {
    100          
277 46         57 eval { $dpaths = &$dir() };
  46         378  
278 46 50       302 if ($@) {
279 0         0 chomp $@;
280 0         0 return $self->error($@);
281             }
282 46         102 unshift(@ipaths, @$dpaths);
283 46         239 next;
284             }
285             elsif (ref($dir) && UNIVERSAL::can($dir, 'paths')) {
286 5   50     19 $dpaths = $dir->paths()
287             || return $self->error($dir->error());
288 5         82 unshift(@ipaths, @$dpaths);
289 5         27 next;
290             }
291             else {
292 354         1561 push(@opaths, $dir);
293             }
294             }
295 207 100       587 return $self->error("INCLUDE_PATH exceeds $MAX_DIRS directories")
296             if @ipaths;
297              
298 206         982 return \@opaths;
299             }
300              
301              
302             #------------------------------------------------------------------------
303             # DESTROY
304             #
305             # The provider cache is implemented as a doubly linked list which Perl
306             # cannot free by itself due to the circular references between NEXT <=>
307             # PREV items. This cleanup method walks the list deleting all the NEXT/PREV
308             # references, allowing the proper cleanup to occur and memory to be
309             # repooled.
310             #------------------------------------------------------------------------
311              
312             sub DESTROY {
313 134     134   327 my $self = shift;
314 134         242 my ($slot, $next);
315              
316 134         334 $slot = $self->{ HEAD };
317 134         1747 while ($slot) {
318 92         264 $next = $slot->[ NEXT ];
319 92         352 undef $slot->[ PREV ];
320 92         111 undef $slot->[ NEXT ];
321 92         192 $slot = $next;
322             }
323 134         308 undef $self->{ HEAD };
324 134         20063 undef $self->{ TAIL };
325             }
326              
327              
328              
329              
330             #========================================================================
331             # -- PRIVATE METHODS --
332             #========================================================================
333              
334             #------------------------------------------------------------------------
335             # _init()
336             #
337             # Initialise the cache.
338             #------------------------------------------------------------------------
339              
340             sub _init {
341 150     150   355 my ($self, $params) = @_;
342 150         356 my $size = $params->{ CACHE_SIZE };
343 150   100     8850 my $path = $params->{ INCLUDE_PATH } || '.';
344 150   100     895 my $cdir = $params->{ COMPILE_DIR } || '';
345 150         10670 my $dlim = $params->{ DELIMITER };
346 150         326 my $debug;
347              
348             # tweak delim to ignore C:/
349 150 50       501 unless (defined $dlim) {
350 150 50       875 $dlim = ($^O eq 'MSWin32') ? ':(?!\\/)' : ':';
351             }
352              
353             # coerce INCLUDE_PATH to an array ref, if not already so
354 150 100       1923 $path = [ split(/$dlim/, $path) ]
355             unless ref $path eq 'ARRAY';
356              
357             # don't allow a CACHE_SIZE 1 because it breaks things and the
358             # additional checking isn't worth it
359 150 0 0     610 $size = 2
      33        
360             if defined $size && ($size == 1 || $size < 0);
361              
362 150 100       513 if (defined ($debug = $params->{ DEBUG })) {
363 17         70 $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PROVIDER
364             | Template::Constants::DEBUG_FLAGS );
365             }
366             else {
367 133         923 $self->{ DEBUG } = $DEBUG;
368             }
369              
370 150 50       580 if ($self->{ DEBUG }) {
371 0         0 local $" = ', ';
372 0 0       0 $self->debug("creating cache of ",
373             defined $size ? $size : 'unlimited',
374             " slots for [ @$path ]");
375             }
376              
377             # create COMPILE_DIR and sub-directories representing each INCLUDE_PATH
378             # element in which to store compiled files
379 150 100       502 if ($cdir) {
380 4         26 require File::Path;
381 4         86 foreach my $dir (@$path) {
382 4 50       16 next if ref $dir;
383 4         11 my $wdir = $dir;
384 4 50       16 $wdir =~ s[:][]g if $^O eq 'MSWin32';
385 4         21 $wdir =~ /(.*)/; # untaint
386 4         14 $wdir = "$1"; # quotes work around bug in Strawberry Perl
387 4         84 $wdir = File::Spec->catfile($cdir, $wdir);
388 4 100       1461 File::Path::mkpath($wdir) unless -d $wdir;
389             }
390             }
391              
392 150         617 $self->{ LOOKUP } = { };
393 150         412 $self->{ NOTFOUND } = { }; # Tracks templates *not* found.
394 150         357 $self->{ SLOTS } = 0;
395 150         349 $self->{ SIZE } = $size;
396 150         334 $self->{ INCLUDE_PATH } = $path;
397 150         512 $self->{ DELIMITER } = $dlim;
398 150         350 $self->{ COMPILE_DIR } = $cdir;
399 150   100     970 $self->{ COMPILE_EXT } = $params->{ COMPILE_EXT } || '';
400 150   100     899 $self->{ ABSOLUTE } = $params->{ ABSOLUTE } || 0;
401 150   100     1063 $self->{ RELATIVE } = $params->{ RELATIVE } || 0;
402 150   100     888 $self->{ TOLERANT } = $params->{ TOLERANT } || 0;
403 150   33     864 $self->{ DOCUMENT } = $params->{ DOCUMENT } || $DOCUMENT;
404 150         385 $self->{ PARSER } = $params->{ PARSER };
405 150         535 $self->{ DEFAULT } = $params->{ DEFAULT };
406 150         379 $self->{ ENCODING } = $params->{ ENCODING };
407             # $self->{ PREFIX } = $params->{ PREFIX };
408 150   33     986 $self->{ STAT_TTL } = $params->{ STAT_TTL } || $STAT_TTL;
409 150         1088 $self->{ PARAMS } = $params;
410              
411             # look for user-provided UNICODE parameter or use default from package var
412             $self->{ UNICODE } = defined $params->{ UNICODE }
413 150 50       621 ? $params->{ UNICODE } : $UNICODE;
414              
415 150         1765 return $self;
416             }
417              
418              
419             #------------------------------------------------------------------------
420             # _fetch($name, $t_name)
421             #
422             # Fetch a file from cache or disk by specification of an absolute or
423             # relative filename. No search of the INCLUDE_PATH is made. If the
424             # file is found and loaded, it is compiled and cached.
425             # Call with:
426             # $name = path to search (possible prefixed by INCLUDE_PATH)
427             # $t_name = template name
428             #------------------------------------------------------------------------
429              
430             sub _fetch {
431 323     323   595 my ($self, $name, $t_name) = @_;
432 323         1599 my $stat_ttl = $self->{ STAT_TTL };
433              
434 323 50       1061 $self->debug("_fetch($name)") if $self->{ DEBUG };
435              
436             # First see if the named template is in the memory cache
437 323 100       1066 if ((my $slot = $self->{ LOOKUP }->{ $name })) {
438             # Test if cache is fresh, and reload/compile if not.
439 78         273 my ($data, $error) = $self->_refresh($slot);
440              
441 78 100       318 return $error
442             ? ( $data, $error ) # $data may contain error text
443             : $slot->[ DATA ]; # returned document object
444             }
445              
446             # Otherwise, see if we already know the template is not found
447 245 100       828 if (my $last_stat_time = $self->{ NOTFOUND }->{ $name }) {
448 56         127 my $expires_in = $last_stat_time + $stat_ttl - time;
449 56 100       134 if ($expires_in > 0) {
450             $self->debug(" file [$name] in negative cache. Expires in $expires_in seconds")
451 54 50       140 if $self->{ DEBUG };
452 54         147 return (undef, Template::Constants::STATUS_DECLINED);
453             }
454             else {
455 2         6 delete $self->{ NOTFOUND }->{ $name };
456             }
457             }
458              
459             # Is there an up-to-date compiled version on disk?
460 191 100       609 if ($self->_compiled_is_current($name)) {
461             # require() the compiled template.
462 17         53 my $compiled_template = $self->_load_compiled( $self->_compiled_filename($name) );
463              
464             # Store and return the compiled template
465 17 50       102 return $self->store( $name, $compiled_template ) if $compiled_template;
466              
467             # Problem loading compiled template:
468             # warn and continue to fetch source template
469 0         0 warn($self->error(), "\n");
470             }
471              
472             # load template from source
473 174         615 my ($template, $error) = $self->_load($name, $t_name);
474              
475 174 100       568 if ($error) {
476             # Template could not be fetched. Add to the negative/notfound cache.
477 87         304 $self->{ NOTFOUND }->{ $name } = time;
478 87         221 return ( $template, $error );
479             }
480              
481             # compile template source
482 87         449 ($template, $error) = $self->_compile($template, $self->_compiled_filename($name) );
483              
484 87 100       591 if ($error) {
485             # return any compile time error
486 1         6 return ($template, $error);
487             }
488             else {
489             # Store compiled template and return it
490 86         560 return $self->store($name, $template->{data}) ;
491             }
492             }
493              
494              
495             #------------------------------------------------------------------------
496             # _fetch_path($name)
497             #
498             # Fetch a file from cache or disk by specification of an absolute cache
499             # name (e.g. 'header') or filename relative to one of the INCLUDE_PATH
500             # directories. If the file isn't already cached and can be found and
501             # loaded, it is compiled and cached under the full filename.
502             #------------------------------------------------------------------------
503              
504             sub _fetch_path {
505 195     195   354 my ($self, $name) = @_;
506              
507 195 50       576 $self->debug("_fetch_path($name)") if $self->{ DEBUG };
508              
509             # the template may have been stored using a non-filename name
510             # so look for the plain name in the cache first
511 195 50       681 if ((my $slot = $self->{ LOOKUP }->{ $name })) {
512             # cached entry exists, so refresh slot and extract data
513 0         0 my ($data, $error) = $self->_refresh($slot);
514              
515 0 0       0 return $error
516             ? ($data, $error)
517             : ($slot->[ DATA ], $error );
518             }
519              
520 195   100     724 my $paths = $self->paths
521             || return ( $self->error, Template::Constants::STATUS_ERROR );
522              
523             # search the INCLUDE_PATH for the file, in cache or on disk
524 194         485 foreach my $dir (@$paths) {
525 293         4041 my $path = File::Spec->catfile($dir, $name);
526              
527 293 50       1052 $self->debug("searching path: $path\n") if $self->{ DEBUG };
528              
529 293         840 my ($data, $error) = $self->_fetch( $path, $name );
530              
531             # Return if no error or if a serious error.
532 293 100 100     1992 return ( $data, $error )
533             if !$error || $error == Template::Constants::STATUS_ERROR;
534              
535             }
536              
537             # not found in INCLUDE_PATH, now try DEFAULT
538 41 100 100     192 return $self->_fetch_path( $self->{DEFAULT} )
539             if defined $self->{DEFAULT} && $name ne $self->{DEFAULT};
540              
541             # We could not handle this template name
542 38         113 return (undef, Template::Constants::STATUS_DECLINED);
543             }
544              
545             sub _compiled_filename {
546 295     295   466 my ($self, $file) = @_;
547 295         1031 my ($compext, $compdir) = @$self{ qw( COMPILE_EXT COMPILE_DIR ) };
548 295         396 my ($path, $compiled);
549              
550             return undef
551 295 100 66     2153 unless $compext || $compdir;
552              
553 62         80 $path = $file;
554 62 50       298 $path =~ /^(.+)$/s or die "invalid filename: $path";
555 62 50       204 $path =~ s[:][]g if $^O eq 'MSWin32';
556              
557 62         115 $compiled = "$path$compext";
558 62 100       539 $compiled = File::Spec->catfile($compdir, $compiled) if length $compdir;
559              
560 62         298 return $compiled;
561             }
562              
563             sub _load_compiled {
564 17     17   33 my ($self, $file) = @_;
565 17         24 my $compiled;
566              
567             # load compiled template via require(); we zap any
568             # %INC entry to ensure it is reloaded (we don't
569             # want 1 returned by require() to say it's in memory)
570 17         64 delete $INC{ $file };
571 17         27 eval { $compiled = require $file; };
  17         13080  
572 17 50       113 return $@
573             ? $self->error("compiled template $compiled: $@")
574             : $compiled;
575             }
576              
577             #------------------------------------------------------------------------
578             # _load($name, $alias)
579             #
580             # Load template text from a string ($name = scalar ref), GLOB or file
581             # handle ($name = ref), or from an absolute filename ($name = scalar).
582             # Returns a hash array containing the following items:
583             # name filename or $alias, if provided, or 'input text', etc.
584             # text template text
585             # time modification time of file, or current time for handles/strings
586             # load time file was loaded (now!)
587             #
588             # On error, returns ($error, STATUS_ERROR), or (undef, STATUS_DECLINED)
589             # if TOLERANT is set.
590             #------------------------------------------------------------------------
591              
592             sub _load {
593 1374     1374   2437 my ($self, $name, $alias) = @_;
594 1374         1814 my ($data, $error);
595 1374         3379 my $tolerant = $self->{ TOLERANT };
596 1374         2888 my $now = time;
597              
598 1374 100 100     7384 $alias = $name unless defined $alias or ref $name;
599              
600             $self->debug("_load($name, ", defined $alias ? $alias : '',
601 1374 0       4268 ')') if $self->{ DEBUG };
    50          
602              
603             # SCALAR ref is the template text
604 1374 100       3803 if (ref $name eq 'SCALAR') {
605             # $name can be a SCALAR reference to the input text...
606             return {
607 1197 50       20529 name => defined $alias ? $alias : 'input text',
    50          
608             path => defined $alias ? $alias : 'input text',
609             text => $$name,
610             time => $now,
611             load => 0,
612             };
613             }
614              
615             # Otherwise, assume GLOB as a file handle
616 177 100       430 if (ref $name) {
617 1         6 local $/;
618 1         31 my $text = <$name>;
619 1 50       11 $text = $self->_decode_unicode($text) if $self->{ UNICODE };
620             return {
621 1 50       14 name => defined $alias ? $alias : 'input file handle',
    50          
622             path => defined $alias ? $alias : 'input file handle',
623             text => $text,
624             time => $now,
625             load => 0,
626             };
627             }
628              
629             # Otherwise, it's the name of the template
630 176 100       511 if ( $self->_template_modified( $name ) ) { # does template exist?
631 89         370 my ($text, $error, $mtime ) = $self->_template_content( $name );
632 89 50       444 unless ( $error ) {
633 89 50       667 $text = $self->_decode_unicode($text) if $self->{ UNICODE };
634             return {
635 89         5547 name => $alias,
636             path => $name,
637             text => $text,
638             time => $mtime,
639             load => $now,
640             };
641             }
642              
643 0 0       0 return ( $error, Template::Constants::STATUS_ERROR )
644             unless $tolerant;
645             }
646              
647             # Unable to process template, pass onto the next Provider.
648 87         282 return (undef, Template::Constants::STATUS_DECLINED);
649             }
650              
651              
652             #------------------------------------------------------------------------
653             # _refresh(\@slot)
654             #
655             # Private method called to mark a cache slot as most recently used.
656             # A reference to the slot array should be passed by parameter. The
657             # slot is relocated to the head of the linked list. If the file from
658             # which the data was loaded has been updated since it was compiled, then
659             # it is re-loaded from disk and re-compiled.
660             #------------------------------------------------------------------------
661              
662             sub _refresh {
663 78     78   141 my ($self, $slot) = @_;
664 78         225 my $stat_ttl = $self->{ STAT_TTL };
665 78         117 my ($head, $file, $data, $error);
666              
667 0 0       0 $self->debug("_refresh([ ",
668             join(', ', map { defined $_ ? $_ : '' } @$slot),
669 78 50       221 '])') if $self->{ DEBUG };
670              
671             # if it's more than $STAT_TTL seconds since we last performed a
672             # stat() on the file then we need to do it again and see if the file
673             # time has changed
674 78         124 my $now = time;
675 78         196 my $expires_in_sec = $slot->[ STAT ] + $stat_ttl - $now;
676              
677 78 100       364 if ( $expires_in_sec <= 0 ) { # Time to check!
    50          
678 2         5 $slot->[ STAT ] = $now;
679              
680             # Grab mtime of template.
681             # Seems like this should be abstracted to compare to
682             # just ask for a newer compiled template (if it's newer)
683             # and let that check for a newer template source.
684 2         16 my $template_mtime = $self->_template_modified( $slot->[ NAME ] );
685 2 50 33     21 if ( ! defined $template_mtime || ( $template_mtime != $slot->[ LOAD ] )) {
686             $self->debug("refreshing cache file ", $slot->[ NAME ])
687 2 50       16 if $self->{ DEBUG };
688              
689 2         17 ($data, $error) = $self->_load($slot->[ NAME ], $slot->[ DATA ]->{ name });
690 2 50       20 ($data, $error) = $self->_compile($data)
691             unless $error;
692              
693 2 100       34 if ($error) {
694             # if the template failed to load/compile then we wipe out the
695             # STAT entry. This forces the provider to try and reload it
696             # each time instead of using the previously cached version
697             # until $STAT_TTL is next up
698 1         5 $slot->[ STAT ] = 0;
699             }
700             else {
701 1         5 $slot->[ DATA ] = $data->{ data };
702 1         39 $slot->[ LOAD ] = $data->{ time };
703             }
704             }
705              
706             } elsif ( $self->{ DEBUG } ) {
707 0         0 $self->debug( sprintf('STAT_TTL not met for file [%s]. Expires in %d seconds',
708             $slot->[ NAME ], $expires_in_sec ) );
709             }
710              
711             # Move this slot to the head of the list
712 78 100       283 unless( $self->{ HEAD } == $slot ) {
713             # remove existing slot from usage chain...
714 47 50       124 if ($slot->[ PREV ]) {
715 47         95 $slot->[ PREV ]->[ NEXT ] = $slot->[ NEXT ];
716             }
717             else {
718 0         0 $self->{ HEAD } = $slot->[ NEXT ];
719             }
720 47 100       105 if ($slot->[ NEXT ]) {
721 18         39 $slot->[ NEXT ]->[ PREV ] = $slot->[ PREV ];
722             }
723             else {
724 29         102 $self->{ TAIL } = $slot->[ PREV ];
725             }
726              
727             # ..and add to start of list
728 47         73 $head = $self->{ HEAD };
729 47 50       122 $head->[ PREV ] = $slot if $head;
730 47         58 $slot->[ PREV ] = undef;
731 47         67 $slot->[ NEXT ] = $head;
732 47         80 $self->{ HEAD } = $slot;
733             }
734              
735 78         212 return ($data, $error);
736             }
737              
738              
739              
740             #------------------------------------------------------------------------
741             # _store($name, $data)
742             #
743             # Private method called to add a data item to the cache. If the cache
744             # size limit has been reached then the oldest entry at the tail of the
745             # list is removed and its slot relocated to the head of the list and
746             # reused for the new data item. If the cache is under the size limit,
747             # or if no size limit is defined, then the item is added to the head
748             # of the list.
749             # Returns compiled template
750             #------------------------------------------------------------------------
751              
752             sub _store {
753 103     103   235 my ($self, $name, $data, $compfile) = @_;
754 103         299 my $size = $self->{ SIZE };
755 103         161 my ($slot, $head);
756              
757             # Return if memory cache disabled. (overriding code should also check)
758             # $$$ What's the expected behaviour of store()? Can't tell from the
759             # docs if you can call store() when SIZE = 0.
760 103 50 33     453 return $data->{data} if defined $size and !$size;
761              
762             # extract the compiled template from the data hash
763 103         215 $data = $data->{ data };
764 103 50       391 $self->debug("_store($name, $data)") if $self->{ DEBUG };
765              
766             # check the modification time -- extra stat here
767 103         435 my $load = $self->_modified($name);
768              
769 103 50 33     461 if (defined $size && $self->{ SLOTS } >= $size) {
770             # cache has reached size limit, so reuse oldest entry
771 0 0       0 $self->debug("reusing oldest cache entry (size limit reached: $size)\nslots: $self->{ SLOTS }") if $self->{ DEBUG };
772              
773             # remove entry from tail of list
774 0         0 $slot = $self->{ TAIL };
775 0         0 $slot->[ PREV ]->[ NEXT ] = undef;
776 0         0 $self->{ TAIL } = $slot->[ PREV ];
777              
778             # remove name lookup for old node
779 0         0 delete $self->{ LOOKUP }->{ $slot->[ NAME ] };
780              
781             # add modified node to head of list
782 0         0 $head = $self->{ HEAD };
783 0 0       0 $head->[ PREV ] = $slot if $head;
784 0         0 @$slot = ( undef, $name, $data, $load, $head, time );
785 0         0 $self->{ HEAD } = $slot;
786              
787             # add name lookup for new node
788 0         0 $self->{ LOOKUP }->{ $name } = $slot;
789             }
790             else {
791             # cache is under size limit, or none is defined
792              
793 103 50       367 $self->debug("adding new cache entry") if $self->{ DEBUG };
794              
795             # add new node to head of list
796 103         250 $head = $self->{ HEAD };
797 103         410 $slot = [ undef, $name, $data, $load, $head, time ];
798 103 100       392 $head->[ PREV ] = $slot if $head;
799 103         235 $self->{ HEAD } = $slot;
800 103 100       378 $self->{ TAIL } = $slot unless $self->{ TAIL };
801              
802             # add lookup from name to slot and increment nslots
803 103         316 $self->{ LOOKUP }->{ $name } = $slot;
804 103         233 $self->{ SLOTS }++;
805             }
806              
807 103         709 return $data;
808             }
809              
810              
811             #------------------------------------------------------------------------
812             # _compile($data)
813             #
814             # Private method called to parse the template text and compile it into
815             # a runtime form. Creates and delegates a Template::Parser object to
816             # handle the compilation, or uses a reference passed in PARSER. On
817             # success, the compiled template is stored in the 'data' item of the
818             # $data hash and returned. On error, ($error, STATUS_ERROR) is returned,
819             # or (undef, STATUS_DECLINED) if the TOLERANT flag is set.
820             # The optional $compiled parameter may be passed to specify
821             # the name of a compiled template file to which the generated Perl
822             # code should be written. Errors are (for now...) silently
823             # ignored, assuming that failures to open a file for writing are
824             # intentional (e.g directory write permission).
825             #------------------------------------------------------------------------
826              
827             sub _compile {
828 1287     1287   2511 my ($self, $data, $compfile) = @_;
829 1287         2752 my $text = $data->{ text };
830 1287         1884 my ($parsedoc, $error);
831              
832             $self->debug("_compile($data, ",
833             defined $compfile ? $compfile : '', ')')
834 1287 0       3975 if $self->{ DEBUG };
    50          
835              
836             my $parser = $self->{ PARSER }
837             ||= Template::Config->parser($self->{ PARAMS })
838 1287   50     13072 || return (Template::Config->error(), Template::Constants::STATUS_ERROR);
      66        
839              
840             # discard the template text - we don't need it any more
841 1287         4343 delete $data->{ text };
842              
843             # call parser to compile template into Perl code
844 1287 100       6444 if ($parsedoc = $parser->parse($text, $data)) {
845              
846             $parsedoc->{ METADATA } = {
847             'name' => $data->{ name },
848             'modtime' => $data->{ time },
849 1284         4306 %{ $parsedoc->{ METADATA } },
  1284         7385  
850             };
851              
852             # write the Perl code to the file $compfile, if defined
853 1284 100       3641 if ($compfile) {
854 14         903 my $basedir = &File::Basename::dirname($compfile);
855 14         49 $basedir =~ /(.*)/;
856 14         40 $basedir = $1;
857              
858 14 100       762 unless (-d $basedir) {
859 6         9 eval { File::Path::mkpath($basedir) };
  6         1500  
860 6 50       25 $error = "failed to create compiled templates directory: $basedir ($@)"
861             if ($@);
862             }
863              
864 14 50       50 unless ($error) {
865 14         40 my $docclass = $self->{ DOCUMENT };
866 14 50       154 $error = 'cache failed to write '
867             . &File::Basename::basename($compfile)
868             . ': ' . $docclass->error()
869             unless $docclass->write_perl_file($compfile, $parsedoc);
870             }
871              
872             # set atime and mtime of newly compiled file, don't bother
873             # if time is undef
874 14 50 33     117 if (!defined($error) && defined $data->{ time }) {
875 14 50       109 my ($cfile) = $compfile =~ /^(.+)$/s or do {
876 0         0 return("invalid filename: $compfile",
877             Template::Constants::STATUS_ERROR);
878             };
879              
880 14         76 my ($ctime) = $data->{ time } =~ /^(\d+)$/;
881 14 50 33     58 unless ($ctime || $ctime eq 0) {
882 0         0 return("invalid time: $ctime",
883             Template::Constants::STATUS_ERROR);
884             }
885 14         415 utime($ctime, $ctime, $cfile);
886              
887             $self->debug(" cached compiled template to file [$compfile]")
888 14 50       72 if $self->{ DEBUG };
889             }
890             }
891              
892 1284 50       3582 unless ($error) {
893             return $data ## RETURN ##
894 1284 50       9634 if $data->{ data } = $DOCUMENT->new($parsedoc);
895 0         0 $error = $Template::Document::ERROR;
896             }
897             }
898             else {
899 3         24 $error = Template::Exception->new( 'parse', "$data->{ name } " .
900             $parser->error() );
901             }
902              
903             # return STATUS_ERROR, or STATUS_DECLINED if we're being tolerant
904             return $self->{ TOLERANT }
905 3 50       99 ? (undef, Template::Constants::STATUS_DECLINED)
906             : ($error, Template::Constants::STATUS_ERROR)
907             }
908              
909             #------------------------------------------------------------------------
910             # _compiled_is_current( $template_name )
911             #
912             # Returns true if $template_name and its compiled name
913             # exist and they have the same mtime.
914             #------------------------------------------------------------------------
915              
916             sub _compiled_is_current {
917 191     191   312 my ( $self, $template_name ) = @_;
918 191   100     773 my $compiled_name = $self->_compiled_filename($template_name) || return;
919 31   100     1532 my $compiled_mtime = (stat($compiled_name))[9] || return;
920 18   50     73 my $template_mtime = $self->_template_modified( $template_name ) || return;
921              
922             # This was >= in the 2.15, but meant that downgrading
923             # a source template would not get picked up.
924 18         78 return $compiled_mtime == $template_mtime;
925             }
926              
927              
928             #------------------------------------------------------------------------
929             # _template_modified($path)
930             #
931             # Returns the last modified time of the $path.
932             # Returns undef if the path does not exist.
933             # Override if templates are not on disk, for example
934             #------------------------------------------------------------------------
935              
936             sub _template_modified {
937 312     312   489 my $self = shift;
938 312   50     804 my $template = shift || return;
939 312         8636 return (stat( $template ))[9];
940             }
941              
942             #------------------------------------------------------------------------
943             # _template_content($path)
944             #
945             # Fetches content pointed to by $path.
946             # Returns the content in scalar context.
947             # Returns ($data, $error, $mtime) in list context where
948             # $data - content
949             # $error - error string if there was an error, otherwise undef
950             # $mtime - last modified time from calling stat() on the path
951             #------------------------------------------------------------------------
952              
953             sub _template_content {
954 101     101   194 my ($self, $path) = @_;
955              
956 101 50       949 return (undef, "No path specified to fetch content from ")
957             unless $path;
958              
959 101         250 my $data;
960             my $mod_date;
961 0         0 my $error;
962              
963 101         311 local *FH;
964 101 50       7432 if(-d $path) {
    50          
965 0         0 $error = "$path: not a file";
966             }
967             elsif (open(FH, "< $path")) {
968 101         682 local $/;
969 101         331 binmode(FH);
970 101         255076 $data = ;
971 101         2183 $mod_date = (stat($path))[9];
972 101         1753 close(FH);
973             }
974             else {
975 0         0 $error = "$path: $!";
976             }
977              
978             return wantarray
979 101 50       791 ? ( $data, $error, $mod_date )
980             : $data;
981             }
982              
983              
984             #------------------------------------------------------------------------
985             # _modified($name)
986             # _modified($name, $time)
987             #
988             # When called with a single argument, it returns the modification time
989             # of the named template. When called with a second argument it returns
990             # true if $name has been modified since $time.
991             #------------------------------------------------------------------------
992              
993             sub _modified {
994 103     103   224 my ($self, $name, $time) = @_;
995 103   50     377 my $load = $self->_template_modified($name)
996             || return $time ? 1 : 0;
997              
998 103 50       476 return $time
999             ? $load > $time
1000             : $load;
1001             }
1002              
1003             #------------------------------------------------------------------------
1004             # _dump()
1005             #
1006             # Debug method which returns a string representing the internal object
1007             # state.
1008             #------------------------------------------------------------------------
1009              
1010             sub _dump {
1011 0     0   0 my $self = shift;
1012 0         0 my $size = $self->{ SIZE };
1013 0         0 my $parser = $self->{ PARSER };
1014 0 0       0 $parser = $parser ? $parser->_dump() : '';
1015 0         0 $parser =~ s/\n/\n /gm;
1016 0 0       0 $size = 'unlimited' unless defined $size;
1017              
1018 0         0 my $output = "[Template::Provider] {\n";
1019 0         0 my $format = " %-16s => %s\n";
1020 0         0 my $key;
1021              
1022             $output .= sprintf($format, 'INCLUDE_PATH',
1023 0         0 '[ ' . join(', ', @{ $self->{ INCLUDE_PATH } }) . ' ]');
  0         0  
1024 0         0 $output .= sprintf($format, 'CACHE_SIZE', $size);
1025              
1026 0         0 foreach $key (qw( ABSOLUTE RELATIVE TOLERANT DELIMITER
1027             COMPILE_EXT COMPILE_DIR )) {
1028 0         0 $output .= sprintf($format, $key, $self->{ $key });
1029             }
1030 0         0 $output .= sprintf($format, 'PARSER', $parser);
1031              
1032              
1033 0         0 local $" = ', ';
1034 0         0 my $lookup = $self->{ LOOKUP };
1035 0 0       0 $lookup = join('', map {
1036 0         0 sprintf(" $format", $_, defined $lookup->{ $_ }
1037 0         0 ? ('[ ' . join(', ', map { defined $_ ? $_ : '' }
1038 0 0       0 @{ $lookup->{ $_ } }) . ' ]') : '');
1039             } sort keys %$lookup);
1040 0         0 $lookup = "{\n$lookup }";
1041              
1042 0         0 $output .= sprintf($format, LOOKUP => $lookup);
1043              
1044 0         0 $output .= '}';
1045 0         0 return $output;
1046             }
1047              
1048              
1049             #------------------------------------------------------------------------
1050             # _dump_cache()
1051             #
1052             # Debug method which prints the current state of the cache to STDERR.
1053             #------------------------------------------------------------------------
1054              
1055             sub _dump_cache {
1056 0     0   0 my $self = shift;
1057 0         0 my ($node, $lut, $count);
1058              
1059 0         0 $count = 0;
1060 0 0       0 if ($node = $self->{ HEAD }) {
1061 0         0 while ($node) {
1062 0         0 $lut->{ $node } = $count++;
1063 0         0 $node = $node->[ NEXT ];
1064             }
1065 0         0 $node = $self->{ HEAD };
1066 0         0 print STDERR "CACHE STATE:\n";
1067 0         0 print STDERR " HEAD: ", $self->{ HEAD }->[ NAME ], "\n";
1068 0         0 print STDERR " TAIL: ", $self->{ TAIL }->[ NAME ], "\n";
1069 0         0 while ($node) {
1070 0         0 my ($prev, $name, $data, $load, $next) = @$node;
1071             # $name = '...' . substr($name, -10) if length $name > 10;
1072 0 0       0 $prev = $prev ? "#$lut->{ $prev }<-": '';
1073 0 0       0 $next = $next ? "->#$lut->{ $next }": '';
1074 0         0 print STDERR " #$lut->{ $node } : [ $prev, $name, $data, $load, $next ]\n";
1075 0         0 $node = $node->[ NEXT ];
1076             }
1077             }
1078             }
1079              
1080             #------------------------------------------------------------------------
1081             # _decode_unicode
1082             #
1083             # Decodes encoded unicode text that starts with a BOM and
1084             # turns it into perl's internal representation
1085             #------------------------------------------------------------------------
1086              
1087             sub _decode_unicode {
1088 90     90   167 my $self = shift;
1089 90         159 my $string = shift;
1090 90 50       306 return undef unless defined $string;
1091              
1092 85     85   113189 use bytes;
  85         1125  
  85         522  
1093 90         26426 require Encode;
1094              
1095 90 50       313682 return $string if Encode::is_utf8( $string );
1096              
1097             # try all the BOMs in order looking for one (order is important
1098             # 32bit BOMs look like 16bit BOMs)
1099              
1100 90         209 my $count = 0;
1101              
1102 90         175 while ($count < @{ $boms }) {
  525         1478  
1103 440         990 my $enc = $boms->[$count++];
1104 440         658 my $bom = $boms->[$count++];
1105              
1106             # does the string start with the bom?
1107 440 100       1284 if ($bom eq substr($string, 0, length($bom))) {
1108             # decode it and hand it back
1109 5         29 return Encode::decode($enc, substr($string, length($bom)), 1);
1110             }
1111             }
1112              
1113             return $self->{ ENCODING }
1114 85 50       641 ? Encode::decode( $self->{ ENCODING }, $string )
1115             : $string;
1116             }
1117              
1118              
1119             1;
1120              
1121             __END__