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 56 57our $VERSION = 2.94; 58our $DEBUG = 0 unless defined $DEBUG; 59our $ERROR = ''; 60 61# name of document class 62our $DOCUMENT = 'Template::Document' unless defined $DOCUMENT; 63 64# maximum time between performing stat() on file to check staleness 65our $STAT_TTL = 1 unless defined $STAT_TTL; 66 67# maximum number of directories in an INCLUDE_PATH, to prevent runaways 68our $MAX_DIRS = 64 unless defined $MAX_DIRS; 69 70# UNICODE is supported in versions of Perl from 5.007 onwards 71our $UNICODE = $] > 5.007 ? 1 : 0; 72 73my $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 82our $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 87BEGIN { 88 if ($] < 5.006) { 89 package bytes; 90 $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 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 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 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 327 328 329 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 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 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 1089 use bytes; 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 11161; 1117 1118__END__ 1119 1120=head1 NAME 1121 1122Template::Provider - Provider module for loading/compiling templates 1123 1124=head1 SYNOPSIS 1125 1126 $provider = Template::Provider->new(\%options); 1127 1128 ($template, $error) = $provider->fetch($name); 1129 1130=head1 DESCRIPTION 1131 1132The L<Template::Provider> is used to load, parse, compile and cache template 1133documents. This object may be sub-classed to provide more specific facilities 1134for loading, or otherwise providing access to templates. 1135 1136The L<Template::Context> objects maintain a list of L<Template::Provider> 1137objects which are polled in turn (via L<fetch()|Template::Context#fetch()>) to 1138return a requested template. Each may return a compiled template, raise an 1139error, or decline to serve the request, giving subsequent providers a chance 1140to do so. 1141 1142The L<Template::Provider> can also be subclassed to provide templates from 1143a different source, e.g. a database. See L<SUBCLASSING> below. 1144 1145This documentation needs work. 1146 1147=head1 PUBLIC METHODS 1148 1149=head2 new(\%options) 1150 1151Constructor method which instantiates and returns a new C<Template::Provider> 1152object. A reference to a hash array of configuration options may be passed. 1153 1154See L<CONFIGURATION OPTIONS> below for a summary of configuration options 1155and L<Template::Manual::Config> for full details. 1156 1157=head2 fetch($name) 1158 1159Returns a compiled template for the name specified. If the template cannot be 1160found then C<(undef, STATUS_DECLINED)> is returned. If an error occurs (e.g. 1161read error, parse error) then C<($error, STATUS_ERROR)> is returned, where 1162C<$error> is the error message generated. If the L<TOLERANT> option is set the 1163the method returns C<(undef, STATUS_DECLINED)> instead of returning an error. 1164 1165=head2 load($name) 1166 1167Loads a template without parsing or compiling it. This is used by the 1168the L<INSERT|Template::Manual::Directives#INSERT> directive. 1169 1170=head2 store($name, $template) 1171 1172Stores the compiled template, C<$template>, in the cache under the name, 1173C<$name>. Susbequent calls to C<fetch($name)> will return this template in 1174preference to any disk-based file. 1175 1176=head2 include_path(\@newpath) 1177 1178Accessor method for the C<INCLUDE_PATH> setting. If called with an 1179argument, this method will replace the existing C<INCLUDE_PATH> with 1180the new value. 1181 1182=head2 paths() 1183 1184This method generates a copy of the C<INCLUDE_PATH> list. Any elements in the 1185list which are dynamic generators (e.g. references to subroutines or objects 1186implementing a C<paths()> method) will be called and the list of directories 1187returned merged into the output list. 1188 1189It is possible to provide a generator which returns itself, thus sending 1190this method into an infinite loop. To detect and prevent this from happening, 1191the C<$MAX_DIRS> package variable, set to C<64> by default, limits the maximum 1192number of paths that can be added to, or generated for the output list. If 1193this number is exceeded then the method will immediately return an error 1194reporting as much. 1195 1196=head1 CONFIGURATION OPTIONS 1197 1198The following list summarises the configuration options that can be provided 1199to the C<Template::Provider> L<new()> constructor. Please consult 1200L<Template::Manual::Config> for further details and examples of each 1201configuration option in use. 1202 1203=head2 INCLUDE_PATH 1204 1205The L<INCLUDE_PATH|Template::Manual::Config#INCLUDE_PATH> option is used to 1206specify one or more directories in which template files are located. 1207 1208 # single path 1209 my $provider = Template::Provider->new({ 1210 INCLUDE_PATH => '/usr/local/templates', 1211 }); 1212 1213 # multiple paths 1214 my $provider = Template::Provider->new({ 1215 INCLUDE_PATH => [ '/usr/local/templates', 1216 '/tmp/my/templates' ], 1217 }); 1218 1219=head2 ABSOLUTE 1220 1221The L<ABSOLUTE|Template::Manual::Config#ABSOLUTE> flag is used to indicate if 1222templates specified with absolute filenames (e.g. 'C</foo/bar>') should be 1223processed. It is disabled by default and any attempt to load a template by 1224such a name will cause a 'C<file>' exception to be raised. 1225 1226 my $provider = Template::Provider->new({ 1227 ABSOLUTE => 1, 1228 }); 1229 1230=head2 RELATIVE 1231 1232The L<RELATIVE|Template::Manual::Config#RELATIVE> flag is used to indicate if 1233templates specified with filenames relative to the current directory (e.g. 1234C<./foo/bar> or C<../../some/where/else>) should be loaded. It is also disabled 1235by default, and will raise a C<file> error if such template names are 1236encountered. 1237 1238 my $provider = Template::Provider->new({ 1239 RELATIVE => 1, 1240 }); 1241 1242=head2 DEFAULT 1243 1244The L<DEFAULT|Template::Manual::Config#DEFAULT> option can be used to specify 1245a default template which should be used whenever a specified template can't be 1246found in the L<INCLUDE_PATH>. 1247 1248 my $provider = Template::Provider->new({ 1249 DEFAULT => 'notfound.html', 1250 }); 1251 1252If a non-existant template is requested through the L<Template> 1253L<process()|Template#process()> method, or by an C<INCLUDE>, C<PROCESS> or 1254C<WRAPPER> directive, then the C<DEFAULT> template will instead be processed, if 1255defined. Note that the C<DEFAULT> template is not used when templates are 1256specified with absolute or relative filenames, or as a reference to a input 1257file handle or text string. 1258 1259=head2 ENCODING 1260 1261The Template Toolkit will automatically decode Unicode templates that 1262have a Byte Order Marker (BOM) at the start of the file. This option 1263can be used to set the default encoding for templates that don't define 1264a BOM. 1265 1266 my $provider = Template::Provider->new({ 1267 ENCODING => 'utf8', 1268 }); 1269 1270See L<Encode> for further information. 1271 1272=head2 CACHE_SIZE 1273 1274The L<CACHE_SIZE|Template::Manual::Config#CACHE_SIZE> option can be used to 1275limit the number of compiled templates that the module should cache. By 1276default, the L<CACHE_SIZE|Template::Manual::Config#CACHE_SIZE> is undefined 1277and all compiled templates are cached. 1278 1279 my $provider = Template::Provider->new({ 1280 CACHE_SIZE => 64, # only cache 64 compiled templates 1281 }); 1282 1283 1284=head2 STAT_TTL 1285 1286The L<STAT_TTL|Template::Manual::Config#STAT_TTL> value can be set to control 1287how long the C<Template::Provider> will keep a template cached in memory 1288before checking to see if the source template has changed. 1289 1290 my $provider = Template::Provider->new({ 1291 STAT_TTL => 60, # one minute 1292 }); 1293 1294=head2 COMPILE_EXT 1295 1296The L<COMPILE_EXT|Template::Manual::Config#COMPILE_EXT> option can be 1297provided to specify a filename extension for compiled template files. 1298It is undefined by default and no attempt will be made to read or write 1299any compiled template files. 1300 1301 my $provider = Template::Provider->new({ 1302 COMPILE_EXT => '.ttc', 1303 }); 1304 1305=head2 COMPILE_DIR 1306 1307The L<COMPILE_DIR|Template::Manual::Config#COMPILE_DIR> option is used to 1308specify an alternate directory root under which compiled template files should 1309be saved. 1310 1311 my $provider = Template::Provider->new({ 1312 COMPILE_DIR => '/tmp/ttc', 1313 }); 1314 1315=head2 TOLERANT 1316 1317The L<TOLERANT|Template::Manual::Config#TOLERANT> flag can be set to indicate 1318that the C<Template::Provider> module should ignore any errors encountered while 1319loading a template and instead return C<STATUS_DECLINED>. 1320 1321=head2 PARSER 1322 1323The L<PARSER|Template::Manual::Config#PARSER> option can be used to define 1324a parser module other than the default of L<Template::Parser>. 1325 1326 my $provider = Template::Provider->new({ 1327 PARSER => MyOrg::Template::Parser->new({ ... }), 1328 }); 1329 1330=head2 DEBUG 1331 1332The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable 1333debugging messages from the L<Template::Provider> module by setting it to include 1334the C<DEBUG_PROVIDER> value. 1335 1336 use Template::Constants qw( :debug ); 1337 1338 my $template = Template->new({ 1339 DEBUG => DEBUG_PROVIDER, 1340 }); 1341 1342=head1 SUBCLASSING 1343 1344The C<Template::Provider> module can be subclassed to provide templates from a 1345different source (e.g. a database). In most cases you'll just need to provide 1346custom implementations of the C<_template_modified()> and C<_template_content()> 1347methods. If your provider requires and custom initialisation then you'll also 1348need to implement a new C<_init()> method. 1349 1350Caching in memory and on disk will still be applied (if enabled) 1351when overriding these methods. 1352 1353=head2 _template_modified($path) 1354 1355Returns a timestamp of the C<$path> passed in by calling C<stat()>. 1356This can be overridden, for example, to return a last modified value from 1357a database. The value returned should be a timestamp value (as returned by C<time()>, 1358although a sequence number should work as well. 1359 1360=head2 _template_content($path) 1361 1362This method returns the content of the template for all C<INCLUDE>, C<PROCESS>, 1363and C<INSERT> directives. 1364 1365When called in scalar context, the method returns the content of the template 1366located at C<$path>, or C<undef> if C<$path> is not found. 1367 1368When called in list context it returns C<($content, $error, $mtime)>, 1369where C<$content> is the template content, C<$error> is an error string 1370(e.g. "C<$path: File not found>"), and C<$mtime> is the template modification 1371time. 1372 1373=head1 AUTHOR 1374 1375Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> 1376 1377=head1 COPYRIGHT 1378 1379Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. 1380 1381This module is free software; you can redistribute it and/or 1382modify it under the same terms as Perl itself. 1383 1384=head1 SEE ALSO 1385 1386L<Template>, L<Template::Parser>, L<Template::Context> 1387 1388=cut 1389 1390# Local Variables: 1391# mode: perl 1392# perl-indent-level: 4 1393# indent-tabs-mode: nil 1394# End: 1395# 1396# vim: expandtab shiftwidth=4: 1397