###----------------------------------------------------------------###
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
projects / chaz / p5-CGI-Ex / blobdiff