diff options
Diffstat (limited to 'lib/Template')
| -rw-r--r-- | lib/Template/Base.pm | 290 | ||||
| -rw-r--r-- | lib/Template/Config.pm | 457 | ||||
| -rw-r--r-- | lib/Template/Constants.pm | 277 | ||||
| -rw-r--r-- | lib/Template/Context.pm | 1549 | ||||
| -rw-r--r-- | lib/Template/Directive.pm | 1004 | ||||
| -rw-r--r-- | lib/Template/Document.pm | 482 | ||||
| -rw-r--r-- | lib/Template/Exception.pm | 244 | ||||
| -rw-r--r-- | lib/Template/Filters.pm | 1438 | ||||
| -rw-r--r-- | lib/Template/Grammar.pm | 6174 | ||||
| -rw-r--r-- | lib/Template/Iterator.pm | 446 | ||||
| -rw-r--r-- | lib/Template/Namespace/Constants.pm | 195 | ||||
| -rw-r--r-- | lib/Template/Parser.pm | 1434 | ||||
| -rw-r--r-- | lib/Template/Plugin.pm | 399 | ||||
| -rw-r--r-- | lib/Template/Plugin/Date.pm | 361 | ||||
| -rw-r--r-- | lib/Template/Plugins.pm | 1031 | ||||
| -rw-r--r-- | lib/Template/Provider.pm | 1433 | ||||
| -rw-r--r-- | lib/Template/Service.pm | 765 | ||||
| -rw-r--r-- | lib/Template/Stash.pm | 1000 | ||||
| -rw-r--r-- | lib/Template/Stash/Context.pm | 781 | ||||
| -rw-r--r-- | lib/Template/Stash/XS.pm | 176 | ||||
| -rw-r--r-- | lib/Template/Test.pm | 701 | ||||
| -rw-r--r-- | lib/Template/View.pm | 754 |
22 files changed, 21391 insertions, 0 deletions
diff --git a/lib/Template/Base.pm b/lib/Template/Base.pm new file mode 100644 index 0000000..b66d9c8 --- /dev/null +++ b/lib/Template/Base.pm @@ -0,0 +1,290 @@ +#============================================================= -*-perl-*- +# +# Template::Base +# +# DESCRIPTION +# Base class module implementing common functionality for various other +# Template Toolkit modules. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#------------------------------------------------------------------------ +# +# $Id: Base.pm,v 2.62 2003/04/24 09:14:38 abw Exp $ +# +#======================================================================== + +package Template::Base; + +require 5.004; + +use strict; +use vars qw( $VERSION ); +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); + + +#------------------------------------------------------------------------ +# new(\%params) +# +# General purpose constructor method which expects a hash reference of +# configuration parameters, or a list of name => value pairs which are +# folded into a hash. Blesses a hash into an object and calls its +# _init() method, passing the parameter hash reference. Returns a new +# object derived from Template::Base, or undef on error. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my ($argnames, @args, $arg, $cfg); +# $class->error(''); # always clear package $ERROR var? + + { no strict qw( refs ); + $argnames = \@{"$class\::BASEARGS"} || [ ]; + } + + # shift off all mandatory args, returning error if undefined or null + foreach $arg (@$argnames) { + return $class->error("no $arg specified") + unless ($cfg = shift); + push(@args, $cfg); + } + + # fold all remaining args into a hash, or use provided hash ref +# local $" = ', '; +# print STDERR "args: [@_]\n"; + $cfg = defined $_[0] && UNIVERSAL::isa($_[0], 'HASH') ? shift : { @_ }; + + my $self = bless { + map { ($_ => shift @args) } @$argnames, + _ERROR => '', + DEBUG => 0, + }, $class; + + return $self->_init($cfg) ? $self : $class->error($self->error); +} + + +#------------------------------------------------------------------------ +# error() +# error($msg, ...) +# +# May be called as a class or object method to set or retrieve the +# package variable $ERROR (class method) or internal member +# $self->{ _ERROR } (object method). The presence of parameters indicates +# that the error value should be set. Undef is then returned. In the +# abscence of parameters, the current error value is returned. +#------------------------------------------------------------------------ + +sub error { + my $self = shift; + my $errvar; + + { + no strict qw( refs ); + $errvar = ref $self ? \$self->{ _ERROR } : \${"$self\::ERROR"}; + } + if (@_) { + $$errvar = ref($_[0]) ? shift : join('', @_); + return undef; + } + else { + return $$errvar; + } +} + + +#------------------------------------------------------------------------ +# _init() +# +# Initialisation method called by the new() constructor and passing a +# reference to a hash array containing any configuration items specified +# as constructor arguments. Should return $self on success or undef on +# error, via a call to the error() method to set the error message. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $config) = @_; + return $self; +} + + +sub DEBUG { + my $self = shift; + print STDERR "DEBUG: ", @_; +} + +sub debug { + my $self = shift; + my $msg = join('', @_); + my ($pkg, $file, $line) = caller(); + + unless ($msg =~ /\n$/) { + $msg .= ($self->{ DEBUG } & Template::Constants::DEBUG_CALLER) + ? " at $file line $line\n" + : "\n"; + } + + print STDERR "[$pkg] $msg"; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Base - Base class module implementing common functionality + +=head1 SYNOPSIS + + package My::Module; + use base qw( Template::Base ); + + sub _init { + my ($self, $config) = @_; + $self->{ doodah } = $config->{ doodah } + || return $self->error("No 'doodah' specified"); + return $self; + } + + package main; + + my $object = My::Module->new({ doodah => 'foobar' }) + || die My::Module->error(); + +=head1 DESCRIPTION + +Base class module which implements a constructor and error reporting +functionality for various Template Toolkit modules. + +=head1 PUBLIC METHODS + +=head2 new(\%config) + +Constructor method which accepts a reference to a hash array or a list +of C<name =E<gt> value> parameters which are folded into a hash. The +_init() method is then called, passing the configuration hash and should +return true/false to indicate success or failure. A new object reference +is returned, or undef on error. Any error message raised can be examined +via the error() class method or directly via the package variable ERROR +in the derived class. + + my $module = My::Module->new({ ... }) + || die My::Module->error(), "\n"; + + my $module = My::Module->new({ ... }) + || die "constructor error: $My::Module::ERROR\n"; + +=head2 error($msg, ...) + +May be called as an object method to get/set the internal _ERROR member +or as a class method to get/set the $ERROR variable in the derived class's +package. + + my $module = My::Module->new({ ... }) + || die My::Module->error(), "\n"; + + $module->do_something() + || die $module->error(), "\n"; + +When called with parameters (multiple params are concatenated), this +method will set the relevant variable and return undef. This is most +often used within object methods to report errors to the caller. + + package My::Module; + + sub foobar { + my $self = shift; + + # some other code... + + return $self->error('some kind of error...') + if $some_condition; + } + +=head2 debug($msg, ...) + +Generates a debugging message by concatenating all arguments +passed into a string and printing it to STDERR. A prefix is +added to indicate the module of the caller. + + package My::Module; + + sub foobar { + my $self = shift; + + $self->debug('called foobar()'); + + # some other code... + } + +When the foobar() method is called, the following message +is sent to STDERR: + + [My::Module] called foobar() + +Objects can set an internal DEBUG value which the debug() +method will examine. If this value sets the relevant bits +to indicate DEBUG_CALLER then the file and line number of +the caller will be appened to the message. + + use Template::Constants qw( :debug ); + + my $module = My::Module->new({ + DEBUG => DEBUG_SERVICE | DEBUG_CONTEXT | DEBUG_CALLER, + }); + + $module->foobar(); + +This generates an error message such as: + + [My::Module] called foobar() at My/Module.pm line 6 + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.62, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template> diff --git a/lib/Template/Config.pm b/lib/Template/Config.pm new file mode 100644 index 0000000..dbe3a53 --- /dev/null +++ b/lib/Template/Config.pm @@ -0,0 +1,457 @@ +#============================================================= -*-perl-*- +# +# Template::Config +# +# DESCRIPTION +# Template Toolkit configuration module. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#------------------------------------------------------------------------ +# +# $Id: Config.pm,v 2.62 2003/04/24 09:14:38 abw Exp $ +# +#======================================================================== + +package Template::Config; + +require 5.004; + +use strict; +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG $ERROR $INSTDIR + $PARSER $PROVIDER $PLUGINS $FILTERS $ITERATOR + $LATEX_PATH $PDFLATEX_PATH $DVIPS_PATH + $STASH $SERVICE $CONTEXT $CONSTANTS @PRELOAD ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; +$ERROR = ''; +$CONTEXT = 'Template::Context'; +$FILTERS = 'Template::Filters'; +$ITERATOR = 'Template::Iterator'; +$PARSER = 'Template::Parser'; +$PLUGINS = 'Template::Plugins'; +$PROVIDER = 'Template::Provider'; +$SERVICE = 'Template::Service'; +$STASH = 'Template::Stash'; +$CONSTANTS = 'Template::Namespace::Constants'; + +@PRELOAD = ( $CONTEXT, $FILTERS, $ITERATOR, $PARSER, + $PLUGINS, $PROVIDER, $SERVICE, $STASH ); + +# the following is set at installation time by the Makefile.PL +$INSTDIR = ''; + +# LaTeX executable paths set at installation time by the Makefile.PL +# Empty strings cause the latex(pdf|dvi|ps) filters to throw an error. +$LATEX_PATH = ''; +$PDFLATEX_PATH = ''; +$DVIPS_PATH = ''; + +#======================================================================== +# --- CLASS METHODS --- +#======================================================================== + +#------------------------------------------------------------------------ +# preload($module, $module, ...) +# +# Preloads all the standard TT modules that are likely to be used, along +# with any other passed as arguments. +#------------------------------------------------------------------------ + +sub preload { + my $class = shift; + + foreach my $module (@PRELOAD, @_) { + $class->load($module) || return; + }; + return 1; +} + + +#------------------------------------------------------------------------ +# load($module) +# +# Load a module via require(). Any occurences of '::' in the module name +# are be converted to '/' and '.pm' is appended. Returns 1 on success +# or undef on error. Use $class->error() to examine the error string. +#------------------------------------------------------------------------ + +sub load { + my ($class, $module) = @_; + $module =~ s[::][/]g; + $module .= '.pm'; +# print STDERR "loading $module\n" +# if $DEBUG; + eval { + require $module; + }; + return $@ ? $class->error("failed to load $module: $@") : 1; +} + + +#------------------------------------------------------------------------ +# parser(\%params) +# +# Instantiate a new parser object of the class whose name is denoted by +# the package variable $PARSER (default: Template::Parser). Returns +# a reference to a newly instantiated parser object or undef on error. +# The class error() method can be called without arguments to examine +# the error message generated by this failure. +#------------------------------------------------------------------------ + +sub parser { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($PARSER); + return $PARSER->new($params) + || $class->error("failed to create parser: ", $PARSER->error); +} + + +#------------------------------------------------------------------------ +# provider(\%params) +# +# Instantiate a new template provider object (default: Template::Provider). +# Returns an object reference or undef on error, as above. +#------------------------------------------------------------------------ + +sub provider { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($PROVIDER); + return $PROVIDER->new($params) + || $class->error("failed to create template provider: ", + $PROVIDER->error); +} + + +#------------------------------------------------------------------------ +# plugins(\%params) +# +# Instantiate a new plugins provider object (default: Template::Plugins). +# Returns an object reference or undef on error, as above. +#------------------------------------------------------------------------ + +sub plugins { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($PLUGINS); + return $PLUGINS->new($params) + || $class->error("failed to create plugin provider: ", + $PLUGINS->error); +} + + +#------------------------------------------------------------------------ +# filters(\%params) +# +# Instantiate a new filters provider object (default: Template::Filters). +# Returns an object reference or undef on error, as above. +#------------------------------------------------------------------------ + +sub filters { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($FILTERS); + return $FILTERS->new($params) + || $class->error("failed to create filter provider: ", + $FILTERS->error); +} + + +#------------------------------------------------------------------------ +# iterator(\@list) +# +# Instantiate a new Template::Iterator object (default: Template::Iterator). +# Returns an object reference or undef on error, as above. +#------------------------------------------------------------------------ + +sub iterator { + my $class = shift; + my $list = shift; + + return undef unless $class->load($ITERATOR); + return $ITERATOR->new($list, @_) + || $class->error("failed to create iterator: ", $ITERATOR->error); +} + + +#------------------------------------------------------------------------ +# stash(\%vars) +# +# Instantiate a new template variable stash object (default: +# Template::Stash). Returns object or undef, as above. +#------------------------------------------------------------------------ + +sub stash { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($STASH); + return $STASH->new($params) + || $class->error("failed to create stash: ", $STASH->error); +} + + +#------------------------------------------------------------------------ +# context(\%params) +# +# Instantiate a new template context object (default: Template::Context). +# Returns object or undef, as above. +#------------------------------------------------------------------------ + +sub context { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($CONTEXT); + return $CONTEXT->new($params) + || $class->error("failed to create context: ", $CONTEXT->error); +} + + +#------------------------------------------------------------------------ +# service(\%params) +# +# Instantiate a new template context object (default: Template::Service). +# Returns object or undef, as above. +#------------------------------------------------------------------------ + +sub service { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($SERVICE); + return $SERVICE->new($params) + || $class->error("failed to create context: ", $SERVICE->error); +} + + +#------------------------------------------------------------------------ +# constants(\%params) +# +# Instantiate a new namespace handler for compile time constant folding +# (default: Template::Namespace::Constants). +# Returns object or undef, as above. +#------------------------------------------------------------------------ + +sub constants { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($CONSTANTS); + return $CONSTANTS->new($params) + || $class->error("failed to create constants namespace: ", + $CONSTANTS->error); +} + + +#------------------------------------------------------------------------ +# instdir($dir) +# +# Returns the root installation directory appended with any local +# component directory passed as an argument. +#------------------------------------------------------------------------ + +sub instdir { + my ($class, $dir) = @_; + my $inst = $INSTDIR + || return $class->error("no installation directory"); + $inst =~ s[/$][]g; + $inst .= "/$dir" if $dir; + return $inst; +} + +#------------------------------------------------------------------------ +# latexpaths() +# +# Returns a reference to a three element array: +# [latex_path, pdf2latex_path, dvips_path] +# These values are determined by Makefile.PL at installation time +# and are used by the latex(pdf|dvi|ps) filters. +#------------------------------------------------------------------------ + +sub latexpaths { + return [$LATEX_PATH, $PDFLATEX_PATH, $DVIPS_PATH]; +} + +#======================================================================== +# This should probably be moved somewhere else in the long term, but for +# now it ensures that Template::TieString is available even if the +# Template::Directive module hasn't been loaded, as is the case when +# using compiled templates and Template::Parser hasn't yet been loaded +# on demand. +#======================================================================== + +#------------------------------------------------------------------------ +# simple package for tying $output variable to STDOUT, used by perl() +#------------------------------------------------------------------------ + +package Template::TieString; + +sub TIEHANDLE { + my ($class, $textref) = @_; + bless $textref, $class; +} +sub PRINT { + my $self = shift; + $$self .= join('', @_); +} + + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Config - Factory module for instantiating other TT2 modules + +=head1 SYNOPSIS + + use Template::Config; + +=head1 DESCRIPTION + +This module implements various methods for loading and instantiating +other modules that comprise the Template Toolkit. It provides a consistent +way to create toolkit components and allows custom modules to be used in +place of the regular ones. + +Package variables such as $STASH, $SERVICE, $CONTEXT, etc., contain +the default module/package name for each component (Template::Stash, +Template::Service and Template::Context, respectively) and are used by +the various factory methods (stash(), service() and context()) to load +the appropriate module. Changing these package variables will cause +subsequent calls to the relevant factory method to load and instantiate +an object from the new class. + +=head1 PUBLIC METHODS + +=head2 load($module) + +Load a module via require(). Any occurences of '::' in the module name +are be converted to '/' and '.pm' is appended. Returns 1 on success +or undef on error. Use $class-E<gt>error() to examine the error string. + +=head2 preload() + +This method preloads all the other Template::* modules that are likely +to be used. It is called by the Template module when running under +mod_perl ($ENV{MOD_PERL} is set). + +=head2 parser(\%config) + +Instantiate a new parser object of the class whose name is denoted by +the package variable $PARSER (default: Template::Parser). Returns +a reference to a newly instantiated parser object or undef on error. + +=head2 provider(\%config) + +Instantiate a new template provider object (default: Template::Provider). +Returns an object reference or undef on error, as above. + +=head2 plugins(\%config) + +Instantiate a new plugins provider object (default: Template::Plugins). +Returns an object reference or undef on error, as above. + +=head2 filters(\%config) + +Instantiate a new filter provider object (default: Template::Filters). +Returns an object reference or undef on error, as above. + +=head2 stash(\%vars) + +Instantiate a new stash object (Template::Stash or Template::Stash::XS +depending on the default set at installation time) using the contents +of the optional hash array passed by parameter as initial variable +definitions. Returns an object reference or undef on error, as above. + +=head2 context(\%config) + +Instantiate a new template context object (default: Template::Context). +Returns an object reference or undef on error, as above. + +=head2 service(\%config) + +Instantiate a new template service object (default: Template::Service). +Returns an object reference or undef on error, as above. + +=head2 instdir($dir) + +Returns the root directory of the Template Toolkit installation under +which optional components are installed. Any relative directory specified +as an argument will be appended to the returned directory. + + # e.g. returns '/usr/local/tt2' + my $ttroot = Template::Config->instdir() + || die "$Template::Config::ERROR\n"; + + # e.g. returns '/usr/local/tt2/templates' + my $template = Template::Config->instdir('templates') + || die "$Template::Config::ERROR\n"; + +Returns undef and sets $Template::Config::ERROR appropriately if the +optional components of the Template Toolkit have not been installed. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.62, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template> diff --git a/lib/Template/Constants.pm b/lib/Template/Constants.pm new file mode 100644 index 0000000..60af6bb --- /dev/null +++ b/lib/Template/Constants.pm @@ -0,0 +1,277 @@ +#============================================================= -*-Perl-*- +# +# Template::Constants.pm +# +# DESCRIPTION +# Definition of constants for the Template Toolkit. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Constants.pm,v 2.62 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Constants; + +require 5.004; +require Exporter; + +use strict; +use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ); +use vars qw( $DEBUG_OPTIONS @STATUS @ERROR @CHOMP @DEBUG); + +@ISA = qw( Exporter ); +$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); + + +#======================================================================== +# ----- EXPORTER ----- +#======================================================================== + +# STATUS constants returned by directives +use constant STATUS_OK => 0; # ok +use constant STATUS_RETURN => 1; # ok, block ended by RETURN +use constant STATUS_STOP => 2; # ok, stoppped by STOP +use constant STATUS_DONE => 3; # ok, iterator done +use constant STATUS_DECLINED => 4; # ok, declined to service request +use constant STATUS_ERROR => 255; # error condition + +# ERROR constants for indicating exception types +use constant ERROR_RETURN => 'return'; # return a status code +use constant ERROR_FILE => 'file'; # file error: I/O, parse, recursion +use constant ERROR_VIEW => 'view'; # view error +use constant ERROR_UNDEF => 'undef'; # undefined variable value used +use constant ERROR_PERL => 'perl'; # error in [% PERL %] block +use constant ERROR_FILTER => 'filter'; # filter error +use constant ERROR_PLUGIN => 'plugin'; # plugin error + +# CHOMP constants for PRE_CHOMP and POST_CHOMP +use constant CHOMP_NONE => 0; # do not remove whitespace +use constant CHOMP_ALL => 1; # remove whitespace +use constant CHOMP_COLLAPSE => 2; # collapse whitespace to a single space + +# DEBUG constants to enable various debugging options +use constant DEBUG_OFF => 0; # do nothing +use constant DEBUG_ON => 1; # basic debugging flag +use constant DEBUG_UNDEF => 2; # throw undef on undefined variables +use constant DEBUG_VARS => 4; # general variable debugging +use constant DEBUG_DIRS => 8; # directive debugging +use constant DEBUG_STASH => 16; # general stash debugging +use constant DEBUG_CONTEXT => 32; # context debugging +use constant DEBUG_PARSER => 64; # parser debugging +use constant DEBUG_PROVIDER => 128; # provider debugging +use constant DEBUG_PLUGINS => 256; # plugins debugging +use constant DEBUG_FILTERS => 512; # filters debugging +use constant DEBUG_SERVICE => 1024; # context debugging +use constant DEBUG_ALL => 2047; # everything + +# extra debugging flags +use constant DEBUG_CALLER => 4096; # add caller file/line +use constant DEBUG_FLAGS => 4096; # bitmask to extraxt flags + +$DEBUG_OPTIONS = { + &DEBUG_OFF => off => off => &DEBUG_OFF, + &DEBUG_ON => on => on => &DEBUG_ON, + &DEBUG_UNDEF => undef => undef => &DEBUG_UNDEF, + &DEBUG_VARS => vars => vars => &DEBUG_VARS, + &DEBUG_DIRS => dirs => dirs => &DEBUG_DIRS, + &DEBUG_STASH => stash => stash => &DEBUG_STASH, + &DEBUG_CONTEXT => context => context => &DEBUG_CONTEXT, + &DEBUG_PARSER => parser => parser => &DEBUG_PARSER, + &DEBUG_PROVIDER => provider => provider => &DEBUG_PROVIDER, + &DEBUG_PLUGINS => plugins => plugins => &DEBUG_PLUGINS, + &DEBUG_FILTERS => filters => filters => &DEBUG_FILTERS, + &DEBUG_SERVICE => service => service => &DEBUG_SERVICE, + &DEBUG_ALL => all => all => &DEBUG_ALL, + &DEBUG_CALLER => caller => caller => &DEBUG_CALLER, +}; + +@STATUS = qw( STATUS_OK STATUS_RETURN STATUS_STOP STATUS_DONE + STATUS_DECLINED STATUS_ERROR ); +@ERROR = qw( ERROR_FILE ERROR_VIEW ERROR_UNDEF ERROR_PERL + ERROR_RETURN ERROR_FILTER ERROR_PLUGIN ); +@CHOMP = qw( CHOMP_NONE CHOMP_ALL CHOMP_COLLAPSE ); +@DEBUG = qw( DEBUG_OFF DEBUG_ON DEBUG_UNDEF DEBUG_VARS + DEBUG_DIRS DEBUG_STASH DEBUG_CONTEXT DEBUG_PARSER + DEBUG_PROVIDER DEBUG_PLUGINS DEBUG_FILTERS DEBUG_SERVICE + DEBUG_ALL DEBUG_CALLER DEBUG_FLAGS ); + +@EXPORT_OK = ( @STATUS, @ERROR, @CHOMP, @DEBUG ); +%EXPORT_TAGS = ( + 'all' => [ @EXPORT_OK ], + 'status' => [ @STATUS ], + 'error' => [ @ERROR ], + 'chomp' => [ @CHOMP ], + 'debug' => [ @DEBUG ], +); + + +sub debug_flags { + my ($self, $debug) = @_; + my (@flags, $flag, $value); + $debug = $self unless defined($debug) || ref($self); + + if ($debug =~ /^\d+$/) { + foreach $flag (@DEBUG) { + next if $flag =~ /^DEBUG_(OFF|ALL|FLAGS)$/; + + # don't trash the original + my $copy = $flag; + $flag =~ s/^DEBUG_//; + $flag = lc $flag; + return $self->error("no value for flag: $flag") + unless defined($value = $DEBUG_OPTIONS->{ $flag }); + $flag = $value; + + if ($debug & $flag) { + $value = $DEBUG_OPTIONS->{ $flag }; + return $self->error("no value for flag: $flag") unless defined $value; + push(@flags, $value); + } + } + return wantarray ? @flags : join(', ', @flags); + } + else { + @flags = split(/\W+/, $debug); + $debug = 0; + foreach $flag (@flags) { + $value = $DEBUG_OPTIONS->{ $flag }; + return $self->error("unknown debug flag: $flag") unless defined $value; + $debug |= $value; + } + return $debug; + } +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Constants - Defines constants for the Template Toolkit + +=head1 SYNOPSIS + + use Template::Constants qw( :status :error :all ); + +=head1 DESCRIPTION + +The Template::Constants modules defines, and optionally exports into the +caller's namespace, a number of constants used by the Template package. + +Constants may be used by specifying the Template::Constants package +explicitly: + + use Template::Constants; + + print Template::Constants::STATUS_DECLINED; + +Constants may be imported into the caller's namespace by naming them as +options to the C<use Template::Constants> statement: + + use Template::Constants qw( STATUS_DECLINED ); + + print STATUS_DECLINED; + +Alternatively, one of the following tagset identifiers may be specified +to import sets of constants; :status, :error, :all. + + use Template::Constants qw( :status ); + + print STATUS_DECLINED; + +See L<Exporter> for more information on exporting variables. + +=head1 EXPORTABLE TAG SETS + +The following tag sets and associated constants are defined: + + :status + STATUS_OK # no problem, continue + STATUS_RETURN # ended current block then continue (ok) + STATUS_STOP # controlled stop (ok) + STATUS_DONE # iterator is all done (ok) + STATUS_DECLINED # provider declined to service request (ok) + STATUS_ERROR # general error condition (not ok) + + :error + ERROR_RETURN # return a status code (e.g. 'stop') + ERROR_FILE # file error: I/O, parse, recursion + ERROR_UNDEF # undefined variable value used + ERROR_PERL # error in [% PERL %] block + ERROR_FILTER # filter error + ERROR_PLUGIN # plugin error + + :chomp # for PRE_CHOMP and POST_CHOMP + CHOMP_NONE # do not remove whitespace + CHOMP_ALL # remove whitespace + CHOMP_COLLAPSE # collapse whitespace to a single space + + :debug + DEBUG_OFF # do nothing + DEBUG_ON # basic debugging flag + DEBUG_UNDEF # throw undef on undefined variables + DEBUG_VARS # general variable debugging + DEBUG_DIRS # directive debugging + DEBUG_STASH # general stash debugging + DEBUG_CONTEXT # context debugging + DEBUG_PARSER # parser debugging + DEBUG_PROVIDER # provider debugging + DEBUG_PLUGINS # plugins debugging + DEBUG_FILTERS # filters debugging + DEBUG_SERVICE # context debugging + DEBUG_ALL # everything + DEBUG_CALLER # add caller file/line info + DEBUG_FLAGS # bitmap used internally + + :all All the above constants. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.62, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Exporter|Exporter> diff --git a/lib/Template/Context.pm b/lib/Template/Context.pm new file mode 100644 index 0000000..6fb29ca --- /dev/null +++ b/lib/Template/Context.pm @@ -0,0 +1,1549 @@ +#============================================================= -*-Perl-*- +# +# Template::Context +# +# DESCRIPTION +# Module defining a context in which a template document is processed. +# This is the runtime processing interface through which templates +# can access the functionality of the Template Toolkit. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# REVISION +# $Id: Context.pm,v 2.81 2003/07/24 11:32:35 abw Exp $ +# +#============================================================================ + +package Template::Context; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $AUTOLOAD $DEBUG_FORMAT ); +use base qw( Template::Base ); + +use Template::Base; +use Template::Config; +use Template::Constants; +use Template::Exception; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.81 $ =~ /(\d+)\.(\d+)/); +$DEBUG_FORMAT = "\n## \$file line \$line : [% \$text %] ##\n"; + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# template($name) +# +# General purpose method to fetch a template and return it in compiled +# form. In the usual case, the $name parameter will be a simple string +# containing the name of a template (e.g. 'header'). It may also be +# a reference to Template::Document object (or sub-class) or a Perl +# sub-routine. These are considered to be compiled templates and are +# returned intact. Finally, it may be a reference to any other kind +# of valid input source accepted by Template::Provider (e.g. scalar +# ref, glob, IO handle, etc). +# +# Templates may be cached at one of 3 different levels. The internal +# BLOCKS member is a local cache which holds references to all +# template blocks used or imported via PROCESS since the context's +# reset() method was last called. This is checked first and if the +# template is not found, the method then walks down the BLOCKSTACK +# list. This contains references to the block definition tables in +# any enclosing Template::Documents that we're visiting (e.g. we've +# been called via an INCLUDE and we want to access a BLOCK defined in +# the template that INCLUDE'd us). If nothing is defined, then we +# iterate through the LOAD_TEMPLATES providers list as a 'chain of +# responsibility' (see Design Patterns) asking each object to fetch() +# the template if it can. +# +# Returns the compiled template. On error, undef is returned and +# the internal ERROR value (read via error()) is set to contain an +# error message of the form "$name: $error". +#------------------------------------------------------------------------ + +sub template { + my ($self, $name) = @_; + my ($prefix, $blocks, $defblocks, $provider, $template, $error); + my ($shortname, $blockname, $providers); + + $self->debug("template($name)") if $self->{ DEBUG }; + + # references to Template::Document (or sub-class) objects objects, or + # CODE references are assumed to be pre-compiled templates and are + # returned intact + return $name + if UNIVERSAL::isa($name, 'Template::Document') + || ref($name) eq 'CODE'; + + $shortname = $name; + + unless (ref $name) { + + $self->debug("looking for block [$name]") if $self->{ DEBUG }; + + # we first look in the BLOCKS hash for a BLOCK that may have + # been imported from a template (via PROCESS) + return $template + if ($template = $self->{ BLOCKS }->{ $name }); + + # then we iterate through the BLKSTACK list to see if any of the + # Template::Documents we're visiting define this BLOCK + foreach $blocks (@{ $self->{ BLKSTACK } }) { + return $template + if $blocks && ($template = $blocks->{ $name }); + } + + # now it's time to ask the providers, so we look to see if any + # prefix is specified to indicate the desired provider set. + if ($^O eq 'MSWin32') { + # let C:/foo through + $prefix = $1 if $shortname =~ s/^(\w{2,})://o; + } + else { + $prefix = $1 if $shortname =~ s/^(\w+)://; + } + + if (defined $prefix) { + $providers = $self->{ PREFIX_MAP }->{ $prefix } + || return $self->throw(Template::Constants::ERROR_FILE, + "no providers for template prefix '$prefix'"); + } + } + $providers = $self->{ PREFIX_MAP }->{ default } + || $self->{ LOAD_TEMPLATES } + unless $providers; + + + # Finally we try the regular template providers which will + # handle references to files, text, etc., as well as templates + # reference by name. If + + $blockname = ''; + while ($shortname) { + $self->debug("asking providers for [$shortname] [$blockname]") + if $self->{ DEBUG }; + + foreach my $provider (@$providers) { + ($template, $error) = $provider->fetch($shortname, $prefix); + if ($error) { + if ($error == Template::Constants::STATUS_ERROR) { + # $template contains exception object + if (UNIVERSAL::isa($template, 'Template::Exception') + && $template->type() eq Template::Constants::ERROR_FILE) { + $self->throw($template); + } + else { + $self->throw( Template::Constants::ERROR_FILE, $template ); + } + } + # DECLINE is ok, carry on + } + elsif (length $blockname) { + return $template + if $template = $template->blocks->{ $blockname }; + } + else { + return $template; + } + } + + last if ref $shortname || ! $self->{ EXPOSE_BLOCKS }; + $shortname =~ s{/([^/]+)$}{} || last; + $blockname = length $blockname ? "$1/$blockname" : $1; + } + + $self->throw(Template::Constants::ERROR_FILE, "$name: not found"); +} + + +#------------------------------------------------------------------------ +# plugin($name, \@args) +# +# Calls on each of the LOAD_PLUGINS providers in turn to fetch() (i.e. load +# and instantiate) a plugin of the specified name. Additional parameters +# passed are propagated to the new() constructor for the plugin. +# Returns a reference to a new plugin object or other reference. On +# error, undef is returned and the appropriate error message is set for +# subsequent retrieval via error(). +#------------------------------------------------------------------------ + +sub plugin { + my ($self, $name, $args) = @_; + my ($provider, $plugin, $error); + + $self->debug("plugin($name, ", defined $args ? @$args : '[ ]', ')') + if $self->{ DEBUG }; + + # request the named plugin from each of the LOAD_PLUGINS providers in turn + foreach my $provider (@{ $self->{ LOAD_PLUGINS } }) { + ($plugin, $error) = $provider->fetch($name, $args, $self); + return $plugin unless $error; + if ($error == Template::Constants::STATUS_ERROR) { + $self->throw($plugin) if ref $plugin; + $self->throw(Template::Constants::ERROR_PLUGIN, $plugin); + } + } + + $self->throw(Template::Constants::ERROR_PLUGIN, "$name: plugin not found"); +} + + +#------------------------------------------------------------------------ +# filter($name, \@args, $alias) +# +# Similar to plugin() above, but querying the LOAD_FILTERS providers to +# return filter instances. An alias may be provided which is used to +# save the returned filter in a local cache. +#------------------------------------------------------------------------ + +sub filter { + my ($self, $name, $args, $alias) = @_; + my ($provider, $filter, $error); + + $self->debug("filter($name, ", + defined $args ? @$args : '[ ]', + defined $alias ? $alias : '<no alias>', ')') + if $self->{ DEBUG }; + + # use any cached version of the filter if no params provided + return $filter + if ! $args && ! ref $name + && ($filter = $self->{ FILTER_CACHE }->{ $name }); + + # request the named filter from each of the FILTERS providers in turn + foreach my $provider (@{ $self->{ LOAD_FILTERS } }) { + ($filter, $error) = $provider->fetch($name, $args, $self); + last unless $error; + if ($error == Template::Constants::STATUS_ERROR) { + $self->throw($filter) if ref $filter; + $self->throw(Template::Constants::ERROR_FILTER, $filter); + } + # return $self->error($filter) + # if $error == &Template::Constants::STATUS_ERROR; + } + + return $self->error("$name: filter not found") + unless $filter; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # commented out by abw on 19 Nov 2001 to fix problem with xmlstyle + # plugin which may re-define a filter by calling define_filter() + # multiple times. With the automatic aliasing/caching below, any + # new filter definition isn't seen. Don't think this will cause + # any problems as filters explicitly supplied with aliases will + # still work as expected. + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # alias defaults to name if undefined + # $alias = $name + # unless defined($alias) or ref($name) or $args; + + # cache FILTER if alias is valid + $self->{ FILTER_CACHE }->{ $alias } = $filter + if $alias; + + return $filter; +} + + +#------------------------------------------------------------------------ +# view(\%config) +# +# Create a new Template::View bound to this context. +#------------------------------------------------------------------------ + +sub view { + my $self = shift; + require Template::View; + return Template::View->new($self, @_) + || $self->throw(&Template::Constants::ERROR_VIEW, + $Template::View::ERROR); +} + + +#------------------------------------------------------------------------ +# process($template, \%params) [% PROCESS template var=val ... %] +# process($template, \%params, $local) [% INCLUDE template var=val ... %] +# +# Processes the template named or referenced by the first parameter. +# The optional second parameter may reference a hash array of variable +# definitions. These are set before the template is processed by +# calling update() on the stash. Note that, unless the third parameter +# is true, the context is not localised and these, and any other +# variables set in the template will retain their new values after this +# method returns. The third parameter is in place so that this method +# can handle INCLUDE calls: the stash will be localized. +# +# Returns the output of processing the template. Errors are thrown +# as Template::Exception objects via die(). +#------------------------------------------------------------------------ + +sub process { + my ($self, $template, $params, $localize) = @_; + my ($trim, $blocks) = @$self{ qw( TRIM BLOCKS ) }; + my (@compiled, $name, $compiled); + my ($stash, $tblocks, $error, $tmpout); + my $output = ''; + + $template = [ $template ] unless ref $template eq 'ARRAY'; + + $self->debug("process([ ", join(', '), @$template, ' ], ', + defined $params ? $params : '<no params>', ', ', + $localize ? '<localized>' : '<unlocalized>', ')') + if $self->{ DEBUG }; + + # fetch compiled template for each name specified + foreach $name (@$template) { + push(@compiled, $self->template($name)); + } + + if ($localize) { + # localise the variable stash with any parameters passed + $stash = $self->{ STASH } = $self->{ STASH }->clone($params); + } else { + # update stash with any new parameters passed + $self->{ STASH }->update($params); + $stash = $self->{ STASH }; + } + + eval { + foreach $name (@$template) { + $compiled = shift @compiled; + my $element = ref $compiled eq 'CODE' + ? { (name => (ref $name ? '' : $name), modtime => time()) } + : $compiled; + $stash->set('component', $element); + + unless ($localize) { + # merge any local blocks defined in the Template::Document + # into our local BLOCKS cache + @$blocks{ keys %$tblocks } = values %$tblocks + if UNIVERSAL::isa($compiled, 'Template::Document') + && ($tblocks = $compiled->blocks()); + } + + if (ref $compiled eq 'CODE') { + $tmpout = &$compiled($self); + } + elsif (ref $compiled) { + $tmpout = $compiled->process($self); + } + else { + $self->throw('file', + "invalid template reference: $compiled"); + } + + if ($trim) { + for ($tmpout) { + s/^\s+//; + s/\s+$//; + } + } + $output .= $tmpout; + } + }; + $error = $@; + + if ($localize) { + # ensure stash is delocalised before dying + $self->{ STASH } = $self->{ STASH }->declone(); + } + + $self->throw(ref $error + ? $error : (Template::Constants::ERROR_FILE, $error)) + if $error; + + return $output; +} + + +#------------------------------------------------------------------------ +# include($template, \%params) [% INCLUDE template var = val, ... %] +# +# Similar to process() above but processing the template in a local +# context. Any variables passed by reference to a hash as the second +# parameter will be set before the template is processed and then +# revert to their original values before the method returns. Similarly, +# any changes made to non-global variables within the template will +# persist only until the template is processed. +# +# Returns the output of processing the template. Errors are thrown +# as Template::Exception objects via die(). +#------------------------------------------------------------------------ + +sub include { + my ($self, $template, $params) = @_; + return $self->process($template, $params, 'localize me!'); +} + +#------------------------------------------------------------------------ +# insert($file) +# +# Insert the contents of a file without parsing. +#------------------------------------------------------------------------ + +sub insert { + my ($self, $file) = @_; + my ($prefix, $providers, $text, $error); + my $output = ''; + + my $files = ref $file eq 'ARRAY' ? $file : [ $file ]; + + $self->debug("insert([ ", join(', '), @$files, " ])") + if $self->{ DEBUG }; + + + FILE: foreach $file (@$files) { + my $name = $file; + + if ($^O eq 'MSWin32') { + # let C:/foo through + $prefix = $1 if $name =~ s/^(\w{2,})://o; + } + else { + $prefix = $1 if $name =~ s/^(\w+)://; + } + + if (defined $prefix) { + $providers = $self->{ PREFIX_MAP }->{ $prefix } + || return $self->throw(Template::Constants::ERROR_FILE, + "no providers for file prefix '$prefix'"); + } + else { + $providers = $self->{ PREFIX_MAP }->{ default } + || $self->{ LOAD_TEMPLATES }; + } + + foreach my $provider (@$providers) { + ($text, $error) = $provider->load($name, $prefix); + next FILE unless $error; + if ($error == Template::Constants::STATUS_ERROR) { + $self->throw($text) if ref $text; + $self->throw(Template::Constants::ERROR_FILE, $text); + } + } + $self->throw(Template::Constants::ERROR_FILE, "$file: not found"); + } + continue { + $output .= $text; + } + return $output; +} + + +#------------------------------------------------------------------------ +# throw($type, $info, \$output) [% THROW errtype "Error info" %] +# +# Throws a Template::Exception object by calling die(). This method +# may be passed a reference to an existing Template::Exception object; +# a single value containing an error message which is used to +# instantiate a Template::Exception of type 'undef'; or a pair of +# values representing the exception type and info from which a +# Template::Exception object is instantiated. e.g. +# +# $context->throw($exception); +# $context->throw("I'm sorry Dave, I can't do that"); +# $context->throw('denied', "I'm sorry Dave, I can't do that"); +# +# An optional third parameter can be supplied in the last case which +# is a reference to the current output buffer containing the results +# of processing the template up to the point at which the exception +# was thrown. The RETURN and STOP directives, for example, use this +# to propagate output back to the user, but it can safely be ignored +# in most cases. +# +# This method rides on a one-way ticket to die() oblivion. It does not +# return in any real sense of the word, but should get caught by a +# surrounding eval { } block (e.g. a BLOCK or TRY) and handled +# accordingly, or returned to the caller as an uncaught exception. +#------------------------------------------------------------------------ + +sub throw { + my ($self, $error, $info, $output) = @_; + local $" = ', '; + + # die! die! die! + if (UNIVERSAL::isa($error, 'Template::Exception')) { + die $error; + } + elsif (defined $info) { + die (Template::Exception->new($error, $info, $output)); + } + else { + $error ||= ''; + die (Template::Exception->new('undef', $error, $output)); + } + + # not reached +} + + +#------------------------------------------------------------------------ +# catch($error, \$output) +# +# Called by various directives after catching an error thrown via die() +# from within an eval { } block. The first parameter contains the errror +# which may be a sanitized reference to a Template::Exception object +# (such as that raised by the throw() method above, a plugin object, +# and so on) or an error message thrown via die from somewhere in user +# code. The latter are coerced into 'undef' Template::Exception objects. +# Like throw() above, a reference to a scalar may be passed as an +# additional parameter to represent the current output buffer +# localised within the eval block. As exceptions are thrown upwards +# and outwards from nested blocks, the catch() method reconstructs the +# correct output buffer from these fragments, storing it in the +# exception object for passing further onwards and upwards. +# +# Returns a reference to a Template::Exception object.. +#------------------------------------------------------------------------ + +sub catch { + my ($self, $error, $output) = @_; + + if (UNIVERSAL::isa($error, 'Template::Exception')) { + $error->text($output) if $output; + return $error; + } + else { + return Template::Exception->new('undef', $error, $output); + } +} + + +#------------------------------------------------------------------------ +# localise(\%params) +# delocalise() +# +# The localise() method creates a local copy of the current stash, +# allowing the existing state of variables to be saved and later +# restored via delocalise(). +# +# A reference to a hash array may be passed containing local variable +# definitions which should be added to the cloned namespace. These +# values persist until delocalisation. +#------------------------------------------------------------------------ + +sub localise { + my $self = shift; + $self->{ STASH } = $self->{ STASH }->clone(@_); +} + +sub delocalise { + my $self = shift; + $self->{ STASH } = $self->{ STASH }->declone(); +} + + +#------------------------------------------------------------------------ +# visit($blocks) +# +# Each Template::Document calls the visit() method on the context +# before processing itself. It passes a reference to the hash array +# of named BLOCKs defined within the document, allowing them to be +# added to the internal BLKSTACK list which is subsequently used by +# template() to resolve templates. +# from a provider. +#------------------------------------------------------------------------ + +sub visit { + my ($self, $blocks) = @_; + unshift(@{ $self->{ BLKSTACK } }, $blocks) +} + + +#------------------------------------------------------------------------ +# leave() +# +# The leave() method is called when the document has finished +# processing itself. This removes the entry from the BLKSTACK list +# that was added visit() above. For persistance of BLOCK definitions, +# the process() method (i.e. the PROCESS directive) does some extra +# magic to copy BLOCKs into a shared hash. +#------------------------------------------------------------------------ + +sub leave { + my $self = shift; + shift(@{ $self->{ BLKSTACK } }); +} + + +#------------------------------------------------------------------------ +# define_block($name, $block) +# +# Adds a new BLOCK definition to the local BLOCKS cache. $block may +# be specified as a reference to a sub-routine or Template::Document +# object or as text which is compiled into a template. Returns a true +# value (the $block reference or compiled block reference) if +# succesful or undef on failure. Call error() to retrieve the +# relevent error message (i.e. compilation failure). +#------------------------------------------------------------------------ + +sub define_block { + my ($self, $name, $block) = @_; + $block = $self->template(\$block) + || return undef + unless ref $block; + $self->{ BLOCKS }->{ $name } = $block; +} + + +#------------------------------------------------------------------------ +# define_filter($name, $filter, $is_dynamic) +# +# Adds a new FILTER definition to the local FILTER_CACHE. +#------------------------------------------------------------------------ + +sub define_filter { + my ($self, $name, $filter, $is_dynamic) = @_; + my ($result, $error); + $filter = [ $filter, 1 ] if $is_dynamic; + + foreach my $provider (@{ $self->{ LOAD_FILTERS } }) { + ($result, $error) = $provider->store($name, $filter); + return 1 unless $error; + $self->throw(&Template::Constants::ERROR_FILTER, $result) + if $error == &Template::Constants::STATUS_ERROR; + } + $self->throw(&Template::Constants::ERROR_FILTER, + "FILTER providers declined to store filter $name"); +} + + +#------------------------------------------------------------------------ +# reset() +# +# Reset the state of the internal BLOCKS hash to clear any BLOCK +# definitions imported via the PROCESS directive. Any original +# BLOCKS definitions passed to the constructor will be restored. +#------------------------------------------------------------------------ + +sub reset { + my ($self, $blocks) = @_; + $self->{ BLKSTACK } = [ ]; + $self->{ BLOCKS } = { %{ $self->{ INIT_BLOCKS } } }; +} + + +#------------------------------------------------------------------------ +# stash() +# +# Simple accessor methods to return the STASH values. This is likely +# to be called quite often so we provide a direct method rather than +# relying on the slower AUTOLOAD. +#------------------------------------------------------------------------ + +sub stash { + return $_[0]->{ STASH }; +} + + +#------------------------------------------------------------------------ +# define_vmethod($type, $name, \&sub) +# +# Passes $type, $name, and &sub on to stash->define_vmethod(). +#------------------------------------------------------------------------ +sub define_vmethod { + my $self = shift; + $self->stash->define_vmethod(@_); +} + + +#------------------------------------------------------------------------ +# debugging($command, @args, \%params) +# +# Method for controlling the debugging status of the context. The first +# argument can be 'on' or 'off' to enable/disable debugging, 'format' +# to define the format of the debug message, or 'msg' to generate a +# debugging message reporting the file, line, message text, etc., +# according to the current debug format. +#------------------------------------------------------------------------ + +sub debugging { + my $self = shift; + my $hash = ref $_[-1] eq 'HASH' ? pop : { }; + my @args = @_; + +# print "*** debug(@args)\n"; + if (@args) { + if ($args[0] =~ /^on|1$/i) { + $self->{ DEBUG_DIRS } = 1; + shift(@args); + } + elsif ($args[0] =~ /^off|0$/i) { + $self->{ DEBUG_DIRS } = 0; + shift(@args); + } + } + + if (@args) { + if ($args[0] =~ /^msg$/i) { + return unless $self->{ DEBUG_DIRS }; + my $format = $self->{ DEBUG_FORMAT }; + $format = $DEBUG_FORMAT unless defined $format; + $format =~ s/\$(\w+)/$hash->{ $1 }/ge; + return $format; + } + elsif ($args[0] =~ /^format$/i) { + $self->{ DEBUG_FORMAT } = $args[1]; + } + # else ignore + } + + return ''; +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# Provides pseudo-methods for read-only access to various internal +# members. For example, templates(), plugins(), filters(), +# eval_perl(), load_perl(), etc. These aren't called very often, or +# may never be called at all. +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + my $result; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + + warn "no such context method/member: $method\n" + unless defined ($result = $self->{ uc $method }); + + return $result; +} + + +#------------------------------------------------------------------------ +# DESTROY +# +# Stash may contain references back to the Context via macro closures, +# etc. This breaks the circular references. +#------------------------------------------------------------------------ + +sub DESTROY { + my $self = shift; + undef $self->{ STASH }; +} + + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init(\%config) +# +# Initialisation method called by Template::Base::new() +#------------------------------------------------------------------------ + +sub _init { + my ($self, $config) = @_; + my ($name, $item, $method, $block, $blocks); + my @itemlut = ( + LOAD_TEMPLATES => 'provider', + LOAD_PLUGINS => 'plugins', + LOAD_FILTERS => 'filters' + ); + + # LOAD_TEMPLATE, LOAD_PLUGINS, LOAD_FILTERS - lists of providers + while (($name, $method) = splice(@itemlut, 0, 2)) { + $item = $config->{ $name } + || Template::Config->$method($config) + || return $self->error($Template::Config::ERROR); + $self->{ $name } = ref $item eq 'ARRAY' ? $item : [ $item ]; + } + + my $providers = $self->{ LOAD_TEMPLATES }; + my $prefix_map = $self->{ PREFIX_MAP } = $config->{ PREFIX_MAP } || { }; + while (my ($key, $val) = each %$prefix_map) { + $prefix_map->{ $key } = [ ref $val ? $val : + map { $providers->[$_] } + split(/\D+/, $val) ] + unless ref $val eq 'ARRAY'; +# print(STDERR "prefix $key => $val => [", +# join(', ', @{ $prefix_map->{ $key } }), "]\n"); + } + + # STASH + $self->{ STASH } = $config->{ STASH } || do { + my $predefs = $config->{ VARIABLES } + || $config->{ PRE_DEFINE } + || { }; + + # hack to get stash to know about debug mode + $predefs->{ _DEBUG } = ( ($config->{ DEBUG } || 0) + & &Template::Constants::DEBUG_UNDEF ) ? 1 : 0 + unless defined $predefs->{ _DEBUG }; + + Template::Config->stash($predefs) + || return $self->error($Template::Config::ERROR); + }; + + # compile any template BLOCKS specified as text + $blocks = $config->{ BLOCKS } || { }; + $self->{ INIT_BLOCKS } = $self->{ BLOCKS } = { + map { + $block = $blocks->{ $_ }; + $block = $self->template(\$block) + || return undef + unless ref $block; + ($_ => $block); + } + keys %$blocks + }; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # RECURSION - flag indicating is recursion into templates is supported + # EVAL_PERL - flag indicating if PERL blocks should be processed + # TRIM - flag to remove leading and trailing whitespace from output + # BLKSTACK - list of hashes of BLOCKs defined in current template(s) + # CONFIG - original configuration hash + # EXPOSE_BLOCKS - make blocks visible as pseudo-files + # DEBUG_FORMAT - format for generating template runtime debugging messages + # DEBUG - format for generating template runtime debugging messages + + $self->{ RECURSION } = $config->{ RECURSION } || 0; + $self->{ EVAL_PERL } = $config->{ EVAL_PERL } || 0; + $self->{ TRIM } = $config->{ TRIM } || 0; + $self->{ BLKSTACK } = [ ]; + $self->{ CONFIG } = $config; + $self->{ EXPOSE_BLOCKS } = defined $config->{ EXPOSE_BLOCKS } + ? $config->{ EXPOSE_BLOCKS } + : 0; + + $self->{ DEBUG_FORMAT } = $config->{ DEBUG_FORMAT }; + $self->{ DEBUG_DIRS } = ($config->{ DEBUG } || 0) + & Template::Constants::DEBUG_DIRS; + $self->{ DEBUG } = defined $config->{ DEBUG } + ? $config->{ DEBUG } & ( Template::Constants::DEBUG_CONTEXT + | Template::Constants::DEBUG_FLAGS ) + : $DEBUG; + + return $self; +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the context object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $output = "[Template::Context] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + foreach $key (qw( RECURSION EVAL_PERL TRIM )) { + $output .= sprintf($format, $key, $self->{ $key }); + } + foreach my $pname (qw( LOAD_TEMPLATES LOAD_PLUGINS LOAD_FILTERS )) { + my $provtext = "[\n"; + foreach my $prov (@{ $self->{ $pname } }) { + $provtext .= $prov->_dump(); +# $provtext .= ",\n"; + } + $provtext =~ s/\n/\n /g; + $provtext =~ s/\s+$//; + $provtext .= ",\n ]"; + $output .= sprintf($format, $pname, $provtext); + } + $output .= sprintf($format, STASH => $self->{ STASH }->_dump()); + $output .= '}'; + return $output; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Context - Runtime context in which templates are processed + +=head1 SYNOPSIS + + use Template::Context; + + # constructor + $context = Template::Context->new(\%config) + || die $Template::Context::ERROR; + + # fetch (load and compile) a template + $template = $context->template($template_name); + + # fetch (load and instantiate) a plugin object + $plugin = $context->plugin($name, \@args); + + # fetch (return or create) a filter subroutine + $filter = $context->filter($name, \@args, $alias); + + # process/include a template, errors are thrown via die() + $output = $context->process($template, \%vars); + $output = $context->include($template, \%vars); + + # raise an exception via die() + $context->throw($error_type, $error_message, \$output_buffer); + + # catch an exception, clean it up and fix output buffer + $exception = $context->catch($exception, \$output_buffer); + + # save/restore the stash to effect variable localisation + $new_stash = $context->localise(\%vars); + $old_stash = $context->delocalise(); + + # add new BLOCK or FILTER definitions + $context->define_block($name, $block); + $context->define_filter($name, \&filtersub, $is_dynamic); + + # reset context, clearing any imported BLOCK definitions + $context->reset(); + + # methods for accessing internal items + $stash = $context->stash(); + $tflag = $context->trim(); + $epflag = $context->eval_perl(); + $providers = $context->templates(); + $providers = $context->plugins(); + $providers = $context->filters(); + ... + +=head1 DESCRIPTION + +The Template::Context module defines an object class for representing +a runtime context in which templates are processed. It provides an +interface to the fundamental operations of the Template Toolkit +processing engine through which compiled templates (i.e. Perl code +constructed from the template source) can process templates, load +plugins and filters, raise exceptions and so on. + +A default Template::Context object is created by the Template module. +Any Template::Context options may be passed to the Template new() +constructor method and will be forwarded to the Template::Context +constructor. + + use Template; + + my $template = Template->new({ + TRIM => 1, + EVAL_PERL => 1, + BLOCKS => { + header => 'This is the header', + footer => 'This is the footer', + }, + }); + +Similarly, the Template::Context constructor will forward all configuration +parameters onto other default objects (e.g. Template::Provider, Template::Plugins, +Template::Filters, etc.) that it may need to instantiate. + + $context = Template::Context->new({ + INCLUDE_PATH => '/home/abw/templates', # provider option + TAG_STYLE => 'html', # parser option + }); + +A Template::Context object (or subclass/derivative) can be explicitly +instantiated and passed to the Template new() constructor method as +the CONTEXT item. + + use Template; + use Template::Context; + + my $context = Template::Context->new({ TRIM => 1 }); + my $template = Template->new({ CONTEXT => $context }); + +The Template module uses the Template::Config context() factory method +to create a default context object when required. The +$Template::Config::CONTEXT package variable may be set to specify an +alternate context module. This will be loaded automatically and its +new() constructor method called by the context() factory method when +a default context object is required. + + use Template; + + $Template::Config::CONTEXT = 'MyOrg::Template::Context'; + + my $template = Template->new({ + EVAL_PERL => 1, + EXTRA_MAGIC => 'red hot', # your extra config items + ... + }); + +=head1 METHODS + +=head2 new(\%params) + +The new() constructor method is called to instantiate a Template::Context +object. Configuration parameters may be specified as a HASH reference or +as a list of (name =E<gt> value) pairs. + + my $context = Template::Context->new({ + INCLUDE_PATH => 'header', + POST_PROCESS => 'footer', + }); + + my $context = Template::Context->new( EVAL_PERL => 1 ); + +The new() method returns a Template::Context object (or sub-class) or +undef on error. In the latter case, a relevant error message can be +retrieved by the error() class method or directly from the +$Template::Context::ERROR package variable. + + my $context = Template::Context->new(\%config) + || die Template::Context->error(); + + my $context = Template::Context->new(\%config) + || die $Template::Context::ERROR; + +The following configuration items may be specified. + +=over 4 + + +=item VARIABLES, PRE_DEFINE + +The VARIABLES option (or PRE_DEFINE - they're equivalent) can be used +to specify a hash array of template variables that should be used to +pre-initialise the stash when it is created. These items are ignored +if the STASH item is defined. + + my $context = Template::Context->new({ + VARIABLES => { + title => 'A Demo Page', + author => 'Joe Random Hacker', + version => 3.14, + }, + }; + +or + + my $context = Template::Context->new({ + PRE_DEFINE => { + title => 'A Demo Page', + author => 'Joe Random Hacker', + version => 3.14, + }, + }; + + + + + +=item BLOCKS + +The BLOCKS option can be used to pre-define a default set of template +blocks. These should be specified as a reference to a hash array +mapping template names to template text, subroutines or Template::Document +objects. + + my $context = Template::Context->new({ + BLOCKS => { + header => 'The Header. [% title %]', + footer => sub { return $some_output_text }, + another => Template::Document->new({ ... }), + }, + }); + + + + + +=item TRIM + +The TRIM option can be set to have any leading and trailing whitespace +automatically removed from the output of all template files and BLOCKs. + +By example, the following BLOCK definition + + [% BLOCK foo %] + Line 1 of foo + [% END %] + +will be processed is as "\nLine 1 of foo\n". When INCLUDEd, the surrounding +newlines will also be introduced. + + before + [% INCLUDE foo %] + after + +output: + before + + Line 1 of foo + + after + +With the TRIM option set to any true value, the leading and trailing +newlines (which count as whitespace) will be removed from the output +of the BLOCK. + + before + Line 1 of foo + after + +The TRIM option is disabled (0) by default. + + + + + + +=item EVAL_PERL + +This flag is used to indicate if PERL and/or RAWPERL blocks should be +evaluated. By default, it is disabled and any PERL or RAWPERL blocks +encountered will raise exceptions of type 'perl' with the message +'EVAL_PERL not set'. Note however that any RAWPERL blocks should +always contain valid Perl code, regardless of the EVAL_PERL flag. The +parser will fail to compile templates that contain invalid Perl code +in RAWPERL blocks and will throw a 'file' exception. + +When using compiled templates (see +L<COMPILE_EXT|Template::Manual::Config/Caching_and_Compiling_Options> and +L<COMPILE_DIR|Template::Manual::Config/Caching_and_Compiling_Options>), +the EVAL_PERL has an affect when the template is compiled, and again +when the templates is subsequently processed, possibly in a different +context to the one that compiled it. + +If the EVAL_PERL is set when a template is compiled, then all PERL and +RAWPERL blocks will be included in the compiled template. If the +EVAL_PERL option isn't set, then Perl code will be generated which +B<always> throws a 'perl' exception with the message 'EVAL_PERL not +set' B<whenever> the compiled template code is run. + +Thus, you must have EVAL_PERL set if you want your compiled templates +to include PERL and RAWPERL blocks. + +At some point in the future, using a different invocation of the +Template Toolkit, you may come to process such a pre-compiled +template. Assuming the EVAL_PERL option was set at the time the +template was compiled, then the output of any RAWPERL blocks will be +included in the compiled template and will get executed when the +template is processed. This will happen regardless of the runtime +EVAL_PERL status. + +Regular PERL blocks are a little more cautious, however. If the +EVAL_PERL flag isn't set for the I<current> context, that is, the +one which is trying to process it, then it will throw the familiar 'perl' +exception with the message, 'EVAL_PERL not set'. + +Thus you can compile templates to include PERL blocks, but optionally +disable them when you process them later. Note however that it is +possible for a PERL block to contain a Perl "BEGIN { # some code }" +block which will always get run regardless of the runtime EVAL_PERL +status. Thus, if you set EVAL_PERL when compiling templates, it is +assumed that you trust the templates to Do The Right Thing. Otherwise +you must accept the fact that there's no bulletproof way to prevent +any included code from trampling around in the living room of the +runtime environment, making a real nuisance of itself if it really +wants to. If you don't like the idea of such uninvited guests causing +a bother, then you can accept the default and keep EVAL_PERL disabled. + + + + + + + +=item RECURSION + +The template processor will raise a file exception if it detects +direct or indirect recursion into a template. Setting this option to +any true value will allow templates to include each other recursively. + + + +=item LOAD_TEMPLATES + +The LOAD_TEMPLATE option can be used to provide a reference to a list +of Template::Provider objects or sub-classes thereof which will take +responsibility for loading and compiling templates. + + my $context = Template::Context->new({ + LOAD_TEMPLATES => [ + MyOrg::Template::Provider->new({ ... }), + Template::Provider->new({ ... }), + ], + }); + +When a PROCESS, INCLUDE or WRAPPER directive is encountered, the named +template may refer to a locally defined BLOCK or a file relative to +the INCLUDE_PATH (or an absolute or relative path if the appropriate +ABSOLUTE or RELATIVE options are set). If a BLOCK definition can't be +found (see the Template::Context template() method for a discussion of +BLOCK locality) then each of the LOAD_TEMPLATES provider objects is +queried in turn via the fetch() method to see if it can supply the +required template. Each provider can return a compiled template, an +error, or decline to service the request in which case the +responsibility is passed to the next provider. If none of the +providers can service the request then a 'not found' error is +returned. The same basic provider mechanism is also used for the +INSERT directive but it bypasses any BLOCK definitions and doesn't +attempt is to parse or process the contents of the template file. + +This is an implementation of the 'Chain of Responsibility' +design pattern as described in +"Design Patterns", Erich Gamma, Richard Helm, Ralph Johnson, John +Vlissides), Addision-Wesley, ISBN 0-201-63361-2, page 223 +. + +If LOAD_TEMPLATES is undefined, a single default provider will be +instantiated using the current configuration parameters. For example, +the Template::Provider INCLUDE_PATH option can be specified in the Template::Context configuration and will be correctly passed to the provider's +constructor method. + + my $context = Template::Context->new({ + INCLUDE_PATH => '/here:/there', + }); + + + + + +=item LOAD_PLUGINS + +The LOAD_PLUGINS options can be used to specify a list of provider +objects (i.e. they implement the fetch() method) which are responsible +for loading and instantiating template plugin objects. The +Template::Content plugin() method queries each provider in turn in a +"Chain of Responsibility" as per the template() and filter() methods. + + my $context = Template::Context->new({ + LOAD_PLUGINS => [ + MyOrg::Template::Plugins->new({ ... }), + Template::Plugins->new({ ... }), + ], + }); + +By default, a single Template::Plugins object is created using the +current configuration hash. Configuration items destined for the +Template::Plugins constructor may be added to the Template::Context +constructor. + + my $context = Template::Context->new({ + PLUGIN_BASE => 'MyOrg::Template::Plugins', + LOAD_PERL => 1, + }); + + + + + +=item LOAD_FILTERS + +The LOAD_FILTERS option can be used to specify a list of provider +objects (i.e. they implement the fetch() method) which are responsible +for returning and/or creating filter subroutines. The +Template::Context filter() method queries each provider in turn in a +"Chain of Responsibility" as per the template() and plugin() methods. + + my $context = Template::Context->new({ + LOAD_FILTERS => [ + MyTemplate::Filters->new(), + Template::Filters->new(), + ], + }); + +By default, a single Template::Filters object is created for the +LOAD_FILTERS list. + + + +=item STASH + +A reference to a Template::Stash object or sub-class which will take +responsibility for managing template variables. + + my $stash = MyOrg::Template::Stash->new({ ... }); + my $context = Template::Context->new({ + STASH => $stash, + }); + +If unspecified, a default stash object is created using the VARIABLES +configuration item to initialise the stash variables. These may also +be specified as the PRE_DEFINE option for backwards compatibility with +version 1. + + my $context = Template::Context->new({ + VARIABLES => { + id => 'abw', + name => 'Andy Wardley', + }, + }; + + + +=item DEBUG + +The DEBUG option can be used to enable various debugging features +of the Template::Context module. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_CONTEXT | DEBUG_DIRS, + }); + +The DEBUG value can include any of the following. Multiple values +should be combined using the logical OR operator, '|'. + +=over 4 + +=item DEBUG_CONTEXT + +Enables general debugging messages for the +L<Template::Context|Template::Context> module. + +=item DEBUG_DIRS + +This option causes the Template Toolkit to generate comments +indicating the source file, line and original text of each directive +in the template. These comments are embedded in the template output +using the format defined in the DEBUG_FORMAT configuration item, or a +simple default format if unspecified. + +For example, the following template fragment: + + + Hello World + +would generate this output: + + ## input text line 1 : ## + Hello + ## input text line 2 : World ## + World + + +=back + + + + + +=back + +=head2 template($name) + +Returns a compiled template by querying each of the LOAD_TEMPLATES providers +(instances of Template::Provider, or sub-class) in turn. + + $template = $context->template('header'); + +On error, a Template::Exception object of type 'file' is thrown via +die(). This can be caught by enclosing the call to template() in an +eval block and examining $@. + + eval { + $template = $context->template('header'); + }; + if ($@) { + print "failed to fetch template: $@\n"; + } + +=head2 plugin($name, \@args) + +Instantiates a plugin object by querying each of the LOAD_PLUGINS +providers. The default LOAD_PLUGINS provider is a Template::Plugins +object which attempts to load plugin modules, according the various +configuration items such as PLUGIN_BASE, LOAD_PERL, etc., and then +instantiate an object via new(). A reference to a list of constructor +arguments may be passed as the second parameter. These are forwarded +to the plugin constructor. + +Returns a reference to a plugin (which is generally an object, but +doesn't have to be). Errors are thrown as Template::Exception objects +of type 'plugin'. + + $plugin = $context->plugin('DBI', 'dbi:msql:mydbname'); + +=head2 filter($name, \@args, $alias) + +Instantiates a filter subroutine by querying the LOAD_FILTERS providers. +The default LOAD_FILTERS providers is a Template::Filters object. +Additional arguments may be passed by list reference along with an +optional alias under which the filter will be cached for subsequent +use. The filter is cached under its own $name if $alias is undefined. +Subsequent calls to filter($name) will return the cached entry, if +defined. Specifying arguments bypasses the caching mechanism and +always creates a new filter. Errors are thrown as Template::Exception +objects of typre 'filter'. + + # static filter (no args) + $filter = $context->filter('html'); + + # dynamic filter (args) aliased to 'padright' + $filter = $context->filter('format', '%60s', 'padright'); + + # retrieve previous filter via 'padright' alias + $filter = $context->filter('padright'); + +=head2 process($template, \%vars) + +Processes a template named or referenced by the first parameter and returns +the output generated. An optional reference to a hash array may be passed +as the second parameter, containing variable definitions which will be set +before the template is processed. The template is processed in the current +context, with no localisation of variables performed. Errors are thrown +as Template::Exception objects via die(). + + $output = $context->process('header', { title => 'Hello World' }); + +=head2 include($template, \%vars) + +Similar to process() above, but using localised variables. Changes made to +any variables will only persist until the include() method completes. + + $output = $context->include('header', { title => 'Hello World' }); + +=head2 throw($error_type, $error_message, \$output) + +Raises an exception in the form of a Template::Exception object by +calling die(). This method may be passed a reference to an existing +Template::Exception object; a single value containing an error message +which is used to instantiate a Template::Exception of type 'undef'; or +a pair of values representing the exception type and info from which a +Template::Exception object is instantiated. e.g. + + $context->throw($exception); + $context->throw("I'm sorry Dave, I can't do that"); + $context->throw('denied', "I'm sorry Dave, I can't do that"); + +The optional third parameter may be a reference to the current output +buffer. This is then stored in the exception object when created, +allowing the catcher to examine and use the output up to the point at +which the exception was raised. + + $output .= 'blah blah blah'; + $output .= 'more rhubarb'; + $context->throw('yack', 'Too much yacking', \$output); + +=head2 catch($exception, \$output) + +Catches an exception thrown, either as a reference to a +Template::Exception object or some other value. In the latter case, +the error string is promoted to a Template::Exception object of +'undef' type. This method also accepts a reference to the current +output buffer which is passed to the Template::Exception constructor, +or is appended to the output buffer stored in an existing +Template::Exception object, if unique (i.e. not the same reference). +By this process, the correct state of the output buffer can be +reconstructed for simple or nested throws. + +=head2 define_block($name, $block) + +Adds a new block definition to the internal BLOCKS cache. The first +argument should contain the name of the block and the second a reference +to a Template::Document object or template sub-routine, or template text +which is automatically compiled into a template sub-routine. Returns +a true value (the sub-routine or Template::Document reference) on +success or undef on failure. The relevant error message can be +retrieved by calling the error() method. + +=head2 define_filter($name, \&filter, $is_dynamic) + +Adds a new filter definition by calling the store() method on each of +the LOAD_FILTERS providers until accepted (in the usual case, this is +accepted straight away by the one and only Template::Filters +provider). The first argument should contain the name of the filter +and the second a reference to a filter subroutine. The optional +third argument can be set to any true value to indicate that the +subroutine is a dynamic filter factory. Returns a true value or +throws a 'filter' exception on error. + +=head2 localise(\%vars) + +Clones the stash to create a context with localised variables. Returns a +reference to the newly cloned stash object which is also stored +internally. + + $stash = $context->localise(); + +=head2 delocalise() + +Restore the stash to its state prior to localisation. + + $stash = $context->delocalise(); + +=head2 visit(\%blocks) + +This method is called by Template::Document objects immediately before +they process their content. It is called to register any local BLOCK +definitions with the context object so that they may be subsequently +delivered on request. + +=head2 leave() + +Compliment to visit(), above. Called by Template::Document objects +immediately after they process their content. + +=head2 reset() + +Clears the local BLOCKS cache of any BLOCK definitions. Any initial set of +BLOCKS specified as a configuration item to the constructor will be reinstated. + +=head2 AUTOLOAD + +An AUTOLOAD method provides access to context configuration items. + + $stash = $context->stash(); + $tflag = $context->trim(); + $epflag = $context->eval_perl(); + ... + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.81, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Document|Template::Document>, L<Template::Exception|Template::Exception>, L<Template::Filters|Template::Filters>, L<Template::Plugins|Template::Plugins>, L<Template::Provider|Template::Provider>, L<Template::Service|Template::Service>, L<Template::Stash|Template::Stash> diff --git a/lib/Template/Directive.pm b/lib/Template/Directive.pm new file mode 100644 index 0000000..67982d3 --- /dev/null +++ b/lib/Template/Directive.pm @@ -0,0 +1,1004 @@ +#================================================================= -*-Perl-*- +# +# Template::Directive +# +# DESCRIPTION +# Factory module for constructing templates from Perl code. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# WARNING +# Much of this module is hairy, even furry in places. It needs +# a lot of tidying up and may even be moved into a different place +# altogether. The generator code is often inefficient, particulary in +# being very anal about pretty-printing the Perl code all neatly, but +# at the moment, that's still high priority for the sake of easier +# debugging. +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Directive.pm,v 2.17 2002/08/08 11:59:15 abw Exp $ +# +#============================================================================ + +package Template::Directive; + +require 5.004; + +use strict; +use Template::Base; +use Template::Constants; +use Template::Exception; + +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG $PRETTY $WHILE_MAX ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.17 $ =~ /(\d+)\.(\d+)/); + +$WHILE_MAX = 1000 unless defined $WHILE_MAX; +$PRETTY = 0 unless defined $PRETTY; +my $OUTPUT = '$output .= '; + + +sub _init { + my ($self, $config) = @_; + $self->{ NAMESPACE } = $config->{ NAMESPACE }; + return $self; +} + + +sub pad { + my ($text, $pad) = @_; + $pad = ' ' x ($pad * 4); + $text =~ s/^(?!#line)/$pad/gm; + $text; +} + +#======================================================================== +# FACTORY METHODS +# +# These methods are called by the parser to construct directive instances. +#======================================================================== + +#------------------------------------------------------------------------ +# template($block) +#------------------------------------------------------------------------ + +sub template { + my ($class, $block) = @_; + $block = pad($block, 2) if $PRETTY; + + return "sub { return '' }" unless $block =~ /\S/; + + return <<EOF; +sub { + my \$context = shift || die "template sub called without context\\n"; + my \$stash = \$context->stash; + my \$output = ''; + my \$error; + + eval { BLOCK: { +$block + } }; + if (\$@) { + \$error = \$context->catch(\$@, \\\$output); + die \$error unless \$error->type eq 'return'; + } + + return \$output; +} +EOF +} + + +#------------------------------------------------------------------------ +# anon_block($block) [% BLOCK %] ... [% END %] +#------------------------------------------------------------------------ + +sub anon_block { + my ($class, $block) = @_; + $block = pad($block, 2) if $PRETTY; + + return <<EOF; + +# BLOCK +$OUTPUT do { + my \$output = ''; + my \$error; + + eval { BLOCK: { +$block + } }; + if (\$@) { + \$error = \$context->catch(\$@, \\\$output); + die \$error unless \$error->type eq 'return'; + } + + \$output; +}; +EOF +} + + +#------------------------------------------------------------------------ +# block($blocktext) +#------------------------------------------------------------------------ + +sub block { + my ($class, $block) = @_; + return join("\n", @{ $block || [] }); +} + + +#------------------------------------------------------------------------ +# textblock($text) +#------------------------------------------------------------------------ + +sub textblock { + my ($class, $text) = @_; + return "$OUTPUT " . &text($class, $text) . ';'; +} + + +#------------------------------------------------------------------------ +# text($text) +#------------------------------------------------------------------------ + +sub text { + my ($class, $text) = @_; + for ($text) { + s/(["\$\@\\])/\\$1/g; + s/\n/\\n/g; + } + return '"' . $text . '"'; +} + + +#------------------------------------------------------------------------ +# quoted(\@items) "foo$bar" +#------------------------------------------------------------------------ + +sub quoted { + my ($class, $items) = @_; + return '' unless @$items; + return ("('' . " . $items->[0] . ')') if scalar @$items == 1; + return '(' . join(' . ', @$items) . ')'; +# my $r = '(' . join(' . ', @$items) . ' . "")'; +# print STDERR "[$r]\n"; +# return $r; +} + + +#------------------------------------------------------------------------ +# ident(\@ident) foo.bar(baz) +#------------------------------------------------------------------------ + +sub ident { + my ($class, $ident) = @_; + return "''" unless @$ident; + my $ns; + + # does the first element of the identifier have a NAMESPACE + # handler defined? + if (ref $class && @$ident > 2 && ($ns = $class->{ NAMESPACE })) { + my $key = $ident->[0]; + $key =~ s/^'(.+)'$/$1/s; + if ($ns = $ns->{ $key }) { + return $ns->ident($ident); + } + } + + if (scalar @$ident <= 2 && ! $ident->[1]) { + $ident = $ident->[0]; + } + else { + $ident = '[' . join(', ', @$ident) . ']'; + } + return "\$stash->get($ident)"; +} + +#------------------------------------------------------------------------ +# identref(\@ident) \foo.bar(baz) +#------------------------------------------------------------------------ + +sub identref { + my ($class, $ident) = @_; + return "''" unless @$ident; + if (scalar @$ident <= 2 && ! $ident->[1]) { + $ident = $ident->[0]; + } + else { + $ident = '[' . join(', ', @$ident) . ']'; + } + return "\$stash->getref($ident)"; +} + + +#------------------------------------------------------------------------ +# assign(\@ident, $value, $default) foo = bar +#------------------------------------------------------------------------ + +sub assign { + my ($class, $var, $val, $default) = @_; + + if (ref $var) { + if (scalar @$var == 2 && ! $var->[1]) { + $var = $var->[0]; + } + else { + $var = '[' . join(', ', @$var) . ']'; + } + } + $val .= ', 1' if $default; + return "\$stash->set($var, $val)"; +} + + +#------------------------------------------------------------------------ +# args(\@args) foo, bar, baz = qux +#------------------------------------------------------------------------ + +sub args { + my ($class, $args) = @_; + my $hash = shift @$args; + push(@$args, '{ ' . join(', ', @$hash) . ' }') + if @$hash; + + return '0' unless @$args; + return '[ ' . join(', ', @$args) . ' ]'; +} + +#------------------------------------------------------------------------ +# filenames(\@names) +#------------------------------------------------------------------------ + +sub filenames { + my ($class, $names) = @_; + if (@$names > 1) { + $names = '[ ' . join(', ', @$names) . ' ]'; + } + else { + $names = shift @$names; + } + return $names; +} + + +#------------------------------------------------------------------------ +# get($expr) [% foo %] +#------------------------------------------------------------------------ + +sub get { + my ($class, $expr) = @_; + return "$OUTPUT $expr;"; +} + + +#------------------------------------------------------------------------ +# call($expr) [% CALL bar %] +#------------------------------------------------------------------------ + +sub call { + my ($class, $expr) = @_; + $expr .= ';'; + return $expr; +} + + +#------------------------------------------------------------------------ +# set(\@setlist) [% foo = bar, baz = qux %] +#------------------------------------------------------------------------ + +sub set { + my ($class, $setlist) = @_; + my $output; + while (my ($var, $val) = splice(@$setlist, 0, 2)) { + $output .= &assign($class, $var, $val) . ";\n"; + } + chomp $output; + return $output; +} + + +#------------------------------------------------------------------------ +# default(\@setlist) [% DEFAULT foo = bar, baz = qux %] +#------------------------------------------------------------------------ + +sub default { + my ($class, $setlist) = @_; + my $output; + while (my ($var, $val) = splice(@$setlist, 0, 2)) { + $output .= &assign($class, $var, $val, 1) . ";\n"; + } + chomp $output; + return $output; +} + + +#------------------------------------------------------------------------ +# insert(\@nameargs) [% INSERT file %] +# # => [ [ $file, ... ], \@args ] +#------------------------------------------------------------------------ + +sub insert { + my ($class, $nameargs) = @_; + my ($file, $args) = @$nameargs; + $file = $class->filenames($file); + return "$OUTPUT \$context->insert($file);"; +} + + +#------------------------------------------------------------------------ +# include(\@nameargs) [% INCLUDE template foo = bar %] +# # => [ [ $file, ... ], \@args ] +#------------------------------------------------------------------------ + +sub include { + my ($class, $nameargs) = @_; + my ($file, $args) = @$nameargs; + my $hash = shift @$args; + $file = $class->filenames($file); + $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + return "$OUTPUT \$context->include($file);"; +} + + +#------------------------------------------------------------------------ +# process(\@nameargs) [% PROCESS template foo = bar %] +# # => [ [ $file, ... ], \@args ] +#------------------------------------------------------------------------ + +sub process { + my ($class, $nameargs) = @_; + my ($file, $args) = @$nameargs; + my $hash = shift @$args; + $file = $class->filenames($file); + $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + return "$OUTPUT \$context->process($file);"; +} + + +#------------------------------------------------------------------------ +# if($expr, $block, $else) [% IF foo < bar %] +# ... +# [% ELSE %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub if { + my ($class, $expr, $block, $else) = @_; + my @else = $else ? @$else : (); + $else = pop @else; + $block = pad($block, 1) if $PRETTY; + + my $output = "if ($expr) {\n$block\n}\n"; + + foreach my $elsif (@else) { + ($expr, $block) = @$elsif; + $block = pad($block, 1) if $PRETTY; + $output .= "elsif ($expr) {\n$block\n}\n"; + } + if (defined $else) { + $else = pad($else, 1) if $PRETTY; + $output .= "else {\n$else\n}\n"; + } + + return $output; +} + + +#------------------------------------------------------------------------ +# foreach($target, $list, $args, $block) [% FOREACH x = [ foo bar ] %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub foreach { + my ($class, $target, $list, $args, $block) = @_; + $args = shift @$args; + $args = @$args ? ', { ' . join(', ', @$args) . ' }' : ''; + + my ($loop_save, $loop_set, $loop_restore, $setiter); + if ($target) { + $loop_save = 'eval { $oldloop = ' . &ident($class, ["'loop'"]) . ' }'; + $loop_set = "\$stash->{'$target'} = \$value"; + $loop_restore = "\$stash->set('loop', \$oldloop)"; + } + else { + $loop_save = '$stash = $context->localise()'; +# $loop_set = "\$stash->set('import', \$value) " +# . "if ref \$value eq 'HASH'"; + $loop_set = "\$stash->get(['import', [\$value]]) " + . "if ref \$value eq 'HASH'"; + $loop_restore = '$stash = $context->delocalise()'; + } + $block = pad($block, 3) if $PRETTY; + + return <<EOF; + +# FOREACH +do { + my (\$value, \$error, \$oldloop); + my \$list = $list; + + unless (UNIVERSAL::isa(\$list, 'Template::Iterator')) { + \$list = Template::Config->iterator(\$list) + || die \$Template::Config::ERROR, "\\n"; + } + + (\$value, \$error) = \$list->get_first(); + $loop_save; + \$stash->set('loop', \$list); + eval { +LOOP: while (! \$error) { + $loop_set; +$block; + (\$value, \$error) = \$list->get_next(); + } + }; + $loop_restore; + die \$@ if \$@; + \$error = 0 if \$error && \$error eq Template::Constants::STATUS_DONE; + die \$error if \$error; +}; +EOF +} + +#------------------------------------------------------------------------ +# next() [% NEXT %] +# +# Next iteration of a FOREACH loop (experimental) +#------------------------------------------------------------------------ + +sub next { + return <<EOF; +(\$value, \$error) = \$list->get_next(); +next LOOP; +EOF +} + + +#------------------------------------------------------------------------ +# wrapper(\@nameargs, $block) [% WRAPPER template foo = bar %] +# # => [ [$file,...], \@args ] +#------------------------------------------------------------------------ + +sub wrapper { + my ($class, $nameargs, $block) = @_; + my ($file, $args) = @$nameargs; + my $hash = shift @$args; + + local $" = ', '; +# print STDERR "wrapper([@$file], { @$hash })\n"; + + return $class->multi_wrapper($file, $hash, $block) + if @$file > 1; + $file = shift @$file; + + $block = pad($block, 1) if $PRETTY; + push(@$hash, "'content'", '$output'); + $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + + return <<EOF; + +# WRAPPER +$OUTPUT do { + my \$output = ''; +$block + \$context->include($file); +}; +EOF +} + + +sub multi_wrapper { + my ($class, $file, $hash, $block) = @_; + $block = pad($block, 1) if $PRETTY; + + push(@$hash, "'content'", '$output'); + $hash = @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + + $file = join(', ', reverse @$file); +# print STDERR "multi wrapper: $file\n"; + + return <<EOF; + +# WRAPPER +$OUTPUT do { + my \$output = ''; +$block + foreach ($file) { + \$output = \$context->include(\$_$hash); + } + \$output; +}; +EOF +} + + +#------------------------------------------------------------------------ +# while($expr, $block) [% WHILE x < 10 %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub while { + my ($class, $expr, $block) = @_; + $block = pad($block, 2) if $PRETTY; + + return <<EOF; + +# WHILE +do { + my \$failsafe = $WHILE_MAX; +LOOP: + while (--\$failsafe && ($expr)) { +$block + } + die "WHILE loop terminated (> $WHILE_MAX iterations)\\n" + unless \$failsafe; +}; +EOF +} + + +#------------------------------------------------------------------------ +# switch($expr, \@case) [% SWITCH %] +# [% CASE foo %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub switch { + my ($class, $expr, $case) = @_; + my @case = @$case; + my ($match, $block, $default); + my $caseblock = ''; + + $default = pop @case; + + foreach $case (@case) { + $match = $case->[0]; + $block = $case->[1]; + $block = pad($block, 1) if $PRETTY; + $caseblock .= <<EOF; +\$match = $match; +\$match = [ \$match ] unless ref \$match eq 'ARRAY'; +if (grep(/^\$result\$/, \@\$match)) { +$block + last SWITCH; +} +EOF + } + + $caseblock .= $default + if defined $default; + $caseblock = pad($caseblock, 2) if $PRETTY; + +return <<EOF; + +# SWITCH +do { + my \$result = $expr; + my \$match; + SWITCH: { +$caseblock + } +}; +EOF +} + + +#------------------------------------------------------------------------ +# try($block, \@catch) [% TRY %] +# ... +# [% CATCH %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub try { + my ($class, $block, $catch) = @_; + my @catch = @$catch; + my ($match, $mblock, $default, $final, $n); + my $catchblock = ''; + my $handlers = []; + + $block = pad($block, 2) if $PRETTY; + $final = pop @catch; + $final = "# FINAL\n" . ($final ? "$final\n" : '') + . 'die $error if $error;' . "\n" . '$output;'; + $final = pad($final, 1) if $PRETTY; + + $n = 0; + foreach $catch (@catch) { + $match = $catch->[0] || do { + $default ||= $catch->[1]; + next; + }; + $mblock = $catch->[1]; + $mblock = pad($mblock, 1) if $PRETTY; + push(@$handlers, "'$match'"); + $catchblock .= $n++ + ? "elsif (\$handler eq '$match') {\n$mblock\n}\n" + : "if (\$handler eq '$match') {\n$mblock\n}\n"; + } + $catchblock .= "\$error = 0;"; + $catchblock = pad($catchblock, 3) if $PRETTY; + if ($default) { + $default = pad($default, 1) if $PRETTY; + $default = "else {\n # DEFAULT\n$default\n \$error = '';\n}"; + } + else { + $default = '# NO DEFAULT'; + } + $default = pad($default, 2) if $PRETTY; + + $handlers = join(', ', @$handlers); +return <<EOF; + +# TRY +$OUTPUT do { + my \$output = ''; + my (\$error, \$handler); + eval { +$block + }; + if (\$@) { + \$error = \$context->catch(\$@, \\\$output); + die \$error if \$error->type =~ /^return|stop\$/; + \$stash->set('error', \$error); + \$stash->set('e', \$error); + if (defined (\$handler = \$error->select_handler($handlers))) { +$catchblock + } +$default + } +$final +}; +EOF +} + + +#------------------------------------------------------------------------ +# throw(\@nameargs) [% THROW foo "bar error" %] +# # => [ [$type], \@args ] +#------------------------------------------------------------------------ + +sub throw { + my ($class, $nameargs) = @_; + my ($type, $args) = @$nameargs; + my $hash = shift(@$args); + my $info = shift(@$args); + $type = shift @$type; # uses same parser production as INCLUDE + # etc., which allow multiple names + # e.g. INCLUDE foo+bar+baz + + if (! $info) { + $args = "$type, undef"; + } + elsif (@$hash || @$args) { + local $" = ', '; + my $i = 0; + $args = "$type, { args => [ " + . join(', ', $info, @$args) + . ' ], ' + . join(', ', + (map { "'" . $i++ . "' => $_" } ($info, @$args)), + @$hash) + . ' }'; + } + else { + $args = "$type, $info"; + } + + return "\$context->throw($args, \\\$output);"; +} + + +#------------------------------------------------------------------------ +# clear() [% CLEAR %] +# +# NOTE: this is redundant, being hard-coded (for now) into Parser.yp +#------------------------------------------------------------------------ + +sub clear { + return "\$output = '';"; +} + +#------------------------------------------------------------------------ +# break() [% BREAK %] +# +# NOTE: this is redundant, being hard-coded (for now) into Parser.yp +#------------------------------------------------------------------------ + +sub break { + return 'last LOOP;'; +} + +#------------------------------------------------------------------------ +# return() [% RETURN %] +#------------------------------------------------------------------------ + +sub return { + return "\$context->throw('return', '', \\\$output);"; +} + +#------------------------------------------------------------------------ +# stop() [% STOP %] +#------------------------------------------------------------------------ + +sub stop { + return "\$context->throw('stop', '', \\\$output);"; +} + + +#------------------------------------------------------------------------ +# use(\@lnameargs) [% USE alias = plugin(args) %] +# # => [ [$file, ...], \@args, $alias ] +#------------------------------------------------------------------------ + +sub use { + my ($class, $lnameargs) = @_; + my ($file, $args, $alias) = @$lnameargs; + $file = shift @$file; # same production rule as INCLUDE + $alias ||= $file; + $args = &args($class, $args); + $file .= ", $args" if $args; +# my $set = &assign($class, $alias, '$plugin'); + return "# USE\n" + . "\$stash->set($alias,\n" + . " \$context->plugin($file));"; +} + +#------------------------------------------------------------------------ +# view(\@nameargs, $block) [% VIEW name args %] +# # => [ [$file, ... ], \@args ] +#------------------------------------------------------------------------ + +sub view { + my ($class, $nameargs, $block, $defblocks) = @_; + my ($name, $args) = @$nameargs; + my $hash = shift @$args; + $name = shift @$name; # same production rule as INCLUDE + $block = pad($block, 1) if $PRETTY; + + if (%$defblocks) { + $defblocks = join(",\n", map { "'$_' => $defblocks->{ $_ }" } + keys %$defblocks); + $defblocks = pad($defblocks, 1) if $PRETTY; + $defblocks = "{\n$defblocks\n}"; + push(@$hash, "'blocks'", $defblocks); + } + $hash = @$hash ? '{ ' . join(', ', @$hash) . ' }' : ''; + + return <<EOF; +# VIEW +do { + my \$output = ''; + my \$oldv = \$stash->get('view'); + my \$view = \$context->view($hash); + \$stash->set($name, \$view); + \$stash->set('view', \$view); + +$block + + \$stash->set('view', \$oldv); + \$view->seal(); + \$output; +}; +EOF +} + + +#------------------------------------------------------------------------ +# perl($block) +#------------------------------------------------------------------------ + +sub perl { + my ($class, $block) = @_; + $block = pad($block, 1) if $PRETTY; + + return <<EOF; + +# PERL +\$context->throw('perl', 'EVAL_PERL not set') + unless \$context->eval_perl(); + +$OUTPUT do { + my \$output = "package Template::Perl;\\n"; + +$block + + local(\$Template::Perl::context) = \$context; + local(\$Template::Perl::stash) = \$stash; + + my \$result = ''; + tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$result; + my \$save_stdout = select *Template::Perl::PERLOUT; + + eval \$output; + select \$save_stdout; + \$context->throw(\$@) if \$@; + \$result; +}; +EOF +} + + +#------------------------------------------------------------------------ +# no_perl() +#------------------------------------------------------------------------ + +sub no_perl { + my $class = shift; + return "\$context->throw('perl', 'EVAL_PERL not set');"; +} + + +#------------------------------------------------------------------------ +# rawperl($block) +# +# NOTE: perhaps test context EVAL_PERL switch at compile time rather than +# runtime? +#------------------------------------------------------------------------ + +sub rawperl { + my ($class, $block, $line) = @_; + for ($block) { + s/^\n+//; + s/\n+$//; + } + $block = pad($block, 1) if $PRETTY; + $line = $line ? " (starting line $line)" : ''; + + return <<EOF; +# RAWPERL +#line 1 "RAWPERL block$line" +$block +EOF +} + + + +#------------------------------------------------------------------------ +# filter() +#------------------------------------------------------------------------ + +sub filter { + my ($class, $lnameargs, $block) = @_; + my ($name, $args, $alias) = @$lnameargs; + $name = shift @$name; + $args = &args($class, $args); + $args = $args ? "$args, $alias" : ", undef, $alias" + if $alias; + $name .= ", $args" if $args; + $block = pad($block, 1) if $PRETTY; + + return <<EOF; + +# FILTER +$OUTPUT do { + my \$output = ''; + my \$filter = \$context->filter($name) + || \$context->throw(\$context->error); + +$block + + &\$filter(\$output); +}; +EOF +} + + +#------------------------------------------------------------------------ +# capture($name, $block) +#------------------------------------------------------------------------ + +sub capture { + my ($class, $name, $block) = @_; + + if (ref $name) { + if (scalar @$name == 2 && ! $name->[1]) { + $name = $name->[0]; + } + else { + $name = '[' . join(', ', @$name) . ']'; + } + } + $block = pad($block, 1) if $PRETTY; + + return <<EOF; + +# CAPTURE +\$stash->set($name, do { + my \$output = ''; +$block + \$output; +}); +EOF + +} + + +#------------------------------------------------------------------------ +# macro($name, $block, \@args) +#------------------------------------------------------------------------ + +sub macro { + my ($class, $ident, $block, $args) = @_; + $block = pad($block, 2) if $PRETTY; + + if ($args) { + my $nargs = scalar @$args; + $args = join(', ', map { "'$_'" } @$args); + $args = $nargs > 1 + ? "\@args{ $args } = splice(\@_, 0, $nargs)" + : "\$args{ $args } = shift"; + + return <<EOF; + +# MACRO +\$stash->set('$ident', sub { + my \$output = ''; + my (%args, \$params); + $args; + \$params = shift; + \$params = { } unless ref(\$params) eq 'HASH'; + \$params = { \%args, %\$params }; + + my \$stash = \$context->localise(\$params); + eval { +$block + }; + \$stash = \$context->delocalise(); + die \$@ if \$@; + return \$output; +}); +EOF + + } + else { + return <<EOF; + +# MACRO +\$stash->set('$ident', sub { + my \$params = \$_[0] if ref(\$_[0]) eq 'HASH'; + my \$output = ''; + + my \$stash = \$context->localise(\$params); + eval { +$block + }; + \$stash = \$context->delocalise(); + die \$@ if \$@; + return \$output; +}); +EOF + } +} + + +sub debug { + my ($class, $nameargs) = @_; + my ($file, $args) = @$nameargs; + my $hash = shift @$args; + $args = join(', ', @$file, @$args); + $args .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + return "$OUTPUT \$context->debugging($args); ## DEBUG ##"; +} + + +1; + +__END__ + diff --git a/lib/Template/Document.pm b/lib/Template/Document.pm new file mode 100644 index 0000000..9e01548 --- /dev/null +++ b/lib/Template/Document.pm @@ -0,0 +1,482 @@ +##============================================================= -*-Perl-*- +# +# Template::Document +# +# DESCRIPTION +# Module defining a class of objects which encapsulate compiled +# templates, storing additional block definitions and metadata +# as well as the compiled Perl sub-routine representing the main +# template content. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Document.pm,v 2.65 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Document; + +require 5.004; + +use strict; +use vars qw( $VERSION $ERROR $COMPERR $DEBUG $AUTOLOAD ); +use base qw( Template::Base ); +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.65 $ =~ /(\d+)\.(\d+)/); + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%document) +# +# Creates a new self-contained Template::Document object which +# encapsulates a compiled Perl sub-routine, $block, any additional +# BLOCKs defined within the document ($defblocks, also Perl sub-routines) +# and additional $metadata about the document. +#------------------------------------------------------------------------ + +sub new { + my ($class, $doc) = @_; + my ($block, $defblocks, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS METADATA ) }; + $defblocks ||= { }; + $metadata ||= { }; + + # evaluate Perl code in $block to create sub-routine reference if necessary + unless (ref $block) { + local $SIG{__WARN__} = \&catch_warnings; + $COMPERR = ''; + + # DON'T LOOK NOW! - blindly untainting can make you go blind! + $block =~ /(.*)/s; + $block = $1; + + $block = eval $block; +# $COMPERR .= "[$@]" if $@; +# return $class->error($COMPERR) + return $class->error($@) + unless defined $block; + } + + # same for any additional BLOCK definitions + @$defblocks{ keys %$defblocks } = + # MORE BLIND UNTAINTING - turn away if you're squeamish + map { + ref($_) + ? $_ + : ( /(.*)/s && eval($1) or return $class->error($@) ) + } values %$defblocks; + + bless { + %$metadata, + _BLOCK => $block, + _DEFBLOCKS => $defblocks, + _HOT => 0, + }, $class; +} + + +#------------------------------------------------------------------------ +# block() +# +# Returns a reference to the internal sub-routine reference, _BLOCK, +# that constitutes the main document template. +#------------------------------------------------------------------------ + +sub block { + return $_[0]->{ _BLOCK }; +} + + +#------------------------------------------------------------------------ +# blocks() +# +# Returns a reference to a hash array containing any BLOCK definitions +# from the template. The hash keys are the BLOCK nameand the values +# are references to Template::Document objects. Returns 0 (# an empty hash) +# if no blocks are defined. +#------------------------------------------------------------------------ + +sub blocks { + return $_[0]->{ _DEFBLOCKS }; +} + + +#------------------------------------------------------------------------ +# process($context) +# +# Process the document in a particular context. Checks for recursion, +# registers the document with the context via visit(), processes itself, +# and then unwinds with a large gin and tonic. +#------------------------------------------------------------------------ + +sub process { + my ($self, $context) = @_; + my $defblocks = $self->{ _DEFBLOCKS }; + my $output; + + + # check we're not already visiting this template + return $context->throw(Template::Constants::ERROR_FILE, + "recursion into '$self->{ name }'") + if $self->{ _HOT } && ! $context->{ RECURSION }; ## RETURN ## + + $context->visit($defblocks); + $self->{ _HOT } = 1; + eval { + my $block = $self->{ _BLOCK }; + $output = &$block($context); + }; + $self->{ _HOT } = 0; + $context->leave(); + + die $context->catch($@) + if $@; + + return $output; +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# Provides pseudo-methods for read-only access to various internal +# members. +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; +# my ($pkg, $file, $line) = caller(); +# print STDERR "called $self->AUTOLOAD($method) from $file line $line\n"; + return $self->{ $method }; +} + + +#======================================================================== +# ----- PRIVATE METHODS ----- +#======================================================================== + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $dblks; + my $output = "$self : $self->{ name }\n"; + + $output .= "BLOCK: $self->{ _BLOCK }\nDEFBLOCKS:\n"; + + if ($dblks = $self->{ _DEFBLOCKS }) { + foreach my $b (keys %$dblks) { + $output .= " $b: $dblks->{ $b }\n"; + } + } + + return $output; +} + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# as_perl($content) +# +# This method expects a reference to a hash passed as the first argument +# containing 3 items: +# METADATA # a hash of template metadata +# BLOCK # string containing Perl sub definition for main block +# DEFBLOCKS # hash containing further subs for addional BLOCK defs +# It returns a string containing Perl code which, when evaluated and +# executed, will instantiate a new Template::Document object with the +# above data. On error, it returns undef with an appropriate error +# message set in $ERROR. +#------------------------------------------------------------------------ + +sub as_perl { + my ($class, $content) = @_; + my ($block, $defblocks, $metadata) = @$content{ qw( BLOCK DEFBLOCKS METADATA ) }; + + $block =~ s/\n/\n /g; + $block =~ s/\s+$//; + + $defblocks = join('', map { + my $code = $defblocks->{ $_ }; + $code =~ s/\n/\n /g; + $code =~ s/\s*$//; + " '$_' => $code,\n"; + } keys %$defblocks); + $defblocks =~ s/\s+$//; + + $metadata = join('', map { + my $x = $metadata->{ $_ }; + $x =~ s/(['\\])/\\$1/g; + " '$_' => '$x',\n"; + } keys %$metadata); + $metadata =~ s/\s+$//; + + return <<EOF +#------------------------------------------------------------------------ +# Compiled template generated by the Template Toolkit version $Template::VERSION +#------------------------------------------------------------------------ + +$class->new({ + METADATA => { +$metadata + }, + BLOCK => $block, + DEFBLOCKS => { +$defblocks + }, +}); +EOF +} + + +#------------------------------------------------------------------------ +# write_perl_file($filename, \%content) +# +# This method calls as_perl() to generate the Perl code to represent a +# compiled template with the content passed as the second argument. +# It then writes this to the file denoted by the first argument. +# +# Returns 1 on success. On error, sets the $ERROR package variable +# to contain an error message and returns undef. +#------------------------------------------------------------------------ + +sub write_perl_file { + my ($class, $file, $content) = @_; + my ($fh, $tmpfile); + + return $class->error("invalid filename: $file") + unless $file =~ /^(.+)$/s; + + eval { + require File::Temp; + require File::Basename; + ($fh, $tmpfile) = File::Temp::tempfile( + DIR => File::Basename::dirname($file) + ); + print $fh $class->as_perl($content) || die $!; + close($fh); + }; + return $class->error($@) if $@; + return rename($tmpfile, $file) + || $class->error($!); +} + + +#------------------------------------------------------------------------ +# catch_warnings($msg) +# +# Installed as +#------------------------------------------------------------------------ + +sub catch_warnings { + $COMPERR .= join('', @_); +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Document - Compiled template document object + +=head1 SYNOPSIS + + use Template::Document; + + $doc = Template::Document->new({ + BLOCK => sub { # some perl code; return $some_text }, + DEFBLOCKS => { + header => sub { # more perl code; return $some_text }, + footer => sub { # blah blah blah; return $some_text }, + }, + METADATA => { + author => 'Andy Wardley', + version => 3.14, + } + }) || die $Template::Document::ERROR; + + print $doc->process($context); + +=head1 DESCRIPTION + +This module defines an object class whose instances represent compiled +template documents. The Template::Parser module creates a +Template::Document instance to encapsulate a template as it is compiled +into Perl code. + +The constructor method, new(), expects a reference to a hash array +containing the BLOCK, DEFBLOCKS and METADATA items. The BLOCK item +should contain a reference to a Perl subroutine or a textual +representation of Perl code, as generated by the Template::Parser +module, which is then evaluated into a subroutine reference using +eval(). The DEFLOCKS item should reference a hash array containing +further named BLOCKs which may be defined in the template. The keys +represent BLOCK names and the values should be subroutine references +or text strings of Perl code as per the main BLOCK item. The METADATA +item should reference a hash array of metadata items relevant to the +document. + +The process() method can then be called on the instantiated +Template::Document object, passing a reference to a Template::Content +object as the first parameter. This will install any locally defined +blocks (DEFBLOCKS) in the the contexts() BLOCKS cache (via a call to +visit()) so that they may be subsequently resolved by the context. The +main BLOCK subroutine is then executed, passing the context reference +on as a parameter. The text returned from the template subroutine is +then returned by the process() method, after calling the context leave() +method to permit cleanup and de-registration of named BLOCKS previously +installed. + +An AUTOLOAD method provides access to the METADATA items for the document. +The Template::Service module installs a reference to the main +Template::Document object in the stash as the 'template' variable. +This allows metadata items to be accessed from within templates, +including PRE_PROCESS templates. + +header: + + <html> + <head> + <title>[% template.title %] + </head> + ... + +Template::Document objects are usually created by the Template::Parser +but can be manually instantiated or sub-classed to provide custom +template components. + +=head1 METHODS + +=head2 new(\%config) + +Constructor method which accept a reference to a hash array containing the +structure as shown in this example: + + $doc = Template::Document->new({ + BLOCK => sub { # some perl code; return $some_text }, + DEFBLOCKS => { + header => sub { # more perl code; return $some_text }, + footer => sub { # blah blah blah; return $some_text }, + }, + METADATA => { + author => 'Andy Wardley', + version => 3.14, + } + }) || die $Template::Document::ERROR; + +BLOCK and DEFBLOCKS items may be expressed as references to Perl subroutines +or as text strings containing Perl subroutine definitions, as is generated +by the Template::Parser module. These are evaluated into subroutine references +using eval(). + +Returns a new Template::Document object or undef on error. The error() class +method can be called, or the $ERROR package variable inspected to retrieve +the relevant error message. + +=head2 process($context) + +Main processing routine for the compiled template document. A reference to +a Template::Context object should be passed as the first parameter. The +method installs any locally defined blocks via a call to the context +visit() method, processes it's own template, passing the context reference +by parameter and then calls leave() in the context to allow cleanup. + + print $doc->process($context); + +Returns a text string representing the generated output for the template. +Errors are thrown via die(). + +=head2 block() + +Returns a reference to the main BLOCK subroutine. + +=head2 blocks() + +Returns a reference to the hash array of named DEFBLOCKS subroutines. + +=head2 AUTOLOAD + +An autoload method returns METADATA items. + + print $doc->author(); + +=head1 PACKAGE SUB-ROUTINES + +=head2 write_perl_file(\%config) + +This package subroutine is provided to effect persistance of compiled +templates. If the COMPILE_EXT option (to indicate a file extension +for saving compiled templates) then the Template::Parser module calls +this subroutine before calling the new() constructor. At this stage, +the parser has a representation of the template as text strings +containing Perl code. We can write that to a file, enclosed in a +small wrapper which will allow us to susequently require() the file +and have Perl parse and compile it into a Template::Document. Thus we +have persistance of compiled templates. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.65, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Parser|Template::Parser> diff --git a/lib/Template/Exception.pm b/lib/Template/Exception.pm new file mode 100644 index 0000000..cf60cb3 --- /dev/null +++ b/lib/Template/Exception.pm @@ -0,0 +1,244 @@ +#============================================================= -*-Perl-*- +# +# Template::Exception +# +# DESCRIPTION +# Module implementing a generic exception class used for error handling +# in the Template Toolkit. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#------------------------------------------------------------------------ +# +# $Id: Exception.pm,v 2.59 2003/04/24 09:14:38 abw Exp $ +# +#======================================================================== + + +package Template::Exception; + +require 5.005; + +use strict; +use vars qw( $VERSION ); + +use constant TYPE => 0; +use constant INFO => 1; +use constant TEXT => 2; +use overload q|""| => "as_string", fallback => 1; + + +$VERSION = sprintf("%d.%02d", q$Revision: 2.59 $ =~ /(\d+)\.(\d+)/); + + +#------------------------------------------------------------------------ +# new($type, $info, \$text) +# +# Constructor method used to instantiate a new Template::Exception +# object. The first parameter should contain the exception type. This +# can be any arbitrary string of the caller's choice to represent a +# specific exception. The second parameter should contain any +# information (i.e. error message or data reference) relevant to the +# specific exception event. The third optional parameter may be a +# reference to a scalar containing output text from the template +# block up to the point where the exception was thrown. +#------------------------------------------------------------------------ + +sub new { + my ($class, $type, $info, $textref) = @_; + bless [ $type, $info, $textref ], $class; +} + + +#------------------------------------------------------------------------ +# type() +# info() +# type_info() +# +# Accessor methods to return the internal TYPE and INFO fields. +#------------------------------------------------------------------------ + +sub type { + $_[0]->[ TYPE ]; +} + +sub info { + $_[0]->[ INFO ]; +} + +sub type_info { + my $self = shift; + @$self[ TYPE, INFO ]; +} + +#------------------------------------------------------------------------ +# text() +# text(\$pretext) +# +# Method to return the text referenced by the TEXT member. A text +# reference may be passed as a parameter to supercede the existing +# member. The existing text is added to the *end* of the new text +# before being stored. This facility is provided for template blocks +# to gracefully de-nest when an exception occurs and allows them to +# reconstruct their output in the correct order. +#------------------------------------------------------------------------ + +sub text { + my ($self, $newtextref) = @_; + my $textref = $self->[ TEXT ]; + + if ($newtextref) { + $$newtextref .= $$textref if $textref && $textref ne $newtextref; + $self->[ TEXT ] = $newtextref; + return ''; + + } + elsif ($textref) { + return $$textref; + } + else { + return ''; + } +} + + +#------------------------------------------------------------------------ +# as_string() +# +# Accessor method to return a string indicating the exception type and +# information. +#------------------------------------------------------------------------ + +sub as_string { + my $self = shift; + return $self->[ TYPE ] . ' error - ' . $self->[ INFO ]; +} + + +#------------------------------------------------------------------------ +# select_handler(@types) +# +# Selects the most appropriate handler for the exception TYPE, from +# the list of types passed in as parameters. The method returns the +# item which is an exact match for TYPE or the closest, more +# generic handler (e.g. foo being more generic than foo.bar, etc.) +#------------------------------------------------------------------------ + +sub select_handler { + my ($self, @options) = @_; + my $type = $self->[ TYPE ]; + my %hlut; + @hlut{ @options } = (1) x @options; + + while ($type) { + return $type if $hlut{ $type }; + + # strip .element from the end of the exception type to find a + # more generic handler + $type =~ s/\.?[^\.]*$//; + } + return undef; +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Exception - Exception handling class module + +=head1 SYNOPSIS + + use Template::Exception; + + my $exception = Template::Exception->new($type, $info); + $type = $exception->type; + $info = $exception->info; + ($type, $info) = $exception->type_info; + + print $exception->as_string(); + + $handler = $exception->select_handler(\@candidates); + +=head1 DESCRIPTION + +The Template::Exception module defines an object class for +representing exceptions within the template processing life cycle. +Exceptions can be raised by modules within the Template Toolkit, or +can be generated and returned by user code bound to template +variables. + + +Exceptions can be raised in a template using the THROW directive, + + [% THROW user.login 'no user id: please login' %] + +or by calling the throw() method on the current Template::Context object, + + $context->throw('user.passwd', 'Incorrect Password'); + $context->throw('Incorrect Password'); # type 'undef' + +or from Perl code by calling die() with a Template::Exception object, + + die (Template::Exception->new('user.denied', 'Invalid User ID')); + +or by simply calling die() with an error string. This is +automagically caught and converted to an exception of 'undef' +type which can then be handled in the usual way. + + die "I'm sorry Dave, I can't do that"; + + + +Each exception is defined by its type and a information component +(e.g. error message). The type can be any identifying string and may +contain dotted components (e.g. 'foo', 'foo.bar', 'foo.bar.baz'). +Exception types are considered to be hierarchical such that 'foo.bar' +would be a specific type of the more general 'foo' type. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.59, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Context|Template::Context> diff --git a/lib/Template/Filters.pm b/lib/Template/Filters.pm new file mode 100644 index 0000000..8667c6a --- /dev/null +++ b/lib/Template/Filters.pm @@ -0,0 +1,1438 @@ +#============================================================= -*-Perl-*- +# +# Template::Filters +# +# DESCRIPTION +# Defines filter plugins as used by the FILTER directive. +# +# AUTHORS +# Andy Wardley <abw@kfs.org>, with a number of filters contributed +# by Leslie Michael Orchard <deus_x@nijacode.com> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Filters.pm,v 2.72 2003/07/01 12:43:55 darren Exp $ +# +#============================================================================ + +package Template::Filters; + +require 5.004; + +use strict; +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG $FILTERS $URI_ESCAPES $PLUGIN_FILTER ); +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.72 $ =~ /(\d+)\.(\d+)/); + + +#------------------------------------------------------------------------ +# standard filters, defined in one of the following forms: +# name => \&static_filter +# name => [ \&subref, $is_dynamic ] +# If the $is_dynamic flag is set then the sub-routine reference +# is called to create a new filter each time it is requested; if +# not set, then it is a single, static sub-routine which is returned +# for every filter request for that name. +#------------------------------------------------------------------------ + +$FILTERS = { + # static filters + 'html' => \&html_filter, + 'html_para' => \&html_paragraph, + 'html_break' => \&html_para_break, + 'html_para_break' => \&html_para_break, + 'html_line_break' => \&html_line_break, + 'uri' => \&uri_filter, + 'upper' => sub { uc $_[0] }, + 'lower' => sub { lc $_[0] }, + 'ucfirst' => sub { ucfirst $_[0] }, + 'lcfirst' => sub { lcfirst $_[0] }, + 'stderr' => sub { print STDERR @_; return '' }, + 'trim' => sub { for ($_[0]) { s/^\s+//; s/\s+$// }; $_[0] }, + 'null' => sub { return '' }, + 'collapse' => sub { for ($_[0]) { s/^\s+//; s/\s+$//; s/\s+/ /g }; + $_[0] }, + + # dynamic filters + 'html_entity' => [ \&html_entity_filter_factory, 1 ], + 'indent' => [ \&indent_filter_factory, 1 ], + 'format' => [ \&format_filter_factory, 1 ], + 'truncate' => [ \&truncate_filter_factory, 1 ], + 'repeat' => [ \&repeat_filter_factory, 1 ], + 'replace' => [ \&replace_filter_factory, 1 ], + 'remove' => [ \&remove_filter_factory, 1 ], + 'eval' => [ \&eval_filter_factory, 1 ], + 'evaltt' => [ \&eval_filter_factory, 1 ], # alias + 'perl' => [ \&perl_filter_factory, 1 ], + 'evalperl' => [ \&perl_filter_factory, 1 ], # alias + 'redirect' => [ \&redirect_filter_factory, 1 ], + 'file' => [ \&redirect_filter_factory, 1 ], # alias + 'stdout' => [ \&stdout_filter_factory, 1 ], + 'latex' => [ \&latex_filter_factory, 1 ], +}; + +# name of module implementing plugin filters +$PLUGIN_FILTER = 'Template::Plugin::Filter'; + + +#======================================================================== +# -- PUBLIC METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# fetch($name, \@args, $context) +# +# Attempts to instantiate or return a reference to a filter sub-routine +# named by the first parameter, $name, with additional constructor +# arguments passed by reference to a list as the second parameter, +# $args. A reference to the calling Template::Context object is +# passed as the third paramter. +# +# Returns a reference to a filter sub-routine or a pair of values +# (undef, STATUS_DECLINED) or ($error, STATUS_ERROR) to decline to +# deliver the filter or to indicate an error. +#------------------------------------------------------------------------ + +sub fetch { + my ($self, $name, $args, $context) = @_; + my ($factory, $is_dynamic, $filter, $error); + + $self->debug("fetch($name, ", + defined $args ? ('[ ', join(', ', @$args), ' ]') : '<no args>', ', ', + defined $context ? $context : '<no context>', + ')') if $self->{ DEBUG }; + + # allow $name to be specified as a reference to + # a plugin filter object; any other ref is + # assumed to be a coderef and hence already a filter; + # non-refs are assumed to be regular name lookups + + if (ref $name) { + if (UNIVERSAL::isa($name, $PLUGIN_FILTER)) { + $factory = $name->factory() + || return $self->error($name->error()); + } + else { + return $name; + } + } + else { + return (undef, Template::Constants::STATUS_DECLINED) + unless ($factory = $self->{ FILTERS }->{ $name } + || $FILTERS->{ $name }); + } + + # factory can be an [ $code, $dynamic ] or just $code + if (ref $factory eq 'ARRAY') { + ($factory, $is_dynamic) = @$factory; + } + else { + $is_dynamic = 0; + } + + if (ref $factory eq 'CODE') { + if ($is_dynamic) { + # if the dynamic flag is set then the sub-routine is a + # factory which should be called to create the actual + # filter... + eval { + ($filter, $error) = &$factory($context, $args ? @$args : ()); + }; + $error ||= $@; + $error = "invalid FILTER for '$name' (not a CODE ref)" + unless $error || ref($filter) eq 'CODE'; + } + else { + # ...otherwise, it's a static filter sub-routine + $filter = $factory; + } + } + else { + $error = "invalid FILTER entry for '$name' (not a CODE ref)"; + } + + if ($error) { + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR) ; + } + else { + return $filter; + } +} + + +#------------------------------------------------------------------------ +# store($name, \&filter) +# +# Stores a new filter in the internal FILTERS hash. The first parameter +# is the filter name, the second a reference to a subroutine or +# array, as per the standard $FILTERS entries. +#------------------------------------------------------------------------ + +sub store { + my ($self, $name, $filter) = @_; + + $self->debug("store($name, $filter)") if $self->{ DEBUG }; + + $self->{ FILTERS }->{ $name } = $filter; + return 1; +} + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init(\%config) +# +# Private initialisation method. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $params) = @_; + + $self->{ FILTERS } = $params->{ FILTERS } || { }; + $self->{ TOLERANT } = $params->{ TOLERANT } || 0; + $self->{ DEBUG } = ( $params->{ DEBUG } || 0 ) + & Template::Constants::DEBUG_FILTERS; + + + return $self; +} + + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $output = "[Template::Filters] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + foreach $key (qw( TOLERANT )) { + my $val = $self->{ $key }; + $val = '<undef>' unless defined $val; + $output .= sprintf($format, $key, $val); + } + + my $filters = $self->{ FILTERS }; + $filters = join('', map { + sprintf(" $format", $_, $filters->{ $_ }); + } keys %$filters); + $filters = "{\n$filters }"; + + $output .= sprintf($format, 'FILTERS (local)' => $filters); + + $filters = $FILTERS; + $filters = join('', map { + my $f = $filters->{ $_ }; + my ($ref, $dynamic) = ref $f eq 'ARRAY' ? @$f : ($f, 0); + sprintf(" $format", $_, $dynamic ? 'dynamic' : 'static'); + } sort keys %$filters); + $filters = "{\n$filters }"; + + $output .= sprintf($format, 'FILTERS (global)' => $filters); + + $output .= '}'; + return $output; +} + + +#======================================================================== +# -- STATIC FILTER SUBS -- +#======================================================================== + +#------------------------------------------------------------------------ +# uri_filter() [% FILTER uri %] +# +# URI escape a string. This code is borrowed from Gisle Aas' URI::Escape +# module. For something so simple, I can't see any validation in making +# the user install the URI modules just for this, so we cut and paste. +# +# URI::Escape is Copyright 1995-2000 Gisle Aas. +#------------------------------------------------------------------------ + +sub uri_filter { + my $text = shift; + + # construct and cache a lookup table for escapes (faster than + # doing a sprintf() for every character in every string each + # time) + $URI_ESCAPES ||= { + map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255), + }; + + $text =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*'()])/$URI_ESCAPES->{$1}/g; + $text; +} + + +#------------------------------------------------------------------------ +# html_filter() [% FILTER html %] +# +# Convert any '<', '>' or '&' characters to the HTML equivalents, '<', +# '>' and '&', respectively. +#------------------------------------------------------------------------ + +sub html_filter { + my $text = shift; + for ($text) { + s/&/&/g; + s/</</g; + s/>/>/g; + s/"/"/g; + } + return $text; +} + + +#------------------------------------------------------------------------ +# html_paragraph() [% FILTER html_para %] +# +# Wrap each paragraph of text (delimited by two or more newlines) in the +# <p>...</p> HTML tags. +#------------------------------------------------------------------------ + +sub html_paragraph { + my $text = shift; + return "<p>\n" + . join("\n</p>\n\n<p>\n", split(/(?:\r?\n){2,}/, $text)) + . "</p>\n"; +} + + +#------------------------------------------------------------------------ +# html_para_break() [% FILTER html_para_break %] +# +# Join each paragraph of text (delimited by two or more newlines) with +# <br><br> HTML tags. +#------------------------------------------------------------------------ + +sub html_para_break { + my $text = shift; + $text =~ s|(\r?\n){2,}|$1<br />$1<br />$1|g; + return $text; +} + +#------------------------------------------------------------------------ +# html_line_break() [% FILTER html_line_break %] +# +# replaces any newlines with <br> HTML tags. +#------------------------------------------------------------------------ + +sub html_line_break { + my $text = shift; + $text =~ s|(\r?\n)|<br />$1|g; + return $text; +} + +#======================================================================== +# -- DYNAMIC FILTER FACTORIES -- +#======================================================================== + +#------------------------------------------------------------------------ +# html_entity_filter_factory(\%options) [% FILTER html %] +# +# Dynamic version of the static html filter which attempts to locate the +# Apache::Util or HTML::Entities modules to perform full entity encoding +# of the text passed. Returns an exception if one or other of the +# modules can't be located. +#------------------------------------------------------------------------ + +sub html_entity_filter_factory { + my $context = shift; + + # if Apache::Util is installed then we use it + eval { + require Apache::Util; + Apache::Util::escape_html(''); + }; + return \&Apache::Util::escape_html + unless $@; + + # otherwise if HTML::Entities is installed then we use that + eval { + require HTML::Entities; + }; + return \&HTML::Entities::encode_entities + unless $@; + + return (undef, Template::Exception->new( html_entity => + 'cannot locate Apache::Util or HTML::Entities' )); + +} + + +#------------------------------------------------------------------------ +# indent_filter_factory($pad) [% FILTER indent(pad) %] +# +# Create a filter to indent text by a fixed pad string or when $pad is +# numerical, a number of space. +#------------------------------------------------------------------------ + +sub indent_filter_factory { + my ($context, $pad) = @_; + $pad = 4 unless defined $pad; + $pad = ' ' x $pad if $pad =~ /^\d+$/; + + return sub { + my $text = shift; + $text = '' unless defined $text; + $text =~ s/^/$pad/mg; + return $text; + } +} + +#------------------------------------------------------------------------ +# format_filter_factory() [% FILTER format(format) %] +# +# Create a filter to format text according to a printf()-like format +# string. +#------------------------------------------------------------------------ + +sub format_filter_factory { + my ($context, $format) = @_; + $format = '%s' unless defined $format; + + return sub { + my $text = shift; + $text = '' unless defined $text; + return join("\n", map{ sprintf($format, $_) } split(/\n/, $text)); + } +} + + +#------------------------------------------------------------------------ +# repeat_filter_factory($n) [% FILTER repeat(n) %] +# +# Create a filter to repeat text n times. +#------------------------------------------------------------------------ + +sub repeat_filter_factory { + my ($context, $iter) = @_; + $iter = 1 unless defined $iter and length $iter; + + return sub { + my $text = shift; + $text = '' unless defined $text; + return join('\n', $text) x $iter; + } +} + + +#------------------------------------------------------------------------ +# replace_filter_factory($s, $r) [% FILTER replace(search, replace) %] +# +# Create a filter to replace 'search' text with 'replace' +#------------------------------------------------------------------------ + +sub replace_filter_factory { + my ($context, $search, $replace) = @_; + $search = '' unless defined $search; + $replace = '' unless defined $replace; + + return sub { + my $text = shift; + $text = '' unless defined $text; + $text =~ s/$search/$replace/g; + return $text; + } +} + + +#------------------------------------------------------------------------ +# remove_filter_factory($text) [% FILTER remove(text) %] +# +# Create a filter to remove 'search' string from the input text. +#------------------------------------------------------------------------ + +sub remove_filter_factory { + my ($context, $search) = @_; + + return sub { + my $text = shift; + $text = '' unless defined $text; + $text =~ s/$search//g; + return $text; + } +} + + +#------------------------------------------------------------------------ +# truncate_filter_factory($n) [% FILTER truncate(n) %] +# +# Create a filter to truncate text after n characters. +#------------------------------------------------------------------------ + +sub truncate_filter_factory { + my ($context, $len) = @_; + $len = 32 unless defined $len; + + return sub { + my $text = shift; + return $text if length $text < $len; + return substr($text, 0, $len - 3) . "..."; + } +} + + +#------------------------------------------------------------------------ +# eval_filter_factory [% FILTER eval %] +# +# Create a filter to evaluate template text. +#------------------------------------------------------------------------ + +sub eval_filter_factory { + my $context = shift; + + return sub { + my $text = shift; + $context->process(\$text); + } +} + + +#------------------------------------------------------------------------ +# perl_filter_factory [% FILTER perl %] +# +# Create a filter to process Perl text iff the context EVAL_PERL flag +# is set. +#------------------------------------------------------------------------ + +sub perl_filter_factory { + my $context = shift; + my $stash = $context->stash; + + return (undef, Template::Exception->new('perl', 'EVAL_PERL is not set')) + unless $context->eval_perl(); + + return sub { + my $text = shift; + local($Template::Perl::context) = $context; + local($Template::Perl::stash) = $stash; + my $out = eval <<EOF; +package Template::Perl; +\$stash = \$context->stash(); +$text +EOF + $context->throw($@) if $@; + return $out; + } +} + + +#------------------------------------------------------------------------ +# redirect_filter_factory($context, $file) [% FILTER redirect(file) %] +# +# Create a filter to redirect the block text to a file. +#------------------------------------------------------------------------ + +sub redirect_filter_factory { + my ($context, $file, $options) = @_; + my $outpath = $context->config->{ OUTPUT_PATH }; + + return (undef, Template::Exception->new('redirect', + 'OUTPUT_PATH is not set')) + unless $outpath; + + $options = { binmode => $options } unless ref $options; + + sub { + my $text = shift; + my $outpath = $context->config->{ OUTPUT_PATH } + || return ''; + $outpath .= "/$file"; + my $error = Template::_output($outpath, \$text, $options); + die Template::Exception->new('redirect', $error) + if $error; + return ''; + } +} + + +#------------------------------------------------------------------------ +# stdout_filter_factory($context, $binmode) [% FILTER stdout(binmode) %] +# +# Create a filter to print a block to stdout, with an optional binmode. +#------------------------------------------------------------------------ + +sub stdout_filter_factory { + my ($context, $options) = @_; + + $options = { binmode => $options } unless ref $options; + + sub { + my $text = shift; + binmode(STDOUT) if $options->{ binmode }; + print STDOUT $text; + return ''; + } +} + + +#------------------------------------------------------------------------ +# latex_filter_factory($context, $outputType) [% FILTER latex(outputType) %] +# +# Return a filter sub that converts a (hopefully) complete LaTeX source +# file to either "ps", "dvi", or "pdf". Output type should be "ps", "dvi" +# or "pdf" (pdf is default). +# +# Creates a temporary directory below File::Spec->tmpdir() (often /tmp) +# and writes the text into doc.tex. It then runs either pdflatex or +# latex and optionally dvips. Based on the exit status either returns +# the entire doc.(pdf|ps|dvi) output or throws an error with a summary +# of the error messages from doc.log. +# +# Written by Craig Barratt, Apr 28 2001. +# Win32 additions by Richard Tietjen. +#------------------------------------------------------------------------ +use File::Path; +use File::Spec; +use Cwd; + +sub latex_filter_factory +{ + my($context, $output) = @_; + + $output = lc($output); + my $fName = "latex"; + my($LaTeXPath, $PdfLaTeXPath, $DviPSPath) + = @{Template::Config->latexpaths()}; + if ( $output eq "ps" || $output eq "dvi" ) { + $context->throw($fName, + "latex not installed (see Template::Config::LATEX_PATH)") + if ( $LaTeXPath eq "" ); + } else { + $output = "pdf"; + $LaTeXPath = $PdfLaTeXPath; + $context->throw($fName, + "pdflatex not installed (see Template::Config::PDFLATEX_PATH)") + if ( $LaTeXPath eq "" ); + } + if ( $output eq "ps" && $DviPSPath eq "" ) { + $context->throw($fName, + "dvips not installed (see Template::Config::DVIPS_PATH)"); + } + if ( $^O !~ /^(MacOS|os2|VMS)$/i ) { + return sub { + local(*FH); + my $text = shift; + my $tmpRootDir = File::Spec->tmpdir(); + my $cnt = 0; + my($tmpDir, $fileName, $devnull); + my $texDoc = 'doc'; + + do { + $tmpDir = File::Spec->catdir($tmpRootDir, + "tt2latex$$" . "_$cnt"); + $cnt++; + } while ( -e $tmpDir ); + mkpath($tmpDir, 0, 0700); + $context->throw($fName, "can't create temp dir $tmpDir") + if ( !-d $tmpDir ); + $fileName = File::Spec->catfile($tmpDir, "$texDoc.tex"); + $devnull = File::Spec->devnull(); + if ( !open(FH, ">$fileName") ) { + rmtree($tmpDir); + $context->throw($fName, "can't open $fileName for output"); + } + print(FH $text); + close(FH); + + # latex must run in tmpDir directory + my $currDir = cwd(); + if ( !chdir($tmpDir) ) { + rmtree($tmpDir); + $context->throw($fName, "can't chdir $tmpDir"); + } + # + # We don't need to quote the backslashes on windows, but we + # do on other OSs + # + my $LaTeX_arg = "\\nonstopmode\\input{$texDoc}"; + $LaTeX_arg = "'$LaTeX_arg'" if ( $^O ne 'MSWin32' ); + if ( system("$LaTeXPath $LaTeX_arg" + . " 1>$devnull 2>$devnull 0<$devnull") ) { + my $texErrs = ""; + $fileName = File::Spec->catfile($tmpDir, "$texDoc.log"); + if ( open(FH, "<$fileName") ) { + my $state = 0; + # + # Try to extract just the interesting errors from + # the verbose log file + # + while ( <FH> ) { + # + # TeX errors seems to start with a "!" at the + # start of the line, and are followed several + # lines later by a line designator of the + # form "l.nnn" where nnn is the line number. + # We make sure we pick up every /^!/ line, and + # the first /^l.\d/ line after each /^!/ line. + # + if ( /^(!.*)/ ) { + $texErrs .= $1 . "\n"; + $state = 1; + } + if ( $state == 1 && /^(l\.\d.*)/ ) { + $texErrs .= $1 . "\n"; + $state = 0; + } + } + close(FH); + } else { + $texErrs = "Unable to open $fileName\n"; + } + my $ok = chdir($currDir); + rmtree($tmpDir); + $context->throw($fName, "can't chdir $currDir") if ( !$ok ); + $context->throw($fName, "latex exited with errors:\n$texErrs"); + } + if ( $output eq "ps" ) { + $fileName = File::Spec->catfile($tmpDir, "$texDoc.dvi"); + if ( system("$DviPSPath $texDoc -o" + . " 1>$devnull 2>$devnull 0<$devnull") ) { + my $ok = chdir($currDir); + rmtree($tmpDir); + $context->throw($fName, "can't chdir $currDir") if ( !$ok ); + $context->throw($fName, "can't run $DviPSPath $fileName"); + } + } + if ( !chdir($currDir) ) { + rmtree($tmpDir); + $context->throw($fName, "can't chdir $currDir"); + } + + my $retStr; + $fileName = File::Spec->catfile($tmpDir, "$texDoc.$output"); + if ( open(FH, $fileName) ) { + local $/ = undef; # slurp file in one go + binmode(FH); + $retStr = <FH>; + close(FH); + } else { + rmtree($tmpDir); + $context->throw($fName, "Can't open output file $fileName"); + } + rmtree($tmpDir); + return $retStr; + } + } else { + $context->throw("$fName not yet supported on $^O OS." + . " Please contribute code!!"); + } +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Filters - Post-processing filters for template blocks + +=head1 SYNOPSIS + + use Template::Filters; + + $filters = Template::Filters->new(\%config); + + ($filter, $error) = $filters->fetch($name, \@args, $context); + +=head1 DESCRIPTION + +The Template::Filters module implements a provider for creating and/or +returning subroutines that implement the standard filters. Additional +custom filters may be provided via the FILTERS options. + +=head1 METHODS + +=head2 new(\%params) + +Constructor method which instantiates and returns a reference to a +Template::Filters object. A reference to a hash array of configuration +items may be passed as a parameter. These are described below. + + my $filters = Template::Filters->new({ + FILTERS => { ... }, + }); + + my $template = Template->new({ + LOAD_FILTERS => [ $filters ], + }); + +A default Template::Filters module is created by the Template.pm module +if the LOAD_FILTERS option isn't specified. All configuration parameters +are forwarded to the constructor. + + $template = Template->new({ + FILTERS => { ... }, + }); + +=head2 fetch($name, \@args, $context) + +Called to request that a filter of a given name be provided. The name +of the filter should be specified as the first parameter. This should +be one of the standard filters or one specified in the FILTERS +configuration hash. The second argument should be a reference to an +array containing configuration parameters for the filter. This may be +specified as 0, or undef where no parameters are provided. The third +argument should be a reference to the current Template::Context +object. + +The method returns a reference to a filter sub-routine on success. It +may also return (undef, STATUS_DECLINE) to decline the request, to allow +delegation onto other filter providers in the LOAD_FILTERS chain of +responsibility. On error, ($error, STATUS_ERROR) is returned where $error +is an error message or Template::Exception object indicating the error +that occurred. + +When the TOLERANT option is set, errors are automatically downgraded to +a STATUS_DECLINE response. + + +=head1 CONFIGURATION OPTIONS + +The following list details the configuration options that can be provided +to the Template::Filters new() constructor. + +=over 4 + + + + +=item FILTERS + +The FILTERS option can be used to specify custom filters which can +then be used with the FILTER directive like any other. These are +added to the standard filters which are available by default. Filters +specified via this option will mask any standard filters of the same +name. + +The FILTERS option should be specified as a reference to a hash array +in which each key represents the name of a filter. The corresponding +value should contain a reference to an array containing a subroutine +reference and a flag which indicates if the filter is static (0) or +dynamic (1). A filter may also be specified as a solitary subroutine +reference and is assumed to be static. + + $filters = Template::Filters->new({ + FILTERS => { + 'sfilt1' => \&static_filter, # static + 'sfilt2' => [ \&static_filter, 0 ], # same as above + 'dfilt1' => [ \&dyanamic_filter_factory, 1 ], + }, + }); + +Additional filters can be specified at any time by calling the +define_filter() method on the current Template::Context object. +The method accepts a filter name, a reference to a filter +subroutine and an optional flag to indicate if the filter is +dynamic. + + my $context = $template->context(); + $context->define_filter('new_html', \&new_html); + $context->define_filter('new_repeat', \&new_repeat, 1); + +Static filters are those where a single subroutine reference is used +for all invocations of a particular filter. Filters that don't accept +any configuration parameters (e.g. 'html') can be implemented +statically. The subroutine reference is simply returned when that +particular filter is requested. The subroutine is called to filter +the output of a template block which is passed as the only argument. +The subroutine should return the modified text. + + sub static_filter { + my $text = shift; + # do something to modify $text... + return $text; + } + +The following template fragment: + + [% FILTER sfilt1 %] + Blah blah blah. + [% END %] + +is approximately equivalent to: + + &static_filter("\nBlah blah blah.\n"); + +Filters that can accept parameters (e.g. 'truncate') should be +implemented dynamically. In this case, the subroutine is taken to be +a filter 'factory' that is called to create a unique filter subroutine +each time one is requested. A reference to the current +Template::Context object is passed as the first parameter, followed by +any additional parameters specified. The subroutine should return +another subroutine reference (usually a closure) which implements the +filter. + + sub dynamic_filter_factory { + my ($context, @args) = @_; + + return sub { + my $text = shift; + # do something to modify $text... + return $text; + } + } + +The following template fragment: + + [% FILTER dfilt1(123, 456) %] + Blah blah blah + [% END %] + +is approximately equivalent to: + + my $filter = &dynamic_filter_factory($context, 123, 456); + &$filter("\nBlah blah blah.\n"); + +See the FILTER directive for further examples. + + + + +=item TOLERANT + +The TOLERANT flag is used by the various Template Toolkit provider +modules (Template::Provider, Template::Plugins, Template::Filters) to +control their behaviour when errors are encountered. By default, any +errors are reported as such, with the request for the particular +resource (template, plugin, filter) being denied and an exception +raised. When the TOLERANT flag is set to any true values, errors will +be silently ignored and the provider will instead return +STATUS_DECLINED. This allows a subsequent provider to take +responsibility for providing the resource, rather than failing the +request outright. If all providers decline to service the request, +either through tolerated failure or a genuine disinclination to +comply, then a 'E<lt>resourceE<gt> not found' exception is raised. + + + + +=item DEBUG + +The DEBUG option can be used to enable debugging messages from the +Template::Filters module by setting it to include the DEBUG_FILTERS +value. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_FILTERS | DEBUG_PLUGINS, + }); + + + + +=back + +=head1 TEMPLATE TOOLKIT FILTERS + +The following standard filters are distributed with the Template Toolkit. + + + +=head2 format(format) + +The 'format' filter takes a format string as a parameter (as per +printf()) and formats each line of text accordingly. + + [% FILTER format('<!-- %-40s -->') %] + This is a block of text filtered + through the above format. + [% END %] + +output: + + <!-- This is a block of text filtered --> + <!-- through the above format. --> + +=head2 upper + +Folds the input to UPPER CASE. + + [% "hello world" FILTER upper %] + +output: + + HELLO WORLD + +=head2 lower + +Folds the input to lower case. + + [% "Hello World" FILTER lower %] + +output: + + hello world + +=head2 ucfirst + +Folds the first character of the input to UPPER CASE. + + [% "hello" FILTER ucfirst %] + +output: + + Hello + +=head2 lcfirst + +Folds the first character of the input to lower case. + + [% "HELLO" FILTER lcfirst %] + +output: + + hELLO + +=head2 trim + +Trims any leading or trailing whitespace from the input text. Particularly +useful in conjunction with INCLUDE, PROCESS, etc., having the same effect +as the TRIM configuration option. + + [% INCLUDE myfile | trim %] + +=head2 collapse + +Collapse any whitespace sequences in the input text into a single space. +Leading and trailing whitespace (which would be reduced to a single space) +is removed, as per trim. + + [% FILTER collapse %] + + The cat + + sat on + + the mat + + [% END %] + +output: + + The cat sat on the mat + +=head2 html + +Converts the characters 'E<lt>', 'E<gt>' and '&' to '<', '>' and +'&', respectively, protecting them from being interpreted as +representing HTML tags or entities. + + [% FILTER html %] + Binary "<=>" returns -1, 0, or 1 depending on... + [% END %] + +output: + + Binary "<=>" returns -1, 0, or 1 depending on... + +=head2 html_entity + +The html filter is fast and simple but it doesn't encode the full +range of HTML entities that your text may contain. The html_entity +filter uses either the Apache::Util module (which is written in C and +is therefore faster) or the HTML::Entities module (written in Perl but +equally as comprehensive) to perform the encoding. If one or other of +these modules are installed on your system then the text will be +encoded (via the escape_html() or encode_entities() subroutines +respectively) to convert all extended characters into their +appropriate HTML entities (e.g. converting 'é' to 'é'). If +neither module is available on your system then an 'html_entity' exception +will be thrown reporting an appropriate message. + +For further information on HTML entity encoding, see +http://www.w3.org/TR/REC-html40/sgml/entities.html. + +=head2 html_para + +This filter formats a block of text into HTML paragraphs. A sequence of +two or more newlines is used as the delimiter for paragraphs which are +then wrapped in HTML E<lt>pE<gt>...E<lt>/pE<gt> tags. + + [% FILTER html_para %] + The cat sat on the mat. + + Mary had a little lamb. + [% END %] + +output: + + <p> + The cat sat on the mat. + </p> + + <p> + Mary had a little lamb. + </p> + +=head2 html_break / html_para_break + +Similar to the html_para filter described above, but uses the HTML tag +sequence E<lt>brE<gt>E<lt>brE<gt> to join paragraphs. + + [% FILTER html_break %] + The cat sat on the mat. + + Mary had a little lamb. + [% END %] + +output: + + The cat sat on the mat. + <br> + <br> + Mary had a little lamb. + +=head2 html_line_break + +This filter replaces any newlines with E<lt>brE<gt> HTML tags, +thus preserving the line breaks of the original text in the +HTML output. + + [% FILTER html_line_break %] + The cat sat on the mat. + Mary had a little lamb. + [% END %] + +output: + + The cat sat on the mat.<br> + Mary had a little lamb.<br> + +=head2 uri + +This filter URI escapes the input text, converting any characters +outside of the permitted URI character set (as defined by RFC 2396) +into a C<%nn> hex escape. + + [% 'my file.html' | uri %] + +output: + + my%20file.html + +Note that URI escaping isn't always enough when generating hyperlinks in +an HTML document. The C<&> character, for example, is valid in a URI and +will not be escaped by the URI filter. In this case you should also filter +the text through the 'html' filter. + + <a href="[% filename | uri | html %]">click here</a> + +=head2 indent(pad) + +Indents the text block by a fixed pad string or width. The 'pad' argument +can be specified as a string, or as a numerical value to indicate a pad +width (spaces). Defaults to 4 spaces if unspecified. + + [% FILTER indent('ME> ') %] + blah blah blah + cabbages, rhubard, onions + [% END %] + +output: + + ME> blah blah blah + ME> cabbages, rhubard, onions + +=head2 truncate(length) + +Truncates the text block to the length specified, or a default length of +32. Truncated text will be terminated with '...' (i.e. the '...' falls +inside the required length, rather than appending to it). + + [% FILTER truncate(21) %] + I have much to say on this matter that has previously + been said on more than one occasion. + [% END %] + +output: + + I have much to say... + +=head2 repeat(iterations) + +Repeats the text block for as many iterations as are specified (default: 1). + + [% FILTER repeat(3) %] + We want more beer and we want more beer, + [% END %] + We are the more beer wanters! + +output: + + We want more beer and we want more beer, + We want more beer and we want more beer, + We want more beer and we want more beer, + We are the more beer wanters! + +=head2 remove(string) + +Searches the input text for any occurrences of the specified string and +removes them. A Perl regular expression may be specified as the search +string. + + [% "The cat sat on the mat" FILTER remove('\s+') %] + +output: + + Thecatsatonthemat + +=head2 replace(search, replace) + +Similar to the remove filter described above, but taking a second parameter +which is used as a replacement string for instances of the search string. + + [% "The cat sat on the mat" | replace('\s+', '_') %] + +output: + + The_cat_sat_on_the_mat + +=head2 redirect(file, options) + +The 'redirect' filter redirects the output of the block into a separate +file, specified relative to the OUTPUT_PATH configuration item. + + [% FOREACH user = myorg.userlist %] + [% FILTER redirect("users/${user.id}.html") %] + [% INCLUDE userinfo %] + [% END %] + [% END %] + +or more succinctly, using side-effect notation: + + [% INCLUDE userinfo + FILTER redirect("users/${user.id}.html") + FOREACH user = myorg.userlist + %] + +A 'file' exception will be thrown if the OUTPUT_PATH option is undefined. + +An optional 'binmode' argument can follow the filename to explicitly set +the output file to binary mode. + + [% PROCESS my/png/generator + FILTER redirect("images/logo.png", binmode=1) %] + +For backwards compatibility with earlier versions, a single true/false +value can be used to set binary mode. + + [% PROCESS my/png/generator + FILTER redirect("images/logo.png", 1) %] + +For the sake of future compatibility and clarity, if nothing else, we +would strongly recommend you explicitly use the named 'binmode' option +as shown in the first example. + +=head2 eval / evaltt + +The 'eval' filter evaluates the block as template text, processing +any directives embedded within it. This allows template variables to +contain template fragments, or for some method to be provided for +returning template fragments from an external source such as a +database, which can then be processed in the template as required. + + my $vars = { + fragment => "The cat sat on the [% place %]", + }; + $template->process($file, $vars); + +The following example: + + [% fragment | eval %] + +is therefore equivalent to + + The cat sat on the [% place %] + +The 'evaltt' filter is provided as an alias for 'eval'. + +=head2 perl / evalperl + +The 'perl' filter evaluates the block as Perl code. The EVAL_PERL +option must be set to a true value or a 'perl' exception will be +thrown. + + [% my_perl_code | perl %] + +In most cases, the [% PERL %] ... [% END %] block should suffice for +evaluating Perl code, given that template directives are processed +before being evaluate as Perl. Thus, the previous example could have +been written in the more verbose form: + + [% PERL %] + [% my_perl_code %] + [% END %] + +as well as + + [% FILTER perl %] + [% my_perl_code %] + [% END %] + +The 'evalperl' filter is provided as an alias for 'perl' for backwards +compatibility. + +=head2 stdout(options) + +The stdout filter prints the output generated by the enclosing block to +STDOUT. The 'binmode' option can be passed as either a named parameter +or a single argument to set STDOUT to binary mode (see the +binmode perl function). + + [% PROCESS something/cool + FILTER stdout(binmode=1) # recommended %] + + [% PROCESS something/cool + FILTER stdout(1) # alternate %] + +The stdout filter can be used to force binmode on STDOUT, or also inside +redirect, null or stderr blocks to make sure that particular output goes +to stdout. See the null filter below for an example. + +=head2 stderr + +The stderr filter prints the output generated by the enclosing block to +STDERR. + +=head2 null + +The null filter prints nothing. This is useful for plugins whose +methods return values that you don't want to appear in the output. +Rather than assigning every plugin method call to a dummy variable +to silence it, you can wrap the block in a null filter: + + [% FILTER null; + USE im = GD.Image(100,100); + black = im.colorAllocate(0, 0, 0); + red = im.colorAllocate(255,0, 0); + blue = im.colorAllocate(0, 0, 255); + im.arc(50,50,95,75,0,360,blue); + im.fill(50,50,red); + im.png | stdout(1); + END; + -%] + +Notice the use of the stdout filter to ensure that a particular expression +generates output to stdout (in this case in binary mode). + +=head2 latex(outputType) + +Passes the text block to LaTeX and produces either PDF, DVI or +PostScript output. The 'outputType' argument determines the output +format and it should be set to one of the strings: "pdf" (default), +"dvi", or "ps". + +The text block should be a complete LaTeX source file. + + [% FILTER latex("pdf") -%] + \documentclass{article} + + \begin{document} + + \title{A Sample TT2 \LaTeX\ Source File} + \author{Craig Barratt} + \maketitle + + \section{Introduction} + This is some text. + + \end{document} + [% END -%] + +The output will be a PDF file. You should be careful not to prepend or +append any extraneous characters or text outside the FILTER block, +since this text will wrap the (binary) output of the latex filter. +Notice the END directive uses '-%]' for the END_TAG to remove the +trailing new line. + +One example where you might prepend text is in a CGI script where +you might include the Content-Type before the latex output, eg: + + Content-Type: application/pdf + + [% FILTER latex("pdf") -%] + \documentclass{article} + \begin{document} + ... + \end{document} + [% END -%] + +In other cases you might use the redirect filter to put the output +into a file, rather than delivering it to stdout. This might be +suitable for batch scripts: + + [% output = FILTER latex("pdf") -%] + \documentclass{article} + \begin{document} + ... + \end{document} + [% END; output | redirect("document.pdf", 1) -%] + +(Notice the second argument to redirect to force binary mode.) + +Note that the latex filter runs one or two external programs, so it +isn't very fast. But for modest documents the performance is adequate, +even for interactive applications. + +A error of type 'latex' will be thrown if there is an error reported +by latex, pdflatex or dvips. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.72, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Context|Template::Context>, L<Template::Manual::Filters|Template::Manual::Filters> diff --git a/lib/Template/Grammar.pm b/lib/Template/Grammar.pm new file mode 100644 index 0000000..2e1a808 --- /dev/null +++ b/lib/Template/Grammar.pm @@ -0,0 +1,6174 @@ +#============================================================= -*-Perl-*- +# +# Template::Grammar +# +# DESCRIPTION +# Grammar file for the Template Toolkit language containing token +# definitions and parser state/rules tables generated by Parse::Yapp. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#------------------------------------------------------------------------ +# +# NOTE: this module is constructed from the parser/Grammar.pm.skel +# file by running the parser/yc script. You only need to do this if +# you have modified the grammar in the parser/Parser.yp file and need +# to-recompile it. See the README in the 'parser' directory for more +# information (sub-directory of the Template distribution). +# +#------------------------------------------------------------------------ +# +# $Id: Grammar.pm,v 2.19 2003/04/29 12:47:22 abw Exp $ +# +#======================================================================== + +package Template::Grammar; + +require 5.004; + +use strict; +use vars qw( $VERSION ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.19 $ =~ /(\d+)\.(\d+)/); + +my (@RESERVED, %CMPOP, $LEXTABLE, $RULES, $STATES); +my ($factory, $rawstart); + + +#======================================================================== + +# Reserved words, comparison and binary operators +#======================================================================== + +@RESERVED = qw( + GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER BLOCK END + USE PLUGIN FILTER MACRO PERL RAWPERL TO STEP AND OR NOT DIV MOD + IF UNLESS ELSE ELSIF FOR NEXT WHILE SWITCH CASE META IN + TRY THROW CATCH FINAL LAST RETURN STOP CLEAR VIEW DEBUG + ); + +# for historical reasons, != and == are converted to ne and eq to perform +# stringwise comparison (mainly because it doesn't generate "non-numerical +# comparison" warnings which != and == can) but the others (e.g. < > <= >=) +# are not converted to their stringwise equivalents. I added 'gt' et al, +# briefly for v2.04d and then took them out again in 2.04e. + +%CMPOP = qw( + != ne + == eq + < < + > > + >= >= + <= <= +); + + +#======================================================================== +# Lexer Token Table +#======================================================================== + +# lookup table used by lexer is initialised with special-cases +$LEXTABLE = { + 'FOREACH' => 'FOR', + 'BREAK' => 'LAST', + '&&' => 'AND', + '||' => 'OR', + '!' => 'NOT', + '|' => 'FILTER', + '.' => 'DOT', + '_' => 'CAT', + '..' => 'TO', +# ':' => 'MACRO', + '=' => 'ASSIGN', + '=>' => 'ASSIGN', +# '->' => 'ARROW', + ',' => 'COMMA', + '\\' => 'REF', + 'and' => 'AND', # explicitly specified so that qw( and or + 'or' => 'OR', # not ) can always be used in lower case, + 'not' => 'NOT', # regardless of ANYCASE flag + 'mod' => 'MOD', + 'div' => 'DIV', +}; + +# localise the temporary variables needed to complete lexer table +{ +# my @tokens = qw< ( ) [ ] { } ${ $ / ; : ? >; + my @tokens = qw< ( ) [ ] { } ${ $ + / ; : ? >; + my @cmpop = keys %CMPOP; +# my @binop = qw( + - * % ); # '/' above, in @tokens + my @binop = qw( - * % ); # '+' and '/' above, in @tokens + + # fill lexer table, slice by slice, with reserved words and operators + @$LEXTABLE{ @RESERVED, @cmpop, @binop, @tokens } + = ( @RESERVED, ('CMPOP') x @cmpop, ('BINOP') x @binop, @tokens ); +} + + +#======================================================================== +# CLASS METHODS +#======================================================================== + +sub new { + my $class = shift; + bless { + LEXTABLE => $LEXTABLE, + STATES => $STATES, + RULES => $RULES, + }, $class; +} + +# update method to set package-scoped $factory lexical +sub install_factory { + my ($self, $new_factory) = @_; + $factory = $new_factory; +} + + +#======================================================================== +# States +#======================================================================== + +$STATES = [ + {#State 0 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'template' => 52, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'switch' => 34, + 'try' => 35, + 'assign' => 19, + 'block' => 72, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 1 + ACTIONS => { + "\$" => 43, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'setlist' => 76, + 'item' => 39, + 'assign' => 19, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 2 + DEFAULT => -130 + }, + {#State 3 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 79, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 4 + DEFAULT => -23 + }, + {#State 5 + ACTIONS => { + ";" => 80 + } + }, + {#State 6 + DEFAULT => -37 + }, + {#State 7 + DEFAULT => -14 + }, + {#State 8 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 90, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 9 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "]" => 94, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 96, + 'item' => 39, + 'range' => 93, + 'node' => 23, + 'ident' => 77, + 'term' => 95, + 'list' => 92, + 'lterm' => 56 + } + }, + {#State 10 + ACTIONS => { + ";" => 97 + } + }, + {#State 11 + DEFAULT => -5 + }, + {#State 12 + ACTIONS => { + ";" => -20 + }, + DEFAULT => -27 + }, + {#State 13 + DEFAULT => -78, + GOTOS => { + '@5-1' => 98 + } + }, + {#State 14 + ACTIONS => { + 'IDENT' => 99 + }, + DEFAULT => -87, + GOTOS => { + 'blockargs' => 102, + 'metadata' => 101, + 'meta' => 100 + } + }, + {#State 15 + ACTIONS => { + 'IDENT' => 99 + }, + GOTOS => { + 'metadata' => 103, + 'meta' => 100 + } + }, + {#State 16 + ACTIONS => { + 'DOT' => 104, + 'ASSIGN' => 105 + }, + DEFAULT => -109 + }, + {#State 17 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 106, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 18 + ACTIONS => { + 'IDENT' => 107 + } + }, + {#State 19 + DEFAULT => -149 + }, + {#State 20 + DEFAULT => -12 + }, + {#State 21 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 108, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'loopvar' => 110, + 'node' => 23, + 'ident' => 77, + 'term' => 109, + 'lterm' => 56 + } + }, + {#State 22 + DEFAULT => -40 + }, + {#State 23 + DEFAULT => -127 + }, + {#State 24 + DEFAULT => -6 + }, + {#State 25 + ACTIONS => { + "\"" => 117, + "\$" => 114, + 'LITERAL' => 116, + 'FILENAME' => 83, + 'IDENT' => 111, + 'NUMBER' => 84, + "\${" => 37 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 118, + 'filename' => 85, + 'lvalue' => 112, + 'lnameargs' => 115, + 'item' => 113, + 'name' => 82 + } + }, + {#State 26 + DEFAULT => -113 + }, + {#State 27 + ACTIONS => { + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 119 + } + }, + {#State 28 + ACTIONS => { + 'LITERAL' => 124, + 'FILENAME' => 83, + 'IDENT' => 120, + 'NUMBER' => 84 + }, + DEFAULT => -87, + GOTOS => { + 'blockargs' => 123, + 'filepart' => 87, + 'filename' => 122, + 'blockname' => 121, + 'metadata' => 101, + 'meta' => 100 + } + }, + {#State 29 + DEFAULT => -43 + }, + {#State 30 + ACTIONS => { + "\$" => 43, + 'LITERAL' => 129, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -119, + GOTOS => { + 'params' => 128, + 'hash' => 125, + 'item' => 126, + 'param' => 127 + } + }, + {#State 31 + DEFAULT => -25 + }, + {#State 32 + ACTIONS => { + "\"" => 117, + "\$" => 114, + 'LITERAL' => 116, + 'FILENAME' => 83, + 'IDENT' => 111, + 'NUMBER' => 84, + "\${" => 37 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 118, + 'filename' => 85, + 'lvalue' => 112, + 'lnameargs' => 130, + 'item' => 113, + 'name' => 82 + } + }, + {#State 33 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -2, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 131, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 34 + DEFAULT => -22 + }, + {#State 35 + DEFAULT => -24 + }, + {#State 36 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 132, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 37 + ACTIONS => { + "\"" => 60, + "\$" => 43, + 'LITERAL' => 78, + 'IDENT' => 2, + 'REF' => 27, + 'NUMBER' => 26, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 133, + 'item' => 39, + 'node' => 23, + 'ident' => 77 + } + }, + {#State 38 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 134, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 39 + ACTIONS => { + "(" => 135 + }, + DEFAULT => -128 + }, + {#State 40 + ACTIONS => { + ";" => 136 + } + }, + {#State 41 + DEFAULT => -38 + }, + {#State 42 + DEFAULT => -11 + }, + {#State 43 + ACTIONS => { + 'IDENT' => 137 + } + }, + {#State 44 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 138, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 45 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 139, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 46 + DEFAULT => -42 + }, + {#State 47 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 140, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 48 + ACTIONS => { + 'IF' => 144, + 'FILTER' => 143, + 'FOR' => 142, + 'WHILE' => 146, + 'WRAPPER' => 145, + 'UNLESS' => 141 + } + }, + {#State 49 + DEFAULT => -39 + }, + {#State 50 + DEFAULT => -10 + }, + {#State 51 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 147, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 52 + ACTIONS => { + '' => 148 + } + }, + {#State 53 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 57, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 149, + 'term' => 58, + 'expr' => 151, + 'assign' => 150, + 'lterm' => 56 + } + }, + {#State 54 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 152, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 55 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 153, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 56 + DEFAULT => -103 + }, + {#State 57 + ACTIONS => { + 'ASSIGN' => 154 + }, + DEFAULT => -112 + }, + {#State 58 + DEFAULT => -146 + }, + {#State 59 + DEFAULT => -15 + }, + {#State 60 + DEFAULT => -176, + GOTOS => { + 'quoted' => 155 + } + }, + {#State 61 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 156, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 62 + ACTIONS => { + ";" => -16, + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -26 + }, + {#State 63 + DEFAULT => -13 + }, + {#State 64 + DEFAULT => -36 + }, + {#State 65 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 167, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 66 + DEFAULT => -9 + }, + {#State 67 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 168, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 68 + DEFAULT => -104 + }, + {#State 69 + ACTIONS => { + "\$" => 43, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'setlist' => 169, + 'item' => 39, + 'assign' => 19, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 70 + ACTIONS => { + "\$" => 43, + 'COMMA' => 171, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -19, + GOTOS => { + 'item' => 39, + 'assign' => 170, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 71 + DEFAULT => -8 + }, + {#State 72 + DEFAULT => -1 + }, + {#State 73 + DEFAULT => -21 + }, + {#State 74 + ACTIONS => { + 'ASSIGN' => 172, + 'DOT' => 104 + } + }, + {#State 75 + ACTIONS => { + 'ASSIGN' => 154 + } + }, + {#State 76 + ACTIONS => { + "\$" => 43, + 'COMMA' => 171, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -30, + GOTOS => { + 'item' => 39, + 'assign' => 170, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 77 + ACTIONS => { + 'DOT' => 104 + }, + DEFAULT => -109 + }, + {#State 78 + DEFAULT => -112 + }, + {#State 79 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 173, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 80 + DEFAULT => -7 + }, + {#State 81 + DEFAULT => -173 + }, + {#State 82 + DEFAULT => -166 + }, + {#State 83 + DEFAULT => -172 + }, + {#State 84 + DEFAULT => -174 + }, + {#State 85 + ACTIONS => { + 'DOT' => 174 + }, + DEFAULT => -168 + }, + {#State 86 + ACTIONS => { + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 175 + } + }, + {#State 87 + DEFAULT => -171 + }, + {#State 88 + DEFAULT => -169 + }, + {#State 89 + DEFAULT => -176, + GOTOS => { + 'quoted' => 176 + } + }, + {#State 90 + DEFAULT => -35 + }, + {#State 91 + ACTIONS => { + "+" => 177, + "(" => 178 + }, + DEFAULT => -156, + GOTOS => { + 'args' => 179 + } + }, + {#State 92 + ACTIONS => { + "{" => 30, + 'COMMA' => 182, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "]" => 180, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 181, + 'lterm' => 56 + } + }, + {#State 93 + ACTIONS => { + "]" => 183 + } + }, + {#State 94 + DEFAULT => -107 + }, + {#State 95 + DEFAULT => -116 + }, + {#State 96 + ACTIONS => { + 'TO' => 184 + }, + DEFAULT => -104 + }, + {#State 97 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 185, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 98 + ACTIONS => { + ";" => 186 + } + }, + {#State 99 + ACTIONS => { + 'ASSIGN' => 187 + } + }, + {#State 100 + DEFAULT => -99 + }, + {#State 101 + ACTIONS => { + 'COMMA' => 189, + 'IDENT' => 99 + }, + DEFAULT => -86, + GOTOS => { + 'meta' => 188 + } + }, + {#State 102 + ACTIONS => { + ";" => 190 + } + }, + {#State 103 + ACTIONS => { + 'COMMA' => 189, + 'IDENT' => 99 + }, + DEFAULT => -17, + GOTOS => { + 'meta' => 188 + } + }, + {#State 104 + ACTIONS => { + "\$" => 43, + 'IDENT' => 2, + 'NUMBER' => 192, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 191 + } + }, + {#State 105 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'WRAPPER' => 55, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + "\"" => 60, + 'PROCESS' => 61, + 'FILTER' => 25, + 'RETURN' => 64, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 193, + 'DEFAULT' => 69, + "{" => 30, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'term' => 58, + 'loop' => 4, + 'expr' => 195, + 'wrapper' => 46, + 'atomexpr' => 48, + 'atomdir' => 12, + 'mdir' => 194, + 'sterm' => 68, + 'filter' => 29, + 'ident' => 149, + 'perl' => 31, + 'setlist' => 70, + 'switch' => 34, + 'try' => 35, + 'assign' => 19, + 'directive' => 196, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 106 + DEFAULT => -33 + }, + {#State 107 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'INCLUDE' => 17, + "(" => 198, + 'SWITCH' => 54, + 'WRAPPER' => 55, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + "\"" => 60, + 'PROCESS' => 61, + 'FILTER' => 25, + 'RETURN' => 64, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 193, + 'DEFAULT' => 69, + "{" => 30, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'term' => 58, + 'loop' => 4, + 'expr' => 199, + 'wrapper' => 46, + 'atomexpr' => 48, + 'atomdir' => 12, + 'mdir' => 197, + 'sterm' => 68, + 'filter' => 29, + 'ident' => 149, + 'perl' => 31, + 'setlist' => 70, + 'switch' => 34, + 'try' => 35, + 'assign' => 19, + 'directive' => 196, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 108 + ACTIONS => { + 'IN' => 201, + 'ASSIGN' => 200 + }, + DEFAULT => -130 + }, + {#State 109 + DEFAULT => -156, + GOTOS => { + 'args' => 202 + } + }, + {#State 110 + ACTIONS => { + ";" => 203 + } + }, + {#State 111 + ACTIONS => { + 'ASSIGN' => -130 + }, + DEFAULT => -173 + }, + {#State 112 + ACTIONS => { + 'ASSIGN' => 204 + } + }, + {#State 113 + DEFAULT => -159 + }, + {#State 114 + ACTIONS => { + "\$" => 43, + 'IDENT' => 205, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 175 + } + }, + {#State 115 + ACTIONS => { + ";" => 206 + } + }, + {#State 116 + ACTIONS => { + 'ASSIGN' => -161 + }, + DEFAULT => -169 + }, + {#State 117 + DEFAULT => -176, + GOTOS => { + 'quoted' => 207 + } + }, + {#State 118 + DEFAULT => -158 + }, + {#State 119 + ACTIONS => { + 'DOT' => 104 + }, + DEFAULT => -110 + }, + {#State 120 + ACTIONS => { + 'ASSIGN' => 187 + }, + DEFAULT => -173 + }, + {#State 121 + DEFAULT => -83 + }, + {#State 122 + ACTIONS => { + 'DOT' => 174 + }, + DEFAULT => -84 + }, + {#State 123 + ACTIONS => { + ";" => 208 + } + }, + {#State 124 + DEFAULT => -85 + }, + {#State 125 + ACTIONS => { + "}" => 209 + } + }, + {#State 126 + ACTIONS => { + 'ASSIGN' => 210 + } + }, + {#State 127 + DEFAULT => -122 + }, + {#State 128 + ACTIONS => { + "\$" => 43, + 'COMMA' => 212, + 'LITERAL' => 129, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -118, + GOTOS => { + 'item' => 126, + 'param' => 211 + } + }, + {#State 129 + ACTIONS => { + 'ASSIGN' => 213 + } + }, + {#State 130 + DEFAULT => -73 + }, + {#State 131 + DEFAULT => -4 + }, + {#State 132 + ACTIONS => { + ";" => 214 + } + }, + {#State 133 + ACTIONS => { + "}" => 215 + } + }, + {#State 134 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -142 + }, + {#State 135 + DEFAULT => -156, + GOTOS => { + 'args' => 216 + } + }, + {#State 136 + DEFAULT => -76, + GOTOS => { + '@4-2' => 217 + } + }, + {#State 137 + DEFAULT => -132 + }, + {#State 138 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 218, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 139 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -29 + }, + {#State 140 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -28 + }, + {#State 141 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 219, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 142 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 108, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'loopvar' => 220, + 'node' => 23, + 'ident' => 77, + 'term' => 109, + 'lterm' => 56 + } + }, + {#State 143 + ACTIONS => { + "\"" => 117, + "\$" => 114, + 'LITERAL' => 116, + 'FILENAME' => 83, + 'IDENT' => 111, + 'NUMBER' => 84, + "\${" => 37 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 118, + 'filename' => 85, + 'lvalue' => 112, + 'lnameargs' => 221, + 'item' => 113, + 'name' => 82 + } + }, + {#State 144 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 222, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 145 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 223, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 146 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 224, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 147 + DEFAULT => -41 + }, + {#State 148 + DEFAULT => 0 + }, + {#State 149 + ACTIONS => { + 'DOT' => 104, + 'ASSIGN' => 172 + }, + DEFAULT => -109 + }, + {#State 150 + ACTIONS => { + ")" => 225 + } + }, + {#State 151 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + ")" => 226, + 'OR' => 162 + } + }, + {#State 152 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 227, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 153 + ACTIONS => { + ";" => 228 + } + }, + {#State 154 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 229, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 155 + ACTIONS => { + "\"" => 234, + 'TEXT' => 231, + ";" => 233, + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 230, + 'quotable' => 232 + } + }, + {#State 156 + DEFAULT => -34 + }, + {#State 157 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 235, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 158 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 236, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 159 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 237, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 160 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 238, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 161 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 239, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 162 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 240, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 163 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 241, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 164 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 242, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 165 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 243, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 166 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 244, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 167 + DEFAULT => -32 + }, + {#State 168 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 245, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 169 + ACTIONS => { + "\$" => 43, + 'COMMA' => 171, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -31, + GOTOS => { + 'item' => 39, + 'assign' => 170, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 170 + DEFAULT => -147 + }, + {#State 171 + DEFAULT => -148 + }, + {#State 172 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 246, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 173 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 247, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 174 + ACTIONS => { + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 248 + } + }, + {#State 175 + ACTIONS => { + 'DOT' => 104 + }, + DEFAULT => -156, + GOTOS => { + 'args' => 249 + } + }, + {#State 176 + ACTIONS => { + "\"" => 250, + 'TEXT' => 231, + ";" => 233, + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 230, + 'quotable' => 232 + } + }, + {#State 177 + ACTIONS => { + "\"" => 89, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'filename' => 85, + 'name' => 251 + } + }, + {#State 178 + DEFAULT => -156, + GOTOS => { + 'args' => 252 + } + }, + {#State 179 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -163, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 180 + DEFAULT => -105 + }, + {#State 181 + DEFAULT => -114 + }, + {#State 182 + DEFAULT => -115 + }, + {#State 183 + DEFAULT => -106 + }, + {#State 184 + ACTIONS => { + "\"" => 60, + "\$" => 43, + 'LITERAL' => 78, + 'IDENT' => 2, + 'REF' => 27, + 'NUMBER' => 26, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 259, + 'item' => 39, + 'node' => 23, + 'ident' => 77 + } + }, + {#State 185 + ACTIONS => { + 'FINAL' => 260, + 'CATCH' => 262 + }, + DEFAULT => -72, + GOTOS => { + 'final' => 261 + } + }, + {#State 186 + ACTIONS => { + 'TEXT' => 263 + } + }, + {#State 187 + ACTIONS => { + "\"" => 266, + 'LITERAL' => 265, + 'NUMBER' => 264 + } + }, + {#State 188 + DEFAULT => -97 + }, + {#State 189 + DEFAULT => -98 + }, + {#State 190 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'template' => 267, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 72, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 191 + DEFAULT => -125 + }, + {#State 192 + DEFAULT => -126 + }, + {#State 193 + ACTIONS => { + ";" => 268 + } + }, + {#State 194 + DEFAULT => -89 + }, + {#State 195 + ACTIONS => { + ";" => -150, + "+" => 157, + 'LITERAL' => -150, + 'IDENT' => -150, + 'CAT' => 163, + "\$" => -150, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + 'COMMA' => -150, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162, + "\${" => -150 + }, + DEFAULT => -26 + }, + {#State 196 + DEFAULT => -92 + }, + {#State 197 + DEFAULT => -91 + }, + {#State 198 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 57, + 'IDENT' => 269, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'margs' => 270, + 'node' => 23, + 'ident' => 149, + 'term' => 58, + 'expr' => 151, + 'assign' => 150, + 'lterm' => 56 + } + }, + {#State 199 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -26 + }, + {#State 200 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 271, + 'lterm' => 56 + } + }, + {#State 201 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 272, + 'lterm' => 56 + } + }, + {#State 202 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -64, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 203 + DEFAULT => -56, + GOTOS => { + '@1-3' => 273 + } + }, + {#State 204 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 274, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 205 + ACTIONS => { + 'ASSIGN' => -132 + }, + DEFAULT => -130 + }, + {#State 206 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 275, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 207 + ACTIONS => { + "\"" => 276, + 'TEXT' => 231, + ";" => 233, + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 230, + 'quotable' => 232 + } + }, + {#State 208 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 277, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 209 + DEFAULT => -108 + }, + {#State 210 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 278, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 211 + DEFAULT => -120 + }, + {#State 212 + DEFAULT => -121 + }, + {#State 213 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 279, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 214 + DEFAULT => -74, + GOTOS => { + '@3-3' => 280 + } + }, + {#State 215 + DEFAULT => -131 + }, + {#State 216 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + ")" => 281, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 217 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 282, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 218 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 283, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 219 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -47 + }, + {#State 220 + DEFAULT => -58 + }, + {#State 221 + DEFAULT => -81 + }, + {#State 222 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -45 + }, + {#State 223 + DEFAULT => -66 + }, + {#State 224 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -61 + }, + {#State 225 + DEFAULT => -144 + }, + {#State 226 + DEFAULT => -145 + }, + {#State 227 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 284, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 228 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 285, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 229 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -151 + }, + {#State 230 + ACTIONS => { + 'DOT' => 104 + }, + DEFAULT => -177 + }, + {#State 231 + DEFAULT => -178 + }, + {#State 232 + DEFAULT => -175 + }, + {#State 233 + DEFAULT => -179 + }, + {#State 234 + DEFAULT => -111 + }, + {#State 235 + ACTIONS => { + 'DIV' => 159, + 'MOD' => 165, + "/" => 166 + }, + DEFAULT => -135 + }, + {#State 236 + ACTIONS => { + ":" => 286, + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 237 + ACTIONS => { + 'MOD' => 165 + }, + DEFAULT => -136 + }, + {#State 238 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -140 + }, + {#State 239 + ACTIONS => { + "+" => 157, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166 + }, + DEFAULT => -133 + }, + {#State 240 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -141 + }, + {#State 241 + ACTIONS => { + "+" => 157, + 'CMPOP' => 164, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -139 + }, + {#State 242 + ACTIONS => { + "+" => 157, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -138 + }, + {#State 243 + DEFAULT => -137 + }, + {#State 244 + ACTIONS => { + 'DIV' => 159, + 'MOD' => 165 + }, + DEFAULT => -134 + }, + {#State 245 + DEFAULT => -59, + GOTOS => { + '@2-3' => 287 + } + }, + {#State 246 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -150 + }, + {#State 247 + ACTIONS => { + 'ELSIF' => 290, + 'ELSE' => 288 + }, + DEFAULT => -50, + GOTOS => { + 'else' => 289 + } + }, + {#State 248 + DEFAULT => -170 + }, + {#State 249 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -162, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 250 + DEFAULT => -167 + }, + {#State 251 + DEFAULT => -165 + }, + {#State 252 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + ")" => 291, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 253 + ACTIONS => { + 'DOT' => 104, + 'ASSIGN' => 292 + }, + DEFAULT => -109 + }, + {#State 254 + ACTIONS => { + "(" => 135, + 'ASSIGN' => 210 + }, + DEFAULT => -128 + }, + {#State 255 + DEFAULT => -153 + }, + {#State 256 + ACTIONS => { + 'ASSIGN' => 213 + }, + DEFAULT => -112 + }, + {#State 257 + DEFAULT => -152 + }, + {#State 258 + DEFAULT => -155 + }, + {#State 259 + DEFAULT => -117 + }, + {#State 260 + ACTIONS => { + ";" => 293 + } + }, + {#State 261 + ACTIONS => { + 'END' => 294 + } + }, + {#State 262 + ACTIONS => { + ";" => 296, + 'DEFAULT' => 297, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'filename' => 295 + } + }, + {#State 263 + ACTIONS => { + 'END' => 298 + } + }, + {#State 264 + DEFAULT => -102 + }, + {#State 265 + DEFAULT => -100 + }, + {#State 266 + ACTIONS => { + 'TEXT' => 299 + } + }, + {#State 267 + ACTIONS => { + 'END' => 300 + } + }, + {#State 268 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 301, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 269 + ACTIONS => { + 'COMMA' => -96, + 'IDENT' => -96, + ")" => -96 + }, + DEFAULT => -130 + }, + {#State 270 + ACTIONS => { + 'COMMA' => 304, + 'IDENT' => 302, + ")" => 303 + } + }, + {#State 271 + DEFAULT => -156, + GOTOS => { + 'args' => 305 + } + }, + {#State 272 + DEFAULT => -156, + GOTOS => { + 'args' => 306 + } + }, + {#State 273 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 307, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 274 + DEFAULT => -157 + }, + {#State 275 + ACTIONS => { + 'END' => 308 + } + }, + {#State 276 + ACTIONS => { + 'ASSIGN' => -160 + }, + DEFAULT => -167 + }, + {#State 277 + ACTIONS => { + 'END' => 309 + } + }, + {#State 278 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -124 + }, + {#State 279 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -123 + }, + {#State 280 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 310, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 281 + DEFAULT => -129 + }, + {#State 282 + ACTIONS => { + 'END' => 311 + } + }, + {#State 283 + ACTIONS => { + 'ELSIF' => 290, + 'ELSE' => 288 + }, + DEFAULT => -50, + GOTOS => { + 'else' => 312 + } + }, + {#State 284 + ACTIONS => { + 'CASE' => 313 + }, + DEFAULT => -55, + GOTOS => { + 'case' => 314 + } + }, + {#State 285 + ACTIONS => { + 'END' => 315 + } + }, + {#State 286 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 316, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 287 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 317, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 288 + ACTIONS => { + ";" => 318 + } + }, + {#State 289 + ACTIONS => { + 'END' => 319 + } + }, + {#State 290 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 320, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 291 + DEFAULT => -164 + }, + {#State 292 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 321, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 293 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 322, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 294 + DEFAULT => -67 + }, + {#State 295 + ACTIONS => { + 'DOT' => 174, + ";" => 323 + } + }, + {#State 296 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 324, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 297 + ACTIONS => { + ";" => 325 + } + }, + {#State 298 + DEFAULT => -79 + }, + {#State 299 + ACTIONS => { + "\"" => 326 + } + }, + {#State 300 + DEFAULT => -82 + }, + {#State 301 + ACTIONS => { + 'END' => 327 + } + }, + {#State 302 + DEFAULT => -94 + }, + {#State 303 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'WRAPPER' => 55, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + "\"" => 60, + 'PROCESS' => 61, + 'FILTER' => 25, + 'RETURN' => 64, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 193, + 'DEFAULT' => 69, + "{" => 30, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'term' => 58, + 'loop' => 4, + 'expr' => 199, + 'wrapper' => 46, + 'atomexpr' => 48, + 'atomdir' => 12, + 'mdir' => 328, + 'sterm' => 68, + 'filter' => 29, + 'ident' => 149, + 'perl' => 31, + 'setlist' => 70, + 'switch' => 34, + 'try' => 35, + 'assign' => 19, + 'directive' => 196, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 304 + DEFAULT => -95 + }, + {#State 305 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -62, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 306 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -63, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 307 + ACTIONS => { + 'END' => 329 + } + }, + {#State 308 + DEFAULT => -80 + }, + {#State 309 + DEFAULT => -88 + }, + {#State 310 + ACTIONS => { + 'END' => 330 + } + }, + {#State 311 + DEFAULT => -77 + }, + {#State 312 + ACTIONS => { + 'END' => 331 + } + }, + {#State 313 + ACTIONS => { + ";" => 332, + 'DEFAULT' => 334, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 333, + 'lterm' => 56 + } + }, + {#State 314 + ACTIONS => { + 'END' => 335 + } + }, + {#State 315 + DEFAULT => -65 + }, + {#State 316 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -143 + }, + {#State 317 + ACTIONS => { + 'END' => 336 + } + }, + {#State 318 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 337, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 319 + DEFAULT => -46 + }, + {#State 320 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 338, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 321 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -154 + }, + {#State 322 + DEFAULT => -71 + }, + {#State 323 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 339, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 324 + ACTIONS => { + 'FINAL' => 260, + 'CATCH' => 262 + }, + DEFAULT => -72, + GOTOS => { + 'final' => 340 + } + }, + {#State 325 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 341, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 326 + DEFAULT => -101 + }, + {#State 327 + DEFAULT => -93 + }, + {#State 328 + DEFAULT => -90 + }, + {#State 329 + DEFAULT => -57 + }, + {#State 330 + DEFAULT => -75 + }, + {#State 331 + DEFAULT => -44 + }, + {#State 332 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 342, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 333 + ACTIONS => { + ";" => 343 + } + }, + {#State 334 + ACTIONS => { + ";" => 344 + } + }, + {#State 335 + DEFAULT => -51 + }, + {#State 336 + DEFAULT => -60 + }, + {#State 337 + DEFAULT => -49 + }, + {#State 338 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 345, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 339 + ACTIONS => { + 'FINAL' => 260, + 'CATCH' => 262 + }, + DEFAULT => -72, + GOTOS => { + 'final' => 346 + } + }, + {#State 340 + DEFAULT => -70 + }, + {#State 341 + ACTIONS => { + 'FINAL' => 260, + 'CATCH' => 262 + }, + DEFAULT => -72, + GOTOS => { + 'final' => 347 + } + }, + {#State 342 + DEFAULT => -54 + }, + {#State 343 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 348, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 344 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 349, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 345 + ACTIONS => { + 'ELSIF' => 290, + 'ELSE' => 288 + }, + DEFAULT => -50, + GOTOS => { + 'else' => 350 + } + }, + {#State 346 + DEFAULT => -68 + }, + {#State 347 + DEFAULT => -69 + }, + {#State 348 + ACTIONS => { + 'CASE' => 313 + }, + DEFAULT => -55, + GOTOS => { + 'case' => 351 + } + }, + {#State 349 + DEFAULT => -53 + }, + {#State 350 + DEFAULT => -48 + }, + {#State 351 + DEFAULT => -52 + } +]; + + +#======================================================================== +# Rules +#======================================================================== + +$RULES = [ + [#Rule 0 + '$start', 2, undef + ], + [#Rule 1 + 'template', 1, +sub +#line 64 "Parser.yp" +{ $factory->template($_[1]) } + ], + [#Rule 2 + 'block', 1, +sub +#line 67 "Parser.yp" +{ $factory->block($_[1]) } + ], + [#Rule 3 + 'block', 0, +sub +#line 68 "Parser.yp" +{ $factory->block() } + ], + [#Rule 4 + 'chunks', 2, +sub +#line 71 "Parser.yp" +{ push(@{$_[1]}, $_[2]) + if defined $_[2]; $_[1] } + ], + [#Rule 5 + 'chunks', 1, +sub +#line 73 "Parser.yp" +{ defined $_[1] ? [ $_[1] ] : [ ] } + ], + [#Rule 6 + 'chunk', 1, +sub +#line 76 "Parser.yp" +{ $factory->textblock($_[1]) } + ], + [#Rule 7 + 'chunk', 2, undef + ], + [#Rule 8 + 'statement', 1, undef + ], + [#Rule 9 + 'statement', 1, undef + ], + [#Rule 10 + 'statement', 1, undef + ], + [#Rule 11 + 'statement', 1, undef + ], + [#Rule 12 + 'statement', 1, undef + ], + [#Rule 13 + 'statement', 1, undef + ], + [#Rule 14 + 'statement', 1, undef + ], + [#Rule 15 + 'statement', 1, undef + ], + [#Rule 16 + 'statement', 1, +sub +#line 89 "Parser.yp" +{ $factory->get($_[1]) } + ], + [#Rule 17 + 'statement', 2, +sub +#line 90 "Parser.yp" +{ $_[0]->add_metadata($_[2]); } + ], + [#Rule 18 + 'statement', 0, undef + ], + [#Rule 19 + 'directive', 1, +sub +#line 94 "Parser.yp" +{ $factory->set($_[1]) } + ], + [#Rule 20 + 'directive', 1, undef + ], + [#Rule 21 + 'directive', 1, undef + ], + [#Rule 22 + 'directive', 1, undef + ], + [#Rule 23 + 'directive', 1, undef + ], + [#Rule 24 + 'directive', 1, undef + ], + [#Rule 25 + 'directive', 1, undef + ], + [#Rule 26 + 'atomexpr', 1, +sub +#line 108 "Parser.yp" +{ $factory->get($_[1]) } + ], + [#Rule 27 + 'atomexpr', 1, undef + ], + [#Rule 28 + 'atomdir', 2, +sub +#line 112 "Parser.yp" +{ $factory->get($_[2]) } + ], + [#Rule 29 + 'atomdir', 2, +sub +#line 113 "Parser.yp" +{ $factory->call($_[2]) } + ], + [#Rule 30 + 'atomdir', 2, +sub +#line 114 "Parser.yp" +{ $factory->set($_[2]) } + ], + [#Rule 31 + 'atomdir', 2, +sub +#line 115 "Parser.yp" +{ $factory->default($_[2]) } + ], + [#Rule 32 + 'atomdir', 2, +sub +#line 116 "Parser.yp" +{ $factory->insert($_[2]) } + ], + [#Rule 33 + 'atomdir', 2, +sub +#line 117 "Parser.yp" +{ $factory->include($_[2]) } + ], + [#Rule 34 + 'atomdir', 2, +sub +#line 118 "Parser.yp" +{ $factory->process($_[2]) } + ], + [#Rule 35 + 'atomdir', 2, +sub +#line 119 "Parser.yp" +{ $factory->throw($_[2]) } + ], + [#Rule 36 + 'atomdir', 1, +sub +#line 120 "Parser.yp" +{ $factory->return() } + ], + [#Rule 37 + 'atomdir', 1, +sub +#line 121 "Parser.yp" +{ $factory->stop() } + ], + [#Rule 38 + 'atomdir', 1, +sub +#line 122 "Parser.yp" +{ "\$output = '';"; } + ], + [#Rule 39 + 'atomdir', 1, +sub +#line 123 "Parser.yp" +{ $_[0]->{ INFOR } || $_[0]->{ INWHILE } + ? 'last LOOP;' + : 'last;' } + ], + [#Rule 40 + 'atomdir', 1, +sub +#line 126 "Parser.yp" +{ $_[0]->{ INFOR } + ? $factory->next() + : ($_[0]->{ INWHILE } + ? 'next LOOP;' + : 'next;') } + ], + [#Rule 41 + 'atomdir', 2, +sub +#line 131 "Parser.yp" +{ if ($_[2]->[0]->[0] =~ /^'(on|off)'$/) { + $_[0]->{ DEBUG_DIRS } = ($1 eq 'on'); + $factory->debug($_[2]); + } + else { + $_[0]->{ DEBUG_DIRS } ? $factory->debug($_[2]) : ''; + } + } + ], + [#Rule 42 + 'atomdir', 1, undef + ], + [#Rule 43 + 'atomdir', 1, undef + ], + [#Rule 44 + 'condition', 6, +sub +#line 144 "Parser.yp" +{ $factory->if(@_[2, 4, 5]) } + ], + [#Rule 45 + 'condition', 3, +sub +#line 145 "Parser.yp" +{ $factory->if(@_[3, 1]) } + ], + [#Rule 46 + 'condition', 6, +sub +#line 147 "Parser.yp" +{ $factory->if("!($_[2])", @_[4, 5]) } + ], + [#Rule 47 + 'condition', 3, +sub +#line 148 "Parser.yp" +{ $factory->if("!($_[3])", $_[1]) } + ], + [#Rule 48 + 'else', 5, +sub +#line 152 "Parser.yp" +{ unshift(@{$_[5]}, [ @_[2, 4] ]); + $_[5]; } + ], + [#Rule 49 + 'else', 3, +sub +#line 154 "Parser.yp" +{ [ $_[3] ] } + ], + [#Rule 50 + 'else', 0, +sub +#line 155 "Parser.yp" +{ [ undef ] } + ], + [#Rule 51 + 'switch', 6, +sub +#line 159 "Parser.yp" +{ $factory->switch(@_[2, 5]) } + ], + [#Rule 52 + 'case', 5, +sub +#line 163 "Parser.yp" +{ unshift(@{$_[5]}, [ @_[2, 4] ]); + $_[5]; } + ], + [#Rule 53 + 'case', 4, +sub +#line 165 "Parser.yp" +{ [ $_[4] ] } + ], + [#Rule 54 + 'case', 3, +sub +#line 166 "Parser.yp" +{ [ $_[3] ] } + ], + [#Rule 55 + 'case', 0, +sub +#line 167 "Parser.yp" +{ [ undef ] } + ], + [#Rule 56 + '@1-3', 0, +sub +#line 170 "Parser.yp" +{ $_[0]->{ INFOR }++ } + ], + [#Rule 57 + 'loop', 6, +sub +#line 171 "Parser.yp" +{ $_[0]->{ INFOR }--; + $factory->foreach(@{$_[2]}, $_[5]) } + ], + [#Rule 58 + 'loop', 3, +sub +#line 175 "Parser.yp" +{ $factory->foreach(@{$_[3]}, $_[1]) } + ], + [#Rule 59 + '@2-3', 0, +sub +#line 176 "Parser.yp" +{ $_[0]->{ INWHILE }++ } + ], + [#Rule 60 + 'loop', 6, +sub +#line 177 "Parser.yp" +{ $_[0]->{ INWHILE }--; + $factory->while(@_[2, 5]) } + ], + [#Rule 61 + 'loop', 3, +sub +#line 179 "Parser.yp" +{ $factory->while(@_[3, 1]) } + ], + [#Rule 62 + 'loopvar', 4, +sub +#line 182 "Parser.yp" +{ [ @_[1, 3, 4] ] } + ], + [#Rule 63 + 'loopvar', 4, +sub +#line 183 "Parser.yp" +{ [ @_[1, 3, 4] ] } + ], + [#Rule 64 + 'loopvar', 2, +sub +#line 184 "Parser.yp" +{ [ 0, @_[1, 2] ] } + ], + [#Rule 65 + 'wrapper', 5, +sub +#line 188 "Parser.yp" +{ $factory->wrapper(@_[2, 4]) } + ], + [#Rule 66 + 'wrapper', 3, +sub +#line 190 "Parser.yp" +{ $factory->wrapper(@_[3, 1]) } + ], + [#Rule 67 + 'try', 5, +sub +#line 194 "Parser.yp" +{ $factory->try(@_[3, 4]) } + ], + [#Rule 68 + 'final', 5, +sub +#line 198 "Parser.yp" +{ unshift(@{$_[5]}, [ @_[2,4] ]); + $_[5]; } + ], + [#Rule 69 + 'final', 5, +sub +#line 201 "Parser.yp" +{ unshift(@{$_[5]}, [ undef, $_[4] ]); + $_[5]; } + ], + [#Rule 70 + 'final', 4, +sub +#line 204 "Parser.yp" +{ unshift(@{$_[4]}, [ undef, $_[3] ]); + $_[4]; } + ], + [#Rule 71 + 'final', 3, +sub +#line 206 "Parser.yp" +{ [ $_[3] ] } + ], + [#Rule 72 + 'final', 0, +sub +#line 207 "Parser.yp" +{ [ 0 ] } + ], + [#Rule 73 + 'use', 2, +sub +#line 210 "Parser.yp" +{ $factory->use($_[2]) } + ], + [#Rule 74 + '@3-3', 0, +sub +#line 213 "Parser.yp" +{ $_[0]->push_defblock(); } + ], + [#Rule 75 + 'view', 6, +sub +#line 214 "Parser.yp" +{ $factory->view(@_[2,5], + $_[0]->pop_defblock) } + ], + [#Rule 76 + '@4-2', 0, +sub +#line 218 "Parser.yp" +{ ${$_[0]->{ INPERL }}++; } + ], + [#Rule 77 + 'perl', 5, +sub +#line 219 "Parser.yp" +{ ${$_[0]->{ INPERL }}--; + $_[0]->{ EVAL_PERL } + ? $factory->perl($_[4]) + : $factory->no_perl(); } + ], + [#Rule 78 + '@5-1', 0, +sub +#line 225 "Parser.yp" +{ ${$_[0]->{ INPERL }}++; + $rawstart = ${$_[0]->{'LINE'}}; } + ], + [#Rule 79 + 'rawperl', 5, +sub +#line 227 "Parser.yp" +{ ${$_[0]->{ INPERL }}--; + $_[0]->{ EVAL_PERL } + ? $factory->rawperl($_[4], $rawstart) + : $factory->no_perl(); } + ], + [#Rule 80 + 'filter', 5, +sub +#line 234 "Parser.yp" +{ $factory->filter(@_[2,4]) } + ], + [#Rule 81 + 'filter', 3, +sub +#line 236 "Parser.yp" +{ $factory->filter(@_[3,1]) } + ], + [#Rule 82 + 'defblock', 5, +sub +#line 241 "Parser.yp" +{ my $name = join('/', @{ $_[0]->{ DEFBLOCKS } }); + pop(@{ $_[0]->{ DEFBLOCKS } }); + $_[0]->define_block($name, $_[4]); + undef + } + ], + [#Rule 83 + 'defblockname', 2, +sub +#line 248 "Parser.yp" +{ push(@{ $_[0]->{ DEFBLOCKS } }, $_[2]); + $_[2]; + } + ], + [#Rule 84 + 'blockname', 1, undef + ], + [#Rule 85 + 'blockname', 1, +sub +#line 254 "Parser.yp" +{ $_[1] =~ s/^'(.*)'$/$1/; $_[1] } + ], + [#Rule 86 + 'blockargs', 1, undef + ], + [#Rule 87 + 'blockargs', 0, undef + ], + [#Rule 88 + 'anonblock', 5, +sub +#line 262 "Parser.yp" +{ local $" = ', '; + print STDERR "experimental block args: [@{ $_[2] }]\n" + if $_[2]; + $factory->anon_block($_[4]) } + ], + [#Rule 89 + 'capture', 3, +sub +#line 268 "Parser.yp" +{ $factory->capture(@_[1, 3]) } + ], + [#Rule 90 + 'macro', 6, +sub +#line 272 "Parser.yp" +{ $factory->macro(@_[2, 6, 4]) } + ], + [#Rule 91 + 'macro', 3, +sub +#line 273 "Parser.yp" +{ $factory->macro(@_[2, 3]) } + ], + [#Rule 92 + 'mdir', 1, undef + ], + [#Rule 93 + 'mdir', 4, +sub +#line 277 "Parser.yp" +{ $_[3] } + ], + [#Rule 94 + 'margs', 2, +sub +#line 280 "Parser.yp" +{ push(@{$_[1]}, $_[2]); $_[1] } + ], + [#Rule 95 + 'margs', 2, +sub +#line 281 "Parser.yp" +{ $_[1] } + ], + [#Rule 96 + 'margs', 1, +sub +#line 282 "Parser.yp" +{ [ $_[1] ] } + ], + [#Rule 97 + 'metadata', 2, +sub +#line 285 "Parser.yp" +{ push(@{$_[1]}, @{$_[2]}); $_[1] } + ], + [#Rule 98 + 'metadata', 2, undef + ], + [#Rule 99 + 'metadata', 1, undef + ], + [#Rule 100 + 'meta', 3, +sub +#line 290 "Parser.yp" +{ for ($_[3]) { s/^'//; s/'$//; + s/\\'/'/g }; + [ @_[1,3] ] } + ], + [#Rule 101 + 'meta', 5, +sub +#line 293 "Parser.yp" +{ [ @_[1,4] ] } + ], + [#Rule 102 + 'meta', 3, +sub +#line 294 "Parser.yp" +{ [ @_[1,3] ] } + ], + [#Rule 103 + 'term', 1, undef + ], + [#Rule 104 + 'term', 1, undef + ], + [#Rule 105 + 'lterm', 3, +sub +#line 306 "Parser.yp" +{ "[ $_[2] ]" } + ], + [#Rule 106 + 'lterm', 3, +sub +#line 307 "Parser.yp" +{ "[ $_[2] ]" } + ], + [#Rule 107 + 'lterm', 2, +sub +#line 308 "Parser.yp" +{ "[ ]" } + ], + [#Rule 108 + 'lterm', 3, +sub +#line 309 "Parser.yp" +{ "{ $_[2] }" } + ], + [#Rule 109 + 'sterm', 1, +sub +#line 312 "Parser.yp" +{ $factory->ident($_[1]) } + ], + [#Rule 110 + 'sterm', 2, +sub +#line 313 "Parser.yp" +{ $factory->identref($_[2]) } + ], + [#Rule 111 + 'sterm', 3, +sub +#line 314 "Parser.yp" +{ $factory->quoted($_[2]) } + ], + [#Rule 112 + 'sterm', 1, undef + ], + [#Rule 113 + 'sterm', 1, undef + ], + [#Rule 114 + 'list', 2, +sub +#line 319 "Parser.yp" +{ "$_[1], $_[2]" } + ], + [#Rule 115 + 'list', 2, undef + ], + [#Rule 116 + 'list', 1, undef + ], + [#Rule 117 + 'range', 3, +sub +#line 324 "Parser.yp" +{ $_[1] . '..' . $_[3] } + ], + [#Rule 118 + 'hash', 1, undef + ], + [#Rule 119 + 'hash', 0, +sub +#line 329 "Parser.yp" +{ "" } + ], + [#Rule 120 + 'params', 2, +sub +#line 332 "Parser.yp" +{ "$_[1], $_[2]" } + ], + [#Rule 121 + 'params', 2, undef + ], + [#Rule 122 + 'params', 1, undef + ], + [#Rule 123 + 'param', 3, +sub +#line 337 "Parser.yp" +{ "$_[1] => $_[3]" } + ], + [#Rule 124 + 'param', 3, +sub +#line 338 "Parser.yp" +{ "$_[1] => $_[3]" } + ], + [#Rule 125 + 'ident', 3, +sub +#line 341 "Parser.yp" +{ push(@{$_[1]}, @{$_[3]}); $_[1] } + ], + [#Rule 126 + 'ident', 3, +sub +#line 342 "Parser.yp" +{ push(@{$_[1]}, + map {($_, 0)} split(/\./, $_[3])); + $_[1]; } + ], + [#Rule 127 + 'ident', 1, undef + ], + [#Rule 128 + 'node', 1, +sub +#line 348 "Parser.yp" +{ [ $_[1], 0 ] } + ], + [#Rule 129 + 'node', 4, +sub +#line 349 "Parser.yp" +{ [ $_[1], $factory->args($_[3]) ] } + ], + [#Rule 130 + 'item', 1, +sub +#line 352 "Parser.yp" +{ "'$_[1]'" } + ], + [#Rule 131 + 'item', 3, +sub +#line 353 "Parser.yp" +{ $_[2] } + ], + [#Rule 132 + 'item', 2, +sub +#line 354 "Parser.yp" +{ $_[0]->{ V1DOLLAR } + ? "'$_[2]'" + : $factory->ident(["'$_[2]'", 0]) } + ], + [#Rule 133 + 'expr', 3, +sub +#line 359 "Parser.yp" +{ "$_[1] $_[2] $_[3]" } + ], + [#Rule 134 + 'expr', 3, +sub +#line 360 "Parser.yp" +{ "$_[1] $_[2] $_[3]" } + ], + [#Rule 135 + 'expr', 3, +sub +#line 361 "Parser.yp" +{ "$_[1] $_[2] $_[3]" } + ], + [#Rule 136 + 'expr', 3, +sub +#line 362 "Parser.yp" +{ "int($_[1] / $_[3])" } + ], + [#Rule 137 + 'expr', 3, +sub +#line 363 "Parser.yp" +{ "$_[1] % $_[3]" } + ], + [#Rule 138 + 'expr', 3, +sub +#line 364 "Parser.yp" +{ "$_[1] $CMPOP{ $_[2] } $_[3]" } + ], + [#Rule 139 + 'expr', 3, +sub +#line 365 "Parser.yp" +{ "$_[1] . $_[3]" } + ], + [#Rule 140 + 'expr', 3, +sub +#line 366 "Parser.yp" +{ "$_[1] && $_[3]" } + ], + [#Rule 141 + 'expr', 3, +sub +#line 367 "Parser.yp" +{ "$_[1] || $_[3]" } + ], + [#Rule 142 + 'expr', 2, +sub +#line 368 "Parser.yp" +{ "! $_[2]" } + ], + [#Rule 143 + 'expr', 5, +sub +#line 369 "Parser.yp" +{ "$_[1] ? $_[3] : $_[5]" } + ], + [#Rule 144 + 'expr', 3, +sub +#line 370 "Parser.yp" +{ $factory->assign(@{$_[2]}) } + ], + [#Rule 145 + 'expr', 3, +sub +#line 371 "Parser.yp" +{ "($_[2])" } + ], + [#Rule 146 + 'expr', 1, undef + ], + [#Rule 147 + 'setlist', 2, +sub +#line 375 "Parser.yp" +{ push(@{$_[1]}, @{$_[2]}); $_[1] } + ], + [#Rule 148 + 'setlist', 2, undef + ], + [#Rule 149 + 'setlist', 1, undef + ], + [#Rule 150 + 'assign', 3, +sub +#line 381 "Parser.yp" +{ [ $_[1], $_[3] ] } + ], + [#Rule 151 + 'assign', 3, +sub +#line 382 "Parser.yp" +{ [ @_[1,3] ] } + ], + [#Rule 152 + 'args', 2, +sub +#line 389 "Parser.yp" +{ push(@{$_[1]}, $_[2]); $_[1] } + ], + [#Rule 153 + 'args', 2, +sub +#line 390 "Parser.yp" +{ push(@{$_[1]->[0]}, $_[2]); $_[1] } + ], + [#Rule 154 + 'args', 4, +sub +#line 391 "Parser.yp" +{ push(@{$_[1]->[0]}, "'', " . + $factory->assign(@_[2,4])); $_[1] } + ], + [#Rule 155 + 'args', 2, +sub +#line 393 "Parser.yp" +{ $_[1] } + ], + [#Rule 156 + 'args', 0, +sub +#line 394 "Parser.yp" +{ [ [ ] ] } + ], + [#Rule 157 + 'lnameargs', 3, +sub +#line 404 "Parser.yp" +{ push(@{$_[3]}, $_[1]); $_[3] } + ], + [#Rule 158 + 'lnameargs', 1, undef + ], + [#Rule 159 + 'lvalue', 1, undef + ], + [#Rule 160 + 'lvalue', 3, +sub +#line 409 "Parser.yp" +{ $factory->quoted($_[2]) } + ], + [#Rule 161 + 'lvalue', 1, undef + ], + [#Rule 162 + 'nameargs', 3, +sub +#line 413 "Parser.yp" +{ [ [$factory->ident($_[2])], $_[3] ] } + ], + [#Rule 163 + 'nameargs', 2, +sub +#line 414 "Parser.yp" +{ [ @_[1,2] ] } + ], + [#Rule 164 + 'nameargs', 4, +sub +#line 415 "Parser.yp" +{ [ @_[1,3] ] } + ], + [#Rule 165 + 'names', 3, +sub +#line 418 "Parser.yp" +{ push(@{$_[1]}, $_[3]); $_[1] } + ], + [#Rule 166 + 'names', 1, +sub +#line 419 "Parser.yp" +{ [ $_[1] ] } + ], + [#Rule 167 + 'name', 3, +sub +#line 422 "Parser.yp" +{ $factory->quoted($_[2]) } + ], + [#Rule 168 + 'name', 1, +sub +#line 423 "Parser.yp" +{ "'$_[1]'" } + ], + [#Rule 169 + 'name', 1, undef + ], + [#Rule 170 + 'filename', 3, +sub +#line 435 "Parser.yp" +{ "$_[1].$_[3]" } + ], + [#Rule 171 + 'filename', 1, undef + ], + [#Rule 172 + 'filepart', 1, undef + ], + [#Rule 173 + 'filepart', 1, undef + ], + [#Rule 174 + 'filepart', 1, undef + ], + [#Rule 175 + 'quoted', 2, +sub +#line 449 "Parser.yp" +{ push(@{$_[1]}, $_[2]) + if defined $_[2]; $_[1] } + ], + [#Rule 176 + 'quoted', 0, +sub +#line 451 "Parser.yp" +{ [ ] } + ], + [#Rule 177 + 'quotable', 1, +sub +#line 454 "Parser.yp" +{ $factory->ident($_[1]) } + ], + [#Rule 178 + 'quotable', 1, +sub +#line 455 "Parser.yp" +{ $factory->text($_[1]) } + ], + [#Rule 179 + 'quotable', 1, +sub +#line 456 "Parser.yp" +{ undef } + ] +]; + + + +1; + + + + + + + + + + + + diff --git a/lib/Template/Iterator.pm b/lib/Template/Iterator.pm new file mode 100644 index 0000000..0063b6e --- /dev/null +++ b/lib/Template/Iterator.pm @@ -0,0 +1,446 @@ +#============================================================= -*-Perl-*- +# +# Template::Iterator +# +# DESCRIPTION +# +# Module defining an iterator class which is used by the FOREACH +# directive for iterating through data sets. This may be +# sub-classed to define more specific iterator types. +# +# An iterator is an object which provides a consistent way to +# navigate through data which may have a complex underlying form. +# This implementation uses the get_first() and get_next() methods to +# iterate through a dataset. The get_first() method is called once +# to perform any data initialisation and return the first value, +# then get_next() is called repeatedly to return successive values. +# Both these methods return a pair of values which are the data item +# itself and a status code. The default implementation handles +# iteration through an array (list) of elements which is passed by +# reference to the constructor. An empty list is used if none is +# passed. The module may be sub-classed to provide custom +# implementations which iterate through any kind of data in any +# manner as long as it can conforms to the get_first()/get_next() +# interface. The object also implements the get_all() method for +# returning all remaining elements as a list reference. +# +# For further information on iterators see "Design Patterns", by the +# "Gang of Four" (Erich Gamma, Richard Helm, Ralph Johnson, John +# Vlissides), Addision-Wesley, ISBN 0-201-63361-2. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Iterator.pm,v 2.59 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Iterator; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $AUTOLOAD ); # AUTO? +use base qw( Template::Base ); +use Template::Constants; +use Template::Exception; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.59 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\@target, \%options) +# +# Constructor method which creates and returns a reference to a new +# Template::Iterator object. A reference to the target data (array +# or hash) may be passed for the object to iterate through. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my $data = shift || [ ]; + my $params = shift || { }; + + if (ref $data eq 'HASH') { + # map a hash into a list of { key => ???, value => ??? } hashes, + # one for each key, sorted by keys + $data = [ map { { key => $_, value => $data->{ $_ } } } + sort keys %$data ]; + } + elsif (UNIVERSAL::can($data, 'as_list')) { + $data = $data->as_list(); + } + elsif (ref $data ne 'ARRAY') { + # coerce any non-list data into an array reference + $data = [ $data ] ; + } + + bless { + _DATA => $data, + _ERROR => '', + }, $class; +} + + +#======================================================================== +# ----- PUBLIC OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# get_first() +# +# Initialises the object for iterating through the target data set. The +# first record is returned, if defined, along with the STATUS_OK value. +# If there is no target data, or the data is an empty set, then undef +# is returned with the STATUS_DONE value. +#------------------------------------------------------------------------ + +sub get_first { + my $self = shift; + my $data = $self->{ _DATA }; + + $self->{ _DATASET } = $self->{ _DATA }; + my $size = scalar @$data; + my $index = 0; + + return (undef, Template::Constants::STATUS_DONE) unless $size; + + # initialise various counters, flags, etc. + @$self{ qw( SIZE MAX INDEX COUNT FIRST LAST ) } + = ( $size, $size - 1, $index, 1, 1, $size > 1 ? 0 : 1, undef ); + @$self{ qw( PREV NEXT ) } = ( undef, $self->{ _DATASET }->[ $index + 1 ]); + + return $self->{ _DATASET }->[ $index ]; +} + + + +#------------------------------------------------------------------------ +# get_next() +# +# Called repeatedly to access successive elements in the data set. +# Should only be called after calling get_first() or a warning will +# be raised and (undef, STATUS_DONE) returned. +#------------------------------------------------------------------------ + +sub get_next { + my $self = shift; + my ($max, $index) = @$self{ qw( MAX INDEX ) }; + my $data = $self->{ _DATASET }; + + # warn about incorrect usage + unless (defined $index) { + my ($pack, $file, $line) = caller(); + warn("iterator get_next() called before get_first() at $file line $line\n"); + return (undef, Template::Constants::STATUS_DONE); ## RETURN ## + } + + # if there's still some data to go... + if ($index < $max) { + # update counters and flags + $index++; + @$self{ qw( INDEX COUNT FIRST LAST ) } + = ( $index, $index + 1, 0, $index == $max ? 1 : 0 ); + @$self{ qw( PREV NEXT ) } = @$data[ $index - 1, $index + 1 ]; + return $data->[ $index ]; ## RETURN ## + } + else { + return (undef, Template::Constants::STATUS_DONE); ## RETURN ## + } +} + + +#------------------------------------------------------------------------ +# get_all() +# +# Method which returns all remaining items in the iterator as a Perl list +# reference. May be called at any time in the life-cycle of the iterator. +# The get_first() method will be called automatically if necessary, and +# then subsequent get_next() calls are made, storing each returned +# result until the list is exhausted. +#------------------------------------------------------------------------ + +sub get_all { + my $self = shift; + my ($max, $index) = @$self{ qw( MAX INDEX ) }; + my @data; + + # if there's still some data to go... + if ($index < $max) { + $index++; + @data = @{ $self->{ _DATASET } } [ $index..$max ]; + + # update counters and flags + @$self{ qw( INDEX COUNT FIRST LAST ) } + = ( $max, $max + 1, 0, 1 ); + + return \@data; ## RETURN ## + } + else { + return (undef, Template::Constants::STATUS_DONE); ## RETURN ## + } +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# Provides access to internal fields (e.g. size, first, last, max, etc) +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $item = $AUTOLOAD; + $item =~ s/.*:://; + return if $item eq 'DESTROY'; + + # alias NUMBER to COUNT for backwards compatability + $item = 'COUNT' if $item =~ /NUMBER/i; + + return $self->{ uc $item }; +} + + +#======================================================================== +# ----- PRIVATE DEBUG METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string detailing the internal state of +# the iterator object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + join('', + " Data: ", $self->{ _DATA }, "\n", + " Index: ", $self->{ INDEX }, "\n", + "Number: ", $self->{ NUMBER }, "\n", + " Max: ", $self->{ MAX }, "\n", + " Size: ", $self->{ SIZE }, "\n", + " First: ", $self->{ FIRST }, "\n", + " Last: ", $self->{ LAST }, "\n", + "\n" + ); +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Iterator - Data iterator used by the FOREACH directive + +=head1 SYNOPSIS + + my $iter = Template::Iterator->new(\@data, \%options); + +=head1 DESCRIPTION + +The Template::Iterator module defines a generic data iterator for use +by the FOREACH directive. + +It may be used as the base class for custom iterators. + +=head1 PUBLIC METHODS + +=head2 new($data) + +Constructor method. A reference to a list of values is passed as the +first parameter. Subsequent calls to get_first() and get_next() calls +will return each element from the list. + + my $iter = Template::Iterator->new([ 'foo', 'bar', 'baz' ]); + +The constructor will also accept a reference to a hash array and will +expand it into a list in which each entry is a hash array containing +a 'key' and 'value' item, sorted according to the hash keys. + + my $iter = Template::Iterator->new({ + foo => 'Foo Item', + bar => 'Bar Item', + }); + +This is equivalent to: + + my $iter = Template::Iterator->new([ + { key => 'bar', value => 'Bar Item' }, + { key => 'foo', value => 'Foo Item' }, + ]); + +When passed a single item which is not an array reference, the constructor +will automatically create a list containing that single item. + + my $iter = Template::Iterator->new('foo'); + +This is equivalent to: + + my $iter = Template::Iterator->new([ 'foo' ]); + +Note that a single item which is an object based on a blessed ARRAY +references will NOT be treated as an array and will be folded into +a list containing that one object reference. + + my $list = bless [ 'foo', 'bar' ], 'MyListClass'; + my $iter = Template::Iterator->new($list); + +equivalent to: + + my $iter = Template::Iterator->new([ $list ]); + +If the object provides an as_list() method then the Template::Iterator +constructor will call that method to return the list of data. For example: + + package MyListObject; + + sub new { + my $class = shift; + bless [ @_ ], $class; + } + + package main; + + my $list = MyListObject->new('foo', 'bar'); + my $iter = Template::Iterator->new($list); + +This is then functionally equivalent to: + + my $iter = Template::Iterator->new([ $list ]); + +The iterator will return only one item, a reference to the MyListObject +object, $list. + +By adding an as_list() method to the MyListObject class, we can force +the Template::Iterator constructor to treat the object as a list and +use the data contained within. + + package MyListObject; + + ... + + sub as_list { + my $self = shift; + return $self; + } + + package main; + + my $list = MyListObject->new('foo', 'bar'); + my $iter = Template::Iterator->new($list); + +The iterator will now return the two item, 'foo' and 'bar', which the +MyObjectList encapsulates. + +=head2 get_first() + +Returns a ($value, $error) pair for the first item in the iterator set. +The $error returned may be zero or undefined to indicate a valid datum +was successfully returned. Returns an error of STATUS_DONE if the list +is empty. + +=head2 get_next() + +Returns a ($value, $error) pair for the next item in the iterator set. +Returns an error of STATUS_DONE if all items in the list have been +visited. + +=head2 get_all() + +Returns a (\@values, $error) pair for all remaining items in the iterator +set. Returns an error of STATUS_DONE if all items in the list have been +visited. + +=head2 size() + +Returns the size of the data set or undef if unknown. + +=head2 max() + +Returns the maximum index number (i.e. the index of the last element) +which is equivalent to size() - 1. + +=head2 index() + +Returns the current index number which is in the range 0 to max(). + +=head2 count() + +Returns the current iteration count in the range 1 to size(). This is +equivalent to index() + 1. Note that number() is supported as an alias +for count() for backwards compatability. + +=head2 first() + +Returns a boolean value to indicate if the iterator is currently on +the first iteration of the set. + +=head2 last() + +Returns a boolean value to indicate if the iterator is currently on +the last iteration of the set. + +=head2 prev() + +Returns the previous item in the data set, or undef if the iterator is +on the first item. + +=head2 next() + +Returns the next item in the data set or undef if the iterator is on the +last item. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.59, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template> diff --git a/lib/Template/Namespace/Constants.pm b/lib/Template/Namespace/Constants.pm new file mode 100644 index 0000000..76e5366 --- /dev/null +++ b/lib/Template/Namespace/Constants.pm @@ -0,0 +1,195 @@ +#================================================================= -*-Perl-*- +# +# Template::Namespace::Constants +# +# DESCRIPTION +# Plugin compiler module for performing constant folding at compile time +# on variables in a particular namespace. +# +# AUTHOR +# Andy Wardley <abw@andywardley.com> +# +# COPYRIGHT +# Copyright (C) 1996-2002 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# REVISION +# $Id: Constants.pm,v 1.17 2003/04/24 09:14:42 abw Exp $ +# +#============================================================================ + +package Template::Namespace::Constants; + +use strict; +use Template::Base; +use Template::Config; +use Template::Directive; +use Template::Exception; + +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG ); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; + + +sub _init { + my ($self, $config) = @_; + $self->{ STASH } = Template::Config->stash($config) + || return $self->error(Template::Config->error()); + return $self; +} + + + +#------------------------------------------------------------------------ +# ident(\@ident) foo.bar(baz) +#------------------------------------------------------------------------ + +sub ident { + my ($self, $ident) = @_; + my @save = @$ident; + + # discard first node indicating constants namespace + splice(@$ident, 0, 2); + + my $nelems = @$ident / 2; + my ($e, $result); + local $" = ', '; + + print STDERR "constant ident [ @$ident ] " if $DEBUG; + + foreach $e (0..$nelems-1) { + # node name must be a constant + unless ($ident->[$e * 2] =~ s/^'(.+)'$/$1/s) { + $self->DEBUG(" * deferred (non-constant item: ", $ident->[$e * 2], ")\n") + if $DEBUG; + return Template::Directive->ident(\@save); + } + + # if args is non-zero then it must be eval'ed + if ($ident->[$e * 2 + 1]) { + my $args = $ident->[$e * 2 + 1]; + my $comp = eval "$args"; + if ($@) { + $self->DEBUG(" * deferred (non-constant args: $args)\n") if $DEBUG; + return Template::Directive->ident(\@save); + } + $self->DEBUG("($args) ") if $comp && $DEBUG; + $ident->[$e * 2 + 1] = $comp; + } + } + + + $result = $self->{ STASH }->get($ident); + + if (! length $result || ref $result) { + my $reason = length $result ? 'reference' : 'no result'; + $self->DEBUG(" * deferred ($reason)\n") if $DEBUG; + return Template::Directive->ident(\@save); + } + + $result =~ s/'/\\'/g; + + $self->DEBUG(" * resolved => '$result'\n") if $DEBUG; + + return "'$result'"; +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Namespace::Constants - Compile time constant folding + +=head1 SYNOPSIS + + # easy way to define constants + use Template; + + my $tt = Template->new({ + CONSTANTS => { + pi => 3.14, + e => 2.718, + }, + }); + + # nitty-gritty, hands-dirty way + use Template::Namespace::Constants; + + my $tt = Template->new({ + NAMESPACE => { + constants => Template::Namespace::Constants->new({ + pi => 3.14, + e => 2.718, + }, + }, + }); + +=head1 DESCRIPTION + +The Template::Namespace::Constants module implements a namespace handler +which is plugged into the Template::Directive compiler module. This then +performs compile time constant folding of variables in a particular namespace. + +=head1 PUBLIC METHODS + +=head2 new(\%constants) + +The new() constructor method creates and returns a reference to a new +Template::Namespace::Constants object. This creates an internal stash +to store the constant variable definitions passed as arguments. + + my $handler = Template::Namespace::Constants->new({ + pi => 3.14, + e => 2.718, + }); + +=head2 ident(\@ident) + +Method called to resolve a variable identifier into a compiled form. In this +case, the method fetches the corresponding constant value from its internal +stash and returns it. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +1.17, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template::Directive|Template::Directive> diff --git a/lib/Template/Parser.pm b/lib/Template/Parser.pm new file mode 100644 index 0000000..34f777d --- /dev/null +++ b/lib/Template/Parser.pm @@ -0,0 +1,1434 @@ +#============================================================= -*-Perl-*- +# +# Template::Parser +# +# DESCRIPTION +# This module implements a LALR(1) parser and assocated support +# methods to parse template documents into the appropriate "compiled" +# format. Much of the parser DFA code (see _parse() method) is based +# on Francois Desarmenien's Parse::Yapp module. Kudos to him. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# The following copyright notice appears in the Parse::Yapp +# documentation. +# +# The Parse::Yapp module and its related modules and shell +# scripts are copyright (c) 1998 Francois Desarmenien, +# France. All rights reserved. +# +# You may use and distribute them under the terms of either +# the GNU General Public License or the Artistic License, as +# specified in the Perl README file. +# +#---------------------------------------------------------------------------- +# +# $Id: Parser.pm,v 2.75 2003/07/01 12:44:56 darren Exp $ +# +#============================================================================ + +package Template::Parser; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $ERROR ); +use base qw( Template::Base ); +use vars qw( $TAG_STYLE $DEFAULT_STYLE $QUOTED_ESCAPES ); + +use Template::Constants qw( :status :chomp ); +use Template::Directive; +use Template::Grammar; + +# parser state constants +use constant CONTINUE => 0; +use constant ACCEPT => 1; +use constant ERROR => 2; +use constant ABORT => 3; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.75 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; +$ERROR = ''; + + +#======================================================================== +# -- COMMON TAG STYLES -- +#======================================================================== + +$TAG_STYLE = { + 'default' => [ '\[%', '%\]' ], + 'template1' => [ '[\[%]%', '%[\]%]' ], + 'metatext' => [ '%%', '%%' ], + 'html' => [ '<!--', '-->' ], + 'mason' => [ '<%', '>' ], + 'asp' => [ '<%', '%>' ], + 'php' => [ '<\?', '\?>' ], + 'star' => [ '\[\*', '\*\]' ], +}; +$TAG_STYLE->{ template } = $TAG_STYLE->{ tt2 } = $TAG_STYLE->{ default }; + + +$DEFAULT_STYLE = { + START_TAG => $TAG_STYLE->{ default }->[0], + END_TAG => $TAG_STYLE->{ default }->[1], +# TAG_STYLE => 'default', + ANYCASE => 0, + INTERPOLATE => 0, + PRE_CHOMP => 0, + POST_CHOMP => 0, + V1DOLLAR => 0, + EVAL_PERL => 0, +}; + +$QUOTED_ESCAPES = { + n => "\n", + r => "\r", + t => "\t", +}; + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%config) +# +# Constructor method. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my $config = $_[0] && UNIVERSAL::isa($_[0], 'HASH') ? shift(@_) : { @_ }; + my ($tagstyle, $debug, $start, $end, $defaults, $grammar, $hash, $key, $udef); + + my $self = bless { + START_TAG => undef, + END_TAG => undef, + TAG_STYLE => 'default', + ANYCASE => 0, + INTERPOLATE => 0, + PRE_CHOMP => 0, + POST_CHOMP => 0, + V1DOLLAR => 0, + EVAL_PERL => 0, + GRAMMAR => undef, + _ERROR => '', + FACTORY => 'Template::Directive', + }, $class; + + # update self with any relevant keys in config + foreach $key (keys %$self) { + $self->{ $key } = $config->{ $key } if defined $config->{ $key }; + } + $self->{ FILEINFO } = [ ]; + + # DEBUG config item can be a bitmask + if (defined ($debug = $config->{ DEBUG })) { + $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PARSER + | Template::Constants::DEBUG_FLAGS ); + $self->{ DEBUG_DIRS } = $debug & Template::Constants::DEBUG_DIRS; + } + # package variable can be set to 1 to support previous behaviour + elsif ($DEBUG == 1) { + $self->{ DEBUG } = Template::Constants::DEBUG_PARSER; + $self->{ DEBUG_DIRS } = 0; + } + # otherwise let $DEBUG be a bitmask + else { + $self->{ DEBUG } = $DEBUG & ( Template::Constants::DEBUG_PARSER + | Template::Constants::DEBUG_FLAGS ); + $self->{ DEBUG_DIRS } = $DEBUG & Template::Constants::DEBUG_DIRS; + } + + $grammar = $self->{ GRAMMAR } ||= do { + require Template::Grammar; + Template::Grammar->new(); + }; + + # build a FACTORY object to include any NAMESPACE definitions, + # but only if FACTORY isn't already an object + if ($config->{ NAMESPACE } && ! ref $self->{ FACTORY }) { + my $fclass = $self->{ FACTORY }; + $self->{ FACTORY } = $fclass->new( NAMESPACE => $config->{ NAMESPACE } ) + || return $class->error($fclass->error()); + } + + +# # determine START_TAG and END_TAG for specified (or default) TAG_STYLE +# $tagstyle = $self->{ TAG_STYLE } || 'default'; +# return $class->error("Invalid tag style: $tagstyle") +# unless defined ($start = $TAG_STYLE->{ $tagstyle }); +# ($start, $end) = @$start; +# +# $self->{ START_TAG } ||= $start; +# $self->{ END_TAG } ||= $end; + + # load grammar rules, states and lex table + @$self{ qw( LEXTABLE STATES RULES ) } + = @$grammar{ qw( LEXTABLE STATES RULES ) }; + + $self->new_style($config) + || return $class->error($self->error()); + + return $self; +} + + +#------------------------------------------------------------------------ +# new_style(\%config) +# +# Install a new (stacked) parser style. This feature is currently +# experimental but should mimic the previous behaviour with regard to +# TAG_STYLE, START_TAG, END_TAG, etc. +#------------------------------------------------------------------------ + +sub new_style { + my ($self, $config) = @_; + my $styles = $self->{ STYLE } ||= [ ]; + my ($tagstyle, $tags, $start, $end, $key); + + # clone new style from previous or default style + my $style = { %{ $styles->[-1] || $DEFAULT_STYLE } }; + + # expand START_TAG and END_TAG from specified TAG_STYLE + if ($tagstyle = $config->{ TAG_STYLE }) { + return $self->error("Invalid tag style: $tagstyle") + unless defined ($tags = $TAG_STYLE->{ $tagstyle }); + ($start, $end) = @$tags; + $config->{ START_TAG } ||= $start; + $config->{ END_TAG } ||= $end; + } + + foreach $key (keys %$DEFAULT_STYLE) { + $style->{ $key } = $config->{ $key } if defined $config->{ $key }; + } + push(@$styles, $style); + return $style; +} + + +#------------------------------------------------------------------------ +# old_style() +# +# Pop the current parser style and revert to the previous one. See +# new_style(). ** experimental ** +#------------------------------------------------------------------------ + +sub old_style { + my $self = shift; + my $styles = $self->{ STYLE }; + return $self->error('only 1 parser style remaining') + unless (@$styles > 1); + pop @$styles; + return $styles->[-1]; +} + + +#------------------------------------------------------------------------ +# parse($text, $data) +# +# Parses the text string, $text and returns a hash array representing +# the compiled template block(s) as Perl code, in the format expected +# by Template::Document. +#------------------------------------------------------------------------ + +sub parse { + my ($self, $text, $info) = @_; + my ($tokens, $block); + + $info->{ DEBUG } = $self->{ DEBUG_DIRS } + unless defined $info->{ DEBUG }; + +# print "info: { ", join(', ', map { "$_ => $info->{ $_ }" } keys %$info), " }\n"; + + # store for blocks defined in the template (see define_block()) + my $defblock = $self->{ DEFBLOCK } = { }; + my $metadata = $self->{ METADATA } = [ ]; + + $self->{ _ERROR } = ''; + + # split file into TEXT/DIRECTIVE chunks + $tokens = $self->split_text($text) + || return undef; ## RETURN ## + + push(@{ $self->{ FILEINFO } }, $info); + + # parse chunks + $block = $self->_parse($tokens, $info); + + pop(@{ $self->{ FILEINFO } }); + + return undef unless $block; ## RETURN ## + + $self->debug("compiled main template document block:\n$block") + if $self->{ DEBUG } & Template::Constants::DEBUG_PARSER; + + return { + BLOCK => $block, + DEFBLOCKS => $defblock, + METADATA => { @$metadata }, + }; +} + + + +#------------------------------------------------------------------------ +# split_text($text) +# +# Split input template text into directives and raw text chunks. +#------------------------------------------------------------------------ + +sub split_text { + my ($self, $text) = @_; + my ($pre, $dir, $prelines, $dirlines, $postlines, $chomp, $tags, @tags); + my $style = $self->{ STYLE }->[-1]; + my ($start, $end, $prechomp, $postchomp, $interp ) = + @$style{ qw( START_TAG END_TAG PRE_CHOMP POST_CHOMP INTERPOLATE ) }; + + my @tokens = (); + my $line = 1; + + return \@tokens ## RETURN ## + unless defined $text && length $text; + + # extract all directives from the text + while ($text =~ s/ + ^(.*?) # $1 - start of line up to directive + (?: + $start # start of tag + (.*?) # $2 - tag contents + $end # end of tag + ) + //sx) { + + ($pre, $dir) = ($1, $2); + $pre = '' unless defined $pre; + $dir = '' unless defined $dir; + + $postlines = 0; # denotes lines chomped + $prelines = ($pre =~ tr/\n//); # NULL - count only + $dirlines = ($dir =~ tr/\n//); # ditto + + # the directive CHOMP options may modify the preceding text + for ($dir) { + # remove leading whitespace and check for a '-' chomp flag + s/^([-+\#])?\s*//s; + if ($1 && $1 eq '#') { + # comment out entire directive except for any chomp flag + $dir = ($dir =~ /([-+])$/) ? $1 : ''; + } + else { + $chomp = ($1 && $1 eq '+') ? 0 : ($1 || $prechomp); +# my $space = $prechomp == &Template::Constants::CHOMP_COLLAPSE + my $space = $prechomp == CHOMP_COLLAPSE + ? ' ' : ''; + + # chomp off whitespace and newline preceding directive + $chomp and $pre =~ s/(\n|^)([ \t]*)\Z/($1||$2) ? $space : ''/me + and $1 eq "\n" + and $prelines++; + } + + # remove trailing whitespace and check for a '-' chomp flag + s/\s*([-+])?\s*$//s; + $chomp = ($1 && $1 eq '+') ? 0 : ($1 || $postchomp); + my $space = $postchomp == &Template::Constants::CHOMP_COLLAPSE + ? ' ' : ''; + + $postlines++ + if $chomp and $text =~ s/ + ^ + ([ \t]*)\n # whitespace to newline + (?:(.|\n)|$) # any char (not EOF) + / + (($1||$2) ? $space : '') . (defined $2 ? $2 : '') + /ex; + } + + # any text preceding the directive can now be added + if (length $pre) { + push(@tokens, $interp + ? [ $pre, $line, 'ITEXT' ] + : ('TEXT', $pre) ); + $line += $prelines; + } + + # and now the directive, along with line number information + if (length $dir) { + # the TAGS directive is a compile-time switch + if ($dir =~ /^TAGS\s+(.*)/i) { + my @tags = split(/\s+/, $1); + if (scalar @tags > 1) { + ($start, $end) = map { quotemeta($_) } @tags; + } + elsif ($tags = $TAG_STYLE->{ $tags[0] }) { + ($start, $end) = @$tags; + } + else { + warn "invalid TAGS style: $tags[0]\n"; + } + } + else { + # DIRECTIVE is pushed as [ $dirtext, $line_no(s), \@tokens ] + push(@tokens, [ $dir, + ($dirlines + ? sprintf("%d-%d", $line, $line + $dirlines) + : $line), + $self->tokenise_directive($dir) ]); + } + } + + # update line counter to include directive lines and any extra + # newline chomped off the start of the following text + $line += $dirlines + $postlines; + } + + # anything remaining in the string is plain text + push(@tokens, $interp + ? [ $text, $line, 'ITEXT' ] + : ( 'TEXT', $text) ) + if length $text; + + return \@tokens; ## RETURN ## +} + + + +#------------------------------------------------------------------------ +# interpolate_text($text, $line) +# +# Examines $text looking for any variable references embedded like +# $this or like ${ this }. +#------------------------------------------------------------------------ + +sub interpolate_text { + my ($self, $text, $line) = @_; + my @tokens = (); + my ($pre, $var, $dir); + + + while ($text =~ + / + ( (?: \\. | [^\$] ){1,3000} ) # escaped or non-'$' character [$1] + | + ( \$ (?: # embedded variable [$2] + (?: \{ ([^\}]*) \} ) # ${ ... } [$3] + | + ([\w\.]+) # $word [$4] + ) + ) + /gx) { + + ($pre, $var, $dir) = ($1, $3 || $4, $2); + + # preceding text + if (defined($pre) && length($pre)) { + $line += $pre =~ tr/\n//; + $pre =~ s/\\\$/\$/g; + push(@tokens, 'TEXT', $pre); + } + # $variable reference + if ($var) { + $line += $dir =~ tr/\n/ /; + push(@tokens, [ $dir, $line, $self->tokenise_directive($var) ]); + } + # other '$' reference - treated as text + elsif ($dir) { + $line += $dir =~ tr/\n//; + push(@tokens, 'TEXT', $dir); + } + } + + return \@tokens; +} + + + +#------------------------------------------------------------------------ +# tokenise_directive($text) +# +# Called by the private _parse() method when it encounters a DIRECTIVE +# token in the list provided by the split_text() or interpolate_text() +# methods. The directive text is passed by parameter. +# +# The method splits the directive into individual tokens as recognised +# by the parser grammar (see Template::Grammar for details). It +# constructs a list of tokens each represented by 2 elements, as per +# split_text() et al. The first element contains the token type, the +# second the token itself. +# +# The method tokenises the string using a complex (but fast) regex. +# For a deeper understanding of the regex magic at work here, see +# Jeffrey Friedl's excellent book "Mastering Regular Expressions", +# from O'Reilly, ISBN 1-56592-257-3 +# +# Returns a reference to the list of chunks (each one being 2 elements) +# identified in the directive text. On error, the internal _ERROR string +# is set and undef is returned. +#------------------------------------------------------------------------ + +sub tokenise_directive { + my ($self, $text, $line) = @_; + my ($token, $uctoken, $type, $lookup); + my $lextable = $self->{ LEXTABLE }; + my $style = $self->{ STYLE }->[-1]; + my ($anycase, $start, $end) = @$style{ qw( ANYCASE START_TAG END_TAG ) }; + my @tokens = ( ); + + while ($text =~ + / + # strip out any comments + (\#[^\n]*) + | + # a quoted phrase matches in $3 + (["']) # $2 - opening quote, ' or " + ( # $3 - quoted text buffer + (?: # repeat group (no backreference) + \\\\ # an escaped backslash \\ + | # ...or... + \\\2 # an escaped quote \" or \' (match $1) + | # ...or... + . # any other character + | \n + )*? # non-greedy repeat + ) # end of $3 + \2 # match opening quote + | + # an unquoted number matches in $4 + (-?\d+(?:\.\d+)?) # numbers + | + # filename matches in $5 + ( \/?\w+(?:(?:\/|::?)\w*)+ | \/\w+) + | + # an identifier matches in $6 + (\w+) # variable identifier + | + # an unquoted word or symbol matches in $7 + ( [(){}\[\]:;,\/\\] # misc parenthesis and symbols +# | \-> # arrow operator (for future?) + | [+\-*] # math operations + | \$\{? # dollar with option left brace + | => # like '=' + | [=!<>]?= | [!<>] # eqality tests + | &&? | \|\|? # boolean ops + | \.\.? # n..n sequence + | \S+ # something unquoted + ) # end of $7 + /gmxo) { + + # ignore comments to EOL + next if $1; + + # quoted string + if (defined ($token = $3)) { + # double-quoted string may include $variable references + if ($2 eq '"') { + if ($token =~ /[\$\\]/) { + $type = 'QUOTED'; + # unescape " and \ but leave \$ escaped so that + # interpolate_text() doesn't incorrectly treat it + # as a variable reference +# $token =~ s/\\([\\"])/$1/g; + for ($token) { + s/\\([^\$nrt])/$1/g; + s/\\([nrt])/$QUOTED_ESCAPES->{ $1 }/ge; + } + push(@tokens, ('"') x 2, + @{ $self->interpolate_text($token) }, + ('"') x 2); + next; + } + else { + $type = 'LITERAL'; + $token =~ s['][\\']g; + $token = "'$token'"; + } + } + else { + $type = 'LITERAL'; + $token = "'$token'"; + } + } + # number + elsif (defined ($token = $4)) { + $type = 'NUMBER'; + } + elsif (defined($token = $5)) { + $type = 'FILENAME'; + } + elsif (defined($token = $6)) { + # reserved words may be in lower case unless case sensitive + $uctoken = $anycase ? uc $token : $token; + if (defined ($type = $lextable->{ $uctoken })) { + $token = $uctoken; + } + else { + $type = 'IDENT'; + } + } + elsif (defined ($token = $7)) { + # reserved words may be in lower case unless case sensitive + $uctoken = $anycase ? uc $token : $token; + unless (defined ($type = $lextable->{ $uctoken })) { + $type = 'UNQUOTED'; + } + } + + push(@tokens, $type, $token); + +# print(STDERR " +[ $type, $token ]\n") +# if $DEBUG; + } + +# print STDERR "tokenise directive() returning:\n [ @tokens ]\n" +# if $DEBUG; + + return \@tokens; ## RETURN ## +} + + +#------------------------------------------------------------------------ +# define_block($name, $block) +# +# Called by the parser 'defblock' rule when a BLOCK definition is +# encountered in the template. The name of the block is passed in the +# first parameter and a reference to the compiled block is passed in +# the second. This method stores the block in the $self->{ DEFBLOCK } +# hash which has been initialised by parse() and will later be used +# by the same method to call the store() method on the calling cache +# to define the block "externally". +#------------------------------------------------------------------------ + +sub define_block { + my ($self, $name, $block) = @_; + my $defblock = $self->{ DEFBLOCK } + || return undef; + + $self->debug("compiled block '$name':\n$block") + if $self->{ DEBUG } & Template::Constants::DEBUG_PARSER; + + $defblock->{ $name } = $block; + + return undef; +} + +sub push_defblock { + my $self = shift; + my $stack = $self->{ DEFBLOCK_STACK } ||= []; + push(@$stack, $self->{ DEFBLOCK } ); + $self->{ DEFBLOCK } = { }; +} + +sub pop_defblock { + my $self = shift; + my $defs = $self->{ DEFBLOCK }; + my $stack = $self->{ DEFBLOCK_STACK } || return $defs; + return $defs unless @$stack; + $self->{ DEFBLOCK } = pop @$stack; + return $defs; +} + + +#------------------------------------------------------------------------ +# add_metadata(\@setlist) +#------------------------------------------------------------------------ + +sub add_metadata { + my ($self, $setlist) = @_; + my $metadata = $self->{ METADATA } + || return undef; + + push(@$metadata, @$setlist); + + return undef; +} + + +#======================================================================== +# ----- PRIVATE METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# _parse(\@tokens, \@info) +# +# Parses the list of input tokens passed by reference and returns a +# Template::Directive::Block object which contains the compiled +# representation of the template. +# +# This is the main parser DFA loop. See embedded comments for +# further details. +# +# On error, undef is returned and the internal _ERROR field is set to +# indicate the error. This can be retrieved by calling the error() +# method. +#------------------------------------------------------------------------ + +sub _parse { + my ($self, $tokens, $info) = @_; + my ($token, $value, $text, $line, $inperl); + my ($state, $stateno, $status, $action, $lookup, $coderet, @codevars); + my ($lhs, $len, $code); # rule contents + my $stack = [ [ 0, undef ] ]; # DFA stack + +# DEBUG +# local $" = ', '; + + # retrieve internal rule and state tables + my ($states, $rules) = @$self{ qw( STATES RULES ) }; + + # call the grammar set_factory method to install emitter factory + $self->{ GRAMMAR }->install_factory($self->{ FACTORY }); + + $line = $inperl = 0; + $self->{ LINE } = \$line; + $self->{ INPERL } = \$inperl; + + $status = CONTINUE; + my $in_string = 0; + + while(1) { + # get state number and state + $stateno = $stack->[-1]->[0]; + $state = $states->[$stateno]; + + # see if any lookaheads exist for the current state + if (exists $state->{'ACTIONS'}) { + + # get next token and expand any directives (i.e. token is an + # array ref) onto the front of the token list + while (! defined $token && @$tokens) { + $token = shift(@$tokens); + if (ref $token) { + ($text, $line, $token) = @$token; + if (ref $token) { + if ($info->{ DEBUG } && ! $in_string) { + # - - - - - - - - - - - - - - - - - - - - - - - - - + # This is gnarly. Look away now if you're easily + # frightened. We're pushing parse tokens onto the + # pending list to simulate a DEBUG directive like so: + # [% DEBUG msg line='20' text='INCLUDE foo' %] + # - - - - - - - - - - - - - - - - - - - - - - - - - + my $dtext = $text; + $dtext =~ s[(['\\])][\\$1]g; + unshift(@$tokens, + DEBUG => 'DEBUG', + IDENT => 'msg', + IDENT => 'line', + ASSIGN => '=', + LITERAL => "'$line'", + IDENT => 'text', + ASSIGN => '=', + LITERAL => "'$dtext'", + IDENT => 'file', + ASSIGN => '=', + LITERAL => "'$info->{ name }'", + (';') x 2, + @$token, + (';') x 2); + } + else { + unshift(@$tokens, @$token, (';') x 2); + } + $token = undef; # force redo + } + elsif ($token eq 'ITEXT') { + if ($inperl) { + # don't perform interpolation in PERL blocks + $token = 'TEXT'; + $value = $text; + } + else { + unshift(@$tokens, + @{ $self->interpolate_text($text, $line) }); + $token = undef; # force redo + } + } + } + else { + # toggle string flag to indicate if we're crossing + # a string boundary + $in_string = ! $in_string if $token eq '"'; + $value = shift(@$tokens); + } + }; + # clear undefined token to avoid 'undefined variable blah blah' + # warnings and let the parser logic pick it up in a minute + $token = '' unless defined $token; + + # get the next state for the current lookahead token + $action = defined ($lookup = $state->{'ACTIONS'}->{ $token }) + ? $lookup + : defined ($lookup = $state->{'DEFAULT'}) + ? $lookup + : undef; + } + else { + # no lookahead actions + $action = $state->{'DEFAULT'}; + } + + # ERROR: no ACTION + last unless defined $action; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # shift (+ive ACTION) + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if ($action > 0) { + push(@$stack, [ $action, $value ]); + $token = $value = undef; + redo; + }; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # reduce (-ive ACTION) + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ($lhs, $len, $code) = @{ $rules->[ -$action ] }; + + # no action imples ACCEPTance + $action + or $status = ACCEPT; + + # use dummy sub if code ref doesn't exist + $code = sub { $_[1] } + unless $code; + + @codevars = $len + ? map { $_->[1] } @$stack[ -$len .. -1 ] + : (); + + eval { + $coderet = &$code( $self, @codevars ); + }; + if ($@) { + my $err = $@; + chomp $err; + return $self->_parse_error($err); + } + + # reduce stack by $len + splice(@$stack, -$len, $len); + + # ACCEPT + return $coderet ## RETURN ## + if $status == ACCEPT; + + # ABORT + return undef ## RETURN ## + if $status == ABORT; + + # ERROR + last + if $status == ERROR; + } + continue { + push(@$stack, [ $states->[ $stack->[-1][0] ]->{'GOTOS'}->{ $lhs }, + $coderet ]), + } + + # ERROR ## RETURN ## + return $self->_parse_error('unexpected end of input') + unless defined $value; + + # munge text of last directive to make it readable +# $text =~ s/\n/\\n/g; + + return $self->_parse_error("unexpected end of directive", $text) + if $value eq ';'; # end of directive SEPARATOR + + return $self->_parse_error("unexpected token ($value)", $text); +} + + + +#------------------------------------------------------------------------ +# _parse_error($msg, $dirtext) +# +# Method used to handle errors encountered during the parse process +# in the _parse() method. +#------------------------------------------------------------------------ + +sub _parse_error { + my ($self, $msg, $text) = @_; + my $line = $self->{ LINE }; + $line = ref($line) ? $$line : $line; + $line = 'unknown' unless $line; + + $msg .= "\n [% $text %]" + if defined $text; + + return $self->error("line $line: $msg"); +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method returns a string representing the internal state of the +# object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $output = "[Template::Parser] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + foreach $key (qw( START_TAG END_TAG TAG_STYLE ANYCASE INTERPOLATE + PRE_CHOMP POST_CHOMP V1DOLLAR )) { + my $val = $self->{ $key }; + $val = '<undef>' unless defined $val; + $output .= sprintf($format, $key, $val); + } + + $output .= '}'; + return $output; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Parser - LALR(1) parser for compiling template documents + +=head1 SYNOPSIS + + use Template::Parser; + + $parser = Template::Parser->new(\%config); + $template = $parser->parse($text) + || die $parser->error(), "\n"; + +=head1 DESCRIPTION + +The Template::Parser module implements a LALR(1) parser and associated methods +for parsing template documents into Perl code. + +=head1 PUBLIC METHODS + +=head2 new(\%params) + +The new() constructor creates and returns a reference to a new +Template::Parser object. A reference to a hash may be supplied as a +parameter to provide configuration values. These may include: + +=over + + + + +=item START_TAG, END_TAG + +The START_TAG and END_TAG options are used to specify character +sequences or regular expressions that mark the start and end of a +template directive. The default values for START_TAG and END_TAG are +'[%' and '%]' respectively, giving us the familiar directive style: + + [% example %] + +Any Perl regex characters can be used and therefore should be escaped +(or use the Perl C<quotemeta> function) if they are intended to +represent literal characters. + + my $parser = Template::Parser->new({ + START_TAG => quotemeta('<+'), + END_TAG => quotemeta('+>'), + }); + +example: + + <+ INCLUDE foobar +> + +The TAGS directive can also be used to set the START_TAG and END_TAG values +on a per-template file basis. + + [% TAGS <+ +> %] + + + + + + +=item TAG_STYLE + +The TAG_STYLE option can be used to set both START_TAG and END_TAG +according to pre-defined tag styles. + + my $parser = Template::Parser->new({ + TAG_STYLE => 'star', + }); + +Available styles are: + + template [% ... %] (default) + template1 [% ... %] or %% ... %% (TT version 1) + metatext %% ... %% (Text::MetaText) + star [* ... *] (TT alternate) + php <? ... ?> (PHP) + asp <% ... %> (ASP) + mason <% ... > (HTML::Mason) + html <!-- ... --> (HTML comments) + +Any values specified for START_TAG and/or END_TAG will over-ride +those defined by a TAG_STYLE. + +The TAGS directive may also be used to set a TAG_STYLE + + [% TAGS html %] + <!-- INCLUDE header --> + + + + + + +=item PRE_CHOMP, POST_CHOMP + +Anything outside a directive tag is considered plain text and is +generally passed through unaltered (but see the INTERPOLATE option). +This includes all whitespace and newlines characters surrounding +directive tags. Directives that don't generate any output will leave +gaps in the output document. + +Example: + + Foo + [% a = 10 %] + Bar + +Output: + + Foo + + Bar + +The PRE_CHOMP and POST_CHOMP options can help to clean up some of this +extraneous whitespace. Both are disabled by default. + + my $parser = Template::Parser->new({ + PRE_CHOMP => 1, + POST_CHOMP => 1, + }); + +With PRE_CHOMP set to 1, the newline and whitespace preceding a directive +at the start of a line will be deleted. This has the effect of +concatenating a line that starts with a directive onto the end of the +previous line. + + Foo <----------. + | + ,---(PRE_CHOMP)----' + | + `-- [% a = 10 %] --. + | + ,---(POST_CHOMP)---' + | + `-> Bar + +With POST_CHOMP set to 1, any whitespace after a directive up to and +including the newline will be deleted. This has the effect of joining +a line that ends with a directive onto the start of the next line. + +If PRE_CHOMP or POST_CHOMP is set to 2, then instead of removing all +the whitespace, the whitespace will be collapsed to a single space. +This is useful for HTML, where (usually) a contiguous block of +whitespace is rendered the same as a single space. + +You may use the CHOMP_NONE, CHOMP_ALL, and CHOMP_COLLAPSE constants +from the Template::Constants module to deactivate chomping, remove +all whitespace, or collapse whitespace to a single space. + +PRE_CHOMP and POST_CHOMP can be activated for individual directives by +placing a '-' immediately at the start and/or end of the directive. + + [% FOREACH user = userlist %] + [%- user -%] + [% END %] + +The '-' characters activate both PRE_CHOMP and POST_CHOMP for the one +directive '[%- name -%]'. Thus, the template will be processed as if +written: + + [% FOREACH user = userlist %][% user %][% END %] + +Note that this is the same as if PRE_CHOMP and POST_CHOMP were set +to CHOMP_ALL; the only way to get the CHOMP_COLLAPSE behavior is +to set PRE_CHOMP or POST_CHOMP accordingly. If PRE_CHOMP or POST_CHOMP +is already set to CHOMP_COLLAPSE, using '-' will give you CHOMP_COLLAPSE +behavior, not CHOMP_ALL behavior. + +Similarly, '+' characters can be used to disable PRE_CHOMP or +POST_CHOMP (i.e. leave the whitespace/newline intact) options on a +per-directive basis. + + [% FOREACH user = userlist %] + User: [% user +%] + [% END %] + +With POST_CHOMP enabled, the above example would be parsed as if written: + + [% FOREACH user = userlist %]User: [% user %] + [% END %] + + + + + +=item INTERPOLATE + +The INTERPOLATE flag, when set to any true value will cause variable +references in plain text (i.e. not surrounded by START_TAG and END_TAG) +to be recognised and interpolated accordingly. + + my $parser = Template::Parser->new({ + INTERPOLATE => 1, + }); + +Variables should be prefixed by a '$' to identify them. Curly braces +can be used in the familiar Perl/shell style to explicitly scope the +variable name where required. + + # INTERPOLATE => 0 + <a href="http://[% server %]/[% help %]"> + <img src="[% images %]/help.gif"></a> + [% myorg.name %] + + # INTERPOLATE => 1 + <a href="http://$server/$help"> + <img src="$images/help.gif"></a> + $myorg.name + + # explicit scoping with { } + <img src="$images/${icon.next}.gif"> + +Note that a limitation in Perl's regex engine restricts the maximum length +of an interpolated template to around 32 kilobytes or possibly less. Files +that exceed this limit in size will typically cause Perl to dump core with +a segmentation fault. If you routinely process templates of this size +then you should disable INTERPOLATE or split the templates in several +smaller files or blocks which can then be joined backed together via +PROCESS or INCLUDE. + + + + + + + +=item ANYCASE + +By default, directive keywords should be expressed in UPPER CASE. The +ANYCASE option can be set to allow directive keywords to be specified +in any case. + + # ANYCASE => 0 (default) + [% INCLUDE foobar %] # OK + [% include foobar %] # ERROR + [% include = 10 %] # OK, 'include' is a variable + + # ANYCASE => 1 + [% INCLUDE foobar %] # OK + [% include foobar %] # OK + [% include = 10 %] # ERROR, 'include' is reserved word + +One side-effect of enabling ANYCASE is that you cannot use a variable +of the same name as a reserved word, regardless of case. The reserved +words are currently: + + GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER + IF UNLESS ELSE ELSIF FOR FOREACH WHILE SWITCH CASE + USE PLUGIN FILTER MACRO PERL RAWPERL BLOCK META + TRY THROW CATCH FINAL NEXT LAST BREAK RETURN STOP + CLEAR TO STEP AND OR NOT MOD DIV END + + +The only lower case reserved words that cannot be used for variables, +regardless of the ANYCASE option, are the operators: + + and or not mod div + + + + + + + + +=item V1DOLLAR + +In version 1 of the Template Toolkit, an optional leading '$' could be placed +on any template variable and would be silently ignored. + + # VERSION 1 + [% $foo %] === [% foo %] + [% $hash.$key %] === [% hash.key %] + +To interpolate a variable value the '${' ... '}' construct was used. +Typically, one would do this to index into a hash array when the key +value was stored in a variable. + +example: + + my $vars = { + users => { + aba => { name => 'Alan Aardvark', ... }, + abw => { name => 'Andy Wardley', ... }, + ... + }, + uid => 'aba', + ... + }; + + $template->process('user/home.html', $vars) + || die $template->error(), "\n"; + +'user/home.html': + + [% user = users.${uid} %] # users.aba + Name: [% user.name %] # Alan Aardvark + +This was inconsistent with double quoted strings and also the +INTERPOLATE mode, where a leading '$' in text was enough to indicate a +variable for interpolation, and the additional curly braces were used +to delimit variable names where necessary. Note that this use is +consistent with UNIX and Perl conventions, among others. + + # double quoted string interpolation + [% name = "$title ${user.name}" %] + + # INTERPOLATE = 1 + <img src="$images/help.gif"></a> + <img src="$images/${icon.next}.gif"> + +For version 2, these inconsistencies have been removed and the syntax +clarified. A leading '$' on a variable is now used exclusively to +indicate that the variable name should be interpolated +(e.g. subsituted for its value) before being used. The earlier example +from version 1: + + # VERSION 1 + [% user = users.${uid} %] + Name: [% user.name %] + +can now be simplified in version 2 as: + + # VERSION 2 + [% user = users.$uid %] + Name: [% user.name %] + +The leading dollar is no longer ignored and has the same effect of +interpolation as '${' ... '}' in version 1. The curly braces may +still be used to explicitly scope the interpolated variable name +where necessary. + +e.g. + + [% user = users.${me.id} %] + Name: [% user.name %] + +The rule applies for all variables, both within directives and in +plain text if processed with the INTERPOLATE option. This means that +you should no longer (if you ever did) add a leading '$' to a variable +inside a directive, unless you explicitly want it to be interpolated. + +One obvious side-effect is that any version 1 templates with variables +using a leading '$' will no longer be processed as expected. Given +the following variable definitions, + + [% foo = 'bar' + bar = 'baz' + %] + +version 1 would interpret the following as: + + # VERSION 1 + [% $foo %] => [% GET foo %] => bar + +whereas version 2 interprets it as: + + # VERSION 2 + [% $foo %] => [% GET $foo %] => [% GET bar %] => baz + +In version 1, the '$' is ignored and the value for the variable 'foo' is +retrieved and printed. In version 2, the variable '$foo' is first interpolated +to give the variable name 'bar' whose value is then retrieved and printed. + +The use of the optional '$' has never been strongly recommended, but +to assist in backwards compatibility with any version 1 templates that +may rely on this "feature", the V1DOLLAR option can be set to 1 +(default: 0) to revert the behaviour and have leading '$' characters +ignored. + + my $parser = Template::Parser->new({ + V1DOLLAR => 1, + }); + + + + + + +=item GRAMMAR + +The GRAMMAR configuration item can be used to specify an alternate +grammar for the parser. This allows a modified or entirely new +template language to be constructed and used by the Template Toolkit. + +Source templates are compiled to Perl code by the Template::Parser +using the Template::Grammar (by default) to define the language +structure and semantics. Compiled templates are thus inherently +"compatible" with each other and there is nothing to prevent any +number of different template languages being compiled and used within +the same Template Toolkit processing environment (other than the usual +time and memory constraints). + +The Template::Grammar file is constructed from a YACC like grammar +(using Parse::YAPP) and a skeleton module template. These files are +provided, along with a small script to rebuild the grammar, in the +'parser' sub-directory of the distribution. You don't have to know or +worry about these unless you want to hack on the template language or +define your own variant. There is a README file in the same directory +which provides some small guidance but it is assumed that you know +what you're doing if you venture herein. If you grok LALR parsers, +then you should find it comfortably familiar. + +By default, an instance of the default Template::Grammar will be +created and used automatically if a GRAMMAR item isn't specified. + + use MyOrg::Template::Grammar; + + my $parser = Template::Parser->new({ + GRAMMAR = MyOrg::Template::Grammar->new(); + }); + + + +=item DEBUG + +The DEBUG option can be used to enable various debugging features +of the Template::Parser module. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_PARSER | DEBUG_DIRS, + }); + +The DEBUG value can include any of the following. Multiple values +should be combined using the logical OR operator, '|'. + +=over 4 + +=item DEBUG_PARSER + +This flag causes the L<Template::Parser|Template::Parser> to generate +debugging messages that show the Perl code generated by parsing and +compiling each template. + +=item DEBUG_DIRS + +This option causes the Template Toolkit to generate comments +indicating the source file, line and original text of each directive +in the template. These comments are embedded in the template output +using the format defined in the DEBUG_FORMAT configuration item, or a +simple default format if unspecified. + +For example, the following template fragment: + + + Hello World + +would generate this output: + + ## input text line 1 : ## + Hello + ## input text line 2 : World ## + World + + +=back + + + + +=back + +=head2 parse($text) + +The parse() method parses the text passed in the first parameter and +returns a reference to a Template::Document object which contains the +compiled representation of the template text. On error, undef is +returned. + +Example: + + $doc = $parser->parse($text) + || die $parser->error(); + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + + + +=head1 VERSION + +2.75, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + + + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + +The original Template::Parser module was derived from a standalone +parser generated by version 0.16 of the Parse::Yapp module. The +following copyright notice appears in the Parse::Yapp documentation. + + The Parse::Yapp module and its related modules and shell + scripts are copyright (c) 1998 Francois Desarmenien, + France. All rights reserved. + + You may use and distribute them under the terms of either + the GNU General Public License or the Artistic License, as + specified in the Perl README file. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Grammar|Template::Grammar>, L<Template::Directive|Template::Directive> + diff --git a/lib/Template/Plugin.pm b/lib/Template/Plugin.pm new file mode 100644 index 0000000..664ac96 --- /dev/null +++ b/lib/Template/Plugin.pm @@ -0,0 +1,399 @@ +#============================================================= -*-Perl-*- +# +# Template::Plugin +# +# DESCRIPTION +# +# Module defining a base class for a plugin object which can be loaded +# and instantiated via the USE directive. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Plugin.pm,v 2.60 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Plugin; + +require 5.004; + +use strict; +use Template::Base; + +use vars qw( $VERSION $DEBUG $ERROR $AUTOLOAD ); +use base qw( Template::Base ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.60 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0; + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# load() +# +# Class method called when the plugin module is first loaded. It +# returns the name of a class (by default, its own class) or a prototype +# object which will be used to instantiate new objects. The new() +# method is then called against the class name (class method) or +# prototype object (object method) to create a new instances of the +# object. +#------------------------------------------------------------------------ + +sub load { + return $_[0]; +} + + +#------------------------------------------------------------------------ +# new($context, $delegate, @params) +# +# Object constructor which is called by the Template::Context to +# instantiate a new Plugin object. This base class constructor is +# used as a general mechanism to load and delegate to other Perl +# modules. The context is passed as the first parameter, followed by +# a reference to a delegate object or the name of the module which +# should be loaded and instantiated. Any additional parameters passed +# to the USE directive are forwarded to the new() constructor. +# +# A plugin object is returned which has an AUTOLOAD method to delegate +# requests to the underlying object. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + bless { + }, $class; +} + +sub old_new { + my ($class, $context, $delclass, @params) = @_; + my ($delegate, $delmod); + + return $class->error("no context passed to $class constructor\n") + unless defined $context; + + if (ref $delclass) { + # $delclass contains a reference to a delegate object + $delegate = $delclass; + } + else { + # delclass is the name of a module to load and instantiate + ($delmod = $delclass) =~ s|::|/|g; + + eval { + require "$delmod.pm"; + $delegate = $delclass->new(@params) + || die "failed to instantiate $delclass object\n"; + }; + return $class->error($@) if $@; + } + + bless { + _CONTEXT => $context, + _DELEGATE => $delegate, + _PARAMS => \@params, + }, $class; +} + + +#------------------------------------------------------------------------ +# fail($error) +# +# Version 1 error reporting function, now replaced by error() inherited +# from Template::Base. Raises a "deprecated function" warning and then +# calls error(). +#------------------------------------------------------------------------ + +sub fail { + my $class = shift; + my ($pkg, $file, $line) = caller(); + warn "Template::Plugin::fail() is deprecated at $file line $line. Please use error()\n"; + $class->error(@_); +} + + +#======================================================================== +# ----- OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# General catch-all method which delegates all calls to the _DELEGATE +# object. +#------------------------------------------------------------------------ + +sub OLD_AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + + if (ref $self eq 'HASH') { + my $delegate = $self->{ _DELEGATE } || return; + return $delegate->$method(@_); + } + my ($pkg, $file, $line) = caller(); +# warn "no such '$method' method called on $self at $file line $line\n"; + return undef; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Plugin - Base class for Template Toolkit plugins + +=head1 SYNOPSIS + + package MyOrg::Template::Plugin::MyPlugin; + use base qw( Template::Plugin ); + use Template::Plugin; + use MyModule; + + sub new { + my $class = shift; + my $context = shift; + bless { + ... + }, $class; + } + +=head1 DESCRIPTION + +A "plugin" for the Template Toolkit is simply a Perl module which +exists in a known package location (e.g. Template::Plugin::*) and +conforms to a regular standard, allowing it to be loaded and used +automatically. + +The Template::Plugin module defines a base class from which other +plugin modules can be derived. A plugin does not have to be derived +from Template::Plugin but should at least conform to its object-oriented +interface. + +It is recommended that you create plugins in your own package namespace +to avoid conflict with toolkit plugins. e.g. + + package MyOrg::Template::Plugin::FooBar; + +Use the PLUGIN_BASE option to specify the namespace that you use. e.g. + + use Template; + my $template = Template->new({ + PLUGIN_BASE => 'MyOrg::Template::Plugin', + }); + +=head1 PLUGIN API + +The following methods form the basic interface between the Template +Toolkit and plugin modules. + +=over 4 + +=item load($context) + +This method is called by the Template Toolkit when the plugin module +is first loaded. It is called as a package method and thus implicitly +receives the package name as the first parameter. A reference to the +Template::Context object loading the plugin is also passed. The +default behaviour for the load() method is to simply return the class +name. The calling context then uses this class name to call the new() +package method. + + package MyPlugin; + + sub load { # called as MyPlugin->load($context) + my ($class, $context) = @_; + return $class; # returns 'MyPlugin' + } + +=item new($context, @params) + +This method is called to instantiate a new plugin object for the USE +directive. It is called as a package method against the class name +returned by load(). A reference to the Template::Context object creating +the plugin is passed, along with any additional parameters specified in +the USE directive. + + sub new { # called as MyPlugin->new($context) + my ($class, $context, @params) = @_; + bless { + _CONTEXT => $context, + }, $class; # returns blessed MyPlugin object + } + +=item error($error) + +This method, inherited from the Template::Base module, is used for +reporting and returning errors. It can be called as a package method +to set/return the $ERROR package variable, or as an object method to +set/return the object _ERROR member. When called with an argument, it +sets the relevant variable and returns undef. When called without an +argument, it returns the value of the variable. + + sub new { + my ($class, $context, $dsn) = @_; + + return $class->error('No data source specified') + unless $dsn; + + bless { + _DSN => $dsn, + }, $class; + } + + ... + + my $something = MyModule->new() + || die MyModule->error(), "\n"; + + $something->do_something() + || die $something->error(), "\n"; + +=back + +=head1 DEEPER MAGIC + +The Template::Context object that handles the loading and use of +plugins calls the new() and error() methods against the package name +returned by the load() method. In pseudo-code terms, it might look +something like this: + + $class = MyPlugin->load($context); # returns 'MyPlugin' + + $object = $class->new($context, @params) # MyPlugin->new(...) + || die $class->error(); # MyPlugin->error() + +The load() method may alterately return a blessed reference to an +object instance. In this case, new() and error() are then called as +I<object> methods against that prototype instance. + + package YourPlugin; + + sub load { + my ($class, $context) = @_; + bless { + _CONTEXT => $context, + }, $class; + } + + sub new { + my ($self, $context, @params) = @_; + return $self; + } + +In this example, we have implemented a 'Singleton' plugin. One object +gets created when load() is called and this simply returns itself for +each call to new(). + +Another implementation might require individual objects to be created +for every call to new(), but with each object sharing a reference to +some other object to maintain cached data, database handles, etc. +This pseudo-code example demonstrates the principle. + + package MyServer; + + sub load { + my ($class, $context) = @_; + bless { + _CONTEXT => $context, + _CACHE => { }, + }, $class; + } + + sub new { + my ($self, $context, @params) = @_; + MyClient->new($self, @params); + } + + sub add_to_cache { ... } + + sub get_from_cache { ... } + + + package MyClient; + + sub new { + my ($class, $server, $blah) = @_; + bless { + _SERVER => $server, + _BLAH => $blah, + }, $class; + } + + sub get { + my $self = shift; + $self->{ _SERVER }->get_from_cache(@_); + } + + sub put { + my $self = shift; + $self->{ _SERVER }->add_to_cache(@_); + } + +When the plugin is loaded, a MyServer instance is created. The new() +method is called against this object which instantiates and returns a +MyClient object, primed to communicate with the creating MyServer. + +=head1 Template::Plugin Delegation + +As of version 2.01, the Template::Plugin module no longer provides an +AUTOLOAD method to delegate to other objects or classes. This was a +badly designed feature that caused more trouble than good. You can +easily add your own AUTOLOAD method to perform delegation if you +require this kind of functionality. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.60, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Plugins|Template::Plugins>, L<Template::Context|Template::Context> diff --git a/lib/Template/Plugin/Date.pm b/lib/Template/Plugin/Date.pm new file mode 100644 index 0000000..1cd0a60 --- /dev/null +++ b/lib/Template/Plugin/Date.pm @@ -0,0 +1,361 @@ +#============================================================= -*-Perl-*- +# +# Template::Plugin::Date +# +# DESCRIPTION +# +# Plugin to generate formatted date strings. +# +# AUTHORS +# Thierry-Michel Barral <kktos@electron-libre.com> +# Andy Wardley <abw@cre.canon.co.uk> +# +# COPYRIGHT +# Copyright (C) 2000 Thierry-Michel Barral, Andy Wardley. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Date.pm,v 2.66 2003/04/24 09:14:43 abw Exp $ +# +#============================================================================ + +package Template::Plugin::Date; + +use strict; +use vars qw( $VERSION $FORMAT @LOCALE_SUFFIX ); +use base qw( Template::Plugin ); +use Template::Plugin; + +use POSIX (); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.66 $ =~ /(\d+)\.(\d+)/); +$FORMAT = '%H:%M:%S %d-%b-%Y'; # default strftime() format +@LOCALE_SUFFIX = qw( .ISO8859-1 .ISO_8859-15 .US-ASCII .UTF-8 ); + +#------------------------------------------------------------------------ +# new(\%options) +#------------------------------------------------------------------------ + +sub new { + my ($class, $context, $params) = @_; + bless { + $params ? %$params : () + }, $class; +} + + +#------------------------------------------------------------------------ +# now() +# +# Call time() to return the current system time in seconds since the epoch. +#------------------------------------------------------------------------ + +sub now { + return time(); +} + + +#------------------------------------------------------------------------ +# format() +# format($time) +# format($time, $format) +# format($time, $format, $locale) +# format($time, $format, $locale, $gmt_flag) +# format(\%named_params); +# +# Returns a formatted time/date string for the specified time, $time, +# (or the current system time if unspecified) using the $format, $locale, +# and $gmt values specified as arguments or internal values set defined +# at construction time). Specifying a Perl-true value for $gmt will +# override the local time zone and force the output to be for GMT. +# Any or all of the arguments may be specified as named parameters which +# get passed as a hash array reference as the final argument. +# ------------------------------------------------------------------------ + +sub format { + my $self = shift; + my $params = ref($_[$#_]) eq 'HASH' ? pop(@_) : { }; + my $time = shift(@_) || $params->{ time } || $self->{ time } + || $self->now(); + my $format = @_ ? shift(@_) + : ($params->{ format } || $self->{ format } || $FORMAT); + my $locale = @_ ? shift(@_) + : ($params->{ locale } || $self->{ locale }); + my $gmt = @_ ? shift(@_) + : ($params->{ gmt } || $self->{ gmt }); + my (@date, $datestr); + + if ($time =~ /^\d+$/) { + # $time is now in seconds since epoch + if ($gmt) { + @date = (gmtime($time))[0..6]; + } + else { + @date = (localtime($time))[0..6]; + } + } + else { + # if $time is numeric, then we assume it's seconds since the epoch + # otherwise, we try to parse it as a 'H:M:S D:M:Y' string + @date = (split(/(?:\/| |:|-)/, $time))[2,1,0,3..5]; + return (undef, Template::Exception->new('date', + "bad time/date string: expects 'h:m:s d:m:y' got: '$time'")) + unless @date >= 6 && defined $date[5]; + $date[4] -= 1; # correct month number 1-12 to range 0-11 + $date[5] -= 1900; # convert absolute year to years since 1900 + $time = &POSIX::mktime(@date); + } + + if ($locale) { + # format the date in a specific locale, saving and subsequently + # restoring the current locale. + my $old_locale = &POSIX::setlocale(&POSIX::LC_ALL); + + # some systems expect locales to have a particular suffix + for my $suffix ('', @LOCALE_SUFFIX) { + my $try_locale = $locale.$suffix; + my $setlocale = &POSIX::setlocale(&POSIX::LC_ALL, $try_locale); + if (defined $setlocale && $try_locale eq $setlocale) { + $locale = $try_locale; + last; + } + } + $datestr = &POSIX::strftime($format, @date); + &POSIX::setlocale(&POSIX::LC_ALL, $old_locale); + } + else { + $datestr = &POSIX::strftime($format, @date); + } + + return $datestr; +} + +sub calc { + my $self = shift; + eval { require "Date/Calc.pm" }; + $self->throw("failed to load Date::Calc: $@") if $@; + return Template::Plugin::Date::Calc->new('no context'); +} + +sub manip { + my $self = shift; + eval { require "Date/Manip.pm" }; + $self->throw("failed to load Date::Manip: $@") if $@; + return Template::Plugin::Date::Manip->new('no context'); +} + + +sub throw { + my $self = shift; + die (Template::Exception->new('date', join(', ', @_))); +} + + +package Template::Plugin::Date::Calc; +use base qw( Template::Plugin ); +use vars qw( $AUTOLOAD ); +*throw = \&Template::Plugin::Date::throw; + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + + my $sub = \&{"Date::Calc::$method"}; + $self->throw("no such Date::Calc method: $method") + unless $sub; + + &$sub(@_); +} + +package Template::Plugin::Date::Manip; +use base qw( Template::Plugin ); +use vars qw( $AUTOLOAD ); +*throw = \&Template::Plugin::Date::throw; + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + + my $sub = \&{"Date::Manip::$method"}; + $self->throw("no such Date::Manip method: $method") + unless $sub; + + &$sub(@_); +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Plugin::Date - Plugin to generate formatted date strings + +=head1 SYNOPSIS + + [% USE date %] + + # use current time and default format + [% date.format %] + + # specify time as seconds since epoch or 'h:m:s d-m-y' string + [% date.format(960973980) %] + [% date.format('4:20:36 21/12/2000') %] + + # specify format + [% date.format(mytime, '%H:%M:%S') %] + + # specify locale + [% date.format(date.now, '%a %d %b %y', 'en_GB') %] + + # named parameters + [% date.format(mytime, format = '%H:%M:%S') %] + [% date.format(locale = 'en_GB') %] + [% date.format(time = date.now, + format = '%H:%M:%S', + locale = 'en_GB) %] + + # specify default format to plugin + [% USE date(format = '%H:%M:%S', locale = 'de_DE') %] + + [% date.format %] + ... + +=head1 DESCRIPTION + +The Date plugin provides an easy way to generate formatted time and date +strings by delegating to the POSIX strftime() routine. + +The plugin can be loaded via the familiar USE directive. + + [% USE date %] + +This creates a plugin object with the default name of 'date'. An alternate +name can be specified as such: + + [% USE myname = date %] + +The plugin provides the format() method which accepts a time value, a +format string and a locale name. All of these parameters are optional +with the current system time, default format ('%H:%M:%S %d-%b-%Y') and +current locale being used respectively, if undefined. Default values +for the time, format and/or locale may be specified as named parameters +in the USE directive. + + [% USE date(format = '%a %d-%b-%Y', locale = 'fr_FR') %] + +When called without any parameters, the format() method returns a string +representing the current system time, formatted by strftime() according +to the default format and for the default locale (which may not be the +current one, if locale is set in the USE directive). + + [% date.format %] + +The plugin allows a time/date to be specified as seconds since the epoch, +as is returned by time(). + + File last modified: [% date.format(filemod_time) %] + +The time/date can also be specified as a string of the form 'h:m:s d/m/y'. +Any of the characters : / - or space may be used to delimit fields. + + [% USE day = date(format => '%A', locale => 'en_GB') %] + [% day.format('4:20:00 9-13-2000') %] + +Output: + + Tuesday + +A format string can also be passed to the format() method, and a locale +specification may follow that. + + [% date.format(filemod, '%d-%b-%Y') %] + [% date.format(filemod, '%d-%b-%Y', 'en_GB') %] + +A fourth parameter allows you to force output in GMT, in the case of +seconds-since-the-epoch input: + + [% date.format(filemod, '%d-%b-%Y', 'en_GB', 1) %] + +Note that in this case, if the local time is not GMT, then also specifying +'%Z' (time zone) in the format parameter will lead to an extremely +misleading result. + +Any or all of these parameters may be named. Positional parameters +should always be in the order ($time, $format, $locale). + + [% date.format(format => '%H:%M:%S') %] + [% date.format(time => filemod, format => '%H:%M:%S') %] + [% date.format(mytime, format => '%H:%M:%S') %] + [% date.format(mytime, format => '%H:%M:%S', locale => 'fr_FR') %] + [% date.format(mytime, format => '%H:%M:%S', gmt => 1) %] + ...etc... + +The now() method returns the current system time in seconds since the +epoch. + + [% date.format(date.now, '%A') %] + +The calc() method can be used to create an interface to the Date::Calc +module (if installed on your system). + + [% calc = date.calc %] + [% calc.Monday_of_Week(22, 2001).join('/') %] + +The manip() method can be used to create an interface to the Date::Manip +module (if installed on your system). + + [% manip = date.manip %] + [% manip.UnixDate("Noon Yesterday","%Y %b %d %H:%M") %] + +=head1 AUTHORS + +Thierry-Michel Barral E<lt>kktos@electron-libre.comE<gt> wrote the original +plugin. + +Andy Wardley E<lt>abw@cre.canon.co.ukE<gt> provided some minor +fixups/enhancements, a test script and documentation. + +Mark D. Mills E<lt>mark@hostile.orgE<gt> cloned Date::Manip from the +cute Date::Calc sub-plugin. + +=head1 VERSION + +2.66, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + + + +=head1 COPYRIGHT + +Copyright (C) 2000 Thierry-Michel Barral, Andy Wardley. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template::Plugin|Template::Plugin>, L<POSIX|POSIX> + diff --git a/lib/Template/Plugins.pm b/lib/Template/Plugins.pm new file mode 100644 index 0000000..839c85e --- /dev/null +++ b/lib/Template/Plugins.pm @@ -0,0 +1,1031 @@ +#============================================================= -*-Perl-*- +# +# Template::Plugins +# +# DESCRIPTION +# Plugin provider which handles the loading of plugin modules and +# instantiation of plugin objects. +# +# AUTHORS +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Plugins.pm,v 2.65 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Plugins; + +require 5.004; + +use strict; +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG $STD_PLUGINS ); +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.65 $ =~ /(\d+)\.(\d+)/); + +$STD_PLUGINS = { + 'autoformat' => 'Template::Plugin::Autoformat', + 'cgi' => 'Template::Plugin::CGI', + 'datafile' => 'Template::Plugin::Datafile', + 'date' => 'Template::Plugin::Date', + 'debug' => 'Template::Plugin::Debug', + 'directory' => 'Template::Plugin::Directory', + 'dbi' => 'Template::Plugin::DBI', + 'dumper' => 'Template::Plugin::Dumper', + 'file' => 'Template::Plugin::File', + 'format' => 'Template::Plugin::Format', + 'html' => 'Template::Plugin::HTML', + 'image' => 'Template::Plugin::Image', + 'iterator' => 'Template::Plugin::Iterator', + 'pod' => 'Template::Plugin::Pod', + 'table' => 'Template::Plugin::Table', + 'url' => 'Template::Plugin::URL', + 'view' => 'Template::Plugin::View', + 'wrap' => 'Template::Plugin::Wrap', + 'xmlstyle' => 'Template::Plugin::XML::Style', +}; + + +#======================================================================== +# -- PUBLIC METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# fetch($name, \@args, $context) +# +# General purpose method for requesting instantiation of a plugin +# object. The name of the plugin is passed as the first parameter. +# The internal FACTORY lookup table is consulted to retrieve the +# appropriate factory object or class name. If undefined, the _load() +# method is called to attempt to load the module and return a factory +# class/object which is then cached for subsequent use. A reference +# to the calling context should be passed as the third parameter. +# This is passed to the _load() class method. The new() method is +# then called against the factory class name or prototype object to +# instantiate a new plugin object, passing any arguments specified by +# list reference as the second parameter. e.g. where $factory is the +# class name 'MyClass', the new() method is called as a class method, +# $factory->new(...), equivalent to MyClass->new(...) . Where +# $factory is a prototype object, the new() method is called as an +# object method, $myobject->new(...). This latter approach allows +# plugins to act as Singletons, cache shared data, etc. +# +# Returns a reference to a plugin, (undef, STATUS_DECLINE) to decline +# the request or ($error, STATUS_ERROR) on error. +#------------------------------------------------------------------------ + +sub fetch { + my ($self, $name, $args, $context) = @_; + my ($factory, $plugin, $error); + + $self->debug("fetch($name, ", + defined $args ? ('[ ', join(', ', @$args), ' ]') : '<no args>', ', ', + defined $context ? $context : '<no context>', + ')') if $self->{ DEBUG }; + + # NOTE: + # the $context ref gets passed as the first parameter to all regular + # plugins, but not to those loaded via LOAD_PERL; to hack around + # this until we have a better implementation, we pass the $args + # reference to _load() and let it unshift the first args in the + # LOAD_PERL case + + $args ||= [ ]; + unshift @$args, $context; + + $factory = $self->{ FACTORY }->{ $name } ||= do { + ($factory, $error) = $self->_load($name, $context); + return ($factory, $error) if $error; ## RETURN + $factory; + }; + + # call the new() method on the factory object or class name + eval { + if (ref $factory eq 'CODE') { + defined( $plugin = &$factory(@$args) ) + || die "$name plugin failed\n"; + } + else { + defined( $plugin = $factory->new(@$args) ) + || die "$name plugin failed: ", $factory->error(), "\n"; + } + }; + if ($error = $@) { +# chomp $error; + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR); + } + + return $plugin; +} + + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init(\%config) +# +# Private initialisation method. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $params) = @_; + my ($pbase, $plugins, $factory) = + @$params{ qw( PLUGIN_BASE PLUGINS PLUGIN_FACTORY ) }; + + $plugins ||= { }; + if (ref $pbase ne 'ARRAY') { + $pbase = $pbase ? [ $pbase ] : [ ]; + } + push(@$pbase, 'Template::Plugin'); + + $self->{ PLUGIN_BASE } = $pbase; + $self->{ PLUGINS } = { %$STD_PLUGINS, %$plugins }; + $self->{ TOLERANT } = $params->{ TOLERANT } || 0; + $self->{ LOAD_PERL } = $params->{ LOAD_PERL } || 0; + $self->{ FACTORY } = $factory || { }; + $self->{ DEBUG } = ( $params->{ DEBUG } || 0 ) + & Template::Constants::DEBUG_PLUGINS; + + return $self; +} + + + +#------------------------------------------------------------------------ +# _load($name, $context) +# +# Private method which attempts to load a plugin module and determine the +# correct factory name or object by calling the load() class method in +# the loaded module. +#------------------------------------------------------------------------ + +sub _load { + my ($self, $name, $context) = @_; + my ($factory, $module, $base, $pkg, $file, $ok, $error); + + if ($module = $self->{ PLUGINS }->{ $name }) { + # plugin module name is explicitly stated in PLUGIN_NAME + $pkg = $module; + ($file = $module) =~ s|::|/|g; + $file =~ s|::|/|g; + $self->debug("loading $module.pm (PLUGIN_NAME)") + if $self->{ DEBUG }; + $ok = eval { require "$file.pm" }; + $error = $@; + } + else { + # try each of the PLUGIN_BASE values to build module name + ($module = $name) =~ s/\./::/g; + + foreach $base (@{ $self->{ PLUGIN_BASE } }) { + $pkg = $base . '::' . $module; + ($file = $pkg) =~ s|::|/|g; + + $self->debug("loading $file.pm (PLUGIN_BASE)") + if $self->{ DEBUG }; + + $ok = eval { require "$file.pm" }; + last unless $@; + + $error .= "$@\n" + unless ($@ =~ /^Can\'t locate $file\.pm/); + } + } + + if ($ok) { + $self->debug("calling $pkg->load()") if $self->{ DEBUG }; + + $factory = eval { $pkg->load($context) }; + $error = ''; + if ($@ || ! $factory) { + $error = $@ || 'load() returned a false value'; + } + } + elsif ($self->{ LOAD_PERL }) { + # fallback - is it a regular Perl module? + ($file = $module) =~ s|::|/|g; + eval { require "$file.pm" }; + if ($@) { + $error = $@; + } + else { + # this is a regular Perl module so the new() constructor + # isn't expecting a $context reference as the first argument; + # so we construct a closure which removes it before calling + # $module->new(@_); + $factory = sub { + shift; + $module->new(@_); + }; + $error = ''; + } + } + + if ($factory) { + $self->debug("$name => $factory") if $self->{ DEBUG }; + return $factory; + } + elsif ($error) { + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR); + } + else { + return (undef, Template::Constants::STATUS_DECLINED); + } +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which constructs and returns text representing the current +# state of the object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $output = "[Template::Plugins] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + foreach $key (qw( TOLERANT LOAD_PERL )) { + $output .= sprintf($format, $key, $self->{ $key }); + } + + local $" = ', '; + my $fkeys = join(", ", keys %{$self->{ FACTORY }}); + my $plugins = $self->{ PLUGINS }; + $plugins = join('', map { + sprintf(" $format", $_, $plugins->{ $_ }); + } keys %$plugins); + $plugins = "{\n$plugins }"; + + $output .= sprintf($format, 'PLUGIN_BASE', "[ @{ $self->{ PLUGIN_BASE } } ]"); + $output .= sprintf($format, 'PLUGINS', $plugins); + $output .= sprintf($format, 'FACTORY', $fkeys); + $output .= '}'; + return $output; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Plugins - Plugin provider module + +=head1 SYNOPSIS + + use Template::Plugins; + + $plugin_provider = Template::Plugins->new(\%options); + + ($plugin, $error) = $plugin_provider->fetch($name, @args); + +=head1 DESCRIPTION + +The Template::Plugins module defines a provider class which can be used +to load and instantiate Template Toolkit plugin modules. + +=head1 METHODS + +=head2 new(\%params) + +Constructor method which instantiates and returns a reference to a +Template::Plugins object. A reference to a hash array of configuration +items may be passed as a parameter. These are described below. + +Note that the Template.pm front-end module creates a Template::Plugins +provider, passing all configuration items. Thus, the examples shown +below in the form: + + $plugprov = Template::Plugins->new({ + PLUGIN_BASE => 'MyTemplate::Plugin', + LOAD_PERL => 1, + ... + }); + +can also be used via the Template module as: + + $ttengine = Template->new({ + PLUGIN_BASE => 'MyTemplate::Plugin', + LOAD_PERL => 1, + ... + }); + +as well as the more explicit form of: + + $plugprov = Template::Plugins->new({ + PLUGIN_BASE => 'MyTemplate::Plugin', + LOAD_PERL => 1, + ... + }); + + $ttengine = Template->new({ + LOAD_PLUGINS => [ $plugprov ], + }); + +=head2 fetch($name, @args) + +Called to request that a plugin of a given name be provided. The relevant +module is first loaded (if necessary) and the load() class method called +to return the factory class name (usually the same package name) or a +factory object (a prototype). The new() method is then called as a +class or object method against the factory, passing all remaining +parameters. + +Returns a reference to a new plugin object or ($error, STATUS_ERROR) +on error. May also return (undef, STATUS_DECLINED) to decline to +serve the request. If TOLERANT is set then all errors will be +returned as declines. + +=head1 CONFIGURATION OPTIONS + +The following list details the configuration options that can be provided +to the Template::Plugins new() constructor. + +=over 4 + + + + +=item PLUGINS + +The PLUGINS options can be used to provide a reference to a hash array +that maps plugin names to Perl module names. A number of standard +plugins are defined (e.g. 'table', 'cgi', 'dbi', etc.) which map to +their corresponding Template::Plugin::* counterparts. These can be +redefined by values in the PLUGINS hash. + + my $plugins = Template::Plugins->new({ + PLUGINS => { + cgi => 'MyOrg::Template::Plugin::CGI', + foo => 'MyOrg::Template::Plugin::Foo', + bar => 'MyOrg::Template::Plugin::Bar', + }, + }); + +The USE directive is used to create plugin objects and does so by +calling the plugin() method on the current Template::Context object. +If the plugin name is defined in the PLUGINS hash then the +corresponding Perl module is loaded via require(). The context then +calls the load() class method which should return the class name +(default and general case) or a prototype object against which the +new() method can be called to instantiate individual plugin objects. + +If the plugin name is not defined in the PLUGINS hash then the PLUGIN_BASE +and/or LOAD_PERL options come into effect. + + + + + +=item PLUGIN_BASE + +If a plugin is not defined in the PLUGINS hash then the PLUGIN_BASE is used +to attempt to construct a correct Perl module name which can be successfully +loaded. + +The PLUGIN_BASE can be specified as a single value or as a reference +to an array of multiple values. The default PLUGIN_BASE value, +'Template::Plugin', is always added the the end of the PLUGIN_BASE +list (a single value is first converted to a list). Each value should +contain a Perl package name to which the requested plugin name is +appended. + +example 1: + + my $plugins = Template::Plugins->new({ + PLUGIN_BASE => 'MyOrg::Template::Plugin', + }); + + [% USE Foo %] # => MyOrg::Template::Plugin::Foo + or Template::Plugin::Foo + +example 2: + + my $plugins = Template::Plugins->new({ + PLUGIN_BASE => [ 'MyOrg::Template::Plugin', + 'YourOrg::Template::Plugin' ], + }); + + [% USE Foo %] # => MyOrg::Template::Plugin::Foo + or YourOrg::Template::Plugin::Foo + or Template::Plugin::Foo + + + + + + +=item LOAD_PERL + +If a plugin cannot be loaded using the PLUGINS or PLUGIN_BASE +approaches then the provider can make a final attempt to load the +module without prepending any prefix to the module path. This allows +regular Perl modules (i.e. those that don't reside in the +Template::Plugin or some other such namespace) to be loaded and used +as plugins. + +By default, the LOAD_PERL option is set to 0 and no attempt will be made +to load any Perl modules that aren't named explicitly in the PLUGINS +hash or reside in a package as named by one of the PLUGIN_BASE +components. + +Plugins loaded using the PLUGINS or PLUGIN_BASE receive a reference to +the current context object as the first argument to the new() +constructor. Modules loaded using LOAD_PERL are assumed to not +conform to the plugin interface. They must provide a new() class +method for instantiating objects but it will not receive a reference +to the context as the first argument. Plugin modules should provide a +load() class method (or inherit the default one from the +Template::Plugin base class) which is called the first time the plugin +is loaded. Regular Perl modules need not. In all other respects, +regular Perl objects and Template Toolkit plugins are identical. + +If a particular Perl module does not conform to the common, but not +unilateral, new() constructor convention then a simple plugin wrapper +can be written to interface to it. + + + + +=item TOLERANT + +The TOLERANT flag is used by the various Template Toolkit provider +modules (Template::Provider, Template::Plugins, Template::Filters) to +control their behaviour when errors are encountered. By default, any +errors are reported as such, with the request for the particular +resource (template, plugin, filter) being denied and an exception +raised. When the TOLERANT flag is set to any true values, errors will +be silently ignored and the provider will instead return +STATUS_DECLINED. This allows a subsequent provider to take +responsibility for providing the resource, rather than failing the +request outright. If all providers decline to service the request, +either through tolerated failure or a genuine disinclination to +comply, then a 'E<lt>resourceE<gt> not found' exception is raised. + + + + +=item DEBUG + +The DEBUG option can be used to enable debugging messages from the +Template::Plugins module by setting it to include the DEBUG_PLUGINS +value. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_FILTERS | DEBUG_PLUGINS, + }); + + + + +=back + + + +=head1 TEMPLATE TOOLKIT PLUGINS + +The following plugin modules are distributed with the Template +Toolkit. Some of the plugins interface to external modules (detailed +below) which should be downloaded from any CPAN site and installed +before using the plugin. + +=head2 Autoformat + +The Autoformat plugin is an interface to Damian Conway's Text::Autoformat +Perl module which provides advanced text wrapping and formatting. See +L<Template::Plugin::Autoformat> and L<Text::Autoformat> for further +details. + + [% USE autoformat(left=10, right=20) %] + [% autoformat(mytext) %] # call autoformat sub + [% mytext FILTER autoformat %] # or use autoformat filter + +The Text::Autoformat module is available from CPAN: + + http://www.cpan.org/modules/by-module/Text/ + +=head2 CGI + +The CGI plugin is a wrapper around Lincoln Stein's +E<lt>lstein@genome.wi.mit.eduE<gt> CGI.pm module. The plugin is +distributed with the Template Toolkit (see L<Template::Plugin::CGI>) +and the CGI module itself is distributed with recent versions Perl, +or is available from CPAN. + + [% USE CGI %] + [% CGI.param('param_name') %] + [% CGI.start_form %] + [% CGI.popup_menu( Name => 'color', + Values => [ 'Green', 'Brown' ] ) %] + [% CGI.end_form %] + +=head2 Datafile + +Provides an interface to data stored in a plain text file in a simple +delimited format. The first line in the file specifies field names +which should be delimiter by any non-word character sequence. +Subsequent lines define data using the same delimiter as int he first +line. Blank lines and comments (lines starting '#') are ignored. See +L<Template::Plugin::Datafile> for further details. + +/tmp/mydata: + + # define names for each field + id : email : name : tel + # here's the data + fred : fred@here.com : Fred Smith : 555-1234 + bill : bill@here.com : Bill White : 555-5678 + +example: + + [% USE userlist = datafile('/tmp/mydata') %] + + [% FOREACH user = userlist %] + [% user.name %] ([% user.id %]) + [% END %] + +=head2 Date + +The Date plugin provides an easy way to generate formatted time and date +strings by delegating to the POSIX strftime() routine. See +L<Template::Plugin::Date> and L<POSIX> for further details. + + [% USE date %] + [% date.format %] # current time/date + + File last modified: [% date.format(template.modtime) %] + +=head2 Directory + +The Directory plugin provides a simple interface to a directory and +the files within it. See L<Template::Plugin::Directory> for further +details. + + [% USE dir = Directory('/tmp') %] + [% FOREACH file = dir.files %] + # all the plain files in the directory + [% END %] + [% FOREACH file = dir.dirs %] + # all the sub-directories + [% END %] + +=head2 DBI + +The DBI plugin, developed by Simon Matthews +E<lt>sam@knowledgepool.comE<gt>, brings the full power of Tim Bunce's +E<lt>Tim.Bunce@ig.co.ukE<gt> database interface module (DBI) to your +templates. See L<Template::Plugin::DBI> and L<DBI> for further details. + + [% USE DBI('dbi:driver:database', 'user', 'pass') %] + + [% FOREACH user = DBI.query( 'SELECT * FROM users' ) %] + [% user.id %] [% user.name %] + [% END %] + +The DBI and relevant DBD modules are available from CPAN: + + http://www.cpan.org/modules/by-module/DBI/ + +=head2 Dumper + +The Dumper plugin provides an interface to the Data::Dumper module. See +L<Template::Plugin::Dumper> and L<Data::Dumper> for futher details. + + [% USE dumper(indent=0, pad="<br>") %] + [% dumper.dump(myvar, yourvar) %] + +=head2 File + +The File plugin provides a general abstraction for files and can be +used to fetch information about specific files within a filesystem. +See L<Template::Plugin::File> for further details. + + [% USE File('/tmp/foo.html') %] + [% File.name %] # foo.html + [% File.dir %] # /tmp + [% File.mtime %] # modification time + +=head2 Filter + +This module implements a base class plugin which can be subclassed +to easily create your own modules that define and install new filters. + + package MyOrg::Template::Plugin::MyFilter; + + use Template::Plugin::Filter; + use base qw( Template::Plugin::Filter ); + + sub filter { + my ($self, $text) = @_; + + # ...mungify $text... + + return $text; + } + + # now load it... + [% USE MyFilter %] + + # ...and use the returned object as a filter + [% FILTER $MyFilter %] + ... + [% END %] + +See L<Template::Plugin::Filter> for further details. + +=head2 Format + +The Format plugin provides a simple way to format text according to a +printf()-like format. See L<Template::Plugin::Format> for further +details. + + [% USE bold = format('<b>%s</b>') %] + [% bold('Hello') %] + +=head2 GD::Image, GD::Polygon, GD::Constants + +These plugins provide access to the GD graphics library via Lincoln +D. Stein's GD.pm interface. These plugins allow PNG, JPEG and other +graphical formats to be generated. + + [% FILTER null; + USE im = GD.Image(100,100); + # allocate some colors + black = im.colorAllocate(0, 0, 0); + red = im.colorAllocate(255,0, 0); + blue = im.colorAllocate(0, 0, 255); + # Draw a blue oval + im.arc(50,50,95,75,0,360,blue); + # And fill it with red + im.fill(50,50,red); + # Output image in PNG format + im.png | stdout(1); + END; + -%] + +See L<Template::Plugin::GD::Image> for further details. + +=head2 GD::Text, GD::Text::Align, GD::Text::Wrap + +These plugins provide access to Martien Verbruggen's GD::Text, +GD::Text::Align and GD::Text::Wrap modules. These plugins allow the +layout, alignment and wrapping of text when drawing text in GD images. + + [% FILTER null; + USE gd = GD.Image(200,400); + USE gdc = GD.Constants; + black = gd.colorAllocate(0, 0, 0); + green = gd.colorAllocate(0, 255, 0); + txt = "This is some long text. " | repeat(10); + USE wrapbox = GD.Text.Wrap(gd, + line_space => 4, + color => green, + text => txt, + ); + wrapbox.set_font(gdc.gdMediumBoldFont); + wrapbox.set(align => 'center', width => 160); + wrapbox.draw(20, 20); + gd.png | stdout(1); + END; + -%] + +See L<Template::Plugin::GD::Text>, L<Template::Plugin::GD::Text::Align> +and L<Template::Plugin::GD::Text::Wrap> for further details. + +=head2 GD::Graph::lines, GD::Graph::bars, GD::Graph::points, GD::Graph::linespoin +ts, GD::Graph::area, GD::Graph::mixed, GD::Graph::pie + +These plugins provide access to Martien Verbruggen's GD::Graph module +that allows graphs, plots and charts to be created. These plugins allow +graphs, plots and charts to be generated in PNG, JPEG and other +graphical formats. + + [% FILTER null; + data = [ + ["1st","2nd","3rd","4th","5th","6th"], + [ 4, 2, 3, 4, 3, 3.5] + ]; + USE my_graph = GD.Graph.pie(250, 200); + my_graph.set( + title => 'A Pie Chart', + label => 'Label', + axislabelclr => 'black', + pie_height => 36, + transparent => 0, + ); + my_graph.plot(data).png | stdout(1); + END; + -%] + +See +L<Template::Plugin::GD::Graph::lines>, +L<Template::Plugin::GD::Graph::bars>, +L<Template::Plugin::GD::Graph::points>, +L<Template::Plugin::GD::Graph::linespoints>, +L<Template::Plugin::GD::Graph::area>, +L<Template::Plugin::GD::Graph::mixed>, +L<Template::Plugin::GD::Graph::pie>, and +L<GD::Graph>, +for more details. + +=head2 GD::Graph::bars3d, GD::Graph::lines3d, GD::Graph::pie3d + +These plugins provide access to Jeremy Wadsack's GD::Graph3d +module. This allows 3D bar charts and 3D lines plots to +be generated. + + [% FILTER null; + data = [ + ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], + [ 1, 2, 5, 6, 3, 1.5, 1, 3, 4], + ]; + USE my_graph = GD.Graph.bars3d(); + my_graph.set( + x_label => 'X Label', + y_label => 'Y label', + title => 'A 3d Bar Chart', + y_max_value => 8, + y_tick_number => 8, + y_label_skip => 2, + # shadows + bar_spacing => 8, + shadow_depth => 4, + shadowclr => 'dred', + transparent => 0, + my_graph.plot(data).png | stdout(1); + END; + -%] + +See +L<Template::Plugin::GD::Graph::lines3d>, +L<Template::Plugin::GD::Graph::bars3d>, and +L<Template::Plugin::GD::Graph::pie3d> +for more details. + +=head2 HTML + +The HTML plugin is very new and very basic, implementing a few useful +methods for generating HTML. It is likely to be extended in the future +or integrated with a larger project to generate HTML elements in a generic +way (as discussed recently on the mod_perl mailing list). + + [% USE HTML %] + [% HTML.escape("if (a < b && c > d) ..." %] + [% HTML.attributes(border => 1, cellpadding => 2) %] + [% HTML.element(table => { border => 1, cellpadding => 2 }) %] + +See L<Template::Plugin::HTML> for further details. + +=head2 Iterator + +The Iterator plugin provides a way to create a Template::Iterator +object to iterate over a data set. An iterator is created +automatically by the FOREACH directive and is aliased to the 'loop' +variable. This plugin allows an iterator to be explicitly created +with a given name, or the default plugin name, 'iterator'. See +L<Template::Plugin::Iterator> for further details. + + [% USE iterator(list, args) %] + + [% FOREACH item = iterator %] + [% '<ul>' IF iterator.first %] + <li>[% item %] + [% '</ul>' IF iterator.last %] + [% END %] + +=head2 Pod + +This plugin provides an interface to the L<Pod::POM|Pod::POM> module +which parses POD documents into an internal object model which can +then be traversed and presented through the Template Toolkit. + + [% USE Pod(podfile) %] + + [% FOREACH head1 = Pod.head1; + FOREACH head2 = head1/head2; + ... + END; + END + %] + +=head2 String + +The String plugin implements an object-oriented interface for +manipulating strings. See L<Template::Plugin::String> for further +details. + + [% USE String 'Hello' %] + [% String.append(' World') %] + + [% msg = String.new('Another string') %] + [% msg.replace('string', 'text') %] + + The string "[% msg %]" is [% msg.length %] characters long. + +=head2 Table + +The Table plugin allows you to format a list of data items into a +virtual table by specifying a fixed number of rows or columns, with +an optional overlap. See L<Template::Plugin::Table> for further +details. + + [% USE table(list, rows=10, overlap=1) %] + + [% FOREACH item = table.col(3) %] + [% item %] + [% END %] + +=head2 URL + +The URL plugin provides a simple way of contructing URLs from a base +part and a variable set of parameters. See L<Template::Plugin::URL> +for further details. + + [% USE mycgi = url('/cgi-bin/bar.pl', debug=1) %] + + [% mycgi %] + # ==> /cgi/bin/bar.pl?debug=1 + + [% mycgi(mode='submit') %] + # ==> /cgi/bin/bar.pl?mode=submit&debug=1 + +=head2 Wrap + +The Wrap plugin uses the Text::Wrap module by David Muir Sharnoff +E<lt>muir@idiom.comE<gt> (with help from Tim Pierce and many many others) +to provide simple paragraph formatting. See L<Template::Plugin::Wrap> +and L<Text::Wrap> for further details. + + [% USE wrap %] + [% wrap(mytext, 40, '* ', ' ') %] # use wrap sub + [% mytext FILTER wrap(40) -%] # or wrap FILTER + +The Text::Wrap module is available from CPAN: + + http://www.cpan.org/modules/by-module/Text/ + +=head2 XML::DOM + +The XML::DOM plugin gives access to the XML Document Object Module via +Clark Cooper E<lt>cooper@sch.ge.comE<gt> and Enno Derksen's +E<lt>enno@att.comE<gt> XML::DOM module. See L<Template::Plugin::XML::DOM> +and L<XML::DOM> for further details. + + [% USE dom = XML.DOM %] + [% doc = dom.parse(filename) %] + + [% FOREACH node = doc.getElementsByTagName('CODEBASE') %] + * [% node.getAttribute('href') %] + [% END %] + +The plugin requires the XML::DOM module, available from CPAN: + + http://www.cpan.org/modules/by-module/XML/ + +=head2 XML::RSS + +The XML::RSS plugin is a simple interface to Jonathan Eisenzopf's +E<lt>eisen@pobox.comE<gt> XML::RSS module. A RSS (Rich Site Summary) +file is typically used to store short news 'headlines' describing +different links within a site. This plugin allows you to parse RSS +files and format the contents accordingly using templates. +See L<Template::Plugin::XML::RSS> and L<XML::RSS> for further details. + + [% USE news = XML.RSS(filename) %] + + [% FOREACH item = news.items %] + <a href="[% item.link %]">[% item.title %]</a> + [% END %] + +The XML::RSS module is available from CPAN: + + http://www.cpan.org/modules/by-module/XML/ + +=head2 XML::Simple + +This plugin implements an interface to the L<XML::Simple|XML::Simple> +module. + + [% USE xml = XML.Simple(xml_file_or_text) %] + + [% xml.head.title %] + +See L<Template::Plugin::XML::Simple> for further details. + +=head2 XML::Style + +This plugin defines a filter for performing simple stylesheet based +transformations of XML text. + + [% USE xmlstyle + table = { + attributes = { + border = 0 + cellpadding = 4 + cellspacing = 1 + } + } + %] + + [% FILTER xmlstyle %] + <table> + <tr> + <td>Foo</td> <td>Bar</td> <td>Baz</td> + </tr> + </table> + [% END %] + +See L<Template::Plugin::XML::Style> for further details. + +=head2 XML::XPath + +The XML::XPath plugin provides an interface to Matt Sergeant's +E<lt>matt@sergeant.orgE<gt> XML::XPath module. See +L<Template::Plugin::XML::XPath> and L<XML::XPath> for further details. + + [% USE xpath = XML.XPath(xmlfile) %] + [% FOREACH page = xpath.findnodes('/html/body/page') %] + [% page.getAttribute('title') %] + [% END %] + +The plugin requires the XML::XPath module, available from CPAN: + + http://www.cpan.org/modules/by-module/XML/ + + + + +=head1 BUGS / ISSUES + +=over 4 + +=item * + +It might be worthwhile being able to distinguish between absolute +module names and those which should be applied relative to PLUGIN_BASE +directories. For example, use 'MyNamespace::MyModule' to denote +absolute module names (e.g. LOAD_PERL), and 'MyNamespace.MyModule' to +denote relative to PLUGIN_BASE. + +=back + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.65, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Plugin|Template::Plugin>, L<Template::Context|Template::Context> diff --git a/lib/Template/Provider.pm b/lib/Template/Provider.pm new file mode 100644 index 0000000..ee599de --- /dev/null +++ b/lib/Template/Provider.pm @@ -0,0 +1,1433 @@ +#============================================================= -*-Perl-*- +# +# Template::Provider +# +# DESCRIPTION +# This module implements a class which handles the loading, compiling +# and caching of templates. Multiple Template::Provider objects can +# be stacked and queried in turn to effect a Chain-of-Command between +# them. A provider will attempt to return the requested template, +# an error (STATUS_ERROR) or decline to provide the template +# (STATUS_DECLINE), allowing subsequent providers to attempt to +# deliver it. See 'Design Patterns' for further details. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# TODO: +# * optional provider prefix (e.g. 'http:') +# * fold ABSOLUTE and RELATIVE test cases into one regex? +# +#---------------------------------------------------------------------------- +# +# $Id: Provider.pm,v 2.70 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Provider; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $ERROR $DOCUMENT $STAT_TTL $MAX_DIRS ); +use base qw( Template::Base ); +use Template::Config; +use Template::Constants; +use Template::Document; +use File::Basename; +use File::Spec; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.70 $ =~ /(\d+)\.(\d+)/); + +# name of document class +$DOCUMENT = 'Template::Document' unless defined $DOCUMENT; + +# maximum time between performing stat() on file to check staleness +$STAT_TTL = 1 unless defined $STAT_TTL; + +# maximum number of directories in an INCLUDE_PATH, to prevent runaways +$MAX_DIRS = 64 unless defined $MAX_DIRS; + +use constant PREV => 0; +use constant NAME => 1; +use constant DATA => 2; +use constant LOAD => 3; +use constant NEXT => 4; +use constant STAT => 5; + +$DEBUG = 0 unless defined $DEBUG; + +#======================================================================== +# -- PUBLIC METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# fetch($name) +# +# Returns a compiled template for the name specified by parameter. +# The template is returned from the internal cache if it exists, or +# loaded and then subsequently cached. The ABSOLUTE and RELATIVE +# configuration flags determine if absolute (e.g. '/something...') +# and/or relative (e.g. './something') paths should be honoured. The +# INCLUDE_PATH is otherwise used to find the named file. $name may +# also be a reference to a text string containing the template text, +# or a file handle from which the content is read. The compiled +# template is not cached in these latter cases given that there is no +# filename to cache under. A subsequent call to store($name, +# $compiled) can be made to cache the compiled template for future +# fetch() calls, if necessary. +# +# Returns a compiled template or (undef, STATUS_DECLINED) if the +# template could not be found. On error (e.g. the file was found +# but couldn't be read or parsed), the pair ($error, STATUS_ERROR) +# is returned. The TOLERANT configuration option can be set to +# downgrade any errors to STATUS_DECLINE. +#------------------------------------------------------------------------ + +sub fetch { + my ($self, $name) = @_; + my ($data, $error); + + if (ref $name) { + # $name can be a reference to a scalar, GLOB or file handle + ($data, $error) = $self->_load($name); + ($data, $error) = $self->_compile($data) + unless $error; + $data = $data->{ data } + unless $error; + } + elsif (File::Spec->file_name_is_absolute($name)) { + # absolute paths (starting '/') allowed if ABSOLUTE set + ($data, $error) = $self->{ ABSOLUTE } + ? $self->_fetch($name) + : $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ("$name: absolute paths are not allowed (set ABSOLUTE option)", + Template::Constants::STATUS_ERROR); + } + elsif ($name =~ m[^\.+/]) { + # anything starting "./" is relative to cwd, allowed if RELATIVE set + ($data, $error) = $self->{ RELATIVE } + ? $self->_fetch($name) + : $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ("$name: relative paths are not allowed (set RELATIVE option)", + Template::Constants::STATUS_ERROR); + } + else { + # otherwise, it's a file name relative to INCLUDE_PATH + ($data, $error) = $self->{ INCLUDE_PATH } + ? $self->_fetch_path($name) + : (undef, Template::Constants::STATUS_DECLINED); + } + +# $self->_dump_cache() +# if $DEBUG > 1; + + return ($data, $error); +} + + +#------------------------------------------------------------------------ +# store($name, $data) +# +# Store a compiled template ($data) in the cached as $name. +#------------------------------------------------------------------------ + +sub store { + my ($self, $name, $data) = @_; + $self->_store($name, { + data => $data, + load => 0, + }); +} + + +#------------------------------------------------------------------------ +# load($name) +# +# Load a template without parsing/compiling it, suitable for use with +# the INSERT directive. There's some duplication with fetch() and at +# some point this could be reworked to integrate them a little closer. +#------------------------------------------------------------------------ + +sub load { + my ($self, $name) = @_; + my ($data, $error); + my $path = $name; + + if (File::Spec->file_name_is_absolute($name)) { + # absolute paths (starting '/') allowed if ABSOLUTE set + $error = "$name: absolute paths are not allowed (set ABSOLUTE option)" + unless $self->{ ABSOLUTE }; + } + elsif ($name =~ m[^\.+/]) { + # anything starting "./" is relative to cwd, allowed if RELATIVE set + $error = "$name: relative paths are not allowed (set RELATIVE option)" + unless $self->{ RELATIVE }; + } + else { + INCPATH: { + # otherwise, it's a file name relative to INCLUDE_PATH + my $paths = $self->paths() + || return ($self->error(), Template::Constants::STATUS_ERROR); + + foreach my $dir (@$paths) { + $path = "$dir/$name"; + last INCPATH + if -f $path; + } + undef $path; # not found + } + } + + if (defined $path && ! $error) { + local $/ = undef; # slurp files in one go + local *FH; + if (open(FH, $path)) { + $data = <FH>; + close(FH); + } + else { + $error = "$name: $!"; + } + } + + if ($error) { + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR); + } + elsif (! defined $path) { + return (undef, Template::Constants::STATUS_DECLINED); + } + else { + return ($data, Template::Constants::STATUS_OK); + } +} + + + +#------------------------------------------------------------------------ +# include_path(\@newpath) +# +# Accessor method for the INCLUDE_PATH setting. If called with an +# argument, this method will replace the existing INCLUDE_PATH with +# the new value. +#------------------------------------------------------------------------ + +sub include_path { + my ($self, $path) = @_; + $self->{ INCLUDE_PATH } = $path if $path; + return $self->{ INCLUDE_PATH }; +} + + +#------------------------------------------------------------------------ +# paths() +# +# Evaluates the INCLUDE_PATH list, ignoring any blank entries, and +# calling and subroutine or object references to return dynamically +# generated path lists. Returns a reference to a new list of paths +# or undef on error. +#------------------------------------------------------------------------ + +sub paths { + my $self = shift; + my @ipaths = @{ $self->{ INCLUDE_PATH } }; + my (@opaths, $dpaths, $dir); + my $count = $MAX_DIRS; + + while (@ipaths && --$count) { + $dir = shift @ipaths || next; + + # $dir can be a sub or object ref which returns a reference + # to a dynamically generated list of search paths. + + if (ref $dir eq 'CODE') { + eval { $dpaths = &$dir() }; + if ($@) { + chomp $@; + return $self->error($@); + } + unshift(@ipaths, @$dpaths); + next; + } + elsif (UNIVERSAL::can($dir, 'paths')) { + $dpaths = $dir->paths() + || return $self->error($dir->error()); + unshift(@ipaths, @$dpaths); + next; + } + else { + push(@opaths, $dir); + } + } + return $self->error("INCLUDE_PATH exceeds $MAX_DIRS directories") + if @ipaths; + + return \@opaths; +} + + +#------------------------------------------------------------------------ +# DESTROY +# +# The provider cache is implemented as a doubly linked list which Perl +# cannot free by itself due to the circular references between NEXT <=> +# PREV items. This cleanup method walks the list deleting all the NEXT/PREV +# references, allowing the proper cleanup to occur and memory to be +# repooled. +#------------------------------------------------------------------------ + +sub DESTROY { + my $self = shift; + my ($slot, $next); + + $slot = $self->{ HEAD }; + while ($slot) { + $next = $slot->[ NEXT ]; + undef $slot->[ PREV ]; + undef $slot->[ NEXT ]; + $slot = $next; + } + undef $self->{ HEAD }; + undef $self->{ TAIL }; +} + + + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init() +# +# Initialise the cache. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $params) = @_; + my $size = $params->{ CACHE_SIZE }; + my $path = $params->{ INCLUDE_PATH } || '.'; + my $cdir = $params->{ COMPILE_DIR } || ''; + my $dlim = $params->{ DELIMITER }; + my $debug; + + # tweak delim to ignore C:/ + unless (defined $dlim) { + $dlim = ($^O eq 'MSWin32') ? ':(?!\\/)' : ':'; + } + + # coerce INCLUDE_PATH to an array ref, if not already so + $path = [ split(/$dlim/, $path) ] + unless ref $path eq 'ARRAY'; + + # don't allow a CACHE_SIZE 1 because it breaks things and the + # additional checking isn't worth it + $size = 2 + if defined $size && ($size == 1 || $size < 0); + + if (defined ($debug = $params->{ DEBUG })) { + $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PROVIDER + | Template::Constants::DEBUG_FLAGS ); + } + else { + $self->{ DEBUG } = $DEBUG; + } + + if ($self->{ DEBUG }) { + local $" = ', '; + $self->debug("creating cache of ", + defined $size ? $size : 'unlimited', + " slots for [ @$path ]"); + } + + # create COMPILE_DIR and sub-directories representing each INCLUDE_PATH + # element in which to store compiled files + if ($cdir) { + +# Stas' hack +# # this is a hack to solve the problem with INCLUDE_PATH using +# # relative dirs +# my $segments = 0; +# for (@$path) { +# my $c = 0; +# $c++ while m|\.\.|g; +# $segments = $c if $c > $segments; +# } +# $cdir .= "/".join "/",('hack') x $segments if $segments; +# + + require File::Path; + foreach my $dir (@$path) { + next if ref $dir; + my $wdir = $dir; + $wdir =~ s[:][]g if $^O eq 'MSWin32'; + $wdir =~ /(.*)/; # untaint + &File::Path::mkpath(File::Spec->catfile($cdir, $1)); + } + } + + $self->{ LOOKUP } = { }; + $self->{ SLOTS } = 0; + $self->{ SIZE } = $size; + $self->{ INCLUDE_PATH } = $path; + $self->{ DELIMITER } = $dlim; + $self->{ COMPILE_DIR } = $cdir; + $self->{ COMPILE_EXT } = $params->{ COMPILE_EXT } || ''; + $self->{ ABSOLUTE } = $params->{ ABSOLUTE } || 0; + $self->{ RELATIVE } = $params->{ RELATIVE } || 0; + $self->{ TOLERANT } = $params->{ TOLERANT } || 0; + $self->{ DOCUMENT } = $params->{ DOCUMENT } || $DOCUMENT; + $self->{ PARSER } = $params->{ PARSER }; + $self->{ DEFAULT } = $params->{ DEFAULT }; +# $self->{ PREFIX } = $params->{ PREFIX }; + $self->{ PARAMS } = $params; + + return $self; +} + + +#------------------------------------------------------------------------ +# _fetch($name) +# +# Fetch a file from cache or disk by specification of an absolute or +# relative filename. No search of the INCLUDE_PATH is made. If the +# file is found and loaded, it is compiled and cached. +#------------------------------------------------------------------------ + +sub _fetch { + my ($self, $name) = @_; + my $size = $self->{ SIZE }; + my ($slot, $data, $error); + + $self->debug("_fetch($name)") if $self->{ DEBUG }; + + my $compiled = $self->_compiled_filename($name); + + if (defined $size && ! $size) { + # caching disabled so load and compile but don't cache + if ($compiled && -f $compiled && (stat($name))[9] <= (stat($compiled))[9]) { + $data = $self->_load_compiled($compiled); + $error = $self->error() unless $data; + } + else { + ($data, $error) = $self->_load($name); + ($data, $error) = $self->_compile($data, $compiled) + unless $error; + $data = $data->{ data } + unless $error; + } + } + elsif ($slot = $self->{ LOOKUP }->{ $name }) { + # cached entry exists, so refresh slot and extract data + ($data, $error) = $self->_refresh($slot); + $data = $slot->[ DATA ] + unless $error; + } + else { + # nothing in cache so try to load, compile and cache + if ($compiled && -f $compiled && (stat($name))[9] <= (stat($compiled))[9]) { + $data = $self->_load_compiled($compiled); + $error = $self->error() unless $data; + $self->store($name, $data) unless $error; + } + else { + ($data, $error) = $self->_load($name); + ($data, $error) = $self->_compile($data, $compiled) + unless $error; + $data = $self->_store($name, $data) + unless $error; + } + + } + + return ($data, $error); +} + + +#------------------------------------------------------------------------ +# _fetch_path($name) +# +# Fetch a file from cache or disk by specification of an absolute cache +# name (e.g. 'header') or filename relative to one of the INCLUDE_PATH +# directories. If the file isn't already cached and can be found and +# loaded, it is compiled and cached under the full filename. +#------------------------------------------------------------------------ + +sub _fetch_path { + my ($self, $name) = @_; + my ($size, $compext, $compdir) = + @$self{ qw( SIZE COMPILE_EXT COMPILE_DIR ) }; + my ($dir, $paths, $path, $compiled, $slot, $data, $error); + local *FH; + + $self->debug("_fetch_path($name)") if $self->{ DEBUG }; + + # caching is enabled if $size is defined and non-zero or undefined + my $caching = (! defined $size || $size); + + INCLUDE: { + + # the template may have been stored using a non-filename name + if ($caching && ($slot = $self->{ LOOKUP }->{ $name })) { + # cached entry exists, so refresh slot and extract data + ($data, $error) = $self->_refresh($slot); + $data = $slot->[ DATA ] + unless $error; + last INCLUDE; + } + + $paths = $self->paths() || do { + $error = Template::Constants::STATUS_ERROR; + $data = $self->error(); + last INCLUDE; + }; + + # search the INCLUDE_PATH for the file, in cache or on disk + foreach $dir (@$paths) { + $path = "$dir/$name"; + + $self->debug("searching path: $path\n") if $self->{ DEBUG }; + + if ($caching && ($slot = $self->{ LOOKUP }->{ $path })) { + # cached entry exists, so refresh slot and extract data + ($data, $error) = $self->_refresh($slot); + $data = $slot->[ DATA ] + unless $error; + last INCLUDE; + } + elsif (-f $path) { + $compiled = $self->_compiled_filename($path) + if $compext || $compdir; + + if ($compiled && -f $compiled && (stat($path))[9] <= (stat($compiled))[9]) { + if ($data = $self->_load_compiled($compiled)) { + # store in cache + $data = $self->store($path, $data); + $error = Template::Constants::STATUS_OK; + last INCLUDE; + } + else { + warn($self->error(), "\n"); + } + } + # $compiled is set if an attempt to write the compiled + # template to disk should be made + + ($data, $error) = $self->_load($path, $name); + ($data, $error) = $self->_compile($data, $compiled) + unless $error; + $data = $self->_store($path, $data) + unless $error || ! $caching; + $data = $data->{ data } if ! $caching; + # all done if $error is OK or ERROR + last INCLUDE if ! $error + || $error == Template::Constants::STATUS_ERROR; + } + } + # template not found, so look for a DEFAULT template + my $default; + if (defined ($default = $self->{ DEFAULT }) && $name ne $default) { + $name = $default; + redo INCLUDE; + } + ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); + } # INCLUDE + + return ($data, $error); +} + + + +sub _compiled_filename { + my ($self, $file) = @_; + my ($compext, $compdir) = @$self{ qw( COMPILE_EXT COMPILE_DIR ) }; + my ($path, $compiled); + + return undef + unless $compext || $compdir; + + $path = $file; + $path =~ /^(.+)$/s or die "invalid filename: $path"; + $path =~ s[:][]g if $^O eq 'MSWin32'; + + $compiled = "$path$compext"; + $compiled = File::Spec->catfile($compdir, $compiled) if length $compdir; + + return $compiled; +} + + +sub _load_compiled { + my ($self, $file) = @_; + my $compiled; + + # load compiled template via require(); we zap any + # %INC entry to ensure it is reloaded (we don't + # want 1 returned by require() to say it's in memory) + delete $INC{ $file }; + eval { $compiled = require $file; }; + return $@ + ? $self->error("compiled template $compiled: $@") + : $compiled; +} + + + +#------------------------------------------------------------------------ +# _load($name, $alias) +# +# Load template text from a string ($name = scalar ref), GLOB or file +# handle ($name = ref), or from an absolute filename ($name = scalar). +# Returns a hash array containing the following items: +# name filename or $alias, if provided, or 'input text', etc. +# text template text +# time modification time of file, or current time for handles/strings +# load time file was loaded (now!) +# +# On error, returns ($error, STATUS_ERROR), or (undef, STATUS_DECLINED) +# if TOLERANT is set. +#------------------------------------------------------------------------ + +sub _load { + my ($self, $name, $alias) = @_; + my ($data, $error); + my $tolerant = $self->{ TOLERANT }; + my $now = time; + local $/ = undef; # slurp files in one go + local *FH; + + $alias = $name unless defined $alias or ref $name; + + $self->debug("_load($name, ", defined $alias ? $alias : '<no alias>', + ')') if $self->{ DEBUG }; + + LOAD: { + if (ref $name eq 'SCALAR') { + # $name can be a SCALAR reference to the input text... + $data = { + name => defined $alias ? $alias : 'input text', + text => $$name, + time => $now, + load => 0, + }; + } + elsif (ref $name) { + # ...or a GLOB or file handle... + my $text = <$name>; + $data = { + name => defined $alias ? $alias : 'input file handle', + text => $text, + time => $now, + load => 0, + }; + } + elsif (-f $name) { + if (open(FH, $name)) { + my $text = <FH>; + $data = { + name => $alias, + text => $text, + time => (stat $name)[9], + load => $now, + }; + } + elsif ($tolerant) { + ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); + } + else { + $data = "$alias: $!"; + $error = Template::Constants::STATUS_ERROR; + } + } + else { + ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); + } + } + + return ($data, $error); +} + + +#------------------------------------------------------------------------ +# _refresh(\@slot) +# +# Private method called to mark a cache slot as most recently used. +# A reference to the slot array should be passed by parameter. The +# slot is relocated to the head of the linked list. If the file from +# which the data was loaded has been upated since it was compiled, then +# it is re-loaded from disk and re-compiled. +#------------------------------------------------------------------------ + +sub _refresh { + my ($self, $slot) = @_; + my ($head, $file, $data, $error); + + + $self->debug("_refresh([ ", + join(', ', map { defined $_ ? $_ : '<undef>' } @$slot), + '])') if $self->{ DEBUG }; + + # if it's more than $STAT_TTL seconds since we last performed a + # stat() on the file then we need to do it again and see if the file + # time has changed + if ( (time - $slot->[ STAT ]) > $STAT_TTL && stat $slot->[ NAME ] ) { + $slot->[ STAT ] = time; + + if ( (stat(_))[9] != $slot->[ LOAD ]) { + + $self->debug("refreshing cache file ", $slot->[ NAME ]) + if $self->{ DEBUG }; + + ($data, $error) = $self->_load($slot->[ NAME ], + $slot->[ DATA ]->{ name }); + ($data, $error) = $self->_compile($data) + unless $error; + + unless ($error) { + $slot->[ DATA ] = $data->{ data }; + $slot->[ LOAD ] = $data->{ time }; + } + } + } + + unless( $self->{ HEAD } == $slot ) { + # remove existing slot from usage chain... + if ($slot->[ PREV ]) { + $slot->[ PREV ]->[ NEXT ] = $slot->[ NEXT ]; + } + else { + $self->{ HEAD } = $slot->[ NEXT ]; + } + if ($slot->[ NEXT ]) { + $slot->[ NEXT ]->[ PREV ] = $slot->[ PREV ]; + } + else { + $self->{ TAIL } = $slot->[ PREV ]; + } + + # ..and add to start of list + $head = $self->{ HEAD }; + $head->[ PREV ] = $slot if $head; + $slot->[ PREV ] = undef; + $slot->[ NEXT ] = $head; + $self->{ HEAD } = $slot; + } + + return ($data, $error); +} + + +#------------------------------------------------------------------------ +# _store($name, $data) +# +# Private method called to add a data item to the cache. If the cache +# size limit has been reached then the oldest entry at the tail of the +# list is removed and its slot relocated to the head of the list and +# reused for the new data item. If the cache is under the size limit, +# or if no size limit is defined, then the item is added to the head +# of the list. +#------------------------------------------------------------------------ + +sub _store { + my ($self, $name, $data, $compfile) = @_; + my $size = $self->{ SIZE }; + my ($slot, $head); + + # extract the load time and compiled template from the data +# my $load = $data->{ load }; + my $load = (stat($name))[9]; + $data = $data->{ data }; + + $self->debug("_store($name, $data)") if $self->{ DEBUG }; + + if (defined $size && $self->{ SLOTS } >= $size) { + # cache has reached size limit, so reuse oldest entry + + $self->debug("reusing oldest cache entry (size limit reached: $size)\nslots: $self->{ SLOTS }") if $self->{ DEBUG }; + + # remove entry from tail of list + $slot = $self->{ TAIL }; + $slot->[ PREV ]->[ NEXT ] = undef; + $self->{ TAIL } = $slot->[ PREV ]; + + # remove name lookup for old node + delete $self->{ LOOKUP }->{ $slot->[ NAME ] }; + + # add modified node to head of list + $head = $self->{ HEAD }; + $head->[ PREV ] = $slot if $head; + @$slot = ( undef, $name, $data, $load, $head, time ); + $self->{ HEAD } = $slot; + + # add name lookup for new node + $self->{ LOOKUP }->{ $name } = $slot; + } + else { + # cache is under size limit, or none is defined + + $self->debug("adding new cache entry") if $self->{ DEBUG }; + + # add new node to head of list + $head = $self->{ HEAD }; + $slot = [ undef, $name, $data, $load, $head, time ]; + $head->[ PREV ] = $slot if $head; + $self->{ HEAD } = $slot; + $self->{ TAIL } = $slot unless $self->{ TAIL }; + + # add lookup from name to slot and increment nslots + $self->{ LOOKUP }->{ $name } = $slot; + $self->{ SLOTS }++; + } + + return $data; +} + + +#------------------------------------------------------------------------ +# _compile($data) +# +# Private method called to parse the template text and compile it into +# a runtime form. Creates and delegates a Template::Parser object to +# handle the compilation, or uses a reference passed in PARSER. On +# success, the compiled template is stored in the 'data' item of the +# $data hash and returned. On error, ($error, STATUS_ERROR) is returned, +# or (undef, STATUS_DECLINED) if the TOLERANT flag is set. +# The optional $compiled parameter may be passed to specify +# the name of a compiled template file to which the generated Perl +# code should be written. Errors are (for now...) silently +# ignored, assuming that failures to open a file for writing are +# intentional (e.g directory write permission). +#------------------------------------------------------------------------ + +sub _compile { + my ($self, $data, $compfile) = @_; + my $text = $data->{ text }; + my ($parsedoc, $error); + + $self->debug("_compile($data, ", + defined $compfile ? $compfile : '<no compfile>', ')') + if $self->{ DEBUG }; + + my $parser = $self->{ PARSER } + ||= Template::Config->parser($self->{ PARAMS }) + || return (Template::Config->error(), Template::Constants::STATUS_ERROR); + + # discard the template text - we don't need it any more + delete $data->{ text }; + + # call parser to compile template into Perl code + if ($parsedoc = $parser->parse($text, $data)) { + + $parsedoc->{ METADATA } = { + 'name' => $data->{ name }, + 'modtime' => $data->{ time }, + %{ $parsedoc->{ METADATA } }, + }; + + # write the Perl code to the file $compfile, if defined + if ($compfile) { + my $basedir = &File::Basename::dirname($compfile); + $basedir =~ /(.*)/; + $basedir = $1; + &File::Path::mkpath($basedir) unless -d $basedir; + + my $docclass = $self->{ DOCUMENT }; + $error = 'cache failed to write ' + . &File::Basename::basename($compfile) + . ': ' . $docclass->error() + unless $docclass->write_perl_file($compfile, $parsedoc); + + # set atime and mtime of newly compiled file, don't bother + # if time is undef + if (!defined($error) && defined $data->{ time }) { + my ($cfile) = $compfile =~ /^(.+)$/s or do { + return("invalid filename: $compfile", + Template::Constants::STATUS_ERROR); + }; + + my ($ctime) = $data->{ time } =~ /^(\d+)$/; + unless ($ctime || $ctime eq 0) { + return("invalid time: $ctime", + Template::Constants::STATUS_ERROR); + } + utime($ctime, $ctime, $cfile); + } + } + + unless ($error) { + return $data ## RETURN ## + if $data->{ data } = Template::Document->new($parsedoc); + $error = $Template::Document::ERROR; + } + } + else { + $error = Template::Exception->new( 'parse', "$data->{ name } " . + $parser->error() ); + } + + # return STATUS_ERROR, or STATUS_DECLINED if we're being tolerant + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR) +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal object +# state. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $size = $self->{ SIZE }; + my $parser = $self->{ PARSER }; + $parser = $parser ? $parser->_dump() : '<no parser>'; + $parser =~ s/\n/\n /gm; + $size = 'unlimited' unless defined $size; + + my $output = "[Template::Provider] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + $output .= sprintf($format, 'INCLUDE_PATH', + '[ ' . join(', ', @{ $self->{ INCLUDE_PATH } }) . ' ]'); + $output .= sprintf($format, 'CACHE_SIZE', $size); + + foreach $key (qw( ABSOLUTE RELATIVE TOLERANT DELIMITER + COMPILE_EXT COMPILE_DIR )) { + $output .= sprintf($format, $key, $self->{ $key }); + } + $output .= sprintf($format, 'PARSER', $parser); + + + local $" = ', '; + my $lookup = $self->{ LOOKUP }; + $lookup = join('', map { + sprintf(" $format", $_, defined $lookup->{ $_ } + ? ('[ ' . join(', ', map { defined $_ ? $_ : '<undef>' } + @{ $lookup->{ $_ } }) . ' ]') : '<undef>'); + } sort keys %$lookup); + $lookup = "{\n$lookup }"; + + $output .= sprintf($format, LOOKUP => $lookup); + + $output .= '}'; + return $output; +} + + +#------------------------------------------------------------------------ +# _dump_cache() +# +# Debug method which prints the current state of the cache to STDERR. +#------------------------------------------------------------------------ + +sub _dump_cache { + my $self = shift; + my ($node, $lut, $count); + + $count = 0; + if ($node = $self->{ HEAD }) { + while ($node) { + $lut->{ $node } = $count++; + $node = $node->[ NEXT ]; + } + $node = $self->{ HEAD }; + print STDERR "CACHE STATE:\n"; + print STDERR " HEAD: ", $self->{ HEAD }->[ NAME ], "\n"; + print STDERR " TAIL: ", $self->{ TAIL }->[ NAME ], "\n"; + while ($node) { + my ($prev, $name, $data, $load, $next) = @$node; +# $name = '...' . substr($name, -10) if length $name > 10; + $prev = $prev ? "#$lut->{ $prev }<-": '<undef>'; + $next = $next ? "->#$lut->{ $next }": '<undef>'; + print STDERR " #$lut->{ $node } : [ $prev, $name, $data, $load, $next ]\n"; + $node = $node->[ NEXT ]; + } + } +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Provider - Provider module for loading/compiling templates + +=head1 SYNOPSIS + + $provider = Template::Provider->new(\%options); + + ($template, $error) = $provider->fetch($name); + +=head1 DESCRIPTION + +The Template::Provider is used to load, parse, compile and cache template +documents. This object may be sub-classed to provide more specific +facilities for loading, or otherwise providing access to templates. + +The Template::Context objects maintain a list of Template::Provider +objects which are polled in turn (via fetch()) to return a requested +template. Each may return a compiled template, raise an error, or +decline to serve the reqest, giving subsequent providers a chance to +do so. + +This is the "Chain of Responsiblity" pattern. See 'Design Patterns' for +further information. + +This documentation needs work. + +=head1 PUBLIC METHODS + +=head2 new(\%options) + +Constructor method which instantiates and returns a new Template::Provider +object. The optional parameter may be a hash reference containing any of +the following items: + +=over 4 + + + + +=item INCLUDE_PATH + +The INCLUDE_PATH is used to specify one or more directories in which +template files are located. When a template is requested that isn't +defined locally as a BLOCK, each of the INCLUDE_PATH directories is +searched in turn to locate the template file. Multiple directories +can be specified as a reference to a list or as a single string where +each directory is delimited by ':'. + + my $provider = Template::Provider->new({ + INCLUDE_PATH => '/usr/local/templates', + }); + + my $provider = Template::Provider->new({ + INCLUDE_PATH => '/usr/local/templates:/tmp/my/templates', + }); + + my $provider = Template::Provider->new({ + INCLUDE_PATH => [ '/usr/local/templates', + '/tmp/my/templates' ], + }); + +On Win32 systems, a little extra magic is invoked, ignoring delimiters +that have ':' followed by a '/' or '\'. This avoids confusion when using +directory names like 'C:\Blah Blah'. + +When specified as a list, the INCLUDE_PATH path can contain elements +which dynamically generate a list of INCLUDE_PATH directories. These +generator elements can be specified as a reference to a subroutine or +an object which implements a paths() method. + + my $provider = Template::Provider->new({ + INCLUDE_PATH => [ '/usr/local/templates', + \&incpath_generator, + My::IncPath::Generator->new( ... ) ], + }); + +Each time a template is requested and the INCLUDE_PATH examined, the +subroutine or object method will be called. A reference to a list of +directories should be returned. Generator subroutines should report +errors using die(). Generator objects should return undef and make an +error available via its error() method. + +For example: + + sub incpath_generator { + + # ...some code... + + if ($all_is_well) { + return \@list_of_directories; + } + else { + die "cannot generate INCLUDE_PATH...\n"; + } + } + +or: + + package My::IncPath::Generator; + + # Template::Base (or Class::Base) provides error() method + use Template::Base; + use base qw( Template::Base ); + + sub paths { + my $self = shift; + + # ...some code... + + if ($all_is_well) { + return \@list_of_directories; + } + else { + return $self->error("cannot generate INCLUDE_PATH...\n"); + } + } + + 1; + + + + + +=item DELIMITER + +Used to provide an alternative delimiter character sequence for +separating paths specified in the INCLUDE_PATH. The default +value for DELIMITER is ':'. + + # tolerate Silly Billy's file system conventions + my $provider = Template::Provider->new({ + DELIMITER => '; ', + INCLUDE_PATH => 'C:/HERE/NOW; D:/THERE/THEN', + }); + + # better solution: install Linux! :-) + +On Win32 systems, the default delimiter is a little more intelligent, +splitting paths only on ':' characters that aren't followed by a '/'. +This means that the following should work as planned, splitting the +INCLUDE_PATH into 2 separate directories, C:/foo and C:/bar. + + # on Win32 only + my $provider = Template::Provider->new({ + INCLUDE_PATH => 'C:/Foo:C:/Bar' + }); + +However, if you're using Win32 then it's recommended that you +explicitly set the DELIMITER character to something else (e.g. ';') +rather than rely on this subtle magic. + + + + +=item ABSOLUTE + +The ABSOLUTE flag is used to indicate if templates specified with +absolute filenames (e.g. '/foo/bar') should be processed. It is +disabled by default and any attempt to load a template by such a +name will cause a 'file' exception to be raised. + + my $provider = Template::Provider->new({ + ABSOLUTE => 1, + }); + + # this is why it's disabled by default + [% INSERT /etc/passwd %] + +On Win32 systems, the regular expression for matching absolute +pathnames is tweaked slightly to also detect filenames that start +with a driver letter and colon, such as: + + C:/Foo/Bar + + + + + + +=item RELATIVE + +The RELATIVE flag is used to indicate if templates specified with +filenames relative to the current directory (e.g. './foo/bar' or +'../../some/where/else') should be loaded. It is also disabled by +default, and will raise a 'file' error if such template names are +encountered. + + my $provider = Template::Provider->new({ + RELATIVE => 1, + }); + + [% INCLUDE ../logs/error.log %] + + + + + +=item DEFAULT + +The DEFAULT option can be used to specify a default template which should +be used whenever a specified template can't be found in the INCLUDE_PATH. + + my $provider = Template::Provider->new({ + DEFAULT => 'notfound.html', + }); + +If a non-existant template is requested through the Template process() +method, or by an INCLUDE, PROCESS or WRAPPER directive, then the +DEFAULT template will instead be processed, if defined. Note that the +DEFAULT template is not used when templates are specified with +absolute or relative filenames, or as a reference to a input file +handle or text string. + + + + + +=item CACHE_SIZE + +The Template::Provider module caches compiled templates to avoid the need +to re-parse template files or blocks each time they are used. The CACHE_SIZE +option is used to limit the number of compiled templates that the module +should cache. + +By default, the CACHE_SIZE is undefined and all compiled templates are +cached. When set to any positive value, the cache will be limited to +storing no more than that number of compiled templates. When a new +template is loaded and compiled and the cache is full (i.e. the number +of entries == CACHE_SIZE), the least recently used compiled template +is discarded to make room for the new one. + +The CACHE_SIZE can be set to 0 to disable caching altogether. + + my $provider = Template::Provider->new({ + CACHE_SIZE => 64, # only cache 64 compiled templates + }); + + my $provider = Template::Provider->new({ + CACHE_SIZE => 0, # don't cache any compiled templates + }); + + + + + + +=item COMPILE_EXT + +From version 2 onwards, the Template Toolkit has the ability to +compile templates to Perl code and save them to disk for subsequent +use (i.e. cache persistence). The COMPILE_EXT option may be +provided to specify a filename extension for compiled template files. +It is undefined by default and no attempt will be made to read or write +any compiled template files. + + my $provider = Template::Provider->new({ + COMPILE_EXT => '.ttc', + }); + +If COMPILE_EXT is defined (and COMPILE_DIR isn't, see below) then compiled +template files with the COMPILE_EXT extension will be written to the same +directory from which the source template files were loaded. + +Compiling and subsequent reuse of templates happens automatically +whenever the COMPILE_EXT or COMPILE_DIR options are set. The Template +Toolkit will automatically reload and reuse compiled files when it +finds them on disk. If the corresponding source file has been modified +since the compiled version as written, then it will load and re-compile +the source and write a new compiled version to disk. + +This form of cache persistence offers significant benefits in terms of +time and resources required to reload templates. Compiled templates can +be reloaded by a simple call to Perl's require(), leaving Perl to handle +all the parsing and compilation. This is a Good Thing. + +=item COMPILE_DIR + +The COMPILE_DIR option is used to specify an alternate directory root +under which compiled template files should be saved. + + my $provider = Template::Provider->new({ + COMPILE_DIR => '/tmp/ttc', + }); + +The COMPILE_EXT option may also be specified to have a consistent file +extension added to these files. + + my $provider1 = Template::Provider->new({ + COMPILE_DIR => '/tmp/ttc', + COMPILE_EXT => '.ttc1', + }); + + my $provider2 = Template::Provider->new({ + COMPILE_DIR => '/tmp/ttc', + COMPILE_EXT => '.ttc2', + }); + + +When COMPILE_EXT is undefined, the compiled template files have the +same name as the original template files, but reside in a different +directory tree. + +Each directory in the INCLUDE_PATH is replicated in full beneath the +COMPILE_DIR directory. This example: + + my $provider = Template::Provider->new({ + COMPILE_DIR => '/tmp/ttc', + INCLUDE_PATH => '/home/abw/templates:/usr/share/templates', + }); + +would create the following directory structure: + + /tmp/ttc/home/abw/templates/ + /tmp/ttc/usr/share/templates/ + +Files loaded from different INCLUDE_PATH directories will have their +compiled forms save in the relevant COMPILE_DIR directory. + +On Win32 platforms a filename may by prefixed by a drive letter and +colon. e.g. + + C:/My Templates/header + +The colon will be silently stripped from the filename when it is added +to the COMPILE_DIR value(s) to prevent illegal filename being generated. +Any colon in COMPILE_DIR elements will be left intact. For example: + + # Win32 only + my $provider = Template::Provider->new({ + DELIMITER => ';', + COMPILE_DIR => 'C:/TT2/Cache', + INCLUDE_PATH => 'C:/TT2/Templates;D:/My Templates', + }); + +This would create the following cache directories: + + C:/TT2/Cache/C/TT2/Templates + C:/TT2/Cache/D/My Templates + + + + +=item TOLERANT + +The TOLERANT flag is used by the various Template Toolkit provider +modules (Template::Provider, Template::Plugins, Template::Filters) to +control their behaviour when errors are encountered. By default, any +errors are reported as such, with the request for the particular +resource (template, plugin, filter) being denied and an exception +raised. When the TOLERANT flag is set to any true values, errors will +be silently ignored and the provider will instead return +STATUS_DECLINED. This allows a subsequent provider to take +responsibility for providing the resource, rather than failing the +request outright. If all providers decline to service the request, +either through tolerated failure or a genuine disinclination to +comply, then a 'E<lt>resourceE<gt> not found' exception is raised. + + + + + + +=item PARSER + +The Template::Parser module implements a parser object for compiling +templates into Perl code which can then be executed. A default object +of this class is created automatically and then used by the +Template::Provider whenever a template is loaded and requires +compilation. The PARSER option can be used to provide a reference to +an alternate parser object. + + my $provider = Template::Provider->new({ + PARSER => MyOrg::Template::Parser->new({ ... }), + }); + + + +=item DEBUG + +The DEBUG option can be used to enable debugging messages from the +Template::Provider module by setting it to include the DEBUG_PROVIDER +value. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_PROVIDER, + }); + + + +=back + +=head2 fetch($name) + +Returns a compiled template for the name specified. If the template +cannot be found then (undef, STATUS_DECLINED) is returned. If an error +occurs (e.g. read error, parse error) then ($error, STATUS_ERROR) is +returned, where $error is the error message generated. If the TOLERANT +flag is set the the method returns (undef, STATUS_DECLINED) instead of +returning an error. + +=head2 store($name, $template) + +Stores the compiled template, $template, in the cache under the name, +$name. Susbequent calls to fetch($name) will return this template in +preference to any disk-based file. + +=head2 include_path(\@newpath)) + +Accessor method for the INCLUDE_PATH setting. If called with an +argument, this method will replace the existing INCLUDE_PATH with +the new value. + +=head2 paths() + +This method generates a copy of the INCLUDE_PATH list. Any elements in the +list which are dynamic generators (e.g. references to subroutines or objects +implementing a paths() method) will be called and the list of directories +returned merged into the output list. + +It is possible to provide a generator which returns itself, thus sending +this method into an infinite loop. To detect and prevent this from happening, +the C<$MAX_DIRS> package variable, set to 64 by default, limits the maximum +number of paths that can be added to, or generated for the output list. If +this number is exceeded then the method will immediately return an error +reporting as much. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.70, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Parser|Template::Parser>, L<Template::Context|Template::Context> diff --git a/lib/Template/Service.pm b/lib/Template/Service.pm new file mode 100644 index 0000000..e2ac533 --- /dev/null +++ b/lib/Template/Service.pm @@ -0,0 +1,765 @@ +#============================================================= -*-Perl-*- +# +# Template::Service +# +# DESCRIPTION +# Module implementing a template processing service which wraps a +# template within PRE_PROCESS and POST_PROCESS templates and offers +# ERROR recovery. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Service.pm,v 2.70 2003/04/29 12:39:37 abw Exp $ +# +#============================================================================ + +package Template::Service; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $ERROR ); +use base qw( Template::Base ); +use Template::Base; +use Template::Config; +use Template::Exception; +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.70 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# process($template, \%params) +# +# Process a template within a service framework. A service may encompass +# PRE_PROCESS and POST_PROCESS templates and an ERROR hash which names +# templates to be substituted for the main template document in case of +# error. Each service invocation begins by resetting the state of the +# context object via a call to reset(). The AUTO_RESET option may be set +# to 0 (default: 1) to bypass this step. +#------------------------------------------------------------------------ + +sub process { + my ($self, $template, $params) = @_; + my $context = $self->{ CONTEXT }; + my ($name, $output, $procout, $error); + $output = ''; + + $self->debug("process($template, ", + defined $params ? $params : '<no params>', + ')') if $self->{ DEBUG }; + + $context->reset() + if $self->{ AUTO_RESET }; + + # pre-request compiled template from context so that we can alias it + # in the stash for pre-processed templates to reference + eval { $template = $context->template($template) }; + return $self->error($@) + if $@; + + # localise the variable stash with any parameters passed + # and set the 'template' variable + $params ||= { }; + $params->{ template } = $template + unless ref $template eq 'CODE'; + $context->localise($params); + + SERVICE: { + # PRE_PROCESS + eval { + foreach $name (@{ $self->{ PRE_PROCESS } }) { + $self->debug("PRE_PROCESS: $name") if $self->{ DEBUG }; + $output .= $context->process($name); + } + }; + last SERVICE if ($error = $@); + + # PROCESS + eval { + foreach $name (@{ $self->{ PROCESS } || [ $template ] }) { + $self->debug("PROCESS: $name") if $self->{ DEBUG }; + $procout .= $context->process($name); + } + }; + if ($error = $@) { + last SERVICE + unless defined ($procout = $self->_recover(\$error)); + } + + if (defined $procout) { + # WRAPPER + eval { + foreach $name (reverse @{ $self->{ WRAPPER } }) { + $self->debug("WRAPPER: $name") if $self->{ DEBUG }; + $procout = $context->process($name, { content => $procout }); + } + }; + last SERVICE if ($error = $@); + $output .= $procout; + } + + # POST_PROCESS + eval { + foreach $name (@{ $self->{ POST_PROCESS } }) { + $self->debug("POST_PROCESS: $name") if $self->{ DEBUG }; + $output .= $context->process($name); + } + }; + last SERVICE if ($error = $@); + } + + $context->delocalise(); + delete $params->{ template }; + + if ($error) { +# $error = $error->as_string if ref $error; + return $self->error($error); + } + + return $output; +} + + +#------------------------------------------------------------------------ +# context() +# +# Returns the internal CONTEXT reference. +#------------------------------------------------------------------------ + +sub context { + return $_[0]->{ CONTEXT }; +} + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +sub _init { + my ($self, $config) = @_; + my ($item, $data, $context, $block, $blocks); + my $delim = $config->{ DELIMITER }; + $delim = ':' unless defined $delim; + + # coerce PRE_PROCESS, PROCESS and POST_PROCESS to arrays if necessary, + # by splitting on non-word characters + foreach $item (qw( PRE_PROCESS PROCESS POST_PROCESS WRAPPER )) { + $data = $config->{ $item }; + $self->{ $item } = [ ], next unless (defined $data); + $data = [ split($delim, $data || '') ] + unless ref $data eq 'ARRAY'; + $self->{ $item } = $data; + } + # unset PROCESS option unless explicitly specified in config + $self->{ PROCESS } = undef + unless defined $config->{ PROCESS }; + + $self->{ ERROR } = $config->{ ERROR } || $config->{ ERRORS }; + $self->{ AUTO_RESET } = defined $config->{ AUTO_RESET } + ? $config->{ AUTO_RESET } : 1; + $self->{ DEBUG } = ( $config->{ DEBUG } || 0 ) + & Template::Constants::DEBUG_SERVICE; + + $context = $self->{ CONTEXT } = $config->{ CONTEXT } + || Template::Config->context($config) + || return $self->error(Template::Config->error); + + return $self; +} + + +#------------------------------------------------------------------------ +# _recover(\$exception) +# +# Examines the internal ERROR hash array to find a handler suitable +# for the exception object passed by reference. Selecting the handler +# is done by delegation to the exception's select_handler() method, +# passing the set of handler keys as arguments. A 'default' handler +# may also be provided. The handler value represents the name of a +# template which should be processed. +#------------------------------------------------------------------------ + +sub _recover { + my ($self, $error) = @_; + my $context = $self->{ CONTEXT }; + my ($hkey, $handler, $output); + + # there shouldn't ever be a non-exception object received at this + # point... unless a module like CGI::Carp messes around with the + # DIE handler. + return undef + unless (ref $$error); + + # a 'stop' exception is thrown by [% STOP %] - we return the output + # buffer stored in the exception object + return $$error->text() + if $$error->type() eq 'stop'; + + my $handlers = $self->{ ERROR } + || return undef; ## RETURN + + if (ref $handlers eq 'HASH') { + if ($hkey = $$error->select_handler(keys %$handlers)) { + $handler = $handlers->{ $hkey }; + $self->debug("using error handler for $hkey") if $self->{ DEBUG }; + } + elsif ($handler = $handlers->{ default }) { + # use default handler + $self->debug("using default error handler") if $self->{ DEBUG }; + } + else { + return undef; ## RETURN + } + } + else { + $handler = $handlers; + $self->debug("using default error handler") if $self->{ DEBUG }; + } + + eval { $handler = $context->template($handler) }; + if ($@) { + $$error = $@; + return undef; ## RETURN + }; + + $context->stash->set('error', $$error); + eval { + $output .= $context->process($handler); + }; + if ($@) { + $$error = $@; + return undef; ## RETURN + } + + return $output; +} + + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which return a string representing the internal object +# state. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $context = $self->{ CONTEXT }->_dump(); + $context =~ s/\n/\n /gm; + + my $error = $self->{ ERROR }; + $error = join('', + "{\n", + (map { " $_ => $error->{ $_ }\n" } + keys %$error), + "}\n") + if ref $error; + + local $" = ', '; + return <<EOF; +$self +PRE_PROCESS => [ @{ $self->{ PRE_PROCESS } } ] +POST_PROCESS => [ @{ $self->{ POST_PROCESS } } ] +ERROR => $error +CONTEXT => $context +EOF +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Service - General purpose template processing service + +=head1 SYNOPSIS + + use Template::Service; + + my $service = Template::Service->new({ + PRE_PROCESS => [ 'config', 'header' ], + POST_PROCESS => 'footer', + ERROR => { + user => 'user/index.html', + dbi => 'error/database', + default => 'error/default', + }, + }); + + my $output = $service->process($template_name, \%replace) + || die $service->error(), "\n"; + +=head1 DESCRIPTION + +The Template::Service module implements an object class for providing +a consistent template processing service. + +Standard header (PRE_PROCESS) and footer (POST_PROCESS) templates may +be specified which are prepended and appended to all templates +processed by the service (but not any other templates or blocks +INCLUDEd or PROCESSed from within). An ERROR hash may be specified +which redirects the service to an alternate template file in the case +of uncaught exceptions being thrown. This allows errors to be +automatically handled by the service and a guaranteed valid response +to be generated regardless of any processing problems encountered. + +A default Template::Service object is created by the Template module. +Any Template::Service options may be passed to the Template new() +constructor method and will be forwarded to the Template::Service +constructor. + + use Template; + + my $template = Template->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + }); + +Similarly, the Template::Service constructor will forward all configuration +parameters onto other default objects (e.g. Template::Context) that it may +need to instantiate. + +A Template::Service object (or subclass/derivative) can be explicitly +instantiated and passed to the Template new() constructor method as +the SERVICE item. + + use Template; + use Template::Service; + + my $service = Template::Service->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + }); + + my $template = Template->new({ + SERVICE => $service, + }); + +The Template::Service module can be sub-classed to create custom service +handlers. + + use Template; + use MyOrg::Template::Service; + + my $service = MyOrg::Template::Service->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + COOL_OPTION => 'enabled in spades', + }); + + my $template = Template->new({ + SERVICE => $service, + }); + +The Template module uses the Template::Config service() factory method +to create a default service object when required. The +$Template::Config::SERVICE package variable may be set to specify an +alternate service module. This will be loaded automatically and its +new() constructor method called by the service() factory method when +a default service object is required. Thus the previous example could +be written as: + + use Template; + + $Template::Config::SERVICE = 'MyOrg::Template::Service'; + + my $template = Template->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + COOL_OPTION => 'enabled in spades', + }); + +=head1 METHODS + +=head2 new(\%config) + +The new() constructor method is called to instantiate a Template::Service +object. Configuration parameters may be specified as a HASH reference or +as a list of (name =E<gt> value) pairs. + + my $service1 = Template::Service->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + }); + + my $service2 = Template::Service->new( ERROR => 'error.html' ); + +The new() method returns a Template::Service object (or sub-class) or +undef on error. In the latter case, a relevant error message can be +retrieved by the error() class method or directly from the +$Template::Service::ERROR package variable. + + my $service = Template::Service->new(\%config) + || die Template::Service->error(); + + my $service = Template::Service->new(\%config) + || die $Template::Service::ERROR; + +The following configuration items may be specified: + +=over 4 + + + + +=item PRE_PROCESS, POST_PROCESS + +These values may be set to contain the name(s) of template files +(relative to INCLUDE_PATH) which should be processed immediately +before and/or after each template. These do not get added to +templates processed into a document via directives such as INCLUDE, +PROCESS, WRAPPER etc. + + my $service = Template::Service->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + }; + +Multiple templates may be specified as a reference to a list. Each is +processed in the order defined. + + my $service = Template::Service->new({ + PRE_PROCESS => [ 'config', 'header' ], + POST_PROCESS => 'footer', + }; + +Alternately, multiple template may be specified as a single string, +delimited by ':'. This delimiter string can be changed via the +DELIMITER option. + + my $service = Template::Service->new({ + PRE_PROCESS => 'config:header', + POST_PROCESS => 'footer', + }; + +The PRE_PROCESS and POST_PROCESS templates are evaluated in the same +variable context as the main document and may define or update +variables for subsequent use. + +config: + + [% # set some site-wide variables + bgcolor = '#ffffff' + version = 2.718 + %] + +header: + + [% DEFAULT title = 'My Funky Web Site' %] + <html> + <head> + <title>[% title %]</title> + </head> + <body bgcolor="[% bgcolor %]"> + +footer: + + <hr> + Version [% version %] + </body> + </html> + +The Template::Document object representing the main template being processed +is available within PRE_PROCESS and POST_PROCESS templates as the 'template' +variable. Metadata items defined via the META directive may be accessed +accordingly. + + $service->process('mydoc.html', $vars); + +mydoc.html: + + [% META title = 'My Document Title' %] + blah blah blah + ... + +header: + + <html> + <head> + <title>[% template.title %]</title></head> + <body bgcolor="[% bgcolor %]"> + + + + + + + + + + + + + + +=item PROCESS + +The PROCESS option may be set to contain the name(s) of template files +(relative to INCLUDE_PATH) which should be processed instead of the +main template passed to the Template::Service process() method. This can +be used to apply consistent wrappers around all templates, similar to +the use of PRE_PROCESS and POST_PROCESS templates. + + my $service = Template::Service->new({ + PROCESS => 'content', + }; + + # processes 'content' instead of 'foo.html' + $service->process('foo.html'); + +A reference to the original template is available in the 'template' +variable. Metadata items can be inspected and the template can be +processed by specifying it as a variable reference (i.e. prefixed by +'$') to an INCLUDE, PROCESS or WRAPPER directive. + +content: + + <html> + <head> + <title>[% template.title %]</title> + </head> + + <body> + [% PROCESS $template %] + <hr> + © Copyright [% template.copyright %] + </body> + </html> + +foo.html: + + [% META + title = 'The Foo Page' + author = 'Fred Foo' + copyright = '2000 Fred Foo' + %] + <h1>[% template.title %]</h1> + Welcome to the Foo Page, blah blah blah + +output: + + <html> + <head> + <title>The Foo Page</title> + </head> + + <body> + <h1>The Foo Page</h1> + Welcome to the Foo Page, blah blah blah + <hr> + © Copyright 2000 Fred Foo + </body> + </html> + + + + + + + +=item ERROR + +The ERROR (or ERRORS if you prefer) configuration item can be used to +name a single template or specify a hash array mapping exception types +to templates which should be used for error handling. If an uncaught +exception is raised from within a template then the appropriate error +template will instead be processed. + +If specified as a single value then that template will be processed +for all uncaught exceptions. + + my $service = Template::Service->new({ + ERROR => 'error.html' + }); + +If the ERROR item is a hash reference the keys are assumed to be +exception types and the relevant template for a given exception will +be selected. A 'default' template may be provided for the general +case. Note that 'ERROR' can be pluralised to 'ERRORS' if you find +it more appropriate in this case. + + my $service = Template::Service->new({ + ERRORS => { + user => 'user/index.html', + dbi => 'error/database', + default => 'error/default', + }, + }); + +In this example, any 'user' exceptions thrown will cause the +'user/index.html' template to be processed, 'dbi' errors are handled +by 'error/database' and all others by the 'error/default' template. +Any PRE_PROCESS and/or POST_PROCESS templates will also be applied +to these error templates. + +Note that exception types are hierarchical and a 'foo' handler will +catch all 'foo.*' errors (e.g. foo.bar, foo.bar.baz) if a more +specific handler isn't defined. Be sure to quote any exception types +that contain periods to prevent Perl concatenating them into a single +string (i.e. C<user.passwd> is parsed as 'user'.'passwd'). + + my $service = Template::Service->new({ + ERROR => { + 'user.login' => 'user/login.html', + 'user.passwd' => 'user/badpasswd.html', + 'user' => 'user/index.html', + 'default' => 'error/default', + }, + }); + +In this example, any template processed by the $service object, or +other templates or code called from within, can raise a 'user.login' +exception and have the service redirect to the 'user/login.html' +template. Similarly, a 'user.passwd' exception has a specific +handling template, 'user/badpasswd.html', while all other 'user' or +'user.*' exceptions cause a redirection to the 'user/index.html' page. +All other exception types are handled by 'error/default'. + + +Exceptions can be raised in a template using the THROW directive, + + [% THROW user.login 'no user id: please login' %] + +or by calling the throw() method on the current Template::Context object, + + $context->throw('user.passwd', 'Incorrect Password'); + $context->throw('Incorrect Password'); # type 'undef' + +or from Perl code by calling die() with a Template::Exception object, + + die (Template::Exception->new('user.denied', 'Invalid User ID')); + +or by simply calling die() with an error string. This is +automagically caught and converted to an exception of 'undef' +type which can then be handled in the usual way. + + die "I'm sorry Dave, I can't do that"; + + + + + + + +=item AUTO_RESET + +The AUTO_RESET option is set by default and causes the local BLOCKS +cache for the Template::Context object to be reset on each call to the +Template process() method. This ensures that any BLOCKs defined +within a template will only persist until that template is finished +processing. This prevents BLOCKs defined in one processing request +from interfering with other independent requests subsequently +processed by the same context object. + +The BLOCKS item may be used to specify a default set of block definitions +for the Template::Context object. Subsequent BLOCK definitions in templates +will over-ride these but they will be reinstated on each reset if AUTO_RESET +is enabled (default), or if the Template::Context reset() method is called. + + + + + + + +=item DEBUG + +The DEBUG option can be used to enable debugging messages from the +Template::Service module by setting it to include the DEBUG_SERVICE +value. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_SERVICE, + }); + + + + +=back + +=head2 process($input, \%replace) + +The process() method is called to process a template specified as the first +parameter, $input. This may be a file name, file handle (e.g. GLOB or IO::Handle) +or a reference to a text string containing the template text. An additional +hash reference may be passed containing template variable definitions. + +The method processes the template, adding any PRE_PROCESS or POST_PROCESS +templates defined, and returns the output text. An uncaught exception thrown +by the template will be handled by a relevant ERROR handler if defined. +Errors that occur in the PRE_PROCESS or POST_PROCESS templates, or those that +occur in the main input template and aren't handled, cause the method to +return undef to indicate failure. The appropriate error message can be +retrieved via the error() method. + + $service->process('myfile.html', { title => 'My Test File' }) + || die $service->error(); + + +=head2 context() + +Returns a reference to the internal context object which is, by default, an +instance of the Template::Context class. + +=head2 error() + +Returns the most recent error message. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.70, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Context|Template::Context> diff --git a/lib/Template/Stash.pm b/lib/Template/Stash.pm new file mode 100644 index 0000000..4f26bca --- /dev/null +++ b/lib/Template/Stash.pm @@ -0,0 +1,1000 @@ +#============================================================= -*-Perl-*- +# +# Template::Stash +# +# DESCRIPTION +# Definition of an object class which stores and manages access to +# variables for the Template Toolkit. +# +# AUTHOR +# Andy Wardley <abw@wardley.org> +# +# COPYRIGHT +# Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Stash.pm,v 2.78 2003/07/24 12:13:32 abw Exp $ +# +#============================================================================ + +package Template::Stash; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.78 $ =~ /(\d+)\.(\d+)/); + + +#======================================================================== +# -- PACKAGE VARIABLES AND SUBS -- +#======================================================================== + +#------------------------------------------------------------------------ +# Definitions of various pseudo-methods. ROOT_OPS are merged into all +# new Template::Stash objects, and are thus default global functions. +# SCALAR_OPS are methods that can be called on a scalar, and ditto +# respectively for LIST_OPS and HASH_OPS +#------------------------------------------------------------------------ + +$ROOT_OPS = { + 'inc' => sub { local $^W = 0; my $item = shift; ++$item }, + 'dec' => sub { local $^W = 0; my $item = shift; --$item }, +# import => \&hash_import, + defined $ROOT_OPS ? %$ROOT_OPS : (), +}; + +$SCALAR_OPS = { + 'item' => sub { $_[0] }, + 'list' => sub { [ $_[0] ] }, + 'hash' => sub { { value => $_[0] } }, + 'length' => sub { length $_[0] }, + 'size' => sub { return 1 }, + 'defined' => sub { return 1 }, + 'repeat' => sub { + my ($str, $count) = @_; + $str = '' unless defined $str; + $count ||= 1; + return $str x $count; + }, + 'search' => sub { + my ($str, $pattern) = @_; + return $str unless defined $str and defined $pattern; + return $str =~ /$pattern/; + }, + 'replace' => sub { + my ($str, $search, $replace) = @_; + $replace = '' unless defined $replace; + return $str unless defined $str and defined $search; + $str =~ s/$search/$replace/g; +# print STDERR "s [ $search ] [ $replace ] g\n"; +# eval "\$str =~ s$search$replaceg"; + return $str; + }, + 'match' => sub { + my ($str, $search) = @_; + return $str unless defined $str and defined $search; + my @matches = ($str =~ /$search/); + return @matches ? \@matches : ''; + }, + 'split' => sub { + my ($str, $split, @args) = @_; + $str = '' unless defined $str; + return [ defined $split ? split($split, $str, @args) + : split(' ', $str, @args) ]; + }, + 'chunk' => sub { + my ($string, $size) = @_; + my @list; + $size ||= 1; + if ($size < 0) { + # sexeger! It's faster to reverse the string, search + # it from the front and then reverse the output than to + # search it from the end, believe it nor not! + $string = reverse $string; + $size = -$size; + unshift(@list, scalar reverse $1) + while ($string =~ /((.{$size})|(.+))/g); + } + else { + push(@list, $1) while ($string =~ /((.{$size})|(.+))/g); + } + return \@list; + }, + + + defined $SCALAR_OPS ? %$SCALAR_OPS : (), +}; + +$HASH_OPS = { + 'item' => sub { my ($hash, $item) = @_; + $item = '' unless defined $item; + $hash->{ $item }; + }, + 'hash' => sub { $_[0] }, + 'size' => sub { scalar keys %{$_[0]} }, + 'keys' => sub { [ keys %{ $_[0] } ] }, + 'values' => sub { [ values %{ $_[0] } ] }, + 'each' => sub { [ %{ $_[0] } ] }, + 'list' => sub { my ($hash, $what) = @_; $what ||= ''; + return ($what eq 'keys') ? [ keys %$hash ] + : ($what eq 'values') ? [ values %$hash ] + : ($what eq 'each') ? [ %$hash ] + : [ map { { key => $_ , value => $hash->{ $_ } } } + keys %$hash ]; + }, + 'exists' => sub { exists $_[0]->{ $_[1] } }, + 'defined' => sub { defined $_[0]->{ $_[1] } }, + 'import' => \&hash_import, + 'sort' => sub { + my ($hash) = @_; + [ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ]; + }, + 'nsort' => sub { + my ($hash) = @_; + [ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ]; + }, + defined $HASH_OPS ? %$HASH_OPS : (), +}; + +$LIST_OPS = { + 'item' => sub { $_[0]->[ $_[1] || 0 ] }, + 'list' => sub { $_[0] }, + 'hash' => sub { my $list = shift; my $n = 0; + return { map { ($n++, $_) } @$list }; }, + 'push' => sub { my $list = shift; push(@$list, shift); return '' }, + 'pop' => sub { my $list = shift; pop(@$list) }, + 'unshift' => sub { my $list = shift; unshift(@$list, shift); return '' }, + 'shift' => sub { my $list = shift; shift(@$list) }, + 'max' => sub { local $^W = 0; my $list = shift; $#$list; }, + 'size' => sub { local $^W = 0; my $list = shift; $#$list + 1; }, + 'first' => sub { + my $list = shift; + return $list->[0] unless @_; + return [ @$list[0..$_[0]-1] ]; + }, + 'last' => sub { + my $list = shift; + return $list->[-1] unless @_; + return [ @$list[-$_[0]..-1] ]; + }, + 'reverse' => sub { my $list = shift; [ reverse @$list ] }, + 'grep' => sub { + my ($list, $pattern) = @_; + $pattern ||= ''; + return [ grep /$pattern/, @$list ]; + }, + 'join' => sub { + my ($list, $joint) = @_; + join(defined $joint ? $joint : ' ', + map { defined $_ ? $_ : '' } @$list) + }, + 'sort' => sub { + $^W = 0; + my ($list, $field) = @_; + return $list unless @$list > 1; # no need to sort 1 item lists + return $field # Schwartzian Transform + ? map { $_->[0] } # for case insensitivity + sort { $a->[1] cmp $b->[1] } + map { [ $_, lc(ref($_) eq 'HASH' + ? $_->{ $field } : + UNIVERSAL::can($_, $field) + ? $_->$field() : $_) ] } + @$list + : map { $_->[0] } + sort { $a->[1] cmp $b->[1] } + map { [ $_, lc $_ ] } + @$list + }, + 'nsort' => sub { + my ($list, $field) = @_; + return $list unless $#$list; # no need to sort 1 item lists + return $field # Schwartzian Transform + ? map { $_->[0] } # for case insensitivity + sort { $a->[1] <=> $b->[1] } + map { [ $_, lc(ref($_) eq 'HASH' + ? $_->{ $field } : + UNIVERSAL::can($_, $field) + ? $_->$field() : $_) ] } + @$list + : map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [ $_, lc $_ ] } + @$list + }, + 'unique' => sub { my %u; [ grep { ++$u{$_} == 1 } @{$_[0]} ] }, + 'merge' => sub { + my $list = shift; + return [ @$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_ ]; + }, + 'slice' => sub { + my ($list, $from, $to) = @_; + $from ||= 0; + $to = $#$list unless defined $to; + return [ @$list[$from..$to] ]; + }, + 'splice' => sub { + my ($list, $offset, $length, @replace) = @_; + + if (@replace) { + # @replace can contain a list of multiple replace items, or + # be a single reference to a list + @replace = @{ $replace[0] } + if @replace == 1 && ref $replace[0] eq 'ARRAY'; + return [ splice @$list, $offset, $length, @replace ]; + } + elsif (defined $length) { + return [ splice @$list, $offset, $length ]; + } + elsif (defined $offset) { + return [ splice @$list, $offset ]; + } + else { + return [ splice(@$list) ]; + } + }, + + defined $LIST_OPS ? %$LIST_OPS : (), +}; + +sub hash_import { + my ($hash, $imp) = @_; + $imp = {} unless ref $imp eq 'HASH'; + @$hash{ keys %$imp } = values %$imp; + return ''; +} + + +#------------------------------------------------------------------------ +# define_vmethod($type, $name, \&sub) +# +# Defines a virtual method of type $type (SCALAR, HASH, or LIST), with +# name $name, that invokes &sub when called. It is expected that &sub +# be able to handle the type that it will be called upon. +#------------------------------------------------------------------------ + +sub define_vmethod { + my ($class, $type, $name, $sub) = @_; + my $op; + $type = lc $type; + + if ($type =~ /^scalar|item$/) { + $op = $SCALAR_OPS; + } + elsif ($type eq 'hash') { + $op = $HASH_OPS; + } + elsif ($type =~ /^list|array$/) { + $op = $LIST_OPS; + } + else { + die "invalid vmethod type: $type\n"; + } + + $op->{ $name } = $sub; + + return 1; +} + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%params) +# +# Constructor method which creates a new Template::Stash object. +# An optional hash reference may be passed containing variable +# definitions that will be used to initialise the stash. +# +# Returns a reference to a newly created Template::Stash. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ }; + + my $self = { + global => { }, + %$params, + %$ROOT_OPS, + '_PARENT' => undef, + }; + + bless $self, $class; +} + + +#======================================================================== +# ----- PUBLIC OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# clone(\%params) +# +# Creates a copy of the current stash object to effect localisation +# of variables. The new stash is blessed into the same class as the +# parent (which may be a derived class) and has a '_PARENT' member added +# which contains a reference to the parent stash that created it +# ($self). This member is used in a successive declone() method call to +# return the reference to the parent. +# +# A parameter may be provided which should reference a hash of +# variable/values which should be defined in the new stash. The +# update() method is called to define these new variables in the cloned +# stash. +# +# Returns a reference to a cloned Template::Stash. +#------------------------------------------------------------------------ + +sub clone { + my ($self, $params) = @_; + $params ||= { }; + + # look out for magical 'import' argument which imports another hash + my $import = $params->{ import }; + if (defined $import && UNIVERSAL::isa($import, 'HASH')) { + delete $params->{ import }; + } + else { + undef $import; + } + + my $clone = bless { + %$self, # copy all parent members + %$params, # copy all new data + '_PARENT' => $self, # link to parent + }, ref $self; + + # perform hash import if defined + &{ $HASH_OPS->{ import }}($clone, $import) + if defined $import; + + return $clone; +} + + +#------------------------------------------------------------------------ +# declone($export) +# +# Returns a reference to the PARENT stash. When called in the following +# manner: +# $stash = $stash->declone(); +# the reference count on the current stash will drop to 0 and be "freed" +# and the caller will be left with a reference to the parent. This +# contains the state of the stash before it was cloned. +#------------------------------------------------------------------------ + +sub declone { + my $self = shift; + $self->{ _PARENT } || $self; +} + + +#------------------------------------------------------------------------ +# get($ident) +# +# Returns the value for an variable stored in the stash. The variable +# may be specified as a simple string, e.g. 'foo', or as an array +# reference representing compound variables. In the latter case, each +# pair of successive elements in the list represent a node in the +# compound variable. The first is the variable name, the second a +# list reference of arguments or 0 if undefined. So, the compound +# variable [% foo.bar('foo').baz %] would be represented as the list +# [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the +# identifier or an empty string if undefined. Errors are thrown via +# die(). +#------------------------------------------------------------------------ + +sub get { + my ($self, $ident, $args) = @_; + my ($root, $result); + $root = $self; + + if (ref $ident eq 'ARRAY' + || ($ident =~ /\./) + && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) { + my $size = $#$ident; + + # if $ident is a list reference, then we evaluate each item in the + # identifier against the previous result, using the root stash + # ($self) as the first implicit 'result'... + + foreach (my $i = 0; $i <= $size; $i += 2) { + $result = $self->_dotop($root, @$ident[$i, $i+1]); + last unless defined $result; + $root = $result; + } + } + else { + $result = $self->_dotop($root, $ident, $args); + } + + return defined $result ? $result : $self->undefined($ident, $args); +} + + +#------------------------------------------------------------------------ +# set($ident, $value, $default) +# +# Updates the value for a variable in the stash. The first parameter +# should be the variable name or array, as per get(). The second +# parameter should be the intended value for the variable. The third, +# optional parameter is a flag which may be set to indicate 'default' +# mode. When set true, the variable will only be updated if it is +# currently undefined or has a false value. The magical 'IMPORT' +# variable identifier may be used to indicate that $value is a hash +# reference whose values should be imported. Returns the value set, +# or an empty string if not set (e.g. default mode). In the case of +# IMPORT, returns the number of items imported from the hash. +#------------------------------------------------------------------------ + +sub set { + my ($self, $ident, $value, $default) = @_; + my ($root, $result, $error); + + $root = $self; + + ELEMENT: { + if (ref $ident eq 'ARRAY' + || ($ident =~ /\./) + && ($ident = [ map { s/\(.*$//; ($_, 0) } + split(/\./, $ident) ])) { + + # a compound identifier may contain multiple elements (e.g. + # foo.bar.baz) and we must first resolve all but the last, + # using _dotop() with the $lvalue flag set which will create + # intermediate hashes if necessary... + my $size = $#$ident; + foreach (my $i = 0; $i < $size - 2; $i += 2) { + $result = $self->_dotop($root, @$ident[$i, $i+1], 1); + last ELEMENT unless defined $result; + $root = $result; + } + + # then we call _assign() to assign the value to the last element + $result = $self->_assign($root, @$ident[$size-1, $size], + $value, $default); + } + else { + $result = $self->_assign($root, $ident, 0, $value, $default); + } + } + + return defined $result ? $result : ''; +} + + +#------------------------------------------------------------------------ +# getref($ident) +# +# Returns a "reference" to a particular item. This is represented as a +# closure which will return the actual stash item when called. +# WARNING: still experimental! +#------------------------------------------------------------------------ + +sub getref { + my ($self, $ident, $args) = @_; + my ($root, $item, $result); + $root = $self; + + if (ref $ident eq 'ARRAY') { + my $size = $#$ident; + + foreach (my $i = 0; $i <= $size; $i += 2) { + ($item, $args) = @$ident[$i, $i + 1]; + last if $i >= $size - 2; # don't evaluate last node + last unless defined + ($root = $self->_dotop($root, $item, $args)); + } + } + else { + $item = $ident; + } + + if (defined $root) { + return sub { my @args = (@{$args||[]}, @_); + $self->_dotop($root, $item, \@args); + } + } + else { + return sub { '' }; + } +} + + + + +#------------------------------------------------------------------------ +# update(\%params) +# +# Update multiple variables en masse. No magic is performed. Simple +# variable names only. +#------------------------------------------------------------------------ + +sub update { + my ($self, $params) = @_; + + # look out for magical 'import' argument to import another hash + my $import = $params->{ import }; + if (defined $import && UNIVERSAL::isa($import, 'HASH')) { + @$self{ keys %$import } = values %$import; + delete $params->{ import }; + } + + @$self{ keys %$params } = values %$params; +} + + +#------------------------------------------------------------------------ +# undefined($ident, $args) +# +# Method called when a get() returns an undefined value. Can be redefined +# in a subclass to implement alternate handling. +#------------------------------------------------------------------------ + +sub undefined { + my ($self, $ident, $args); + return ''; +} + + +#======================================================================== +# ----- PRIVATE OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# _dotop($root, $item, \@args, $lvalue) +# +# This is the core 'dot' operation method which evaluates elements of +# variables against their root. All variables have an implicit root +# which is the stash object itself (a hash). Thus, a non-compound +# variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is +# '(stash.)foo.bar'. The first parameter is a reference to the current +# root, initially the stash itself. The second parameter contains the +# name of the variable element, e.g. 'foo'. The third optional +# parameter is a reference to a list of any parenthesised arguments +# specified for the variable, which are passed to sub-routines, object +# methods, etc. The final parameter is an optional flag to indicate +# if this variable is being evaluated on the left side of an assignment +# (e.g. foo.bar.baz = 10). When set true, intermediated hashes will +# be created (e.g. bar) if necessary. +# +# Returns the result of evaluating the item against the root, having +# performed any variable "magic". The value returned can then be used +# as the root of the next _dotop() in a compound sequence. Returns +# undef if the variable is undefined. +#------------------------------------------------------------------------ + +sub _dotop { + my ($self, $root, $item, $args, $lvalue) = @_; + my $rootref = ref $root; + my $atroot = ($root eq $self); + my ($value, @result); + + $args ||= [ ]; + $lvalue ||= 0; + +# print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n" +# if $DEBUG; + + # return undef without an error if either side of the dot is unviable + # or if an attempt is made to access a private member, starting _ or . + return undef + unless defined($root) and defined($item) and $item !~ /^[\._]/; + + if ($atroot || $rootref eq 'HASH') { + + # if $root is a regular HASH or a Template::Stash kinda HASH (the + # *real* root of everything). We first lookup the named key + # in the hash, or create an empty hash in its place if undefined + # and the $lvalue flag is set. Otherwise, we check the HASH_OPS + # pseudo-methods table, calling the code if found, or return undef. + + if (defined($value = $root->{ $item })) { + return $value unless ref $value eq 'CODE'; ## RETURN + @result = &$value(@$args); ## @result + } + elsif ($lvalue) { + # we create an intermediate hash if this is an lvalue + return $root->{ $item } = { }; ## RETURN + } + # ugly hack: only allow import vmeth to be called on root stash + elsif (($value = $HASH_OPS->{ $item }) + && ! $atroot || $item eq 'import') { + @result = &$value($root, @$args); ## @result + } + elsif ( ref $item eq 'ARRAY' ) { + # hash slice + return [@$root{@$item}]; ## RETURN + } + } + elsif ($rootref eq 'ARRAY') { + + # if root is an ARRAY then we check for a LIST_OPS pseudo-method + # (except for l-values for which it doesn't make any sense) + # or return the numerical index into the array, or undef + + if (($value = $LIST_OPS->{ $item }) && ! $lvalue) { + @result = &$value($root, @$args); ## @result + } + elsif ($item =~ /^-?\d+$/) { + $value = $root->[$item]; + return $value unless ref $value eq 'CODE'; ## RETURN + @result = &$value(@$args); ## @result + } + elsif ( ref $item eq 'ARRAY' ) { + # array slice + return [@$root[@$item]]; ## RETURN + } + } + + # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL') + # doesn't appear to work with CGI, returning true for the first call + # and false for all subsequent calls. + + elsif (ref($root) && UNIVERSAL::can($root, 'can')) { + + # if $root is a blessed reference (i.e. inherits from the + # UNIVERSAL object base class) then we call the item as a method. + # If that fails then we try to fallback on HASH behaviour if + # possible. + eval { @result = $root->$item(@$args); }; + + if ($@) { + # temporary hack - required to propogate errors thrown + # by views; if $@ is a ref (e.g. Template::Exception + # object then we assume it's a real error that needs + # real throwing + + die $@ if ref($@) || ($@ !~ /Can't locate object method/); + + # failed to call object method, so try some fallbacks + if (UNIVERSAL::isa($root, 'HASH') + && defined($value = $root->{ $item })) { + return $value unless ref $value eq 'CODE'; ## RETURN + @result = &$value(@$args); + } + elsif (UNIVERSAL::isa($root, 'ARRAY') + && ($value = $LIST_OPS->{ $item })) { + @result = &$value($root, @$args); + } + elsif ($value = $SCALAR_OPS->{ $item }) { + @result = &$value($root, @$args); + } + elsif ($value = $LIST_OPS->{ $item }) { + @result = &$value([$root], @$args); + } + elsif ($self->{ _DEBUG }) { + @result = (undef, $@); + } + } + } + elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { + # at this point, it doesn't look like we've got a reference to + # anything we know about, so we try the SCALAR_OPS pseudo-methods + # table (but not for l-values) + @result = &$value($root, @$args); ## @result + } + elsif (($value = $LIST_OPS->{ $item }) && ! $lvalue) { + # last-ditch: can we promote a scalar to a one-element + # list and apply a LIST_OPS virtual method? + @result = &$value([$root], @$args); + } + elsif ($self->{ _DEBUG }) { + die "don't know how to access [ $root ].$item\n"; ## DIE + } + else { + @result = (); + } + + # fold multiple return items into a list unless first item is undef + if (defined $result[0]) { + return ## RETURN + scalar @result > 1 ? [ @result ] : $result[0]; + } + elsif (defined $result[1]) { + die $result[1]; ## DIE + } + elsif ($self->{ _DEBUG }) { + die "$item is undefined\n"; ## DIE + } + + return undef; +} + + +#------------------------------------------------------------------------ +# _assign($root, $item, \@args, $value, $default) +# +# Similar to _dotop() above, but assigns a value to the given variable +# instead of simply returning it. The first three parameters are the +# root item, the item and arguments, as per _dotop(), followed by the +# value to which the variable should be set and an optional $default +# flag. If set true, the variable will only be set if currently false +# (undefined/zero) +#------------------------------------------------------------------------ + +sub _assign { + my ($self, $root, $item, $args, $value, $default) = @_; + my $rootref = ref $root; + my $atroot = ($root eq $self); + my $result; + $args ||= [ ]; + $default ||= 0; + +# print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n", +# "value=$value, default=$default)\n") +# if $DEBUG; + + # return undef without an error if either side of the dot is unviable + # or if an attempt is made to update a private member, starting _ or . + return undef ## RETURN + unless $root and defined $item and $item !~ /^[\._]/; + + if ($rootref eq 'HASH' || $atroot) { +# if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) { +# # import hash entries into root hash +# @$root{ keys %$value } = values %$value; +# return ''; ## RETURN +# } + # if the root is a hash we set the named key + return ($root->{ $item } = $value) ## RETURN + unless $default && $root->{ $item }; + } + elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) { + # or set a list item by index number + return ($root->[$item] = $value) ## RETURN + unless $default && $root->{ $item }; + } + elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) { + # try to call the item as a method of an object + + return $root->$item(@$args, $value) ## RETURN + unless $default && $root->$item(); + +# 2 issues: +# - method call should be wrapped in eval { } +# - fallback on hash methods if object method not found +# +# eval { $result = $root->$item(@$args, $value); }; +# +# if ($@) { +# die $@ if ref($@) || ($@ !~ /Can't locate object method/); +# +# # failed to call object method, so try some fallbacks +# if (UNIVERSAL::isa($root, 'HASH') && exists $root->{ $item }) { +# $result = ($root->{ $item } = $value) +# unless $default && $root->{ $item }; +# } +# } +# return $result; ## RETURN + + } + else { + die "don't know how to assign to [$root].[$item]\n"; ## DIE + } + + return undef; +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the object. The method calls itself recursively to dump sub-hashes. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + return "[Template::Stash] " . $self->_dump_frame(2); +} + +sub _dump_frame { + my ($self, $indent) = @_; + $indent ||= 1; + my $buffer = ' '; + my $pad = $buffer x $indent; + my $text = "{\n"; + local $" = ', '; + + my ($key, $value); + + return $text . "...excessive recursion, terminating\n" + if $indent > 32; + + foreach $key (keys %$self) { + $value = $self->{ $key }; + $value = '<undef>' unless defined $value; + next if $key =~ /^\./; + if (ref($value) eq 'ARRAY') { + $value = '[ ' . join(', ', map { defined $_ ? $_ : '<undef>' } + @$value) . ' ]'; + } + elsif (ref $value eq 'HASH') { + $value = _dump_frame($value, $indent + 1); + } + + $text .= sprintf("$pad%-16s => $value\n", $key); + } + $text .= $buffer x ($indent - 1) . '}'; + return $text; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Stash - Magical storage for template variables + +=head1 SYNOPSIS + + use Template::Stash; + + my $stash = Template::Stash->new(\%vars); + + # get variable values + $value = $stash->get($variable); + $value = $stash->get(\@compound); + + # set variable value + $stash->set($variable, $value); + $stash->set(\@compound, $value); + + # default variable value + $stash->set($variable, $value, 1); + $stash->set(\@compound, $value, 1); + + # set variable values en masse + $stash->update(\%new_vars) + + # methods for (de-)localising variables + $stash = $stash->clone(\%new_vars); + $stash = $stash->declone(); + +=head1 DESCRIPTION + +The Template::Stash module defines an object class which is used to store +variable values for the runtime use of the template processor. Variable +values are stored internally in a hash reference (which itself is blessed +to create the object) and are accessible via the get() and set() methods. + +Variables may reference hash arrays, lists, subroutines and objects +as well as simple values. The stash automatically performs the right +magic when dealing with variables, calling code or object methods, +indexing into lists, hashes, etc. + +The stash has clone() and declone() methods which are used by the +template processor to make temporary copies of the stash for +localising changes made to variables. + +=head1 PUBLIC METHODS + +=head2 new(\%params) + +The new() constructor method creates and returns a reference to a new +Template::Stash object. + + my $stash = Template::Stash->new(); + +A hash reference may be passed to provide variables and values which +should be used to initialise the stash. + + my $stash = Template::Stash->new({ var1 => 'value1', + var2 => 'value2' }); + +=head2 get($variable) + +The get() method retrieves the variable named by the first parameter. + + $value = $stash->get('var1'); + +Dotted compound variables can be retrieved by specifying the variable +elements by reference to a list. Each node in the variable occupies +two entries in the list. The first gives the name of the variable +element, the second is a reference to a list of arguments for that +element, or 0 if none. + + [% foo.bar(10).baz(20) %] + + $stash->get([ 'foo', 0, 'bar', [ 10 ], 'baz', [ 20 ] ]); + +=head2 set($variable, $value, $default) + +The set() method sets the variable name in the first parameter to the +value specified in the second. + + $stash->set('var1', 'value1'); + +If the third parameter evaluates to a true value, the variable is +set only if it did not have a true value before. + + $stash->set('var2', 'default_value', 1); + +Dotted compound variables may be specified as per get() above. + + [% foo.bar = 30 %] + + $stash->set([ 'foo', 0, 'bar', 0 ], 30); + +The magical variable 'IMPORT' can be specified whose corresponding +value should be a hash reference. The contents of the hash array are +copied (i.e. imported) into the current namespace. + + # foo.bar = baz, foo.wiz = waz + $stash->set('foo', { 'bar' => 'baz', 'wiz' => 'waz' }); + + # import 'foo' into main namespace: foo = baz, wiz = waz + $stash->set('IMPORT', $stash->get('foo')); + +=head2 clone(\%params) + +The clone() method creates and returns a new Template::Stash object which +represents a localised copy of the parent stash. Variables can be +freely updated in the cloned stash and when declone() is called, the +original stash is returned with all its members intact and in the +same state as they were before clone() was called. + +For convenience, a hash of parameters may be passed into clone() which +is used to update any simple variable (i.e. those that don't contain any +namespace elements like 'foo' and 'bar' but not 'foo.bar') variables while +cloning the stash. For adding and updating complex variables, the set() +method should be used after calling clone(). This will correctly resolve +and/or create any necessary namespace hashes. + +A cloned stash maintains a reference to the stash that it was copied +from in its '_PARENT' member. + +=head2 declone() + +The declone() method returns the '_PARENT' reference and can be used to +restore the state of a stash as described above. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.78, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Context|Template::Context> diff --git a/lib/Template/Stash/Context.pm b/lib/Template/Stash/Context.pm new file mode 100644 index 0000000..8f9cfdb --- /dev/null +++ b/lib/Template/Stash/Context.pm @@ -0,0 +1,781 @@ +#============================================================= -*-Perl-*- +# +# Template::Stash::Context +# +# DESCRIPTION +# This is an alternate stash object which includes a patch from +# Craig Barratt to implement various new virtual methods to allow +# dotted template variable to denote if object methods and subroutines +# should be called in scalar or list context. It adds a little overhead +# to each stash call and I'm a little wary of doing that. So for now, +# it's implemented as a separate stash module which will allow us to +# test it out, benchmark it and switch it in or out as we require. +# +# This is what Craig has to say about it: +# +# Here's a better set of features for the core. Attached is a new version +# of Stash.pm (based on TT2.02) that: +# +# - supports the special op "scalar" that forces scalar context on +# function calls, eg: +# +# cgi.param("foo").scalar +# +# calls cgi.param("foo") in scalar context (unlike my wimpy +# scalar op from last night). Array context is the default. +# +# With non-function operands, scalar behaves like the perl +# version (eg: no-op for scalar, size for arrays, etc). +# +# - supports the special op "ref" that behaves like the perl ref. +# If applied to a function the function is not called. Eg: +# +# cgi.param("foo").ref +# +# does *not* call cgi.param and evaluates to "CODE". Similarly, +# HASH.ref, ARRAY.ref return what you expect. +# +# - adds a new scalar and list op called "array" that is a no-op for +# arrays and promotes scalars to one-element arrays. +# +# - allows scalar ops to be applied to arrays and hashes in place, +# eg: ARRAY.repeat(3) repeats each element in place. +# +# - allows list ops to be applied to scalars by promoting the scalars +# to one-element arrays (like an implicit "array"). So you can +# do things like SCALAR.size, SCALAR.join and get a useful result. +# +# This also means you can now use x.0 to safely get the first element +# whether x is an array or scalar. +# +# The new Stash.pm passes the TT2.02 test suite. But I haven't tested the +# new features very much. One nagging implementation problem is that the +# "scalar" and "ref" ops have higher precedence than user variable names. +# +# AUTHORS +# Andy Wardley <abw@kfs.org> +# Craig Barratt <craig@arraycomm.com> +# +# COPYRIGHT +# Copyright (C) 1996-2001 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2001 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Context.pm,v 1.53 2003/04/24 09:14:47 abw Exp $ +# +#============================================================================ + +package Template::Stash::Context; + +require 5.004; + +use strict; +use Template::Stash; +use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS ); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.53 $ =~ /(\d+)\.(\d+)/); + + +#======================================================================== +# -- PACKAGE VARIABLES AND SUBS -- +#======================================================================== + +#------------------------------------------------------------------------ +# copy virtual methods from those in the regular Template::Stash +#------------------------------------------------------------------------ + +$ROOT_OPS = { + %$Template::Stash::ROOT_OPS, + defined $ROOT_OPS ? %$ROOT_OPS : (), +}; + +$SCALAR_OPS = { + %$Template::Stash::SCALAR_OPS, + 'array' => sub { return [$_[0]] }, + defined $SCALAR_OPS ? %$SCALAR_OPS : (), +}; + +$LIST_OPS = { + %$Template::Stash::LIST_OPS, + 'array' => sub { return $_[0] }, + defined $LIST_OPS ? %$LIST_OPS : (), +}; + +$HASH_OPS = { + %$Template::Stash::HASH_OPS, + defined $HASH_OPS ? %$HASH_OPS : (), +}; + + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%params) +# +# Constructor method which creates a new Template::Stash object. +# An optional hash reference may be passed containing variable +# definitions that will be used to initialise the stash. +# +# Returns a reference to a newly created Template::Stash. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ }; + + my $self = { + global => { }, + %$params, + %$ROOT_OPS, + '_PARENT' => undef, + }; + + bless $self, $class; +} + + +#======================================================================== +# ----- PUBLIC OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# clone(\%params) +# +# Creates a copy of the current stash object to effect localisation +# of variables. The new stash is blessed into the same class as the +# parent (which may be a derived class) and has a '_PARENT' member added +# which contains a reference to the parent stash that created it +# ($self). This member is used in a successive declone() method call to +# return the reference to the parent. +# +# A parameter may be provided which should reference a hash of +# variable/values which should be defined in the new stash. The +# update() method is called to define these new variables in the cloned +# stash. +# +# Returns a reference to a cloned Template::Stash. +#------------------------------------------------------------------------ + +sub clone { + my ($self, $params) = @_; + $params ||= { }; + + # look out for magical 'import' argument which imports another hash + my $import = $params->{ import }; + if (defined $import && UNIVERSAL::isa($import, 'HASH')) { + delete $params->{ import }; + } + else { + undef $import; + } + + my $clone = bless { + %$self, # copy all parent members + %$params, # copy all new data + '_PARENT' => $self, # link to parent + }, ref $self; + + # perform hash import if defined + &{ $HASH_OPS->{ import }}($clone, $import) + if defined $import; + + return $clone; +} + + +#------------------------------------------------------------------------ +# declone($export) +# +# Returns a reference to the PARENT stash. When called in the following +# manner: +# $stash = $stash->declone(); +# the reference count on the current stash will drop to 0 and be "freed" +# and the caller will be left with a reference to the parent. This +# contains the state of the stash before it was cloned. +#------------------------------------------------------------------------ + +sub declone { + my $self = shift; + $self->{ _PARENT } || $self; +} + + +#------------------------------------------------------------------------ +# get($ident) +# +# Returns the value for an variable stored in the stash. The variable +# may be specified as a simple string, e.g. 'foo', or as an array +# reference representing compound variables. In the latter case, each +# pair of successive elements in the list represent a node in the +# compound variable. The first is the variable name, the second a +# list reference of arguments or 0 if undefined. So, the compound +# variable [% foo.bar('foo').baz %] would be represented as the list +# [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the +# identifier or an empty string if undefined. Errors are thrown via +# die(). +#------------------------------------------------------------------------ + +sub get { + my ($self, $ident, $args) = @_; + my ($root, $result); + $root = $self; + + if (ref $ident eq 'ARRAY' + || ($ident =~ /\./) + && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) { + my $size = $#$ident; + + # if $ident is a list reference, then we evaluate each item in the + # identifier against the previous result, using the root stash + # ($self) as the first implicit 'result'... + + foreach (my $i = 0; $i <= $size; $i += 2) { + if ( $i + 2 <= $size && ($ident->[$i+2] eq "scalar" + || $ident->[$i+2] eq "ref") ) { + $result = $self->_dotop($root, @$ident[$i, $i+1], 0, + $ident->[$i+2]); + $i += 2; + } else { + $result = $self->_dotop($root, @$ident[$i, $i+1]); + } + last unless defined $result; + $root = $result; + } + } + else { + $result = $self->_dotop($root, $ident, $args); + } + + return defined $result ? $result : ''; +} + + +#------------------------------------------------------------------------ +# set($ident, $value, $default) +# +# Updates the value for a variable in the stash. The first parameter +# should be the variable name or array, as per get(). The second +# parameter should be the intended value for the variable. The third, +# optional parameter is a flag which may be set to indicate 'default' +# mode. When set true, the variable will only be updated if it is +# currently undefined or has a false value. The magical 'IMPORT' +# variable identifier may be used to indicate that $value is a hash +# reference whose values should be imported. Returns the value set, +# or an empty string if not set (e.g. default mode). In the case of +# IMPORT, returns the number of items imported from the hash. +#------------------------------------------------------------------------ + +sub set { + my ($self, $ident, $value, $default) = @_; + my ($root, $result, $error); + + $root = $self; + + ELEMENT: { + if (ref $ident eq 'ARRAY' + || ($ident =~ /\./) + && ($ident = [ map { s/\(.*$//; ($_, 0) } + split(/\./, $ident) ])) { + + # a compound identifier may contain multiple elements (e.g. + # foo.bar.baz) and we must first resolve all but the last, + # using _dotop() with the $lvalue flag set which will create + # intermediate hashes if necessary... + my $size = $#$ident; + foreach (my $i = 0; $i < $size - 2; $i += 2) { + $result = $self->_dotop($root, @$ident[$i, $i+1], 1); + last ELEMENT unless defined $result; + $root = $result; + } + + # then we call _assign() to assign the value to the last element + $result = $self->_assign($root, @$ident[$size-1, $size], + $value, $default); + } + else { + $result = $self->_assign($root, $ident, 0, $value, $default); + } + } + + return defined $result ? $result : ''; +} + + +#------------------------------------------------------------------------ +# getref($ident) +# +# Returns a "reference" to a particular item. This is represented as a +# closure which will return the actual stash item when called. +# WARNING: still experimental! +#------------------------------------------------------------------------ + +sub getref { + my ($self, $ident, $args) = @_; + my ($root, $item, $result); + $root = $self; + + if (ref $ident eq 'ARRAY') { + my $size = $#$ident; + + foreach (my $i = 0; $i <= $size; $i += 2) { + ($item, $args) = @$ident[$i, $i + 1]; + last if $i >= $size - 2; # don't evaluate last node + last unless defined + ($root = $self->_dotop($root, $item, $args)); + } + } + else { + $item = $ident; + } + + if (defined $root) { + return sub { my @args = (@{$args||[]}, @_); + $self->_dotop($root, $item, \@args); + } + } + else { + return sub { '' }; + } +} + + + + +#------------------------------------------------------------------------ +# update(\%params) +# +# Update multiple variables en masse. No magic is performed. Simple +# variable names only. +#------------------------------------------------------------------------ + +sub update { + my ($self, $params) = @_; + + # look out for magical 'import' argument to import another hash + my $import = $params->{ import }; + if (defined $import && UNIVERSAL::isa($import, 'HASH')) { + @$self{ keys %$import } = values %$import; + delete $params->{ import }; + } + + @$self{ keys %$params } = values %$params; +} + + +#======================================================================== +# ----- PRIVATE OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# _dotop($root, $item, \@args, $lvalue, $nextItem) +# +# This is the core 'dot' operation method which evaluates elements of +# variables against their root. All variables have an implicit root +# which is the stash object itself (a hash). Thus, a non-compound +# variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is +# '(stash.)foo.bar'. The first parameter is a reference to the current +# root, initially the stash itself. The second parameter contains the +# name of the variable element, e.g. 'foo'. The third optional +# parameter is a reference to a list of any parenthesised arguments +# specified for the variable, which are passed to sub-routines, object +# methods, etc. The final parameter is an optional flag to indicate +# if this variable is being evaluated on the left side of an assignment +# (e.g. foo.bar.baz = 10). When set true, intermediated hashes will +# be created (e.g. bar) if necessary. +# +# Returns the result of evaluating the item against the root, having +# performed any variable "magic". The value returned can then be used +# as the root of the next _dotop() in a compound sequence. Returns +# undef if the variable is undefined. +#------------------------------------------------------------------------ + +sub _dotop { + my ($self, $root, $item, $args, $lvalue, $nextItem) = @_; + my $rootref = ref $root; + my ($value, @result, $ret, $retVal); + $nextItem ||= ""; + my $scalarContext = 1 if ( $nextItem eq "scalar" ); + my $returnRef = 1 if ( $nextItem eq "ref" ); + + $args ||= [ ]; + $lvalue ||= 0; + +# print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n" +# if $DEBUG; + + # return undef without an error if either side of the dot is unviable + # or if an attempt is made to access a private member, starting _ or . + return undef + unless defined($root) and defined($item) and $item !~ /^[\._]/; + + if (ref(\$root) eq "SCALAR" && !$lvalue && + (($value = $LIST_OPS->{ $item }) || $item =~ /^-?\d+$/) ) { + # + # Promote scalar to one element list, to be processed below. + # + $rootref = 'ARRAY'; + $root = [$root]; + } + if ($rootref eq __PACKAGE__ || $rootref eq 'HASH') { + + # if $root is a regular HASH or a Template::Stash kinda HASH (the + # *real* root of everything). We first lookup the named key + # in the hash, or create an empty hash in its place if undefined + # and the $lvalue flag is set. Otherwise, we check the HASH_OPS + # pseudo-methods table, calling the code if found, or return undef. + + if (defined($value = $root->{ $item })) { + ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef, + $scalarContext); + return $retVal if ( $ret ); ## RETURN + } + elsif ($lvalue) { + # we create an intermediate hash if this is an lvalue + return $root->{ $item } = { }; ## RETURN + } + elsif ($value = $HASH_OPS->{ $item }) { + @result = &$value($root, @$args); ## @result + } + elsif (ref $item eq 'ARRAY') { + # hash slice + return [@$root{@$item}]; ## RETURN + } + elsif ($value = $SCALAR_OPS->{ $item }) { + # + # Apply scalar ops to every hash element, in place. + # + foreach my $key ( keys %$root ) { + $root->{$key} = &$value($root->{$key}, @$args); + } + } + } + elsif ($rootref eq 'ARRAY') { + + # if root is an ARRAY then we check for a LIST_OPS pseudo-method + # (except for l-values for which it doesn't make any sense) + # or return the numerical index into the array, or undef + + if (($value = $LIST_OPS->{ $item }) && ! $lvalue) { + @result = &$value($root, @$args); ## @result + } + elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { + # + # Apply scalar ops to every array element, in place. + # + for ( my $i = 0 ; $i < @$root ; $i++ ) { + $root->[$i] = &$value($root->[$i], @$args); ## @result + } + } + elsif ($item =~ /^-?\d+$/) { + $value = $root->[$item]; + ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef, + $scalarContext); + return $retVal if ( $ret ); ## RETURN + } + elsif (ref $item eq 'ARRAY' ) { + # array slice + return [@$root[@$item]]; ## RETURN + } + } + + # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL') + # doesn't appear to work with CGI, returning true for the first call + # and false for all subsequent calls. + + elsif (ref($root) && UNIVERSAL::can($root, 'can')) { + + # if $root is a blessed reference (i.e. inherits from the + # UNIVERSAL object base class) then we call the item as a method. + # If that fails then we try to fallback on HASH behaviour if + # possible. + return ref $root->can($item) if ( $returnRef ); ## RETURN + eval { + @result = $scalarContext ? scalar $root->$item(@$args) + : $root->$item(@$args); ## @result + }; + + if ($@) { + # failed to call object method, so try some fallbacks + if (UNIVERSAL::isa($root, 'HASH') + && defined($value = $root->{ $item })) { + ($ret, $retVal, @result) = _dotop_return($value, $args, + $returnRef, $scalarContext); + return $retVal if ( $ret ); ## RETURN + } + elsif (UNIVERSAL::isa($root, 'ARRAY') + && ($value = $LIST_OPS->{ $item })) { + @result = &$value($root, @$args); + } + else { + @result = (undef, $@); + } + } + } + elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { + + # at this point, it doesn't look like we've got a reference to + # anything we know about, so we try the SCALAR_OPS pseudo-methods + # table (but not for l-values) + + @result = &$value($root, @$args); ## @result + } + elsif ($self->{ _DEBUG }) { + die "don't know how to access [ $root ].$item\n"; ## DIE + } + else { + @result = (); + } + + # fold multiple return items into a list unless first item is undef + if (defined $result[0]) { + return ref(@result > 1 ? [ @result ] : $result[0]) + if ( $returnRef ); ## RETURN + if ( $scalarContext ) { + return scalar @result if ( @result > 1 ); ## RETURN + return scalar(@{$result[0]}) if ( ref $result[0] eq "ARRAY" ); + return scalar(%{$result[0]}) if ( ref $result[0] eq "HASH" ); + return $result[0]; ## RETURN + } else { + return @result > 1 ? [ @result ] : $result[0]; ## RETURN + } + } + elsif (defined $result[1]) { + die $result[1]; ## DIE + } + elsif ($self->{ _DEBUG }) { + die "$item is undefined\n"; ## DIE + } + + return undef; +} + +#------------------------------------------------------------------------ +# ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef, +# $scalarContext); +# +# Handle the various return processing for _dotop +#------------------------------------------------------------------------ +sub _dotop_return +{ + my($value, $args, $returnRef, $scalarContext) = @_; + my(@result); + + return (1, ref $value) if ( $returnRef ); ## RETURN + if ( $scalarContext ) { + return (1, scalar(@$value)) if ref $value eq 'ARRAY'; ## RETURN + return (1, scalar(%$value)) if ref $value eq 'HASH'; ## RETURN + return (1, scalar($value)) unless ref $value eq 'CODE'; ## RETURN; + @result = scalar &$value(@$args) ## @result; + } else { + return (1, $value) unless ref $value eq 'CODE'; ## RETURN + @result = &$value(@$args); ## @result + } + return (0, undef, @result); +} + + +#------------------------------------------------------------------------ +# _assign($root, $item, \@args, $value, $default) +# +# Similar to _dotop() above, but assigns a value to the given variable +# instead of simply returning it. The first three parameters are the +# root item, the item and arguments, as per _dotop(), followed by the +# value to which the variable should be set and an optional $default +# flag. If set true, the variable will only be set if currently false +# (undefined/zero) +#------------------------------------------------------------------------ + +sub _assign { + my ($self, $root, $item, $args, $value, $default) = @_; + my $rootref = ref $root; + my $result; + $args ||= [ ]; + $default ||= 0; + +# print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n", +# "value=$value, default=$default)\n") +# if $DEBUG; + + # return undef without an error if either side of the dot is unviable + # or if an attempt is made to update a private member, starting _ or . + return undef ## RETURN + unless $root and defined $item and $item !~ /^[\._]/; + + if ($rootref eq 'HASH' || $rootref eq __PACKAGE__) { +# if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) { +# # import hash entries into root hash +# @$root{ keys %$value } = values %$value; +# return ''; ## RETURN +# } + # if the root is a hash we set the named key + return ($root->{ $item } = $value) ## RETURN + unless $default && $root->{ $item }; + } + elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) { + # or set a list item by index number + return ($root->[$item] = $value) ## RETURN + unless $default && $root->{ $item }; + } + elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) { + # try to call the item as a method of an object + return $root->$item(@$args, $value); ## RETURN + } + else { + die "don't know how to assign to [$root].[$item]\n"; ## DIE + } + + return undef; +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the object. The method calls itself recursively to dump sub-hashes. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $indent = shift || 1; + my $buffer = ' '; + my $pad = $buffer x $indent; + my $text = ''; + local $" = ', '; + + my ($key, $value); + + + return $text . "...excessive recursion, terminating\n" + if $indent > 32; + + foreach $key (keys %$self) { + + $value = $self->{ $key }; + $value = '<undef>' unless defined $value; + + if (ref($value) eq 'ARRAY') { + $value = "$value [@$value]"; + } + $text .= sprintf("$pad%-8s => $value\n", $key); + next if $key =~ /^\./; + if (UNIVERSAL::isa($value, 'HASH')) { + $text .= _dump($value, $indent + 1); + } + } + $text; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Stash::Context - Experimetal stash allowing list/scalar context definition + +=head1 SYNOPSIS + + use Template; + use Template::Stash::Context; + + my $stash = Template::Stash::Context->new(\%vars); + my $tt2 = Template->new({ STASH => $stash }); + +=head1 DESCRIPTION + +This is an alternate stash object which includes a patch from +Craig Barratt to implement various new virtual methods to allow +dotted template variable to denote if object methods and subroutines +should be called in scalar or list context. It adds a little overhead +to each stash call and I'm a little wary of applying that to the core +default stash without investigating the effects first. So for now, +it's implemented as a separate stash module which will allow us to +test it out, benchmark it and switch it in or out as we require. + +This is what Craig has to say about it: + +Here's a better set of features for the core. Attached is a new version +of Stash.pm (based on TT2.02) that: + +* supports the special op "scalar" that forces scalar context on +function calls, eg: + + cgi.param("foo").scalar + +calls cgi.param("foo") in scalar context (unlike my wimpy +scalar op from last night). Array context is the default. + +With non-function operands, scalar behaves like the perl +version (eg: no-op for scalar, size for arrays, etc). + +* supports the special op "ref" that behaves like the perl ref. +If applied to a function the function is not called. Eg: + + cgi.param("foo").ref + +does *not* call cgi.param and evaluates to "CODE". Similarly, +HASH.ref, ARRAY.ref return what you expect. + +* adds a new scalar and list op called "array" that is a no-op for +arrays and promotes scalars to one-element arrays. + +* allows scalar ops to be applied to arrays and hashes in place, +eg: ARRAY.repeat(3) repeats each element in place. + +* allows list ops to be applied to scalars by promoting the scalars +to one-element arrays (like an implicit "array"). So you can +do things like SCALAR.size, SCALAR.join and get a useful result. + +This also means you can now use x.0 to safely get the first element +whether x is an array or scalar. + +The new Stash.pm passes the TT2.02 test suite. But I haven't tested the +new features very much. One nagging implementation problem is that the +"scalar" and "ref" ops have higher precedence than user variable names. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +1.53, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template::Stash|Template::Stash> diff --git a/lib/Template/Stash/XS.pm b/lib/Template/Stash/XS.pm new file mode 100644 index 0000000..ca37c08 --- /dev/null +++ b/lib/Template/Stash/XS.pm @@ -0,0 +1,176 @@ +#============================================================= -*-Perl-*- +# +# Template::Stash::XS +# +# DESCRIPTION +# +# Perl bootstrap for XS module. Inherits methods from +# Template::Stash when not implemented in the XS module. +# +#======================================================================== + +package Template::Stash::XS; + +use Template; +use Template::Stash; + +BEGIN { + require DynaLoader; + @Template::Stash::XS::ISA = qw( DynaLoader Template::Stash ); + + eval { + bootstrap Template::Stash::XS $Template::VERSION; + }; + if ($@) { + die "Couldn't load Template::Stash::XS $Template::VERSION:\n\n$@\n"; + } +} + + +sub DESTROY { + # no op + 1; +} + + +# catch missing method calls here so perl doesn't barf +# trying to load *.al files +sub AUTOLOAD { + my ($self, @args) = @_; + my @c = caller(0); + my $auto = $AUTOLOAD; + + $auto =~ s/.*:://; + $self =~ s/=.*//; + + die "Can't locate object method \"$auto\"" . + " via package \"$self\" at $c[1] line $c[2]\n"; +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Stash::XS - Experimetal high-speed stash written in XS + +=head1 SYNOPSIS + + use Template; + use Template::Stash::XS; + + my $stash = Template::Stash::XS->new(\%vars); + my $tt2 = Template->new({ STASH => $stash }); + +=head1 DESCRIPTION + +This module loads the XS version of Template::Stash::XS. It should +behave very much like the old one, but run about twice as fast. +See the synopsis above for usage information. + +Only a few methods (such as get and set) have been implemented in XS. +The others are inherited from Template::Stash. + +=head1 NOTE + +To always use the XS version of Stash, modify the Template/Config.pm +module near line 45: + + $STASH = 'Template::Stash::XS'; + +If you make this change, then there is no need to explicitly create +an instance of Template::Stash::XS as seen in the SYNOPSIS above. Just +use Template as normal. + +Alternatively, in your code add this line before creating a Template +object: + + $Template::Config::STASH = 'Template::Stash::XS'; + +To use the original, pure-perl version restore this line in +Template/Config.pm: + + $STASH = 'Template::Stash'; + +Or in your code: + + $Template::Config::STASH = 'Template::Stash'; + +You can elect to have this performed once for you at installation +time by answering 'y' or 'n' to the question that asks if you want +to make the XS Stash the default. + +=head1 BUGS + +Please report bugs to the Template Toolkit mailing list +templates@template-toolkit.org + +As of version 2.05 of the Template Toolkit, use of the XS Stash is +known to have 2 potentially troublesome side effects. The first +problem is that accesses to tied hashes (e.g. Apache::Session) may not +work as expected. This should be fixed in an imminent release. If +you are using tied hashes then it is suggested that you use the +regular Stash by default, or write a thin wrapper around your tied +hashes to enable the XS Stash to access items via regular method +calls. + +The second potential problem is that enabling the XS Stash causes all +the Template Toolkit modules to be installed in an architecture +dependant library, e.g. in + + /usr/lib/perl5/site_perl/5.6.0/i386-linux/Template + +instead of + + /usr/lib/perl5/site_perl/5.6.0/Template + +At the time of writing, we're not sure why this is happening but it's +likely that this is either a bug or intentional feature in the Perl +ExtUtils::MakeMaker module. As far as I know, Perl always checks the +architecture dependant directories before the architecture independant +ones. Therefore, a newer version of the Template Toolkit installed +with the XS Stash enabled should be used by Perl in preference to any +existing version using the regular stash. However, if you install a +future version of the Template Toolkit with the XS Stash disabled, you +may find that Perl continues to use the older version with XS Stash +enabled in preference. + +=head1 AUTHORS + +Andy Wardley E<lt>abw@tt2.orgE<gt> + +Doug Steinwand E<lt>dsteinwand@citysearch.comE<gt> + +=head1 VERSION + +Template Toolkit version 2.10, released on 24 July 2003. + + + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + +=head1 SEE ALSO + +L<Template::Stash|Template::Stash> + diff --git a/lib/Template/Test.pm b/lib/Template/Test.pm new file mode 100644 index 0000000..ba5915f --- /dev/null +++ b/lib/Template/Test.pm @@ -0,0 +1,701 @@ +#============================================================= -*-Perl-*- +# +# Template::Test +# +# DESCRIPTION +# Module defining a test harness which processes template input and +# then compares the output against pre-define expected output. +# Generates test output compatible with Test::Harness. This was +# originally the t/texpect.pl script. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Test.pm,v 2.64 2003/04/29 12:29:49 abw Exp $ +# +#============================================================================ + +package Template::Test; + +require 5.004; + +use strict; +use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS + $VERSION $DEBUG $EXTRA $PRESERVE $REASON $NO_FLUSH + $loaded %callsign); +use Template qw( :template ); +use Exporter; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0; +@ISA = qw( Exporter ); +@EXPORT = qw( ntests ok is match flush skip_all test_expect callsign banner ); +@EXPORT_OK = ( 'assert' ); +%EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] ); +$| = 1; + +$REASON = 'not applicable on this platform'; +$NO_FLUSH = 0; +$EXTRA = 0; # any extra tests to come after test_expect() +$PRESERVE = 0 # don't mangle newlines in output/expect + unless defined $PRESERVE; + +# always set binmode on Win32 machines so that any output generated +# is true to what we expect +$Template::BINMODE = ($^O eq 'MSWin32') ? 1 : 0; + +my @results = (); +my ($ntests, $ok_count); +*is = \&match; + +END { + # ensure flush() is called to print any cached results + flush(); +} + + +#------------------------------------------------------------------------ +# ntests($n) +# +# Declare how many (more) tests are expected to come. If ok() is called +# before ntests() then the results are cached instead of being printed +# to STDOUT. When ntests() is called, the total number of tests +# (including any cached) is known and the "1..$ntests" line can be +# printed along with the cached results. After that, calls to ok() +# generated printed output immediately. +#------------------------------------------------------------------------ + +sub ntests { + $ntests = shift; + # add any pre-declared extra tests, or pre-stored test @results, to + # the grand total of tests + $ntests += $EXTRA + scalar @results; + $ok_count = 1; + print $ntests ? "1..$ntests\n" : "1..$ntests # skipped: $REASON\n"; + # flush cached results + foreach my $pre_test (@results) { + ok(@$pre_test); + } +} + + +#------------------------------------------------------------------------ +# ok($truth, $msg) +# +# Tests the value passed for truth and generates an "ok $n" or "not ok $n" +# line accordingly. If ntests() hasn't been called then we cached +# results for later, instead. +#------------------------------------------------------------------------ + +sub ok { + my ($ok, $msg) = @_; + + # cache results if ntests() not yet called + unless ($ok_count) { + push(@results, [ $ok, $msg ]); + return $ok; + } + + $msg = defined $msg ? " - $msg" : ''; + if ($ok) { + print "ok ", $ok_count++, "$msg\n"; + } + else { + print STDERR "FAILED $ok_count: $msg\n" if defined $msg; + print "not ok ", $ok_count++, "$msg\n"; + } +} + + + +#------------------------------------------------------------------------ +# assert($truth, $error) +# +# Test value for truth, die if false. +#------------------------------------------------------------------------ + +sub assert { + my ($ok, $err) = @_; + return ok(1) if $ok; + + # failed + my ($pkg, $file, $line) = caller(); + $err ||= "assert failed"; + $err .= " at $file line $line\n"; + ok(0); + die $err; +} + +#------------------------------------------------------------------------ +# match( $result, $expect ) +#------------------------------------------------------------------------ + +sub match { + my ($result, $expect, $msg) = @_; + my $count = $ok_count ? $ok_count : scalar @results + 1; + + # force stringification of $result to avoid 'no eq method' overload errors + $result = "$result" if ref $result; + + if ($result eq $expect) { + return ok(1, $msg); + } + else { + print STDERR "FAILED $count:\n expect: [$expect]\n result: [$result]\n"; + return ok(0, $msg); + } +} + + +#------------------------------------------------------------------------ +# flush() +# +# Flush any tests results. +#------------------------------------------------------------------------ + +sub flush { + ntests(0) + unless $ok_count || $NO_FLUSH; +} + + +#------------------------------------------------------------------------ +# skip_all($reason) +# +# Skip all tests, setting $REASON to contain any message passed. Calls +# exit(0) which triggers flush() which generates a "1..0 # $REASON" +# string to keep to test harness happy. +#------------------------------------------------------------------------ + +sub skip_all { + $REASON = join('', @_); + exit(0); +} + + +#------------------------------------------------------------------------ +# test_expect($input, $template, \%replace) +# +# This is the main testing sub-routine. The $input parameter should be a +# text string or a filehandle reference (e.g. GLOB or IO::Handle) from +# which the input text can be read. The input should contain a number +# of tests which are split up and processed individually, comparing the +# generated output against the expected output. Tests should be defined +# as follows: +# +# -- test -- +# test input +# -- expect -- +# expected output +# +# -- test -- +# etc... +# +# The number of tests is determined and ntests() is called to generate +# the "0..$n" line compatible with Test::Harness. Each test input is +# then processed by the Template object passed as the second parameter, +# $template. This may also be a hash reference containing configuration +# which are used to instantiate a Template object, or may be left +# undefined in which case a default Template object will be instantiated. +# The third parameter, also optional, may be a reference to a hash array +# defining template variables. This is passed to the template process() +# method. +#------------------------------------------------------------------------ + +sub test_expect { + my ($src, $tproc, $params) = @_; + my ($input, @tests); + my ($output, $expect, $match); + my $count = 0; + my $ttprocs; + + # read input text + eval { + local $/ = undef; + $input = ref $src ? <$src> : $src; + }; + if ($@) { + ntests(1); ok(0); + warn "Cannot read input text from $src\n"; + return undef; + } + + # remove any comment lines + $input =~ s/^#.*?\n//gm; + + # remove anything before '-- start --' and/or after '-- stop --' + $input = $' if $input =~ /\s*--\s*start\s*--\s*/; + $input = $` if $input =~ /\s*--\s*stop\s*--\s*/; + + @tests = split(/^\s*--\s*test\s*--\s*\n/im, $input); + + # if the first line of the file was '--test--' (optional) then the + # first test will be empty and can be discarded + shift(@tests) if $tests[0] =~ /^\s*$/; + + ntests(3 + scalar(@tests) * 2); + + # first test is that Template loaded OK, which it did + ok(1, 'running test_expect()'); + + # optional second param may contain a Template reference or a HASH ref + # of constructor options, or may be undefined + if (ref($tproc) eq 'HASH') { + # create Template object using hash of config items + $tproc = Template->new($tproc) + || die Template->error(), "\n"; + } + elsif (ref($tproc) eq 'ARRAY') { + # list of [ name => $tproc, name => $tproc ], use first $tproc + $ttprocs = { @$tproc }; + $tproc = $tproc->[1]; + } + elsif (! ref $tproc) { + $tproc = Template->new() + || die Template->error(), "\n"; + } + # otherwise, we assume it's a Template reference + + # test: template processor created OK + ok($tproc, 'template processor is engaged'); + + # third test is that the input read ok, which it did + ok(1, 'input read and split into ' . scalar @tests . ' tests'); + + # the remaining tests are defined in @tests... + foreach $input (@tests) { + $count++; + my $name = ''; + + if ($input =~ s/^\s*-- name:? (.*?) --\s*\n//im) { + $name = $1; + } + else { + $name = "template text $count"; + } + + # split input by a line like "-- expect --" + ($input, $expect) = + split(/^\s*--\s*expect\s*--\s*\n/im, $input); + $expect = '' + unless defined $expect; + + $output = ''; + + # input text may be prefixed with "-- use name --" to indicate a + # Template object in the $ttproc hash which we should use + if ($input =~ s/^\s*--\s*use\s+(\S+)\s*--\s*\n//im) { + my $ttname = $1; + my $ttlookup; + if ($ttlookup = $ttprocs->{ $ttname }) { + $tproc = $ttlookup; + } + else { + warn "no such template object to use: $ttname\n"; + } + } + + # process input text + $tproc->process(\$input, $params, \$output) || do { + warn "Template process failed: ", $tproc->error(), "\n"; + # report failure and automatically fail the expect match + ok(0, "$name process FAILED: " . subtext($input)); + ok(0, '(obviously did not match expected)'); + next; + }; + + # processed OK + ok(1, "$name processed OK: " . subtext($input)); + + # another hack: if the '-- expect --' section starts with + # '-- process --' then we process the expected output + # before comparing it with the generated output. This is + # slightly twisted but it makes it possible to run tests + # where the expected output isn't static. See t/date.t for + # an example. + + if ($expect =~ s/^\s*--+\s*process\s*--+\s*\n//im) { + my $out; + $tproc->process(\$expect, $params, \$out) || do { + warn("Template process failed (expect): ", + $tproc->error(), "\n"); + # report failure and automatically fail the expect match + ok(0, "failed to process expected output [" + . subtext($expect) . ']'); + next; + }; + $expect = $out; + }; + + # strip any trailing blank lines from expected and real output + foreach ($expect, $output) { + s/\n*\Z//mg; + } + + $match = ($expect eq $output) ? 1 : 0; + if (! $match || $DEBUG) { + print "MATCH FAILED\n" + unless $match; + + my ($copyi, $copye, $copyo) = ($input, $expect, $output); + unless ($PRESERVE) { + foreach ($copyi, $copye, $copyo) { + s/\n/\\n/g; + } + } + printf(" input: [%s]\nexpect: [%s]\noutput: [%s]\n", + $copyi, $copye, $copyo); + } + + ok($match, $match ? "$name matched expected" : "$name did not match expected"); + }; +} + +#------------------------------------------------------------------------ +# callsign() +# +# Returns a hash array mapping lower a..z to their phonetic alphabet +# equivalent. +#------------------------------------------------------------------------ + +sub callsign { + my %callsign; + @callsign{ 'a'..'z' } = qw( + alpha bravo charlie delta echo foxtrot golf hotel india + juliet kilo lima mike november oscar papa quebec romeo + sierra tango umbrella victor whisky x-ray yankee zulu ); + return \%callsign; +} + + +#------------------------------------------------------------------------ +# banner($text) +# +# Prints a banner with the specified text if $DEBUG is set. +#------------------------------------------------------------------------ + +sub banner { + return unless $DEBUG; + my $text = join('', @_); + my $count = $ok_count ? $ok_count - 1 : scalar @results; + print "-" x 72, "\n$text ($count tests completed)\n", "-" x 72, "\n"; +} + + +sub subtext { + my $text = shift; + $text =~ s/\s*$//sg; + $text = substr($text, 0, 32) . '...' if length $text > 32; + $text =~ s/\n/\\n/g; + return $text; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Test - Module for automating TT2 test scripts + +=head1 SYNOPSIS + + use Template::Test; + + $Template::Test::DEBUG = 0; # set this true to see each test running + $Template::Test::EXTRA = 2; # 2 extra tests follow test_expect()... + + # ok() can be called any number of times before test_expect + ok( $true_or_false ) + + # test_expect() splits $input into individual tests, processes each + # and compares generated output against expected output + test_expect($input, $template, \%replace ); + + # $input is text or filehandle (e.g. DATA section after __END__) + test_expect( $text ); + test_expect( \*DATA ); + + # $template is a Template object or configuration hash + my $template_cfg = { ... }; + test_expect( $input, $template_cfg ); + my $template_obj = Template->new($template_cfg); + test_expect( $input, $template_obj ); + + # $replace is a hash reference of template variables + my $replace = { + a => 'alpha', + b => 'bravo' + }; + test_expect( $input, $template, $replace ); + + # ok() called after test_expect should be declared in $EXTRA (2) + ok( $true_or_false ) + ok( $true_or_false ) + +=head1 DESCRIPTION + +The Template::Test module defines the test_expect() and other related +subroutines which can be used to automate test scripts for the +Template Toolkit. See the numerous tests in the 't' sub-directory of +the distribution for examples of use. + +The test_expect() subroutine splits an input document into a number +of separate tests, processes each one using the Template Toolkit and +then compares the generated output against an expected output, also +specified in the input document. It generates the familiar "ok/not +ok" output compatible with Test::Harness. + +The test input should be specified as a text string or a reference to +a filehandle (e.g. GLOB or IO::Handle) from which it can be read. In +particular, this allows the test input to be placed after the __END__ +marker and read via the DATA filehandle. + + use Template::Test; + + test_expect(\*DATA); + + __END__ + # this is the first test (this is a comment) + -- test -- + blah blah blah [% foo %] + -- expect -- + blah blah blah value_of_foo + + # here's the second test (no surprise, so is this) + -- test -- + more blah blah [% bar %] + -- expect -- + more blah blah value_of_bar + +Blank lines between test sections are generally ignored. Any line starting +with '#' is treated as a comment and is ignored. + +The second and third parameters to test_expect() are optional. The second +may be either a reference to a Template object which should be used to +process the template fragments, or a reference to a hash array containing +configuration values which should be used to instantiate a new Template +object. + + # pass reference to config hash + my $config = { + INCLUDE_PATH => '/here/there:/every/where', + POST_CHOMP => 1, + }; + test_expect(\*DATA, $config); + + # or create Template object explicitly + my $template = Template->new($config); + test_expect(\*DATA, $template); + + +The third parameter may be used to reference a hash array of template +variable which should be defined when processing the tests. This is +passed to the Template process() method. + + my $replace = { + a => 'alpha', + b => 'bravo', + }; + + test_expect(\*DATA, $config, $replace); + +The second parameter may be left undefined to specify a default Template +configuration. + + test_expect(\*DATA, undef, $replace); + +For testing the output of different Template configurations, a +reference to a list of named Template objects also may be passed as +the second parameter. + + my $tt1 = Template->new({ ... }); + my $tt2 = Template->new({ ... }); + my @tts = [ one => $tt1, two => $tt1 ]; + +The first object in the list is used by default. Other objects may be +switched in with the '-- use $name --' marker. This should immediately +follow a '-- test --' line. That object will then be used for the rest +of the test, or until a different object is selected. + + -- test -- + -- use one -- + [% blah %] + -- expect -- + blah, blah + + -- test -- + still using one... + -- expect -- + ... + + -- test -- + -- use two -- + [% blah %] + -- expect -- + blah, blah, more blah + +The test_expect() sub counts the number of tests, and then calls ntests() +to generate the familiar "1..$ntests\n" test harness line. Each +test defined generates two test numbers. The first indicates +that the input was processed without error, and the second that the +output matches that expected. + +Additional test may be run before test_expect() by calling ok(). +These test results are cached until ntests() is called and the final +number of tests can be calculated. Then, the "1..$ntests" line is +output, along with "ok $n" / "not ok $n" lines for each of the cached +test result. Subsequent calls to ok() then generate an output line +immediately. + + my $something = SomeObject->new(); + ok( $something ); + + my $other = AnotherThing->new(); + ok( $other ); + + test_expect(\*DATA); + +If any tests are to follow after test_expect() is called then these +should be pre-declared by setting the $EXTRA package variable. This +value (default: 0) is added to the grand total calculated by ntests(). +The results of the additional tests are also registered by calling ok(). + + $Template::Test::EXTRA = 2; + + # can call ok() any number of times before test_expect() + ok( $did_that_work ); + ok( $make_sure ); + ok( $dead_certain ); + + # <some> number of tests... + test_expect(\*DATA, $config, $replace); + + # here's those $EXTRA tests + ok( defined $some_result && ref $some_result eq 'ARRAY' ); + ok( $some_result->[0] eq 'some expected value' ); + +If you don't want to call test_expect() at all then you can call +ntests($n) to declare the number of tests and generate the test +header line. After that, simply call ok() for each test passing +a true or false values to indicate that the test passed or failed. + + ntests(2); + ok(1); + ok(0); + +If you're really lazy, you can just call ok() and not bother declaring +the number of tests at all. All tests results will be cached until the +end of the script and then printed in one go before the program exits. + + ok( $x ); + ok( $y ); + +You can identify only a specific part of the input file for testing +using the '-- start --' and '-- stop --' markers. Anything before the +first '-- start --' is ignored, along with anything after the next +'-- stop --' marker. + + -- test -- + this is test 1 (not performed) + -- expect -- + this is test 1 (not performed) + + -- start -- + + -- test -- + this is test 2 + -- expect -- + this is test 2 + + -- stop -- + + ... + +For historical reasons and general utility, the module also defines a +'callsign' subroutine which returns a hash mapping a..z to their phonetic +alphabet equivalent (e.g. radio callsigns). This is used by many +of the test scripts as a "known source" of variable values. + + test_expect(\*DATA, $config, callsign()); + +A banner() subroutine is also provided which prints a simple banner +including any text passed as parameters, if $DEBUG is set. + + banner('Testing something-or-other'); + +example output: + + #------------------------------------------------------------ + # Testing something-or-other (27 tests completed) + #------------------------------------------------------------ + +The $DEBUG package variable can be set to enable debugging mode. + +The $PRESERVE package variable can be set to stop the test_expect() +from converting newlines in the output and expected output into +the literal strings '\n'. + +=head1 HISTORY + +This module started its butt-ugly life as the t/texpect.pl script. It +was cleaned up to became the Template::Test module some time around +version 0.29. It underwent further cosmetic surgery for version 2.00 +but still retains some rear-end resemblances. + +=head1 BUGS / KNOWN "FEATURES" + +Imports all methods by default. This is generally a Bad Thing, but +this module is only used in test scripts (i.e. at build time) so a) we +don't really care and b) it saves typing. + +The line splitter may be a bit dumb, especially if it sees lines like +-- this -- that aren't supposed to be special markers. So don't do that. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.64, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template> diff --git a/lib/Template/View.pm b/lib/Template/View.pm new file mode 100644 index 0000000..312ff45 --- /dev/null +++ b/lib/Template/View.pm @@ -0,0 +1,754 @@ +#============================================================= -*-Perl-*- +# +# Template::View +# +# DESCRIPTION +# A custom view of a template processing context. Can be used to +# implement custom "skins". +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 2000 Andy Wardley. All Rights Reserved. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# TODO +# * allowing print to have a hash ref as final args will cause problems +# if you do this: [% view.print(hash1, hash2, hash3) %]. Current +# work-around is to do [% view.print(hash1); view.print(hash2); +# view.print(hash3) %] or [% view.print(hash1, hash2, hash3, { }) %] +# +# REVISION +# $Id: View.pm,v 2.8 2002/04/15 15:53:37 abw Exp $ +# +#============================================================================ + +package Template::View; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $AUTOLOAD @BASEARGS $MAP ); +use base qw( Template::Base ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.8 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; +@BASEARGS = qw( context ); +$MAP = { + HASH => 'hash', + ARRAY => 'list', + TEXT => 'text', + default => '', +}; + +#$DEBUG = 1; + +#------------------------------------------------------------------------ +# _init(\%config) +# +# Initialisation method called by the Template::Base class new() +# constructor. $self->{ context } has already been set, by virtue of +# being named in @BASEARGS. Remaining config arguments are presented +# as a hash reference. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $config) = @_; + + # move 'context' somewhere more private + $self->{ _CONTEXT } = $self->{ context }; + delete $self->{ context }; + + # generate table mapping object types to templates + my $map = $config->{ map } || { }; + $map->{ default } = $config->{ default } unless defined $map->{ default }; + $self->{ map } = { + %$MAP, + %$map, + }; + + # local BLOCKs definition table + $self->{ _BLOCKS } = $config->{ blocks } || { }; + + # name of presentation method which printed objects might provide + $self->{ method } = defined $config->{ method } + ? $config->{ method } : 'present'; + + # view is sealed by default preventing variable update after + # definition, however we don't actually seal a view until the + # END of the view definition + my $sealed = $config->{ sealed }; + $sealed = 1 unless defined $sealed; + $self->{ sealed } = $sealed ? 1 : 0; + + # copy remaining config items from $config or set defaults + foreach my $arg (qw( base prefix suffix notfound silent )) { + $self->{ $arg } = $config->{ $arg } || ''; + } + + # name of data item used by view() + $self->{ item } = $config->{ item } || 'item'; + + # map methods of form ${include_prefix}_foobar() to include('foobar')? + $self->{ include_prefix } = $config->{ include_prefix } || 'include_'; + # what about mapping foobar() to include('foobar')? + $self->{ include_naked } = defined $config->{ include_naked } + ? $config->{ include_naked } : 1; + + # map methods of form ${view_prefix}_foobar() to include('foobar')? + $self->{ view_prefix } = $config->{ view_prefix } || 'view_'; + # what about mapping foobar() to view('foobar')? + $self->{ view_naked } = $config->{ view_naked } || 0; + + # the view is initially unsealed, allowing directives in the initial + # view template to create data items via the AUTOLOAD; once sealed via + # call to seal(), the AUTOLOAD will not update any internal items. + delete @$config{ qw( base method map default prefix suffix notfound item + include_prefix include_naked silent sealed + view_prefix view_naked blocks ) }; + $config = { %{ $self->{ base }->{ data } }, %$config } + if $self->{ base }; + $self->{ data } = $config; + $self->{ SEALED } = 0; + + return $self; +} + + +#------------------------------------------------------------------------ +# seal() +# unseal() +# +# Seal or unseal the view to allow/prevent new datat items from being +# automatically created by the AUTOLOAD method. +#------------------------------------------------------------------------ + +sub seal { + my $self = shift; + $self->{ SEALED } = $self->{ sealed }; +} + +sub unseal { + my $self = shift; + $self->{ SEALED } = 0; +} + + +#------------------------------------------------------------------------ +# clone(\%config) +# +# Cloning method which takes a copy of $self and then applies to it any +# modifications specified in the $config hash passed as an argument. +# Configuration items may also be specified as a list of "name => $value" +# arguments. Returns a reference to the cloned Template::View object. +# +# NOTE: may need to copy BLOCKS??? +#------------------------------------------------------------------------ + +sub clone { + my $self = shift; + my $clone = bless { %$self }, ref $self; + my $config = ref $_[0] eq 'HASH' ? shift : { @_ }; + + # merge maps + $clone->{ map } = { + %{ $self->{ map } }, + %{ $config->{ map } || { } }, + }; + + # "map => { default=>'xxx' }" can be specified as "default => 'xxx'" + $clone->{ map }->{ default } = $config->{ default } + if defined $config->{ default }; + + # update any remaining config items + my @args = qw( base prefix suffix notfound item method include_prefix + include_naked view_prefix view_naked ); + foreach my $arg (@args) { + $clone->{ $arg } = $config->{ $arg } if defined $config->{ $arg }; + } + push(@args, qw( default map )); + delete @$config{ @args }; + + # anything left is data + my $data = $clone->{ data } = { %{ $self->{ data } } }; + @$data{ keys %$config } = values %$config; + + return $clone; +} + + +#------------------------------------------------------------------------ +# print(@items, ..., \%config) +# +# Prints @items in turn by mapping each to an approriate template using +# the internal 'map' hash. If an entry isn't found and the item is an +# object that implements the method named in the internal 'method' item, +# (default: 'present'), then the method will be called passing a reference +# to $self, against which the presenter method may make callbacks (e.g. +# to view_item()). If the presenter method isn't implemented, then the +# 'default' map entry is consulted and used if defined. The final argument +# may be a reference to a hash array providing local overrides to the internal +# defaults for various items (prefix, suffix, etc). In the presence +# of this parameter, a clone of the current object is first made, applying +# any configuration updates, and control is then delegated to it. +#------------------------------------------------------------------------ + +sub print { + my $self = shift; + + # if final config hash is specified then create a clone and delegate to it + # NOTE: potential problem when called print(\%data_hash1, \%data_hash2); + if ((scalar @_ > 1) && (ref $_[-1] eq 'HASH')) { + my $cfg = pop @_; + my $clone = $self->clone($cfg) + || return; + return $clone->print(@_) + || $self->error($clone->error()); + } + my ($item, $type, $template, $present); + my $method = $self->{ method }; + my $map = $self->{ map }; + my $output = ''; + + # print each argument + foreach $item (@_) { + my $newtype; + + if (! ($type = ref $item)) { + # non-references are TEXT + $type = 'TEXT'; + $template = $map->{ $type }; + } + elsif (! defined ($template = $map->{ $type })) { + # no specific map entry for object, maybe it implements a + # 'present' (or other) method? +# $self->DEBUG("determining if $item can $method\n") if $DEBUG; + if ( $method && UNIVERSAL::can($item, $method) ) { + $self->DEBUG("Calling \$item->$method\n") if $DEBUG; + $present = $item->$method($self); ## call item method + # undef returned indicates error, note that we expect + # $item to have called error() on the view + return unless defined $present; + $output .= $present; + next; ## NEXT + } + elsif ( UNIVERSAL::isa($item, 'HASH' ) + && defined($newtype = $item->{$method}) + && defined($template = $map->{"$method=>$newtype"})) { + } + elsif ( defined($newtype) + && defined($template = $map->{"$method=>*"}) ) { + $template =~ s/\*/$newtype/; + } + elsif (! ($template = $map->{ default }) ) { + # default not defined, so construct template name from type + ($template = $type) =~ s/\W+/_/g; + } + } +# else { +# $self->DEBUG("defined map type for $type: $template\n"); +# } + $self->DEBUG("printing view '", $template || '', "', $item\n") if $DEBUG; + $output .= $self->view($template, $item) + if $template; + } + return $output; +} + + +#------------------------------------------------------------------------ +# view($template, $item, \%vars) +# +# Wrapper around include() which expects a template name, $template, +# followed by a data item, $item, and optionally, a further hash array +# of template variables. The $item is added as an entry to the $vars +# hash (which is created empty if not passed as an argument) under the +# name specified by the internal 'item' member, which is appropriately +# 'item' by default. Thus an external object present() method can +# callback against this object method, simply passing a data item to +# be displayed. The external object doesn't have to know what the +# view expects the item to be called in the $vars hash. +#------------------------------------------------------------------------ + +sub view { + my ($self, $template, $item) = splice(@_, 0, 3); + my $vars = ref $_[0] eq 'HASH' ? shift : { @_ }; + $vars->{ $self->{ item } } = $item if defined $item; + $self->include($template, $vars); +} + + +#------------------------------------------------------------------------ +# include($template, \%vars) +# +# INCLUDE a template, $template, mapped according to the current prefix, +# suffix, default, etc., where $vars is an optional hash reference +# containing template variable definitions. If the template isn't found +# then the method will default to any 'notfound' template, if defined +# as an internal item. +#------------------------------------------------------------------------ + +sub include { + my ($self, $template, $vars) = @_; + my $context = $self->{ _CONTEXT }; + + $template = $self->template($template); + + $vars = { } unless ref $vars eq 'HASH'; + $vars->{ view } ||= $self; + + $context->include( $template, $vars ); + +# DEBUGGING +# my $out = $context->include( $template, $vars ); +# print STDERR "VIEW return [$out]\n"; +# return $out; +} + + +#------------------------------------------------------------------------ +# template($template) +# +# Returns a compiled template for the specified template name, according +# to the current configuration parameters. +#------------------------------------------------------------------------ + +sub template { + my ($self, $name) = @_; + my $context = $self->{ _CONTEXT }; + return $context->throw(Template::Constants::ERROR_VIEW, + "no view template specified") + unless $name; + + my $notfound = $self->{ notfound }; + my $base = $self->{ base }; + my ($template, $block, $error); + + return $block + if ($block = $self->{ _BLOCKS }->{ $name }); + + # try the named template + $template = $self->template_name($name); + $self->DEBUG("looking for $template\n") if $DEBUG; + eval { $template = $context->template($template) }; + + # try asking the base view if not found + if (($error = $@) && $base) { + $self->DEBUG("asking base for $name\n") if $DEBUG; + eval { $template = $base->template($name) }; + } + + # try the 'notfound' template (if defined) if that failed + if (($error = $@) && $notfound) { + unless ($template = $self->{ _BLOCKS }->{ $notfound }) { + $notfound = $self->template_name($notfound); + $self->DEBUG("not found, looking for $notfound\n") if $DEBUG; + eval { $template = $context->template($notfound) }; + + return $context->throw(Template::Constants::ERROR_VIEW, $error) + if $@; # return first error + } + } + elsif ($error) { + $self->DEBUG("no 'notfound'\n") + if $DEBUG; + return $context->throw(Template::Constants::ERROR_VIEW, $error); + } + return $template; +} + + +#------------------------------------------------------------------------ +# template_name($template) +# +# Returns the name of the specified template with any appropriate prefix +# and/or suffix added. +#------------------------------------------------------------------------ + +sub template_name { + my ($self, $template) = @_; + $template = $self->{ prefix } . $template . $self->{ suffix } + if $template; + + $self->DEBUG("template name: $template\n") if $DEBUG; + return $template; +} + + +#------------------------------------------------------------------------ +# default($val) +# +# Special case accessor to retrieve/update 'default' as an alias for +# '$map->{ default }'. +#------------------------------------------------------------------------ + +sub default { + my $self = shift; + return @_ ? ($self->{ map }->{ default } = shift) + : $self->{ map }->{ default }; +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# + +# Returns/updates public internal data items (i.e. not prefixed '_' or +# '.') or presents a view if the method matches the view_prefix item, +# e.g. view_foo(...) => view('foo', ...). Similarly, the +# include_prefix is used, if defined, to map include_foo(...) to +# include('foo', ...). If that fails then the entire method name will +# be used as the name of a template to include iff the include_named +# parameter is set (default: 1). Last attempt is to match the entire +# method name to a view() call, iff view_naked is set. Otherwise, a +# 'view' exception is raised reporting the error "no such view member: +# $method". +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $item = $AUTOLOAD; + $item =~ s/.*:://; + return if $item eq 'DESTROY'; + + if ($item =~ /^[\._]/) { + return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, + "attempt to view private member: $item"); + } + elsif (exists $self->{ $item }) { + # update existing config item (e.g. 'prefix') if unsealed + return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, + "cannot update config item in sealed view: $item") + if @_ && $self->{ SEALED }; + $self->DEBUG("accessing item: $item\n") if $DEBUG; + return @_ ? ($self->{ $item } = shift) : $self->{ $item }; + } + elsif (exists $self->{ data }->{ $item }) { + # get/update existing data item (must be unsealed to update) + if (@_ && $self->{ SEALED }) { + return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, + "cannot update item in sealed view: $item") + unless $self->{ silent }; + # ignore args if silent + @_ = (); + } + $self->DEBUG(@_ ? "updating data item: $item <= $_[0]\n" + : "returning data item: $item\n") if $DEBUG; + return @_ ? ($self->{ data }->{ $item } = shift) + : $self->{ data }->{ $item }; + } + elsif (@_ && ! $self->{ SEALED }) { + # set data item if unsealed + $self->DEBUG("setting unsealed data: $item => @_\n") if $DEBUG; + $self->{ data }->{ $item } = shift; + } + elsif ($item =~ s/^$self->{ view_prefix }//) { + $self->DEBUG("returning view($item)\n") if $DEBUG; + return $self->view($item, @_); + } + elsif ($item =~ s/^$self->{ include_prefix }//) { + $self->DEBUG("returning include($item)\n") if $DEBUG; + return $self->include($item, @_); + } + elsif ($self->{ include_naked }) { + $self->DEBUG("returning naked include($item)\n") if $DEBUG; + return $self->include($item, @_); + } + elsif ($self->{ view_naked }) { + $self->DEBUG("returning naked view($item)\n") if $DEBUG; + return $self->view($item, @_); + } + else { + return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, + "no such view member: $item"); + } +} + + +1; + + +__END__ + +=head1 NAME + +Template::View - customised view of a template processing context + +=head1 SYNOPSIS + + # define a view + [% VIEW view + # some standard args + prefix => 'my_', + suffix => '.tt2', + notfound => 'no_such_file' + ... + + # any other data + title => 'My View title' + other_item => 'Joe Random Data' + ... + %] + # add new data definitions, via 'my' self reference + [% my.author = "$abw.name <$abw.email>" %] + [% my.copy = "© Copyright 2000 $my.author" %] + + # define a local block + [% BLOCK header %] + This is the header block, title: [% title or my.title %] + [% END %] + + [% END %] + + # access data items for view + [% view.title %] + [% view.other_item %] + + # access blocks directly ('include_naked' option, set by default) + [% view.header %] + [% view.header(title => 'New Title') %] + + # non-local templates have prefix/suffix attached + [% view.footer %] # => [% INCLUDE my_footer.tt2 %] + + # more verbose form of block access + [% view.include( 'header', title => 'The Header Title' ) %] + [% view.include_header( title => 'The Header Title' ) %] + + # very short form of above ('include_naked' option, set by default) + [% view.header( title => 'The Header Title' ) %] + + # non-local templates have prefix/suffix attached + [% view.footer %] # => [% INCLUDE my_footer.tt2 %] + + # fallback on the 'notfound' template ('my_no_such_file.tt2') + # if template not found + [% view.include('missing') %] + [% view.include_missing %] + [% view.missing %] + + # print() includes a template relevant to argument type + [% view.print("some text") %] # type=TEXT, template='text' + + [% BLOCK my_text.tt2 %] # 'text' with prefix/suffix + Text: [% item %] + [% END %] + + # now print() a hash ref, mapped to 'hash' template + [% view.print(some_hash_ref) %] # type=HASH, template='hash' + + [% BLOCK my_hash.tt2 %] # 'hash' with prefix/suffix + hash keys: [% item.keys.sort.join(', ') + [% END %] + + # now print() a list ref, mapped to 'list' template + [% view.print(my_list_ref) %] # type=ARRAY, template='list' + + [% BLOCK my_list.tt2 %] # 'list' with prefix/suffix + list: [% item.join(', ') %] + [% END %] + + # print() maps 'My::Object' to 'My_Object' + [% view.print(myobj) %] + + [% BLOCK my_My_Object.tt2 %] + [% item.this %], [% item.that %] + [% END %] + + # update mapping table + [% view.map.ARRAY = 'my_list_template' %] + [% view.map.TEXT = 'my_text_block' %] + + + # change prefix, suffix, item name, etc. + [% view.prefix = 'your_' %] + [% view.default = 'anyobj' %] + ... + +=head1 DESCRIPTION + +TODO + +=head1 METHODS + +=head2 new($context, \%config) + +Creates a new Template::View presenting a custom view of the specified +$context object. + +A reference to a hash array of configuration options may be passed as the +second argument. + +=over 4 + +=item prefix + +Prefix added to all template names. + + [% USE view(prefix => 'my_') %] + [% view.view('foo', a => 20) %] # => my_foo + +=item suffix + +Suffix added to all template names. + + [% USE view(suffix => '.tt2') %] + [% view.view('foo', a => 20) %] # => foo.tt2 + +=item map + +Hash array mapping reference types to template names. The print() +method uses this to determine which template to use to present any +particular item. The TEXT, HASH and ARRAY items default to 'test', +'hash' and 'list' appropriately. + + [% USE view(map => { ARRAY => 'my_list', + HASH => 'your_hash', + My::Foo => 'my_foo', } ) %] + + [% view.print(some_text) %] # => text + [% view.print(a_list) %] # => my_list + [% view.print(a_hash) %] # => your_hash + [% view.print(a_foo) %] # => my_foo + + [% BLOCK text %] + Text: [% item %] + [% END %] + + [% BLOCK my_list %] + list: [% item.join(', ') %] + [% END %] + + [% BLOCK your_hash %] + hash keys: [% item.keys.sort.join(', ') + [% END %] + + [% BLOCK my_foo %] + Foo: [% item.this %], [% item.that %] + [% END %] + +=item method + +Name of a method which objects passed to print() may provide for presenting +themselves to the view. If a specific map entry can't be found for an +object reference and it supports the method (default: 'present') then +the method will be called, passing the view as an argument. The object +can then make callbacks against the view to present itself. + + package Foo; + + sub present { + my ($self, $view) = @_; + return "a regular view of a Foo\n"; + } + + sub debug { + my ($self, $view) = @_; + return "a debug view of a Foo\n"; + } + +In a template: + + [% USE view %] + [% view.print(my_foo_object) %] # a regular view of a Foo + + [% USE view(method => 'debug') %] + [% view.print(my_foo_object) %] # a debug view of a Foo + +=item default + +Default template to use if no specific map entry is found for an item. + + [% USE view(default => 'my_object') %] + + [% view.print(objref) %] # => my_object + +If no map entry or default is provided then the view will attempt to +construct a template name from the object class, substituting any +sequence of non-word characters to single underscores, e.g. + + # 'fubar' is an object of class Foo::Bar + [% view.print(fubar) %] # => Foo_Bar + +Any current prefix and suffix will be added to both the default template +name and any name constructed from the object class. + +=item notfound + +Fallback template to use if any other isn't found. + +=item item + +Name of the template variable to which the print() method assigns the current +item. Defaults to 'item'. + + [% USE view %] + [% BLOCK list %] + [% item.join(', ') %] + [% END %] + [% view.print(a_list) %] + + [% USE view(item => 'thing') %] + [% BLOCK list %] + [% thing.join(', ') %] + [% END %] + [% view.print(a_list) %] + +=item view_prefix + +Prefix of methods which should be mapped to view() by AUTOLOAD. Defaults +to 'view_'. + + [% USE view %] + [% view.view_header() %] # => view('header') + + [% USE view(view_prefix => 'show_me_the_' %] + [% view.show_me_the_header() %] # => view('header') + +=item view_naked + +Flag to indcate if any attempt should be made to map method names to +template names where they don't match the view_prefix. Defaults to 0. + + [% USE view(view_naked => 1) %] + + [% view.header() %] # => view('header') + +=back + +=head2 print( $obj1, $obj2, ... \%config) + +TODO + +=head2 view( $template, \%vars, \%config ); + +TODO + +=head1 AUTHOR + +Andy Wardley E<lt>abw@kfs.orgE<gt> + +=head1 REVISION + +$Revision: 2.8 $ + +=head1 COPYRIGHT + +Copyright (C) 2000 Andy Wardley. All Rights Reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template::Plugin|Template::Plugin>, + +=cut + + + + + |