From: Paul Seamons Date: Tue, 12 Jun 2007 00:00:00 +0000 (+0000) Subject: CGI::Ex 2.14 X-Git-Tag: v2.14 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=aa030874456c91d688e6c9b25e82d2bf9575ea6f;p=chaz%2Fp5-CGI-Ex CGI::Ex 2.14 --- diff --git a/Changes b/Changes index 6ea7345..aa0bd82 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,9 @@ +2.14 + 2007-06-12 + * Moved CGI::Ex::Template to Template::Alloy + * Template::Alloy is now required as a dependency + * Update some portions of App POD. + 2.13 2007-05-21 * Added full support for HTML::Template and HTML::Template::Expr. diff --git a/MANIFEST b/MANIFEST index e01df32..f2440d7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -11,9 +11,6 @@ lib/CGI/Ex/JSONDump.pm lib/CGI/Ex/md5.js lib/CGI/Ex/sha1.js lib/CGI/Ex/Template.pm -lib/CGI/Ex/Template.pod -lib/CGI/Ex/Template/Extra.pm -lib/CGI/Ex/Template/HTE.pm lib/CGI/Ex/validate.js lib/CGI/Ex/Validate.pm lib/CGI/Ex/yaml_load.js @@ -83,8 +80,5 @@ t/4_app_00_base.t t/5_dump_00_base.t t/6_die_00_base.t t/7_template_00_base.t -t/7_template_01_includes.t -t/7_template_02_view.t -t/7_template_03_html_template.t t/8_auth_00_base.t t/9_jsondump_00_base.t diff --git a/META.yml b/META.yml index b7db1f9..0baa453 100644 --- a/META.yml +++ b/META.yml @@ -1,10 +1,11 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: CGI-Ex -version: 2.13 +version: 2.14 version_from: lib/CGI/Ex.pm installdirs: site requires: + Template::Alloy: 1.002 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30_01 diff --git a/Makefile.PL b/Makefile.PL index 8ac2254..754fca4 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -11,6 +11,9 @@ WriteMakefile( ABSTRACT_FROM => "lib/CGI/Ex.pm", VERSION_FROM => "lib/CGI/Ex.pm", INSTALLDIRS => 'site', + PREREQ_PM => { + 'Template::Alloy' => '1.002', + }, dist => { DIST_DEFAULT => 'all tardist', diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index edd456e..6737649 100644 --- a/lib/CGI/Ex.pm +++ b/lib/CGI/Ex.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.13'; + $VERSION = '2.14'; $PREFERRED_CGI_MODULE ||= 'CGI'; @EXPORT = (); @EXPORT_OK = qw(get_form diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm index 59ab6d2..9ccbab3 100644 --- a/lib/CGI/Ex/App.pm +++ b/lib/CGI/Ex/App.pm @@ -10,7 +10,7 @@ use strict; use vars qw($VERSION); BEGIN { - $VERSION = '2.13'; + $VERSION = '2.14'; Time::HiRes->import('time') if eval {require Time::HiRes}; eval {require Scalar::Util}; diff --git a/lib/CGI/Ex/App.pod b/lib/CGI/Ex/App.pod index a359a47..0188cdc 100644 --- a/lib/CGI/Ex/App.pod +++ b/lib/CGI/Ex/App.pod @@ -516,15 +516,19 @@ The following shows how to add variables using the hash_swap hook on the step "m }; } -You could also return the fields from the hash_common hook and they would be available -in both the template swapping as well as form filling. +You could also return the fields from the hash_common hook and they +would be available in both the template swapping as well as form +filling. -See the hash_base, hash_common, hash_form, hash_swap, hash_errors, swap_template, and -template_args hooks for more information. +See the hash_base, hash_common, hash_form, hash_swap, hash_errors, +swap_template, and template_args hooks for more information. -The default template engine used is CGI::Ex::Template which is Template::Toolkit compatible. -See the CGI::Ex::Template or Template::Toolkit documentation for the types of data -that can be passed, and for the syntax that can be used. +The default template engine used is CGI::Ex::Template which is now a subclass +of Template::Alloy. The default interface used is TT which is the +Template::Toolkit interface. Template::Alloy allows for using TT documents, +HTML::Template documents, HTML::Template::Expr documents, Text::Tmpl documents, +or Velocity (VTL) documents. See the L documentation +for more information. =head1 ADDING ADDITIONAL FORM FILL VARIABLES @@ -561,7 +565,7 @@ validation files). The default file_print hook will look for content on your file system, but it can also be completely overridden to return a reference to a scalar containing the contents of your file. Actually it can return -anything that CGI::Ex::Template (Template::Toolkit compatible) will +anything that Template::Alloy (Template::Toolkit compatible) will treat as input. This templated html is displayed to the user during any step that enters the "print" phase. @@ -784,7 +788,7 @@ Note: This example would be considerably shorter if the html file separate files. Though CGI::Ex::App will work "out of the box" as shown it is more probable that any platform using it will customize the various hooks to their own tastes (for example, switching print to -use a templating system other than CGI::Ex::Template). +use a templating system other than Template::Alloy). =head1 SYNOPSIS STEP BY STEP @@ -1283,7 +1287,7 @@ hook. Adds method base_dir_rel to hook name_module, and name_step and adds on the default file extension found in $self->ext_print which defaults to the property $self->{ext_print} which will default to ".html". Should return a filename relative to base_dir_abs that can be -swapped using CGI::Ex::Template, or should be a scalar reference to +swapped using Template::Alloy, or should be a scalar reference to the template content that can be swapped. This will be used by the hook print. @@ -1959,11 +1963,12 @@ List the step previous to this one. Will return '' if there is no previous step =item print (hook) -Take the information generated by prepared_print, format it, and print it out. -Default incarnation uses CGI::Ex::Template which is compatible with -Template::Toolkit. Arguments are: step name (used to call the -file_print hook), swap hashref (passed to call swap_template), and -fill hashref (passed to fill_template). +Take the information generated by prepared_print, format it, and print +it out. Default incarnation uses CGI::Ex::Template (a subclass of +Template::Alloy) which is compatible with Template::Toolkit. +Arguments are: step name (used to call the file_print hook), swap +hashref (passed to call swap_template), and fill hashref (passed to +fill_template). During the print call, the file_print hook is called which should return a filename or a scalar reference to the template content is @@ -2144,19 +2149,23 @@ method to look for in the form. Default value is 'step'. =item swap_template (hook) -Takes the template and hash of variables prepared in print, and processes them -through the current template engine (default engine is CGI::Ex::Template). +Takes the template and hash of variables prepared in print, and +processes them through the current template engine (default engine is +CGI::Ex::Template a subclass of Template::Alloy). -Arguments are the template and the swap hashref. The template can be either a -scalar reference to the actual content, or the filename of the content. If the -filename is specified - it should be relative to base_dir_abs (which will be -used to initialize INCLUDE_PATH by default). +Arguments are the template and the swap hashref. The template can be +either a scalar reference to the actual content, or the filename of +the content. If the filename is specified - it should be relative to +base_dir_abs (which will be used to initialize INCLUDE_PATH by +default). -The default method will create a template object by calling the template_args hook -and passing the returned hashref to the template_obj method. The default template_obj method -returns a CGI::Ex::Template object, but could easily be swapped to use a Template::Toolkit -based object. If a non-Template::Toolkit compatible object is to be used, then -the swap_template hook can be overridden to use another templating engine. +The default method will create a template object by calling the +template_args hook and passing the returned hashref to the +template_obj method. The default template_obj method returns a +CGI::Ex::Template object, but could easily be swapped to use a +Template::Toolkit based object. If a non-Template::Toolkit compatible +object is to be used, then the swap_template hook can be overridden to +use another templating engine. For example to use the HTML::Template engine you could override the swap_template method as follows: @@ -2189,6 +2198,8 @@ following to parse the templates using HTML::Template::Expr syntax. return {SYNTAX => 'hte'}; } +For a listing of the available syntaxes, see the current L documentation. + =item template_args (hook) Returns a hashref of args that will be passed to the "new" method of CGI::Ex::Template. @@ -2196,7 +2207,8 @@ The method is normally called from the swap_template hook. The swap_template ho will add a value for INCLUDE_PATH which is set equal to base_dir_abs, if the INCLUDE_PATH value is not already set. -The returned hashref can contain any arguments that CGI::Ex::Template would understand. +The returned hashref can contain any arguments that CGI::Ex::Template (a subclass of Template::Alloy) +would understand. sub template_args { return { @@ -2205,11 +2217,15 @@ The returned hashref can contain any arguments that CGI::Ex::Template would unde }; } +See the L documentation for a listing of all possible configuration arguments. + =item template_obj (method) -Called from swap_template. It is passed the result of template_args that have -had a default INCLUDE_PATH added. The default implementation uses CGI::Ex::Template -but can easily be changed to use Template::Toolkit by using code similar to the following: +Called from swap_template. It is passed the result of template_args +that have had a default INCLUDE_PATH added. The default +implementation uses CGI::Ex::Template (a subclass of Template::Alloy) +but can easily be changed to use Template::Toolkit by using code +similar to the following: use Template; @@ -2371,7 +2387,8 @@ different. Seemingly the most well know of application builders. CGI::Ex::App is different in that it: - * Uses Template::Toolkit compatible CGI::Ex::Template by default + * Uses Template::Toolkit compatible CGI::Ex::Template (a + subclass of Template::Alloy) by default. CGI::Ex::App can easily use another toolkit by simply overriding the ->swap_template method. CGI::Application uses HTML::Template. diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index c515f68..d7056e2 100644 --- a/lib/CGI/Ex/Auth.pm +++ b/lib/CGI/Ex/Auth.pm @@ -18,7 +18,7 @@ use MIME::Base64 qw(encode_base64 decode_base64); use Digest::MD5 qw(md5_hex); use CGI::Ex; -$VERSION = '2.13'; +$VERSION = '2.14'; ###----------------------------------------------------------------### diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index 20893e3..fcd00a4 100644 --- a/lib/CGI/Ex/Conf.pm +++ b/lib/CGI/Ex/Conf.pm @@ -29,7 +29,7 @@ use vars qw($VERSION ); @EXPORT_OK = qw(conf_read conf_write in_cache); -$VERSION = '2.13'; +$VERSION = '2.14'; $DEFAULT_EXT = 'conf'; diff --git a/lib/CGI/Ex/Die.pm b/lib/CGI/Ex/Die.pm index 203890b..345468a 100644 --- a/lib/CGI/Ex/Die.pm +++ b/lib/CGI/Ex/Die.pm @@ -23,7 +23,7 @@ use CGI::Ex; use CGI::Ex::Dump qw(debug ctrace dex_html); BEGIN { - $VERSION = '2.13'; + $VERSION = '2.14'; $SHOW_TRACE = 0 if ! defined $SHOW_TRACE; $IGNORE_EVAL = 0 if ! defined $IGNORE_EVAL; $EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS; diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm index 09b5937..1a9070c 100644 --- a/lib/CGI/Ex/Dump.pm +++ b/lib/CGI/Ex/Dump.pm @@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION use strict; use Exporter; -$VERSION = '2.13'; +$VERSION = '2.14'; @ISA = qw(Exporter); @EXPORT = qw(dex dex_warn dex_text dex_html ctrace dex_trace); @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug); diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm index 9cf60cd..b15b773 100644 --- a/lib/CGI/Ex/Fill.pm +++ b/lib/CGI/Ex/Fill.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.13'; + $VERSION = '2.14'; @EXPORT = qw(form_fill); @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key); }; diff --git a/lib/CGI/Ex/JSONDump.pm b/lib/CGI/Ex/JSONDump.pm index bbc3134..c07a138 100644 --- a/lib/CGI/Ex/JSONDump.pm +++ b/lib/CGI/Ex/JSONDump.pm @@ -17,7 +17,7 @@ use strict; use base qw(Exporter); BEGIN { - $VERSION = '2.13'; + $VERSION = '2.14'; @EXPORT = qw(JSONDump); @EXPORT_OK = @EXPORT; diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 0b44a2c..2f6fbfa 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -1,3341 +1,159 @@ package CGI::Ex::Template; -###----------------------------------------------------------------### -# See the perldoc in CGI/Ex/Template.pod -# Copyright 2007 - Paul Seamons # -# Distributed under the Perl Artistic License without warranty # -###----------------------------------------------------------------### +=head1 NAME -use strict; - -our $VERSION = '2.13'; - -our $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception'; -our $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator'; -our $PACKAGE_CONTEXT = 'CGI::Ex::Template::Context'; -our $QR_PRIVATE = qr/^[_.]/; - -our $SYNTAX = { - cet => \&parse_tree_tt3, - ht => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; local $self->{'EXPR'} = 0; $self->parse_tree_hte(@_) }, - hte => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; $self->parse_tree_hte(@_) }, - tt3 => \&parse_tree_tt3, - tt2 => sub { my $self = shift; local $self->{'V2PIPE'} = 1; $self->parse_tree_tt3(@_) }, - tt1 => sub { my $self = shift; local $self->{'V2PIPE'} = 1; local $self->{'V1DOLLAR'} = 1; $self->parse_tree_tt3(@_) }, -}; - -our $TAGS = { - asp => ['<%', '%>' ], # ASP - default => ['\[%', '%\]' ], # default - html => ['' ], # HTML comments - mason => ['<%', '>' ], # HTML::Mason - metatext => ['%%', '%%' ], # Text::MetaText - php => ['<\?', '\?>' ], # PHP - star => ['\[\*', '\*\]' ], # TT alternate - template => ['\[%', '%\]' ], # Normal Template Toolkit - template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style - tt2 => ['\[%', '%\]' ], # TT2 -}; - -our $SCALAR_OPS = { - '0' => sub { $_[0] }, - abs => sub { local $^W; abs shift }, - atan2 => sub { local $^W; atan2($_[0], $_[1]) }, - chunk => \&vmethod_chunk, - collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ }, - cos => sub { local $^W; cos $_[0] }, - defined => sub { defined $_[0] ? 1 : '' }, - exp => sub { local $^W; exp $_[0] }, - fmt => \&vmethod_fmt_scalar, - 'format' => \&vmethod_format, - hash => sub { {value => $_[0]} }, - hex => sub { local $^W; hex $_[0] }, - html => sub { local $_ = $_[0]; s/&/&/g; s//>/g; s/\"/"/g; s/\'/'/g; $_ }, - indent => \&vmethod_indent, - int => sub { local $^W; int $_[0] }, - item => sub { $_[0] }, - js => sub { local $_ = $_[0]; return if ! $_; s/\n/\\n/g; s/\r/\\r/g; s/(? sub { lc $_[0] }, - lcfirst => sub { lcfirst $_[0] }, - length => sub { defined($_[0]) ? length($_[0]) : 0 }, - list => sub { [$_[0]] }, - log => sub { local $^W; log $_[0] }, - lower => sub { lc $_[0] }, - match => \&vmethod_match, - new => sub { defined $_[0] ? $_[0] : '' }, - null => sub { '' }, - oct => sub { local $^W; oct $_[0] }, - rand => sub { local $^W; rand shift }, - remove => sub { vmethod_replace(shift, shift, '', 1) }, - repeat => \&vmethod_repeat, - replace => \&vmethod_replace, - search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ }, - sin => sub { local $^W; sin $_[0] }, - size => sub { 1 }, - split => \&vmethod_split, - sprintf => sub { local $^W; my $pat = shift; sprintf($pat, @_) }, - sqrt => sub { local $^W; sqrt $_[0] }, - srand => sub { local $^W; srand $_[0]; '' }, - stderr => sub { print STDERR $_[0]; '' }, - substr => \&vmethod_substr, - trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ }, - uc => sub { uc $_[0] }, - ucfirst => sub { ucfirst $_[0] }, - upper => sub { uc $_[0] }, - uri => \&vmethod_uri, - url => \&vmethod_url, -}; - -our $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops - eval => [\&filter_eval, 1], - evaltt => [\&filter_eval, 1], - file => [\&filter_redirect, 1], - redirect => [\&filter_redirect, 1], -}; - -our $LIST_OPS = { - defined => sub { return 1 if @_ == 1; defined $_[0]->[ defined($_[1]) ? $_[1] : 0 ] }, - first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]}, - fmt => \&vmethod_fmt_list, - grep => sub { local $^W; my ($ref, $pat) = @_; [grep {/$pat/} @$ref] }, - hash => sub { local $^W; my $list = shift; return {@$list} if ! @_; my $i = shift || 0; return {map {$i++ => $_} @$list} }, - import => sub { my $ref = shift; push @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_; '' }, - item => sub { $_[0]->[ $_[1] || 0 ] }, - join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref }, - last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]}, - list => sub { $_[0] }, - max => sub { local $^W; $#{ $_[0] } }, - merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] }, - new => sub { local $^W; return [@_] }, - null => sub { '' }, - nsort => \&vmethod_nsort, - pick => \&vmethod_pick, - pop => sub { pop @{ $_[0] } }, - push => sub { my $ref = shift; push @$ref, @_; return '' }, - reverse => sub { [ reverse @{ $_[0] } ] }, - shift => sub { shift @{ $_[0] } }, - size => sub { local $^W; scalar @{ $_[0] } }, - slice => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] }, - sort => \&vmethod_sort, - splice => \&vmethod_splice, - unique => sub { my %u; return [ grep { ! $u{$_}++ } @{ $_[0] } ] }, - unshift => sub { my $ref = shift; unshift @$ref, @_; return '' }, -}; - -our $HASH_OPS = { - defined => sub { return 1 if @_ == 1; defined $_[0]->{ defined($_[1]) ? $_[1] : '' } }, - delete => sub { my $h = shift; delete @{ $h }{map {defined($_) ? $_ : ''} @_}; '' }, - each => sub { [%{ $_[0] }] }, - exists => sub { exists $_[0]->{ defined($_[1]) ? $_[1] : '' } }, - fmt => \&vmethod_fmt_hash, - hash => sub { $_[0] }, - import => sub { my ($a, $b) = @_; @{$a}{keys %$b} = values %$b if ref($b) eq 'HASH'; '' }, - item => sub { my ($h, $k) = @_; $k = '' if ! defined $k; $QR_PRIVATE && $k =~ $QR_PRIVATE ? undef : $h->{$k} }, - items => sub { [ %{ $_[0] } ] }, - keys => sub { [keys %{ $_[0] }] }, - list => \&vmethod_list_hash, - new => sub { local $^W; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} }, - null => sub { '' }, - nsort => sub { my $ref = shift; [sort { $ref->{$a} <=> $ref->{$b}} keys %$ref] }, - pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } sort keys %{ $_[0] } ] }, - size => sub { scalar keys %{ $_[0] } }, - sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] }, - values => sub { [values %{ $_[0] }] }, -}; - -our $VOBJS = { - Text => $SCALAR_OPS, - List => $LIST_OPS, - Hash => $HASH_OPS, -}; -foreach (values %$VOBJS) { - $_->{'Text'} = $_->{'fmt'}; - $_->{'Hash'} = $_->{'hash'}; - $_->{'List'} = $_->{'list'}; -} - -our $DIRECTIVES = { - #name parse_sub play_sub block postdir continue no_interp - BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1], - BREAK => [sub {}, \&play_control], - CALL => [\&parse_CALL, \&play_CALL], - CASE => [\&parse_CASE, undef, 0, 0, {SWITCH => 1, CASE => 1}], - CATCH => [\&parse_CATCH, undef, 0, 0, {TRY => 1, CATCH => 1}], - CLEAR => [sub {}, \&play_CLEAR], - '#' => [sub {}, sub {}], - CONFIG => [\&parse_CONFIG, \&play_CONFIG], - DEBUG => [\&parse_DEBUG, \&play_DEBUG], - DEFAULT => [\&parse_DEFAULT, \&play_DEFAULT], - DUMP => [\&parse_DUMP, \&play_DUMP], - ELSE => [sub {}, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}], - ELSIF => [\&parse_IF, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}], - END => [sub {}, sub {}], - FILTER => [\&parse_FILTER, \&play_FILTER, 1, 1], - '|' => [\&parse_FILTER, \&play_FILTER, 1, 1], - FINAL => [sub {}, undef, 0, 0, {TRY => 1, CATCH => 1}], - FOR => [\&parse_FOREACH, \&play_FOREACH, 1, 1], - FOREACH => [\&parse_FOREACH, \&play_FOREACH, 1, 1], - GET => [\&parse_GET, \&play_GET], - IF => [\&parse_IF, \&play_IF, 1, 1], - INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE], - INSERT => [\&parse_INSERT, \&play_INSERT], - LAST => [sub {}, \&play_control], - LOOP => [\&parse_LOOP, \&play_LOOP, 1, 1], - MACRO => [\&parse_MACRO, \&play_MACRO], - META => [\&parse_META, \&play_META], - NEXT => [sub {}, \&play_control], - PERL => [sub {}, \&play_PERL, 1, 0, 0, 1], - PROCESS => [\&parse_PROCESS, \&play_PROCESS], - RAWPERL => [sub {}, \&play_RAWPERL, 1, 0, 0, 1], - RETURN => [sub {}, \&play_control], - SET => [\&parse_SET, \&play_SET], - STOP => [sub {}, \&play_control], - SWITCH => [\&parse_SWITCH, \&play_SWITCH, 1], - TAGS => [\&parse_TAGS, sub {}], - THROW => [\&parse_THROW, \&play_THROW], - TRY => [sub {}, \&play_TRY, 1], - UNLESS => [\&parse_UNLESS, \&play_UNLESS, 1, 1], - USE => [\&parse_USE, \&play_USE], - VIEW => [\&parse_VIEW, \&play_VIEW, 1], - WHILE => [\&parse_WHILE, \&play_WHILE, 1, 1], - WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER, 1, 1], - #name parse_sub play_sub block postdir continue no_interp -}; - -### setup the operator parsing -our $OPERATORS = [ - # type precedence symbols action (undef means play_operator will handle) - ['prefix', 99, ['\\'], undef ], - ['postfix', 98, ['++'], undef ], - ['postfix', 98, ['--'], undef ], - ['prefix', 97, ['++'], undef ], - ['prefix', 97, ['--'], undef ], - ['right', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ], - ['prefix', 93, ['!'], sub { ! $_[0] } ], - ['prefix', 93, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], - ['left', 90, ['*'], sub { $_[0] * $_[1] } ], - ['left', 90, ['/'], sub { $_[0] / $_[1] } ], - ['left', 90, ['div', 'DIV'], sub { int($_[0] / $_[1]) } ], - ['left', 90, ['%', 'mod', 'MOD'], sub { $_[0] % $_[1] } ], - ['left', 85, ['+'], sub { $_[0] + $_[1] } ], - ['left', 85, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], - ['left', 85, ['~', '_'], undef ], - ['none', 80, ['<'], sub { $_[0] < $_[1] } ], - ['none', 80, ['>'], sub { $_[0] > $_[1] } ], - ['none', 80, ['<='], sub { $_[0] <= $_[1] } ], - ['none', 80, ['>='], sub { $_[0] >= $_[1] } ], - ['none', 80, ['lt'], sub { $_[0] lt $_[1] } ], - ['none', 80, ['gt'], sub { $_[0] gt $_[1] } ], - ['none', 80, ['le'], sub { $_[0] le $_[1] } ], - ['none', 80, ['ge'], sub { $_[0] ge $_[1] } ], - ['none', 75, ['=='], sub { $_[0] == $_[1] } ], - ['none', 75, ['eq'], sub { $_[0] eq $_[1] } ], - ['none', 75, ['!='], sub { $_[0] != $_[1] } ], - ['none', 75, ['ne'], sub { $_[0] ne $_[1] } ], - ['none', 75, ['<=>'], sub { $_[0] <=> $_[1] } ], - ['none', 75, ['cmp'], sub { $_[0] cmp $_[1] } ], - ['left', 70, ['&&'], undef ], - ['right', 65, ['||'], undef ], - ['none', 60, ['..'], sub { $_[0] .. $_[1] } ], - ['ternary', 55, ['?', ':'], undef ], - ['assign', 53, ['+='], sub { $_[0] + $_[1] } ], - ['assign', 53, ['-='], sub { $_[0] - $_[1] } ], - ['assign', 53, ['*='], sub { $_[0] * $_[1] } ], - ['assign', 53, ['/='], sub { $_[0] / $_[1] } ], - ['assign', 53, ['%='], sub { $_[0] % $_[1] } ], - ['assign', 53, ['**='], sub { $_[0] ** $_[1] } ], - ['assign', 53, ['~=', '_='], sub { $_[0] . $_[1] } ], - ['assign', 52, ['='], undef ], - ['prefix', 50, ['not', 'NOT'], sub { ! $_[0] } ], - ['left', 45, ['and', 'AND'], undef ], - ['right', 40, ['or', 'OR'], undef ], -]; -our ($QR_OP, $QR_OP_PREFIX, $QR_OP_ASSIGN, $OP, $OP_PREFIX, $OP_DISPATCH, $OP_ASSIGN, $OP_POSTFIX, $OP_TERNARY); -sub _op_qr { # no mixed \w\W operators - my %used; - my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {! /\{\}|\[\]/} grep {/^\W{2,}$/} @_; - my $chr = join '', sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_; - my $word = join '|', reverse sort grep {++$used{$_} < 2} grep {/^\w+$/} @_; - $chr = "[$chr]" if $chr; - $word = "\\b(?:$word)\\b" if $word; - return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex"; -} -sub _build_ops { - $QR_OP = _op_qr(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS); - $QR_OP_PREFIX = _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS); - $QR_OP_ASSIGN = _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS); - $OP = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] ne 'prefix' } @$OPERATORS}; # all non-prefix - $OP_PREFIX = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] eq 'prefix' } @$OPERATORS}; - $OP_DISPATCH = {map {my $ref = $_; map {$_ => $ref->[3]} @{$ref->[2]}} grep {$_->[3] } @$OPERATORS}; - $OP_ASSIGN = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'assign' } @$OPERATORS}; - $OP_POSTFIX = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'postfix'} @$OPERATORS}; # bool is postfix - $OP_TERNARY = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'ternary'} @$OPERATORS}; # bool is ternary -} -_build_ops(); - -our $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )'; -our $QR_COMMENTS = '(?-s: \# .* \s*)*'; -our $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\.][\w\-\.]* (?:/[\w\-\.]+)*'; -our $QR_BLOCK = '\w+\b (?: :\w+\b)* )'; -our $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?'; -our $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=;) )'; - -our $WHILE_MAX = 1000; -our $EXTRA_COMPILE_EXT = '.sto'; -our $MAX_EVAL_RECURSE = 50; -our $MAX_MACRO_RECURSE = 50; -our $STAT_TTL ||= 1; - -our @CONFIG_COMPILETIME = qw(SYNTAX ANYCASE INTERPOLATE PRE_CHOMP POST_CHOMP SEMICOLONS V1DOLLAR V2PIPE V2EQUALS); -our @CONFIG_RUNTIME = qw(DUMP VMETHOD_FUNCTIONS); - -BEGIN { - if ($ENV{'MOD_PERL'}) { - eval {require Scalar::Util}; - require CGI::Ex::Template::Extra; - require CGI::Ex::Template::HTE; - } -}; - -###----------------------------------------------------------------### - -sub new { - my $class = shift; - my $args = ref($_[0]) ? { %{ shift() } } : {@_}; - - ### allow for lowercase args - if (my @keys = grep {/^[a-z][a-z_]+$/} keys %$args) { - @{ $args }{ map { uc $_ } @keys } = delete @{ $args }{ @keys }; - } - - my $self = bless $args, $class; - - ### "enable" debugging - we only support DEBUG_DIRS and DEBUG_UNDEF - if ($self->{'DEBUG'}) { - $self->{'_debug_dirs'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/; - $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/; - } - - return $self; -} - -###----------------------------------------------------------------### - -sub _process { - my $self = shift; - my $file = shift; - local $self->{'_vars'} = shift || {}; - my $out_ref = shift || $self->throw('undef', "Missing output ref"); - local $self->{'_top_level'} = delete $self->{'_start_top_level'}; - my $i = length $$out_ref; - - ### parse and execute - my $doc; - eval { - ### handed us a precompiled document - if (ref($file) eq 'HASH' && $file->{'_tree'}) { - $doc = $file; - - ### load the document - } else { - $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");; - } - - ### prevent recursion - $self->throw('file', "recursion into '$doc->{name}'") - if ! $self->{'RECURSION'} && $self->{'_in'}->{$doc->{'name'}} && $doc->{'name'} ne 'input text'; - local $self->{'_in'}->{$doc->{'name'}} = 1; - - ### execute the document - if (! @{ $doc->{'_tree'} }) { # no tags found - just return the content - $$out_ref = ${ $doc->{'_content'} }; - } else { - local $self->{'_component'} = $doc; - local $self->{'_template'} = $self->{'_top_level'} ? $doc : $self->{'_template'}; - local @{ $self }{@CONFIG_RUNTIME} = @{ $self }{@CONFIG_RUNTIME}; - $self->execute_tree($doc->{'_tree'}, $out_ref); - } - - ### trim whitespace from the beginning and the end of a block or template - if ($self->{'TRIM'}) { - substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ \s+ $ }{}x; # tail first - substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ ^ \s+ }{}x; - } - }; - - ### handle exceptions - if (my $err = $@) { - $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; - $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc; - die $err if ! $self->{'_top_level'} || $err->type !~ /stop|return/; - } - - return 1; -} - -###----------------------------------------------------------------### - -sub load_parsed_tree { - my $self = shift; - my $file = shift; - return if ! defined $file; - - my $doc = {name => $file}; - my $ref = $self->{'_documents'}->{$file}; - - ### looks like a string reference - if (ref $file) { - $doc->{'_content'} = $file; - $doc->{'name'} = 'input text'; - $doc->{'_is_str_ref'} = 1; - - ### looks like a previously cached-in-memory document - } elsif ($ref - && ( time - $ref->{'cache_time'} < ($self->{'STAT_TTL'} || $STAT_TTL) # don't stat more than once a second - || $ref->{'modtime'} == (stat $ref->{'_filename'})[9] # otherwise see if the file was modified - )) { - $doc = $self->{'_documents'}->{$file}; - return $doc; - - ### looks like a block name of some sort - } elsif ($self->{'BLOCKS'}->{$file}) { - my $block = $self->{'BLOCKS'}->{$file}; - - ### allow for predefined blocks that are a code or a string - if (UNIVERSAL::isa($block, 'CODE')) { - $block = $block->(); - } - if (! UNIVERSAL::isa($block, 'HASH')) { - $self->throw('block', "Unsupported BLOCK type \"$block\"") if ref $block; - my $copy = $block; - $block = eval { $self->load_parsed_tree(\$copy) } - || $self->throw('block', 'Parse error on predefined block'); - } - $doc->{'_tree'} = $block->{'_tree'} || $self->throw('block', "Invalid block definition (missing tree)"); - return $doc; - - ### handle cached not_founds - } elsif ($self->{'_not_found'}->{$file} - && ((time - $self->{'_not_found'}->{$file}->{'cache_time'} - < ($self->{'NEGATIVE_STAT_TTL'} || $self->{'STAT_TTL'} || $STAT_TTL)) # negative cache for a second - || do { delete $self->{'_not_found'}->{$file}; 0 } # clear cache on failure - )) { - die $self->{'_not_found'}->{$file}->{'exception'}; - - ### go and look on the file system - } else { - $doc->{'_filename'} = eval { $self->include_filename($file) }; - if (my $err = $@) { - ### allow for blocks in other files - if ($self->{'EXPOSE_BLOCKS'} - && ! $self->{'_looking_in_block_file'}) { - local $self->{'_looking_in_block_file'} = 1; - my $block_name = ''; - while ($file =~ s|/([^/.]+)$||) { - $block_name = length($block_name) ? "$1/$block_name" : $1; - my $ref = eval { $self->load_parsed_tree($file) } || next; - my $_tree = $ref->{'_tree'}; - foreach my $node (@$_tree) { - next if ! ref $node; - next if $node->[0] eq 'META'; - last if $node->[0] ne 'BLOCK'; - next if $block_name ne $node->[3]; - $doc->{'_content'} = $ref->{'_content'}; - $doc->{'_tree'} = $node->[4]; - $doc->{'modtime'} = $ref->{'modtime'}; - $file = $ref->{'name'}; - last; - } - } - $err = '' if ! $doc->{'_tree'}; - } elsif ($self->{'DEFAULT'}) { - $err = '' if ($doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) }); - } - if ($err) { - ### cache the negative error - if (! defined($self->{'NEGATIVE_STAT_TTL'}) || $self->{'NEGATIVE_STAT_TTL'}) { - $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; - $self->{'_not_found'}->{$file} = { - cache_time => time, - exception => $self->exception($err->type, $err->info." (cached)"), - }; - } - die $err; - } - } - - ### no tree yet - look for a file cache - if (! $doc->{'_tree'}) { - $doc->{'modtime'} = (stat $doc->{'_filename'})[9]; - if ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) { - if ($self->{'COMPILE_DIR'}) { - $doc->{'_compile_filename'} = $self->{'COMPILE_DIR'} .'/'. $file; - } else { - $doc->{'_compile_filename'} = $doc->{'_filename'}; - } - $doc->{'_compile_filename'} .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'}); - $doc->{'_compile_filename'} .= $EXTRA_COMPILE_EXT if defined $EXTRA_COMPILE_EXT; - - if (-e $doc->{'_compile_filename'} && (stat _)[9] == $doc->{'modtime'}) { - require Storable; - $doc->{'_tree'} = Storable::retrieve($doc->{'_compile_filename'}); - $doc->{'compile_was_used'} = 1; - } else { - my $str = $self->slurp($doc->{'_filename'}); - $doc->{'_content'} = \$str; - } - } else { - my $str = $self->slurp($doc->{'_filename'}); - $doc->{'_content'} = \$str; - } - } - - } - - ### haven't found a parsed tree yet - parse the content into a tree - if (! $doc->{'_tree'}) { - if ($self->{'CONSTANTS'}) { - my $key = $self->{'CONSTANT_NAMESPACE'} || 'constants'; - $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'}; - } - - local $self->{'_component'} = $doc; - $doc->{'_tree'} = eval { $self->parse_tree($doc->{'_content'}) } - || do { my $e = $@; $e->doc($doc) if UNIVERSAL::can($e, 'doc') && ! $e->doc; die $e }; # errors die - } - - ### cache parsed_tree in memory unless asked not to do so - if (! $doc->{'_is_str_ref'} && (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'})) { - $self->{'_documents'}->{$file} ||= $doc; - $doc->{'cache_time'} = time; - - ### allow for config option to keep the cache size down - if ($self->{'CACHE_SIZE'}) { - my $all = $self->{'_documents'}; - if (scalar(keys %$all) > $self->{'CACHE_SIZE'}) { - my $n = 0; - foreach my $file (sort {$all->{$b}->{'cache_time'} <=> $all->{$a}->{'cache_time'}} keys %$all) { - delete($all->{$file}) if ++$n > $self->{'CACHE_SIZE'}; - } - } - } - } - - ### save a cache on the fileside as asked - if ($doc->{'_compile_filename'} && ! $doc->{'compile_was_used'}) { - my $dir = $doc->{'_compile_filename'}; - $dir =~ s|/[^/]+$||; - if (! -d $dir) { - require File::Path; - File::Path::mkpath($dir); - } - require Storable; - Storable::store($doc->{'_tree'}, $doc->{'_compile_filename'}); - utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_compile_filename'}; - } - - return $doc; -} - -###----------------------------------------------------------------### - -sub parse_tree { - my $syntax = $_[0]->{'SYNTAX'} || 'cet'; - my $meth = $SYNTAX->{$syntax} || $_[0]->throw('parse', "Unknown SYNTAX \"$syntax\""); - return $meth->(@_); -} - -sub parse_tree_tt3 { - my $self = shift; - my $str_ref = shift; - if (! $str_ref || ! defined $$str_ref) { - $self->throw('parse.no_string', "No string or undefined during parse"); - } - - my $STYLE = $self->{'TAG_STYLE'} || 'default'; - my $START = $self->{'START_TAG'} || $TAGS->{$STYLE}->[0]; - my $END = $self->{'END_TAG'} || $TAGS->{$STYLE}->[1]; - local $self->{'_end_tag'} = $END; - - local @{ $self }{@CONFIG_COMPILETIME} = @{ $self }{@CONFIG_COMPILETIME}; - - my @tree; # the parsed tree - my $pointer = \@tree; # pointer to current tree to handle nested blocks - my @state; # maintain block levels - local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS) - local $self->{'_no_interp'} = 0; # no interpolation in some blocks (usually PERL) - my @in_view; # let us know if we are in a view - my @blocks; # store blocks for later moving to front - my @meta; # place to store any found meta information (to go into META) - my $post_chomp = 0; # previous post_chomp setting - my $continue = 0; # flag for multiple directives in the same tag - my $post_op = 0; # found a post-operative DIRECTIVE - my $capture; # flag to start capture - my $func; - my $node; - local pos $$str_ref = 0; - - while (1) { - ### continue looking for information in a semi-colon delimited tag - if ($continue) { - $node = [undef, $continue, undef]; - - ### find the next opening tag - } else { - $$str_ref =~ m{ \G (.*?) $START }gcxs - || last; - - ### found a text portion - chomp it, interpolate it and store it - if (length $1) { - my $text = $1; - my $_last = pos $$str_ref; - if ($post_chomp) { - if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x } - elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x } - elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x } - } - if (length $text) { - push @$pointer, $text; - $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'}; - } - } - - $node = [undef, pos($$str_ref), undef]; - - ### take care of whitespace and comments flags - my $pre_chomp = $$str_ref =~ m{ \G ([+=~-]) }gcx ? $1 : $self->{'PRE_CHOMP'}; - $pre_chomp =~ y/-=~+/1230/ if $pre_chomp; - if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) { - if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x } - elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x } - elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x } - splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length - } - - ### leading # means to comment the entire section - if ($$str_ref =~ m{ \G \# }gcx) { - $$str_ref =~ m{ \G (.*?) ([+~=-]?) ($END) }gcxs # brute force - can't comment tags with nested %] - || $self->throw('parse', "Missing closing tag", undef, pos($$str_ref)); - $node->[0] = '#'; - $node->[2] = pos($$str_ref) - length($3); - push @$pointer, $node; - - $post_chomp = $2; - $post_chomp ||= $self->{'POST_CHOMP'}; - $post_chomp =~ y/-=~+/1230/ if $post_chomp; - next; - } - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - } - - ### look for DIRECTIVES - if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcxo # find a word - && ($func = $self->{'ANYCASE'} ? uc($1) : $1) - && ($DIRECTIVES->{$func} - || ((pos($$str_ref) -= length $1) && 0)) - ) { # is it a directive - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcx; - - $node->[0] = $func; - - ### store out this current node level to the appropriate tree location - # on a post operator - replace the original node with the new one - store the old in the new - if ($DIRECTIVES->{$func}->[3] && $post_op) { - my @post_op = @$post_op; - @$post_op = @$node; - $node = $post_op; - $node->[4] = [\@post_op]; - # if there was not a semi-colon - see if semis were required - } elsif ($post_op && $self->{'SEMICOLONS'}) { - $self->throw('parse', "Missing semi-colon with SEMICOLONS => 1", undef, $node->[1]); - - # handle directive captures for an item like "SET foo = BLOCK" - } elsif ($capture) { - push @{ $capture->[4] }, $node; - undef $capture; - - # normal nodes - } else{ - push @$pointer, $node; - } - - ### parse any remaining tag details - $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) }; - if (my $err = $@) { - $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; - die $err; - } - $node->[2] = pos $$str_ref; - - ### anything that behaves as a block ending - if ($func eq 'END' || $DIRECTIVES->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc) - if (! @state) { - $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref)); - } - my $parent_node = pop @state; - - if ($func ne 'END') { - pop @$pointer; # we will store the node in the parent instead - $parent_node->[5] = $node; - my $parent_type = $parent_node->[0]; - if (! $DIRECTIVES->{$func}->[4]->{$parent_type}) { - $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref)); - } - } - - ### restore the pointer up one level (because we hit the end of a block) - $pointer = (! @state) ? \@tree : $state[-1]->[4]; - - ### normal end block - if ($func eq 'END') { - if ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front - if (defined($parent_node->[3]) && @in_view) { - push @{ $in_view[-1] }, $parent_node; - } else { - push @blocks, $parent_node; - } - if ($pointer->[-1] && ! $pointer->[-1]->[6]) { - splice(@$pointer, -1, 1, ()); - } - } elsif ($parent_node->[0] eq 'VIEW') { - my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }}; - unshift @{ $parent_node->[3] }, $ref; - } elsif ($DIRECTIVES->{$parent_node->[0]}->[5]) { # allow no_interp to turn on and off - $self->{'_no_interp'}--; - } - - ### continuation block - such as an elsif - } else { - push @state, $node; - $pointer = $node->[4] ||= []; - } - - ### handle block directives - } elsif ($DIRECTIVES->{$func}->[2] && ! $post_op) { - push @state, $node; - $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node - push @in_view, [] if $func eq 'VIEW'; - $self->{'_no_interp'}++ if $DIRECTIVES->{$node->[0]}->[5] # allow no_interp to turn on and off - - } elsif ($func eq 'TAGS') { - ($START, $END) = @{ $node->[3] }; - - ### allow for one more closing tag of the old style - if ($$str_ref =~ m{ \G ([+~=-]?) $self->{'_end_tag'} }gcxs) { - $post_chomp = $1 || $self->{'POST_CHOMP'}; - $post_chomp =~ y/-=~+/1230/ if $post_chomp; - $continue = 0; - $post_op = 0; - $self->{'_end_tag'} = $END; # need to keep track so parse_expr knows when to stop - next; - } - $self->{'_end_tag'} = $END; - - } elsif ($func eq 'META') { - unshift @meta, %{ $node->[3] }; # first defined win - $node->[3] = undef; # only let these be defined once - at the front of the tree - } - - ### allow for bare variable getting and setting - } elsif (defined(my $var = $self->parse_expr($str_ref))) { - if ($post_op && $self->{'SEMICOLONS'}) { - $self->throw('parse', "Missing semi-colon with SEMICOLONS => 1", undef, $node->[1]); - } - push @$pointer, $node; - if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? (?! [+=~-]? $END) \s* $QR_COMMENTS }gcx) { - $node->[0] = 'SET'; - $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, $str_ref, $node, $1, $var) }; - if (my $err = $@) { - $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; - die $err; - } - } else { - $node->[0] = 'GET'; - $node->[3] = $var; - } - $node->[2] = pos $$str_ref; - } - - ### look for the closing tag - if ($$str_ref =~ m{ \G (?: ; \s* $QR_COMMENTS)? ([+=~-]?) $END }gcxs) { - $post_chomp = $1 || $self->{'POST_CHOMP'}; - $post_chomp =~ y/-=~+/1230/ if $post_chomp; - $continue = 0; - $post_op = 0; - next; - } - - ### semi-colon = end of statement - we will need to continue parsing this tag - if ($$str_ref =~ m{ \G ; \s* $QR_COMMENTS }gcxo) { - $post_op = 0; - - ### we are flagged to start capturing the output of the next directive - set it up - } elsif ($node->[6]) { - $post_op = 0; - $capture = $node; - - ### allow next directive to be post-operative (or not) - } else { - $post_op = $node; - } - - ### no closing tag yet - no need to get an opening tag on next loop - $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref)) if $continue == pos $$str_ref; - $continue = pos $$str_ref; - } - - ### cleanup the tree - unshift(@tree, @blocks) if @blocks; - unshift(@tree, ['META', 0, 0, {@meta}]) if @meta; - $self->throw('parse', "Missing END directive", $state[-1], pos($$str_ref)) if @state > 0; - - ### pull off the last text portion - if any - if (pos($$str_ref) != length($$str_ref)) { - my $text = substr $$str_ref, pos($$str_ref); - my $_last = pos($$str_ref); - if ($post_chomp) { - if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x } - elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x } - elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x } - } - if (length $text) { - push @$pointer, $text; - $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'}; - } - } - - return \@tree; -} - -sub parse_tree_hte { - require CGI::Ex::Template::HTE; - &CGI::Ex::Template::HTE::parse_tree_hte; -} - -sub parse_expr { - my $self = shift; - my $str_ref = shift; - my $ARGS = shift || {}; - my $is_aq = $ARGS->{'auto_quote'} ? 1 : 0; - my $mark = pos $$str_ref; - - ### allow for custom auto_quoting (such as hash constructors) - if ($is_aq) { - if ($$str_ref =~ m{ \G $ARGS->{'auto_quote'} }gcx) { - return $1; - - ### allow for auto-quoted $foo - } elsif ($$str_ref =~ m{ \G \$ (\w+\b (?:\.\w+\b)*) \s* $QR_COMMENTS }gcxo) { - my $name = $1; - if ($$str_ref !~ m{ \G \( }gcx || $name =~ /^(?:qw|m|\d)/) { - return $self->parse_expr(\$name); - } - ### this is a little cryptic/odd - but TT allows items in - ### autoquote position to only be prefixed by a $ - gross - ### so we will defer to the regular parsing - but after the $ - pos($$str_ref) = $mark + 1; - $is_aq = undef; # but don't allow operators - false flag handed down - - ### allow for ${foo.bar} type constructs - } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) { - my $var = $self->parse_expr($str_ref); - $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo - || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); - return $var; - } - } - - - ### test for leading prefix operators - my $has_prefix; - while (! $is_aq && $$str_ref =~ m{ \G ($QR_OP_PREFIX) }gcxo) { - push @{ $has_prefix }, $1; - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - } - - my @var; - my $is_literal; - my $is_namespace; - my $already_parsed_args; - - ### allow hex - if ($$str_ref =~ m{ \G 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }gcxo) { - my $number = eval { hex $1 } || 0; - push @var, \ $number; - $is_literal = 1; - - ### allow for numbers - } elsif ($$str_ref =~ m{ \G ( $QR_NUM ) \s* $QR_COMMENTS }gcxo) { - my $number = $1; - push @var, \ $number; - $is_literal = 1; - - ### allow for quoted array constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G qw ([^\w\s]) \s* }gcxo) { - my $quote = $1; - $quote =~ y|([{<|)]}>|; - $$str_ref =~ m{ \G (.*?) (?throw('parse.missing.array_close', "Missing close \"$quote\"", undef, pos($$str_ref)); - my $str = $1; - $str =~ s{ ^ \s+ }{}x; - $str =~ s{ \s+ $ }{}x; - $str =~ s{ \\ \Q$quote\E }{$quote}gx; - push @var, [undef, '[]', split /\s+/, $str]; - - ### allow for regex constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G / }gcx) { - $$str_ref =~ m{ \G (.*?) (?throw('parse', 'Unclosed regex tag "/"', undef, pos($$str_ref)); - my ($str, $opts) = ($1, $2); - $self->throw('parse', 'e option not allowed on regex', undef, pos($$str_ref)) if $opts =~ /e/; - $self->throw('parse', 'g option not supported on regex', undef, pos($$str_ref)) if $opts =~ /g/; - $str =~ s|\\n|\n|g; - $str =~ s|\\t|\t|g; - $str =~ s|\\r|\r|g; - $str =~ s|\\\/|\/|g; - $str =~ s|\\\$|\$|g; - $self->throw('parse', "Invalid regex: $@", undef, pos($$str_ref)) if ! eval { "" =~ /$str/; 1 }; - push @var, [undef, 'qr', $str, $opts]; - - ### looks like a normal variable start - } elsif ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxo) { - push @var, $1; - $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1}; - - ### allow for literal strings - } elsif ($$str_ref =~ m{ \G ([\"\']) }gcx) { - my $quote = $1; - $$str_ref =~ m{ \G (.*?) (?throw('parse', "Unclosed quoted string ($1)", undef, pos($$str_ref)); - my $str = $1; - if ($quote eq "'") { # no interpolation on single quoted strings - $str =~ s{ \\\' }{\'}xg; - push @var, \ $str; - $is_literal = 1; - } else { - $str =~ s/\\n/\n/g; - $str =~ s/\\t/\t/g; - $str =~ s/\\r/\r/g; - $str =~ s/\\"/"/g; - my @pieces = $is_aq - ? split(m{ (?: ^ | (?parse_expr(\$name); - } - @pieces = grep {defined && length} @pieces; - if (@pieces == 1 && ! ref $pieces[0]) { - push @var, \ $pieces[0]; - $is_literal = 1; - } elsif (! @pieces) { - push @var, \ ''; - $is_literal = 1; - } else { - push @var, [undef, '~', @pieces]; - } - } - if ($is_aq) { - return ${ $var[0] } if $is_literal; - push @var, 0; - return \@var; - } - - ### allow for leading $foo type constructs - } elsif ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) { - if ($self->{'V1DOLLAR'}) { - push @var, $1; - $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1}; - } else { - push @var, [$1, 0]; - } - - ### allow for ${foo.bar} type constructs - } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) { - push @var, $self->parse_expr($str_ref); - $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo - || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); - - ### looks like an array constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G \[ \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset presedence - my $arrayref = [undef, '[]']; - while (defined(my $var = $self->parse_expr($str_ref))) { - push @$arrayref, $var; - $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo; - } - $$str_ref =~ m{ \G \] \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, pos($$str_ref)); - push @var, $arrayref; - - ### looks like a hash constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G \{ \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset precedence - my $hashref = [undef, '{}']; - while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))) { - $$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo; - my $val = $self->parse_expr($str_ref); - push @$hashref, $key, $val; - $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo; - } - $$str_ref =~ m{ \G \} \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.curly_bracket', "Missing close \}", undef, pos($$str_ref)); - push @var, $hashref; - - ### looks like a paren grouper - } elsif (! $is_aq && $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset precedence - my $var = $self->parse_expr($str_ref, {allow_parened_ops => 1}); - - $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref)); - - $self->throw('parse', 'Paren group cannot be followed by an open paren', undef, pos($$str_ref)) - if $$str_ref =~ m{ \G \( }gcx; - - $already_parsed_args = 1; - if (! ref $var) { - push @var, \$var, 0; - $is_literal = 1; - } elsif (! defined $var->[0]) { - push @var, $var, 0; - } else { - push @var, @$var; - } - - ### nothing to find - return failure - } else { - pos($$str_ref) = $mark if $is_aq || $has_prefix; - return; - } +CGI::Ex::Template - Template::Alloy based TT2/TT3/HT/HTE/Tmpl/Velocity engine. - # auto_quoted thing was too complicated - if ($is_aq) { - pos($$str_ref) = $mark; - return; - } +=cut - ### looks for args for the initial - if ($already_parsed_args) { - # do nothing - } elsif ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset precedence - my $args = $self->parse_args($str_ref, {is_parened => 1}); - $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref)); - push @var, $args; - } else { - push @var, 0; - } - - - ### allow for nested items - while ($$str_ref =~ m{ \G ( \.(?!\.) | \|(?!\|) ) }gcx) { - if ($1 eq '|' && $self->{'V2PIPE'}) { - pos($$str_ref) -= 1; - last; - } - - push(@var, $1) if ! $ARGS->{'no_dots'}; - - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - - ### allow for interpolated variables in the middle - one.$foo.two - if ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) { - push @var, $self->{'V1DOLLAR'} ? $1 : [$1, 0]; - - ### or one.${foo.bar}.two - } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) { - push @var, $self->parse_expr($str_ref); - $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo - || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); - - ### allow for names - } elsif ($$str_ref =~ m{ \G (-? \w+) \s* $QR_COMMENTS }gcxo) { - push @var, $1; - - } else { - $self->throw('parse', "Not sure how to continue parsing", undef, pos($$str_ref)); - } - - ### looks for args for the nested item - if ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset precedence - my $args = $self->parse_args($str_ref, {is_parened => 1}); - $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref)); - push @var, $args; - } else { - push @var, 0; - } - - } - - ### flatten literals and constants as much as possible - my $var; - if ($is_literal) { - $var = ${ $var[0] }; - if ($#var != 1) { - $var[0] = [undef, '~', $var]; - $var = \@var; - } - } elsif ($is_namespace) { - $var = $self->play_expr(\@var, {is_namespace_during_compile => 1}); - } else { - $var = \@var; - } - - ### allow for all "operators" - if (! $self->{'_operator_precedence'} && defined $is_aq) { - my $tree; - my $found; - while (1) { - my $mark = pos $$str_ref; - if ($self->{'_end_tag'} && $$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) { - pos($$str_ref) = $mark; - last; - } elsif ($$str_ref !~ m{ \G ($QR_OP) }gcxo) { - pos($$str_ref) = $mark; - last; - } - if ($OP_ASSIGN->{$1} && ! $ARGS->{'allow_parened_ops'}) { # only allow assignment in parens - pos($$str_ref) = $mark; - last; - } - local $self->{'_operator_precedence'} = 1; - my $op = $1; - $op = 'eq' if $op eq '==' && (! defined($self->{'V2EQUALS'}) || $self->{'V2EQUALS'}); - $op = 'ne' if $op eq '!=' && (! defined($self->{'V2EQUALS'}) || $self->{'V2EQUALS'}); - - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - - ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --) - if ($OP_POSTFIX->{$op}) { - $var = [[undef, $op, $var, 1], 0]; # cheat - give a "second value" to postfix ops - next; - - ### allow for prefix operator precedence - } elsif ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix->[-1]}->[1]) { - if ($tree) { - if ($#$tree == 1) { # only one operator - keep simple things fast - $var = [[undef, $tree->[0], $var, $tree->[1]], 0]; - } else { - unshift @$tree, $var; - $var = $self->apply_precedence($tree, $found); - } - undef $tree; - undef $found; - } - $var = [[undef, $has_prefix->[-1], $var ], 0]; - if (! @$has_prefix) { undef $has_prefix } else { pop @$has_prefix } - } - - ### add the operator to the tree - my $var2 = $self->parse_expr($str_ref, {from_here => 1}); - $self->throw('parse', 'Missing variable after "'.$op.'"', undef, pos($$str_ref)) if ! defined $var2; - push (@{ $tree ||= [] }, $op, $var2); - $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op} - } - - ### if we found operators - tree the nodes by operator precedence - if ($tree) { - if (@$tree == 2) { # only one operator - keep simple things fast - $var = [[undef, $tree->[0], $var, $tree->[1]], 0]; - } else { - unshift @$tree, $var; - $var = $self->apply_precedence($tree, $found); - } - } - } - - ### allow for prefix on non-chained variables - if ($has_prefix) { - $var = [[undef, $_, $var], 0] for reverse @$has_prefix; - } - - return $var; -} - -### this is used to put the parsed variables into the correct operations tree -sub apply_precedence { - my ($self, $tree, $found) = @_; - - my @var; - my $trees; - ### look at the operators we found in the order we found them - for my $prec (sort keys %$found) { - my $ops = $found->{$prec}; - local $found->{$prec}; - delete $found->{$prec}; - - ### split the array on the current operators for this level - my @ops; - my @exprs; - for (my $i = 1; $i <= $#$tree; $i += 2) { - next if ! $ops->{ $tree->[$i] }; - push @ops, $tree->[$i]; - push @exprs, [splice @$tree, 0, $i, ()]; - shift @$tree; - $i = -1; - } - next if ! @exprs; # this iteration didn't have the current operator - push @exprs, $tree if scalar @$tree; # add on any remaining items - - ### simplify sub expressions - for my $node (@exprs) { - if (@$node == 1) { - $node = $node->[0]; # single item - its not a tree - } elsif (@$node == 3) { - $node = [[undef, $node->[1], $node->[0], $node->[2]], 0]; # single operator - put it straight on - } else { - $node = $self->apply_precedence($node, $found); # more complicated - recurse - } - } - - ### assemble this current level - - ### some rules: - # 1) items at the same precedence level must all be either right or left or ternary associative - # 2) ternary items cannot share precedence with anybody else. - # 3) there really shouldn't be another operator at the same level as a postfix - my $type = $OP->{$ops[0]}->[0]; - - if ($type eq 'ternary') { - my $op = $OP->{$ops[0]}->[2]->[0]; # use the first op as what we are using - - ### return simple ternary - if (@exprs == 3) { - $self->throw('parse', "Ternary operator mismatch") if $ops[0] ne $op; - $self->throw('parse', "Ternary operator mismatch") if ! $ops[1] || $ops[1] eq $op; - return [[undef, $op, @exprs], 0]; - } - - - ### reorder complex ternary - rare case - while ($#ops >= 1) { - ### if we look starting from the back - the first lead ternary op will always be next to its matching op - for (my $i = $#ops; $i >= 0; $i --) { - next if $OP->{$ops[$i]}->[2]->[1] eq $ops[$i]; - my ($op, $op2) = splice @ops, $i, 2, (); # remove the pair of operators - my $node = [[undef, $op, @exprs[$i .. $i + 2]], 0]; - splice @exprs, $i, 3, $node; - } - } - return $exprs[0]; # at this point the ternary has been reduced to a single operator - - } elsif ($type eq 'right' || $type eq 'assign') { - my $val = $exprs[-1]; - $val = [[undef, $ops[$_ - 1], $exprs[$_], $val], 0] for reverse (0 .. $#exprs - 1); - return $val; - - } else { - my $val = $exprs[0]; - $val = [[undef, $ops[$_ - 1], $val, $exprs[$_]], 0] for (1 .. $#exprs); - return $val; - - } - } - - $self->throw('parse', "Couldn't apply precedence"); -} - -### look for arguments - both positional and named -sub parse_args { - my $self = shift; - my $str_ref = shift; - my $ARGS = shift || {}; - - my @args; - my @named; - my $name; - my $end = $self->{'_end_tag'} || '(?!)'; - while (1) { - my $mark = pos $$str_ref; - - ### look to see if the next thing is a directive or a closing tag - if (! $ARGS->{'is_parened'} - && ! $ARGS->{'require_arg'} - && $$str_ref =~ m{ \G $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$end))) }gcxo - && ((pos($$str_ref) = $mark) || 1) # always revert - && $DIRECTIVES->{$self->{'ANYCASE'} ? uc($1) : $1} # looks like a directive - we are done - ) { - last; - } - if ($$str_ref =~ m{ \G [+=~-]? $end }gcx) { - pos($$str_ref) = $mark; - last; - } - - ### find the initial arg - my $name; - if ($ARGS->{'allow_bare_filenames'}) { - $name = $self->parse_expr($str_ref, {auto_quote => " - ($QR_FILENAME # file name - | $QR_BLOCK # or block - (?= [+=~-]? $end # an end tag - | \\s*[+,;] # followed by explicit + , or ; - | \\s+ (?! [\\s=]) # or space not before an = - ) \\s* $QR_COMMENTS"}); - # filenames can be separated with a "+" - why a "+" ? - if ($$str_ref =~ m{ \G \+ (?! [+=~-]? $end) \s* $QR_COMMENTS }gcxo) { - push @args, $name; - $ARGS->{'require_arg'} = 1; - next; - } - } - if (! defined $name) { - $name = $self->parse_expr($str_ref); - if (! defined $name) { - if ($ARGS->{'require_arg'} && ! @args && ! $ARGS->{'positional_only'} && ! @named) { - $self->throw('parse', 'Argument required', undef, pos($$str_ref)); - } else { - last; - } - } - } - - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - - ### see if it is named or positional - if ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo) { - $self->throw('parse', 'Named arguments not allowed', undef, $mark) if $ARGS->{'positional_only'}; - my $val = $self->parse_expr($str_ref); - $name = $name->[0] if ref($name) && @$name == 2 && ! $name->[1]; # strip a level of indirection on named arguments - push @named, $name, $val; - } else { - push @args, $name; - } - - ### look for trailing comma - $ARGS->{'require_arg'} = ($$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo) || 0; - } - - ### allow for named arguments to be added at the front (if asked) - if ($ARGS->{'named_at_front'}) { - unshift @args, [[undef, '{}', @named], 0]; - } elsif (scalar @named) { # only add at end - if there are some - push @args, [[undef, '{}', @named], 0] - } - - return \@args; -} - -### allow for looking for $foo or ${foo.bar} in TEXT "nodes" of the parse tree. -sub interpolate_node { - my ($self, $tree, $offset) = @_; - return if $self->{'_no_interp'}; - - ### split on variables while keeping the variables - my @pieces = split m{ (?: ^ | (?[-1]; - if ($#pieces <= 0) { - $tree->[-1] =~ s{ \\ ([\"\$]) }{$1}xg; - return; - } - - my @sub_tree; - my $n = 0; - foreach my $piece (@pieces) { - $offset += length $piece; # we track the offset to make sure DEBUG has the right location - $piece =~ s{ \\ ([\"\$]) }{$1}xg; - if (! ($n++ % 2)) { # odds will always be text chunks - next if ! length $piece; - push @sub_tree, $piece; - } elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x - || $piece =~ m{ ^ \$\{ \s* (.*?) (?parse_expr(\$name)]; - } else { - $self->throw('parse', "Parse error during interpolate node"); - } - } - - ### replace the tree - splice @$tree, -1, 1, @sub_tree; -} - -###----------------------------------------------------------------### - -sub execute_tree { - my ($self, $tree, $out_ref) = @_; - - # node contains (0: DIRECTIVE, - # 1: start_index, - # 2: end_index, - # 3: parsed tag details, - # 4: sub tree for block types - # 5: continuation sub trees for sub continuation block types (elsif, else, etc) - # 6: flag to capture next directive - for my $node (@$tree) { - ### text nodes are just the bare text - if (! ref $node) { - $$out_ref .= $node if defined $node; - next; - } - - $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'}; - - $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref); - } -} - -sub play_expr { - ### allow for the parse tree to store literals - return $_[1] if ! ref $_[1]; - - my $self = shift; - my $var = shift; - my $ARGS = shift || {}; - my $i = 0; - - ### determine the top level of this particular variable access - my $ref; - my $name = $var->[$i++]; - my $args = $var->[$i++]; - if (ref $name) { - if (! defined $name->[0]) { # operator - return $self->play_operator($name) if wantarray && $name->[1] eq '..'; - $ref = $self->play_operator($name); - } else { # a named variable access (ie via $name.foo) - $name = $self->play_expr($name); - if (defined $name) { - return if $QR_PRIVATE && $name =~ $QR_PRIVATE; # don't allow vars that begin with _ - return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name}; - $ref = $self->{'_vars'}->{$name}; - } - } - } elsif (defined $name) { - if ($ARGS->{'is_namespace_during_compile'}) { - $ref = $self->{'NAMESPACE'}->{$name}; - } else { - return if $QR_PRIVATE && $name =~ $QR_PRIVATE; # don't allow vars that begin with _ - return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name}; - $ref = $self->{'_vars'}->{$name}; - if (! defined $ref) { - $ref = ($name eq 'template' || $name eq 'component') ? $self->{"_$name"} : $VOBJS->{$name}; - $ref = $SCALAR_OPS->{$name} if ! $ref && (! defined($self->{'VMETHOD_FUNCTIONS'}) || $self->{'VMETHOD_FUNCTIONS'}); - } - } - } - - - my %seen_filters; - while (defined $ref) { - - ### check at each point if the rurned thing was a code - if (UNIVERSAL::isa($ref, 'CODE')) { - return $ref if $i >= $#$var && $ARGS->{'return_ref'}; - my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ()); - if (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - $ref = undef; - last; - } - } - - ### descend one chained level - last if $i >= $#$var; - my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; - $name = $var->[$i++]; - $args = $var->[$i++]; - - ### allow for named portions of a variable name (foo.$name.bar) - if (ref $name) { - if (ref($name) eq 'ARRAY') { - $name = $self->play_expr($name); - if (! defined($name) || ($QR_PRIVATE && $name =~ $QR_PRIVATE) || $name =~ /^\./) { - $ref = undef; - last; - } - } else { - die "Shouldn't get a ". ref($name) ." during a vivify on chain"; - } - } - if ($QR_PRIVATE && $name =~ $QR_PRIVATE) { # don't allow vars that begin with _ - $ref = undef; - last; - } - - ### allow for scalar and filter access (this happens for every non virtual method call) - if (! ref $ref) { - if ($SCALAR_OPS->{$name}) { # normal scalar op - $ref = $SCALAR_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); - - } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op - $ref = $LIST_OPS->{$name}->([$ref], $args ? map { $self->play_expr($_) } @$args : ()); - - } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args - || $FILTER_OPS->{$name} # predefined filters in CET - || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash - || $self->list_filters->{$name}) { # filter defined in Template::Filters - - if (UNIVERSAL::isa($filter, 'CODE')) { - $ref = eval { $filter->($ref) }; # non-dynamic filter - no args - if (my $err = $@) { - $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; - die $err; - } - } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { - $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); - - } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters - eval { - my $sub = $filter->[0]; - if ($filter->[1]) { # it is a "dynamic filter" that will return a sub - ($sub, my $err) = $sub->($self->context, $args ? map { $self->play_expr($_) } @$args : ()); - if (! $sub && $err) { - $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; - die $err; - } elsif (! UNIVERSAL::isa($sub, 'CODE')) { - $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") - if ref($sub) !~ /Template::Exception$/; - die $sub; - } - } - $ref = $sub->($ref); - }; - if (my $err = $@) { - $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; - die $err; - } - } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) - $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; - $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree - $i = 2; - } - if (scalar keys %seen_filters - && $seen_filters{$var->[$i - 5] || ''}) { - $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); - } - } else { - $ref = undef; - } - - } else { - - ### method calls on objects - if ($was_dot_call && UNIVERSAL::can($ref, 'can')) { - return $ref if $i >= $#$var && $ARGS->{'return_ref'}; - my @args = $args ? map { $self->play_expr($_) } @$args : (); - my @results = eval { $ref->$name(@args) }; - if ($@) { - my $class = ref $ref; - die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/; - } elsif (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - next; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - $ref = undef; - last; - } - # didn't find a method by that name - so fail down to hash and array access - } - - ### hash member access - if (UNIVERSAL::isa($ref, 'HASH')) { - if ($was_dot_call && exists($ref->{$name}) ) { - return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->{$name}; - $ref = $ref->{$name}; - } elsif ($HASH_OPS->{$name}) { - $ref = $HASH_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); - } elsif ($ARGS->{'is_namespace_during_compile'}) { - return $var; # abort - can't fold namespace variable - } else { - return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'}; - $ref = undef; - } - - ### array access - } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if ($name =~ m{ ^ -? $QR_NUM $ }ox) { - return \ $ref->[$name] if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->[$name]; - $ref = $ref->[$name]; - } elsif ($LIST_OPS->{$name}) { - $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); - } else { - $ref = undef; - } - } - } - - } # end of while - - ### allow for undefinedness - if (! defined $ref) { - if ($self->{'_debug_undef'}) { - my $chunk = $var->[$i - 2]; - $chunk = $self->play_expr($chunk) if ref($chunk) eq 'ARRAY'; - die "$chunk is undefined\n"; - } else { - $ref = $self->undefined_any($var); - } - } - - return $ref; -} - -sub is_empty_named_args { - my ($self, $hash_ident) = @_; - # [[undef, '{}', 'key1', 'val1', 'key2, 'val2'], 0] - return @{ $hash_ident->[0] } <= 2; -} - -sub set_variable { - my ($self, $var, $val, $ARGS) = @_; - $ARGS ||= {}; - my $i = 0; - - ### allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %]) - $var = [$var, 0] if ! ref $var; - - ### determine the top level of this particular variable access - my $ref = $var->[$i++]; - my $args = $var->[$i++]; - if (ref $ref) { - ### non-named types can't be set - return if ref($ref) ne 'ARRAY' || ! defined $ref->[0]; - - # named access (ie via $name.foo) - $ref = $self->play_expr($ref); - if (defined $ref && (! $QR_PRIVATE || $ref !~ $QR_PRIVATE)) { # don't allow vars that begin with _ - if ($#$var <= $i) { - return $self->{'_vars'}->{$ref} = $val; - } else { - $ref = $self->{'_vars'}->{$ref} ||= {}; - } - } else { - return; - } - } elsif (defined $ref) { - return if $QR_PRIVATE && $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ - if ($#$var <= $i) { - return $self->{'_vars'}->{$ref} = $val; - } else { - $ref = $self->{'_vars'}->{$ref} ||= {}; - } - } - - while (defined $ref) { - - ### check at each point if the returned thing was a code - if (UNIVERSAL::isa($ref, 'CODE')) { - my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ()); - if (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - return; - } - } - - ### descend one chained level - last if $i >= $#$var; - my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; - my $name = $var->[$i++]; - my $args = $var->[$i++]; - - ### allow for named portions of a variable name (foo.$name.bar) - if (ref $name) { - if (ref($name) eq 'ARRAY') { - $name = $self->play_expr($name); - if (! defined($name) || $name =~ /^[_.]/) { - return; - } - } else { - die "Shouldn't get a ".ref($name)." during a vivify on chain"; - } - } - if ($QR_PRIVATE && $name =~ $QR_PRIVATE) { # don't allow vars that begin with _ - return; - } - - ### scalar access - if (! ref $ref) { - return; - - ### method calls on objects - } elsif (UNIVERSAL::can($ref, 'can')) { - my $lvalueish; - my @args = $args ? map { $self->play_expr($_) } @$args : (); - if ($i >= $#$var) { - $lvalueish = 1; - push @args, $val; - } - my @results = eval { $ref->$name(@args) }; - if (! $@) { - if (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - return; - } - return if $lvalueish; - next; - } - my $class = ref $ref; - die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/; - # fall on down to "normal" accessors - } - - ### hash member access - if (UNIVERSAL::isa($ref, 'HASH')) { - if ($#$var <= $i) { - return $ref->{$name} = $val; - } else { - $ref = $ref->{$name} ||= {}; - next; - } - - ### array access - } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if ($name =~ m{ ^ -? $QR_NUM $ }ox) { - if ($#$var <= $i) { - return $ref->[$name] = $val; - } else { - $ref = $ref->[$name] ||= {}; - next; - } - } else { - return; - } - - } - - } - - return; -} - -###----------------------------------------------------------------### - -sub play_operator { - my ($self, $tree) = @_; - ### $tree looks like [undef, '+', 4, 5] - - if ($OP_DISPATCH->{$tree->[1]}) { - local $^W; - if ($OP_ASSIGN->{$tree->[1]}) { - my $val = $OP_DISPATCH->{$tree->[1]}->($self->play_expr($tree->[2]), $self->play_expr($tree->[3])); - $self->set_variable($tree->[2], $val); - return $val; - } else { - return $OP_DISPATCH->{$tree->[1]}->(@$tree == 3 ? $self->play_expr($tree->[2]) : ($self->play_expr($tree->[2]), $self->play_expr($tree->[3]))); - } - } - - my $op = $tree->[1]; - - ### do custom and short-circuitable operators - if ($op eq '=') { - my $val = $self->play_expr($tree->[3]); - $self->set_variable($tree->[2], $val); - return $val; - - } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') { - my $val = $self->play_expr($tree->[2]) || $self->play_expr($tree->[3]); - return defined($val) ? $val : ''; - - } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') { - my $val = $self->play_expr($tree->[2]) && $self->play_expr($tree->[3]); - return defined($val) ? $val : ''; - - } elsif ($op eq '?') { - local $^W; - return $self->play_expr($tree->[2]) ? $self->play_expr($tree->[3]) : $self->play_expr($tree->[4]); - - } elsif ($op eq '~' || $op eq '_') { - local $^W; - my $s = ''; - $s .= $self->play_expr($tree->[$_]) for 2 .. $#$tree; - return $s; - - } elsif ($op eq '[]') { - return [map {$self->play_expr($tree->[$_])} 2 .. $#$tree]; - - } elsif ($op eq '{}') { - local $^W; - my @e; - push @e, $self->play_expr($tree->[$_]) for 2 .. $#$tree; - return {@e}; - - } elsif ($op eq '++') { - local $^W; - my $val = 0 + $self->play_expr($tree->[2]); - $self->set_variable($tree->[2], $val + 1); - return $tree->[3] ? $val : $val + 1; # ->[3] is set to 1 during parsing of postfix ops - - } elsif ($op eq '--') { - local $^W; - my $val = 0 + $self->play_expr($tree->[2]); - $self->set_variable($tree->[2], $val - 1); - return $tree->[3] ? $val : $val - 1; # ->[3] is set to 1 during parsing of postfix ops - - } elsif ($op eq '\\') { - my $var = $tree->[2]; - - my $ref = $self->play_expr($var, {return_ref => 1}); - return $ref if ! ref $ref; - return sub { sub { $$ref } } if ref $ref eq 'SCALAR' || ref $ref eq 'REF'; - - my $self_copy = $self; - eval {require Scalar::Util; Scalar::Util::weaken($self_copy)}; - - my $last = ['temp deref key', $var->[-1] ? [@{ $var->[-1] }] : 0]; - return sub { sub { # return a double sub so that the current play_expr will return a coderef - local $self_copy->{'_vars'}->{'temp deref key'} = $ref; - $last->[-1] = (ref $last->[-1] ? [@{ $last->[-1] }, @_] : [@_]) if @_; - return $self->play_expr($last); - } }; - } elsif ($op eq 'qr') { - return $tree->[3] ? qr{(?$tree->[3]:$tree->[2])} : qr{$tree->[2]}; - } - - $self->throw('operator', "Un-implemented operation $op"); -} - -###----------------------------------------------------------------### +use strict; +use warnings; +use Template::Alloy 1.002; +use base qw(Template::Alloy); +use vars qw($VERSION + $QR_PRIVATE + $WHILE_MAX + $MAX_EVAL_RECURSE + $MAX_MACRO_RECURSE + $STAT_TTL + $EXTRA_COMPILE_EXT + $PERL_COMPILE_EXT + $SCALAR_OPS + $FILTER_OPS + $LIST_OPS + $HASH_OPS + $VOBJS + ); + +$VERSION = '2.14'; + +### install true symbol table aliases that can be localized +*QR_PRIVATE = *Template::Alloy::QR_PRIVATE; +*WHILE_MAX = *Template::Alloy::WHILE_MAX; +*MAX_EVAL_RECURSE = *Template::Alloy::MAX_EVAL_RECURSE; +*MAX_MACRO_RECURSE = *Template::Alloy::MAX_MACRO_RECURSE; +*STAT_TTL = *Template::Alloy::STAT_TTL; +*EXTRA_COMPILE_EXT = *Template::Alloy::EXTRA_COMPILE_EXT; +*PERL_COMPILE_EXT = *Template::Alloy::PERL_COMPILE_EXT; +*SCALAR_OPS = *Template::Alloy::SCALAR_OPS; +*FILTER_OPS = *Template::Alloy::FILTER_OPS; +*LIST_OPS = *Template::Alloy::LIST_OPS; +*HASH_OPS = *Template::Alloy::HASH_OPS; +*VOBJS = *Template::Alloy::VOBJS; -sub parse_BLOCK { - my ($self, $str_ref, $node) = @_; +1; - my $end = $self->{'_end_tag'} || '(?!)'; - my $block_name = $self->parse_expr($str_ref, {auto_quote => " - ($QR_FILENAME # file name - | $QR_BLOCK # or block - (?= [+=~-]? $end # an end tag - | \\s*[+,;] # followed by explicit + , or ; - | \\s+ (?! [\\s=]) # or space not before an = - ) \\s* $QR_COMMENTS"}); +__END__ - return '' if ! defined $block_name; +=head1 SYNOPSIS - my $prepend = join "/", map {$_->[3]} grep {ref($_) && $_->[0] eq 'BLOCK'} @{ $self->{'_state'} || {} }; - return $prepend ? "$prepend/$block_name" : $block_name; -} +=head2 Template::Toolkit style usage -sub play_BLOCK { - my ($self, $block_name, $node, $out_ref) = @_; + my $t = Template::Alloy->new( + INCLUDE_PATH => ['/path/to/templates'], + ); - ### store a named reference - but do nothing until something processes it - $self->{'BLOCKS'}->{$block_name} = { - _tree => $node->[4], - name => $self->{'_component'}->{'name'} .'/'. $block_name, + my $swap = { + key1 => 'val1', + key2 => 'val2', + code => sub { 42 }, + hash => {a => 'b'}, }; - return; -} - -sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) } - -sub play_CALL { - my ($self, $ident, $node) = @_; - my $var = $self->play_expr($ident); - $var = $self->undefined_get($ident, $node) if ! defined $var; - return; -} - -sub parse_CASE { - my ($self, $str_ref) = @_; - return if $$str_ref =~ m{ \G DEFAULT \s* }gcx; - return $self->parse_expr($str_ref); -} - -sub parse_CATCH { - my ($self, $str_ref) = @_; - return $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"}); -} - -sub play_control { - my ($self, $undef, $node) = @_; - $self->throw(lc($node->[0]), 'Control exception', $node); -} - -sub play_CLEAR { - my ($self, $undef, $node, $out_ref) = @_; - $$out_ref = ''; - return; -} - -sub parse_CONFIG { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::parse_CONFIG; -} - -sub play_CONFIG { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_CONFIG; -} - -sub parse_DEBUG { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::parse_DEBUG; -} - -sub play_DEBUG { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_DEBUG; -} - -sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) } - -sub play_DEFAULT { - my ($self, $set) = @_; - foreach (@$set) { - my ($op, $set, $default) = @$_; - next if ! defined $set; - my $val = $self->play_expr($set); - if (! $val) { - $default = defined($default) ? $self->play_expr($default) : ''; - $self->set_variable($set, $default); - } - } - return; -} - -sub parse_DUMP { - my ($self, $str_ref) = @_; - return $self->parse_args($str_ref, {named_at_front => 1}); -} - -sub play_DUMP { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_DUMP; -} - -sub parse_FILTER { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::parse_FILTER; -} - -sub play_FILTER { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_FILTER; -} - -sub parse_FOREACH { - my ($self, $str_ref) = @_; - my $items = $self->parse_expr($str_ref); - my $var; - if ($$str_ref =~ m{ \G (= | [Ii][Nn]\b) \s* }gcx) { - $var = [@$items]; - $items = $self->parse_expr($str_ref); - } - return [$var, $items]; -} - -sub play_FOREACH { - my ($self, $ref, $node, $out_ref) = @_; - - ### get the items - make sure it is an arrayref - my ($var, $items) = @$ref; - - $items = $self->play_expr($items); - return '' if ! defined $items; - - if (ref($items) !~ /Iterator$/) { - $items = $self->iterator($items); - } - - my $sub_tree = $node->[4]; - - local $self->{'_vars'}->{'loop'} = $items; - - ### if the FOREACH tag sets a var - then nothing but the loop var gets localized - if (defined $var) { - my ($item, $error) = $items->get_first; - while (! $error) { - - $self->set_variable($var, $item); - - ### execute the sub tree - eval { $self->execute_tree($sub_tree, $out_ref) }; - if (my $err = $@) { - if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) { - if ($err->type eq 'next') { - ($item, $error) = $items->get_next; - next; - } - last if $err->type =~ /last|break/; - } - die $err; - } - - ($item, $error) = $items->get_next; - } - die $error if $error && $error != 3; # Template::Constants::STATUS_DONE; - ### if the FOREACH tag doesn't set a var - then everything gets localized - } else { - - ### localize variable access for the foreach - my $swap = $self->{'_vars'}; - local $self->{'_vars'} = my $copy = {%$swap}; - - ### iterate use the iterator object - #foreach (my $i = $items->index; $i <= $#$vals; $items->index(++ $i)) { - my ($item, $error) = $items->get_first; - while (! $error) { - - if (ref($item) eq 'HASH') { - @$copy{keys %$item} = values %$item; - } - - ### execute the sub tree - eval { $self->execute_tree($sub_tree, $out_ref) }; - if (my $err = $@) { - if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) { - if ($err->type eq 'next') { - ($item, $error) = $items->get_next; - next; - } - last if $err->type =~ /last|break/; - } - die $err; - } - - ($item, $error) = $items->get_next; - } - die $error if $error && $error != 3; # Template::Constants::STATUS_DONE; - } - - return; -} - -sub parse_GET { - my ($self, $str_ref) = @_; - my $ref = $self->parse_expr($str_ref); - $self->throw('parse', "Missing variable name", undef, pos($$str_ref)) if ! defined $ref; - return $ref; -} - -sub play_GET { - my ($self, $ident, $node, $out_ref) = @_; - my $var = $self->play_expr($ident); - if (defined $var) { - $$out_ref .= $var; - } else { - $var = $self->undefined_get($ident, $node); - $$out_ref .= $var if defined $var; - } - return; -} - -sub parse_IF { - my ($self, $str_ref) = @_; - return $self->parse_expr($str_ref); -} - -sub play_IF { - my ($self, $var, $node, $out_ref) = @_; - - my $val = $self->play_expr($var); - if ($val) { - my $body_ref = $node->[4] ||= []; - $self->execute_tree($body_ref, $out_ref); - return; - } - - while ($node = $node->[5]) { # ELSE, ELSIF's - if ($node->[0] eq 'ELSE') { - my $body_ref = $node->[4] ||= []; - $self->execute_tree($body_ref, $out_ref); - return; - } - my $var = $node->[3]; - my $val = $self->play_expr($var); - if ($val) { - my $body_ref = $node->[4] ||= []; - $self->execute_tree($body_ref, $out_ref); - return; - } - } - return; -} - -sub parse_INCLUDE { $DIRECTIVES->{'PROCESS'}->[0]->(@_) } - -sub play_INCLUDE { - my ($self, $str_ref, $node, $out_ref) = @_; - - ### localize the swap - my $swap = $self->{'_vars'} || {}; - local $self->{'_vars'} = {%$swap}; - - ### localize the blocks - my $blocks = $self->{'BLOCKS'} || {}; - local $self->{'BLOCKS'} = {%$blocks}; - - return $DIRECTIVES->{'PROCESS'}->[1]->($self, $str_ref, $node, $out_ref); -} - -sub parse_INSERT { $DIRECTIVES->{'PROCESS'}->[0]->(@_) } - -sub play_INSERT { - my ($self, $args, $node, $out_ref) = @_; - if ($self->{'NO_INCLUDES'}) { - $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive"); - } - - my ($named, @files) = @$args; - - foreach my $name (@files) { - my $filename = $self->play_expr($name); - $$out_ref .= $self->_insert($filename); - } - - return; -} - -sub parse_LOOP { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::parse_LOOP; -} - -sub play_LOOP { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_LOOP; -} - -sub parse_MACRO { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::parse_MACRO; -} - -sub play_MACRO { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_MACRO; -} - -sub parse_META { - my ($self, $str_ref) = @_; - my $args = $self->parse_args($str_ref, {named_at_front => 1}); - my $hash; - return $hash if ($hash = $self->play_expr($args->[0])) && UNIVERSAL::isa($hash, 'HASH'); - return undef; -} - - -sub play_META { - my ($self, $hash) = @_; - return if ! $hash; - my @keys = keys %$hash; - - my $ref; - if ($self->{'_top_level'}) { - $ref = $self->{'_template'} ||= {}; - } else { - $ref = $self->{'_component'} ||= {}; - } - - @{ $ref }{ @keys } = @{ $hash }{ @keys }; - return; -} - -sub play_PERL { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_PERL; -} - -sub parse_PROCESS { - my ($self, $str_ref) = @_; - - return $self->parse_args($str_ref, { - named_at_front => 1, - allow_bare_filenames => 1, - require_arg => 1, - }); -} - -sub play_PROCESS { - my ($self, $info, $node, $out_ref) = @_; - if ($self->{'NO_INCLUDES'}) { - $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive"); - } - - my ($args, @files) = @$info; - - ### set passed args - # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0] - $args = $args->[0]; - foreach (my $i = 2; $i < @$args; $i+=2) { - my $key = $args->[$i]; - my $val = $self->play_expr($args->[$i+1]); - if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever - foreach my $key (keys %$val) { - $self->set_variable([$key,0], $val->{$key}); - } - next; - } - $self->set_variable($key, $val); - } - - ### iterate on any passed block or filename - foreach my $ref (@files) { - next if ! defined $ref; - my $filename = $self->play_expr($ref); - my $out = ''; # have temp item to allow clear to correctly clear - - ### normal blocks or filenames - if (! ref $filename) { - eval { $self->_process($filename, $self->{'_vars'}, \$out) }; # restart the swap - passing it our current stash - - ### allow for $template which is used in some odd instances - } else { - my $doc; - if ($ref->[0] eq 'template') { - $doc = $filename; - } else { - $doc = $self->play_expr($ref); - if (ref($doc) ne 'HASH' || ! $doc->{'_tree'}) { - $self->throw('process', "Passed item doesn't appear to be a valid document"); - } - } - $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'}; - local $self->{'_process_dollar_template'} = 1; - local $self->{'_component'} = $filename; - return if ! $doc->{'_tree'}; - - ### execute and trim - eval { $self->execute_tree($doc->{'_tree'}, \$out) }; - if ($self->{'TRIM'}) { - $out =~ s{ \s+ $ }{}x; - $out =~ s{ ^ \s+ }{}x; - } - - ### handle exceptions - if (my $err = $@) { - $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; - $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc; - } - - } - - ### append any output - $$out_ref .= $out; - if (my $err = $@) { - die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/; - } - } - - return; -} - -sub play_RAWPERL { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_RAWPERL; -} - -sub parse_SET { - my ($self, $str_ref, $node, $initial_op, $initial_var) = @_; - my @SET; - my $func; - - if ($initial_op) { - if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcx # find a word - && ((pos($$str_ref) -= length($1)) || 1) # always revert - && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing - $node->[6] = 1; # set a flag to keep parsing - my $val = $node->[4] ||= []; # setup storage - return [[$initial_op, $initial_var, $val]]; - } else { # get a normal variable - return [[$initial_op, $initial_var, $self->parse_expr($str_ref)]]; - } - } - - while (1) { - my $set = $self->parse_expr($str_ref); - last if ! defined $set; - - if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? \s* }gcx) { - my $op = $1; - if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcx # find a word - && ((pos($$str_ref) -= length($1)) || 1) # always revert - && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing - $node->[6] = 1; # set a flag to keep parsing - my $val = $node->[4] ||= []; # setup storage - push @SET, [$op, $set, $val]; - last; - } else { # get a normal variable - push @SET, [$op, $set, $self->parse_expr($str_ref)]; - } - } else { - push @SET, ['=', $set, undef]; - } - } - - return \@SET; -} - -sub play_SET { - my ($self, $set, $node) = @_; - foreach (@$set) { - my ($op, $set, $val) = @$_; - if (! defined $val) { # not defined - # do nothing - allow for setting to undef - } elsif ($node->[4] && $val == $node->[4]) { # a captured directive - my $sub_tree = $node->[4]; - $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK'; - $val = ''; - $self->execute_tree($sub_tree, \$val); - } else { # normal var - $val = $self->play_expr($val); - } - - if ($OP_DISPATCH->{$op}) { - local $^W; - $val = $OP_DISPATCH->{$op}->($self->play_expr($set), $val); - } - - $self->set_variable($set, $val); - } - return; -} - -sub parse_SWITCH { $DIRECTIVES->{'GET'}->[0]->(@_) } - -sub play_SWITCH { - my ($self, $var, $node, $out_ref) = @_; - - my $val = $self->play_expr($var); - $val = '' if ! defined $val; - ### $node->[4] is thrown away - - my $default; - while ($node = $node->[5]) { # CASES - my $var = $node->[3]; - if (! defined $var) { - $default = $node->[4]; - next; - } - - my $val2 = $self->play_expr($var); - $val2 = [$val2] if ! UNIVERSAL::isa($val2, 'ARRAY'); - for my $test (@$val2) { # find matching values - next if ! defined $val && defined $test; - next if defined $val && ! defined $test; - if ($val ne $test) { # check string-wise first - then numerical - next if $val !~ m{ ^ -? $QR_NUM $ }ox; - next if $test !~ m{ ^ -? $QR_NUM $ }ox; - next if $val != $test; - } - - my $body_ref = $node->[4] ||= []; - $self->execute_tree($body_ref, $out_ref); - return; - } - } - - if ($default) { - $self->execute_tree($default, $out_ref); - } - - return; -} - -sub parse_TAGS { - my ($self, $str_ref, $node) = @_; - - my ($start, $end); - if ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxs) { - my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref)); - ($start, $end) = @$ref; - - } else { - local $self->{'_operator_precedence'} = 1; # prevent operator matching - $start = $$str_ref =~ m{ \G (?= [\'\"\/]) }gcx - ? $self->parse_expr($str_ref) - : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s+ $QR_COMMENTS"}) - || $self->throw('parse', "Invalid opening tag in TAGS", undef, pos($$str_ref)); - $end = $$str_ref =~ m{ \G (?= [\'\"\/]) }gcx - ? $self->parse_expr($str_ref) - : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s* $QR_COMMENTS"}) - || $self->throw('parse', "Invalid closing tag in TAGS", undef, pos($$str_ref)); - for my $tag ($start, $end) { - $tag = $self->play_expr($tag); - $tag = quotemeta($tag) if ! ref $tag; - } - } - return [$start, $end]; -} - -sub parse_THROW { - my ($self, $str_ref, $node) = @_; - my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"}); - $self->throw('parse.missing', "Missing name in THROW", $node, pos($$str_ref)) if ! $name; - my $args = $self->parse_args($str_ref, {named_at_front => 1}); - return [$name, $args]; -} - -sub play_THROW { - my ($self, $ref, $node) = @_; - my ($name, $args) = @$ref; - - $name = $self->play_expr($name); - - my ($named, @args) = @$args; - push @args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some - - @args = map { $self->play_expr($_) } @args; - $self->throw($name, \@args, $node); # dies - return; # but return just in case -} - -sub play_TRY { - my ($self, $foo, $node, $out_ref) = @_; - my $out = ''; - - my $body_ref = $node->[4]; - eval { $self->execute_tree($body_ref, \$out) }; - my $err = $@; - - if (! $node->[5]) { # no catch or final - if (! $err) { # no final block and no error - $$out_ref .= $out; - return; - } - $self->throw('parse.missing', "Missing CATCH block", $node); - } - if ($err) { - $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; - if ($err->type =~ /stop|return/) { - $$out_ref .= $out; - die $err; - } - } - - ### loop through the nested catch and final blocks - my $catch_body_ref; - my $last_found; - my $type = $err ? $err->type : ''; - my $final; - while ($node = $node->[5]) { # CATCH - if ($node->[0] eq 'FINAL') { - $final = $node->[4]; - next; - } - next if ! $err; - my $name = $self->play_expr($node->[3]); - $name = '' if ! defined $name || lc($name) eq 'default'; - if ($type =~ / ^ \Q$name\E \b /x - && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins - $catch_body_ref = $node->[4] || []; - $last_found = $name; - } - } - - ### play the best catch block - if ($err) { - if (! $catch_body_ref) { - $$out_ref .= $out; - die $err; - } - local $self->{'_vars'}->{'error'} = $err; - local $self->{'_vars'}->{'e'} = $err; - eval { $self->execute_tree($catch_body_ref, \$out) }; - if (my $err = $@) { - $$out_ref .= $out; - die $err; - } - } - - ### the final block - $self->execute_tree($final, \$out) if $final; - - $$out_ref .= $out; - - return; -} - -sub parse_UNLESS { - my $ref = $DIRECTIVES->{'IF'}->[0]->(@_); - return [[undef, '!', $ref], 0]; -} - -sub play_UNLESS { return $DIRECTIVES->{'IF'}->[1]->(@_) } - -sub parse_USE { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::parse_USE; -} - -sub play_USE { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_USE; -} - -sub parse_VIEW { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::parse_VIEW; -} - -sub play_VIEW { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::play_VIEW; -} - -sub parse_WHILE { $DIRECTIVES->{'IF'}->[0]->(@_) } - -sub play_WHILE { - my ($self, $var, $node, $out_ref) = @_; - return if ! defined $var; - - my $sub_tree = $node->[4]; - - ### iterate use the iterator object - my $count = $WHILE_MAX; - while (--$count > 0) { - - $self->play_expr($var) || last; - - ### execute the sub tree - eval { $self->execute_tree($sub_tree, $out_ref) }; - if (my $err = $@) { - if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) { - next if $err->type =~ /next/; - last if $err->type =~ /last|break/; - } - die $err; - } - } - die "WHILE loop terminated (> $WHILE_MAX iterations)\n" if ! $count; - - return; -} - -sub parse_WRAPPER { $DIRECTIVES->{'PROCESS'}->[0]->(@_) } - -sub play_WRAPPER { - my ($self, $args, $node, $out_ref) = @_; - my $sub_tree = $node->[4] || return; - - my ($named, @files) = @$args; + # print to STDOUT + $t->process('my/template.tt', $swap) + || die $t->error; + # process into a variable my $out = ''; - $self->execute_tree($sub_tree, \$out); - - foreach my $name (reverse @files) { - local $self->{'_vars'}->{'content'} = $out; - $out = ''; - $DIRECTIVES->{'INCLUDE'}->[1]->($self, [$named, $name], $node, \$out); - } - - $$out_ref .= $out; - return; -} - -###----------------------------------------------------------------### - -sub _vars { - my $self = shift; - $self->{'_vars'} = shift if $#_ == 0; - return $self->{'_vars'} ||= {}; -} - -sub include_filename { - my ($self, $file) = @_; - if ($file =~ m|^/|) { - $self->throw('file', "$file absolute paths are not allowed (set ABSOLUTE option)") if ! $self->{'ABSOLUTE'}; - return $file if -e $file; - } elsif ($file =~ m{(^|/)\.\./}) { - $self->throw('file', "$file relative paths are not allowed (set RELATIVE option)") if ! $self->{'RELATIVE'}; - return $file if -e $file; - } - - my $paths = $self->{'INCLUDE_PATHS'} ||= do { - # TT does this everytime a file is looked up - we are going to do it just in time - the first time - my $paths = $self->{'INCLUDE_PATH'} || []; - $paths = $paths->() if UNIVERSAL::isa($paths, 'CODE'); - $paths = $self->split_paths($paths) if ! UNIVERSAL::isa($paths, 'ARRAY'); - $paths; # return of the do - }; - foreach my $path (@$paths) { - return "$path/$file" if -e "$path/$file"; - } - - $self->throw('file', "$file: not found"); -} - -sub split_paths { - my ($self, $path) = @_; - return $path if ref $path; - my $delim = $self->{'DELIMITER'} || ':'; - $delim = ($delim eq ':' && $^O eq 'MSWin32') ? qr|:(?!/)| : qr|\Q$delim\E|; - return [split $delim, $path]; -} - -sub _insert { - my ($self, $file) = @_; - return $self->slurp($self->include_filename($file)); -} - -sub slurp { - my ($self, $file) = @_; - open(my $fh, '<', $file) || $self->throw('file', "$file couldn't be opened: $!"); - read $fh, my $txt, -s $file; - return $txt; -} - -sub process_simple { - my $self = shift; - my $in = shift || die "Missing input"; - my $swap = shift || die "Missing variable hash"; - my $out = shift || die "Missing output string ref"; - - eval { - delete $self->{'_debug_off'}; - delete $self->{'_debug_format'}; - local $self->{'_start_top_level'} = 1; - $self->_process($in, $swap, $out); - }; - if (my $err = $@) { - if ($err->type !~ /stop|return|next|last|break/) { - $self->{'error'} = $err; - return; - } - } - return 1; -} - -sub process { - my ($self, $in, $swap, $out, @ARGS) = @_; - delete $self->{'error'}; - - my $args; - $args = ($#ARGS == 0 && UNIVERSAL::isa($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS; - - ### get the content - my $content; - if (ref $in) { - if (UNIVERSAL::isa($in, 'SCALAR')) { # reference to a string - $content = $in; - } elsif (UNIVERSAL::isa($in, 'CODE')) { - $content = $in->(); - $content = \$content; - } else { # should be a file handle - local $/ = undef; - $content = <$in>; - $content = \$content; - } - } else { - ### should be a filename - $content = $in; - } - - - ### prepare block localization - my $blocks = $self->{'BLOCKS'} ||= {}; - - - ### do the swap - my $output = ''; - eval { - - ### localize the stash - $swap ||= {}; - my $var1 = $self->{'_vars'} ||= {}; - my $var2 = $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {}; - $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing - my $copy = {%$var2, %$var1, %$swap}; - - local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore - local $self->{'_template'}; - - delete $self->{'_debug_off'}; - delete $self->{'_debug_format'}; - - ### handle pre process items that go before every document - my $pre = ''; - if ($self->{'PRE_PROCESS'}) { - $self->_load_template_meta($content); - foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) { - $self->_process($name, $copy, \$pre); - } - } - - ### process the central file now - catching errors to allow for the ERROR config - eval { - ### handle the PROCESS config - which loads another template in place of the real one - if (exists $self->{'PROCESS'}) { - $self->_load_template_meta($content); - foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) { - next if ! length $name; - $self->_process($name, $copy, \$output); - } - - ### handle "normal" content - } else { - local $self->{'_start_top_level'} = 1; - $self->_process($content, $copy, \$output); - } - }; - - ### catch errors with ERROR config - if (my $err = $@) { - $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; - die $err if $err->type =~ /stop|return/; - my $catch = $self->{'ERRORS'} || $self->{'ERROR'} || die $err; - $catch = {default => $catch} if ! ref $catch; - my $type = $err->type; - my $last_found; - my $file; - foreach my $name (keys %$catch) { - my $_name = (! defined $name || lc($name) eq 'default') ? '' : $name; - if ($type =~ / ^ \Q$_name\E \b /x - && (! defined($last_found) || length($last_found) < length($_name))) { # more specific wins - $last_found = $_name; - $file = $catch->{$name}; - } - } - - ### found error handler - try it out - if (defined $file) { - $output = ''; - local $copy->{'error'} = local $copy->{'e'} = $err; - $self->_process($file, $copy, \$output); - } - } - - ### handle wrapper directives - if (exists $self->{'WRAPPER'}) { - $self->_load_template_meta($content); - foreach my $name (reverse @{ $self->split_paths($self->{'WRAPPER'}) }) { - next if ! length $name; - local $copy->{'content'} = $output; - my $out = ''; - $self->_process($name, $copy, \$out); - $output = $out; - } - } - - $output = $pre . $output if length $pre; - - ### handle post process items that go after every document - if ($self->{'POST_PROCESS'}) { - $self->_load_template_meta($content); - foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) { - $self->_process($name, $copy, \$output); - } - } - - }; - if (my $err = $@) { - $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; - if ($err->type !~ /stop|return|next|last|break/) { - $self->{'error'} = $err; - return; - } - } - - - - ### clear blocks as asked (AUTO_RESET) defaults to on - $self->{'BLOCKS'} = $blocks if exists($self->{'AUTO_RESET'}) && ! $self->{'AUTO_RESET'}; - - ### send the content back out - $out ||= $self->{'OUTPUT'}; - if (ref $out) { - if (UNIVERSAL::isa($out, 'CODE')) { - $out->($output); - } elsif (UNIVERSAL::can($out, 'print')) { - $out->print($output); - } elsif (UNIVERSAL::isa($out, 'SCALAR')) { # reference to a string - $$out = $output; - } elsif (UNIVERSAL::isa($out, 'ARRAY')) { - push @$out, $output; - } else { # should be a file handle - print $out $output; - } - } elsif ($out) { # should be a filename - my $file; - if ($out =~ m|^/|) { - if (! $self->{'ABSOLUTE'}) { - $self->{'error'} = $self->throw('file', "ABSOLUTE paths disabled"); - } else { - $file = $out; - } - } elsif ($out =~ m|^\.\.?/|) { - if (! $self->{'RELATIVE'}) { - $self->{'error'} = $self->throw('file', "RELATIVE paths disabled"); - } else { - $file = $out; - } - } else { - if (! $self->{'OUTPUT_PATH'}) { - $self->{'error'} = $self->throw('file', "OUTPUT_PATH not set"); - } else { - $file = $self->{'OUTPUT_PATH'} . '/' . $out; - } - } - if ($file) { - if (open my $fh, '>', $file) { - if (my $bm = $args->{'binmode'}) { - if (+$bm == 1) { binmode $fh } - else { binmode $fh, $bm } - } - print $fh $output; - } else { - $self->{'error'} = $self->throw('file', "$out couldn't be opened for writing: $!"); - } - } - } else { - print $output; - } - - return if $self->{'error'}; - return 1; -} - -sub error { shift->{'error'} } - -sub _load_template_meta { - my $self = shift; - return if $self->{'_template'}; # only do once as need - - eval { - ### load the meta data for the top document - ### this is needed by some of the custom handlers such as PRE_PROCESS and POST_PROCESS - my $content = shift; - my $doc = $self->{'_template'} = $self->load_parsed_tree($content) || {}; - my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META') - ? $doc->{'_tree'}->[0]->[3] : {}; - - $self->{'_template'} = $doc; - @{ $doc }{keys %$meta} = values %$meta; - }; - - return; -} + $t->process('my/template.tt', $swap, \$out); + ### Alloy uses the same syntax and configuration as Template::Toolkit -###----------------------------------------------------------------### -sub exception { - my $self = shift; - my $type = shift; - my $info = shift; - return $type if ref($type) =~ /Template::Exception$/; - if (ref($info) eq 'ARRAY') { - my $hash = ref($info->[-1]) eq 'HASH' ? pop(@$info) : {}; - if (@$info >= 2 || scalar keys %$hash) { - my $i = 0; - $hash->{$_} = $info->[$_] for 0 .. $#$info; - $hash->{'args'} = $info; - $info = $hash; - } elsif (@$info == 1) { - $info = $info->[0]; - } else { - $info = $type; - $type = 'undef'; - } - } - return $PACKAGE_EXCEPTION->new($type, $info, @_); -} +=head2 HTML::Template::Expr style usage -sub throw { die shift->exception(@_) } + my $t = Template::Alloy->new( + filename => 'my/template.ht', + path => ['/path/to/templates'], + ); -sub context { - my $self = shift; - require CGI::Ex::Template::Extra; - return CGI::Ex::Template::Context->new({_template => $self}); -} - -sub iterator { - my $self = shift; - $PACKAGE_ITERATOR->new(@_); -} - -sub undefined_get { - my ($self, $ident, $node) = @_; - return $self->{'UNDEFINED_GET'}->($self, $ident, $node) if $self->{'UNDEFINED_GET'}; - return ''; -} - -sub undefined_any { - my ($self, $ident) = @_; - return $self->{'UNDEFINED_ANY'}->($self, $ident) if $self->{'UNDEFINED_ANY'}; - return; -} - -sub list_filters { - my $self = shift; - return $self->{'_filters'} ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {}; -} - -sub list_plugins { - require CGI::Ex::Template::Extra; - &CGI::Ex::Template::Extra::list_plugins; -} - -sub debug_node { - my ($self, $node) = @_; - my $info = $self->node_info($node); - my $format = $self->{'_debug_format'} || $self->{'DEBUG_FORMAT'} || "\n## \$file line \$line : [% \$text %] ##\n"; - $format =~ s{\$(file|line|text)}{$info->{$1}}g; - return $format; -} - -sub node_info { - my ($self, $node) = @_; - my $doc = $self->{'_component'}; - my $i = $node->[1]; - my $j = $node->[2] || return ''; # META can be 0 - $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s }; - my $s = substr(${ $doc->{'_content'} }, $i, $j - $i); - $s =~ s/^\s+//; - $s =~ s/\s+$//; - return { - file => $doc->{'name'}, - line => $self->get_line_number_by_index($doc, $i), - text => $s, + my $swap = { + key1 => 'val1', + key2 => 'val2', + code => sub { 42 }, + hash => {a => 'b'}, }; -} - -sub get_line_number_by_index { - my ($self, $doc, $index, $include_char) = @_; - return 1 if $index <= 0; - - ### get the line offsets for the doc - my $lines = $doc->{'_line_offsets'} ||= do { - $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s }; - my $i = 0; - my @lines = (0); - while (1) { - $i = index(${ $doc->{'_content'} }, "\n", $i) + 1; - last if $i == 0; - push @lines, $i; - } - \@lines; - }; - - ### binary search them (this is fast even on big docs) - my ($i, $j) = (0, $#$lines); - if ($index > $lines->[-1]) { - $i = $j; - } else { - while (1) { - last if abs($i - $j) <= 1; - my $k = int(($i + $j) / 2); - $j = $k if $lines->[$k] >= $index; - $i = $k if $lines->[$k] <= $index; - } - } - return $include_char ? ($i + 1, $index - $lines->[$i]) : $i + 1; -} - -###----------------------------------------------------------------### -### long virtual methods or filters -### many of these vmethods have used code from Template/Stash.pm to -### assure conformance with the TT spec. - -sub define_syntax { - my ($self, $name, $sub) = @_; - $SYNTAX->{$name} = $sub; - return 1; -} - -sub define_operator { - my ($self, $args) = @_; - push @$OPERATORS, [@{ $args }{qw(type precedence symbols play_sub)}]; - _build_ops(); - return 1; -} -sub define_directive { - my ($self, $name, $args) = @_; - $DIRECTIVES->{$name} = [@{ $args }{qw(parse_sub play_sub is_block is_postop continues no_interp)}]; - return 1; -} + $t->param($swap); -sub define_vmethod { - my ($self, $type, $name, $sub) = @_; - if ( $type =~ /scalar|item|text/i) { $SCALAR_OPS->{$name} = $sub } - elsif ($type =~ /array|list/i ) { $LIST_OPS->{ $name} = $sub } - elsif ($type =~ /hash/i ) { $HASH_OPS->{ $name} = $sub } - elsif ($type =~ /filter/i ) { $FILTER_OPS->{$name} = $sub } - else { die "Invalid type vmethod type $type" } - return 1; -} + # print to STDOUT (errors die) + $t->output(print_to => \*STDOUT); -sub vmethod_fmt_scalar { - my $str = shift; $str = '' if ! defined $str; - my $pat = shift; $pat = '%s' if ! defined $pat; - local $^W; - return @_ ? sprintf($pat, $_[0], $str) - : sprintf($pat, $str); -} + # process into a variable + my $out = $t->output; -sub vmethod_fmt_list { - my $ref = shift || return ''; - my $pat = shift; $pat = '%s' if ! defined $pat; - my $sep = shift; $sep = ' ' if ! defined $sep; - local $^W; - return @_ ? join($sep, map {sprintf $pat, $_[0], $_} @$ref) - : join($sep, map {sprintf $pat, $_} @$ref); -} + ### Alloy can also use the same syntax and configuration as HTML::Template -sub vmethod_fmt_hash { - my $ref = shift || return ''; - my $pat = shift; $pat = "%s\t%s" if ! defined $pat; - my $sep = shift; $sep = "\n" if ! defined $sep; - local $^W; - return ! @_ ? join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref) - : @_ == 1 ? join($sep, map {sprintf $pat, $_[0], $_, $ref->{$_}} sort keys %$ref) # don't get to pick - it applies to the key - : join($sep, map {sprintf $pat, $_[0], $_, $_[1], $ref->{$_}} sort keys %$ref); -} +=head2 Text::Tmpl style usage -sub vmethod_chunk { - my $str = shift; - my $size = shift || 1; - my @list; - if ($size < 0) { # chunk from the opposite end - $str = reverse $str; - $size = -$size; - unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg; - } else { - push(@list, $1) while $str =~ /( .{$size} | .+ )/xg; - } - return \@list; -} + my $t = Template::Alloy->new; -sub vmethod_indent { - my $str = shift; $str = '' if ! defined $str; - my $pre = shift; $pre = 4 if ! defined $pre; - $pre = ' ' x $pre if $pre =~ /^\d+$/; - $str =~ s/^/$pre/mg; - return $str; -} - -sub vmethod_format { - my $str = shift; $str = '' if ! defined $str; - my $pat = shift; $pat = '%s' if ! defined $pat; - if (@_) { - return join "\n", map{ sprintf $pat, $_[0], $_ } split(/\n/, $str); - } else { - return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str); - } -} - -sub vmethod_list_hash { - my ($hash, $what) = @_; - $what = 'pairs' if ! $what || $what !~ /^(keys|values|each|pairs)$/; - return $HASH_OPS->{$what}->($hash); -} - - -sub vmethod_match { - my ($str, $pat, $global) = @_; - return [] if ! defined $str || ! defined $pat; - my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/); - return @res ? \@res : ''; -} - -sub vmethod_nsort { - my ($list, $field) = @_; - return defined($field) - ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field} - : UNIVERSAL::can($_, $field) ? $_->$field() - : $_)]} @$list ] - : [sort {$a <=> $b} @$list]; -} - -sub vmethod_pick { - my $ref = shift; - no warnings; - my $n = int(shift); - $n = 1 if $n < 1; - my @ind = map { $ref->[ rand @$ref ] } 1 .. $n; - return $n == 1 ? $ind[0] : \@ind; -} - -sub vmethod_repeat { - my ($str, $n, $join) = @_; - return '' if ! defined $str || ! length $str; - $n = 1 if ! defined($n) || ! length $n; - $join = '' if ! defined $join; - return join $join, ($str) x $n; -} - -### This method is a combination of my submissions along -### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum -sub vmethod_replace { - my ($text, $pattern, $replace, $global) = @_; - $text = '' unless defined $text; - $pattern = '' unless defined $pattern; - $replace = '' unless defined $replace; - $global = 1 unless defined $global; - my $expand = sub { - my ($chunk, $start, $end) = @_; - $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{ - $1 ? $1 - : ($2 > $#$start || $2 == 0) ? '' - : substr($text, $start->[$2], $end->[$2] - $start->[$2]); - }exg; - $chunk; + my $swap = { + key1 => 'val1', + key2 => 'val2', + code => sub { 42 }, + hash => {a => 'b'}, }; - if ($global) { - $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg; - } else { - $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e; - } - return $text; -} - -sub vmethod_sort { - my ($list, $field) = @_; - return defined($field) - ? [map {$_->[0]} 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 ]; # case insensitive -} -sub vmethod_splice { - my ($ref, $i, $len, @replace) = @_; - @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY'; - if (defined $len) { - return [splice @$ref, $i || 0, $len, @replace]; - } elsif (defined $i) { - return [splice @$ref, $i]; - } else { - return [splice @$ref]; - } -} + $t->set_delimiters('#[', ']#'); + $t->set_strip(0); + $t->set_values($swap); + $t->set_dir('/path/to/templates'); -sub vmethod_split { - my ($str, $pat, $lim) = @_; - $str = '' if ! defined $str; - if (defined $lim) { return defined $pat ? [split $pat, $str, $lim] : [split ' ', $str, $lim] } - else { return defined $pat ? [split $pat, $str ] : [split ' ', $str ] } -} + my $out = $t->parse_file('my/template.tmpl'); -sub vmethod_substr { - my ($str, $i, $len, $replace) = @_; - $i ||= 0; - return substr($str, $i) if ! defined $len; - return substr($str, $i, $len) if ! defined $replace; - substr($str, $i, $len, $replace); - return $str; -} + my $str = "Foo #[echo $key1]# Bar"; + my $out = $t->parse_string($str); -sub vmethod_uri { - my $str = shift; - utf8::encode($str) if defined &utf8::encode; - $str =~ s/([^A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg; - return $str; -} -sub vmethod_url { - my $str = shift; - utf8::encode($str) if defined &utf8::encode; - $str =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg; - return $str; -} + ### Alloy uses the same syntax and configuration as Text::Tmpl -sub filter_eval { - my $context = shift; - my $syntax = shift; +=head2 Velocity (VTL) style usage - return sub { - ### prevent recursion - my $t = $context->_template; - local $t->{'_eval_recurse'} = $t->{'_eval_recurse'} || 0; - $context->throw('eval_recurse', "MAX_EVAL_RECURSE $MAX_EVAL_RECURSE reached") - if ++$t->{'_eval_recurse'} > ($t->{'MAX_EVAL_RECURSE'} || $MAX_EVAL_RECURSE); + my $t = Template::Alloy->new; - - my $text = shift; - local $t->{'SYNTAX'} = $syntax || $t->{'SYNTAX'}; - return $context->process(\$text); + my $swap = { + key1 => 'val1', + key2 => 'val2', + code => sub { 42 }, + hash => {a => 'b'}, }; -} - -sub filter_redirect { - my ($context, $file, $options) = @_; - my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set'); - $context->throw('redirect', 'Invalid filename - cannot include "/../"') - if $file =~ m{(^|/)\.\./}; - - return sub { - my $text = shift; - if (! -d $path) { - require File::Path; - File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!"); - } - open (my $fh, '>', "$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!"); - if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) { - if (+$bm == 1) { binmode $fh } - else { binmode $fh, $bm} - } - print $fh $text; - return ''; - }; -} - -###----------------------------------------------------------------### -sub dump_parse { - my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new; - my $str = shift; - require Data::Dumper; - return Data::Dumper::Dumper($obj->parse_tree(\$str)); -} + my $out = $t->merge('my/template.vtl', $swap); -sub dump_parse_expr { - my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new; - my $str = shift; - require Data::Dumper; - return Data::Dumper::Dumper($obj->parse_expr(\$str)); -} + my $str = "#set($foo 1 + 3) ($foo) ($bar) ($!baz)"; + my $out = $t->merge(\$str, $swap); -###----------------------------------------------------------------### -### support for few HTML::Template and HTML::Template::Expr calling syntax +=head1 DESCRIPTION -sub register_function { - my ($name, $sub) = @_; - $SCALAR_OPS->{$name} = $sub; -} +CGI::Ex::Template is the original base for the code that is now +Template::Alloy. Template::Alloy employed enough complexity and +featureset to warrant moving it out to a separate namespace. -sub param { - require CGI::Ex::Template::HTE; - &CGI::Ex::Template::HTE::param; -} +CGI::Ex::Template is now a place holder subclass of Template::Alloy. +You can use CGI::Ex::Template as a standalone module - but it is +suggested that you use Template::Alloy directly instead. -sub output { - require CGI::Ex::Template::HTE; - &CGI::Ex::Template::HTE::output; -} +For examples of usage, configuration, syntax, bugs, vmethods, +directives, etc please refer to the L documentation. -sub clear_param { shift->{'param'} = {} } +=head1 AUTHOR -sub query { shift->throw('query', "Not implemented in CGI::Ex::Template") } +Paul Seamons -sub new_file { my $class = shift; my $in = shift; $class->new(source => $in, type => 'filename', @_) } -sub new_scalar_ref { my $class = shift; my $in = shift; $class->new(source => $in, type => 'scalarref', @_) } -sub new_array_ref { my $class = shift; my $in = shift; $class->new(source => $in, type => 'arrayref', @_) } -sub new_filehandle { my $class = shift; my $in = shift; $class->new(source => $in, type => 'filehandle', @_) } +=head1 LICENSE -###----------------------------------------------------------------### - -package CGI::Ex::Template::Exception; - -use overload - '""' => \&as_string, - bool => sub { defined shift }, - fallback => 1; - -sub new { - my ($class, $type, $info, $node, $pos, $doc) = @_; - return bless [$type, $info, $node, $pos, $doc], $class; -} - -sub type { shift->[0] } - -sub info { shift->[1] } - -sub node { - my $self = shift; - $self->[2] = shift if @_; - $self->[2]; -} - -sub offset { - my $self = shift; - $self->[3] = shift if @_; - $self->[3]; -} - -sub doc { - my $self = shift; - $self->[4] = shift if @_; - $self->[4]; -} - -sub as_string { - my $self = shift; - if ($self->type =~ /^parse/) { - if (my $doc = $self->doc) { - my ($line, $char) = CGI::Ex::Template->get_line_number_by_index($doc, $self->offset, 'include_char'); - return $self->type ." error - $doc->{'name'} line $line char $char: ". $self->info; - } else { - return $self->type .' error - '. $self->info .' (At char '. $self->offset .')'; - } - } else { - return $self->type .' error - '. $self->info; - } -} - -###----------------------------------------------------------------### - -package CGI::Ex::Template::Iterator; - -sub new { - my ($class, $items) = @_; - $items = [] if ! defined $items; - if (UNIVERSAL::isa($items, 'HASH')) { - $items = [ map { {key => $_, value => $items->{ $_ }} } sort keys %$items ]; - } elsif (UNIVERSAL::can($items, 'as_list')) { - $items = $items->as_list; - } elsif (! UNIVERSAL::isa($items, 'ARRAY')) { - $items = [$items]; - } - return bless [$items, 0], $class; -} - -sub get_first { - my $self = shift; - return (undef, 3) if ! @{ $self->[0] }; - return ($self->[0]->[$self->[1] = 0], undef); -} - -sub get_next { - my $self = shift; - return (undef, 3) if ++ $self->[1] > $#{ $self->[0] }; - return ($self->items->[$self->[1]], undef); -} - -sub items { shift->[0] } - -sub index { shift->[1] } - -sub max { $#{ shift->[0] } } - -sub size { shift->max + 1 } - -sub count { shift->index + 1 } - -sub number { shift->index + 1 } - -sub first { (shift->index == 0) || 0 } - -sub last { my $self = shift; return ($self->index == $self->max) || 0 } - -sub prev { - my $self = shift; - return undef if $self->index <= 0; - return $self->items->[$self->index - 1]; -} - -sub next { - my $self = shift; - return undef if $self->index >= $self->max; - return $self->items->[$self->index + 1]; -} - -###----------------------------------------------------------------### - -1; +This module may be distributed under the same terms as Perl itself. -### See the perldoc in CGI/Ex/Template.pod +=cut diff --git a/lib/CGI/Ex/Validate.pm b/lib/CGI/Ex/Validate.pm index f226df8..f97d425 100644 --- a/lib/CGI/Ex/Validate.pm +++ b/lib/CGI/Ex/Validate.pm @@ -22,7 +22,7 @@ use vars qw($VERSION @UNSUPPORTED_BROWSERS ); -$VERSION = '2.13'; +$VERSION = '2.14'; $DEFAULT_EXT = 'val'; $QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/; diff --git a/samples/benchmark/bench_template.pl b/samples/benchmark/bench_template.pl index 36a4461..17866dd 100644 --- a/samples/benchmark/bench_template.pl +++ b/samples/benchmark/bench_template.pl @@ -46,12 +46,9 @@ my @config2 = (@config1, COMPILE_EXT => '.ttc'); #use CGI::Ex::Template::XS; #my $tt1 = CGI::Ex::Template::XS->new(@config1); -#my $tt2 = CGI::Ex::Template::XS->new(@config2); my $tt1 = Template->new(@config1); -my $tt2 = Template->new(@config2); -my $cet = CGI::Ex::Template->new(@config1); -my $cetc = CGI::Ex::Template->new(@config2); +my $cet = CGI::Ex::Template->new(@config1, compile_perl => 1); #$swap->{$_} = $_ for (1 .. 1000); # swap size affects benchmark speed diff --git a/samples/benchmark/bench_various_templaters.pl b/samples/benchmark/bench_various_templaters.pl index 2ba98e2..e052f91 100644 --- a/samples/benchmark/bench_various_templaters.pl +++ b/samples/benchmark/bench_various_templaters.pl @@ -14,7 +14,9 @@ use Template::Stash; use Template::Stash::XS; use Template::Parser::CET; use Text::Template; +use Text::Tmpl; use HTML::Template; +use HTML::Template::Compiled; use HTML::Template::Expr; use HTML::Template::JIT; use CGI::Ex::Dump qw(debug); @@ -30,13 +32,17 @@ my $names = { CETX => 'CGI::Ex::Template::XS using TT interface', CETH => 'CGI::Ex::Template using HTML::Template interface', CETXH => 'CGI::Ex::Template::XS using HTML::Template interface', + CETXHp => 'CGI::Ex::Template::XS using HTML::Template interface - Perl code eval based', + CETXTMPL => 'CGI::Ex::Temmplate::XS using Text::Tmpl interface', HT => 'HTML::Template', HTE => 'HTML::Template::Expr', HTJ => 'HTML::Template::JIT - Compiled to C template', + HTC => 'HTML::Template::Compiled', TextTemplate => 'Text::Template - Perl code eval based', TT => 'Template::Toolkit', TTX => 'Template::Toolkit with Stash::XS', TTXCET => 'Template::Toolkit with Stash::XS and Template::Parser::CET', + TMPL => 'Text::Tmpl - Engine is C based', mem => 'Compiled in memory', file => 'Loaded from file', @@ -159,6 +165,31 @@ $filler {\$shell_footer} DOC +###----------------------------------------------------------------### +### Tmpl style template + +my $content_tmpl = <<"DOC"; + + +$filler + + +This is some text. + + + + + +$filler + + +DOC + +if (open (my $fh, ">$dir/foo.tmpl")) { + print $fh $content_tmpl; + close $fh; +} + ###----------------------------------------------------------------### ### The TT interface allows for a single object to be cached and reused. @@ -168,6 +199,10 @@ my $ct = CGI::Ex::Template->new( INCLUDE_PATH => \@dirs, VARIABLES => $stash my $ctx = CGI::Ex::Template::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t); ###----------------------------------------------------------------### +my %CETH_DOCUMENTS; +my %CETXH_DOCUMENTS; +my %CETXHp_DOCUMENTS; + my $tests = { @@ -182,27 +217,64 @@ my $tests = { my $tt = Template->new(INCLUDE_PATH => \@dirs, STASH => Template::Stash::XS->new($stash_t), COMPILE_DIR => $dir2); my $out = ""; $tt->process('foo.tt', $form, \$out); $out; }, - CET_file => sub { - my $t = CGI::Ex::Template->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_DIR => $dir2); - my $out = ''; $t->process('foo.tt', $form, \$out); $out; - }, - CETX_file => sub { - my $t = CGI::Ex::Template::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_DIR => $dir2); - my $out = ''; $t->process('foo.tt', $form, \$out); $out; - }, +# CET_file => sub { +# my $t = CGI::Ex::Template->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_DIR => $dir2); +# my $out = ''; $t->process('foo.tt', $form, \$out); $out; +# }, +# CETX_file => sub { +# my $t = CGI::Ex::Template::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_DIR => $dir2); +# my $out = ''; $t->process('foo.tt', $form, \$out); $out; +# }, CETH_file => sub { - my $ht = CGI::Ex::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2); + my $ht = CGI::Ex::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, CASE_SENSITVE=>1); + $ht->{'_documents'} = \%CETH_DOCUMENTS; $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, CETXH_file => sub { - my $ht = CGI::Ex::Template::XS->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2); + my $ht = CGI::Ex::Template::XS->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, + CASE_SENSITVE=>1); + $ht->{'_documents'} = \%CETXH_DOCUMENTS; + $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; + }, + CETXHp_file => sub { + my $ht = CGI::Ex::Template::XS->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, + CASE_SENSITVE=>1, compile_perl => 1, cache => 1); + $ht->{'_documents'} = \%CETXHp_DOCUMENTS; $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, HT_file => sub { - my $ht = HTML::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2); + my $ht = HTML::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, CASE_SENSITVE=>1); + $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; + }, + HTC_file => sub { + my $ht = HTML::Template::Compiled->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, CASE_SENSITVE=>1); $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, + TMPL_file => sub { + my $tt = Text::Tmpl->new; + for my $ref (@{ $stash_ht->{'a_stuff'} }) { + $tt->loop_iteration('a_stuff')->set_values($ref); + } + $tt->set_values($stash_ht); + $tt->set_values($form); + $tt->set_delimiters(''); + $tt->set_dir("$dir/"); + $tt->set_strip(0); + my $out = $tt->parse_file("foo.tmpl"); + }, +# CETXTMPL_file => sub { +# my $tt = CGI::Ex::Template::XS->new; +# for my $ref (@{ $stash_ht->{'a_stuff'} }) { +# $tt->loop_iteration('a_stuff')->set_values($ref); +# } +# $tt->set_values($stash_ht); +# $tt->set_values($form); +# $tt->set_delimiters(''); +# $tt->set_dir("$dir/"); +# $tt->set_strip(0); +# my $out = $tt->parse_file("foo.tmpl"); +# }, ###----------------------------------------------------------------### ### str infers that we are pulling from a string reference @@ -227,58 +299,92 @@ my $tests = { my $t = Template->new(STASH => Template::Stash::XS->new($stash_t), PARSER => Template::Parser::CET->new); my $out = ""; $t->process(\$content_tt, $form, \$out); $out; }, - CET_str => sub { - my $t = CGI::Ex::Template->new(VARIABLES => $stash_t); - my $out = ""; $t->process(\$content_tt, $form, \$out); $out; - }, - CETX_str => sub { - my $t = CGI::Ex::Template::XS->new(VARIABLES => $stash_t); - my $out = ""; $t->process(\$content_tt, $form, \$out); $out; - }, +# CET_str => sub { +# my $t = CGI::Ex::Template->new(VARIABLES => $stash_t); +# my $out = ""; $t->process(\$content_tt, $form, \$out); $out; +# }, +# CETX_str => sub { +# my $t = CGI::Ex::Template::XS->new(VARIABLES => $stash_t); +# my $out = ""; $t->process(\$content_tt, $form, \$out); $out; +# }, CETH_str => sub { - my $ht = CGI::Ex::Template->new( type => 'scalarref', source => \$content_ht); + my $ht = CGI::Ex::Template->new( type => 'scalarref', source => \$content_ht, CASE_SENSITVE=>1); + $ht->{'_documents'} = \%CETH_DOCUMENTS; $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, CETXH_str => sub { - my $ht = CGI::Ex::Template::XS->new(type => 'scalarref', source => \$content_ht); + my $ht = CGI::Ex::Template::XS->new(type => 'scalarref', source => \$content_ht, CASE_SENSITVE=>1); + $ht->{'_documents'} = \%CETXH_DOCUMENTS; + $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; + }, + CETXHp_str => sub { + my $ht = CGI::Ex::Template::XS->new(type => 'scalarref', source => \$content_ht, CASE_SENSITVE=>1, compile_perl => 1, cache => 1); + $ht->{'_documents'} = \%CETXHp_DOCUMENTS; $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, HT_str => sub { - my $ht = HTML::Template->new( type => 'scalarref', source => \$content_ht); + my $ht = HTML::Template->new( type => 'scalarref', source => \$content_ht, CASE_SENSITVE=>1); $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, HTE_str => sub { - my $ht = HTML::Template::Expr->new( type => 'scalarref', source => \$content_ht); + my $ht = HTML::Template::Expr->new( type => 'scalarref', source => \$content_ht, CASE_SENSITVE=>1); + $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; + }, + HTC_str => sub { + my $ht = HTML::Template::Compiled->new(type => 'scalarref', source => \$content_ht, CASE_SENSITVE=>1); $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, + TMPL_str => sub { + my $tt = Text::Tmpl->new; + for my $ref (@{ $stash_ht->{'a_stuff'} }) { + $tt->loop_iteration('a_stuff')->set_values($ref); + } + $tt->set_values($stash_ht); + $tt->set_values($form); + $tt->set_delimiters(''); + $tt->set_dir("$dir/"); + $tt->set_strip(0); + my $out = $tt->parse_string($content_tmpl); + }, ###----------------------------------------------------------------### ### mem indicates that the compiled form is stored in memory TT_mem => sub { my $out = ""; $tt->process( 'foo.tt', $form, \$out); $out }, TTX_mem => sub { my $out = ""; $ttx->process('foo.tt', $form, \$out); $out }, - CET_mem => sub { my $out = ""; $ct->process( 'foo.tt', $form, \$out); $out }, - CETX_mem => sub { my $out = ""; $ctx->process('foo.tt', $form, \$out); $out }, +# CET_mem => sub { my $out = ""; $ct->process( 'foo.tt', $form, \$out); $out }, +# CETX_mem => sub { my $out = ""; $ctx->process('foo.tt', $form, \$out); $out }, CETH_mem => sub { - my $ht = CGI::Ex::Template->new( filename => "foo.ht", path => \@dirs, cache => 1); + my $ht = CGI::Ex::Template->new( filename => "foo.ht", path => \@dirs, cache => 1, CASE_SENSITVE=>1); + $ht->{'_documents'} = \%CETH_DOCUMENTS; $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, CETXH_mem => sub { - my $ht = CGI::Ex::Template::XS->new(filename => "foo.ht", path => \@dirs, cache => 1); + my $ht = CGI::Ex::Template::XS->new(filename => "foo.ht", path => \@dirs, cache => 1, CASE_SENSITVE=>1); + $ht->{'_documents'} = \%CETXH_DOCUMENTS; + $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; + }, + CETXHp_mem => sub { + my $ht = CGI::Ex::Template::XS->new(filename => "foo.ht", path => \@dirs, cache => 1, CASE_SENSITVE=>1, compile_perl => 1, cache => 1); + $ht->{'_documents'} = \%CETXHp_DOCUMENTS; $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, HT_mem => sub { - my $ht = HTML::Template->new( filename => "foo.ht", path => \@dirs, cache => 1); + my $ht = HTML::Template->new( filename => "foo.ht", path => \@dirs, cache => 1, CASE_SENSITVE=>1); + $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; + }, + HTC_mem => sub { + my $ht = HTML::Template::Compiled->new( filename => "foo.ht", path => \@dirs, cache => 1, CASE_SENSITVE=>1); $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, HTE_mem => sub { - my $ht = HTML::Template::Expr->new( filename => "foo.ht", path => \@dirs, cache => 1); + my $ht = HTML::Template::Expr->new( filename => "foo.ht", path => \@dirs, cache => 1, CASE_SENSITVE=>1); $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, HTJ_mem => sub { # this is interesting - it is compiled - but it is pulled into memory just once - my $ht = HTML::Template::JIT->new( filename => "foo.ht", path => \@dirs, jit_path => $dir2); + my $ht = HTML::Template::JIT->new( filename => "foo.ht", path => \@dirs, jit_path => $dir2, CASE_SENSITVE=>1); $ht->param($stash_ht); $ht->param($form); my $out = $ht->output; }, }; @@ -286,6 +392,10 @@ my $tests = { my $test = $tests->{'TT_str'}->(); foreach my $name (sort keys %$tests) { if ($test ne $tests->{$name}->()) { + print "--------------------------TT_str-------\n"; + print $test; + print "--------------------------$name--------\n"; + print $tests->{$name}->(); die "$name did not match TT_str output\n"; } $name =~ /(\w+)_(\w+)/; diff --git a/samples/memory_template.pl b/samples/memory_template.pl index 9c05566..070c505 100644 --- a/samples/memory_template.pl +++ b/samples/memory_template.pl @@ -30,6 +30,10 @@ if (! fork) { $module = 'HTML::Template'; } elsif (! fork) { $module = 'HTML::Template::Expr'; +} elsif (! fork) { + $module = 'HTML::Template::Compiled'; +} elsif (! fork) { + $module = 'Text::Tmpl'; } elsif (! fork) { $module = 'Template'; $name = 'Template::Parser::CET'; @@ -47,7 +51,8 @@ if ($module) { if ($module =~ /HTML::Template/) { my $t = eval { $module->new }; - + } elsif ($module eq 'Text::Tmpl') { + my $t = eval { $module->new->parse_string($txt) }; } else { my $t = $module->new(ABSOLUTE => 1); diff --git a/t/7_template_00_base.t b/t/7_template_00_base.t index aab6d0d..c5ea4ef 100644 --- a/t/7_template_00_base.t +++ b/t/7_template_00_base.t @@ -4,24 +4,27 @@ 7_template_00_base.t - Test the basic language functionality of CGI::Ex::Template - including many edge cases +=head1 DESCRIPTION + +Test the basics of CGI::Ex::Template inheritance - but leave the full test suite to Template::Alloy. + =cut use vars qw($module $is_tt); BEGIN { - $module = 'CGI::Ex::Template'; #real 0m0.885s #user 0m0.432s #sys 0m0.004s -# $module = 'Template'; #real 0m2.133s #user 0m1.108s #sys 0m0.024s + $module = 'CGI::Ex::Template'; + if (grep {/tt/i} @ARGV) { + $module = 'Template'; + } $is_tt = $module eq 'Template'; }; use strict; -use Test::More tests => ! $is_tt ? 894 : 613; +use Test::More tests => ! $is_tt ? 46 : 45; use Data::Dumper qw(Dumper); -use constant test_taint => 0 && eval { require Taint::Runtime }; use_ok($module); -Taint::Runtime::taint_start() if test_taint; - ###----------------------------------------------------------------### sub process_ok { # process the value and say if it was ok @@ -34,8 +37,6 @@ sub process_ok { # process the value and say if it was ok my $line = (caller)[2]; delete $vars->{'tt_config'}; - Taint::Runtime::taint(\$str) if test_taint; - $obj->process(\$str, $vars, \$out); my $ok = ref($test) ? $out =~ $test : $out eq $test; if ($ok) { @@ -50,41 +51,6 @@ sub process_ok { # process the value and say if it was ok } } -###----------------------------------------------------------------### - -### set up some dummy packages for various tests -{ - package MyTestPlugin::Foo; - $INC{'MyTestPlugin/Foo.pm'} = $0; - sub load { $_[0] } - sub new { - my $class = shift; - my $context = shift; # note the plugin style object that needs to shift off context - my $args = shift || {}; - return bless $args, $class; - } - sub bar { my $self = shift; return join('', map {"$_$self->{$_}"} sort keys %$self) } - sub seven { 7 } - sub many { return 1, 2, 3 } - sub echo { my $self = shift; $_[0] } -} -{ - package Foo2; - $INC{'Foo2.pm'} = $0; - use base qw(MyTestPlugin::Foo); - use vars qw($AUTOLOAD); - sub new { - my $class = shift; - my $args = shift || {}; # note - no plugin context - return bless $args, $class; - } - sub leave {} # hacks to allow tt to do the plugins passed via PLUGINS - sub delocalise {} # hacks to allow tt to do the plugins passed via PLUGINS -} - -my $obj = Foo2->new; -my $vars; - ###----------------------------------------------------------------### print "### GET ##############################################################\n"; @@ -106,101 +72,9 @@ process_ok("[% foo.length %]" => 1, {foo => sub { 7 }}); process_ok("[% foo.0 %]" => 7, {foo => sub { return 7, 2, 3 }}); process_ok("[% foo(bar) %]" => 7, {foo => sub { $_[0] }, bar => 7}); process_ok("[% foo(bar.baz) %]" => 7,{foo => sub { $_[0] }, bar => {baz => 7}}); -process_ok("[% foo.seven %]" => 7, {foo => $obj}); -process_ok("[% foo.seven() %]" => 7, {foo => $obj}); -process_ok("[% foo.seven.length %]" => 1, {foo => $obj}); -process_ok("[% foo.echo(7) %]" => 7, {foo => $obj}); -process_ok("[% foo.many.0 %]" => 1, {foo => $obj}); -process_ok("[% foo.many.10 %]" => '',{foo => $obj}); -process_ok("[% foo.nomethod %]" => '',{foo => $obj}); -process_ok("[% foo.nomethod.0 %]" => '',{foo => $obj}); - -process_ok("[% GET foo %]" => ""); -process_ok("[% GET foo %]" => "7", {foo => 7}); -process_ok("[% GET foo.bar %]" => ""); -process_ok("[% GET foo.bar %]" => "", {foo => {}}); -process_ok("[% GET foo.bar %]" => "7", {foo => {bar => 7}}); -process_ok("[% GET foo.0 %]" => "7", {foo => [7, 2, 3]}); -process_ok("[% GET foo %]" => 7, {foo => sub { 7 }}); -process_ok("[% GET foo(7) %]" => 7, {foo => sub { $_[0] }}); - -process_ok("[% \$name %]" => "", {name => 'foo'}); -process_ok("[% \$name %]" => "7", {name => 'foo', foo => 7}); -process_ok("[% \$name.bar %]" => "", {name => 'foo'}); -process_ok("[% \$name.bar %]" => "", {name => 'foo', foo => {}}); -process_ok("[% \$name.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); -process_ok("[% \$name().bar %]" => "7", {name => 'foo', foo => {bar => 7}}); -process_ok("[% \$name.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); -process_ok("[% \$name %]" => 7, {name => 'foo', foo => sub { 7 }}); -process_ok("[% \$name(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); - -process_ok("[% GET \$name %]" => "", {name => 'foo'}); -process_ok("[% GET \$name %]" => "7", {name => 'foo', foo => 7}); -process_ok("[% GET \$name.bar %]" => "", {name => 'foo'}); -process_ok("[% GET \$name.bar %]" => "", {name => 'foo', foo => {}}); -process_ok("[% GET \$name.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); -process_ok("[% GET \$name.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); -process_ok("[% GET \$name %]" => 7, {name => 'foo', foo => sub { 7 }}); -process_ok("[% GET \$name(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); -process_ok("[% \$name %]" => "", {name => 'foo foo', foo => 7}); -process_ok("[% GET \$name %]" => "", {name => 'foo foo', foo => 7}); - -process_ok("[% \${name} %]" => "", {name => 'foo'}); -process_ok("[% \${name} %]" => "7", {name => 'foo', foo => 7}); -process_ok("[% \${name}.bar %]" => "", {name => 'foo'}); -process_ok("[% \${name}.bar %]" => "", {name => 'foo', foo => {}}); -process_ok("[% \${name}.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); -process_ok("[% \${name}().bar %]" => "7", {name => 'foo', foo => {bar => 7}}); -process_ok("[% \${name}.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); -process_ok("[% \${name} %]" => 7, {name => 'foo', foo => sub { 7 }}); -process_ok("[% \${name}(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); - -process_ok("[% GET \${name} %]" => "", {name => 'foo'}); -process_ok("[% GET \${name} %]" => "7", {name => 'foo', foo => 7}); -process_ok("[% GET \${name}.bar %]" => "", {name => 'foo'}); -process_ok("[% GET \${name}.bar %]" => "", {name => 'foo', foo => {}}); -process_ok("[% GET \${name}.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); -process_ok("[% GET \${name}.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); -process_ok("[% GET \${name} %]" => 7, {name => 'foo', foo => sub { 7 }}); -process_ok("[% GET \${name}(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); - -process_ok("[% \${name} %]" => "", {name => 'foo foo', foo => 7}); -process_ok("[% GET \${name} %]" => "", {name => 'foo foo', foo => 7}); -process_ok("[% GET \${'foo'} %]" => 'bar', {foo => 'bar'}); - -process_ok("[% foo.\$name %]" => '', {name => 'bar'}); -process_ok("[% foo.\$name %]" => 7, {name => 'bar', foo => {bar => 7}}); -process_ok("[% foo.\$name.baz %]" => '', {name => 'bar', bar => {baz => 7}}); - -process_ok("[% \"hi\" %]" => 'hi'); -process_ok("[% \"hi %]" => ''); -process_ok("[% 'hi' %]" => 'hi'); -process_ok("[% 'hi %]" => ''); -process_ok("[% \"\$foo\" %]" => '7', {foo => 7}); -process_ok("[% \"hi \$foo\" %]" => 'hi 7', {foo => 7}); -process_ok("[% \"hi \${foo}\" %]" => 'hi 7', {foo => 7}); -process_ok("[% 'hi \$foo' %]" => 'hi $foo', {foo => 7}); -process_ok("[% 'hi \${foo}' %]" => 'hi ${foo}', {foo => 7}); -process_ok("[% 7 %]" => 7); -process_ok("[% -7 %]" => -7); - -process_ok("[% \"hi \${foo.seven}\" %]" => 'hi 7', {foo => $obj}); -process_ok("[% \"hi \${foo.echo(7)}\" %]" => 'hi 7', {foo => $obj}); - -process_ok("[% _foo %]2" => '2', {_foo => 1}); -process_ok("[% \$bar %]2" => '2', {_foo => 1, bar => '_foo'}); -process_ok("[% __foo %]2" => '2', {__foo => 1}); - -process_ok("[% qw/Foo Bar Baz/.0 %]" => 'Foo') if ! $is_tt; -process_ok('[% [0..10].-1 %]' => '10') if ! $is_tt; -process_ok('[% [0..10].${ 2.3 } %]' => '2') if ! $is_tt; - -process_ok("[% (1 + 2)() %]" => ''); # parse error -process_ok("[% (1 + 2) %]" => '3'); -process_ok("[% (a) %]" => '2', {a => 2}); -process_ok("[% ('foo') %]" => 'foo'); -process_ok("[% (a(2)) %]" => '2', {a => sub { $_[0] }}); +# we don't do as many tests here - leave that to Template::Alloy +# See Template::Alloy t/05_tt_base.t ###----------------------------------------------------------------### print "### SET ##############################################################\n"; @@ -215,7 +89,6 @@ process_ok("[% SET foo = 1 %][% SET foo %][% foo %]" => ''); process_ok("[% SET foo = [] %][% foo.0 %]" => ""); process_ok("[% SET foo = [1, 2, 3] %][% foo.1 %]" => 2); process_ok("[% SET foo = {} %][% foo.0 %]" => ""); -process_ok("[% SET foo = {1 => 2} %][% foo.1 %]" => "2") if ! $is_tt; process_ok("[% SET foo = {'1' => 2} %][% foo.1 %]" => "2"); process_ok("[% SET name = 1 %][% SET foo = name %][% foo %]" => "1"); @@ -224,7 +97,6 @@ process_ok("[% SET name = 1 %][% SET foo = \${name} %][% foo %]" => ""); process_ok("[% SET name = 1 %][% SET foo = \"\$name\" %][% foo %]" => "1"); process_ok("[% SET name = 1 foo = name %][% foo %]" => '1'); process_ok("[% SET name = 1 %][% SET foo = {\$name => 2} %][% foo.1 %]" => "2"); -process_ok("[% SET name = 1 %][% SET foo = {\"\$name\" => 2} %][% foo.1 %]" => "2") if ! $is_tt; process_ok("[% SET name = 1 %][% SET foo = {\${name} => 2} %][% foo.1 %]" => "2"); process_ok("[% SET name = 7 %][% SET foo = {'2' => name} %][% foo.2 %]" => "7"); @@ -240,600 +112,12 @@ process_ok("[% SET foo.bar.baz.bing = 1 %][% foo.bar.baz.bing %]" => '1'); process_ok("[% SET foo.bar.2 = 1 %][% foo.bar.2 %] [% foo.bar.size %]" => '1 1'); process_ok("[% SET foo.bar = [] %][% SET foo.bar.2 = 1 %][% foo.bar.2 %] [% foo.bar.size %]" => '1 3'); -process_ok("[% SET name = 'two' %][% SET \$name = 3 %][% two %]" => 3); -process_ok("[% SET name = 'two' %][% SET \${name} = 3 %][% two %]" => 3); -process_ok("[% SET name = 2 %][% SET foo.\$name = 3 %][% foo.2 %]" => 3); -process_ok("[% SET name = 2 %][% SET foo.\$name = 3 %][% foo.\$name %]" => 3); -process_ok("[% SET name = 2 %][% SET foo.\${name} = 3 %][% foo.2 %]" => 3); -process_ok("[% SET name = 2 %][% SET foo.\${name} = 3 %][% foo.2 %]" => 3); -process_ok("[% SET name = 'two' %][% SET \$name.foo = 3 %][% two.foo %]" => 3); -process_ok("[% SET name = 'two' %][% SET \${name}.foo = 3 %][% two.foo %]" => 3); -process_ok("[% SET name = 'two' %][% SET foo.\$name.foo = 3 %][% foo.two.foo %]" => 3); -process_ok("[% SET name = 'two' %][% SET foo.\${name}.foo = 3 %][% foo.two.foo %]" => 3); - -process_ok("[% SET foo = [1..10] %][% foo.6 %]" => 7); -process_ok("[% SET foo = [10..1] %][% foo.6 %]" => ''); -process_ok("[% SET foo = [-10..-1] %][% foo.6 %]" => -4); -process_ok("[% SET foo = [1..10, 21..30] %][% foo.12 %]" => 23) if ! $is_tt; -process_ok("[% SET foo = [..100] bar = 7 %][% bar %][% foo.0 %]" => ''); -process_ok("[% SET foo = [100..] bar = 7 %][% bar %][% foo.0 %]" => ''); -process_ok("[% SET foo = ['a'..'z'] %][% foo.6 %]" => 'g'); -process_ok("[% SET foo = ['z'..'a'] %][% foo.6 %]" => ''); -process_ok("[% SET foo = ['a'..'z'].reverse %][% foo.6 %]" => 't') if ! $is_tt; - -process_ok("[% foo = 1 %][% foo %]" => '1'); -process_ok("[% foo = 1 ; bar = 2 %][% foo %][% bar %]" => '12'); -process_ok("[% foo.bar = 2 %][% foo.bar %]" => '2'); - -process_ok('[% a = "a" %]|[% (b = a) %]|[% a %]|[% b %]' => '|a|a|a'); -process_ok('[% a = "a" %][% (c = (b = a)) %][% a %][% b %][% c %]' => 'aaaa'); - -process_ok("[% a = qw{Foo Bar Baz} ; a.2 %]" => 'Baz') if ! $is_tt; - -process_ok("[% _foo = 1 %][% _foo %]2" => '2'); -process_ok("[% foo._bar %]2" => '2', {foo => {_bar =>1}}); - -###----------------------------------------------------------------### -print "### multiple statements in same tag ##################################\n"; - -process_ok("[% foo; %]" => '1', {foo => 1}); -process_ok("[% GET foo; %]" => '1', {foo => 1}); -process_ok("[% GET foo; GET foo %]" => '11', {foo => 1}); -process_ok("[% GET foo GET foo %]" => '11', {foo => 1}) if ! $is_tt; -process_ok("[% GET foo GET foo %]" => '', {foo => 1, tt_config => [SEMICOLONS => 1]}); - -process_ok("[% foo = 1 bar = 2 %][% foo %][% bar %]" => '12'); -process_ok("[% foo = 1 bar = 2 %][% foo = 3 bar %][% foo %][% bar %]" => '232') if ! $is_tt; -process_ok("[% a = 1 a = a + 2 a %]" => '3') if ! $is_tt; - -process_ok("[% foo = 1 bar = 2 %][% foo %][% bar %]" => '', {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; -process_ok("[% foo = 1 bar = 2 %][% foo = 3 bar %][% foo %][% bar %]" => '', {tt_config => [SEMICOLONS => 1]}); -process_ok("[% a = 1 a = a + 2 a %]" => '', {tt_config => [SEMICOLONS => 1]}); - - -###----------------------------------------------------------------### -print "### CALL / DEFAULT ###################################################\n"; - -process_ok("[% DEFAULT foo = 7 %][% foo %]" => 7); -process_ok("[% SET foo = 5 %][% DEFAULT foo = 7 %][% foo %]" => 5); -process_ok("[% DEFAULT foo.bar.baz.bing = 6 %][% foo.bar.baz.bing %]" => 6); - -my $t = 0; -process_ok("[% foo %]" => 'hi', {foo => sub {$t++; 'hi'}}); -process_ok("[% GET foo %]" => 'hi', {foo => sub {$t++; 'hi'}}); -process_ok("[% CALL foo %]" => '', {foo => sub {$t++; 'hi'}}); -ok($t == 3, "CALL method actually called var"); - -###----------------------------------------------------------------### -print "### scalar vmethods ##################################################\n"; - -process_ok("[% n.0 %]" => '7', {n => 7}) if ! $is_tt; -process_ok("[% n.abs %]" => '7', {n => 7}) if ! $is_tt; -process_ok("[% n.abs %]" => '7', {n => -7}) if ! $is_tt; -process_ok("[% n.atan2.substr(0, 6) %]" => '1.5707', {n => 7}) if ! $is_tt; -process_ok("[% (4 * n.atan2(1)).substr(0, 7) %]" => '3.14159', {n => 1}) if ! $is_tt; -process_ok("[% n.chunk(3).join %]" => 'abc def g', {n => 'abcdefg'}); -process_ok("[% n.chunk(-3).join %]" => 'a bcd efg', {n => 'abcdefg'}); -process_ok("[% n|collapse %]" => "a b", {n => ' a b '}); # TT2 filter -process_ok("[% n.cos.substr(0,5) %]" => "1", {n => 0}) if ! $is_tt; -process_ok("[% n.cos.substr(0,5) %]" => "0.707", {n => atan2(1,1)}) if ! $is_tt; -process_ok("[% n.defined %]" => "1", {n => ''}); -process_ok("[% n.defined %]" => "", {n => undef}); -process_ok("[% n.defined %]" => "1", {n => '1'}); -process_ok("[% n.exp.substr(0,5) %]" => "2.718", {n => 1}) if ! $is_tt; -process_ok("[% n.exp.log.substr(0,5) %]" => "8", {n => 8}) if ! $is_tt; -process_ok("[% n.fmt %]" => '7', {n => 7}) if ! $is_tt; -process_ok("[% n.fmt('%02d') %]" => '07', {n => 7}) if ! $is_tt; -process_ok("[% n.fmt('%0*d', 3) %]" => '007', {n => 7}) if ! $is_tt; -process_ok("[% n.fmt('(%s)') %]" => "(a\nb)", {n => "a\nb"}) if ! $is_tt; -process_ok("[% n|format('%02d') %]" => '07', {n => 7}); # TT2 filter -process_ok("[% n|format('%0*d', 3) %]" => '007', {n => 7}) if ! $is_tt; -process_ok("[% n|format('(%s)') %]" => "(a)\n(b)", {n => "a\nb"}); # TT2 filter -process_ok("[% n.hash.items.1 %]" => "b", {n => {a => "b"}}); -process_ok("[% n.hex %]" => "255", {n => "FF"}) if ! $is_tt; -process_ok("[% n|html %]" => "&", {n => '&'}); # TT2 filter -process_ok("[% n|indent %]" => " a\n b", {n => "a\nb"}); # TT2 filter -process_ok("[% n|indent(2) %]" => " a\n b", {n => "a\nb"}); # TT2 filter -process_ok("[% n|indent('wow ') %]" => "wow a\nwow b", {n => "a\nb"}); # TT2 filter -process_ok("[% n.int %]" => "123", {n => "123.234"}) if ! $is_tt; -process_ok("[% n.int %]" => "123", {n => "123gggg"}) if ! $is_tt; -process_ok("[% n.int %]" => "0", {n => "ff123.234"}) if ! $is_tt; -process_ok("[% n.item %]" => '7', {n => 7}); -process_ok("[% n.lc %]" => 'abc', {n => "ABC"}) if ! $is_tt; -process_ok("[% n|lcfirst %]" => 'fOO', {n => "FOO"}); # TT2 filter -process_ok("[% n.length %]" => 3, {n => "abc"}); -process_ok("[% n.list.0 %]" => 'abc', {n => "abc"}); -process_ok("[% n.log.substr(0,5) %]" => "4.605", {n => 100}) if ! $is_tt; -process_ok("[% n|lower %]" => 'abc', {n => "ABC"}); # TT2 filter -process_ok("[% n.match('foo').join %]" => '', {n => "bar"}); -process_ok("[% n.match('foo').join %]" => '1', {n => "foo"}); -process_ok("[% n.match('foo',1).join %]" => 'foo', {n => "foo"}); -process_ok("[% n.match('(foo)').join %]" => 'foo', {n => "foo"}); -process_ok("[% n.match('(foo)').join %]" => 'foo', {n => "foofoo"}); -process_ok("[% n.match('(foo)',1).join %]" => 'foo foo', {n => "foofoo"}); -process_ok("[% n.null %]" => '', {n => "abc"}); -process_ok("[% n.oct %]" => "255", {n => "377"}) if ! $is_tt; -process_ok("[% n.rand %]" => qr{^\d+\.\d+}, {n => "2"}) if ! $is_tt; -process_ok("[% n.rand %]" => qr{^\d+\.\d+}, {n => "ab"}) if ! $is_tt; -process_ok("[% n.remove('bc') %]" => "a", {n => "abc"}); -process_ok("[% n.remove('bc') %]" => "aa", {n => "abcabc"}); -process_ok("[% n.repeat %]" => '1', {n => 1}) if ! $is_tt; # tt2 virtual method defaults to 0 -process_ok("[% n.repeat(0) %]" => '', {n => 1}); -process_ok("[% n.repeat(1) %]" => '1', {n => 1}); -process_ok("[% n.repeat(2) %]" => '11', {n => 1}); -process_ok("[% n.repeat(2,'|') %]" => '1|1', {n => 1}) if ! $is_tt; -process_ok("[% n.replace('foo', 'bar') %]" => 'barbar', {n => 'foofoo'}); -process_ok("[% n.replace('(foo)', 'bar\$1') %]" => 'barfoobarfoo', {n => 'foofoo'}) if ! $is_tt; -process_ok("[% n.replace('foo', 'bar', 0) %]" => 'barfoo', {n => 'foofoo'}) if ! $is_tt; -process_ok("[% n.search('foo') %]" => '', {n => "bar"}); -process_ok("[% n.search('foo') %]" => '1', {n => "foo"}); -process_ok("[% n.sin.substr(0,5) %]" => "0", {n => 0}) if ! $is_tt; -process_ok("[% n.sin.substr(0,5) %]" => "1", {n => 2*atan2(1,1)}) if ! $is_tt; -process_ok("[% n.size %]" => '1', {n => "foo"}); -process_ok("[% n.split.join('|') %]" => "abc", {n => "abc"}); -process_ok("[% n.split.join('|') %]" => "a|b|c", {n => "a b c"}); -process_ok("[% n.split.join('|') %]" => "a|b|c", {n => "a b c"}); -process_ok("[% n.split(u,2).join('|') %]" => "a|b c", {n => "a b c", u => undef}) if ! $is_tt; -process_ok("[% n.split(u,2).join('|') %]" => "a| b c", {n => "a b c", u => undef}) if $is_tt; -process_ok("[% n.split('/').join('|') %]" => "a|b|c", {n => "a/b/c"}); -process_ok("[% n.split('/', 2).join('|') %]" => "a|b/c", {n => "a/b/c"}); -process_ok("[% n.sprintf(7) %]" => '7', {n => '%d'}) if ! $is_tt; -process_ok("[% n.sprintf(3, 7, 12) %]" => '007 12', {n => '%0*d %d'}) if ! $is_tt; -process_ok("[% n.sqrt %]" => "3", {n => 9}) if ! $is_tt; -process_ok("[% n.srand; 12 %]" => "12", {n => 9}) if ! $is_tt; -process_ok("[% n.stderr %]" => "", {n => "# testing stderr ... ok\r"}); -process_ok("[% n|trim %]" => "a b", {n => ' a b '}); # TT2 filter -process_ok("[% n.uc %]" => 'FOO', {n => "foo"}) if ! $is_tt; # TT2 filter -process_ok("[% n|ucfirst %]" => 'Foo', {n => "foo"}); # TT2 filter -process_ok("[% n|upper %]" => 'FOO', {n => "foo"}); # TT2 filter -process_ok("[% n|uri %]" => 'a%20b', {n => "a b"}); # TT2 filter - -###----------------------------------------------------------------### -print "### list vmethods ####################################################\n"; - -process_ok("[% a.defined %]" => '1', {a => [2,3]}); -process_ok("[% a.defined(1) %]" => '1', {a => [2,3]}); -process_ok("[% a.defined(3) %]" => '', {a => [2,3]}); -process_ok("[% a.first %]" => '2', {a => [2..10]}); -process_ok("[% a.first(3).join %]" => '2 3 4', {a => [2..10]}); -process_ok("[% a.fmt %]" => '2 3', {a => [2,3]}) if ! $is_tt; -process_ok("[% a.fmt('%02d') %]" => '02 03', {a => [2,3]}) if ! $is_tt; -process_ok("[% a.fmt('%02d',' ') %]" => '02 03', {a => [2,3]}) if ! $is_tt; -process_ok("[% a.fmt('%02d','|') %]" => '02|03', {a => [2,3]}) if ! $is_tt; -process_ok("[% a.fmt('%0*d','|', 3) %]" => '002|003', {a => [2,3]}) if ! $is_tt; -process_ok("[% a.grep.join %]" => '2 3', {a => [2,3]}); -process_ok("[% a.grep(2).join %]" => '2', {a => [2,3]}); -process_ok("[% a.hash.items.join %]" => '2 3', {a => [2,3]}); -process_ok("[% a.hash(5).items.sort.join %]" => '2 3 5 6', {a => [2,3]}); -process_ok("[% a.import(5) %]|[% a.join %]" => '|2 3', {a => [2,3]}) if ! $is_tt; -process_ok("[% a.import(5) %]|[% a.join %]" => qr{^ARRAY.+|2 3$ }x, {a => [2,3]}) if $is_tt; -process_ok("[% a.import([5]) %]|[% a.join %]" => '|2 3 5', {a => [2,3]}) if ! $is_tt; -process_ok("[% a.import([5]) %]|[% a.join %]" => qr{ARRAY.+|2 3 5$ }x, {a => [2,3]}) if $is_tt; -process_ok("[% a.item %]" => '2', {a => [2,3]}); -process_ok("[% a.item(1) %]" => '3', {a => [2,3]}); -process_ok("[% a.join %]" => '2 3', {a => [2,3]}); -process_ok("[% a.join('|') %]" => '2|3', {a => [2,3]}); -process_ok("[% a.last %]" => '10', {a => [2..10]}); -process_ok("[% a.last(3).join %]" => '8 9 10', {a => [2..10]}); -process_ok("[% a.list.join %]" => '2 3', {a => [2, 3]}); -process_ok("[% a.max %]" => '1', {a => [2, 3]}); -process_ok("[% a.merge(5).join %]" => '2 3', {a => [2,3]}); -process_ok("[% a.merge([5]).join %]" => '2 3 5', {a => [2,3]}); -process_ok("[% a.merge([5]).null %][% a.join %]" => '2 3', {a => [2,3]}); -process_ok("[% a.nsort.join %]" => '1 2 3', {a => [2, 3, 1]}); -process_ok("[% a.nsort('b').0.b %]" => '7', {a => [{b => 23}, {b => 7}]}); -process_ok("[% a.pop %][% a.join %]" => '32', {a => [2, 3]}); -process_ok("[% a.push(3) %][% a.join %]" => '2 3 3', {a => [2, 3]}); -process_ok("[% a.pick %]" => qr{ ^[23]$ }x, {a => [2, 3]}) if ! $is_tt; -process_ok("[% a.pick(5).join('') %]" => qr{ ^[23]{5}$ }x, {a => [2, 3]}) if ! $is_tt; -process_ok("[% a.reverse.join %]" => '3 2', {a => [2, 3]}); -process_ok("[% a.shift %][% a.join %]" => '23', {a => [2, 3]}); -process_ok("[% a.size %]" => '2', {a => [2, 3]}); -process_ok("[% a.slice.join %]" => '2 3 4 5', {a => [2..5]}); -process_ok("[% a.slice(2).join %]" => '4 5', {a => [2..5]}); -process_ok("[% a.slice(0,2).join %]" => '2 3 4', {a => [2..5]}); -process_ok("[% a.sort.join %]" => '1 2 3', {a => [2, 3, 1]}); -process_ok("[% a.sort('b').0.b %]" => 'wee', {a => [{b => "wow"}, {b => "wee"}]}); -process_ok("[% a.splice.join %]|[% a.join %]" => '2 3 4 5|', {a => [2..5]}); -process_ok("[% a.splice(2).join %]|[% a.join %]" => '4 5|2 3', {a => [2..5]}); -process_ok("[% a.splice(0,2).join %]|[% a.join %]" => '2 3|4 5', {a => [2..5]}); -process_ok("[% a.splice(0,2,'hrm').join %]|[% a.join %]" => '2 3|hrm 4 5', {a => [2..5]}); -process_ok("[% a.unique.join %]" => '2 3', {a => [2,3,3,3,2]}); -process_ok("[% a.unshift(3) %][% a.join %]" => '3 2 3', {a => [2, 3]}); - -###----------------------------------------------------------------### -print "### hash vmethods ####################################################\n"; - -process_ok("[% h.defined %]" => "1", {h => {}}); -process_ok("[% h.defined('a') %]" => "1", {h => {a => 1}}); -process_ok("[% h.defined('b') %]" => "", {h => {a => 1}}); -process_ok("[% h.defined('a') %]" => "", {h => {a => undef}}); -process_ok("[% h.delete('a') %]|[% h.keys.0 %]" => "|b", {h => {a => 1, b=> 2}}); -process_ok("[% h.delete('a', 'b').join %]|[% h.keys.0 %]" => "|", {h => {a => 1, b=> 2}}); -process_ok("[% h.delete('a', 'c').join %]|[% h.keys.0 %]" => "|b", {h => {a => 1, b=> 2}}); -process_ok("[% h.each.sort.join %]" => "1 2 a b", {h => {a => 1, b=> 2}}); -process_ok("[% h.exists('a') %]" => "1", {h => {a => 1}}); -process_ok("[% h.exists('b') %]" => "", {h => {a => 1}}); -process_ok("[% h.exists('a') %]" => "1", {h => {a => undef}}); -process_ok("[% h.fmt %]" => "b\tB\nc\tC", {h => {b => "B", c => "C"}}) if ! $is_tt; -process_ok("[% h.fmt('%s => %s') %]" => "b => B\nc => C", {h => {b => "B", c => "C"}}) if ! $is_tt; -process_ok("[% h.fmt('%s => %s', '|') %]" => "b => B|c => C", {h => {b => "B", c => "C"}}) if ! $is_tt; -process_ok("[% h.fmt('%*s=>%s', '|', 3) %]" => " b=>B| c=>C", {h => {b => "B", c => "C"}}) if ! $is_tt; -process_ok("[% h.fmt('%*s=>%*s', '|', 3, 4) %]" => " b=> B| c=> C", {h => {b => "B", c => "C"}}) if ! $is_tt; -process_ok("[% h.hash.fmt %]" => "b\tB\nc\tC", {h => {b => "B", c => "C"}}) if ! $is_tt; -process_ok("[% h.import('a') %]|[% h.items.sort.join %]" => "|b B c C", {h => {b => "B", c => "C"}}); -process_ok("[% h.import({'b' => 'boo'}) %]|[% h.items.sort.join %]" => "|b boo c C", {h => {b => "B", c => "C"}}); -process_ok("[% h.item('a') %]" => 'A', {h => {a => 'A'}}); -process_ok("[% h.item('_a') %]" => '', {h => {_a => 'A'}}) if ! $is_tt; -process_ok("[% h.items.sort.join %]" => "1 2 a b", {h => {a => 1, b=> 2}}); -process_ok("[% h.keys.sort.join %]" => "a b", {h => {a => 1, b=> 2}}); -process_ok("[% h.list('each').sort.join %]" => "1 2 a b", {h => {a => 1, b=> 2}}); -process_ok("[% h.list('keys').sort.join %]" => "a b", {h => {a => 1, b=> 2}}); -process_ok("[% h.list('pairs').0.items.sort.join %]" => "1 a key value", {h => {a => 1, b=> 2}}); -process_ok("[% h.list('values').sort.join %]" => "1 2", {h => {a => 1, b=> 2}}); -process_ok("[% h.null %]" => "", {h => {}}); -process_ok("[% h.nsort.join %]" => "b a", {h => {a => 7, b => 2}}); -process_ok("[% h.pairs.0.items.sort.join %]" => "1 a key value", {h => {a => 1, b=> 2}}); -process_ok("[% h.size %]" => "2", {h => {a => 1, b=> 2}}); -process_ok("[% h.sort.join %]" => "b a", {h => {a => "BBB", b => "A"}}); -process_ok("[% h.values.sort.join %]" => "1 2", {h => {a => 1, b=> 2}}); - -###----------------------------------------------------------------### -print "### vmethods as functions ############################################\n"; - -process_ok("[% sprintf('%d %d', 7, 8) %] d" => '7 8 d') if ! $is_tt; -process_ok("[% sprintf('%d %d', 7, 8) %] d" => '7 8 d', {tt_config => [VMETHOD_FUNCTIONS => 1]}) if ! $is_tt; -process_ok("[% sprintf('%d %d', 7, 8) %] d" => ' d', {tt_config => [VMETHOD_FUNCTIONS => 0]}) if ! $is_tt; -process_ok("[% int(2.234) %]" => '2') if ! $is_tt; - -process_ok("[% int(2.234) ; int = 44; int(2.234) ; SET int; int(2.234) %]" => '2442') if ! $is_tt; # hide and unhide - -###----------------------------------------------------------------### -print "### more virtual methods / filters ###################################\n"; - -process_ok("[% [0 .. 10].reverse.1 %]" => 9) if ! $is_tt; -process_ok("[% {a => 'A'}.a %]" => 'A') if ! $is_tt; -process_ok("[% 'This is a string'.length %]" => 16) if ! $is_tt; -process_ok("[% 123.length %]" => 3) if ! $is_tt; -process_ok("[% 123.2.length %]" => 5) if ! $is_tt; -process_ok("[% -123.2.length %]" => -5) if ! $is_tt; # the - doesn't bind as tight as the dot methods -process_ok("[% (-123.2).length %]" => 6) if ! $is_tt; -process_ok("[% a = 23; a.0 %]" => 23) if ! $is_tt; # '0' is a scalar_op -process_ok('[% 1.rand %]' => qr/^0\.\d+(?:e-?\d+)?$/) if ! $is_tt; - -process_ok("[% n.size %]", => 'SIZE', {n => {size => 'SIZE', a => 'A'}}); -process_ok("[% n|size %]", => '2', {n => {size => 'SIZE', a => 'A'}}) if ! $is_tt; # tt2 | is alias for FILTER - -process_ok('[% foo | eval %]' => 'baz', {foo => '[% bar %]', bar => 'baz'}); -process_ok('[% "1" | indent(2) %]' => ' 1'); - - -process_ok("[% n FILTER size %]", => '1', {n => {size => 'SIZE', a => 'A'}}) if ! $is_tt; # tt2 doesn't have size - -process_ok("[% n FILTER repeat %]" => '1', {n => 1}); -process_ok("[% n FILTER repeat(0) %]" => '', {n => 1}); -process_ok("[% n FILTER repeat(1) %]" => '1', {n => 1}); -process_ok("[% n FILTER repeat(2) %]" => '11', {n => 1}); -process_ok("[% n FILTER repeat(2,'|') %]" => '1|1', {n => 1}) if ! $is_tt; - -process_ok("[% n FILTER echo = repeat(2) %][% n FILTER echo %]" => '1111', {n => 1}); -process_ok("[% n FILTER echo = repeat(2) %][% n | echo %]" => '1111', {n => 1}); -process_ok("[% n FILTER echo = repeat(2) %][% n|echo.length %]" => '112', {n => 1}) if ! $is_tt; -process_ok("[% n FILTER echo = repeat(2) %][% n FILTER \$foo %]" => '1111', {n => 1, foo => 'echo'}); -process_ok("[% n FILTER echo = repeat(2) %][% n | \$foo %]" => '1111', {n => 1, foo => 'echo'}); -process_ok("[% n FILTER echo = repeat(2) %][% n|\$foo.length %]" => '112', {n => 1, foo => 'echo'}) if ! $is_tt; - -process_ok('[% "hi" FILTER $foo %]' => 'hihi', {foo => sub {sub {$_[0]x2}}}); # filter via a passed var -process_ok('[% FILTER $foo %]hi[% END %]' => 'hihi', {foo => sub {sub {$_[0]x2}}}); # filter via a passed var -process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => sub {$_[0]x2}}]}); -process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {$_[0]x2},0]}]}); -process_ok('[% "hi" FILTER foo(2) %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {my$a=$_[1];sub{$_[0]x$a}},1]}]}); - -process_ok('[% ["a".."z"].pick %]' => qr/^[a-z]/) if ! $is_tt; - -process_ok("[% ' ' | uri %]" => '%20'); - -process_ok('[% "one".fmt %]' => "one") if ! $is_tt; -process_ok('[% 2.fmt("%02d") %]' => "02") if ! $is_tt; - -process_ok('[% [1..3].fmt %]' => "1 2 3") if ! $is_tt; -process_ok('[% [1..3].fmt("%02d") %]' => '01 02 03') if ! $is_tt; -process_ok('[% [1..3].fmt("%s", ", ") %]' => '1, 2, 3') if ! $is_tt; - -process_ok('[% {a => "B", c => "D"}.fmt %]' => "a\tB\nc\tD") if ! $is_tt; -process_ok('[% {a => "B", c => "D"}.fmt("%s:%s") %]' => "a:B\nc:D") if ! $is_tt; -process_ok('[% {a => "B", c => "D"}.fmt("%s:%s", "; ") %]' => "a:B; c:D") if ! $is_tt; - -process_ok('[% 1|format("%s") %]' => '1') if ! $is_tt; -process_ok('[% 1|format("%*s", 6) %]' => ' 1') if ! $is_tt; -process_ok('[% 1|format("%-*s", 6) %]' => '1 ') if ! $is_tt; - -process_ok('[% 1.fmt("%-*s", 6) %]' => '1 ') if ! $is_tt; -process_ok('[% [1,2].fmt("%-*s", "|", 6) %]' => '1 |2 ') if ! $is_tt; -process_ok('[% {1=>2,3=>4}.fmt("%*s:%*s", "|", 3, 3) %]' => ' 1: 2| 3: 4') if ! $is_tt; - -###----------------------------------------------------------------### -print "### virtual objects ##################################################\n"; - -process_ok('[% a = "foobar" %][% Text.length(a) %]' => 6) if ! $is_tt; -process_ok('[% a = [1 .. 10] %][% List.size(a) %]' => 10) if ! $is_tt; -process_ok('[% a = {a=>"A", b=>"B"} ; Hash.size(a) %]' => 2) if ! $is_tt; - -process_ok('[% a = Text.new("This is a string") %][% a.length %]' => 16) if ! $is_tt; -process_ok('[% a = List.new("one", "two", "three") %][% a.size %]' => 3) if ! $is_tt; -process_ok('[% a = Hash.new("one", "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; -process_ok('[% a = Hash.new(one = "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; -process_ok('[% a = Hash.new(one => "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; - -process_ok('[% {a => 1, b => 2} | Hash.keys | List.join(", ") %]' => 'a, b') if ! $is_tt; - -###----------------------------------------------------------------### -print "### chomping #########################################################\n"; - -process_ok(" [% foo %]" => ' '); -process_ok(" [%- foo %]" => ''); -process_ok("\n[%- foo %]" => ''); -process_ok("\n [%- foo %]" => ''); -process_ok("\n\n[%- foo %]" => "\n"); -process_ok(" \n\n[%- foo %]" => " \n"); -process_ok(" \n[%- foo %]" => " ") if ! $is_tt; -process_ok(" \n \n[%- foo %]" => " \n ") if ! $is_tt; - -process_ok("[% 7 %] " => '7 '); -process_ok("[% 7 -%] " => '7 '); -process_ok("[% 7 -%]\n" => '7'); -process_ok("[% 7 -%] \n" => '7'); -process_ok("[% 7 -%]\n " => '7 '); -process_ok("[% 7 -%]\n\n\n" => "7\n\n"); -process_ok("[% 7 -%] \n " => '7 '); - -###----------------------------------------------------------------### -print "### string operators #################################################\n"; - -process_ok('[% a = "foo"; a _ "bar" %]' => 'foobar'); -process_ok('[% a = "foo"; a ~ "bar" %]' => 'foobar') if ! $is_tt; -process_ok('[% a = "foo"; a ~= "bar"; a %]' => 'foobar') if ! $is_tt; -process_ok('[% "b" gt "c" %]<<<' => '<<<') if ! $is_tt; -process_ok('[% "b" gt "a" %]<<<' => '1<<<') if ! $is_tt; -process_ok('[% "b" ge "c" %]<<<' => '<<<') if ! $is_tt; -process_ok('[% "b" ge "b" %]<<<' => '1<<<') if ! $is_tt; -process_ok('[% "b" lt "c" %]<<<' => '1<<<') if ! $is_tt; -process_ok('[% "b" lt "a" %]<<<' => '<<<') if ! $is_tt; -process_ok('[% "b" le "a" %]<<<' => '<<<') if ! $is_tt; -process_ok('[% "b" le "b" %]<<<' => '1<<<') if ! $is_tt; -process_ok('[% "a" cmp "b" %]<<<' => '-1<<<') if ! $is_tt; -process_ok('[% "b" cmp "b" %]<<<' => '0<<<') if ! $is_tt; -process_ok('[% "c" cmp "b" %]<<<' => '1<<<') if ! $is_tt; - -###----------------------------------------------------------------### -print "### math operators ###################################################\n"; - -process_ok("[% 1 + 2 %]" => 3); -process_ok("[% 1 + 2 + 3 %]" => 6); -process_ok("[% (1 + 2) %]" => 3); -process_ok("[% 2 - 1 %]" => 1); -process_ok("[% -1 + 2 %]" => 1); -process_ok("[% -1+2 %]" => 1); -process_ok("[% 2 - 1 %]" => 1); -process_ok("[% 2-1 %]" => 1) if ! $is_tt; -process_ok("[% 2 - -1 %]" => 3); -process_ok("[% 4 * 2 %]" => 8); -process_ok("[% 4 / 2 %]" => 2); -process_ok("[% 10 / 3 %]" => qr/^3.333/); -process_ok("[% 10 div 3 %]" => '3'); -process_ok("[% 2 ** 3 %]" => 8) if ! $is_tt; -process_ok("[% 1 + 2 * 3 %]" => 7); -process_ok("[% 3 * 2 + 1 %]" => 7); -process_ok("[% (1 + 2) * 3 %]" => 9); -process_ok("[% 3 * (1 + 2) %]" => 9); -process_ok("[% 1 + 2 ** 3 %]" => 9) if ! $is_tt; -process_ok("[% 2 * 2 ** 3 %]" => 16) if ! $is_tt; -process_ok("[% SET foo = 1 %][% foo + 2 %]" => 3); -process_ok("[% SET foo = 1 %][% (foo + 2) %]" => 3); - -process_ok("[% a = 1; (a += 2) %]" => 3) if ! $is_tt; -process_ok("[% a = 1; (a -= 2) %]" => -1) if ! $is_tt; -process_ok("[% a = 4; (a /= 2) %]" => 2) if ! $is_tt; -process_ok("[% a = 1; (a *= 2) %]" => 2) if ! $is_tt; -process_ok("[% a = 3; (a **= 2) %]" => 9) if ! $is_tt; -process_ok("[% a = 1; (a %= 2) %]" => 1) if ! $is_tt; - -process_ok('[% a += 1 %]-[% a %]-[% a += 1 %]-[% a %]' => '-1--2') if ! $is_tt; -process_ok('[% (a += 1) %]-[% (a += 1) %]' => '1-2') if ! $is_tt; - -process_ok('[% a = 2; a -= 3; a %]' => '-1') if ! $is_tt; -process_ok('[% a = 2; a *= 3; a %]' => '6') if ! $is_tt; -process_ok('[% a = 2; a /= .5; a %]' => '4') if ! $is_tt; -process_ok('[% a = 8; a %= 3; a %]' => '2') if ! $is_tt; -process_ok('[% a = 2; a **= 3; a %]' => '8') if ! $is_tt; - -process_ok('[% a = 1 %][% ++a %][% a %]' => '22') if ! $is_tt; -process_ok('[% a = 1 %][% a++ %][% a %]' => '12') if ! $is_tt; -process_ok('[% a = 1 %][% --a %][% a %]' => '00') if ! $is_tt; -process_ok('[% a = 1 %][% a-- %][% a %]' => '10') if ! $is_tt; -process_ok('[% a++ FOR [1..3] %]' => '012') if ! $is_tt; -process_ok('[% --a FOR [1..3] %]' => '-1-2-3') if ! $is_tt; - -process_ok('[% 2 > 3 %]<<<' => '<<<'); -process_ok('[% 2 > 1 %]<<<' => '1<<<'); -process_ok('[% 2 >= 3 %]<<<' => '<<<'); -process_ok('[% 2 >= 2 %]<<<' => '1<<<'); -process_ok('[% 2 < 3 %]<<<' => '1<<<'); -process_ok('[% 2 < 1 %]<<<' => '<<<'); -process_ok('[% 2 <= 1 %]<<<' => '<<<'); -process_ok('[% 2 <= 2 %]<<<' => '1<<<'); -process_ok('[% 1 <=> 2 %]<<<' => '-1<<<') if ! $is_tt; -process_ok('[% 2 <=> 2 %]<<<' => '0<<<') if ! $is_tt; -process_ok('[% 3 <=> 2 %]<<<' => '1<<<') if ! $is_tt; - -###----------------------------------------------------------------### -print "### boolean operators ################################################\n"; - -process_ok("[% 5 && 6 %]" => 6); -process_ok("[% 5 || 6 %]" => 5); -process_ok("[% 0 || 6 %]" => 6); -process_ok("[% 0 && 6 %]" => 0); -process_ok("[% 0 && 0 %]" => 0); -process_ok("[% 5 && 6 && 7%]" => 7); -process_ok("[% 0 || 1 || 2 %]" => 1); - -process_ok("[% 5 + (0 || 5) %]" => 10); - - -process_ok("[% 1 ? 2 : 3 %]" => '2'); -process_ok("[% 0 ? 2 : 3 %]" => '3'); -process_ok("[% 0 ? (1 ? 2 : 3) : 4 %]" => '4'); -process_ok("[% 0 ? 1 ? 2 : 3 : 4 %]" => '4'); - -process_ok("[% t = 1 || 0 ? 3 : 4 %][% t %]" => 3); -process_ok("[% t = 0 or 1 ? 3 : 4 %][% t %]" => 3); -process_ok("[% t = 1 or 0 ? 3 : 4 %][% t %]" => 1) if ! $is_tt; - -process_ok("[% 0 ? 2 : 3 %]" => '3'); -process_ok("[% 1 ? 2 : 3 %]" => '2'); -process_ok("[% 0 ? 1 ? 2 : 3 : 4 %]" => '4'); -process_ok("[% t = 0 ? 1 ? [1..4] : [2..4] : [3..4] %][% t.0 %]" => '3'); -process_ok("[% t = 1 || 0 ? 0 : 1 || 2 ? 2 : 3 %][% t %]" => '0'); -process_ok("[% t = 0 or 0 ? 0 : 1 or 2 ? 2 : 3 %][% t %]" => '1') if ! $is_tt; -process_ok("[% t = 0 or 0 ? 0 : 0 or 2 ? 2 : 3 %][% t %]" => '2'); - -process_ok("[% 0 ? 1 ? 1 + 2 * 3 : 1 + 2 * 4 : 1 + 2 * 5 %]" => '11'); - -###----------------------------------------------------------------### -print "### regex ############################################################\n"; - -process_ok("[% /foo/ %]" => '(?-xism:foo)') if ! $is_tt; -process_ok("[% /foo %]" => '') if ! $is_tt; -process_ok("[% /foo/x %]" => '(?-xism:(?x:foo))') if ! $is_tt; -process_ok("[% /foo/xi %]" => '(?-xism:(?xi:foo))') if ! $is_tt; -process_ok("[% /foo/xis %]" => '(?-xism:(?xis:foo))') if ! $is_tt; -process_ok("[% /foo/xism %]" => '(?-xism:(?xism:foo))') if ! $is_tt; -process_ok("[% /foo/e %]" => '') if ! $is_tt; -process_ok("[% /foo/g %]" => '') if ! $is_tt; -process_ok("[% /foo %]" => '') if ! $is_tt; -process_ok("[% /foo**/ %]" => '') if ! $is_tt; -process_ok("[% /fo\\/o/ %]" => '(?-xism:fo/o)') if ! $is_tt; -process_ok("[% 'foobar'.match(/(f\\w\\w)/).0 %]" => 'foo') if ! $is_tt; - -###----------------------------------------------------------------### -print "### BLOCK / PROCESS / INCLUDE#########################################\n"; - -process_ok("[% PROCESS foo %]one" => ''); -process_ok("[% BLOCK foo %]one" => ''); -process_ok("[% BLOCK foo %][% END %]one" => 'one'); -process_ok("[% BLOCK %][% END %]one" => 'one'); -process_ok("[% BLOCK foo %]hi there[% END %]one" => 'one'); -process_ok("[% BLOCK foo %][% BLOCK foo %][% END %][% END %]" => ''); -process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo %]" => 'hi there'); -process_ok("[% PROCESS foo %][% BLOCK foo %]hi there[% END %]" => 'hi there'); -process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo foo %]" => 'hi therehi there') if ! $is_tt; -process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo, foo %]" => 'hi therehi there') if ! $is_tt; -process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo + foo %]" => 'hi therehi there'); -process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo %]" => 'hi ONE there', {one => 'ONE'}); -process_ok("[% BLOCK foo %]hi [% IF 1 %]Yes[% END %] there[% END %]<<[% PROCESS foo %]>>" => '<>'); -process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo one = 'two' %]" => 'hi two there'); -process_ok("[% BLOCK foo %]hi [% one.two %] there[% END %][% PROCESS foo one.two = 'two' %]" => 'hi two there'); -process_ok("[% BLOCK foo %]hi [% one.two %] there[% END %][% PROCESS foo + foo one.two = 'two' %]" => 'hi two there'x2); -process_ok("[% BLOCK foo %][% BLOCK bar %]hi [% one %] there[% END %][% END %][% PROCESS foo/bar one => 'two' %]" => 'hi two there'); - -process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo one = 'two' %][% one %]" => 'hi two theretwo'); -process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% INCLUDE foo one = 'two' %][% one %]" => 'hi two there'); - -###----------------------------------------------------------------### -print "### IF / UNLESS / ELSIF / ELSE #######################################\n"; - -process_ok("[% IF 1 %]Yes[% END %]" => 'Yes'); -process_ok("[% IF 0 %]Yes[% END %]" => ''); -process_ok("[% IF 0 %]Yes[% ELSE %]No[% END %]" => 'No'); -process_ok("[% IF 0 %]Yes[% ELSIF 1 %]No[% END %]" => 'No'); -process_ok("[% IF 0 %]Yes[% ELSIF 0 %]No[% END %]" => ''); -process_ok("[% IF 0 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm'); - -process_ok("[% UNLESS 1 %]Yes[% END %]" => ''); -process_ok("[% UNLESS 0 %]Yes[% END %]" => 'Yes'); -process_ok("[% UNLESS 0 %]Yes[% ELSE %]No[% END %]" => 'Yes'); -process_ok("[% UNLESS 1 %]Yes[% ELSIF 1 %]No[% END %]" => 'No'); -process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% END %]" => ''); -process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm'); - -###----------------------------------------------------------------### -print "### comments #########################################################\n"; - -process_ok("[%# one %]" => '', {one => 'ONE'}); -process_ok("[%#\n one %]" => '', {one => 'ONE'}); -process_ok("[%-#\n one %]" => '', {one => 'ONE'}) if ! $is_tt; -process_ok("[% #\n one %]" => 'ONE', {one => 'ONE'}); -process_ok("[%# BLOCK one %]" => ''); -process_ok("[%# BLOCK one %]two" => 'two'); -process_ok("[%# BLOCK one %]two[% END %]" => ''); -process_ok("[%# BLOCK one %]two[% END %]three" => ''); -process_ok("[% -# --%] -foo" => "foo"); - -###----------------------------------------------------------------### -print "### FOREACH / NEXT / LAST ############################################\n"; - -process_ok("[% FOREACH foo %]" => ''); -process_ok("[% FOREACH foo %][% END %]" => ''); -process_ok("[% FOREACH foo %]bar[% END %]" => ''); -process_ok("[% FOREACH foo %]bar[% END %]" => 'bar', {foo => 1}); -process_ok("[% FOREACH f IN foo %]bar[% f %][% END %]" => 'bar1bar2', {foo => [1,2]}); -process_ok("[% FOREACH f = foo %]bar[% f %][% END %]" => 'bar1bar2', {foo => [1,2]}); -process_ok("[% FOREACH f = [1,2] %]bar[% f %][% END %]" => 'bar1bar2'); -process_ok("[% FOREACH f = [1..3] %]bar[% f %][% END %]" => 'bar1bar2bar3'); -process_ok("[% FOREACH f = [{a=>'A'},{a=>'B'}] %]bar[% f.a %][% END %]" => 'barAbarB'); -process_ok("[% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %]" => 'barAbarB'); -process_ok("[% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %][% a %]" => 'barAbarB'); -process_ok("[% FOREACH f = [1..3] %][% loop.count %]/[% loop.size %] [% END %]" => '1/3 2/3 3/3 '); -process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% f %][% END %][% END %]" => '1'); -process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% f %][% END %][% END %]" => '3'); -process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% NEXT %][% END %][% f %][% END %]" => '23'); -process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% LAST %][% END %][% f %][% END %]" => ''); -process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% NEXT %][% END %][% END %]" => '123'); -process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% LAST %][% END %][% END %]" => '1'); - -process_ok('[% a = ["Red", "Blue"] ; FOR [0..3] ; a.${ loop.index % a.size } ; END %]' => 'RedBlueRedBlue') if ! $is_tt; - -### TT is not consistent in what is localized - well it is documented -### if you set a variable in the FOREACH tag, then nothing in the loop gets localized -### if you don't set a variable - everything gets localized -process_ok("[% foo = 1 %][% FOREACH [1..10] %][% foo %][% foo = 2 %][% END %]" => '1222222222'); -process_ok("[% f = 1 %][% FOREACH i = [1..10] %][% i %][% f = 2 %][% END %][% f %]" => '123456789102'); -process_ok("[% f = 1 %][% FOREACH [1..10] %][% f = 2 %][% END %][% f %]" => '1'); -process_ok("[% f = 1 %][% FOREACH f = [1..10] %][% f %][% END %][% f %]" => '1234567891010'); -process_ok("[% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => ''); -process_ok("[% a %][% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => ''); -process_ok("[% a = 2 %][% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => '2'); -process_ok("[% a = 2 %][% FOREACH [1] %][% a = 1 %][% END %][% a %]" => '2'); -process_ok("[% a = 2 %][% FOREACH i = [1] %][% a = 1 %][% END %][% a %]" => '1'); -process_ok("[% FOREACH i = [1] %][% SET a = 1 %][% END %][% a %]" => '1'); -process_ok("[% f.b = 1 %][% FOREACH f.b = [1..10] %][% f.b %][% END %][% f.b %]" => '1234567891010') if ! $is_tt; -process_ok("[% a = 1 %][% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %][% a %]" => 'barAbarB1'); -process_ok("[% FOREACH [1..3] %][% loop.size %][% END %][% loop.size %]" => '333'); -process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '333') if ! $is_tt; -process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '3331') if $is_tt; - -process_ok('[% FOREACH f = [1..3]; 1; END %]' => '111'); -process_ok('[% FOREACH f = [1..3]; f; END %]' => '123'); -process_ok('[% FOREACH f = [1..3]; "$f"; END %]' => '123'); -process_ok('[% FOREACH f = [1..3]; f + 1; END %]' => '234'); +# We don't do as many tests here - leave that to Template::Alloy +# See Template::Alloy t/05_tt_base.t ###----------------------------------------------------------------### print "### LOOP #############################################################\n"; -process_ok("[% var = [{key => 'a'}, {key => 'b'}] -%] -[% LOOP var -%] - ([% key %]) -[% END %]" => " (a)\n (b)\n") if ! $is_tt; - -process_ok("[% var = [{key => 'a'}, {key => 'b'}] -%] -[% LOOP var -%] - [%- NEXT IF key eq 'a' -%] - ([% key %]) -[% END %]" => " (b)\n") if ! $is_tt; - if (! $is_tt) { local $CGI::Ex::Template::QR_PRIVATE = 0; local $CGI::Ex::Template::QR_PRIVATE = 0; # warn clean @@ -848,499 +132,8 @@ if (! $is_tt) { ", {tt_config => [LOOP_CONTEXT_VARS => 1]}); } -###----------------------------------------------------------------### -print "### WHILE ############################################################\n"; - -process_ok("[% WHILE foo %]" => ''); -process_ok("[% WHILE foo %][% END %]" => ''); -process_ok("[% WHILE (foo = foo - 1) %][% END %]" => ''); -process_ok("[% WHILE (foo = foo - 1) %][% foo %][% END %]" => '21', {foo => 3}); -process_ok("[% WHILE foo %][% foo %][% foo = foo - 1 %][% END %]" => '321', {foo => 3}); - -process_ok("[% WHILE 1 %][% foo %][% foo = foo - 1 %][% LAST IF foo == 1 %][% END %]" => '32', {foo => 3}); -process_ok("[% f = 10; WHILE f; f = f - 1 ; f ; END %]" => '9876543210'); -process_ok("[% f = 10; WHILE f; f = f - 1 ; f ; END ; f %]" => '98765432100'); -process_ok("[% f = 10; a = 2; WHILE f; f = f - 1 ; f ; a=3; END ; a%]" => '98765432103'); - -process_ok("[% f = 10; WHILE (g=f); f = f - 1 ; f ; END %]" => '9876543210'); -process_ok("[% f = 10; WHILE (g=f); f = f - 1 ; f ; END ; f %]" => '98765432100'); -process_ok("[% f = 10; a = 2; WHILE (g=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432103'); -process_ok("[% f = 10; a = 2; WHILE (a=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432100'); - -###----------------------------------------------------------------### -print "### STOP / RETURN / CLEAR ############################################\n"; - -process_ok("[% STOP %]" => ''); -process_ok("One[% STOP %]Two" => 'One'); -process_ok("[% BLOCK foo %]One[% STOP %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstOne'); -process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% STOP %][% END %][% END %]" => '1'); -process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% STOP %][% END %][% f %][% END %]" => ''); - -process_ok("[% RETURN %]" => ''); -process_ok("One[% RETURN %]Two" => 'One'); -process_ok("[% BLOCK foo %]One[% RETURN %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstOneLast'); -process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% RETURN %][% END %][% END %]" => '1'); -process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% RETURN %][% END %][% f %][% END %]" => ''); - -process_ok("[% CLEAR %]" => ''); -process_ok("One[% CLEAR %]Two" => 'Two'); -process_ok("[% BLOCK foo %]One[% CLEAR %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstTwoLast'); -process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% CLEAR %][% END %][% END %]" => '23'); -process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% CLEAR %][% END %][% f %][% END %]" => '123'); -process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.last %][% CLEAR %][% END %][% END %]" => ''); -process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% CLEAR %][% END %][% f %][% END %]" => '3'); - -###----------------------------------------------------------------### -print "### post opererative directives ######################################\n"; - -process_ok("[% GET foo IF 1 %]" => '1', {foo => 1}); -process_ok("[% f FOREACH f = [1..3] %]" => '123'); - -process_ok("2[% GET foo IF 1 IF 2 %]" => '21', {foo => 1}) if ! $is_tt; -process_ok("2[% GET foo IF 1 IF 0 %]" => '2', {foo => 1}) if ! $is_tt; -process_ok("[% f FOREACH f = [1..3] IF 1 %]" => '123') if ! $is_tt; -process_ok("[% f FOREACH f = [1..3] IF 0 %]" => '') if ! $is_tt; -process_ok("[% f FOREACH f = g FOREACH g = [1..3] %]" => '123') if ! $is_tt; -process_ok("[% f FOREACH f = g.a FOREACH g = [{a=>1}, {a=>2}, {a=>3}] %]" => '123') if ! $is_tt; -process_ok("[% f FOREACH f = a FOREACH [{a=>1}, {a=>2}, {a=>3}] %]" => '123') if ! $is_tt; - -process_ok("[% FOREACH f = [1..3] IF 1 %]([% f %])[% END %]" => '(1)(2)(3)') if ! $is_tt; -process_ok("[% FOREACH f = [1..3] IF 0 %]([% f %])[% END %]" => '') if ! $is_tt; - -process_ok("[% BLOCK bar %][% foo %][% foo = foo - 1 %][% END %][% PROCESS bar WHILE foo %]" => '321', {foo => 3}); - -###----------------------------------------------------------------### -print "### capturing ########################################################\n"; - -process_ok("[% foo = BLOCK %]Hi[% END %][% foo %][% foo %]" => 'HiHi'); -process_ok("[% BLOCK foo %]Hi[% END %][% bar = PROCESS foo %]-[% bar %]" => '-Hi'); -process_ok("[% foo = IF 1 %]Hi[% END %][% foo %]" => 'Hi'); - -###----------------------------------------------------------------### -print "### TAGS #############################################################\n"; - -process_ok("[% TAGS asp %]<% 1 + 2 %>" => 3); -process_ok("[% TAGS default %][% 1 + 2 %]" => 3); -process_ok("[% TAGS html %]" => '3'); -process_ok("[% TAGS mason %]<% 1 + 2 >" => 3); -process_ok("[% TAGS metatext %]%% 1 + 2 %%" => 3); -process_ok("[% TAGS php %]" => 3); -process_ok("[% TAGS star %][* 1 + 2 *]" => 3); -process_ok("[% TAGS template %][% 1 + 2 %]" => 3); -process_ok("[% TAGS template1 %][% 1 + 2 %]" => 3); -process_ok("[% TAGS template1 %]%% 1 + 2 %%" => 3); -process_ok("[% TAGS tt2 %][% 1 + 2 %]" => 3); - -process_ok("[% TAGS html %] " => '3'); -process_ok("[% TAGS html %]" => '3') if ! $is_tt; -process_ok("[% TAGS html %]\n" => '3'); -process_ok("[% BLOCK foo %][% TAGS html %] " => '3 3'); -process_ok("[% BLOCK foo %][% TAGS html %][% END %][% PROCESS foo %] [% 1 + 2 %]" => ''); - -process_ok("[% TAGS %]" => '3'); - -process_ok("[% TAGS [<] [>] %][<] 1 + 2 [>]" => 3); -process_ok("[% TAGS '[<]' '[>]' %][<] 1 + 2 [>]" => 3) if ! $is_tt; -process_ok("[% TAGS /[<]/ /[>]/ %]< 1 + 2 >" => 3) if ! $is_tt; -process_ok("[% TAGS ** ** %]** 1 + 2 **" => 3); -process_ok("[% TAGS '**' '**' %]** 1 + 2 **" => 3) if ! $is_tt; -process_ok("[% TAGS /**/ /**/ %]** 1 + 2 **" => "") if ! $is_tt; - -process_ok("[% TAGS html -->" => '3') if ! $is_tt; -process_ok("[% TAGS html ; 7 -->" => '73') if ! $is_tt; -process_ok("[% TAGS html ; 7 %]" => '') if ! $is_tt; # error - the old closing tag must come next - -###----------------------------------------------------------------### -print "### SWITCH / CASE ####################################################\n"; - -process_ok("[% SWITCH 1 %][% END %]hi" => 'hi'); -process_ok("[% SWITCH 1 %][% CASE %]bar[% END %]hi" => 'barhi'); -process_ok("[% SWITCH 1 %]Pre[% CASE %]bar[% END %]hi" => 'barhi'); -process_ok("[% SWITCH 1 %][% CASE DEFAULT %]bar[% END %]hi" => 'barhi'); -process_ok("[% SWITCH 1 %][% CASE 0 %]bar[% END %]hi" => 'hi'); -process_ok("[% SWITCH 1 %][% CASE 1 %]bar[% END %]hi" => 'barhi'); -process_ok("[% SWITCH 1 %][% CASE foo %][% CASE 1 %]bar[% END %]hi" => 'barhi'); -process_ok("[% SWITCH 1 %][% CASE [1..10] %]bar[% END %]hi" => 'barhi'); -process_ok("[% SWITCH 11 %][% CASE [1..10] %]bar[% END %]hi" => 'hi'); - -process_ok("[% SWITCH 1.0 %][% CASE [1..10] %]bar[% END %]hi" => 'barhi'); -process_ok("[% SWITCH '1.0' %][% CASE [1..10] %]bar[% END %]hi" => 'barhi') if ! $is_tt; - -###----------------------------------------------------------------### -print "### TRY / THROW / CATCH / FINAL ######################################\n"; - -process_ok("[% TRY %][% END %]hi" => 'hi'); -process_ok("[% TRY %]Foo[% END %]hi" => 'Foohi'); -process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% END %]hi" => ''); -process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH %][% END %]hi" => 'Foohi') if ! $is_tt; -process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH %]there[% END %]hi" => 'Footherehi'); -process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH foo %]there[% END %]hi" => 'Footherehi'); -process_ok("[% TRY %]Foo[% TRY %]Foo[% THROW foo 'for fun' %][% CATCH bar %]one[% END %][% CATCH %]two[% END %]hi" => 'FooFootwohi'); -process_ok("[% TRY %]Foo[% TRY %]Foo[% THROW foo 'for fun' %][% CATCH bar %]one[% END %][% CATCH s %]two[% END %]hi" => ''); -process_ok("[% TRY %]Foo[% THROW foo.bar 'for fun' %][% CATCH foo %]one[% CATCH foo.bar %]two[% END %]hi" => 'Footwohi'); - -process_ok("[% TRY %]Foo[% FINAL %]Bar[% END %]hi" => 'FooBarhi'); -process_ok("[% TRY %]Foo[% THROW foo %][% FINAL %]Bar[% CATCH %]one[% END %]hi" => ''); -process_ok("[% TRY %]Foo[% THROW foo %][% CATCH %]one[% FINAL %]Bar[% END %]hi" => 'FoooneBarhi'); -process_ok("[% TRY %]Foo[% THROW foo %][% CATCH bar %]one[% FINAL %]Bar[% END %]hi" => ''); - -process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error %][% END %]" => 'foo error - bar'); -process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error.type %][% END %]" => 'foo'); -process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error.info %][% END %]" => 'bar'); -process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.type %][% END %]" => 'undef'); -process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.info %][% END %]" => 'foo'); - -###----------------------------------------------------------------### -print "### named args #######################################################\n"; - -process_ok("[% foo(bar = 'one', baz = 'two') %]" => "baronebaztwo", - {foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}}); -process_ok("[%bar='ONE'%][% foo(\$bar = 'one') %]" => "ONEone", - {foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}}); - -###----------------------------------------------------------------### -print "### USE ##############################################################\n"; - -my @config_p = (PLUGIN_BASE => 'MyTestPlugin', LOAD_PERL => 1); -process_ok("[% USE son_of_gun_that_does_not_exist %]one" => '', {tt_config => \@config_p}); -process_ok("[% USE Foo %]one" => 'one', {tt_config => \@config_p}); -process_ok("[% USE Foo2 %]one" => 'one', {tt_config => \@config_p}); -process_ok("[% USE Foo(bar = 'baz') %]one[% Foo.bar %]" => 'onebarbaz', {tt_config => \@config_p}); -process_ok("[% USE Foo2(bar = 'baz') %]one[% Foo2.bar %]" => 'onebarbaz', {tt_config => \@config_p}); -process_ok("[% USE Foo(bar = 'baz') %]one[% Foo.bar %]" => 'onebarbaz', {tt_config => \@config_p}); -process_ok("[% USE d = Foo(bar = 'baz') %]one[% d.bar %]" => 'onebarbaz', {tt_config => \@config_p}); -process_ok("[% USE d.d = Foo(bar = 'baz') %]one[% d.d.bar %]" => '', {tt_config => \@config_p}); - -process_ok("[% USE a(bar = 'baz') %]one[% a.seven %]" => '', {tt_config => [@config_p, PLUGINS => {a=>'Foo'}, ]}); -process_ok("[% USE a(bar = 'baz') %]one[% a.seven %]" => 'one7', {tt_config => [@config_p, PLUGINS => {a=>'Foo2'},]}); - -@config_p = (PLUGIN_BASE => ['NonExistant', 'MyTestPlugin'], LOAD_PERL => 1); -process_ok("[% USE Foo %]one" => 'one', {tt_config => \@config_p}); - -###----------------------------------------------------------------### -print "### MACRO ############################################################\n"; - -process_ok("[% MACRO foo PROCESS bar %][% BLOCK bar %]Hi[% END %][% foo %]" => 'Hi'); -process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi'); -process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi'); -process_ok("[% MACRO foo(n) BLOCK %]Hi[% n %][% END %][% foo(2) %]" => 'Hi2'); -process_ok("[%n=1%][% MACRO foo(n) BLOCK %]Hi[% n %][% END %][% foo(2) %][%n%]" => 'Hi21'); -process_ok("[%n=1%][% MACRO foo BLOCK %]Hi[% n = 2%][% END %][% foo %][%n%]" => 'Hi1'); -process_ok("[% MACRO foo(n) FOREACH i=[1..n] %][% i %][% END %][% foo(3) %]" => '123'); - -process_ok('[% MACRO f BLOCK %]>[% TRY; f ; CATCH ; "caught" ; END %][% END %][% f %]' => '>>>caught', {tt_config => [MAX_MACRO_RECURSE => 3]}) if ! $is_tt; - -###----------------------------------------------------------------### -print "### DEBUG ############################################################\n"; - -process_ok("\n\n[% one %]" => "\n\n\n## input text line 3 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]}); -process_ok("[% one %]" => "\n## input text line 1 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]}); -process_ok("[% one %]\n\n" => "(1)ONE\n\n", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']}); -process_ok("1\n2\n3[% one %]" => "1\n2\n3(3)ONE", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']}); -process_ok("[% one;\n one %]" => "(1)ONE(2)ONE", {one=>'ONE', tt_config => ['DEBUG' => 8, - 'DEBUG_FORMAT' => '($line)']}) if ! $is_tt; -process_ok("[% DEBUG format '(\$line)' %][% one %]" => qr/\(1\)/, {one=>'ONE', tt_config => ['DEBUG' => 8]}); - -process_ok("[% TRY %][% abc %][% CATCH %][% error %][% END %]" => "undef error - abc is undefined\n", {tt_config => ['DEBUG' => 2]}); -process_ok("[% TRY %][% abc.def %][% CATCH %][% error %][% END %]" => "undef error - def is undefined\n", {abc => {}, tt_config => ['DEBUG' => 2]}); - -###----------------------------------------------------------------### -print "### constants ########################################################\n"; - -my @config_c = ( - CONSTANTS => { - harry => sub {'do_this_once'}, - foo => { - bar => {baz => 42}, - bim => 57, - }, - bing => 'baz', - bang => 'bim', - }, - VARIABLES => { - bam => 'bar', - }, -); -process_ok("[% constants.harry %]" => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c}); -process_ok("[% constants.harry.length %]" => '12', {tt_config => \@config_c}); -process_ok("[% SET constants.something = 1 %][% constants.something %]one" => '1one', {tt_config => \@config_c}); -process_ok("[% SET constants.harry = 1 %][% constants.harry %]one" => 'do_this_onceone', {tt_config => \@config_c}); -process_ok("[% constants.foo.\${constants.bang} %]" => '57', {tt_config => [@config_c]}); -process_ok("[% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt; -process_ok("[% bam = 'somethingelse' %][% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt; - -process_ok('[% constants.${"harry"} %]' => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c}); -process_ok('[% ${"constants"}.harry %]' => 'foo', {constants => {harry => 'foo'}, tt_config => \@config_c}) if ! $is_tt; -process_ok('[% ${"constants"}.harry %]' => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c}) if $is_tt; -process_ok('[% ${"con${\\"s\\"}tants"}.harry %]' => 'foo', {constants => {harry => 'foo'}, tt_config => \@config_c}) if ! $is_tt; - -###----------------------------------------------------------------### -print "### INTERPOLATE / ANYCASE / TRIM #####################################\n"; - -process_ok("Foo \$one Bar" => 'Foo ONE Bar', {one => 'ONE', tt_config => ['INTERPOLATE' => 1]}); -process_ok("[% PERL %] my \$n=7; print \$n [% END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]}); -process_ok("[% TRY ; PERL %] my \$n=7; print \$n [% END ; END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]}); - -process_ok("[% GET %]" => '', {GET => 'ONE'}); -process_ok("[% GET GET %]" => 'ONE', {GET => 'ONE'}) if ! $is_tt; -process_ok("[% get one %]" => 'ONE', {one => 'ONE', tt_config => ['ANYCASE' => 1]}); -process_ok("[% get %]" => '', {get => 'ONE', tt_config => ['ANYCASE' => 1]}); -process_ok("[% get get %]" => 'ONE', {get => 'ONE', tt_config => ['ANYCASE' => 1]}) if ! $is_tt; - -process_ok("[% BLOCK foo %]\nhi\n[% END %][% PROCESS foo %]" => "\nhi\n"); -process_ok("[% BLOCK foo %]\nhi[% END %][% PROCESS foo %]" => "hi", {tt_config => [TRIM => 1]}); -process_ok("[% BLOCK foo %]hi\n[% END %][% PROCESS foo %]" => "hi", {tt_config => [TRIM => 1]}); -process_ok("[% BLOCK foo %]hi[% nl %][% END %][% PROCESS foo %]" => "hi", {nl => "\n", tt_config => [TRIM => 1]}); -process_ok("[% BLOCK foo %][% nl %]hi[% END %][% PROCESS foo %]" => "hi", {nl => "\n", tt_config => [TRIM => 1]}); -process_ok("A[% TRY %]\nhi\n[% END %]" => "A\nhi", {tt_config => [TRIM => 1]}); - -###----------------------------------------------------------------### -print "### V1DOLLAR #########################################################\n"; - -process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|bar|bar|A', {a => 'A', A => 'bar'}); -process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|A|bar|A', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1]}); - -$vars = {a => {b => {c=>'Cb'}, B => {c=>'CB'}}, b => 'B', Cb => 'bar', CB => 'Bar'}; -process_ok('[% a.b.c %]|[% $a.b.c %]|[% a.$b.c %]|[% ${ a.b.c } %]' => 'Cb||CB|bar', $vars); -process_ok('[% a.b.c %]|[% $a.b.c %]|[% a.$b.c %]|[% ${ a.b.c } %]' => 'Cb|Cb|Cb|bar', {%$vars, tt_config => [V1DOLLAR => 1]}); - -process_ok('[% "$a" %]|$a|[% "${a}" %]|${a}' => 'A|$a|A|${a}', {a => 'A', A => 'bar'}); -process_ok('[% "$a" %]|$a|[% "${a}" %]|${a}' => 'A|$a|A|${a}', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1]}); -process_ok('[% "$a" %]|$a|[% "${a}" %]|${a}' => 'A|A|A|A', {a => 'A', A => 'bar', tt_config => [INTERPOLATE => 1]}); -process_ok('[% "$a" %]|$a|[% "${a}" %]|${a}' => 'A|A|A|A', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1, INTERPOLATE => 1]}); - -process_ok('[% constants.a %]|[% $constants.a %]|[% constants.$a %]' => 'A|A|A', {tt_config => [V1DOLLAR => 1, CONSTANTS => {a => 'A'}]}); - -###----------------------------------------------------------------### -print "### V2PIPE / V2EQUALS ################################################\n"; - -process_ok("[%- BLOCK a %]b is [% b %] -[% END %] -[%- PROCESS a b => 237 | repeat(2) %]" => "b is 237 -b is 237\n", {tt_config => [V2PIPE => 1]}); - -process_ok("[%- BLOCK a %]b is [% b %] -[% END %] -[%- PROCESS a b => 237 | repeat(2) %]" => "b is 237237\n") if ! $is_tt; - -process_ok("[% ('a' == 'b') || 0 %]" => 0); -process_ok("[% ('a' != 'b') || 0 %]" => 1); -process_ok("[% ('a' == 'b') || 0 %]" => 0, {tt_config => [V2EQUALS => 1]}) if ! $is_tt; -process_ok("[% ('a' != 'b') || 0 %]" => 1, {tt_config => [V2EQUALS => 1]}) if ! $is_tt; -process_ok("[% ('a' == 'b') || 0 %]" => 1, {tt_config => [V2EQUALS => 0]}) if ! $is_tt; -process_ok("[% ('a' != 'b') || 0 %]" => 0, {tt_config => [V2EQUALS => 0]}) if ! $is_tt; -process_ok("[% ('7' == '7.0') || 0 %]" => 0); -process_ok("[% ('7' == '7.0') || 0 %]" => 1, {tt_config => [V2EQUALS => 0]}) if ! $is_tt; - -###----------------------------------------------------------------### -print "### configuration ####################################################\n"; - -process_ok('[% a = 7 %]$a' => 7, {tt_config => ['INTERPOLATE' => 1]}); -process_ok('[% a = 7 %]$a' => 7, {tt_config => ['interpolate' => 1]}) if ! $is_tt; - -###----------------------------------------------------------------### -print "### PERL #############################################################\n"; - -process_ok("[% TRY %][% PERL %][% END %][% CATCH ; error; END %]" => 'perl error - EVAL_PERL not set'); -process_ok("[% PERL %] print \"[% one %]\" [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]}); -process_ok("[% PERL %] print \$stash->get('one') [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]}); -process_ok("[% PERL %] print \$stash->set('a.b.c', 7) [% END %][% a.b.c %]" => '77', {tt_config => ['EVAL_PERL' => 1]}); - -###----------------------------------------------------------------### -print "### recursion prevention #############################################\n"; - -process_ok("[% BLOCK foo %][% PROCESS bar %][% END %][% BLOCK bar %][% PROCESS foo %][% END %][% PROCESS foo %]" => '') if ! $is_tt; - -###----------------------------------------------------------------### -print "### META #############################################################\n"; - -process_ok("[% template.name %]" => 'input text'); -process_ok("[% META foo = 'bar' %][% template.foo %]" => 'bar'); -process_ok("[% META name = 'bar' %][% template.name %]" => 'bar'); -process_ok("[% META foo = 'bar' %][% component.foo %]" => 'bar'); -process_ok("[% META foo = 'bar' %][% component = '' %][% component.foo %]|foo" => '|foo'); -process_ok("[% META foo = 'bar' %][% template = '' %][% template.foo %]|foo" => '|foo'); - -###----------------------------------------------------------------### -print "### references #######################################################\n"; - -process_ok("[% a=3; b=\\a; b; a %]" => 33); -process_ok("[% a=3; b=\\a; a=7; b; a %]" => 77); - -process_ok("[% a={}; a.1=7; b=\\a.1; b; a.1 %]" => '77'); -process_ok("[% a={}; a.1=7; b=\\a.20; a.20=7; b; a.20 %]" => '77'); - -process_ok("[% a=[]; a.1=7; b=\\a.1; b; a.1 %]" => '77'); -process_ok("[% a=[]; a.1=7; b=\\a.20; a.20=7; b; a.20 %]" => '77'); - -process_ok("[% \\a %]" => qr/^CODE/, {a => sub { return "a sub [@_]" } }); -process_ok("[% b=\\a; b %]" => 'a sub []', {a => sub { return "a sub [@_]" } }); -process_ok("[% b=\\a(1); b %]" => 'a sub [1]', {a => sub { return "a sub [@_]" } }); -process_ok("[% b=\\a; b(2) %]" => 'a sub [2]', {a => sub { return "a sub [@_]" } }); -process_ok("[% b=\\a(1); b(2) %]" => 'a sub [1 2]', {a => sub { return "a sub [@_]" } }); -process_ok("[% f=\\j.k; j.k=7; f %]" => '7', {j => {k => 3}}); - -process_ok('[% a = "a" ; f = {a=>"A",b=>"B"} ; foo = \f.$a ; foo %]' => 'A'); -process_ok('[% a = "a" ; f = {a=>"A",b=>"B"} ; foo = \f.$a ; a = "b" ; foo %]' => 'A'); -process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-") ; a = "cd"; foo %]' => '-AB-cd'); -process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-").replace("-AB-", "*") ; a = "cd"; foo %]' => '*cd'); - -process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-") ; f = "ab"; foo %]' => '-AB-cd'); -process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-").replace("-AB-", "*") ; f = "ab"; foo %]' => '*cd'); - -###----------------------------------------------------------------### -print "### reserved words ###################################################\n"; - -$vars = { - GET => 'named_get', - get => 'lower_named_get', - named_get => 'value of named_get', - hold_get => 'GET', -}; -process_ok("[% GET %]" => '', $vars); -process_ok("[% GET GET %]" => 'named_get', $vars) if ! $is_tt; -process_ok("[% GET get %]" => 'lower_named_get', $vars); -process_ok("[% GET \${'GET'} %]" => 'bar', {GET => 'bar'}); - -process_ok("[% GET = 1 %][% GET GET %]" => '', $vars); -process_ok("[% SET GET = 1 %][% GET GET %]" => '1', $vars) if ! $is_tt; - -process_ok("[% GET \$hold_get %]" => 'named_get', $vars); -process_ok("[% GET \$GET %]" => 'value of named_get', $vars) if ! $is_tt; -process_ok("[% BLOCK GET %]hi[% END %][% PROCESS GET %]" => 'hi') if ! $is_tt; -process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo a = GET %]" => 'hi', $vars) if ! $is_tt; -process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo GET = 1 %]" => ''); -process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo IF GET %]" => 'hi', $vars) if ! $is_tt; - -###----------------------------------------------------------------### -print "### embedded items ###################################################\n"; - -process_ok('[% " \" " %]' => ' " '); -process_ok('[% " \$foo " %]' => ' $foo '); -process_ok('[% " \${foo} " %]' => ' ${foo} '); -process_ok('[% " \n " %]' => " \n "); -process_ok('[% " \t " %]' => " \t "); -process_ok('[% " \r " %]' => " \r "); - -process_ok("[% 'foo\\'bar' %]" => "foo'bar"); -process_ok('[% "foo\\"bar" %]' => 'foo"bar'); -process_ok('[% qw(foo \)).1 %]' => ')') if ! $is_tt; -process_ok('[% qw|foo \||.1 %]' => '|') if ! $is_tt; - -process_ok("[% ' \\' ' %]" => " ' "); -process_ok("[% ' \\r ' %]" => ' \r '); -process_ok("[% ' \\n ' %]" => ' \n '); -process_ok("[% ' \\t ' %]" => ' \t '); -process_ok("[% ' \$foo ' %]" => ' $foo '); - -process_ok('[% A = "bar" ; ${ "A" } %]' => 'bar'); -process_ok('[% A = "bar" ; "(${ A })" %]' => '(bar)'); -process_ok('[% A = "bar" ; ${ {a => "A"}.a } %]' => 'bar') if ! $is_tt; -process_ok('[% A = "bar" ; "(${ {a => \"A\"\\}.a })" %]' => '(A)') if ! $is_tt; -process_ok('[% A = "bar" ; "(${ \\${ {a => \"A\"\\}.a \\} })" %]' => '(bar)') if ! $is_tt; -process_ok('[% A = "bar" %](${ {a => \"A\"\\}.a })' => '(A)', {tt_config => [INTERPOLATE => 1]}) if ! $is_tt; -process_ok('[% A = "bar" %](${ \\${ {a => \"A\"\\}.a \\} })' => '(bar)', {tt_config => [INTERPOLATE => 1]}) if ! $is_tt; - -process_ok('[% "[%" %]' => '[%') if ! $is_tt; -process_ok('[% "%]" %]' => '%]') if ! $is_tt; -process_ok('[% a = "[% %]" %][% a %]' => '[% %]') if ! $is_tt; -process_ok('[% "[% 1 + 2 %]" | eval %]' => '3') if ! $is_tt; - -process_ok('[% qw([% 1 + 2 %]).join %]' => '[% 1 + 2 %]') if ! $is_tt; -process_ok('[% qw([% 1 + 2 %]).join.eval %]' => '3') if ! $is_tt; - -process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'caught\' ; END %]"; f.eval %]' => '>>>>>caught', {tt_config => [MAX_EVAL_RECURSE => 5]}) if ! $is_tt; -process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'foo\' ; END %]"; f.eval;f.eval %]' => '>>foo>>foo', {tt_config => [MAX_EVAL_RECURSE => 2]}) if ! $is_tt; - -###----------------------------------------------------------------### -print "### DUMP #############################################################\n"; - -if (! $is_tt) { -local $ENV{'REQUEST_METHOD'} = 0; -process_ok("[% DUMP a %]" => "DUMP: File \"input text\" line 1\n a = undef;\n"); -process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = undef;'); -process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = \'s\';', {a => "s"}); -process_ok("[%\n p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 2 a = \'s\';', {a => "s"}); -process_ok("[% p = DUMP a, b; p.collapse %]" => 'DUMP: File "input text" line 1 a, b = [ \'s\', undef ];', {a => "s"}); -process_ok("[% p = DUMP a Useqq => 'b'; p.collapse %]" => 'DUMP: File "input text" line 1 a Useqq => \'b\' = [ \'s\', { \'Useqq\' => \'b\' } ];', {a => "s"}); -process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = "s";', {a => "s", tt_config => [DUMP => {Useqq => 1}]}); -process_ok("[% p = DUMP a; p.collapse %]|foo" => '|foo', {a => "s", tt_config => [DUMP => 0]}); -process_ok("[% p = DUMP _a, b; p.collapse %]" => 'DUMP: File "input text" line 1 _a, b = [ undef, \'c\' ];', {_a => "s", b=> "c"}); -process_ok("[% p = DUMP {a => 'b'}; p.collapse %]" => 'DUMP: File "input text" line 1 {a => \'b\'} = { \'a\' => \'b\' };'); -process_ok("[% p = DUMP _a; p.collapse %]" => 'DUMP: File "input text" line 1 _a = undef;', {_a => "s"}); -process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = { \'b\' => \'c\' };', {a => {b => 'c'}}); -process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = {};', {a => {_b => 'c'}}); -process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = {};', {a => {_b => 'c'}, tt_config => [DUMP => {Sortkeys => 1}]}); -process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 Dump(7)', {a => 7, tt_config => [DUMP => {handler=>sub {"Dump(@_)"}}]}); -process_ok("[% p = DUMP a; p.collapse %]" => 'a = \'s\';', {a => "s", tt_config => [DUMP => {header => 0}]}); -process_ok("[% p = DUMP a; p.collapse %]" => '
a = 's';
', {a => "s", tt_config => [DUMP => {header => 0, html => 1}]}); -local $ENV{'REQUEST_METHOD'} = 1; -process_ok("[% p = DUMP a; p.collapse %]" => '
a = 's';
', {a => "s", tt_config => [DUMP => {header => 0}]}); -process_ok("[% p = DUMP a; p.collapse %]" => 'a = \'s\';', {a => "s", tt_config => [DUMP => {header => 0, html => 0}]}); -local $ENV{'REQUEST_METHOD'} = 0; -process_ok("[% SET global; p = DUMP; p.collapse %]" => "DUMP: File \"input text\" line 1 EntireStash = { 'a' => 'b', 'global' => undef };", {a => 'b', tt_config => [DUMP => {Sortkeys => 1}]}); -process_ok("[% SET global; p = DUMP; p.collapse %]" => "DUMP: File \"input text\" line 1 EntireStash = { 'a' => 'b', 'global' => undef };", {a => 'b', tt_config => [DUMP => {Sortkeys => 1, EntireStash => 1}]}); -process_ok("[% SET global; p = DUMP; p.collapse %]" => "DUMP: File \"input text\" line 1", {a => 'b', tt_config => [DUMP => {Sortkeys => 1, EntireStash => 0}]}); -} - -###----------------------------------------------------------------### -print "### SYNTAX ###########################################################\n"; - -if (! $is_tt) { -process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "", {tt_config => [SYNTAX => 'garbage']}); -process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237237"); -process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237237", {tt_config => [SYNTAX => 'cet']}); -process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237237", {tt_config => [SYNTAX => 'tt3']}); -process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237b is 237", {tt_config => [SYNTAX => 'tt2']}); -process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237b is 237", {tt_config => [SYNTAX => 'tt1']}); -process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237b is 237", {tt_config => [SYNTAX => 'tt1']}); - - -process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|bar|bar|A', {a => 'A', A => 'bar'}); -process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|bar|bar|A', {a => 'A', A => 'bar', tt_config => [SYNTAX => 'tt2']}); -process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|A|bar|A', {a => 'A', A => 'bar', tt_config => [SYNTAX => 'tt1']}); - -process_ok("" => "FOO", {foo => "FOO", tt_config => [SYNTAX => 'ht']}); -process_ok("" => "7 8", {tt_config => [SYNTAX => 'hte']}); -process_ok("" => "1", {tt_config => [SYNTAX => 'hte']}); -process_ok("" => "1", {tt_config => [SYNTAX => 'hte']}); -process_ok("d" => "", {tt_config => [SYNTAX => 'ht']}); - -process_ok("[% \"\"|eval('hte') %] = [% 6 %]" => "6 = 6"); -process_ok("[% \"\"|eval('ht') %] = [% 6 %]" => ""); - -} - -###----------------------------------------------------------------### -print "### CONFIG ############################################################\n"; - -if (! $is_tt) { -process_ok("[% CONFIG ANYCASE => 1 %][% get 234 %]" => 234); -process_ok("[% CONFIG anycase => 1 %][% get 234 %]" => 234); -process_ok("[% CONFIG PRE_CHOMP => '-' %]\n[% 234 %]" => 234); -process_ok("[% CONFIG POST_CHOMP => '-' %][% 234 %]\n" => 234); -process_ok("[% CONFIG INTERPOLATE => '-' %]\${ 234 }" => 234); -process_ok("[% CONFIG V1DOLLAR => 1 %][% a = 234 %][% \$a %]" => 234); -process_ok("[% CONFIG V2PIPE => 1 %][% BLOCK a %]b is [% b %][% END %][% PROCESS a b => 234 | repeat(2) %]" => "b is 234b is 234"); -process_ok("[% CONFIG V2EQUALS => 1 %][% ('7' == '7.0') || 0 %]" => 0); -process_ok("[% CONFIG V2EQUALS => 0 %][% ('7' == '7.0') || 0 %]" => 1); - -process_ok("[% CONFIG BOGUS => 2 %]bar" => ''); - -process_ok("[% CONFIG ANYCASE %]|[% CONFIG ANYCASE => 1 %][% CONFIG ANYCASE %]" => 'CONFIG ANYCASE = undef|CONFIG ANYCASE = 1'); -process_ok("[% CONFIG ANYCASE %]|[% CONFIG ANYCASE => 1 %][% CONFIG ANYCASE %]" => 'CONFIG ANYCASE = undef|CONFIG ANYCASE = 1'); - -process_ok("[% \"[% GET 1+2+3 %]\" | eval %] = [% get 6 %]" => "", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; -process_ok("[% CONFIG ANYCASE => 1 %][% get 6 %]" => "6", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; -process_ok("[% CONFIG ANYCASE => 1 %][% \"[% get 1+2+3 %]\" | eval %] = [% get 6 %]" => "6 = 6", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; -process_ok("[% \"[% CONFIG ANYCASE => 1 %][% get 1+2+3 %]\" | eval %] = [% get 6 %]" => "", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; -process_ok("[% \"[% CONFIG ANYCASE => 1 %][% get 1+2+3 %]\" | eval %] = [% GET 6 %]" => "6 = 6", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; -process_ok("[% CONFIG SYNTAX => 'hte' %][% \"\"|eval %] = [% 6 %]" => "6 = 6"); - -process_ok("[% CONFIG DUMP %]|[% CONFIG DUMP => 0 %][% DUMP %]bar" => 'CONFIG DUMP = undef|bar'); -process_ok("[% CONFIG DUMP => {Useqq=>1, header=>0, html=>0} %][% DUMP 'foo' %]" => "'foo' = \"foo\";\n"); -process_ok("[% CONFIG VMETHOD_FUNCTIONS => 0 %][% sprintf('%d %d', 7, 8) %] d" => ' d'); -} +# See Template::Alloy t/05_tt_base.t ###----------------------------------------------------------------### print "### DONE #############################################################\n"; +print "### See Template::Alloy t/05_tt_base.t\n";