+2.13
+ 2007-05-21
+ * Added full support for HTML::Template and HTML::Template::Expr.
+ * Added missing HTML::Template::Expr vmethods.
+ * Added support for using Text vmethods as top level items.
+ * Added SYNTAX configuration item.
+ * Added V2EQUALS configuration item.
+ * Broke Extra and HTE out to its own area.
+ * Added many more tests.
+ * Allow QR_PRIVATE to be false.
+
+
2.12
2007-05-11
* Add STAT_TTL
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
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
# 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.12
+version: 2.13
version_from: lib/CGI/Ex.pm
installdirs: site
requires:
use base qw(Exporter);
BEGIN {
- $VERSION = '2.12';
+ $VERSION = '2.13';
$PREFERRED_CGI_MODULE ||= 'CGI';
@EXPORT = ();
@EXPORT_OK = qw(get_form
use vars qw($VERSION);
BEGIN {
- $VERSION = '2.12';
+ $VERSION = '2.13';
Time::HiRes->import('time') if eval {require Time::HiRes};
eval {require Scalar::Util};
return $t->output;
}
+As of version 2.13 of CGI::Ex::Template you could also simply do the
+following to parse the templates using HTML::Template::Expr syntax.
+
+ sub template_args {
+ return {SYNTAX => 'hte'};
+ }
+
=item template_args (hook)
Returns a hashref of args that will be passed to the "new" method of CGI::Ex::Template.
use Digest::MD5 qw(md5_hex);
use CGI::Ex;
-$VERSION = '2.12';
+$VERSION = '2.13';
###----------------------------------------------------------------###
);
@EXPORT_OK = qw(conf_read conf_write in_cache);
-$VERSION = '2.12';
+$VERSION = '2.13';
$DEFAULT_EXT = 'conf';
use CGI::Ex::Dump qw(debug ctrace dex_html);
BEGIN {
- $VERSION = '2.12';
+ $VERSION = '2.13';
$SHOW_TRACE = 0 if ! defined $SHOW_TRACE;
$IGNORE_EVAL = 0 if ! defined $IGNORE_EVAL;
$EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;
use strict;
use Exporter;
-$VERSION = '2.12';
+$VERSION = '2.13';
@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);
use base qw(Exporter);
BEGIN {
- $VERSION = '2.12';
+ $VERSION = '2.13';
@EXPORT = qw(form_fill);
@EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
};
use base qw(Exporter);
BEGIN {
- $VERSION = '2.12';
+ $VERSION = '2.13';
@EXPORT = qw(JSONDump);
@EXPORT_OK = @EXPORT;
###----------------------------------------------------------------###
use strict;
-use constant trace => $ENV{'CET_TRACE'} || 0; # enable for low level tracing
-use vars qw($VERSION
- $TAGS
- $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS $VOBJS
- $DIRECTIVES $QR_DIRECTIVE
-
- $OPERATORS
- $OP_DISPATCH
- $OP_ASSIGN
- $OP
- $OP_PREFIX
- $OP_POSTFIX
- $OP_TERNARY
-
- $QR_OP
- $QR_OP_PREFIX
- $QR_OP_ASSIGN
-
- $QR_COMMENTS
- $QR_FILENAME
- $QR_NUM
- $QR_AQ_SPACE
- $QR_PRIVATE
-
- $PACKAGE_EXCEPTION $PACKAGE_ITERATOR $PACKAGE_CONTEXT $PACKAGE_STASH $PACKAGE_PERL_HANDLE
- $MAX_EVAL_RECURSE $MAX_MACRO_RECURSE
- $WHILE_MAX
- $EXTRA_COMPILE_EXT
- $DEBUG
- $STAT_TTL
-
- @CONFIG_COMPILETIME
- @CONFIG_RUNTIME
- );
-BEGIN {
- $VERSION = '2.12';
-
- $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
- $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
- $PACKAGE_CONTEXT = 'CGI::Ex::Template::_Context';
- $PACKAGE_STASH = 'CGI::Ex::Template::_Stash';
- $PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle';
-
- $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 $VERSION = '2.13';
- $SCALAR_OPS = {
- '0' => sub { $_[0] },
- chunk => \&vmethod_chunk,
- collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
- defined => sub { defined $_[0] ? 1 : '' },
- indent => \&vmethod_indent,
- int => sub { local $^W; int $_[0] },
- fmt => \&vmethod_fmt_scalar,
- 'format' => \&vmethod_format,
- hash => sub { {value => $_[0]} },
- html => sub { local $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; s/\"/"/g; s/\'/'/g; $_ },
- item => sub { $_[0] },
- lcfirst => sub { lcfirst $_[0] },
- length => sub { defined($_[0]) ? length($_[0]) : 0 },
- list => sub { [$_[0]] },
- lower => sub { lc $_[0] },
- match => \&vmethod_match,
- new => sub { defined $_[0] ? $_[0] : '' },
- null => sub { '' },
- 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/ },
- size => sub { 1 },
- split => \&vmethod_split,
- stderr => sub { print STDERR $_[0]; '' },
- substr => \&vmethod_substr,
- trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
- ucfirst => sub { ucfirst $_[0] },
- upper => sub { uc $_[0] },
- uri => \&vmethod_uri,
- url => \&vmethod_url,
- };
+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/^[_.]/;
- $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 $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(@_) },
+};
- $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 $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
+};
- $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; $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 $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; 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/(?<!\\)([\"\'])/\\$1/g; $_ },
+ lc => 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,
+};
- $VOBJS = {
- Text => $SCALAR_OPS,
- List => $LIST_OPS,
- Hash => $HASH_OPS,
- };
- foreach (values %$VOBJS) {
- $_->{'Text'} = $_->{'as'};
- $_->{'Hash'} = $_->{'hash'};
- $_->{'List'} = $_->{'list'};
- }
-
- $DIRECTIVES = {
- #name parse_sub play_sub block postdir continue move_to_front
- BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1, 0, 0, 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 => [undef, 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],
- MACRO => [\&parse_MACRO, \&play_MACRO],
- META => [undef, \&play_META],
- NEXT => [sub {}, \&play_control],
- PERL => [\&parse_PERL, \&play_PERL, 1],
- PROCESS => [\&parse_PROCESS, \&play_PROCESS],
- RAWPERL => [\&parse_PERL, \&play_RAWPERL, 1],
- RETURN => [sub {}, \&play_control],
- SET => [\&parse_SET, \&play_SET],
- STOP => [sub {}, \&play_control],
- SWITCH => [\&parse_SWITCH, \&play_SWITCH, 1],
- TAGS => [undef, 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 #move_to_front
- };
+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],
+};
- ### setup the operator parsing
- $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, ['==', 'eq'], sub { $_[0] eq $_[1] } ],
- ['none', 75, ['!=', 'ne'], sub { $_[0] ne $_[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 ],
- ];
- $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
- 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_op_qr { _op_qr(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS) }
- sub _build_op_qr_prefix { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS) }
- sub _build_op_qr_assign { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS) }
- $QR_OP = _build_op_qr();
- $QR_OP_PREFIX = _build_op_qr_prefix();
- $QR_OP_ASSIGN = _build_op_qr_assign();
-
- $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )';
- $QR_COMMENTS = '(?-s: \# .* \s*)*';
- $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\.][\w\-\.]* (?:/[\w\-\.]+)*';
- $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?';
- $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=;) )';
- $QR_PRIVATE = qr/^[_.]/;
-
- $WHILE_MAX = 1000;
- $EXTRA_COMPILE_EXT = '.sto';
- $MAX_EVAL_RECURSE = 50;
- $MAX_MACRO_RECURSE = 50;
- $STAT_TTL ||= 1;
-
- @CONFIG_COMPILETIME = qw(ANYCASE INTERPOLATE PRE_CHOMP POST_CHOMP V1DOLLAR V2PIPE);
- @CONFIG_RUNTIME = qw(DUMP);
-
- eval {require Scalar::Util};
+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 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) {
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->{'_in_perl'}; # no interpolation in perl
+ 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 @move_to_front; # items that need to be declared first (usually BLOCKS)
+ 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; # found a post-operative DIRECTIVE
+ my $post_op = 0; # found a post-operative DIRECTIVE
my $capture; # flag to start capture
my $func;
my $node;
- my $mark;
local pos $$str_ref = 0;
while (1) {
### continue looking for information in a semi-colon delimited tag
if ($continue) {
- $node = [undef, pos($$str_ref), undef];
+ $node = [undef, $continue, undef];
- ### look through the string using index
+ ### 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;
-
- if ($text =~ m{ ($END) }xs) {
- my $char = pos($$str_ref) + $-[1] + 1;
- $self->throw('parse', "Found unmatched closing tag \"$1\"", undef, $char);
- }
-
+ 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 ($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
}
- if ($$str_ref =~ m{ \G \# }gcx) { # leading # means to comment the entire section
+
+ ### 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] = '#';
&& ($DIRECTIVES->{$func}
|| ((pos($$str_ref) -= length $1) && 0))
) { # is it a directive
- $node->[0] = $func;
$$str_ref =~ m{ \G \s* $QR_COMMENTS }gcx;
- ### store out this current node level
- if ($post_op) { # on a post operator - replace the original node with the new one - store the old in the new
+ $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) {
- # do nothing - it will be handled further down
+ 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) {
### normal end block
if ($func eq 'END') {
- if ($DIRECTIVES->{$parent_node->[0]}->[5]) { # move things like BLOCKS to front
- if ($parent_node->[0] eq 'BLOCK'
- && defined($parent_node->[3])
- && @in_view) {
+ 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 @move_to_front, $parent_node;
+ push @blocks, $parent_node;
}
- if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var
+ if ($pointer->[-1] && ! $pointer->[-1]->[6]) {
splice(@$pointer, -1, 1, ());
}
- } elsif ($parent_node->[0] =~ /PERL$/) {
- delete $self->{'_in_perl'};
} 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 {
- $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;
- }
push @state, $node;
$pointer = $node->[4] ||= [];
}
- } elsif ($func eq 'TAGS') {
- my $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;
- }
- }
+ ### 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
- $node->[2] = pos $$str_ref;
+ } 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 = undef;
+ $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') {
- my $args = $self->parse_args($str_ref, {named_at_front => 1});
- my $hash;
- if (($hash = $self->play_expr($args->[0]))
- && UNIVERSAL::isa($hash, 'HASH')) {
- unshift @meta, %$hash; # first defined win
- }
-
- ### all other "normal" tags
- } else {
- $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;
- }
- if ($DIRECTIVES->{$func}->[2] && ! $post_op) { # this looks like a block directive
- push @state, $node;
- $pointer = $node->[4] ||= [];
- }
- push @in_view, [] if $func eq 'VIEW';
+ 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->[0] = 'GET';
$node->[3] = $var;
}
-
- ### handle empty tags [% %]
- } elsif ($$str_ref =~ m{ \G (?: ; \s* $QR_COMMENTS)? ([+=~-]?) ($END) }gcxs) {
- my $end = $2;
- $post_chomp = $1 || $self->{'POST_CHOMP'};
- $post_chomp =~ y/-=~+/1230/ if $post_chomp;
- $node->[2] = pos($$str_ref) - length($end);
- $continue = 0;
- $post_op = undef;
- next;
-
- } else { # error
- $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref));
+ $node->[2] = pos $$str_ref;
}
- ### we now have the directive to capture for an item like "SET foo = BLOCK" - store it
- if ($capture) {
- my $parent_node = $capture;
- push @{ $parent_node->[4] }, $node;
- undef $capture;
- }
-
- ### look for the closing tag again
- if ($$str_ref =~ m{ \G (?: ; \s* $QR_COMMENTS)? ([+=~-]?) ($END) }gcxs) {
- my $end = $2;
+ ### 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;
-
- $node->[2] = pos($$str_ref) - length($end);
$continue = 0;
- $post_op = undef;
+ $post_op = 0;
next;
}
- ### we always continue - and always record our position now
- $continue = 1;
- $node->[2] = pos $$str_ref;
+ ### 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
- if ($node->[6]) {
- $post_op = undef;
- $capture = $node;
-
- ### semi-colon = end of statement - we will need to continue parsing this tag
- } elsif ($$str_ref =~ m{ \G ; \s* $QR_COMMENTS }gcxo) {
- $post_op = undef;
+ } elsif ($node->[6]) {
+ $post_op = 0;
+ $capture = $node;
+ ### allow next directive to be post-operative (or not)
} else {
- ### looking at a post operator ([% u FOREACH u IN [1..3] %])
- $mark = pos $$str_ref;
- if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcxo # find a word without advancing position
- && ($func = $self->{'ANYCASE'} ? uc($1) : $1)
- && (($DIRECTIVES->{$func} # and its a directive
- && $DIRECTIVES->{$func}->[3]) # that can be post operative
- || ((pos($$str_ref) = $mark) && 0)) # otherwise rollback
- ) {
- $post_op = $node; # store flag so next loop puts items in this node
- pos($$str_ref) = $mark;
-
- } else {
- $post_op = undef;
- }
+ $post_op = $node;
}
- }
- if (@move_to_front) {
- unshift @tree, @move_to_front;
- }
- if (@meta) {
- unshift @tree, ['META', 0, 0, {@meta}];
+ ### 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;
}
- if ($#state > -1) {
- $self->throw('parse.missing.end', "Missing END", $state[-1], 0);
- }
+ ### 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);
-
- if ($text =~ m{ ($END) }xs) {
- my $char = pos($$str_ref) + $-[1] + 1;
- $self->throw('parse', "Found unmatched closing tag \"$1\"", undef, $char);
- }
-
my $_last = pos($$str_ref);
if ($post_chomp) {
if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
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;
}
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 ($ARGS->{'allow_bare_filenames'}) {
$name = $self->parse_expr($str_ref, {auto_quote => "
($QR_FILENAME # file name
- | \\w+\\b (?: :\\w+\\b)* ) # or block
+ | $QR_BLOCK # or block
(?= [+=~-]? $end # an end tag
| \\s*[+,;] # followed by explicit + , or ;
| \\s+ (?! [\\s=]) # or space not before an =
### 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->{'_in_perl'};
+ return if $self->{'_no_interp'};
### split on variables while keeping the variables
my @pieces = split m{ (?: ^ | (?<! \\)) (\$\w+ (?:\.\w+)* | \$\{ .*? (?<!\\) \}) }x, $tree->[-1];
for my $node (@$tree) {
### text nodes are just the bare text
if (! ref $node) {
- warn "NODE: TEXT\n" if trace;
$$out_ref .= $node if defined $node;
next;
}
- warn "NODE: $node->[0] (char $node->[1])\n" if trace;
$$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};
- my $val = $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref);
- $$out_ref .= $val if defined $val;
+ $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref);
}
}
### determine the top level of this particular variable access
my $ref;
- use CGI::Ex::Dump qw(debug dex_trace);
- debug dex_trace
- if ref $var ne 'ARRAY';
my $name = $var->[$i++];
my $args = $var->[$i++];
- warn "play_expr: begin \"$name\"\n" if trace;
if (ref $name) {
if (! defined $name->[0]) { # operator
return $self->play_operator($name) if wantarray && $name->[1] eq '..';
} else { # a named variable access (ie via $name.foo)
$name = $self->play_expr($name);
if (defined $name) {
- return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
+ 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 ($ARGS->{'is_namespace_during_compile'}) {
$ref = $self->{'NAMESPACE'}->{$name};
} else {
- return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
+ 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};
- $ref = ($name eq 'template' || $name eq 'component') ? $self->{"_$name"} : $VOBJS->{$name} if ! defined $ref;
+ 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 $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
$name = $var->[$i++];
$args = $var->[$i++];
- warn "play_expr: nested \"$name\"\n" if trace;
### 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 =~ $QR_PRIVATE || $name =~ /^\./) {
+ if (! defined($name) || ($QR_PRIVATE && $name =~ $QR_PRIVATE) || $name =~ /^\./) {
$ref = undef;
last;
}
die "Shouldn't get a ". ref($name) ." during a vivify on chain";
}
}
- if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
+ if ($QR_PRIVATE && $name =~ $QR_PRIVATE) { # don't allow vars that begin with _
$ref = undef;
last;
}
# named access (ie via $name.foo)
$ref = $self->play_expr($ref);
- if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _
+ if (defined $ref && (! $QR_PRIVATE || $ref !~ $QR_PRIVATE)) { # don't allow vars that begin with _
if ($#$var <= $i) {
return $self->{'_vars'}->{$ref} = $val;
} else {
return;
}
} elsif (defined $ref) {
- return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
+ return if $QR_PRIVATE && $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
if ($#$var <= $i) {
return $self->{'_vars'}->{$ref} = $val;
} else {
die "Shouldn't get a ".ref($name)." during a vivify on chain";
}
}
- if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
+ if ($QR_PRIVATE && $name =~ $QR_PRIVATE) { # don't allow vars that begin with _
return;
}
return $val;
} elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
- return $self->play_expr($tree->[2]) || $self->play_expr($tree->[3]) || '';
+ 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 $var = $self->play_expr($tree->[2]) && $self->play_expr($tree->[3]);
- return $var ? $var : 0;
+ my $val = $self->play_expr($tree->[2]) && $self->play_expr($tree->[3]);
+ return defined($val) ? $val : '';
} elsif ($op eq '?') {
local $^W;
my $end = $self->{'_end_tag'} || '(?!)';
my $block_name = $self->parse_expr($str_ref, {auto_quote => "
($QR_FILENAME # file name
- | \\w+\\b (?: :\\w+\\b)* ) # or block
+ | $QR_BLOCK # or block
(?= [+=~-]? $end # an end tag
| \\s*[+,;] # followed by explicit + , or ;
| \\s+ (?! [\\s=]) # or space not before an =
sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) }
-sub play_CALL { $DIRECTIVES->{'GET'}->[1]->(@_); return }
+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) = @_;
sub play_CLEAR {
my ($self, $undef, $node, $out_ref) = @_;
$$out_ref = '';
+ return;
}
sub parse_CONFIG {
- my ($self, $str_ref) = @_;
-
- my %ctime = map {$_ => 1} @CONFIG_COMPILETIME;
- my %rtime = map {$_ => 1} @CONFIG_RUNTIME;
-
- my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1});
- my $ref = $config->[0]->[0];
- for (my $i = 2; $i < @$ref; $i += 2) {
- my $key = $ref->[$i] = uc $ref->[$i];
- my $val = $ref->[$i + 1];
- if ($ctime{$key}) {
- splice @$ref, $i, 2, (); # remove the options
- $self->{$key} = $self->play_expr($val);
- $i -= 2;
- } elsif (! $rtime{$key}) {
- $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
- }
- }
- for (my $i = 1; $i < @$config; $i++) {
- my $key = $config->[$i] = uc $config->[$i]->[0];
- if ($ctime{$key}) {
- $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef');
- } elsif (! $rtime{$key}) {
- $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
- }
- }
- return $config;
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_CONFIG;
}
sub play_CONFIG {
- my ($self, $config) = @_;
-
- my %rtime = map {$_ => 1} @CONFIG_RUNTIME;
-
- ### do runtime config - not many options get these
- my ($named, @the_rest) = @$config;
- $named = $self->play_expr($named);
- @{ $self }{keys %$named} = @{ $named }{keys %$named};
-
- ### show what current values are
- return join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest);
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_CONFIG;
}
sub parse_DEBUG {
- my ($self, $str_ref) = @_;
- $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx
- || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref));
- my $ret = [lc($1)];
- if ($ret->[0] eq 'format') {
- $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs
- || $self->throw('parse', "Missing format string", undef, pos($$str_ref));
- $ret->[1] = $2;
- }
- return $ret;
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_DEBUG;
}
sub play_DEBUG {
- my ($self, $ref) = @_;
- if ($ref->[0] eq 'on') {
- delete $self->{'_debug_off'};
- } elsif ($ref->[0] eq 'off') {
- $self->{'_debug_off'} = 1;
- } elsif ($ref->[0] eq 'format') {
- $self->{'_debug_format'} = $ref->[1];
- }
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_DEBUG;
}
sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) }
}
sub play_DUMP {
- my ($self, $dump, $node) = @_;
-
- my $conf = $self->{'DUMP'};
- return if ! $conf && defined $conf; # DUMP => 0
- $conf = {} if ref $conf ne 'HASH';
-
- ### allow for handler override
- my $handler = $conf->{'handler'};
- if (! $handler) {
- require Data::Dumper;
- my $obj = Data::Dumper->new([]);
- my $meth;
- foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) }
- my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1;
- $obj->Sortkeys(sub { my $h = shift; [grep {$_ !~ $QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] });
- $handler = sub { $obj->Values([@_]); $obj->Dump }
- }
-
- my ($named, @dump) = @$dump;
- push @dump, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
- $_ = $self->play_expr($_) foreach @dump;
-
- ### look for the text describing what to dump
- my $info = $self->node_info($node);
- my $out;
- if (@dump) {
- $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump);
- my $name = $info->{'text'};
- $name =~ s/^[+=~-]?\s*DUMP\s+//;
- $name =~ s/\s*[+=~-]?$//;
- $out =~ s/\$VAR1/$name/;
- } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) {
- $out = '';
- } else {
- $out = $handler->($self->{'_vars'});
- $out =~ s/\$VAR1/EntireStash/g;
- }
-
- if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) {
- $out = $SCALAR_OPS->{'html'}->($out);
- $out = "<pre>$out</pre>";
- $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out" if $conf->{'header'} || ! defined $conf->{'header'};
- } else {
- $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'};
- }
-
- return $out;
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_DUMP;
}
sub parse_FILTER {
- my ($self, $str_ref) = @_;
- my $name = '';
- if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) {
- $name = $1;
- }
-
- my $filter = $self->parse_expr($str_ref);
- $filter = '' if ! defined $filter;
-
- return [$name, $filter];
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_FILTER;
}
sub play_FILTER {
- my ($self, $ref, $node, $out_ref) = @_;
- my ($name, $filter) = @$ref;
-
- return '' if ! @$filter;
-
- $self->{'FILTERS'}->{$name} = $filter if length $name;
-
- my $sub_tree = $node->[4];
-
- ### play the block
- my $out = '';
- eval { $self->execute_tree($sub_tree, \$out) };
- die $@ if $@ && ref($@) !~ /Template::Exception$/;
-
- my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it
-
-
- return $DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_FILTER;
}
sub parse_FOREACH {
return '' if ! defined $items;
if (ref($items) !~ /Iterator$/) {
- $items = $PACKAGE_ITERATOR->new($items);
+ $items = $self->iterator($items);
}
my $sub_tree = $node->[4];
die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
}
- return undef;
+ return;
}
sub parse_GET {
}
sub play_GET {
- my ($self, $ident, $node) = @_;
+ my ($self, $ident, $node, $out_ref) = @_;
my $var = $self->play_expr($ident);
- return (! defined $var) ? $self->undefined_get($ident, $node) : $var;
+ 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, $node, $out_ref) = @_;
### localize the swap
- my $swap = $self->{'_vars'};
+ my $swap = $self->{'_vars'} || {};
local $self->{'_vars'} = {%$swap};
### localize the blocks
- my $blocks = $self->{'BLOCKS'};
+ my $blocks = $self->{'BLOCKS'} || {};
local $self->{'BLOCKS'} = {%$blocks};
- my $str = $DIRECTIVES->{'PROCESS'}->[1]->($self, $str_ref, $node, $out_ref);
-
- return $str;
+ 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;
return;
}
-sub parse_MACRO {
- my ($self, $str_ref, $node) = @_;
-
- my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"});
- $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name;
- if (! ref $name) {
- $name = [ $name, 0 ];
- }
+sub parse_LOOP {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_LOOP;
+}
- my $args;
- if ($$str_ref =~ m{ \G \( \s* }gcx) {
- $args = $self->parse_args($str_ref, {positional_only => 1});
- $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
- }
+sub play_LOOP {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_LOOP;
+}
- $node->[6] = 1; # set a flag to keep parsing
- return [$name, $args];
+sub parse_MACRO {
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_MACRO;
}
sub play_MACRO {
- my ($self, $ref, $node, $out_ref) = @_;
- my ($name, $args) = @$ref;
-
- ### get the sub tree
- my $sub_tree = $node->[4];
- if (! $sub_tree || ! $sub_tree->[0]) {
- $self->set_variable($name, undef);
- return;
- } elsif ($sub_tree->[0]->[0] eq 'BLOCK') {
- $sub_tree = $sub_tree->[0]->[4];
- }
-
- my $self_copy = $self;
- eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
-
- ### install a closure in the stash that will handle the macro
- $self->set_variable($name, sub {
- ### macros localize
- my $copy = $self_copy->{'_vars'};
- local $self_copy->{'_vars'}= {%$copy};
-
- ### prevent recursion
- local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0;
- $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $MAX_MACRO_RECURSE reached")
- if ++$self_copy->{'_macro_recurse'} > ($self_copy->{'MAX_MACRO_RECURSE'} || $MAX_MACRO_RECURSE);
-
-
- ### set arguments
- my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
- my @positional = @_;
- foreach my $var (@$args) {
- $self_copy->set_variable($var, shift(@positional));
- }
- foreach my $name (sort keys %$named) {
- $self_copy->set_variable([$name, 0], $named->{$name});
- }
-
- ### finally - run the sub tree
- my $out = '';
- $self_copy->execute_tree($sub_tree, \$out);
- return $out;
- });
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_MACRO;
+}
- return;
+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;
return;
}
-sub parse_PERL { shift->{'_in_perl'} = 1; return }
-
sub play_PERL {
- my ($self, $info, $node, $out_ref) = @_;
- $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
-
- ### fill in any variables
- my $perl = $node->[4] || return;
- my $out = '';
- $self->execute_tree($perl, \$out);
- $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
-
- ### try the code
- my $err;
- eval {
- package CGI::Ex::Template::Perl;
-
- my $context = $self->context;
- my $stash = $context->stash;
-
- ### setup a fake handle
- local *PERLOUT;
- tie *PERLOUT, $CGI::Ex::Template::PACKAGE_PERL_HANDLE, $out_ref;
- my $old_fh = select PERLOUT;
-
- eval $out;
- $err = $@;
-
- ### put the handle back
- select $old_fh;
-
- };
- $err ||= $@;
-
-
- if ($err) {
- $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
- die $err;
- }
-
- return;
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_PERL;
}
sub parse_PROCESS {
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;
}
sub play_RAWPERL {
- my ($self, $info, $node, $out_ref) = @_;
- $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
-
- ### fill in any variables
- my $tree = $node->[4] || return;
- my $perl = '';
- $self->execute_tree($tree, \$perl);
- $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
-
- ### try the code
- my $err;
- my $output = '';
- eval {
- package CGI::Ex::Template::Perl;
-
- my $context = $self->context;
- my $stash = $context->stash;
-
- eval $perl;
- $err = $@;
- };
- $err ||= $@;
-
- $$out_ref .= $output;
-
- if ($err) {
- $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
- die $err;
- }
-
- return;
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_RAWPERL;
}
sub parse_SET {
foreach (@$set) {
my ($op, $set, $val) = @$_;
if (! defined $val) { # not defined
- $val = '';
+ # 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';
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"});
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);
+ $self->throw($name, \@args, $node); # dies
+ return; # but return just in case
}
sub play_TRY {
sub play_UNLESS { return $DIRECTIVES->{'IF'}->[1]->(@_) }
sub parse_USE {
- my ($self, $str_ref) = @_;
-
- my $var;
- my $mark = pos $$str_ref;
- if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))
- && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment
- || ((pos($$str_ref) = $mark) && 0)) # otherwise we need to rollback
- ) {
- $var = $_var;
- }
-
- my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"});
- $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module;
- $module =~ s/\./::/g;
-
- my $args;
- my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo;
- $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1});
-
- if ($open) {
- $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
- }
-
- return [$var, $module, $args];
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_USE;
}
sub play_USE {
- my ($self, $ref, $node, $out_ref) = @_;
- my ($var, $module, $args) = @$ref;
-
- ### get the stash storage location - default to the module
- $var = $module if ! defined $var;
- my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
- pop @var; # remove the trailing '.'
-
- 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
-
- ### look for a plugin_base
- my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
- my $obj;
-
- foreach my $base (ref($BASE) eq 'ARRAY' ? @$BASE : $BASE) {
- my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
- : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
- : "${base}::${module}";
- my $require = "$package.pm";
- $require =~ s|::|/|g;
-
- ### try and load the module - fall back to bare module if allowed
- if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
- my $shape = $package->load;
- my $context = $self->context;
- $obj = $shape->new($context, map { $self->play_expr($_) } @args);
- } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
- $obj = $PACKAGE_ITERATOR->new($args[0]);
- } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
- foreach my $package (@packages) {
- my $require = "$package.pm";
- $require =~ s|::|/|g;
- eval {require $require} || next;
- my $shape = $package->load;
- my $context = $self->context;
- $obj = $shape->new($context, map { $self->play_expr($_) } @args);
- }
- } elsif ($self->{'LOAD_PERL'}) {
- my $require = "$module.pm";
- $require =~ s|::|/|g;
- if (eval {require $require}) {
- $obj = $module->new(map { $self->play_expr($_) } @args);
- }
- }
- }
- if (! defined $obj) {
- my $err = "$module: plugin not found";
- $self->throw('plugin', $err);
- }
-
- ### all good
- $self->set_variable(\@var, $obj);
-
- return;
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::play_USE;
}
sub parse_VIEW {
- my ($self, $str_ref) = @_;
-
- my $ref = $self->parse_args($str_ref, {
- named_at_front => 1,
- require_arg => 1,
- });
-
- return $ref;
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::parse_VIEW;
}
sub play_VIEW {
- my ($self, $ref, $node, $out_ref) = @_;
-
- my ($blocks, $args, $name) = @$ref;
-
- ### get args ready
- # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
- $args = $args->[0];
- my $hash = {};
- foreach (my $i = 2; $i < @$args; $i+=2) {
- my $key = $args->[$i];
- my $val = $self->play_expr($args->[$i+1]);
- if (ref $key) {
- if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
- $key = $key->[0];
- } else {
- $self->set_variable($key, $val);
- next; # what TT does
- }
- }
- $hash->{$key} = $val;
- }
-
- ### prepare the blocks
- my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : '';
- foreach my $key (keys %$blocks) {
- $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}};
- }
- $hash->{'blocks'} = $blocks;
-
- ### get the view
- if (! eval { require Template::View }) {
- $self->throw('view', 'Could not load Template::View library');
- }
- my $view = Template::View->new($self->context, $hash)
- || $self->throw('view', $Template::View::ERROR);
-
- ### 'play it'
- my $old_view = $self->play_expr(['view', 0]);
- $self->set_variable($name, $view);
- $self->set_variable(['view', 0], $view);
-
- if ($node->[4]) {
- my $out = '';
- $self->execute_tree($node->[4], \$out);
- # throw away $out
- }
-
- $self->set_variable(['view', 0], $old_view);
- $view->seal;
-
- return '';
+ 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;
+ return if ! defined $var;
my $sub_tree = $node->[4];
}
die "WHILE loop terminated (> $WHILE_MAX iterations)\n" if ! $count;
- return undef;
+ return;
}
sub parse_WRAPPER { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
sub slurp {
my ($self, $file) = @_;
- local *FH;
- open(FH, "<$file") || $self->throw('file', "$file couldn't be opened: $!");
- read FH, my $txt, -s $file;
- close FH;
+ open(my $fh, '<', $file) || $self->throw('file', "$file couldn't be opened: $!");
+ read $fh, my $txt, -s $file;
return $txt;
}
my $args;
$args = ($#ARGS == 0 && UNIVERSAL::isa($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS;
- $self->DEBUG("set binmode\n") if $DEBUG && $args->{'binmode'}; # holdover for TT2 tests
### get the content
my $content;
}
}
if ($file) {
- local *FH;
- if (open FH, ">$file") {
+ if (open my $fh, '>', $file) {
if (my $bm = $args->{'binmode'}) {
- if (+$bm == 1) { binmode FH }
- else { binmode FH, $bm }
+ if (+$bm == 1) { binmode $fh }
+ else { binmode $fh, $bm }
}
- print FH $output;
- close FH;
+ print $fh $output;
} else {
$self->{'error'} = $self->throw('file', "$out couldn't be opened for writing: $!");
}
sub error { shift->{'error'} }
-sub DEBUG {
- my $self = shift;
- print STDERR "DEBUG: ", @_;
-}
-
sub _load_template_meta {
my $self = shift;
return if $self->{'_template'}; # only do once as need
- ### 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;
+ 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;
}
sub context {
my $self = shift;
- return bless {_template => $self}, $PACKAGE_CONTEXT; # a fake context
+ require CGI::Ex::Template::Extra;
+ return CGI::Ex::Template::Context->new({_template => $self});
+}
+
+sub iterator {
+ my $self = shift;
+ $PACKAGE_ITERATOR->new(@_);
}
sub undefined_get {
}
sub list_plugins {
- my $self = shift;
- my $args = shift || {};
- my $base = $args->{'base'} || '';
-
- return $self->{'_plugins'}->{$base} ||= do {
- my @plugins;
-
- $base =~ s|::|/|g;
- my @dirs = grep {-d $_} map {"$_/$base"} @INC;
-
- foreach my $dir (@dirs) {
- require File::Find;
- File::Find::find(sub {
- my $mod = $base .'/'. ($File::Find::name =~ m|^ $dir / (.*\w) \.pm $|x ? $1 : return);
- $mod =~ s|/|::|g;
- push @plugins, $mod;
- }, $dir);
- }
-
- \@plugins; # return of the do
- };
+ require CGI::Ex::Template::Extra;
+ &CGI::Ex::Template::Extra::list_plugins;
}
sub debug_node {
### 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;
+}
+
sub define_vmethod {
my ($self, $type, $name, $sub) = @_;
- if ( $type =~ /scalar|item/i) { $SCALAR_OPS->{$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";
- }
+ else { die "Invalid type vmethod type $type" }
return 1;
}
sub filter_eval {
my $context = shift;
+ my $syntax = shift;
return sub {
### prevent recursion
my $text = shift;
+ local $t->{'SYNTAX'} = $syntax || $t->{'SYNTAX'};
return $context->process(\$text);
};
}
require File::Path;
File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
}
- local *FH;
- open (FH, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
+ 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}
+ if (+$bm == 1) { binmode $fh }
+ else { binmode $fh, $bm}
}
- print FH $text;
- close FH;
+ print $fh $text;
return '';
};
}
return Data::Dumper::Dumper($obj->parse_expr(\$str));
}
+###----------------------------------------------------------------###
+### support for few HTML::Template and HTML::Template::Expr calling syntax
+
+sub register_function {
+ my ($name, $sub) = @_;
+ $SCALAR_OPS->{$name} = $sub;
+}
+
+sub param {
+ require CGI::Ex::Template::HTE;
+ &CGI::Ex::Template::HTE::param;
+}
+
+sub output {
+ require CGI::Ex::Template::HTE;
+ &CGI::Ex::Template::HTE::output;
+}
+
+sub clear_param { shift->{'param'} = {} }
+
+sub query { shift->throw('query', "Not implemented in CGI::Ex::Template") }
+
+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', @_) }
+
###----------------------------------------------------------------###
package CGI::Ex::Template::Exception;
###----------------------------------------------------------------###
-package CGI::Ex::Template::_Context;
-
-use vars qw($AUTOLOAD);
-
-sub _template { shift->{'_template'} || die "Missing _template" }
-
-sub template {
- my ($self, $name) = @_;
- return $self->_template->{'BLOCKS'}->{$name} || $self->_template->load_parsed_tree($name);
-}
-
-sub config { shift->_template }
-
-sub stash {
- my $self = shift;
- return $self->{'stash'} ||= bless {_template => $self->_template}, $CGI::Ex::Template::PACKAGE_STASH;
-}
-
-sub insert { shift->_template->_insert(@_) }
-
-sub eval_perl { shift->_template->{'EVAL_PERL'} }
-
-sub process {
- my $self = shift;
- my $ref = shift;
- my $args = shift || {};
-
- $self->_template->set_variable($_, $args->{$_}) for keys %$args;
-
- my $out = '';
- $self->_template->_process($ref, $self->_template->_vars, \$out);
- return $out;
-}
-
-sub include {
- my $self = shift;
- my $ref = shift;
- my $args = shift || {};
-
- my $t = $self->_template;
-
- my $swap = $t->{'_vars'};
- local $t->{'_vars'} = {%$swap};
-
- $t->set_variable($_, $args->{$_}) for keys %$args;
-
- my $out = ''; # have temp item to allow clear to correctly clear
- eval { $t->_process($ref, $t->_vars, \$out) };
- if (my $err = $@) {
- die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
- }
-
- return $out;
-}
-
-sub define_filter {
- my ($self, $name, $filter, $is_dynamic) = @_;
- $filter = [ $filter, 1 ] if $is_dynamic;
- $self->define_vmethod('filter', $name, $filter);
-}
-
-sub filter {
- my ($self, $name, $args, $alias) = @_;
- my $t = $self->_template;
-
- my $filter;
- if (! ref $name) {
- $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex::Template::FILTER_OPS->{$name} || $CGI::Ex::Template::SCALAR_OPS->{$name};
- $t->throw('filter', $name) if ! $filter;
- } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) {
- $filter = $name;
- } elsif (UNIVERSAL::can($name, 'factory')) {
- $filter = $name->factory || $t->throw($name->error);
- } else {
- $t->throw('undef', "$name: filter not found");
- }
-
- if (UNIVERSAL::isa($filter, 'ARRAY')) {
- $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
- } elsif ($args && @$args) {
- my $sub = $filter;
- $filter = sub { $sub->(shift, @$args) };
- }
-
- $t->{'FILTERS'}->{$alias} = $filter if $alias;
-
- return $filter;
-}
-
-sub define_vmethod { shift->_template->define_vmethod(@_) }
-
-sub throw {
- my ($self, $type, $info) = @_;
-
- if (UNIVERSAL::isa($type, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
- die $type;
- } elsif (defined $info) {
- $self->_template->throw($type, $info);
- } else {
- $self->_template->throw('undef', $type);
- }
-}
-
-sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
-
-sub DESTROY {}
-
-###----------------------------------------------------------------###
-
-package CGI::Ex::Template::_Stash;
-
-use vars qw($AUTOLOAD);
-
-sub _template { shift->{'_template'} || die "Missing _template" }
-
-sub get {
- my ($self, $var) = @_;
- if (! ref $var) {
- if ($var =~ /^\w+$/) { $var = [$var, 0] }
- else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
- }
- return $self->_template->play_expr($var, {no_dots => 1});
-}
-
-sub set {
- my ($self, $var, $val) = @_;
- if (! ref $var) {
- if ($var =~ /^\w+$/) { $var = [$var, 0] }
- else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
- }
- $self->_template->set_variable($var, $val, {no_dots => 1});
- return $val;
-}
-
-sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
-
-sub DESTROY {}
-
-###----------------------------------------------------------------###
-
-package CGI::Ex::Template::EvalPerlHandle;
-
-sub TIEHANDLE {
- my ($class, $out_ref) = @_;
- return bless [$out_ref], $class;
-}
-
-sub PRINT {
- my $self = shift;
- ${ $self->[0] } .= $_ for grep {defined && length} @_;
- return 1;
-}
-
-###----------------------------------------------------------------###
-
1;
### See the perldoc in CGI/Ex/Template.pod
=head1 SYNOPSIS
+ ### Template::Toolkit style usage
+
my $t = CGI::Ex::Template->new(
INCLUDE_PATH => ['/path/to/templates'],
);
### CET uses the same syntax and configuration as Template::Toolkit
+
+ ### HTML::Template style usage
+
+ my $t = CGI::Ex::Template->new(
+ filename => 'my/template.ht',
+ path => ['/path/to/templates'],
+ );
+
+ my $swap = {
+ key1 => 'val1',
+ key2 => 'val2',
+ code => sub { 42 },
+ hash => {a => 'b'},
+ };
+
+ $t->param($swap);
+
+ # print to STDOUT (errors die)
+ $t->output(print_to => \*STDOUT);
+
+ # process into a variable
+ my $out = $t->output;
+
+ ### CET can also use the same syntax and configuration as HTML::Template
+
=head1 DESCRIPTION
CGI::Ex::Template happened by accident (accidentally on purpose). The
the features of TT2 as well as some from TT3. CGI::Ex::Template is a
full-featured implementation of the Template::Toolkit language.
-CGI::Ex::Template (CET hereafter) is smaller, faster, uses less memory
-and less CPU than TT2. However, it is most likely less portable, less
-extendable, and probably has many of the bugs that TT2 has already massaged
-out from years of bug reports and patches from a very active community
-and mailing list. CET does not have a vibrant community behind it. Fixes
-applied to TT2 will take longer to get into CET, should they get in at all.
-An attempt will be made to follow updates made to TT2 to keep the two
-in sync at a language level. There already has been, and it is expected that
-there will continue to be code sharing between the two projects. (Acutally
-I will try and keep applicable fixes in sync with TT).
+As of version 2.13, CGI::Ex::Template also provides near full
+compatibility with HTML::Template (HT), HTML::Template::JIT (HTJ), and
+HTML::Template::Expr (HTE). Version 2.13 introduced the SYNTAX
+configuration allowing for inclusion of TT style templates in HT and
+vice versa. It also provided the HTML::Template output and param
+methods which allow CET to provide the HTML::Template interface. It
+was possible to add this extra functionality because CGI::Ex::Template
+employs an open architecture.
CGI::Ex::Template uses a recursive regex based grammar (early versions
-before the 2.10 release did not). This allows for the embedding of opening
-and closing tags inside other tags (as in [% a = "[% 1 + 2 %]" ; a|eval %]).
-The individual methods such as parse_expr and play_expr may be used by external
-applications to add TT style variable parsing to other applications.
-
-Most of the standard Template::Toolkit documentation covering directives,
-variables, configuration, plugins, filters, syntax, and vmethods should
-apply to CET just fine (This pod tries to explain everything - but there is
-too much). The section on differences between CET and TT will explain
-what too look out for.
-
-Note: A clarification on "faster". All templates are going to take
-different amounts of time to process. Different types of DIRECTIVES
-parse and play more quickly than others. The test script
-samples/benchmark/bench_template.pl was used to obtain sample numbers.
-In general the following statements are true:
-
- If you load a new Template object each time and pass a filename, CET
- is around 3.5 times faster.
-
- If you load a new Template object and pass a string ref, CET
- is around 3 times faster.
-
- If you load a new Template object and use CACHE_EXT, CET
- is around 1.5 times faster.
-
- If you use a cached object with a cached in memory template,
- then CET is 50% faster.
-
- If you use Template::Stash::XS with a cached in memory template,
- then CET is about as fast. But if you use CGI::Ex::Template::XS,
- the CETX is faster still (about twice as fast as CET).
-
-It is pretty hard to beat the speed of XS stash with compiled in
-memory templates. Many systems don't have access to those so
-CET may make more sense. Hopefully as TT is revised, many of the CET
-speed advantages can be incorporated so that the core TT is just as
-fast or faster. This was last updated at version 2.10 of CET and
-2.18 of TT.
+before the 2.10 release did not). This allows for the embedding of
+opening and closing tags inside other tags (as in [% a = "[% 1 + 2 %]"
+; a|eval %]). The individual methods such as parse_expr and play_expr
+may be used by external applications to add TT style variable parsing
+to other applications.
+
+CGI::Ex::Template is fast but CGI::Ex::Template::XS is even faster.
+If CGI::Ex::Template isn't fast enough for you, the XS version has key
+methods coded in C and provides a noticable improvement over the
+non-XS version. CET by itself is generally faster than TT, HT, and HTE.
+The XS version is nearly always faster - even than HTJ. CET also uses less
+memory than TT and HTE, and only a little more than HT. (This is all
+as of version 2.13 in May 2007 - those other modules will undoubtedly
+receive updates that will improve their performance).
+
+Most of the standard Template::Toolkit documentation covering
+directives, variables, configuration, plugins, filters, syntax, and
+vmethods should apply to CET just fine (This pod tries to explain
+everything - but there is too much). The section on differences
+between CET and TT will explain what too look out for.
+
+Additionally, most of the standard HTML::Template and
+HTML::Template::Expr documentation covering methods, variables,
+expressions, and syntax will apply to CET just fine as well.
So should you use CGI::Ex::Template ? Well, try it out. It may
give you no visible improvement. Or it could.
-
=head1 PUBLIC METHODS
The following section lists most of the publicly available methods. Some less
INCLUDE_PATH => ['/my/path/to/content', '/my/path/to/content2'],
});
- Arguments may be passed as a hash or as a hashref. Returns a CGI::Ex::Template object.
+Arguments may be passed as a hash or as a hashref. Returns a CGI::Ex::Template object.
- There are currently no errors during CGI::Ex::Template object creation.
+There are currently no errors during CGI::Ex::Template object creation. If you are
+using the HTML::Template interface, this is different behavior. The document is
+not parsed until the output or process methods are called.
=item C<process>
This is the main method call for starting processing. Any errors that result in the
template processing being stopped will be stored and available via the ->error method.
+This is the TT compatible method - see the output method for HT compatibility.
-Process takes three arguments.
-
+ my $t = CGI::Ex::Template->new;
$t->process($in, $swap, $out)
|| die $t->error;
+Process takes three arguments.
+
The $in argument can be any one of:
String containing the filename of the template to be processed. The filename should
Additionally - the $out argument can be configured using the OUTPUT configuration
item.
+The process method defaults to using the "cet" syntax which will parse TT3 and most
+TT2 documents. To parse HT or HTE documents, you must pass the SYNTAX configuration
+item to the "new" method. All calls to process would then default to HTE syntax.
+
+ my $obj = CGI::Ex::Template->new(SYNTAX => 'hte');
+
=item C<process_simple>
Similar to the process method but with the following restrictions:
$obj->process('somefile.html', {a => 'b'}, \$string_ref)
|| die $obj->error;
+=item C<output>
+
+HTML::Template way to process a template. The output method requires that a filename,
+filehandle, scalarref, or arrayref argument was passed to the new method. All of
+the HT calling conventions for new are supported. The key difference is that CET will
+not actually process the template until the output method is called.
+
+ my $obj = CGI::Ex::Template->new(filename => 'myfile.html');
+ $obj->param(\%swap);
+ print $obj->output;
+
+See the HTML::Template documentation for more information.
+
+The output method defaults to using the "hte" syntax which will parse HTE and HT documents.
+To parse TT3 or TT2 documents, you must pass the SYNTAX configuration
+item to the "new" method. All calls to process would then default to TT3 syntax.
+
+ my $obj = CGI::Ex::Template->new(SYNTAX => 'tt3');
+
+Any errors that occur during the output method will die with the error as the die value.
+
+=item C<param>
+
+HTML::Template way to get or set variable values that will be used by the output method.
+
+ my $val = $obj->param('key'); # get one value
+
+ $obj->param(key => $val); # set one value
+
+ $obj->param(key => $val, key2 => $val2); # set multiple
+
+ $obj->param({key => $val, key2 => $val2}); # set multiple
+
+See the HTML::Template documentation for more information.
+
+Note: CET does not support the die_on_bad_params configuration. This is because CET
+does not resolve variable names until the output method is called.
+
=item C<define_vmethod>
This method is available for defining extra Virtual methods or filters. This method is similar
to Template::Stash::define_vmethod.
+ CGI::Ex::Template->define_vmethod(
+ 'text',
+ reverse => sub { my $item = shift; return scalar reverse $item },
+ );
+
+=item C<register_function>
+
+This is the HTML::Template way of defining text vmethods. It is the same as
+calling define_vmethod with "text" as the first argument.
+
+ CGI::Ex::Template->register_function(
+ reverse => sub { my $item = shift; return scalar reverse $item },
+ );
+
+=item C<define_directive>
+
+This method can be used for adding new directives or overridding existing
+ones.
+
+ CGI::Ex::Template->define_directive(
+ MYDIR => {
+ parse_sub => sub {}, # parse additional items in the tag
+ play_sub => sub {
+ my ($self, $ref, $node, $out_ref) = @_;
+ $$out_ref .= "I always say the same thing!";
+ return;
+ },
+ is_block => 1, # is this block like
+ is_postop => 0, # not a post operative directive
+ no_interp => 1, # no interpolation in this block
+ continues => undef, # it doesn't "continue" any other directives
+ },
+ );
+
+Now with a template like:
+
+ my $str = "([% MYDIR %]This is something[% END %])";
+ CGI::Ex::Template->new->process(\$str);
+
+You will get:
+
+ (I always say the same thing!)
+
+We'll add more details in later revisions of this document.
+
+=item C<define_syntax>
+
+This method can be used for adding other syntaxes to or overridding
+existing ones in the list of choices available in CET. The syntax can
+be chosen by the SYNTAX configuration item.
+
+ CGI::Ex::Template->define_syntax(
+ my_uber_syntax => sub {
+ my $self = shift;
+ local $self->{'V2PIPE'} = 0;
+ local $self->{'V2EQUALS'} = 0;
+ local $self->{'PRE_CHOMP'} = 0;
+ local $self->{'POST_CHOMP'} = 0;
+ local $self->{'NO_INCLUDES'} = 0;
+ return $self->parse_tree_tt3(@_);
+ },
+ );
+
+The subroutine that is used must return an opcode tree (AST) that
+can be played by the execute_tree method.
+
+=item C<define_operator>
+
+This method allows for adding new operators or overriding existing ones.
+
+ CGI::Ex::Template->define_operator({
+ type => 'right', # can be one of prefix, postfix, right, left, none, ternary, assign
+ precedence => 84, # relative precedence for resolving multiple operators without parens
+ symbols => ['foo', 'FOO'], # any mix of chars can be used for the operators
+ play_sub => sub {
+ my ($one, $two) = @_;
+ return "You've been foo'ed ($one, $two)";
+ },
+ });
+
+You can then use it in a template as in the following:
+
+ my $str = "[% 'ralph' foo 1 + 2 * 3 %]";
+ CGI::Ex::Template->new->process(\$str);
+
+You will get:
+
+ You've been foo'ed (ralph, 7)
+
+Future revisions of this document will include more samples.
+
=back
=head1 TODO
- Add HTML::Template support
+Move module to its own namespace.
+
+Cleanup operator API to allow for easier full customization of
+operators.
-=head1 HOW IS CGI::Ex::Template DIFFERENT
+Give better examples of overriding directives, syntax, and operators.
+
+Add more functions to the XS version.
+
+Find other syntaxes to include.
+
+=head1 HOW IS CGI::Ex::Template DIFFERENT from Template::Toolkit
CET uses the same base template syntax and configuration items as TT2,
but the internals of CET were written from scratch. Additionally much
-of the planned TT3 syntax is supported. The following is a list of
-some of the ways that the configuration and syntax of CET are
-different from that of TT2. Note: items that are planned to work in
-TT3 are marked with (TT3).
+of the planned TT3 syntax is supported as well as most of that of
+HTML::Template::Expr. The following is a list of some of the ways
+that the configuration and syntax of CET are different from that of
+TT2. Note: items that are planned to work in TT3 are marked with
+(TT3).
=over 4
-=item Numerical hash keys work
+=item
+
+Numerical hash keys work
[% a = {1 => 2} %]
-=item Quoted hash key interpolation is fine
+=item
+
+Quoted hash key interpolation is fine
[% a = {"$foo" => 1} %]
-=item Multiple ranges in same constructor
+=item
+
+Multiple ranges in same constructor
[% a = [1..10, 21..30] %]
-=item Constructor types can call virtual methods. (TT3)
+=item
+
+Constructor types can call virtual methods. (TT3)
[% a = [1..10].reverse %]
[% {a => b}.size %] # = 1
-=item The "${" and "}" variable interpolators can contain expressions,
+=item
+
+The "${" and "}" variable interpolators can contain expressions,
not just variables.
[% [0..10].${ 1 + 2 } %] # = 4
[% color = qw/Red Blue/; FOR [1..4] ; color.${ loop.index % color.size } ; END %]
# = RedBlueRedBlue
-=item You can use regular expression quoting.
+=item
+
+You can use regular expression quoting.
[% "foo".match( /(F\w+)/i ).0 %] # = foo
-=item Tags can be nested.
+=item
+
+Tags can be nested.
[% f = "[% (1 + 2) %]" %][% f|eval %] # = 3
-=item Arrays can be accessed with non-integer numbers.
+=item
+
+Arrays can be accessed with non-integer numbers.
[% [0..10].${ 2.3 } %] # = 3
-=item Reserved names are less reserved. (TT3)
+=item
+
+Reserved names are less reserved. (TT3)
[% GET GET %] # gets the variable named "GET"
[% GET $GET %] # gets the variable who's name is stored in "GET"
-=item Filters and SCALAR_OPS are interchangeable. (TT3)
+=item
+
+Filters and SCALAR_OPS are interchangeable. (TT3)
[% a | length %]
[% b . lower %]
-=item Pipe "|" can be used anywhere dot "." can be and means to call
+=item
+
+Pipe "|" can be used anywhere dot "." can be and means to call
the virtual method. (TT3)
[% a = {size => "foo"} %][% a.size %] # = foo
[% a = {size => "foo"} %][% a|size %] # = 1 (size of hash)
-=item Pipe "|" and "." can be mixed. (TT3)
+=item
+
+Pipe "|" and "." can be mixed. (TT3)
[% "aa" | repeat(2) . length %] # = 4
-=item Added V2PIPE configuration item
+=item
+
+Added V2PIPE configuration item
Restores the behavior of the pipe operator to be
compatible with TT2.
[% PROCESS a | repeat(2) %] # = process block or file named a ~ a
-=item Added Virtual Object Namespaces. (TT3)
+=item
+
+Added V2EQUALS configuration item
+
+Allows for turning off TT2 "==" behavior. Defaults to 1
+in TT syntaxes and to 0 in HT syntaxes.
+
+ [% CONFIG V2EQUALS => 1 %][% ('7' == '7.0') || 0 %]
+ [% CONFIG V2EQUALS => 0 %][% ('7' == '7.0') || 0 %]
+
+Prints
+
+ 0
+ 1
+
+=item
+
+Added Virtual Object Namespaces. (TT3)
The Text, List, and Hash types give direct access
to virtual methods.
| Hash.keys
| List.join(", ") %] # = a, b
-=item Added "fmt" scalar, list, and hash virtual methods.
+=item
+
+Added "fmt" scalar, list, and hash virtual methods.
[% list.fmt("%s", ", ") %]
[% hash.fmt("%s => %s", "\n") %]
-=item Whitespace is less meaningful. (TT3)
+=item
+
+Added missing HTML::Template::Expr vmethods
+
+The following vmethods were added - they correspond to the
+perl functions of the same name.
+
+ abs
+ atan2
+ cos
+ exp
+ hex
+ lc
+ log
+ oct
+ sin
+ sprintf
+ sqrt
+ srand
+ uc
+
+=item
+
+Allow all Scalar vmethods to behave as top level functions.
+
+ [% sprintf("%d %d", 7, 8) %] # = "7 8"
+
+The following are equivalent in CET:
+
+ [% "abc".length %]
+ [% length("abc") %]
+
+This feature may be disabling by setting the
+VMETHOD_FUNCTIONS configuration item to 0.
+
+This is similar to how HTML::Template::Expr operates, but
+now you can use this functionality in TT templates as well.
+
+=item
+
+Whitespace is less meaningful. (TT3)
[% 2-1 %] # = 1 (fails in TT2)
-=item Added pow operator.
+=item
+
+Added pow operator.
[% 2 ** 3 %] [% 2 pow 3 %] # = 8 8
-=item Added self modifiers (+=, -=, *=, /=, %=, **=, ~=). (TT3)
+=item
+
+Added string comparison operators (gt ge lt le cmp)
+
+ [% IF "a" lt "b" %]a is less[% END %]
+
+=item
+
+Added numeric comparison operator (<=>)
+
+This can be used to make up for the fact that TT2 made == the
+same as eq (which will hopefully change - use eq when you mean eq).
+
+ [% IF ! (a <=> b) %]a == b[% END %]
+
+ [% IF (a <=> b) %]a != b[% END %]
+
+=item
+
+Added self modifiers (+=, -=, *=, /=, %=, **=, ~=). (TT3)
[% a = 2; a *= 3 ; a %] # = 6
[% a = 2; (a *= 3) ; a %] # = 66
-=item Added pre and post increment and decrement (++ --). (TT3)
+=item
+
+Added pre and post increment and decrement (++ --). (TT3)
[% ++a ; ++a %] # = 12
[% a-- ; a-- %] # = 0-1
-=item Added qw// contructor. (TT3)
+=item
+
+Added qw// contructor. (TT3)
[% a = qw(a b c); a.1 %] # = b
[% qw/a b c/.2 %] # = c
-=item Added regex contructor. (TT3)
+=item
+
+Added regex contructor. (TT3)
[% "FOO".match(/(foo)/i).0 %] # = FOO
[% a = /(foo)/i; "FOO".match(a).0 %] # = FOO
-=item Allow for scientific notation. (TT3)
+=item
+
+Allow for scientific notation. (TT3)
[% a = 1.2e-20 %]
[% 123.fmt('%.3e') %] # = 1.230e+02
-=item Allow for hexidecimal input. (TT3)
+=item
+
+Allow for hexidecimal input. (TT3)
[% a = 0xff0000 %][% a %] # = 16711680
[% a = 0xff2 / 0xd; a.fmt('%x') %] # = 13a
-=item FOREACH variables can be nested.
+=item
+
+FOREACH variables can be nested.
[% FOREACH f.b = [1..10] ; f.b ; END %]
Note that nested variables are subject to scoping issues.
f.b will not be reset to its value before the FOREACH.
-=item Post operative directives can be nested. (TT3)
+=item
+
+Post operative directives can be nested. (TT3)
Andy Wardley calls this side-by-side effect notation.
[% a = [[1..3], [5..7]] %][% i FOREACH i = j FOREACH j = a %] # = 123567
-=item Semi-colons on directives in the same tag are optional. (TT3)
+=item
+
+Semi-colons on directives in the same tag are optional. (TT3)
[% SET a = 1
GET a
2
END %] # prints 1
-=item CATCH blocks can be empty.
+Note2: This behavior can be disabled by setting the SEMICOLONS
+configuration item to a true value. If SEMICOLONS is true, then
+a SEMICOLON must be set after any directive that isn't followed
+by a post-operative directive.
+
+=item
+
+CATCH blocks can be empty.
TT2 requires them to contain something.
-=item Added a DUMP directive.
+=item
+
+Added a DUMP directive.
Used for Data::Dumpering the passed variable or expression.
[% DUMP a.a %]
-=item Added CONFIG directive.
+=item
+
+Added CONFIG directive.
[% CONFIG
ANYCASE => 1
PRE_CHOMP => '-'
%]
-=item Configuration options can use lowercase names instead
+=item
+
+Configuration options can use lowercase names instead
of the all uppercase names that TT2 uses.
my $t = CGI::Ex::Template->new({
interpolate => 1,
});
-=item CET does not generate Perl code.
+=item
+
+Added LOOP directive (works the same as LOOP in HTML::Template.
+
+ [%- var = [{key => 'a'}, {key => 'b'}] %]
+ [%- LOOP var %]
+ ([% key %])
+ [%- END %]
+
+ Prints
+
+ (a)
+ (b)
+
+=item
+
+CET can parse HTML::Template and HTML::Template::Expr documents
+as well as TT2 and TT3 documents.
+
+=item
+
+Added SYNTAX configuration. The SYNTAX configuration can be
+used to change what template syntax will be used for parsing
+included templates or eval'ed strings.
+
+ [% CONFIG SYNTAX => 'hte' %]
+ [% var = '<TMPL_VAR EXPR="sprintf('%s', 'hello world')">' %]
+ [% var | eval %]
+
+=item
+
+CET does not generate Perl code.
It generates an "opcode" tree. The opcode tree is an arrayref
of scalars and array refs nested as deeply as possible. This "simple"
structure could be shared TT implementations in other languages
via JSON or YAML.
-=item CET uses storable for its compiled templates.
+=item
+
+CET uses storable for its compiled templates.
If EVAL_PERL is off, CET will not eval_string on ANY piece of information.
-=item There is eval_filter and MACRO recursion protection
+=item
+
+There is eval_filter and MACRO recursion protection
You can control the nested nature of eval_filter and MACRO
recursion using the MAX_EVAL_RECURSE and MAX_MACRO_RECURSE
configuration items.
-=item There is no context.
+=item
+
+There is no context.
CET provides a context object that mimics the Template::Context
interface for use by some TT filters, eval perl blocks, views,
and plugins.
-=item There is no stash.
+=item
+
+There is no stash.
Well there is but it isn't an object.
mimics the Template::Stash interface for use by some TT filters, eval
perl blocks, and plugins.
-=item There is no provider.
+=item
+
+There is no provider.
CET uses the load_parsed_tree method to get and cache templates.
-=item There is no parser/grammar.
+=item
+
+There is no parser/grammar.
CET has its own built-in recursive regex based parser and grammar system.
module uses the output of parse_tree to generate a TT style compiled perl
document.
-=item The DEBUG directive is more limited.
+=item
+
+The DEBUG directive is more limited.
It only understands DEBUG_DIRS (8) and DEBUG_UNDEF (2).
-=item CET has better line information
+=item
+
+CET has better line information
When debug dirs is on, directives on different lines separated
by colons show the line they are on rather than a general line range.
=back
+=head1 HOW IS CGI::Ex::Template DIFFERENT from HTML::Template
+
+CET can use the same base template syntax and configuration items as HTE
+and HT. The internals of CET were written to support TT3, but were
+general enough to be extended to support HTML::Template as well. The result
+is HTML::Template::Expr compatible syntax, with CET speed and a wide range
+of additional features.
+
+The TMPL_VAR, TMPL_IF, TMPL_ELSE, TMPL_UNLESS, TMPL_LOOP, and TMPL_INCLUDE
+all work identically to HTML::Template.
+
+=over 4
+
+=item
+
+Added support for other TT3 directives and for TT style "dot notation."
+
+ <TMPL_SET a = "bar">
+ <TMPL_SET b = [1 .. 25]>
+ <TMPL_SET foo = PROCESS 'filename.tt'>
+
+ <TMPL_GET foo> # similar to <TMPL_VAR NAME="foo">
+ <TMPL_GET b.3>
+ <TMPL_GET my.nested.chained.variable.1>
+ <TMPL_GET my_var | html>
+
+ <TMPL_USE foo = DBI(db => ...)>
+ <TMPL_CALL foo.connect>
+
+Any of the TT directives can be used in HTML::Template documents.
+
+For many die-hard HTML::Template fans, it is probably quite scary to
+be providing all of the TT functionality. All of the extended
+TT functionality can be disabled by setting the NO_TT configuration
+item. The NO_TT configuration is automatically set if the SYNTAX is
+set to "ht" and the output method is called.
+
+=item
+
+There is an ELSIF!!!
+
+ <TMPL_IF foo>
+ FOO
+ <TMPL_ELSIF bar>
+ BAR
+ <TMPL_ELSE>
+ Done then
+ </TMPL_IF>
+
+=item
+
+Added CHOMP capabilities (PRE_CHOMP and POST_CHOMP)
+
+ Foo
+ <~TMPL_VAR EXPR="1+2"~>
+ Bar
+
+ Prints Foo3Bar
+
+=item
+
+Added INTERPOLATE capability
+
+ <TMPL_SET foo = 'FOO'>
+ <TMPL_CONFIG INTERPOLATE => 1>
+ $foo <TMPL_GET foo> ${ 1 + 2 }
+
+ Prints
+
+ FOO FOO 3
+
+=item
+
+Allow for HTML::Template templates to include TT style templates.
+
+ <TMPL_CONFIG SYNTAX => 'tt3'>
+ <TMPL_INCLUDE "filename.tt">
+
+=item
+
+Allow for Expr parsing to follow proper precedence rules.
+
+ <TMPL_VAR EXPR="1 + 2 * 3">
+
+ Properly prints 7.
+
+=item
+
+Uses all of the caching and opcode tree optimations provided by
+CGI::Ex::Template and CGI::Ex::Template::XS.
+
+=item
+
+CET does not provide the query method from HTML::Template. This
+is because parsing of the document is delayed until the output
+method is called, and because CET supports TT style chained
+variables which often are not resolvable until run time.
+
+=back
+
=head1 VARIABLES
This section discusses how to use variables and expressions in the TT
hashref as the second argument to the process method, or by setting
the "VARIABLES" or "PRE_DEFINE" configuration variables.
+If you are using the HT and HTE syntaxes, the VAR, IF, UNLESS,
+LOOP, and INCLUDE directives will accept a NAME attribute which may
+only be a single level (non-chained) HTML::Template variable name, or
+they may accept an EXPR attribute which may be any valid TT3 variable or expression.
+
+The following are some sample ways to access variables.
+
### some sample variables
my %vars = (
one => '1.0',
[% 1 + 2 * 3 %] Prints 7
[% (1 + 2) * 3 %] Prints 9
- [% x = 2 %]
+ [% x = 2 %] # assignments don't return anything
+ [% (x = 2) %] Prints 2 # unless they are in parens
[% y = 3 %]
- [% z = x * (y - 1) %] Prints 4
+ [% x * (y - 1) %] Prints 4
=head1 VIRTUAL METHODS
Scalar virtual methods are also available through the "Text" virtual
object (except for true filters such as eval and redirect).
+All scalar virtual methods are available as top level functions as well.
+This is not true of TT2. In CGI::Ex::Template the following are equivalent:
+
+ [% "abc".length %]
+ [% length("abc") %]
+
+You may set VMETHOD_FUNCTIONS to 0 to disable this behavior.
+
=over 4
=item '0'
Allows for scalars to mask as arrays (scalars already will, but this
allows for more direct access).
+=item abs
+
+ [% -1.abs %] Returns the absolute value
+
+=item atan2
+
+ [% pi = 4 * 1.atan2(1) %]
+
+Returns the arctangent. The item itself represents Y, the passed argument represents X.
+
=item chunk
[% item.chunk(60).join("\n") %] Split string up into a list of chunks of text 60 chars wide.
[% item.collapse %] Strip leading and trailing whitespace and collapse all other space to one space.
-=item defined
-
- [% item.defined %] Always true - because the undef sub translates all undefs to ''.
+=item cos
-=item indent
+ [% item.cos %] Returns the cosine of the item.
- [% item.indent(3) %] Indent that number of spaces.
+=item defined
- [% item.indent("Foo: ") %] Add the string "Foo: " to the beginning of every line.
+ [% item.defined %] Always true - because the undef sub translates all undefs to ''.
=item eval
Same as the eval filter.
+=item exp
+
+ [% 1.exp %] Something like 2.71828182845905
+
+Returns "e" to the power of the item.
+
=item file
Same as the redirect filter.
[% item.fmt('%*s', 6) %]
Similar to format. Returns a string formatted with the passed pattern. Default pattern is %s.
+Opposite from of the sprintf vmethod.
=item format
[% item.hash %] Returns a one item hash with a key of "value" and a value of the item.
+
+=item hex
+
+ [% "FF".hex %]
+
+Returns the decimal value of the passed hex numbers. Note that you
+may also just use [% 0xFF %].
+
=item html
[% item.html %] Performs a very basic html encoding (swaps out &, <, > and " for the html entities)
+=item indent
+
+ [% item.indent(3) %] Indent that number of spaces.
+
+ [% item.indent("Foo: ") %] Add the string "Foo: " to the beginning of every line.
+
=item int
[% item.int %] Return the integer portion of the value (0 if none).
+=item lc
+
+Same as the lower vmethod. Returns the lower cased version of the item.
+
=item lcfirst
[% item.lcfirst %] Capitalize the leading letter.
[% item.list %] Returns a list with a single value of the item.
+=item log
+
+ [% 8.exp.log %] Equal to 8.
+
+Returns the natural log base "e" of the item.
+
=item lower
[% item.lower %] Return a lower-casified string.
[% item.null %] Do nothing.
+=item oct
+
+ [% "377".oct %]
+
+Returns the decimal value of the octal string. On recent versions of perl you
+may also pass numbers starting with 0x which will be interpreted as hexidecimal,
+and starting with 0b which will be interpreted as binary.
+
=item rand
[% item = 10; item.rand %] Returns a number greater or equal to 0 but less than 10.
[% item.search(/(\w+)/, "($1)") %] Same as before.
+=item sin
+
+ [% item.sin %] Returns the sine of the item.
+
=item size
[% item.size %] Always returns 1.
[% item.split( /\s+/, 3 ) %] Same as before.
+=item sprintf
+
+ [% item = "%d %d" %]
+ [% item.sprintf(7, 8) %]
+
+Uses the pattern stored in self, and passes it to sprintf with the passed arguments.
+Opposite from the fmt vmethod.
+
+=item sqrt
+
+ [% item.sqrt %]
+
+Returns the square root of the number.
+
+=item srand
+
+Calls the perl srand function to set the interal random seed. This
+will affect future calls to the rand vmethod.
+
=item stderr
[% item.stderr %] Print the item to the current STDERR handle.
[% item.trim %] Strips leading and trailing whitespace.
+=item uc
+
+Same as the upper command. Returns upper cased string.
+
=item ucfirst
[% item.ucfirst %] Lower-case the leading letter.
=item upper
- [% item.upper %] Return a upper-casified string.
+ [% item.upper %] Return a upper cased string.
=item uri
references to the $SCALAR_OPS, $LIST_OPS, and $HASH_OPS hashes
found in the $VOBJS hash of CGI::Ex::Template.
-=head1 DIRECTIVES
+=head1 DIRECTIVES (TT Style)
This section contains the alphabetical list of DIRECTIVES available in
the TT language. DIRECTIVES are the "functions" and control
POST_CHOMP
V1DOLLAR
V2PIPE
+ V2EQUALS
The following runtime configuration options may be set:
DUMP
+ VMETHOD_FUNCTIONS
If non-named parameters as passed, they will show the current configuration:
[% 'A equaled B' IF a == b %]
+Note: If you are using HTML::Template style documents, the TMPL_IF
+tag parses using the limited HTML::Template parsing rules. However,
+you may use EXPR="" to embed a TT3 style expression.
+
=item C<INCLUDE>
Parse the contents of a file or block and insert them. Variables defined
Used to exit out of a WHILE or FOREACH loop.
+=item C<LOOP>
+
+This directive operates similar to the HTML::Template loop directive.
+The LOOP directive expects a single variable name. This variable name
+should point to an arrayref of hashrefs. The keys of each hashref
+will be added to the variable stash when it is iterated.
+
+ [% var a = [{b => 1}, {b => 2}, {b => 3}] %]
+
+ [% LOOP a %] ([% b %]) [% END %]
+
+Would print:
+
+ (1) (2) (3)
+
+If CET is in HT mode and GLOBAL_VARS is false, the contents of
+the hashref will be the only items available during the loop iteration.
+
+If LOOP_CONTEXT_VARS is true, and $QR_PRIVATE is false (default when
+called through the output method), then the variables __first__, __last__,
+ __inner__, __odd__, and __counter__ will be set. See the HTML::Template
+loop_context_vars configuration item for more information.
+
=item C<MACRO>
Takes a directive and turns it into a variable that can take arguments.
=back
+=head1 DIRECTIVES (HTML::Template Style)
+
+HTML::Template templates use directives that look similar to the
+following:
+
+ <TMPL_VAR NAME="foo">
+
+ <TMPL_IF NAME="bar">
+ BAR
+ </TMPL_IF>
+
+The normal set of HTML::Template directives are TMPL_VAR,
+TMPL_IF, TMPL_ELSE, TMPL_UNLESS, TMPL_INCLUDE, and TMPL_LOOP.
+These tags should have either a NAME attribute, an EXPR attribute,
+or a bare variable name that is used to specify the value to
+be operated. If a NAME is specified, it may only be a single
+level value (as opposed to a TT chained variable). In the case
+of the TMPL_INCLUDE directive, the NAME is the file to be included.
+
+In CET, the EXPR attribute can be used with any of these types to
+specify TT compatible variable or expression that will be used for
+the value.
+
+ <TMPL_VAR NAME="foo"> Prints the value contained in foo
+ <TMPL_VAR foo> Prints the value contained in foo
+ <TMPL_VAR EXPR="foo"> Prints the value contained in foo
+
+ <TMPL_VAR NAME="foo.bar.baz"> Prints the value contained in {'foo.bar.baz'}
+ <TMPL_VAR EXPR="foo.bar.baz"> Prints the value contained in {foo}->{bar}->{baz}
+
+ <TMPL_IF foo> Prints FOO if foo is true
+ FOO
+ </TMPL_IF
+
+ <TMPL_UNLESS foo> Prints FOO unless foo is true
+ FOO
+ </TMPL_UNLESS
+
+ <TMPL_INCLUDE NAME="foo.ht"> Includes the template in "foo.ht"
+
+ <TMPL_LOOP foo> Iterates on the arrayref foo
+ <TMPL_VAR name>
+ </TMPL_LOOP>
+
+CGI::Ex::Template makes all of the other TT3 directives available
+in addition to the normal set of HTML::Template directives. For
+example, the following is valid in CET.
+ <TMPL_MACRO bar(n) BLOCK>You said <TMPL_VAR n></TMPL_MACRO>
+ <TMPL_GET bar("hello")>
+
+The TMPL_VAR tag may also include an optional ESCAPE attribute.
+This specifies how the value of the tag should be escaped prior
+to substituting into the template.
+
+ Escape value | Type of escape
+ ---------------------------------
+ HTML, 1 | HTML encoding
+ URL | URL encoding
+ JS | basic javascript encoding (\n, \r, and \")
+ NONE, 0 | No encoding (default).
+
+The TMPL_VAR tag may also include an optional DEFAULT attribute
+that contains a string that will be used if the variable returns
+false.
+
+ <TMPL_VAR foo DEFAULT="Foo was false">
=head1 OPERATORS
Non associative binary. String comparators.
-=item C<== eq>
+=item C<eq>
+
+Non associative binary. String equality test.
+
+=item C<==>
+
+Non associative binary. In TT syntaxes the V2EQUALS configuration
+item defaults to true which means this operator will operate
+the same as the "eq" operator. Setting V2EQUALS to 0 will
+change this operator to mean numeric equality. You could also use [% ! (a <=> b) %]
+but that is a bit messy.
+
+The HTML::Template syntaxes default V2EQUALS to 0 which means
+that it will test for numeric equality just as you would normally
+expect.
+
+In either case - you should always use "eq" when you mean "eq".
+The V2EQUALS will most likely eventually default to 0.
+
+=item C<ne>
+
+Non associative binary. String non-equality test.
+
+=item C<!=>
-Non associative binary. Equality test. TT chose to use Perl's eq for both operators.
-There is no test for numeric equality.
+Non associative binary. In TT syntaxes the V2EQUALS configuration
+item defaults to true which means this operator will operate
+the same as the "ne" operator. Setting V2EQUALS to 0 will
+change this operator to mean numeric non-equality.
+You could also use [% (a <=> b) %] but that is a bit messy.
-=item C<!= ne>
+The HTML::Template syntaxes default V2EQUALS to 0 which means
+that it will test for numeric non-equality just as you would
+normally expect.
-Non associative binary. Non-equality test. TT chose to use Perl's ne for both
-operators. There is no test for numeric non-equality.
+In either case - you should always use "ne" when you mean "ne".
+The V2EQUALS will most likely eventually default to 0.
+
+=item C<< <=> >>
+
+Non associative binary. Numeric comparison operator. Returns -1 if the first argument is
+less than the second, 0 if they are equal, and 1 if the first argument is greater.
+
+=item C<< cmp >>
+
+Non associative binary. String comparison operator. Returns -1 if the first argument is
+less than the second, 0 if they are equal, and 1 if the first argument is greater.
=item C<&&>
Hello.Hi.Howdy.
-=head1 CONFIGURATION
+=head1 CONFIGURATION (TT STYLE)
The following TT2 configuration variables are supported (in
alphabetical order). Note: for further discussion you can refer to
the TT config documentation.
+Items may be passed in upper or lower case.
+
These variables should be passed to the "new" constructor.
my $obj = CGI::Ex::Template->new(
Boolean. Default false. If true, allows filenames to be specified
that are relative to the currently running process.
+=item SEMICOLONS
+
+Boolean. Default fast. If true, then the syntax will require that
+semi-colons separate multiple directives in the same tag. This is
+useful for keeping the syntax a little more clean as well as trouble
+shooting some errors.
+
=item START_TAG
Set a string to use as the opening delimiter for TT. Default is "[%".
fewer file system accesses. Setting it to a negative number will allow
for the file system to be checked every hit.
+=item SYNTAX (not in TT)
+
+Defaults to "cet". Indicates the syntax that will be used for parsing
+included templates or eval'ed strings. You can use the CONFIG
+directive to change the SYNTAX on the fly (it will not affect
+the syntax of the document currently being parsed).
+
+The syntax may be passed in upper or lower case.
+
+The available choices are:
+
+ cet - CGI::Ex::Template style - the same as TT3
+ tt3 - Template::Toolkit ver3 - same as CET
+ tt2 - Template::Toolkit ver2 - almost the same as TT3
+ tt1 - Template::Toolkit ver1 - almost the same as TT2
+ ht - HTML::Template - same as HTML::Template::Expr without EXPR
+ hte - HTML::Template::Expr
+
+Passing in a different syntax allows for the process method
+to use a non-TT syntax and for the output method to use a non-HT
+syntax.
+
+The following is a sample of HTML::Template interface usage parsing
+a Template::Toolkit style document.
+
+ my $obj = CGI::Ex::Template->new(filename => 'my/template.tt'
+ syntax => 'cet');
+ $obj->param(\%swap);
+ print $obj->output;
+
+The following is a sample of Template::Toolkit interface usage parsing
+a HTML::Template::Expr style document.
+
+ my $obj = CGI::Ex::Template->new(SYNTAX => 'hte');
+ $obj->process('my/template.ht', \%swap);
+
+You can use the define_syntax method to add another custom syntax to
+the list of available options.
+
=item TAG_STYLE
Allow for setting the type of tag delimiters to use for parsing the TT.
"Text: ${foo}" "Text: ${foo}"
"Text: ${$foo}" "Text: ${foo}"
+=item V2EQUALS
+
+Default 1 in TT syntaxes, defaults to 0 in HTML::Template syntaxes.
+
+If set to 1 then "==" is an alias for "eq" and "!= is an alias for
+"ne".
+
+ [% CONFIG V2EQUALS => 1 %][% ('7' == '7.0') || 0 %]
+ [% CONFIG V2EQUALS => 0 %][% ('7' == '7.0') || 0 %]
+
+ Prints
+
+ 0
+ 1
+
=item V2PIPE
Restores the behavior of the pipe operator to be compatible with TT2.
variables are available for use in any of the executed templates.
See the section on VARIABLES for the types of information that can be passed in.
+=item VMETHOD_FUNCTIONS
+
+Defaults to 1. All scalar virtual methods are available as top level functions as well.
+This is not true of TT2. In CGI::Ex::Template the following are equivalent:
+
+ [% "abc".length %]
+ [% length("abc") %]
+
+You may set VMETHOD_FUNCTIONS to 0 to disable this behavior.
+
=item WRAPPER
Operates similar to the WRAPPER directive. The option can be given a
=back
+=head1 CONFIGURATION (HTML::Template STYLE)
+
+The following HTML::Template and HTML::Template::Expr
+configuration variables are supported (in HTML::Template documentation order).
+Note: for further discussion you can refer to the HT documentation.
+Many of the variables mentioned in the TT CONFIGURATION section
+apply here as well. Unless noted, these items only apply when
+using the output method.
+
+Items may be passed in upper or lower case.
+
+These variables should be passed to the "new" constructor.
+
+ my $obj = CGI::Ex::Template->new(
+ type => 'filename',
+ source => 'my/template.ht',
+ die_on_bad_params => 1,
+ loop_context_vars => 1,
+ global_vars => 1
+ post_chomp => "=",
+ pre_chomp => "-",
+ );
+
+=over 4
+
+=item type
+
+Can be one of filename, filehandle, arrayref, or scalarref. Indicates what type
+of input is in the "source" configuration item.
+
+=item source
+
+Stores where to read the input file. The type is specified in the "type"
+configuration item.
+
+=item filename
+
+Indicates a filename to read the template from. Same as putting the
+filename in the "source" item and setting "type" to "filename".
+
+Must be set to enable caching.
+
+=item filehandle
+
+Should contain an open filehandle to read the template from. Same as
+putting the filehandle in the "source" item and setting "type" to "filehandle".
+
+Will not be cached.
+
+=item arrayref
+
+Should contain an arrayref whose values are the lines of the template. Same as
+putting the arrayref in the "source" item and setting "type" to "arrayref".
+
+Will not be cached.
+
+=item scalarref
+
+Should contain an reference to a scalar that contains the template. Same as
+putting the scalar ref in the "source" item and setting "type" to "scalarref".
+
+Will not be cached.
+
+=item cache
+
+If set to one, then CET will use a global, in-memory document cache
+to store compiled templates in between calls. This is generally only
+useful in a mod_perl environment. The document is checked for a different
+modification time at each request.
+
+=item blind_cache
+
+Same as with cache enabled, but will not check if the document has
+been modified.
+
+=item file_cache
+
+If set to 1, will cache the compiled document on the file system. If
+true, file_cache_dir must be set.
+
+=item file_cache_dir
+
+The directory where to store cached documents when file_cache is true.
+This is similar to the TT compile_dir option.
+
+=item double_file_cache
+
+Uses a combination of file_cache and cache.
+
+=item path
+
+Same as INCLUDE_PATH when using the process method.
+
+=item associate
+
+May be a single CGI object or an arrayref of objects. The params
+from these objects will be added to the params during the
+output call.
+
+=item case_sensitive
+
+Allow passed variables set through the param method, or the
+associate configuration to be used case sensitively. Default is
+off. It is highly suggested that this be set to 1.
+
+=item loop_context_vars
+
+Default false. When true, calls to the loop directive will
+create the following variables that give information about the
+current iteration of the loop:
+
+ __first__ - True on first iteration only
+ __last__ - True on last iteration only
+ __inner__ - True on any iteration that isn't first or last
+ __odd__ - True on odd iterations
+ __counter__ - The iteration count
+
+These variables are also available to LOOPs run under
+TT syntax if loop_context_vars is set and if QR_PRIVATE is set to 0.
+
+=item no_includes
+
+Default false. If true, calls to INCLUDE, PROCESS, WRAPPER and INSERT
+will fail. This option is also available when using the process method.
+
+=item global_vars.
+
+Default true in HTE mode. Default false in HT. Allows top level
+variables to be used in LOOPs. When false, only variables defined
+in the current LOOP iteration hashref will be available.
+
+=item default_escape
+
+Controls the type of escape used on named variables in TMPL_VAR
+directives. Can be one of HTML, URL, or JS. The values of
+TMPL_VAR directives will be encoded with this type unless
+they specify their own type via an ESCAPE attribute.
+
+=back
+
+=head1 UNSUPPORTED HT CONFIGURATION
+
+=over 4
+
+=item die_on_bad_params
+
+CET does not resolve variables until the template is output.
+
+=item force_untaint
+
+=item strict
+
+CET is strict on parsing HT documents.
+
+=item shared_cache, double_cache
+
+CET doesn't have shared caching. Yet.
+
+=item search_path_on_include
+
+CET will check the full path array on each include.
-=head1 UNSUPPORTED TT CONFIGURATION
+=item debug items
+
+The HTML::Template style options are included here, but you
+can use the TT style DEBUG and DUMP directives to do intropection.
+
+=item max_includes
+
+CET uses TT's recursion protection.
+
+=item filter
+
+CET doesn't offer these.
+
+=back
+
+=head1 UNSUPPORTED TT2 CONFIGURATION
=over 4
Used to create a "pseudo" context object that allows for portability
of TT plugins, filters, and perl blocks that need a context object.
-=item C<DEBUG>
-
-TT2 Holdover that is used once for binmode setting during a TT2 test.
-
=item C<debug_node>
Used to get debug info on a directive if DEBUG_DIRS is set.
--- /dev/null
+package CGI::Ex::Template::Extra;
+
+=head1 NAME
+
+CGI::Ex::Template::Extra - load extra and advanced features that aren't as commonly used
+
+=head1 DESCRIPTION
+
+Provides for extra or extended features that may not be as commonly used.
+This module should not normally be used by itself.
+
+=head1 AUTHOR
+
+Paul Seamons <paul at seamons dot com>
+
+=head1 LICENSE
+
+This module may be distributed under the same terms as Perl itself.
+
+=cut
+
+use strict;
+use warnings;
+
+our $VERSION = '2.13';
+
+sub parse_CONFIG {
+ my ($self, $str_ref) = @_;
+
+ my %ctime = map {$_ => 1} @CGI::Ex::Template::CONFIG_COMPILETIME;
+ my %rtime = map {$_ => 1} @CGI::Ex::Template::CONFIG_RUNTIME;
+
+ my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1});
+ my $ref = $config->[0]->[0];
+ for (my $i = 2; $i < @$ref; $i += 2) {
+ my $key = $ref->[$i] = uc $ref->[$i];
+ my $val = $ref->[$i + 1];
+ if ($ctime{$key}) {
+ $self->{$key} = $self->play_expr($val);
+ } elsif (! $rtime{$key}) {
+ $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
+ }
+ }
+ for (my $i = 1; $i < @$config; $i++) {
+ my $key = $config->[$i] = uc $config->[$i]->[0];
+ if ($ctime{$key}) {
+ $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef');
+ } elsif (! $rtime{$key}) {
+ $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
+ }
+ }
+ return $config;
+}
+
+sub play_CONFIG {
+ my ($self, $config, $node, $out_ref) = @_;
+
+ my %rtime = map {$_ => 1} @CGI::Ex::Template::CONFIG_RUNTIME;
+
+ ### do runtime config - not many options get these
+ my ($named, @the_rest) = @$config;
+ $named = $self->play_expr($named);
+ @{ $self }{keys %$named} = @{ $named }{keys %$named};
+
+ ### show what current values are
+ $$out_ref .= join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest);
+ return;
+}
+
+sub parse_DEBUG {
+ my ($self, $str_ref) = @_;
+ $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx
+ || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref));
+ my $ret = [lc($1)];
+ if ($ret->[0] eq 'format') {
+ $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs
+ || $self->throw('parse', "Missing format string", undef, pos($$str_ref));
+ $ret->[1] = $2;
+ }
+ return $ret;
+}
+
+sub play_DEBUG {
+ my ($self, $ref) = @_;
+ if ($ref->[0] eq 'on') {
+ delete $self->{'_debug_off'};
+ } elsif ($ref->[0] eq 'off') {
+ $self->{'_debug_off'} = 1;
+ } elsif ($ref->[0] eq 'format') {
+ $self->{'_debug_format'} = $ref->[1];
+ }
+ return;
+}
+
+sub play_DUMP {
+ my ($self, $dump, $node, $out_ref) = @_;
+
+ my $conf = $self->{'DUMP'};
+ return if ! $conf && defined $conf; # DUMP => 0
+ $conf = {} if ref $conf ne 'HASH';
+
+ ### allow for handler override
+ my $handler = $conf->{'handler'};
+ if (! $handler) {
+ require Data::Dumper;
+ my $obj = Data::Dumper->new([]);
+ my $meth;
+ foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) }
+ my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1;
+ $obj->Sortkeys(sub { my $h = shift; [grep {$_ !~ $CGI::Ex::Template::QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] });
+ $handler = sub { $obj->Values([@_]); $obj->Dump }
+ }
+
+ my ($named, @dump) = @$dump;
+ push @dump, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
+ $_ = $self->play_expr($_) foreach @dump;
+
+ ### look for the text describing what to dump
+ my $info = $self->node_info($node);
+ my $out;
+ if (@dump) {
+ $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump);
+ my $name = $info->{'text'};
+ $name =~ s/^[+=~-]?\s*DUMP\s+//;
+ $name =~ s/\s*[+=~-]?$//;
+ $out =~ s/\$VAR1/$name/;
+ } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) {
+ $out = '';
+ } else {
+ $out = $handler->($self->{'_vars'});
+ $out =~ s/\$VAR1/EntireStash/g;
+ }
+
+ if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) {
+ $out = $CGI::Ex::Template::SCALAR_OPS->{'html'}->($out);
+ $out = "<pre>$out</pre>";
+ $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out" if $conf->{'header'} || ! defined $conf->{'header'};
+ } else {
+ $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'};
+ }
+
+ $$out_ref .= $out;
+ return;
+}
+
+sub parse_FILTER {
+ my ($self, $str_ref) = @_;
+ my $name = '';
+ if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) {
+ $name = $1;
+ }
+
+ my $filter = $self->parse_expr($str_ref);
+ $filter = '' if ! defined $filter;
+
+ return [$name, $filter];
+}
+
+sub play_FILTER {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($name, $filter) = @$ref;
+
+ return '' if ! @$filter;
+
+ $self->{'FILTERS'}->{$name} = $filter if length $name;
+
+ my $sub_tree = $node->[4];
+
+ ### play the block
+ my $out = '';
+ eval { $self->execute_tree($sub_tree, \$out) };
+ die $@ if $@ && ref($@) !~ /Template::Exception$/;
+
+ my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it
+
+ return $CGI::Ex::Template::DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
+}
+
+sub parse_LOOP {
+ my ($self, $str_ref, $node) = @_;
+ return $self->parse_expr($str_ref)
+ || $self->throw('parse', 'Missing variable on LOOP directive', undef, pos($$str_ref));
+}
+
+sub play_LOOP {
+ my ($self, $ref, $node, $out_ref) = @_;
+
+ my $var = $self->play_expr($ref);
+ my $sub_tree = $node->[4];
+
+ my $global = ! $self->{'SYNTAX'} || $self->{'SYNTAX'} ne 'ht' || $self->{'GLOBAL_VARS'};
+
+ my $items = ref($var) eq 'ARRAY' ? $var : ! defined($var) ? [] : [$var];
+
+ my $i = 0;
+ for my $ref (@$items) {
+ ### setup the loop
+ $self->throw('loop', 'Scalar value used in LOOP') if $ref && ref($ref) ne 'HASH';
+ local $self->{'_vars'} = (! $global) ? ($ref || {}) : (ref($ref) eq 'HASH') ? {%{ $self->{'_vars'} }, %$ref} : $self->{'_vars'};
+ if ($self->{'LOOP_CONTEXT_VARS'} && ! $CGI::Ex::Template::QR_PRIVATE) {
+ $self->{'_vars'}->{'__counter__'} = ++$i;
+ $self->{'_vars'}->{'__first__'} = $i == 1 ? 1 : 0;
+ $self->{'_vars'}->{'__last__'} = $i == @$items ? 1 : 0;
+ $self->{'_vars'}->{'__inner__'} = $i == 1 || $i == @$items ? 0 : 1;
+ $self->{'_vars'}->{'__odd__'} = ($i % 2) ? 1 : 0;
+ }
+
+ ### execute the sub tree
+ eval { $self->execute_tree($sub_tree, $out_ref) };
+ if (my $err = $@) {
+ if (UNIVERSAL::isa($err, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
+ next if $err->type eq 'next';
+ last if $err->type =~ /last|break/;
+ }
+ die $err;
+ }
+ }
+
+ return;
+}
+
+sub parse_MACRO {
+ my ($self, $str_ref, $node) = @_;
+
+ my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $CGI::Ex::Template::QR_COMMENTS"});
+ $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name;
+ if (! ref $name) {
+ $name = [ $name, 0 ];
+ }
+
+ my $args;
+ if ($$str_ref =~ m{ \G \( \s* }gcx) {
+ $args = $self->parse_args($str_ref, {positional_only => 1});
+ $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
+ }
+
+ $node->[6] = 1; # set a flag to keep parsing
+ return [$name, $args];
+}
+
+sub play_MACRO {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($name, $args) = @$ref;
+
+ ### get the sub tree
+ my $sub_tree = $node->[4];
+ if (! $sub_tree || ! $sub_tree->[0]) {
+ $self->set_variable($name, undef);
+ return;
+ } elsif ($sub_tree->[0]->[0] eq 'BLOCK') {
+ $sub_tree = $sub_tree->[0]->[4];
+ }
+
+ my $self_copy = $self;
+ eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
+
+ ### install a closure in the stash that will handle the macro
+ $self->set_variable($name, sub {
+ ### macros localize
+ my $copy = $self_copy->{'_vars'};
+ local $self_copy->{'_vars'}= {%$copy};
+
+ ### prevent recursion
+ local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0;
+ my $max = $self_copy->{'MAX_MACRO_RECURSE'} || $CGI::Ex::Template::MAX_MACRO_RECURSE;
+ $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $max reached")
+ if ++$self_copy->{'_macro_recurse'} > $max;
+
+ ### set arguments
+ my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
+ my @positional = @_;
+ foreach my $var (@$args) {
+ $self_copy->set_variable($var, shift(@positional));
+ }
+ foreach my $name (sort keys %$named) {
+ $self_copy->set_variable([$name, 0], $named->{$name});
+ }
+
+ ### finally - run the sub tree
+ my $out = '';
+ $self_copy->execute_tree($sub_tree, \$out);
+ return $out;
+ });
+
+ return;
+}
+
+sub play_PERL {
+ my ($self, $info, $node, $out_ref) = @_;
+ $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
+
+ ### fill in any variables
+ my $perl = $node->[4] || return;
+ my $out = '';
+ $self->execute_tree($perl, \$out);
+ $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
+
+ ### try the code
+ my $err;
+ eval {
+ package CGI::Ex::Template::Perl;
+
+ my $context = $self->context;
+ my $stash = $context->stash;
+
+ ### setup a fake handle
+ local *PERLOUT;
+ tie *PERLOUT, 'CGI::Ex::Template::EvalPerlHandle', $out_ref;
+ my $old_fh = select PERLOUT;
+
+ eval $out;
+ $err = $@;
+
+ ### put the handle back
+ select $old_fh;
+
+ };
+ $err ||= $@;
+
+
+ if ($err) {
+ $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+
+ return;
+}
+
+sub play_RAWPERL {
+ my ($self, $info, $node, $out_ref) = @_;
+ $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
+
+ ### fill in any variables
+ my $tree = $node->[4] || return;
+ my $perl = '';
+ $self->execute_tree($tree, \$perl);
+ $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
+
+ ### try the code
+ my $err;
+ my $output = '';
+ eval {
+ package CGI::Ex::Template::Perl;
+
+ my $context = $self->context;
+ my $stash = $context->stash;
+
+ eval $perl;
+ $err = $@;
+ };
+ $err ||= $@;
+
+ $$out_ref .= $output;
+
+ if ($err) {
+ $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+
+ return;
+}
+
+sub parse_USE {
+ my ($self, $str_ref) = @_;
+
+ my $QR_COMMENTS = $CGI::Ex::Template::QR_COMMENTS;
+
+ my $var;
+ my $mark = pos $$str_ref;
+ if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))
+ && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment
+ || ((pos($$str_ref) = $mark) && 0)) # otherwise we need to rollback
+ ) {
+ $var = $_var;
+ }
+
+ my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"});
+ $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module;
+ $module =~ s/\./::/g;
+
+ my $args;
+ my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo;
+ $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1});
+
+ if ($open) {
+ $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
+ }
+
+ return [$var, $module, $args];
+}
+
+sub play_USE {
+ my ($self, $ref, $node, $out_ref) = @_;
+ my ($var, $module, $args) = @$ref;
+
+ ### get the stash storage location - default to the module
+ $var = $module if ! defined $var;
+ my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
+ pop @var; # remove the trailing '.'
+
+ 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
+
+ ### look for a plugin_base
+ my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
+ my $obj;
+
+ foreach my $base (ref($BASE) eq 'ARRAY' ? @$BASE : $BASE) {
+ my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
+ : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
+ : "${base}::${module}";
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+
+ ### try and load the module - fall back to bare module if allowed
+ if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
+ my $shape = $package->load;
+ my $context = $self->context;
+ $obj = $shape->new($context, map { $self->play_expr($_) } @args);
+ } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
+ $obj = $self->iterator($args[0]);
+ } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
+ foreach my $package (@packages) {
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+ eval {require $require} || next;
+ my $shape = $package->load;
+ my $context = $self->context;
+ $obj = $shape->new($context, map { $self->play_expr($_) } @args);
+ }
+ } elsif ($self->{'LOAD_PERL'}) {
+ my $require = "$module.pm";
+ $require =~ s|::|/|g;
+ if (eval {require $require}) {
+ $obj = $module->new(map { $self->play_expr($_) } @args);
+ }
+ }
+ }
+ if (! defined $obj) {
+ my $err = "$module: plugin not found";
+ $self->throw('plugin', $err);
+ }
+
+ ### all good
+ $self->set_variable(\@var, $obj);
+
+ return;
+}
+
+sub parse_VIEW {
+ my ($self, $str_ref) = @_;
+
+ my $ref = $self->parse_args($str_ref, {
+ named_at_front => 1,
+ require_arg => 1,
+ });
+
+ return $ref;
+}
+
+sub play_VIEW {
+ my ($self, $ref, $node, $out_ref) = @_;
+
+ my ($blocks, $args, $name) = @$ref;
+
+ ### get args ready
+ # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
+ $args = $args->[0];
+ my $hash = {};
+ foreach (my $i = 2; $i < @$args; $i+=2) {
+ my $key = $args->[$i];
+ my $val = $self->play_expr($args->[$i+1]);
+ if (ref $key) {
+ if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
+ $key = $key->[0];
+ } else {
+ $self->set_variable($key, $val);
+ next; # what TT does
+ }
+ }
+ $hash->{$key} = $val;
+ }
+
+ ### prepare the blocks
+ my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : '';
+ foreach my $key (keys %$blocks) {
+ $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}};
+ }
+ $hash->{'blocks'} = $blocks;
+
+ ### get the view
+ if (! eval { require Template::View }) {
+ $self->throw('view', 'Could not load Template::View library');
+ }
+ my $view = Template::View->new($self->context, $hash)
+ || $self->throw('view', $Template::View::ERROR);
+
+ ### 'play it'
+ my $old_view = $self->play_expr(['view', 0]);
+ $self->set_variable($name, $view);
+ $self->set_variable(['view', 0], $view);
+
+ if ($node->[4]) {
+ my $out = '';
+ $self->execute_tree($node->[4], \$out);
+ # throw away $out
+ }
+
+ $self->set_variable(['view', 0], $old_view);
+ $view->seal;
+
+ return;
+}
+
+###----------------------------------------------------------------###
+
+sub list_plugins {
+ my $self = shift;
+ my $args = shift || {};
+ my $base = $args->{'base'} || '';
+
+ return $self->{'_plugins'}->{$base} ||= do {
+ my @plugins;
+
+ $base =~ s|::|/|g;
+ my @dirs = grep {-d $_} map {"$_/$base"} @INC;
+
+ foreach my $dir (@dirs) {
+ require File::Find;
+ File::Find::find(sub {
+ my $mod = $base .'/'. ($File::Find::name =~ m|^ $dir / (.*\w) \.pm $|x ? $1 : return);
+ $mod =~ s|/|::|g;
+ push @plugins, $mod;
+ }, $dir);
+ }
+
+ \@plugins; # return of the do
+ };
+}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::Context;
+
+use vars qw($AUTOLOAD);
+
+sub new {
+ my $class = shift;
+ my $self = shift || {};
+ die "Missing _template" if ! $self->{'_template'};
+ return bless $self, $class;
+}
+
+sub _template { shift->{'_template'} || die "Missing _template" }
+
+sub template {
+ my ($self, $name) = @_;
+ return $self->_template->{'BLOCKS'}->{$name} || $self->_template->load_parsed_tree($name);
+}
+
+sub config { shift->_template }
+
+sub stash {
+ my $self = shift;
+ return $self->{'stash'} ||= bless {_template => $self->_template}, 'CGI::Ex::Template::_Stash';
+}
+
+sub insert { shift->_template->_insert(@_) }
+
+sub eval_perl { shift->_template->{'EVAL_PERL'} }
+
+sub process {
+ my $self = shift;
+ my $ref = shift;
+ my $args = shift || {};
+
+ $self->_template->set_variable($_, $args->{$_}) for keys %$args;
+
+ my $out = '';
+ $self->_template->_process($ref, $self->_template->_vars, \$out);
+ return $out;
+}
+
+sub include {
+ my $self = shift;
+ my $ref = shift;
+ my $args = shift || {};
+
+ my $t = $self->_template;
+
+ my $swap = $t->{'_vars'};
+ local $t->{'_vars'} = {%$swap};
+
+ $t->set_variable($_, $args->{$_}) for keys %$args;
+
+ my $out = ''; # have temp item to allow clear to correctly clear
+ eval { $t->_process($ref, $t->_vars, \$out) };
+ if (my $err = $@) {
+ die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
+ }
+
+ return $out;
+}
+
+sub define_filter {
+ my ($self, $name, $filter, $is_dynamic) = @_;
+ $filter = [ $filter, 1 ] if $is_dynamic;
+ $self->define_vmethod('filter', $name, $filter);
+}
+
+sub filter {
+ my ($self, $name, $args, $alias) = @_;
+ my $t = $self->_template;
+
+ my $filter;
+ if (! ref $name) {
+ $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex::Template::FILTER_OPS->{$name} || $CGI::Ex::Template::SCALAR_OPS->{$name};
+ $t->throw('filter', $name) if ! $filter;
+ } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) {
+ $filter = $name;
+ } elsif (UNIVERSAL::can($name, 'factory')) {
+ $filter = $name->factory || $t->throw($name->error);
+ } else {
+ $t->throw('undef', "$name: filter not found");
+ }
+
+ if (UNIVERSAL::isa($filter, 'ARRAY')) {
+ $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
+ } elsif ($args && @$args) {
+ my $sub = $filter;
+ $filter = sub { $sub->(shift, @$args) };
+ }
+
+ $t->{'FILTERS'}->{$alias} = $filter if $alias;
+
+ return $filter;
+}
+
+sub define_vmethod { shift->_template->define_vmethod(@_) }
+
+sub throw {
+ my ($self, $type, $info) = @_;
+
+ if (UNIVERSAL::isa($type, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
+ die $type;
+ } elsif (defined $info) {
+ $self->_template->throw($type, $info);
+ } else {
+ $self->_template->throw('undef', $type);
+ }
+}
+
+sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
+
+sub DESTROY {}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::_Stash;
+
+use vars qw($AUTOLOAD);
+
+sub _template { shift->{'_template'} || die "Missing _template" }
+
+sub get {
+ my ($self, $var) = @_;
+ if (! ref $var) {
+ if ($var =~ /^\w+$/) { $var = [$var, 0] }
+ else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
+ }
+ return $self->_template->play_expr($var, {no_dots => 1});
+}
+
+sub set {
+ my ($self, $var, $val) = @_;
+ if (! ref $var) {
+ if ($var =~ /^\w+$/) { $var = [$var, 0] }
+ else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
+ }
+ $self->_template->set_variable($var, $val, {no_dots => 1});
+ return $val;
+}
+
+sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
+
+sub DESTROY {}
+
+###----------------------------------------------------------------###
+
+package CGI::Ex::Template::EvalPerlHandle;
+
+sub TIEHANDLE {
+ my ($class, $out_ref) = @_;
+ return bless [$out_ref], $class;
+}
+
+sub PRINT {
+ my $self = shift;
+ ${ $self->[0] } .= $_ for grep {defined && length} @_;
+ return 1;
+}
+
+###----------------------------------------------------------------###
+
+1;
--- /dev/null
+package CGI::Ex::Template::HTE;
+
+=head1 NAME
+
+CGI::Ex::Template::HTE - provide HTML::Template and HTML::Template::Expr support
+
+=head1 DESCRIPTION
+
+Provides for extra or extended features that may not be as commonly used.
+This module should not normally be used by itself.
+
+See the CGI::Ex::Template documentation for configuration and other parameters.
+
+=head1 AUTHOR
+
+Paul Seamons <paul at seamons dot com>
+
+=head1 LICENSE
+
+This module may be distributed under the same terms as Perl itself.
+
+=cut
+
+use strict;
+use warnings;
+
+our $VERSION = '2.13';
+our %DOCUMENTS; # global cache used with new(cache => 1) and output
+
+sub parse_tree_hte {
+ 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 $START = qr{<(|!--\s*)(/?)([+=~-]?)[Tt][Mm][Pp][Ll]_(\w+)\b};
+ local $self->{'_end_tag'}; # changes over time
+
+ local @{ $self }{@CGI::Ex::Template::CONFIG_COMPILETIME} = @{ $self }{@CGI::Ex::Template::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 perl
+ my @in_view; # let us know if we are in a view
+ my @blocks; # storage for defined blocks
+ 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;
+ my ($comment, $is_close);
+ local pos $$str_ref = 0;
+ my $allow_expr = ! defined($self->{'EXPR'}) || $self->{'EXPR'}; # default is on
+
+ while (1) {
+ ### allow for TMPL_SET foo = PROCESS foo
+ if ($capture) {
+ $func = $$str_ref =~ m{ \G \s* (\w+)\b }gcx
+ ? uc $1 : $self->throw('parse', "Error looking for block in capture DIRECTIVE", undef, pos($$str_ref));
+ if ($func ne 'VAR' && ! $CGI::Ex::Template::DIRECTIVES->{$func}) {
+ $self->throw('parse', "Found unknow DIRECTIVE ($func)", undef, pos($$str_ref) - length($func));
+ }
+
+ $node = [$func, pos($$str_ref) - length($func), undef];
+
+ push @{ $capture->[4] }, $node;
+ undef $capture;
+
+ ### handle all other TMPL tags
+ } else {
+ ### find the next opening tag
+ $$str_ref =~ m{ \G (.*?) $START }gcxs
+ || last;
+ (my $text, $comment, $is_close, my $pre_chomp, $func) = ($1, $2, $3, $4, uc $5);
+
+ ### found a text portion - chomp it, interpolate it and store it
+ if (length $text) {
+ 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'};
+ }
+ }
+
+ ### make sure we know this directive
+ if ($func ne 'VAR' && ! $CGI::Ex::Template::DIRECTIVES->{$func}) {
+ $self->throw('parse', "Found unknow DIRECTIVE ($func)", undef, pos($$str_ref) - length($func));
+ }
+ $node = [$func, pos($$str_ref) - length($func) - length($pre_chomp) - 5, undef];
+
+ ### take care of chomping - yes HT now get CHOMP SUPPORT
+ $pre_chomp ||= $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
+ }
+
+ push @$pointer, $node;
+ }
+
+ $$str_ref =~ m{ \G \s+ }gcx;
+
+ ### parse remaining tag details
+ if (! $is_close) {
+ ### handle HT style nodes
+ if ($func =~ /^(IF|ELSIF|UNLESS|LOOP|VAR|INCLUDE)$/) {
+ $func = $node->[0] = 'GET' if $func eq 'VAR';
+
+ ### handle EXPR attribute
+ if ($$str_ref =~ m{ \G [Ee][Xx][Pp][Rr] \s*=\s* ([\"\']?) \s* }gcx) {
+ if (! $allow_expr) {
+ $self->throw('parse', 'EXPR are not allowed without hte mode', undef, pos($$str_ref));
+ }
+ my $quote = $1;
+ $self->{'_end_tag'} = $comment ? qr{$quote\s*([+=~-]?)-->} : qr{$quote\s*([+=~-]?)>};
+ $node->[3] = $self->parse_expr($str_ref)
+ || $self->throw('parse', 'Error while looking for EXPR', undef, pos($$str_ref));
+
+ ### handle "normal" NAME attributes
+ } else {
+
+ ### store what we'll find at the end of the tag
+ $self->{'_end_tag'} = $comment ? qr{([+=~-]?)-->} : qr{([+=~-]?)>};
+
+ my ($name, $escape, $default);
+ while (1) {
+ if ($$str_ref =~ m{ \G (\w+) \s*=\s* }gcx) {
+ my $key = lc $1;
+ my $val = $$str_ref =~ m{ \G ([\"\']) (.*?) (?<!\\) \1 \s* }gcx ? $2
+ : $$str_ref =~ m{ \G ([\w./+_]+) \s* }gcx ? $1
+ : $self->throw('parse', "Error while looking for value of \"$key\" attribute", undef, pos($$str_ref));
+ if ($key eq 'name') {
+ $name ||= $val;
+ } else {
+ $self->throw('parse', uc($key)." not allowed in TMPL_$func tag") if $func ne 'GET';
+ if ($key eq 'escape') { $escape ||= lc $val }
+ elsif ($key eq 'default') { $default ||= $val }
+ else { $self->throw('parse', uc($key)." not allowed in TMPL_$func tag") }
+ }
+ } elsif ($$str_ref =~ m{ \G ([\w./+_]+) \s* }gcx) {
+ $name ||= $1;
+ } else {
+ last;
+ }
+ }
+
+ $self->throw('parse', 'Error while looking for NAME', undef, pos($$str_ref)) if ! $name;
+ $node->[3] = $func eq 'INCLUDE' ? $name : [($self->{'CASE_SENSITIVE'} ? $name : lc $name), 0]; # set the variable
+ $node->[3] = [[undef, '||', $node->[3], $default], 0] if $default;
+ $node->[2] = pos $$str_ref;
+
+ ### dress up node before finishing
+ $escape = lc $self->{'DEFAULT_ESCAPE'} if ! $escape && $self->{'DEFAULT_ESCAPE'};
+ if ($escape) {
+ $self->throw('parse', "ESCAPE not allowed in TMPL_$func tag") if $func ne 'GET';
+ if ($escape eq 'html' || $escape eq '1') {
+ push @{ $node->[3] }, '|', 'html', 0;
+ } elsif ($escape eq 'url') {
+ push @{ $node->[3] }, '|', 'url', 0;
+ } elsif ($escape eq 'js') {
+ push @{ $node->[3] }, '|', 'js', 0;
+ }
+ }
+ }
+
+ ### fixup DIRECTIVE storage
+ if ($func eq 'INCLUDE') {
+ $node->[3] = [[[undef, '{}'],0], $node->[3]];
+ } elsif ($func eq 'UNLESS') {
+ $node->[0] = 'IF';
+ $node->[3] = [[undef, '!', $node->[3]], 0];
+ }
+
+ ### handle TT Directive extensions
+ } else {
+ $self->throw('parse', "Found a TT tag $func with NO_TT enabled", undef, pos($$str_ref)) if $self->{'NO_TT'};
+ $self->{'_end_tag'} = $comment ? qr{\s*([+=~-]?)-->} : qr{\s*([+=~-]?)>};
+ $node->[3] = eval { $CGI::Ex::Template::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;
+ }
+ }
+
+ ### handle ending tags - or continuation blocks
+ if ($is_close || $CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
+ if (! @state) {
+ $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref));
+ }
+ my $parent_node = pop @state;
+
+ ### TODO - check for matching loop close name
+ $func = $node->[0] = 'END' if $is_close;
+
+ ### handle continuation blocks such as elsif, else, catch etc
+ if ($CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
+ pop @$pointer; # we will store the node in the parent instead
+ $parent_node->[5] = $node;
+ my $parent_type = $parent_node->[0];
+ if (! $CGI::Ex::Template::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 (! $CGI::Ex::Template::DIRECTIVES->{$func}->[4]) {
+ 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]) { # capturing doesn't remove the var
+ splice(@$pointer, -1, 1, ());
+ }
+ } elsif ($parent_node->[0] eq 'VIEW') {
+ my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }};
+ unshift @{ $parent_node->[3] }, $ref;
+ } elsif ($CGI::Ex::Template::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 ($CGI::Ex::Template::DIRECTIVES->{$func}->[2]) {
+ 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 $CGI::Ex::Template::DIRECTIVES->{$node->[0]}->[5] # allow no_interp to turn on and off
+
+ } 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
+ }
+
+
+ ### look for the closing tag
+ 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;
+ next;
+
+ ### setup capturing
+ } elsif ($node->[6]) {
+ $capture = $node;
+ next;
+
+ ### no closing tag
+ } else {
+ $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref));
+ }
+ }
+
+ ### cleanup the tree
+ unshift(@tree, @blocks) if @blocks;
+ unshift(@tree, ['META', 0, 0, {@meta}]) if @meta;
+ $self->throw('parse', "Missing </TMPL_ close tag", $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;
+}
+
+###----------------------------------------------------------------###
+### a few HTML::Template and HTML::Template::Expr routines
+
+sub param {
+ my $self = shift;
+ my $args;
+ if (@_ == 1) {
+ my $key = shift;
+ if (ref($key) ne 'HASH') {
+ $key = lc $key if $self->{'CASE_SENSITIVE'};
+ return $self->{'_vars'}->{$key};
+ }
+ $args = [%$key];
+ } else {
+ $self->throw('param', "Odd number of parameters") if @_ % 2;
+ $args = \@_;
+ }
+ while (@$args) {
+ my $key = shift @$args;
+ $key = lc $key if $self->{'CASE_SENSITIVE'};
+ $self->{'_vars'}->{$key} = shift @$args;
+ }
+ return;
+}
+
+sub output {
+ my $self = shift;
+ my $args = ref($_[0]) eq 'HASH' ? shift : {@_};
+ my $type = $self->{'TYPE'} || '';
+
+ my $content;
+ if ($type eq 'filehandle' || $self->{'FILEHANDLE'}) {
+ my $in = $self->{'FILEHANDLE'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type filehandle');
+ local $/ = undef;
+ $content = <$in>;
+ $content = \$content;
+ } elsif ($type eq 'arrayref' || $self->{'ARRAYREF'}) {
+ my $in = $self->{'ARRAYREF'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type arrayref');
+ $content = join "", @$in;
+ $content = \$content;
+ } elsif ($type eq 'filename' || $self->{'FILENAME'}) {
+ $content = $self->{'FILENAME'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type filename');
+ } elsif ($type eq 'scalarref' || $self->{'SCALARREF'}) {
+ $content = $self->{'SCALARREF'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type scalarref');
+ } else {
+ $self->throw('output', "Unknown input type");
+ }
+
+
+ my $param = $self->{'_vars'} || {};
+ if (my $ref = $self->{'ASSOCIATE'}) {
+ foreach my $obj (ref($ref) eq 'ARRAY' ? $ref : @$ref) {
+ foreach my $key ($obj->param) {
+ $self->{'_vars'}->{$self->{'CASE_SENSITIVE'} ? lc($key) : $key} = $obj->param($key);
+ }
+ }
+ }
+
+
+ ### override some TT defaults
+ local $self->{'FILE_CACHE'} = $self->{'DOUBLE_FILE_CACHE'} ? 1 : $self->{'FILE_CACHE'};
+ my $cache_size = ($self->{'CACHE'}) ? undef : 0;
+ my $compile_dir = (! $self->{'FILE_CACHE'}) ? undef : $self->{'FILE_CACHE_DIR'} || $self->throw('output', 'Missing file_cache_dir');
+ my $stat_ttl = (! $self->{'BLIND_CACHE'}) ? undef : 60; # not sure how high to set the blind cache
+ $cache_size = undef if $self->{'DOUBLE_FILE_CACHE'};
+
+ local $self->{'SYNTAX'} = $self->{'SYNTAX'} || 'hte';
+ local $self->{'NO_TT'} = $self->{'NO_TT'} || ($self->{'SYNTAX'} eq 'hte' ? 0 : 1);
+ local $self->{'CACHE_SIZE'} = $cache_size;
+ local $self->{'STAT_TTL'} = $stat_ttl;
+ local $self->{'COMPILE_DIR'} = $compile_dir;
+ local $self->{'ABSOLUTE'} = 1;
+ local $self->{'RELATIVE'} = 1;
+ local $self->{'INCLUDE_PATH'} = $self->{'PATH'} || './';
+ local $self->{'V2EQUALS'} = $self->{'V2EQUALS'} || 0;
+ local $self->{'_documents'} = \%DOCUMENTS;
+ local $CGI::Ex::Template::QR_PRIVATE = undef;
+
+ if ($args->{'print_to'}) {
+ $self->process_simple($content, $param, $args->{'print_to'}) || die $self->error;
+ return undef;
+ } else {
+ my $out = '';
+ $self->process_simple($content, $param, \$out) || die $self->error;
+ return $out;
+ }
+}
+
+###----------------------------------------------------------------###
+
+1;
@UNSUPPORTED_BROWSERS
);
-$VERSION = '2.12';
+$VERSION = '2.13';
$DEFAULT_EXT = 'val';
$QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;
use strict;
use Benchmark qw(timethese cmpthese);
-my $file = $0;
-$file =~ s|[^/]+$|WrapEx.pm|;
-#require $file;
-
use Template;
use Template::Stash;
use Template::Stash::XS;
+use Template::Parser::CET;
use Text::Template;
use HTML::Template;
use HTML::Template::Expr;
use POSIX qw(tmpnam);
use File::Path qw(mkpath rmtree);
+###----------------------------------------------------------------###
+
+my $names = {
+ CET => 'CGI::Ex::Template using TT interface',
+ 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',
+ HT => 'HTML::Template',
+ HTE => 'HTML::Template::Expr',
+ HTJ => 'HTML::Template::JIT - Compiled to C template',
+ 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',
+
+ mem => 'Compiled in memory',
+ file => 'Loaded from file',
+ str => 'From string ref',
+};
+
+###----------------------------------------------------------------###
+### get cache and compile dirs ready
+
my $dir = tmpnam;
my $dir2 = "$dir.cache";
mkpath($dir);
END {rmtree $dir; rmtree $dir2};
my @dirs = ($dir);
+###----------------------------------------------------------------###
+
my $form = {
foo => 'bar',
pass_in_something => 'what ever you want',
};
-###----------------------------------------------------------------###
+my $filler = ((" foo" x 10)."\n") x 10;
my $stash_t = {
shell_header => "This is a header",
###----------------------------------------------------------------###
### TT style template
-my $content_tt = q{[% shell_header %]
+my $content_tt = <<"DOC";
+[% shell_header %]
[% shell_start %]
+$filler
[% IF foo %]
This is some text.
[% FOREACH i IN a_stuff %][% i %][% END %]
[% pass_in_something %]
+$filler
[% shell_end %]
[% shell_footer %]
-};
+DOC
if (open (my $fh, ">$dir/foo.tt")) {
print $fh $content_tt;
###----------------------------------------------------------------###
### HTML::Template style
-my $content_ht = q{<TMPL_VAR NAME=shell_header>
+my $content_ht = <<"DOC";
+<TMPL_VAR NAME=shell_header>
<TMPL_VAR NAME=shell_start>
+$filler
<TMPL_IF NAME=foo>
This is some text.
<TMPL_LOOP NAME=a_stuff><TMPL_VAR NAME=name></TMPL_LOOP>
<TMPL_VAR NAME=pass_in_something>
+$filler
<TMPL_VAR NAME=shell_end>
<TMPL_VAR NAME=shell_footer>
-};
+DOC
if (open (my $fh, ">$dir/foo.ht")) {
print $fh $content_ht;
###----------------------------------------------------------------###
### Text::Template style template
-my $content_p = q{{$shell_header}
-{$shell_start}
+my $content_p = <<"DOC";
+{\$shell_header}
+{\$shell_start}
+$filler
-{ if ($foo) {
- $OUT .= "
+{ if (\$foo) {
+ \$OUT .= "
This is some text.
";
}
}
-{ $OUT .= $_ foreach @$a_stuff; }
-{$pass_in_something}
+{ \$OUT .= \$_ foreach \@\$a_stuff; }
+{\$pass_in_something}
-{$shell_end}
-{$shell_footer}
-};
+$filler
+{\$shell_end}
+{\$shell_footer}
+DOC
###----------------------------------------------------------------###
-### setup the objects
-
-my $tt = Template->new({
- INCLUDE_PATH => \@dirs,
- STASH => Template::Stash->new($stash_t),
-});
-
-my $ttx = Template->new({
- INCLUDE_PATH => \@dirs,
- STASH => Template::Stash::XS->new($stash_t),
-});
-
-my $ct = CGI::Ex::Template->new({
- INCLUDE_PATH => \@dirs,
- VARIABLES => $stash_t,
-});
-
-my $ctx = CGI::Ex::Template::XS->new({
- INCLUDE_PATH => \@dirs,
- VARIABLES => $stash_t,
-});
-
-my $pt = Text::Template->new(TYPE => 'STRING', SOURCE => $content_p, HASH => $form);
-
-my $ht = HTML::Template->new(type => 'scalarref', source => \$content_ht);
-$ht->param($stash_ht);
-$ht->param($form);
-
-my $hte = HTML::Template::Expr->new(type => 'scalarref', source => \$content_ht);
-$hte->param($stash_ht);
-$hte->param($form);
+### The TT interface allows for a single object to be cached and reused.
-my $ht_c = HTML::Template->new(type => 'filename', source => "foo.ht", cache => 1, path => \@dirs);
-$ht_c->param($stash_ht);
-$ht_c->param($form);
-
-my $ht_j = HTML::Template::JIT->new(filename => "foo.ht", path => \@dirs, jit_path => $dir2);
-$ht_j->param($stash_ht);
-$ht_j->param($form);
+my $tt = Template->new( INCLUDE_PATH => \@dirs, STASH => Template::Stash->new($stash_t));
+my $ttx = Template->new( INCLUDE_PATH => \@dirs, STASH => Template::Stash::XS->new($stash_t));
+my $ct = CGI::Ex::Template->new( INCLUDE_PATH => \@dirs, VARIABLES => $stash_t);
+my $ctx = CGI::Ex::Template::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t);
###----------------------------------------------------------------###
-### make sure everything is ok by trying it once
-
-my $out_tt = "";
-$tt->process(\$content_tt, $form, \$out_tt);
-
-my $out_ttx = "";
-$ttx->process(\$content_tt, $form, \$out_ttx);
-
-my $out_ct = "";
-$ct->process(\$content_tt, $form, \$out_ct);
-
-my $out_ctx = "";
-$ctx->process(\$content_tt, $form, \$out_ctx);
-my $out_c2 = "";
-$ct->process('foo.tt', $form, \$out_c2);
-
-my $out_c3 = '';
-$ct->process_simple(\$content_tt, {%$stash_t, %$form}, \$out_c3);
-
-my $out_pt = $pt->fill_in(PACKAGE => 'FOO', HASH => $form);
-
-my $out_ht = $ht->output;
-my $out_hte = $hte->output;
-my $out_htc = $ht_c->output;
-my $out_htj = $ht_j->output;
+my $tests = {
-if ($out_ct ne $out_tt) {
- debug $out_ct, $out_tt;
- die "CGI::Ex::Template didn't match tt";
-}
-if ($out_ctx ne $out_tt) {
- debug $out_ctx, $out_tt;
- die "CGI::Ex::Template::XS didn't match tt";
-}
-if ($out_ttx ne $out_tt) {
- debug $out_ttx, $out_tt;
- die "Template::Stash::XS didn't match tt";
-}
-if ($out_c2 ne $out_tt) {
- debug $out_c2, $out_tt;
- die "CGI::Ex::Template from file didn't match tt";
-}
-if ($out_c3 ne $out_tt) {
- debug $out_c3, $out_tt;
- die "CGI::Ex::Template by swap didn't match tt";
-}
-if ($out_pt ne $out_tt) {
- debug $out_pt, $out_tt;
- die "Text Template didn't match tt";
-}
-if ($out_ht ne $out_tt) {
- debug $out_ht, $out_tt;
- die "HTML::Template didn't match tt";
-}
-if ($out_hte ne $out_tt) {
- debug $out_hte, $out_tt;
- die "HTML::Template::Expr didn't match tt";
-}
-if ($out_htc ne $out_tt) {
- debug $out_htc, $out_tt;
- die "HTML::Template::Expr didn't match tt";
-}
-if ($out_htj ne $out_tt) {
- debug $out_htj, $out_tt;
- die "HTML::Template::JIT didn't match tt";
-}
+ ###----------------------------------------------------------------###
+ ### compile means item was compiled to optree or perlcode and stored on disk
-###----------------------------------------------------------------###
-
-my $tests = {
- TT_str => sub {
- my $tt = Template->new({
- INCLUDE_PATH => \@dirs,
- STASH => Template::Stash->new($stash_t),
- });
- my $out = "";
- $tt->process(\$content_tt, $form, \$out);
- },
- TT_mem => sub {
- my $out = "";
- $tt->process('foo.tt', $form, \$out);
- },
- TT_compile => sub {
- my $tt = Template->new({
- INCLUDE_PATH => \@dirs,
- STASH => Template::Stash->new($stash_t),
- COMPILE_DIR => $dir2,
- });
- my $out = "";
- $tt->process('foo.tt', $form, \$out);
+ TT_file => sub {
+ my $tt = Template->new(INCLUDE_PATH => \@dirs, STASH => Template::Stash->new($stash_t), COMPILE_DIR => $dir2);
+ my $out = ""; $tt->process('foo.tt', $form, \$out); $out;
},
-
- TTX_str => sub {
- my $tt = Template->new({
- INCLUDE_PATH => \@dirs,
- STASH => Template::Stash::XS->new($stash_t),
- });
- my $out = "";
- $tt->process(\$content_tt, $form, \$out);
+ TTX_file => sub {
+ 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;
},
- TTX_mem => sub {
- my $out = "";
- $ttx->process('foo.tt', $form, \$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;
},
- TTX_compile => sub {
- 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);
+ 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_str => sub {
- my $ct = CGI::Ex::Template->new({
- INCLUDE_PATH => \@dirs,
- VARIABLES => $stash_t,
- });
- my $out = "";
- $ct->process(\$content_tt, $form, \$out);
+ CETH_file => sub {
+ my $ht = CGI::Ex::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2);
+ $ht->param($stash_ht); $ht->param($form); my $out = $ht->output;
},
- CET_mem => sub {
- my $out = "";
- $ct->process('foo.tt', $form, \$out);
+ CETXH_file => sub {
+ my $ht = CGI::Ex::Template::XS->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2);
+ $ht->param($stash_ht); $ht->param($form); my $out = $ht->output;
},
- CET_compile => sub {
- my $ct = CGI::Ex::Template->new({
- INCLUDE_PATH => \@dirs,
- VARIABLES => $stash_t,
- COMPILE_DIR => $dir2,
- });
- my $out = '';
- $ct->process('foo.tt', $form, \$out);
+ HT_file => sub {
+ my $ht = HTML::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2);
+ $ht->param($stash_ht); $ht->param($form); my $out = $ht->output;
},
- CTX_str => sub {
- my $ct = CGI::Ex::Template::XS->new({
- INCLUDE_PATH => \@dirs,
- VARIABLES => $stash_t,
- });
- my $out = "";
- $ct->process(\$content_tt, $form, \$out);
- },
- CTX_mem => sub {
- my $out = "";
- $ctx->process('foo.tt', $form, \$out);
- },
- CTX_compile => sub {
- my $ct = CGI::Ex::Template::XS->new({
- INCLUDE_PATH => \@dirs,
- VARIABLES => $stash_t,
- COMPILE_DIR => $dir2,
- });
- my $out = '';
- $ct->process('foo.tt', $form, \$out);
- },
+ ###----------------------------------------------------------------###
+ ### str infers that we are pulling from a string reference
- TextTemplate => sub {
+ TextTemplate_str => sub {
my $pt = Text::Template->new(
TYPE => 'STRING',
SOURCE => $content_p,
my $out = $pt->fill_in(PACKAGE => 'FOO', HASH => $form);
},
- HT_str => sub {
- my $ht = HTML::Template->new(type => 'scalarref', source => \$content_ht);
- $ht->param($stash_ht);
- $ht->param($form);
- my $out = $ht->output;
+ TT_str => sub {
+ my $t = Template->new(STASH => Template::Stash->new($stash_t));
+ my $out = ""; $t->process(\$content_tt, $form, \$out); $out;
},
- HT_mem => sub {
- my $ht = HTML::Template->new(type => 'filename', source => "foo.ht", path => \@dirs, cache => 1);
- $ht->param($stash_ht);
- $ht->param($form);
- my $out = $ht->output;
+ TTX_str => sub {
+ my $t = Template->new(STASH => Template::Stash::XS->new($stash_t));
+ my $out = ""; $t->process(\$content_tt, $form, \$out); $out;
},
- HT_compile => sub {
- my $ht = HTML::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2);
- $ht->param($stash_ht);
- $ht->param($form);
- my $out = $ht->output;
+ TTXCET_str => sub {
+ 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;
},
+ CETH_str => sub {
+ my $ht = CGI::Ex::Template->new( type => 'scalarref', source => \$content_ht);
+ $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);
+ $ht->param($stash_ht); $ht->param($form); my $out = $ht->output;
+ },
+ HT_str => sub {
+ my $ht = HTML::Template->new( type => 'scalarref', source => \$content_ht);
+ $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);
- $ht->param($stash_ht);
- $ht->param($form);
- my $out = $ht->output;
+ my $ht = HTML::Template::Expr->new( type => 'scalarref', source => \$content_ht);
+ $ht->param($stash_ht); $ht->param($form); my $out = $ht->output;
+ },
+
+ ###----------------------------------------------------------------###
+ ### 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 },
+
+ CETH_mem => sub {
+ my $ht = CGI::Ex::Template->new( filename => "foo.ht", path => \@dirs, cache => 1);
+ $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);
+ $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);
+ $ht->param($stash_ht); $ht->param($form); my $out = $ht->output;
},
HTE_mem => sub {
- my $ht = HTML::Template::Expr->new(type => 'filename', source => "foo.ht", path => \@dirs, cache => 1);
- $ht->param($stash_ht);
- $ht->param($form);
- my $out = $ht->output;
+ my $ht = HTML::Template::Expr->new( filename => "foo.ht", path => \@dirs, cache => 1);
+ $ht->param($stash_ht); $ht->param($form); my $out = $ht->output;
},
-
- HTJ_compile => sub {
- my $ht = HTML::Template::JIT->new(filename => "foo.ht", path => \@dirs, jit_path => $dir2);
- $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);
+ $ht->param($stash_ht); $ht->param($form); my $out = $ht->output;
},
};
+my $test = $tests->{'TT_str'}->();
+foreach my $name (sort keys %$tests) {
+ if ($test ne $tests->{$name}->()) {
+ die "$name did not match TT_str output\n";
+ }
+ $name =~ /(\w+)_(\w+)/;
+ print "$name - $names->{$1} - ($names->{$2})\n";
+}
+
+###----------------------------------------------------------------###
+### and now - the tests - grouped by common capability
-my %mem_tests = map {($_ => $tests->{$_})} qw(TT_mem TTX_mem CET_mem HT_mem HTE_mem CTX_mem);
-my %cpl_tests = map {($_ => $tests->{$_})} qw(TT_compile TTX_compile CET_compile HT_compile HTJ_compile CTX_compile);
-my %str_tests = map {($_ => $tests->{$_})} qw(TT_str TTX_str CET_str HT_str HTE_str TextTemplate CTX_str);
+my %mem_tests = map {($_ => $tests->{$_})} grep {/_mem$/} keys %$tests;
+my %cpl_tests = map {($_ => $tests->{$_})} grep {/_file$/} keys %$tests;
+my %str_tests = map {($_ => $tests->{$_})} grep {/_str$/} keys %$tests;
print "------------------------------------------------------------------------\n";
print "From a string or scalarref tests\n";
print "Cached in memory tests\n";
cmpthese timethese (-2, \%mem_tests);
-print "------------------------------------------------------------------------\n";
-print "All variants together\n";
-cmpthese timethese (-2, $tests);
+#print "------------------------------------------------------------------------\n";
+#print "All variants together\n";
+#cmpthese timethese (-2, $tests);
###----------------------------------------------------------------###
+
+__END__
+
+=head1 SAMPLE OUTPUT v2.13
+
+ CETH_file - CGI::Ex::Template using HTML::Template interface - (Loaded from file)
+ CETH_mem - CGI::Ex::Template using HTML::Template interface - (Compiled in memory)
+ CETH_str - CGI::Ex::Template using HTML::Template interface - (From string ref)
+ CETXH_file - CGI::Ex::Template::XS using HTML::Template interface - (Loaded from file)
+ CETXH_mem - CGI::Ex::Template::XS using HTML::Template interface - (Compiled in memory)
+ CETXH_str - CGI::Ex::Template::XS using HTML::Template interface - (From string ref)
+ CETX_file - CGI::Ex::Template::XS using TT interface - (Loaded from file)
+ CETX_mem - CGI::Ex::Template::XS using TT interface - (Compiled in memory)
+ CETX_str - CGI::Ex::Template::XS using TT interface - (From string ref)
+ CET_file - CGI::Ex::Template using TT interface - (Loaded from file)
+ CET_mem - CGI::Ex::Template using TT interface - (Compiled in memory)
+ CET_str - CGI::Ex::Template using TT interface - (From string ref)
+ HTE_mem - HTML::Template::Expr - (Compiled in memory)
+ HTE_str - HTML::Template::Expr - (From string ref)
+ HTJ_mem - HTML::Template::JIT - Compiled to C template - (Compiled in memory)
+ HT_file - HTML::Template - (Loaded from file)
+ HT_mem - HTML::Template - (Compiled in memory)
+ HT_str - HTML::Template - (From string ref)
+ TTXCET_str - Template::Toolkit with Stash::XS and Template::Parser::CET - (From string ref)
+ TTX_file - Template::Toolkit with Stash::XS - (Loaded from file)
+ TTX_mem - Template::Toolkit with Stash::XS - (Compiled in memory)
+ TTX_str - Template::Toolkit with Stash::XS - (From string ref)
+ TT_file - Template::Toolkit - (Loaded from file)
+ TT_mem - Template::Toolkit - (Compiled in memory)
+ TT_str - Template::Toolkit - (From string ref)
+ TextTemplate_str - Text::Template - Perl code eval based - (From string ref)
+ ------------------------------------------------------------------------
+ From a string or scalarref tests
+ Benchmark: running CETH_str, CETXH_str, CETX_str, CET_str, HTE_str, HT_str, TTXCET_str, TTX_str, TT_str, TextTemplate_str for at least 2 CPU seconds...
+ CETH_str: 2 wallclock secs ( 2.18 usr + 0.00 sys = 2.18 CPU) @ 1449.08/s (n=3159)
+ CETXH_str: 2 wallclock secs ( 2.00 usr + 0.01 sys = 2.01 CPU) @ 1700.00/s (n=3417)
+ CETX_str: 2 wallclock secs ( 2.22 usr + 0.00 sys = 2.22 CPU) @ 1584.23/s (n=3517)
+ CET_str: 2 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 1333.18/s (n=2853)
+ HTE_str: 2 wallclock secs ( 2.07 usr + 0.00 sys = 2.07 CPU) @ 922.71/s (n=1910)
+ HT_str: 2 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 1221.13/s (n=2601)
+ TTXCET_str: 2 wallclock secs ( 2.01 usr + 0.01 sys = 2.02 CPU) @ 534.16/s (n=1079)
+ TTX_str: 2 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 312.62/s (n=669)
+ TT_str: 3 wallclock secs ( 2.12 usr + 0.01 sys = 2.13 CPU) @ 300.47/s (n=640)
+ TextTemplate_str: 2 wallclock secs ( 2.13 usr + 0.02 sys = 2.15 CPU) @ 1189.77/s (n=2558)
+ Rate TT_str TTX_str TTXCET_str HTE_str TextTemplate_str HT_str CET_str CETH_str CETX_str CETXH_str
+ TT_str 300/s -- -4% -44% -67% -75% -75% -77% -79% -81% -82%
+ TTX_str 313/s 4% -- -41% -66% -74% -74% -77% -78% -80% -82%
+ TTXCET_str 534/s 78% 71% -- -42% -55% -56% -60% -63% -66% -69%
+ HTE_str 923/s 207% 195% 73% -- -22% -24% -31% -36% -42% -46%
+ TextTemplate_str 1190/s 296% 281% 123% 29% -- -3% -11% -18% -25% -30%
+ HT_str 1221/s 306% 291% 129% 32% 3% -- -8% -16% -23% -28%
+ CET_str 1333/s 344% 326% 150% 44% 12% 9% -- -8% -16% -22%
+ CETH_str 1449/s 382% 364% 171% 57% 22% 19% 9% -- -9% -15%
+ CETX_str 1584/s 427% 407% 197% 72% 33% 30% 19% 9% -- -7%
+ CETXH_str 1700/s 466% 444% 218% 84% 43% 39% 28% 17% 7% --
+ ------------------------------------------------------------------------
+ Compiled and cached on the file system tests
+ Benchmark: running CETH_file, CETXH_file, CETX_file, CET_file, HT_file, TTX_file, TT_file for at least 2 CPU seconds...
+ CETH_file: 3 wallclock secs ( 2.14 usr + 0.02 sys = 2.16 CPU) @ 3106.02/s (n=6709)
+ CETXH_file: 2 wallclock secs ( 2.01 usr + 0.04 sys = 2.05 CPU) @ 4447.80/s (n=9118)
+ CETX_file: 3 wallclock secs ( 2.02 usr + 0.09 sys = 2.11 CPU) @ 3586.26/s (n=7567)
+ CET_file: 3 wallclock secs ( 2.16 usr + 0.05 sys = 2.21 CPU) @ 2432.13/s (n=5375)
+ HT_file: 2 wallclock secs ( 2.18 usr + 0.03 sys = 2.21 CPU) @ 1868.33/s (n=4129)
+ TTX_file: 2 wallclock secs ( 2.14 usr + 0.04 sys = 2.18 CPU) @ 820.64/s (n=1789)
+ TT_file: 2 wallclock secs ( 2.11 usr + 0.04 sys = 2.15 CPU) @ 733.02/s (n=1576)
+ Rate TT_file TTX_file HT_file CET_file CETH_file CETX_file CETXH_file
+ TT_file 733/s -- -11% -61% -70% -76% -80% -84%
+ TTX_file 821/s 12% -- -56% -66% -74% -77% -82%
+ HT_file 1868/s 155% 128% -- -23% -40% -48% -58%
+ CET_file 2432/s 232% 196% 30% -- -22% -32% -45%
+ CETH_file 3106/s 324% 278% 66% 28% -- -13% -30%
+ CETX_file 3586/s 389% 337% 92% 47% 15% -- -19%
+ CETXH_file 4448/s 507% 442% 138% 83% 43% 24% --
+ ------------------------------------------------------------------------
+ Cached in memory tests
+ Benchmark: running CETH_mem, CETXH_mem, CETX_mem, CET_mem, HTE_mem, HTJ_mem, HT_mem, TTX_mem, TT_mem for at least 2 CPU seconds...
+ CETH_mem: 2 wallclock secs ( 2.11 usr + 0.03 sys = 2.14 CPU) @ 3193.46/s (n=6834)
+ CETXH_mem: 2 wallclock secs ( 2.18 usr + 0.04 sys = 2.22 CPU) @ 4622.07/s (n=10261)
+ CETX_mem: 2 wallclock secs ( 2.02 usr + 0.10 sys = 2.12 CPU) @ 6334.43/s (n=13429)
+ CET_mem: 2 wallclock secs ( 2.16 usr + 0.04 sys = 2.20 CPU) @ 3946.82/s (n=8683)
+ HTE_mem: 2 wallclock secs ( 2.20 usr + 0.01 sys = 2.21 CPU) @ 1515.38/s (n=3349)
+ HTJ_mem: 2 wallclock secs ( 2.05 usr + 0.06 sys = 2.11 CPU) @ 5990.05/s (n=12639)
+ HT_mem: 2 wallclock secs ( 1.98 usr + 0.03 sys = 2.01 CPU) @ 2588.56/s (n=5203)
+ TTX_mem: 2 wallclock secs ( 2.07 usr + 0.03 sys = 2.10 CPU) @ 3254.29/s (n=6834)
+ TT_mem: 2 wallclock secs ( 2.18 usr + 0.02 sys = 2.20 CPU) @ 2217.73/s (n=4879)
+ Rate HTE_mem TT_mem HT_mem CETH_mem TTX_mem CET_mem CETXH_mem HTJ_mem CETX_mem
+ HTE_mem 1515/s -- -32% -41% -53% -53% -62% -67% -75% -76%
+ TT_mem 2218/s 46% -- -14% -31% -32% -44% -52% -63% -65%
+ HT_mem 2589/s 71% 17% -- -19% -20% -34% -44% -57% -59%
+ CETH_mem 3193/s 111% 44% 23% -- -2% -19% -31% -47% -50%
+ TTX_mem 3254/s 115% 47% 26% 2% -- -18% -30% -46% -49%
+ CET_mem 3947/s 160% 78% 52% 24% 21% -- -15% -34% -38%
+ CETXH_mem 4622/s 205% 108% 79% 45% 42% 17% -- -23% -27%
+ HTJ_mem 5990/s 295% 170% 131% 88% 84% 52% 30% -- -5%
+ CETX_mem 6334/s 318% 186% 145% 98% 95% 60% 37% 6% --
+
+=cut
};
use strict;
-use Test::More tests => ! $is_tt ? 806 : 599;
+use Test::More tests => ! $is_tt ? 894 : 613;
use Data::Dumper qw(Dumper);
use constant test_taint => 0 && eval { require Taint::Runtime };
process_ok("[% a = qw{Foo Bar Baz} ; a.2 %]" => 'Baz') if ! $is_tt;
-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 %][% _foo %]2" => '2');
process_ok("[% foo._bar %]2" => '2', {foo => {_bar =>1}});
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";
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|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.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|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)').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.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(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
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('[% 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('[% 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('[% FOREACH f = [1..3]; "$f"; END %]' => '123');
process_ok('[% FOREACH f = [1..3]; f + 1; END %]' => '234');
+###----------------------------------------------------------------###
+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
+ CGI::Ex::Template->define_vmethod('scalar', textjoin => sub {join(shift, @_)});
+
+ process_ok("[% var = [{key => 'a'}, {key => 'b'}, {key => 'c'}] -%]
+[% LOOP var -%]
+([% textjoin('|', key, __first__, __last__, __inner__, __odd__) %])
+[% END -%]" => "(a|1|0|0|1)
+(b|0|0|1|0)
+(c|0|1|0|1)
+", {tt_config => [LOOP_CONTEXT_VARS => 1]});
+}
+
###----------------------------------------------------------------###
print "### WHILE ############################################################\n";
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; 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');
+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('[% constants.a %]|[% $constants.a %]|[% constants.$a %]' => 'A|A|A', {tt_config => [V1DOLLAR => 1, CONSTANTS => {a => 'A'}]});
###----------------------------------------------------------------###
-print "### V2PIPE ###########################################################\n";
+print "### V2PIPE / V2EQUALS ################################################\n";
process_ok("[%- BLOCK a %]b is [% b %]
[% END %]
[% 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("[% p = DUMP a; p.collapse %]" => '<pre>a = 's'; </pre>', {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' => '' };", {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' => '' };", {a => 'b', tt_config => [DUMP => {Sortkeys => 1, EntireStash => 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}]});
+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("<TMPL_VAR name=foo>" => "FOO", {foo => "FOO", tt_config => [SYNTAX => 'ht']});
+process_ok("<TMPL_VAR EXPR='sprintf(\"%d %d\", 7, 8)'>" => "7 8", {tt_config => [SYNTAX => 'hte']});
+process_ok("<TMPL_VAR EXPR='7 == \"7.0\"'>" => "1", {tt_config => [SYNTAX => 'hte']});
+process_ok("<TMPL_VAR EXPR='\"a\" == \"b\"'>" => "1", {tt_config => [SYNTAX => 'hte']});
+process_ok("<TMPL_VAR EXPR='sprintf(\"%d %d\", 7, 8)'>d" => "", {tt_config => [SYNTAX => 'ht']});
+
+process_ok("[% \"<TMPL_VAR EXPR='1+2+3'>\"|eval('hte') %] = [% 6 %]" => "6 = 6");
+process_ok("[% \"<TMPL_VAR EXPR='1+2+3'>\"|eval('ht') %] = [% 6 %]" => "");
+
+}
+
###----------------------------------------------------------------###
print "### CONFIG ############################################################\n";
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' %][% \"<TMPL_VAR EXPR='1+2+3'>\"|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');
}
###----------------------------------------------------------------###
--- /dev/null
+# -*- Mode: Perl; -*-
+
+=head1 NAME
+
+7_template_03_html_template.t - Test the ability to parse and play html template
+
+=cut
+
+use vars qw($module $is_ht $is_hte $is_cet);
+BEGIN {
+ $module = 'CGI::Ex::Template';
+# $module = 'HTML::Template';
+# $module = 'HTML::Template::Expr';
+ $is_hte = $module eq 'HTML::Template::Expr';
+ $is_ht = $module eq 'HTML::Template';
+ $is_cet = $module eq 'CGI::Ex::Template';
+};
+
+use strict;
+use Test::More tests => ($is_cet) ? 92 : ($is_ht) ? 60 : 64;
+use Data::Dumper qw(Dumper);
+use constant test_taint => 0 && eval { require Taint::Runtime };
+
+use_ok($module);
+
+Taint::Runtime::taint_start() if test_taint;
+
+### find a place to allow for testing
+my $test_dir = $0 .'.test_dir';
+END { rmdir $test_dir }
+mkdir $test_dir, 0755;
+ok(-d $test_dir, "Got a test dir up and running");
+
+
+sub process_ok { # process the value and say if it was ok
+ my $str = shift;
+ my $test = shift;
+ my $vars = shift || {};
+ my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || [];
+ my $line = (caller)[2];
+ delete $vars->{'tt_config'};
+
+ Taint::Runtime::taint(\$str) if test_taint;
+
+ my $obj;
+ my $out;
+ eval {
+ $obj = shift || $module->new(scalarref => \$str, die_on_bad_params => 0, path => $test_dir, @$conf); # new object each time
+ $obj->param($vars);
+ $out = $obj->output;
+ };
+ my $err = $@;
+ $out = '' if ! defined $out;
+
+ my $ok = ref($test) ? $out =~ $test : $out eq $test;
+ if ($ok) {
+ ok(1, "Line $line \"$str\" => \"$out\"");
+ return $obj;
+ } else {
+ ok(0, "Line $line \"$str\"");
+ warn "# Was:\n$out\n# Should've been:\n$test\n";
+ print "$err\n";
+ if ($obj && $obj->can('parse_tree')) {
+ local $obj->{'SYNTAX'} = 'hte';
+ print Dumper $obj->parse_tree(\$str);
+ }
+ exit;
+ }
+}
+
+### create some files to include
+my $foo_template = "$test_dir/foo.ht";
+END { unlink $foo_template };
+open(my $fh, ">$foo_template") || die "Couldn't open $foo_template: $!";
+print $fh "Good Day!";
+close $fh;
+
+###----------------------------------------------------------------###
+print "### VAR ##############################################################\n";
+
+process_ok("Foo" => "Foo");
+
+process_ok("<TMPL_VAR foo>" => "FOO", {foo => "FOO"});
+process_ok("<TMPL_VAR foo>" => "FOO", {foo => "FOO"});
+process_ok("<TMPL_VAR name=foo>" => "FOO", {foo => "FOO"});
+process_ok("<TMPL_VAR NAME=foo>" => "FOO", {foo => "FOO"});
+process_ok("<TMPL_VAR NAME=\"foo\">" => "FOO", {foo => "FOO"});
+process_ok("<TMPL_VAR NAME='foo'>" => "FOO", {foo => "FOO"});
+process_ok("<TMPL_VAR NAME='foo' >" => "FOO", {foo => "FOO"});
+process_ok("<TMPL_VAR foo >" => "FOO", {foo => "FOO"});
+
+process_ok("<TMPL_VAR foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR foo>" => "<>", {foo => "<>", tt_config => [default_escape => 'html']});
+process_ok("<TMPL_VAR ESCAPE=html foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=HTML foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=\"HTML\" foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE='HTML' foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=1 foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=0 foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=NONE foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=URL foo>" => "%3C%3E", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=JS foo>" => "<>\\n\\r\t\\\"\\\'", {foo => "<>\n\r\t\"\'"});
+
+process_ok("<TMPL_VAR foo ESCAPE=html>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR NAME=foo ESCAPE=html>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=html NAME=foo>" => "<>", {foo => "<>"});
+process_ok("<TMPL_VAR ESCAPE=html NAME=foo ESCAPE=js>" => "<>", {foo => "<>"});
+
+process_ok("<TMPL_VAR DEFAULT=bar NAME=foo>" => "FOO", {foo => "FOO", bar => "BAR"});
+process_ok("<TMPL_VAR DEFAULT=bar NAME=foo>d" => "bard", {foo => undef, bar => "BAR"});
+process_ok("<TMPL_VAR NAME=foo DEFAULT=bar>d" => "bard", {foo => undef, bar => "BAR"});
+process_ok("<TMPL_VAR DEFAULT=bar NAME=foo DEFAULT=bing>d" => "bard");
+
+process_ok("<!--TMPL_VAR foo-->" => "FOO", {foo => "FOO"}) if $is_cet;
+process_ok("<!--TMPL_VAR NAME='foo'-->" => "FOO", {foo => "FOO"});
+
+###----------------------------------------------------------------###
+print "### IF / ELSE / UNLESS ###############################################\n";
+
+process_ok("<TMPL_IF foo>bar</TMPL_IF>" => "", {foo => ""});
+process_ok("<TMPL_IF foo>bar</TMPL_IF>" => "bar", {foo => "1"});
+process_ok("<TMPL_IF foo>bar<TMPL_ELSE>bing</TMPL_IF>" => "bing", {foo => ''});
+process_ok("<TMPL_IF foo>bar<TMPL_ELSE>bing</TMPL_IF>" => "bar", {foo => '1'});
+process_ok("<TMPL_UNLESS foo>bar</TMPL_UNLESS>" => "bar", {foo => ""});
+process_ok("<TMPL_UNLESS foo>bar</TMPL_UNLESS>" => "", {foo => "1"});
+
+process_ok("<TMPL_IF ESCAPE=HTML foo>bar</TMPL_IF>baz" => "", {foo => "1"});
+process_ok("<TMPL_IF DEFAULT=bar foo>bar</TMPL_IF>baz" => "", {foo => "1"});
+
+###----------------------------------------------------------------###
+print "### INCLUDE ##########################################################\n";
+
+process_ok("<TMPL_INCLUDE blah>" => "");
+process_ok("<TMPL_INCLUDE foo.ht>" => "Good Day!");
+process_ok("<TMPL_INCLUDE $test_dir/foo.ht>" => "Good Day!", {tt_config => [path => '']});
+process_ok("<TMPL_INCLUDE NAME=foo.ht>" => "Good Day!");
+process_ok("<TMPL_INCLUDE NAME='foo.ht'>" => "Good Day!");
+process_ok("<TMPL_INCLUDE NAME='foo.ht'>" => "", {tt_config => [no_includes => 1]});
+
+process_ok("<TMPL_INCLUDE ESCAPE=HTML NAME='foo.ht'>" => "");
+process_ok("<TMPL_INCLUDE DEFAULT=bar NAME='foo.ht'>" => "");
+
+process_ok("<TMPL_INCLUDE EXPR=\"'foo.ht'\">" => "Good Day!") if $is_cet;
+process_ok("<TMPL_INCLUDE EXPR=\"foo\">" => "Good Day!", {foo => 'foo.ht'}) if $is_cet;
+process_ok("<TMPL_INCLUDE EXPR=\"sprintf('%s', 'foo.ht')\">" => "Good Day!") if $is_cet;
+
+###----------------------------------------------------------------###
+print "### EXPR #############################################################\n";
+
+process_ok("<TMPL_VAR EXPR=\"sprintf('%d', foo)\">" => "777", {foo => "777"}) if ! $is_ht;
+process_ok("<TMPL_VAR EXPR=\"sprintf('%d', foo)\">" => "777", {foo => "777"}) if ! $is_ht;
+process_ok("<TMPL_VAR EXPR='sprintf(\"%d\", foo)'>" => "777", {foo => "777"}) if ! $is_ht && ! $is_hte; # odd that HTE can't parse this
+process_ok("<TMPL_VAR EXPR=\"sprintf(\"%d\", foo)\">" => "777", {foo => "777"}) if ! $is_ht;
+process_ok("<TMPL_VAR EXPR=sprintf(\"%d\", foo)>" => "777", {foo => "777"}) if ! $is_ht && ! $is_hte;
+process_ok("<TMPL_VAR EXPR=\"sprintf('%s', foo)\">" => "<>", {foo => "<>"}) if ! $is_ht;
+process_ok("<TMPL_VAR ESCAPE=HTML EXPR=\"sprintf('%s', foo)\">" => "", {foo => "<>"});
+process_ok("<TMPL_VAR DEFAULT=bar EXPR=foo>" => "", {foo => "FOO", bar => "BAR"});
+
+process_ok("<!--TMPL_VAR EXPR=\"foo\"-->" => "FOO", {foo => "FOO"}) if ! $is_ht;;
+
+###----------------------------------------------------------------###
+print "### LOOP #############################################################\n";
+
+process_ok("<TMPL_LOOP blah></TMPL_LOOP>foo" => "foo");
+process_ok("<TMPL_LOOP blah>Hi</TMPL_LOOP>foo" => "", {blah => 1});
+process_ok("<TMPL_LOOP blah>Hi</TMPL_LOOP>foo" => "Hifoo", {blah => {wow => 1}}) if $is_cet;
+process_ok("<TMPL_LOOP blah>Hi</TMPL_LOOP>foo" => "HiHifoo", {blah => [{}, {}]});
+process_ok("<TMPL_LOOP blah>(<TMPL_VAR i>)</TMPL_LOOP>foo" => "(1)(2)(3)foo", {blah => [{i=>1}, {i=>2}, {i=>3}]});
+process_ok("<TMPL_LOOP NAME=\"blah\">(<TMPL_VAR i>)</TMPL_LOOP>foo" => "(1)(2)(3)foo", {blah => [{i=>1}, {i=>2}, {i=>3}]});
+process_ok("<TMPL_LOOP EXPR=\"blah\">(<TMPL_VAR i>)</TMPL_LOOP>foo" => "(1)(2)(3)foo", {blah => [{i=>1}, {i=>2}, {i=>3}]}) if $is_cet;
+process_ok("<TMPL_LOOP blah>(<TMPL_VAR i>)(<TMPL_VAR blue>)</TMPL_LOOP>foo" => "(1)()(2)()(3)()foo", {blah => [{i=>1}, {i=>2}, {i=>3}], blue => 'B'}) if $is_ht;
+process_ok("<TMPL_LOOP blah>(<TMPL_VAR i>)(<TMPL_VAR blue>)</TMPL_LOOP>foo" => "(1)(B)(2)(B)(3)(B)foo", {blah => [{i=>1}, {i=>2}, {i=>3}], blue => 'B', tt_config => [GLOBAL_VARS => 1]});
+
+process_ok("<TMPL_LOOP blah>(<TMPL_VAR i>)(<TMPL_VAR blue>)</TMPL_LOOP>foo" => "(1)()(2)()(3)()foo", {blah => [{i=>1}, {i=>2}, {i=>3}], blue => 'B', tt_config => [SYNTAX => 'ht']}) if $is_cet;
+process_ok("<TMPL_LOOP blah>(<TMPL_VAR i>)(<TMPL_VAR blue>)</TMPL_LOOP>foo" => "(1)(B)(2)(B)(3)(B)foo", {blah => [{i=>1}, {i=>2}, {i=>3}], blue => 'B', tt_config => [GLOBAL_VARS => 1, SYNTAX => 'ht']}) if $is_cet;
+
+process_ok("<TMPL_LOOP blah>(<TMPL_VAR i>)</TMPL_LOOP>foo" => "(1)()(3)foo", {blah => [{i=>1}, undef, {i=>3}]});
+
+process_ok("<TMPL_LOOP blah>\n(<TMPL_VAR __first__>|<TMPL_VAR __last__>|<TMPL_VAR __odd__>|<TMPL_VAR __inner__>|<TMPL_VAR __counter__>)</TMPL_LOOP>foo" => "
+(||||)
+(||||)
+(||||)foo", {blah => [undef, undef, undef]});
+
+process_ok("<TMPL_LOOP blah>\n(<TMPL_VAR __first__>|<TMPL_VAR __last__>|<TMPL_VAR __odd__>|<TMPL_VAR __inner__>|<TMPL_VAR __counter__>)</TMPL_LOOP>foo" => "
+(1||1|0|1)
+(0|0||1|2)
+(0|1|1|0|3)foo", {blah => [undef, undef, undef], tt_config => [LOOP_CONTEXT_VARS => 1]}) if ! $is_cet;
+
+process_ok("<TMPL_LOOP blah>\n(<TMPL_VAR __first__>|<TMPL_VAR __last__>|<TMPL_VAR __odd__>|<TMPL_VAR __inner__>|<TMPL_VAR __counter__>)</TMPL_LOOP>foo" => "
+(1|0|1|0|1)
+(0|0|0|1|2)
+(0|1|1|0|3)foo", {blah => [undef, undef, undef], tt_config => [LOOP_CONTEXT_VARS => 1]}) if $is_cet;
+
+
+process_ok("<TMPL_LOOP NAME=\"blah\"><TMPL_IF EXPR='i==2'><TMPL_NEXT></TMPL_IF>(<TMPL_VAR i>)</TMPL_LOOP>foo" => "(1)(3)foo", {blah => [{i=>1}, {i=>2}, {i=>3}]}) if $is_cet;
+
+###----------------------------------------------------------------###
+print "### TT3 DIRECTIVES ###################################################\n";
+
+process_ok("<TMPL_GET foo>" => "FOO", {foo => "FOO"}) if $is_cet;
+process_ok("<TMPL_GET foo>" => "", {foo => "FOO", tt_config => [NO_TT => 1]}) if $is_cet;
+process_ok("<TMPL_GET foo>" => "", {foo => "FOO", tt_config => [SYNTAX => 'ht']}) if $is_cet;
+process_ok("<TMPL_GET 1+2+3+4>" => "10", {foo => "FOO"}) if $is_cet;
+
+process_ok("<TMPL_IF foo>bar<TMPL_ELSIF wow>wee<TMPL_ELSE>bing</TMPL_IF>" => "bar", {foo => "1"}) if $is_cet;
+
+process_ok("<TMPL_SET i = 'foo'>(<TMPL_VAR i>)" => "(foo)") if $is_cet;
+process_ok("<TMPL_SET i = 'foo'>(<TMPL_GET i>)" => "(foo)") if $is_cet;
+process_ok("<TMPL_FOR i IN [1..3]>(<TMPL_VAR i>)</TMPL_FOR>" => "(1)(2)(3)") if $is_cet;
+
+process_ok("<TMPL_BLOCK foo>(<TMPL_VAR i>)</TMPL_BLOCK><TMPL_PROCESS foo i='bar'>" => "(bar)") if $is_cet;
+process_ok("<TMPL_BLOCK foo>(<TMPL_VAR i>)</TMPL_BLOCK><TMPL_SET wow = PROCESS foo i='bar'><TMPL_VAR wow>" => "(bar)") if $is_cet;
+
+process_ok("<TMPL_GET template.foo><TMPL_META foo = 'bar'>" => "bar") if $is_cet;
+
+process_ok('<TMPL_MACRO bar(n) BLOCK>You said <TMPL_VAR n></TMPL_MACRO><TMPL_GET bar("hello")>' => 'You said hello') if $is_cet;
+
+###----------------------------------------------------------------###
+print "### TT3 CHOMPING #####################################################\n";
+
+process_ok("\n<TMPL_GET foo>" => "\nFOO", {foo => "FOO"}) if $is_cet;
+process_ok("<TMPL_GET foo->\n" => "FOO", {foo => "FOO"}) if $is_cet;
+process_ok("\n<-TMPL_GET foo>" => "FOO", {foo => "FOO"}) if $is_cet;
+
+###----------------------------------------------------------------###
+print "### TT3 INTERPOLATE ##################################################\n";
+
+process_ok('$foo <TMPL_GET foo> ${ 1 + 2 }' => '$foo FOO ${ 1 + 2 }', {foo => "FOO"});
+process_ok('$foo <TMPL_GET foo> ${ 1 + 2 }' => 'FOO FOO 3', {foo => "FOO", tt_config => [INTERPOLATE => 1]}) if $is_cet;
+process_ok('<TMPL_CONFIG INTERPOLATE => 1>$foo <TMPL_GET foo> ${ 1 + 2 }' => 'FOO FOO 3', {foo => "FOO"}) if $is_cet;
+
+###----------------------------------------------------------------###
+print "### DONE #############################################################\n";
projects / chaz / p5-CGI-Ex / commitdiff
