local-lib5/lib/perl5/i486-linux-gnu-thread-multi/Template/Provider.pm

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