← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:11 2021

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