← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 13:50:58 2016
Reported on Fri Jan 8 13:51:26 2016

Filename/usr/lib/x86_64-linux-gnu/perl5/5.20/Template/Provider.pm
StatementsExecuted 41 statements in 5.24ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1111.59ms1.70msTemplate::Provider::::BEGIN@46Template::Provider::BEGIN@46
11121µs28µsTemplate::Provider::::BEGIN@1089Template::Provider::BEGIN@1089
11115µs26µsTemplate::Provider::::BEGIN@41Template::Provider::BEGIN@41
11115µs55µsTemplate::Provider::::BEGIN@47Template::Provider::BEGIN@47
11111µs87µsTemplate::Provider::::BEGIN@43Template::Provider::BEGIN@43
11111µs45µsTemplate::Provider::::BEGIN@50Template::Provider::BEGIN@50
11110µs21µsTemplate::Provider::::BEGIN@45Template::Provider::BEGIN@45
1119µs9µsTemplate::Provider::::CORE:qrTemplate::Provider::CORE:qr (opcode)
1118µs16µsTemplate::Provider::::BEGIN@42Template::Provider::BEGIN@42
1117µs22µsTemplate::Provider::::BEGIN@51Template::Provider::BEGIN@51
1117µs22µsTemplate::Provider::::BEGIN@55Template::Provider::BEGIN@55
1117µs7µsTemplate::Provider::::BEGIN@48Template::Provider::BEGIN@48
1117µs21µsTemplate::Provider::::BEGIN@52Template::Provider::BEGIN@52
1117µs21µsTemplate::Provider::::BEGIN@54Template::Provider::BEGIN@54
1117µs20µsTemplate::Provider::::BEGIN@53Template::Provider::BEGIN@53
1116µs6µsTemplate::Provider::::BEGIN@44Template::Provider::BEGIN@44
1114µs4µsTemplate::Provider::::BEGIN@87Template::Provider::BEGIN@87
0000s0sTemplate::Provider::::DESTROYTemplate::Provider::DESTROY
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
41242µs238µs
# spent 26µs (15+11) within Template::Provider::BEGIN@41 which was called: # once (15µs+11µs) by Template::BEGIN@29 at line 41
use strict;
# spent 26µs making 1 call to Template::Provider::BEGIN@41 # spent 11µs making 1 call to strict::import
42235µs223µs
# spent 16µs (8+8) within Template::Provider::BEGIN@42 which was called: # once (8µs+8µs) by Template::BEGIN@29 at line 42
use warnings;
# spent 16µs making 1 call to Template::Provider::BEGIN@42 # spent 8µs making 1 call to warnings::import
432123µs2164µs
# spent 87µs (11+76) within Template::Provider::BEGIN@43 which was called: # once (11µs+76µs) by Template::BEGIN@29 at line 43
use base 'Template::Base';
# spent 87µs making 1 call to Template::Provider::BEGIN@43 # spent 76µs making 1 call to base::import
44230µs16µs
# spent 6µs within Template::Provider::BEGIN@44 which was called: # once (6µs+0s) by Template::BEGIN@29 at line 44
use Template::Config;
# spent 6µs making 1 call to Template::Provider::BEGIN@44
45259µs232µs
# spent 21µs (10+11) within Template::Provider::BEGIN@45 which was called: # once (10µs+11µs) by Template::BEGIN@29 at line 45
use Template::Constants;
# spent 21µs making 1 call to Template::Provider::BEGIN@45 # spent 12µs making 1 call to Exporter::import
462184µs11.70ms
# spent 1.70ms (1.59+110µs) within Template::Provider::BEGIN@46 which was called: # once (1.59ms+110µs) by Template::BEGIN@29 at line 46
use Template::Document;
# spent 1.70ms making 1 call to Template::Provider::BEGIN@46
47276µs294µs
# spent 55µs (15+40) within Template::Provider::BEGIN@47 which was called: # once (15µs+40µs) by Template::BEGIN@29 at line 47
use File::Basename;
# spent 55µs making 1 call to Template::Provider::BEGIN@47 # spent 40µs making 1 call to Exporter::import
48228µs17µs
# spent 7µs within Template::Provider::BEGIN@48 which was called: # once (7µs+0s) by Template::BEGIN@29 at line 48
use File::Spec;
# spent 7µs making 1 call to Template::Provider::BEGIN@48
49
50268µs279µs
# spent 45µs (11+34) within Template::Provider::BEGIN@50 which was called: # once (11µs+34µs) by Template::BEGIN@29 at line 50
use constant PREV => 0;
# spent 45µs making 1 call to Template::Provider::BEGIN@50 # spent 34µs making 1 call to constant::import
51244µs237µs
# spent 22µs (7+15) within Template::Provider::BEGIN@51 which was called: # once (7µs+15µs) by Template::BEGIN@29 at line 51
use constant NAME => 1; # template name -- indexed by this name in LOOKUP
# spent 22µs making 1 call to Template::Provider::BEGIN@51 # spent 15µs making 1 call to constant::import
52242µs235µs
# spent 21µs (7+14) within Template::Provider::BEGIN@52 which was called: # once (7µs+14µs) by Template::BEGIN@29 at line 52
use constant DATA => 2; # Compiled template
# spent 21µs making 1 call to Template::Provider::BEGIN@52 # spent 14µs making 1 call to constant::import
53241µs234µs
# spent 20µs (7+14) within Template::Provider::BEGIN@53 which was called: # once (7µs+14µs) by Template::BEGIN@29 at line 53
use constant LOAD => 3; # mtime of template
# spent 20µs making 1 call to Template::Provider::BEGIN@53 # spent 14µs making 1 call to constant::import
54242µs235µs
# spent 21µs (7+14) within Template::Provider::BEGIN@54 which was called: # once (7µs+14µs) by Template::BEGIN@29 at line 54
use constant NEXT => 4; # link to next item in cache linked list
# spent 21µs making 1 call to Template::Provider::BEGIN@54 # spent 14µs making 1 call to constant::import
552229µs236µs
# spent 22µs (7+14) within Template::Provider::BEGIN@55 which was called: # once (7µs+14µs) by Template::BEGIN@29 at line 55
use constant STAT => 5; # Time last stat()ed
# spent 22µs making 1 call to Template::Provider::BEGIN@55 # spent 14µs making 1 call to constant::import
56
571400nsour $VERSION = 2.94;
581700nsour $DEBUG = 0 unless defined $DEBUG;
591300nsour $ERROR = '';
60
61# name of document class
621200nsour $DOCUMENT = 'Template::Document' unless defined $DOCUMENT;
63
64# maximum time between performing stat() on file to check staleness
651100nsour $STAT_TTL = 1 unless defined $STAT_TTL;
66
67# maximum number of directories in an INCLUDE_PATH, to prevent runaways
681100nsour $MAX_DIRS = 64 unless defined $MAX_DIRS;
69
70# UNICODE is supported in versions of Perl from 5.007 onwards
7112µsour $UNICODE = $] > 5.007 ? 1 : 0;
72
7312µsmy $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
82115µs19µsour $RELATIVE_PATH = qr[(?:^|/)\.+/];
# spent 9µs making 1 call to Template::Provider::CORE: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
# spent 4µs within Template::Provider::BEGIN@87 which was called: # once (4µs+0s) by Template::BEGIN@29 at line 92
BEGIN {
8815µs if ($] < 5.006) {
89 package bytes;
90 $INC{'bytes.pm'} = 1;
91 }
9213.99ms14µs}
# spent 4µs making 1 call to Template::Provider::BEGIN@87
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
122sub fetch {
123 my ($self, $name) = @_;
124 my ($data, $error);
125
126
127 if (ref $name) {
128 # $name can be a reference to a scalar, GLOB or file handle
129 ($data, $error) = $self->_load($name);
130 ($data, $error) = $self->_compile($data)
131 unless $error;
132 $data = $data->{ data }
133 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 ? (undef, Template::Constants::STATUS_DECLINED)
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 ? (undef, Template::Constants::STATUS_DECLINED)
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 ? $self->_fetch_path($name)
157 : (undef, Template::Constants::STATUS_DECLINED);
158 }
159
160# $self->_dump_cache()
161# if $DEBUG > 1;
162
163 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
174sub store {
175 my ($self, $name, $data) = @_;
176 $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
191sub load {
192 my ($self, $name) = @_;
193 my ($data, $error);
194 my $path = $name;
195
196 if (File::Spec->file_name_is_absolute($name)) {
197 # absolute paths (starting '/') allowed if ABSOLUTE set
198 $error = "$name: absolute paths are not allowed (set ABSOLUTE option)"
199 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 unless $self->{ RELATIVE };
205 }
206 else {
207 INCPATH: {
208 # otherwise, it's a file name relative to INCLUDE_PATH
209 my $paths = $self->paths()
210 || return ($self->error(), Template::Constants::STATUS_ERROR);
211
212 foreach my $dir (@$paths) {
213 $path = File::Spec->catfile($dir, $name);
214 last INCPATH
215 if $self->_template_modified($path);
216 }
217 undef $path; # not found
218 }
219 }
220
221 # Now fetch the content
222 ($data, $error) = $self->_template_content($path)
223 if defined $path && !$error;
224
225 if ($error) {
226 return $self->{ TOLERANT }
227 ? (undef, Template::Constants::STATUS_DECLINED)
228 : ($error, Template::Constants::STATUS_ERROR);
229 }
230 elsif (! defined $path) {
231 return (undef, Template::Constants::STATUS_DECLINED);
232 }
233 else {
234 return ($data, Template::Constants::STATUS_OK);
235 }
236}
237
- -
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
248sub include_path {
249 my ($self, $path) = @_;
250 $self->{ INCLUDE_PATH } = $path if $path;
251 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
264sub paths {
265 my $self = shift;
266 my @ipaths = @{ $self->{ INCLUDE_PATH } };
267 my (@opaths, $dpaths, $dir);
268 my $count = $MAX_DIRS;
269
270 while (@ipaths && --$count) {
271 $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 if (ref $dir eq 'CODE') {
277 eval { $dpaths = &$dir() };
278 if ($@) {
279 chomp $@;
280 return $self->error($@);
281 }
282 unshift(@ipaths, @$dpaths);
283 next;
284 }
285 elsif (ref($dir) && UNIVERSAL::can($dir, 'paths')) {
286 $dpaths = $dir->paths()
287 || return $self->error($dir->error());
288 unshift(@ipaths, @$dpaths);
289 next;
290 }
291 else {
292 push(@opaths, $dir);
293 }
294 }
295 return $self->error("INCLUDE_PATH exceeds $MAX_DIRS directories")
296 if @ipaths;
297
298 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
312sub DESTROY {
313 my $self = shift;
314 my ($slot, $next);
315
316 $slot = $self->{ HEAD };
317 while ($slot) {
318 $next = $slot->[ NEXT ];
319 undef $slot->[ PREV ];
320 undef $slot->[ NEXT ];
321 $slot = $next;
322 }
323 undef $self->{ HEAD };
324 undef $self->{ TAIL };
325}
326
- -
330#========================================================================
331# -- PRIVATE METHODS --
332#========================================================================
333
334#------------------------------------------------------------------------
335# _init()
336#
337# Initialise the cache.
338#------------------------------------------------------------------------
339
340sub _init {
341 my ($self, $params) = @_;
342 my $size = $params->{ CACHE_SIZE };
343 my $path = $params->{ INCLUDE_PATH } || '.';
344 my $cdir = $params->{ COMPILE_DIR } || '';
345 my $dlim = $params->{ DELIMITER };
346 my $debug;
347
348 # tweak delim to ignore C:/
349 unless (defined $dlim) {
350 $dlim = ($^O eq 'MSWin32') ? ':(?!\\/)' : ':';
351 }
352
353 # coerce INCLUDE_PATH to an array ref, if not already so
354 $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 $size = 2
360 if defined $size && ($size == 1 || $size < 0);
361
362 if (defined ($debug = $params->{ DEBUG })) {
363 $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PROVIDER
364 | Template::Constants::DEBUG_FLAGS );
365 }
366 else {
367 $self->{ DEBUG } = $DEBUG;
368 }
369
370 if ($self->{ DEBUG }) {
371 local $" = ', ';
372 $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 if ($cdir) {
380 require File::Path;
381 foreach my $dir (@$path) {
382 next if ref $dir;
383 my $wdir = $dir;
384 $wdir =~ s[:][]g if $^O eq 'MSWin32';
385 $wdir =~ /(.*)/; # untaint
386 $wdir = "$1"; # quotes work around bug in Strawberry Perl
387 $wdir = File::Spec->catfile($cdir, $wdir);
388 File::Path::mkpath($wdir) unless -d $wdir;
389 }
390 }
391
392 $self->{ LOOKUP } = { };
393 $self->{ NOTFOUND } = { }; # Tracks templates *not* found.
394 $self->{ SLOTS } = 0;
395 $self->{ SIZE } = $size;
396 $self->{ INCLUDE_PATH } = $path;
397 $self->{ DELIMITER } = $dlim;
398 $self->{ COMPILE_DIR } = $cdir;
399 $self->{ COMPILE_EXT } = $params->{ COMPILE_EXT } || '';
400 $self->{ ABSOLUTE } = $params->{ ABSOLUTE } || 0;
401 $self->{ RELATIVE } = $params->{ RELATIVE } || 0;
402 $self->{ TOLERANT } = $params->{ TOLERANT } || 0;
403 $self->{ DOCUMENT } = $params->{ DOCUMENT } || $DOCUMENT;
404 $self->{ PARSER } = $params->{ PARSER };
405 $self->{ DEFAULT } = $params->{ DEFAULT };
406 $self->{ ENCODING } = $params->{ ENCODING };
407# $self->{ PREFIX } = $params->{ PREFIX };
408 $self->{ STAT_TTL } = $params->{ STAT_TTL } || $STAT_TTL;
409 $self->{ PARAMS } = $params;
410
411 # look for user-provided UNICODE parameter or use default from package var
412 $self->{ UNICODE } = defined $params->{ UNICODE }
413 ? $params->{ UNICODE } : $UNICODE;
414
415 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
430sub _fetch {
431 my ($self, $name, $t_name) = @_;
432 my $stat_ttl = $self->{ STAT_TTL };
433
434 $self->debug("_fetch($name)") if $self->{ DEBUG };
435
436 # First see if the named template is in the memory cache
437 if ((my $slot = $self->{ LOOKUP }->{ $name })) {
438 # Test if cache is fresh, and reload/compile if not.
439 my ($data, $error) = $self->_refresh($slot);
440
441 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 if (my $last_stat_time = $self->{ NOTFOUND }->{ $name }) {
448 my $expires_in = $last_stat_time + $stat_ttl - time;
449 if ($expires_in > 0) {
450 $self->debug(" file [$name] in negative cache. Expires in $expires_in seconds")
451 if $self->{ DEBUG };
452 return (undef, Template::Constants::STATUS_DECLINED);
453 }
454 else {
455 delete $self->{ NOTFOUND }->{ $name };
456 }
457 }
458
459 # Is there an up-to-date compiled version on disk?
460 if ($self->_compiled_is_current($name)) {
461 # require() the compiled template.
462 my $compiled_template = $self->_load_compiled( $self->_compiled_filename($name) );
463
464 # Store and return the compiled template
465 return $self->store( $name, $compiled_template ) if $compiled_template;
466
467 # Problem loading compiled template:
468 # warn and continue to fetch source template
469 warn($self->error(), "\n");
470 }
471
472 # load template from source
473 my ($template, $error) = $self->_load($name, $t_name);
474
475 if ($error) {
476 # Template could not be fetched. Add to the negative/notfound cache.
477 $self->{ NOTFOUND }->{ $name } = time;
478 return ( $template, $error );
479 }
480
481 # compile template source
482 ($template, $error) = $self->_compile($template, $self->_compiled_filename($name) );
483
484 if ($error) {
485 # return any compile time error
486 return ($template, $error);
487 }
488 else {
489 # Store compiled template and return it
490 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
504sub _fetch_path {
505 my ($self, $name) = @_;
506
507 $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 if ((my $slot = $self->{ LOOKUP }->{ $name })) {
512 # cached entry exists, so refresh slot and extract data
513 my ($data, $error) = $self->_refresh($slot);
514
515 return $error
516 ? ($data, $error)
517 : ($slot->[ DATA ], $error );
518 }
519
520 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 foreach my $dir (@$paths) {
525 my $path = File::Spec->catfile($dir, $name);
526
527 $self->debug("searching path: $path\n") if $self->{ DEBUG };
528
529 my ($data, $error) = $self->_fetch( $path, $name );
530
531 # Return if no error or if a serious error.
532 return ( $data, $error )
533 if !$error || $error == Template::Constants::STATUS_ERROR;
534
535 }
536
537 # not found in INCLUDE_PATH, now try DEFAULT
538 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 return (undef, Template::Constants::STATUS_DECLINED);
543}
544
545sub _compiled_filename {
546 my ($self, $file) = @_;
547 my ($compext, $compdir) = @$self{ qw( COMPILE_EXT COMPILE_DIR ) };
548 my ($path, $compiled);
549
550 return undef
551 unless $compext || $compdir;
552
553 $path = $file;
554 $path =~ /^(.+)$/s or die "invalid filename: $path";
555 $path =~ s[:][]g if $^O eq 'MSWin32';
556
557 $compiled = "$path$compext";
558 $compiled = File::Spec->catfile($compdir, $compiled) if length $compdir;
559
560 return $compiled;
561}
562
563sub _load_compiled {
564 my ($self, $file) = @_;
565 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 delete $INC{ $file };
571 eval { $compiled = require $file; };
572 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
592sub _load {
593 my ($self, $name, $alias) = @_;
594 my ($data, $error);
595 my $tolerant = $self->{ TOLERANT };
596 my $now = time;
597
598 $alias = $name unless defined $alias or ref $name;
599
600 $self->debug("_load($name, ", defined $alias ? $alias : '<no alias>',
601 ')') if $self->{ DEBUG };
602
603 # SCALAR ref is the template text
604 if (ref $name eq 'SCALAR') {
605 # $name can be a SCALAR reference to the input text...
606 return {
607 name => defined $alias ? $alias : 'input text',
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 if (ref $name) {
617 local $/;
618 my $text = <$name>;
619 $text = $self->_decode_unicode($text) if $self->{ UNICODE };
620 return {
621 name => defined $alias ? $alias : 'input file handle',
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 if ( $self->_template_modified( $name ) ) { # does template exist?
631 my ($text, $error, $mtime ) = $self->_template_content( $name );
632 unless ( $error ) {
633 $text = $self->_decode_unicode($text) if $self->{ UNICODE };
634 return {
635 name => $alias,
636 path => $name,
637 text => $text,
638 time => $mtime,
639 load => $now,
640 };
641 }
642
643 return ( "$alias: $!", Template::Constants::STATUS_ERROR )
644 unless $tolerant;
645 }
646
647 # Unable to process template, pass onto the next Provider.
648 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 upated since it was compiled, then
659# it is re-loaded from disk and re-compiled.
660#------------------------------------------------------------------------
661
662sub _refresh {
663 my ($self, $slot) = @_;
664 my $stat_ttl = $self->{ STAT_TTL };
665 my ($head, $file, $data, $error);
666
667 $self->debug("_refresh([ ",
668 join(', ', map { defined $_ ? $_ : '<undef>' } @$slot),
669 '])') 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 my $now = time;
675 my $expires_in_sec = $slot->[ STAT ] + $stat_ttl - $now;
676
677 if ( $expires_in_sec <= 0 ) { # Time to check!
678 $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 my $template_mtime = $self->_template_modified( $slot->[ NAME ] );
685 if ( ! defined $template_mtime || ( $template_mtime != $slot->[ LOAD ] )) {
686 $self->debug("refreshing cache file ", $slot->[ NAME ])
687 if $self->{ DEBUG };
688
689 ($data, $error) = $self->_load($slot->[ NAME ], $slot->[ DATA ]->{ name });
690 ($data, $error) = $self->_compile($data)
691 unless $error;
692
693 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 $slot->[ STAT ] = 0;
699 }
700 else {
701 $slot->[ DATA ] = $data->{ data };
702 $slot->[ LOAD ] = $data->{ time };
703 }
704 }
705
706 } elsif ( $self->{ DEBUG } ) {
707 $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 unless( $self->{ HEAD } == $slot ) {
713 # remove existing slot from usage chain...
714 if ($slot->[ PREV ]) {
715 $slot->[ PREV ]->[ NEXT ] = $slot->[ NEXT ];
716 }
717 else {
718 $self->{ HEAD } = $slot->[ NEXT ];
719 }
720 if ($slot->[ NEXT ]) {
721 $slot->[ NEXT ]->[ PREV ] = $slot->[ PREV ];
722 }
723 else {
724 $self->{ TAIL } = $slot->[ PREV ];
725 }
726
727 # ..and add to start of list
728 $head = $self->{ HEAD };
729 $head->[ PREV ] = $slot if $head;
730 $slot->[ PREV ] = undef;
731 $slot->[ NEXT ] = $head;
732 $self->{ HEAD } = $slot;
733 }
734
735 return ($data, $error);
736}
737
- -
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
752sub _store {
753 my ($self, $name, $data, $compfile) = @_;
754 my $size = $self->{ SIZE };
755 my ($slot, $head);
756
757 # Return if memory cache disabled. (overridding 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 return $data->{data} if defined $size and !$size;
761
762 # extract the compiled template from the data hash
763 $data = $data->{ data };
764 $self->debug("_store($name, $data)") if $self->{ DEBUG };
765
766 # check the modification time -- extra stat here
767 my $load = $self->_modified($name);
768
769 if (defined $size && $self->{ SLOTS } >= $size) {
770 # cache has reached size limit, so reuse oldest entry
771 $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 $slot = $self->{ TAIL };
775 $slot->[ PREV ]->[ NEXT ] = undef;
776 $self->{ TAIL } = $slot->[ PREV ];
777
778 # remove name lookup for old node
779 delete $self->{ LOOKUP }->{ $slot->[ NAME ] };
780
781 # add modified node to head of list
782 $head = $self->{ HEAD };
783 $head->[ PREV ] = $slot if $head;
784 @$slot = ( undef, $name, $data, $load, $head, time );
785 $self->{ HEAD } = $slot;
786
787 # add name lookup for new node
788 $self->{ LOOKUP }->{ $name } = $slot;
789 }
790 else {
791 # cache is under size limit, or none is defined
792
793 $self->debug("adding new cache entry") if $self->{ DEBUG };
794
795 # add new node to head of list
796 $head = $self->{ HEAD };
797 $slot = [ undef, $name, $data, $load, $head, time ];
798 $head->[ PREV ] = $slot if $head;
799 $self->{ HEAD } = $slot;
800 $self->{ TAIL } = $slot unless $self->{ TAIL };
801
802 # add lookup from name to slot and increment nslots
803 $self->{ LOOKUP }->{ $name } = $slot;
804 $self->{ SLOTS }++;
805 }
806
807 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
827sub _compile {
828 my ($self, $data, $compfile) = @_;
829 my $text = $data->{ text };
830 my ($parsedoc, $error);
831
832 $self->debug("_compile($data, ",
833 defined $compfile ? $compfile : '<no compfile>', ')')
834 if $self->{ DEBUG };
835
836 my $parser = $self->{ PARSER }
837 ||= Template::Config->parser($self->{ PARAMS })
838 || return (Template::Config->error(), Template::Constants::STATUS_ERROR);
839
840 # discard the template text - we don't need it any more
841 delete $data->{ text };
842
843 # call parser to compile template into Perl code
844 if ($parsedoc = $parser->parse($text, $data)) {
845
846 $parsedoc->{ METADATA } = {
847 'name' => $data->{ name },
848 'modtime' => $data->{ time },
849 %{ $parsedoc->{ METADATA } },
850 };
851
852 # write the Perl code to the file $compfile, if defined
853 if ($compfile) {
854 my $basedir = &File::Basename::dirname($compfile);
855 $basedir =~ /(.*)/;
856 $basedir = $1;
857
858 unless (-d $basedir) {
859 eval { File::Path::mkpath($basedir) };
860 $error = "failed to create compiled templates directory: $basedir ($@)"
861 if ($@);
862 }
863
864 unless ($error) {
865 my $docclass = $self->{ DOCUMENT };
866 $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 if (!defined($error) && defined $data->{ time }) {
875 my ($cfile) = $compfile =~ /^(.+)$/s or do {
876 return("invalid filename: $compfile",
877 Template::Constants::STATUS_ERROR);
878 };
879
880 my ($ctime) = $data->{ time } =~ /^(\d+)$/;
881 unless ($ctime || $ctime eq 0) {
882 return("invalid time: $ctime",
883 Template::Constants::STATUS_ERROR);
884 }
885 utime($ctime, $ctime, $cfile);
886
887 $self->debug(" cached compiled template to file [$compfile]")
888 if $self->{ DEBUG };
889 }
890 }
891
892 unless ($error) {
893 return $data ## RETURN ##
894 if $data->{ data } = $DOCUMENT->new($parsedoc);
895 $error = $Template::Document::ERROR;
896 }
897 }
898 else {
899 $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 ? (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
916sub _compiled_is_current {
917 my ( $self, $template_name ) = @_;
918 my $compiled_name = $self->_compiled_filename($template_name) || return;
919 my $compiled_mtime = (stat($compiled_name))[9] || return;
920 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 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
936sub _template_modified {
937 my $self = shift;
938 my $template = shift || return;
939 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
953sub _template_content {
954 my ($self, $path) = @_;
955
956 return (undef, "No path specified to fetch content from ")
957 unless $path;
958
959 my $data;
960 my $mod_date;
961 my $error;
962
963 local *FH;
964 if (open(FH, "< $path")) {
965 local $/;
966 binmode(FH);
967 $data = <FH>;
968 $mod_date = (stat($path))[9];
969 close(FH);
970 }
971 else {
972 $error = "$path: $!";
973 }
974
975 return wantarray
976 ? ( $data, $error, $mod_date )
977 : $data;
978}
979
980
981#------------------------------------------------------------------------
982# _modified($name)
983# _modified($name, $time)
984#
985# When called with a single argument, it returns the modification time
986# of the named template. When called with a second argument it returns
987# true if $name has been modified since $time.
988#------------------------------------------------------------------------
989
990sub _modified {
991 my ($self, $name, $time) = @_;
992 my $load = $self->_template_modified($name)
993 || return $time ? 1 : 0;
994
995 return $time
996 ? $load > $time
997 : $load;
998}
999
1000#------------------------------------------------------------------------
1001# _dump()
1002#
1003# Debug method which returns a string representing the internal object
1004# state.
1005#------------------------------------------------------------------------
1006
1007sub _dump {
1008 my $self = shift;
1009 my $size = $self->{ SIZE };
1010 my $parser = $self->{ PARSER };
1011 $parser = $parser ? $parser->_dump() : '<no parser>';
1012 $parser =~ s/\n/\n /gm;
1013 $size = 'unlimited' unless defined $size;
1014
1015 my $output = "[Template::Provider] {\n";
1016 my $format = " %-16s => %s\n";
1017 my $key;
1018
1019 $output .= sprintf($format, 'INCLUDE_PATH',
1020 '[ ' . join(', ', @{ $self->{ INCLUDE_PATH } }) . ' ]');
1021 $output .= sprintf($format, 'CACHE_SIZE', $size);
1022
1023 foreach $key (qw( ABSOLUTE RELATIVE TOLERANT DELIMITER
1024 COMPILE_EXT COMPILE_DIR )) {
1025 $output .= sprintf($format, $key, $self->{ $key });
1026 }
1027 $output .= sprintf($format, 'PARSER', $parser);
1028
1029
1030 local $" = ', ';
1031 my $lookup = $self->{ LOOKUP };
1032 $lookup = join('', map {
1033 sprintf(" $format", $_, defined $lookup->{ $_ }
1034 ? ('[ ' . join(', ', map { defined $_ ? $_ : '<undef>' }
1035 @{ $lookup->{ $_ } }) . ' ]') : '<undef>');
1036 } sort keys %$lookup);
1037 $lookup = "{\n$lookup }";
1038
1039 $output .= sprintf($format, LOOKUP => $lookup);
1040
1041 $output .= '}';
1042 return $output;
1043}
1044
1045
1046#------------------------------------------------------------------------
1047# _dump_cache()
1048#
1049# Debug method which prints the current state of the cache to STDERR.
1050#------------------------------------------------------------------------
1051
1052sub _dump_cache {
1053 my $self = shift;
1054 my ($node, $lut, $count);
1055
1056 $count = 0;
1057 if ($node = $self->{ HEAD }) {
1058 while ($node) {
1059 $lut->{ $node } = $count++;
1060 $node = $node->[ NEXT ];
1061 }
1062 $node = $self->{ HEAD };
1063 print STDERR "CACHE STATE:\n";
1064 print STDERR " HEAD: ", $self->{ HEAD }->[ NAME ], "\n";
1065 print STDERR " TAIL: ", $self->{ TAIL }->[ NAME ], "\n";
1066 while ($node) {
1067 my ($prev, $name, $data, $load, $next) = @$node;
1068# $name = '...' . substr($name, -10) if length $name > 10;
1069 $prev = $prev ? "#$lut->{ $prev }<-": '<undef>';
1070 $next = $next ? "->#$lut->{ $next }": '<undef>';
1071 print STDERR " #$lut->{ $node } : [ $prev, $name, $data, $load, $next ]\n";
1072 $node = $node->[ NEXT ];
1073 }
1074 }
1075}
1076
1077#------------------------------------------------------------------------
1078# _decode_unicode
1079#
1080# Decodes encoded unicode text that starts with a BOM and
1081# turns it into perl's internal representation
1082#------------------------------------------------------------------------
1083
1084sub _decode_unicode {
1085 my $self = shift;
1086 my $string = shift;
1087 return undef unless defined $string;
1088
10892177µs236µs
# spent 28µs (21+8) within Template::Provider::BEGIN@1089 which was called: # once (21µs+8µs) by Template::BEGIN@29 at line 1089
use bytes;
# spent 28µs making 1 call to Template::Provider::BEGIN@1089 # spent 8µs making 1 call to bytes::import
1090 require Encode;
1091
1092 return $string if Encode::is_utf8( $string );
1093
1094 # try all the BOMs in order looking for one (order is important
1095 # 32bit BOMs look like 16bit BOMs)
1096
1097 my $count = 0;
1098
1099 while ($count < @{ $boms }) {
1100 my $enc = $boms->[$count++];
1101 my $bom = $boms->[$count++];
1102
1103 # does the string start with the bom?
1104 if ($bom eq substr($string, 0, length($bom))) {
1105 # decode it and hand it back
1106 return Encode::decode($enc, substr($string, length($bom)), 1);
1107 }
1108 }
1109
1110 return $self->{ ENCODING }
1111 ? Encode::decode( $self->{ ENCODING }, $string )
1112 : $string;
1113}
1114
1115
111619µs1;
1117
1118__END__
 
# spent 9µs within Template::Provider::CORE:qr which was called: # once (9µs+0s) by Template::BEGIN@29 at line 82
sub Template::Provider::CORE:qr; # opcode
Report produced by the NYTProf 6.02 Perl profiler, developed by Tim Bunce and Adam Kaplan.