X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FCGI%2FEx%2FTemplate.pm;h=0b44a2c435ca4b47bbe9bebc555eb537a33d8f9c;hb=80a766126b7d0281ee013d369d9e6af45cc2cf42;hp=93533372da07177162bee7194d0a28c6f05ea745;hpb=f30b8252fcf71659a2fd3b5895e009ff8e39299d;p=chaz%2Fp5-CGI-Ex diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 9353337..0b44a2c 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -7,290 +7,294 @@ package CGI::Ex::Template; ###----------------------------------------------------------------### 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_NOTDOT - $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 - ); -BEGIN { - $VERSION = '2.10'; - - $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'; - $MAX_EVAL_RECURSE = 50; - $MAX_MACRO_RECURSE = 50; - - $TAGS = { - asp => ['<%', '%>' ], # ASP - default => ['\[%', '%\]' ], # default - html => ['' ], # HTML comments - mason => ['<%', '>' ], # HTML::Mason - metatext => ['%%', '%%' ], # Text::MetaText - php => ['<\?', '\?>' ], # PHP - star => ['\[\*', '\*\]' ], # TT alternate - template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style - }; +our $VERSION = '2.13'; - $SCALAR_OPS = { - '0' => sub { $_[0] }, - as => \&vmethod_as_scalar, - 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_as_scalar, - 'format' => \&vmethod_format, - hash => sub { {value => $_[0]} }, - html => sub { local $_ = $_[0]; 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, - }; +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 = { - as => \&vmethod_as_list, - 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_as_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, - pop => sub { pop @{ $_[0] } }, - push => sub { my $ref = shift; push @$ref, @_; return '' }, - random => sub { my $ref = shift; $ref->[ rand @$ref ] }, - 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 = { - as => \&vmethod_as_hash, - defined => sub { return 1 if @_ == 1; defined $_[0]->{ defined($_[1]) ? $_[1] : '' } }, - delete => sub { my $h = shift; my @v = delete @{ $h }{map {defined($_) ? $_ : ''} @_}; @_ == 1 ? $v[0] : \@v }, - each => sub { [%{ $_[0] }] }, - exists => sub { exists $_[0]->{ defined($_[1]) ? $_[1] : '' } }, - fmt => \&vmethod_as_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; $_ }, + indent => \&vmethod_indent, + int => sub { local $^W; int $_[0] }, + item => sub { $_[0] }, + js => sub { local $_ = $_[0]; return if ! $_; s/\n/\\n/g; s/\r/\\r/g; s/(? sub { lc $_[0] }, + lcfirst => sub { lcfirst $_[0] }, + length => sub { defined($_[0]) ? length($_[0]) : 0 }, + list => sub { [$_[0]] }, + log => sub { local $^W; log $_[0] }, + lower => sub { lc $_[0] }, + match => \&vmethod_match, + new => sub { defined $_[0] ? $_[0] : '' }, + null => sub { '' }, + oct => sub { local $^W; oct $_[0] }, + rand => sub { local $^W; rand shift }, + remove => sub { vmethod_replace(shift, shift, '', 1) }, + repeat => \&vmethod_repeat, + replace => \&vmethod_replace, + search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ }, + sin => sub { local $^W; sin $_[0] }, + size => sub { 1 }, + split => \&vmethod_split, + sprintf => sub { local $^W; my $pat = shift; sprintf($pat, @_) }, + sqrt => sub { local $^W; sqrt $_[0] }, + srand => sub { local $^W; srand $_[0]; '' }, + stderr => sub { print STDERR $_[0]; '' }, + substr => \&vmethod_substr, + trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ }, + uc => sub { uc $_[0] }, + ucfirst => sub { ucfirst $_[0] }, + upper => sub { uc $_[0] }, + uri => \&vmethod_uri, + url => \&vmethod_url, +}; - $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 {}], - 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], - WHILE => [\&parse_IF, \&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 ], - ['', 0, ['{}'], undef ], - ['', 0, ['[]'], 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\-\.]+)*'; - $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?'; - $QR_AQ_NOTDOT = "(?! \\s* $QR_COMMENTS \\.)"; - $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=[;+]) )'; # the + comes into play on filenames - $QR_PRIVATE = qr/^[_.]/; - - $WHILE_MAX = 1000; - $EXTRA_COMPILE_EXT = '.sto2'; - - 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; + } }; ###----------------------------------------------------------------### @@ -328,8 +332,14 @@ sub _process { ### parse and execute my $doc; eval { + ### handed us a precompiled document + if (ref($file) eq 'HASH' && $file->{'_tree'}) { + $doc = $file; + ### load the document - $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");; + } else { + $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");; + } ### prevent recursion $self->throw('file', "recursion into '$doc->{name}'") @@ -340,18 +350,18 @@ sub _process { if (! @{ $doc->{'_tree'} }) { # no tags found - just return the content $$out_ref = ${ $doc->{'_content'} }; } else { - local $self->{'_vars'}->{'component'} = $doc; - $self->{'_vars'}->{'template'} = $doc if $self->{'_top_level'}; + local $self->{'_component'} = $doc; + local $self->{'_template'} = $self->{'_top_level'} ? $doc : $self->{'_template'}; + local @{ $self }{@CONFIG_RUNTIME} = @{ $self }{@CONFIG_RUNTIME}; $self->execute_tree($doc->{'_tree'}, $out_ref); - delete $self->{'_vars'}->{'template'} if $self->{'_top_level'}; } - }; - ### trim whitespace from the beginning and the end of a block or template - if ($self->{'TRIM'}) { - substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ \s+ $ }{}x; # tail first - substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ ^ \s+ }{}x; - } + ### trim whitespace from the beginning and the end of a block or template + if ($self->{'TRIM'}) { + substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ \s+ $ }{}x; # tail first + substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ ^ \s+ }{}x; + } + }; ### handle exceptions if (my $err = $@) { @@ -371,20 +381,20 @@ sub load_parsed_tree { return if ! defined $file; my $doc = {name => $file}; + my $ref = $self->{'_documents'}->{$file}; ### looks like a string reference if (ref $file) { - $doc->{'_content'} = $file; - $doc->{'name'} = 'input text'; - $doc->{'is_str_ref'} = 1; + $doc->{'_content'} = $file; + $doc->{'name'} = 'input text'; + $doc->{'_is_str_ref'} = 1; ### looks like a previously cached-in-memory document - } elsif ($self->{'_documents'}->{$file} - && ( ($self->{'_documents'}->{$file}->{'_cache_time'} == time) # don't stat more than once a second - || ($self->{'_documents'}->{$file}->{'modtime'} - == (stat $self->{'_documents'}->{$file}->{'_filename'})[9]))) { + } elsif ($ref + && ( time - $ref->{'cache_time'} < ($self->{'STAT_TTL'} || $STAT_TTL) # don't stat more than once a second + || $ref->{'modtime'} == (stat $ref->{'_filename'})[9] # otherwise see if the file was modified + )) { $doc = $self->{'_documents'}->{$file}; - $doc->{'_cache_time'} = time; return $doc; ### looks like a block name of some sort @@ -404,6 +414,13 @@ sub load_parsed_tree { $doc->{'_tree'} = $block->{'_tree'} || $self->throw('block', "Invalid block definition (missing tree)"); return $doc; + ### handle cached not_founds + } elsif ($self->{'_not_found'}->{$file} + && ((time - $self->{'_not_found'}->{$file}->{'cache_time'} + < ($self->{'NEGATIVE_STAT_TTL'} || $self->{'STAT_TTL'} || $STAT_TTL)) # negative cache for a second + || do { delete $self->{'_not_found'}->{$file}; 0 } # clear cache on failure + )) { + die $self->{'_not_found'}->{$file}->{'exception'}; ### go and look on the file system } else { @@ -430,10 +447,19 @@ sub load_parsed_tree { last; } } - die $err if ! $doc->{'_tree'}; + $err = '' if ! $doc->{'_tree'}; } elsif ($self->{'DEFAULT'}) { - $doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) } || die $err; - } else { + $err = '' if ($doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) }); + } + if ($err) { + ### cache the negative error + if (! defined($self->{'NEGATIVE_STAT_TTL'}) || $self->{'NEGATIVE_STAT_TTL'}) { + $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; + $self->{'_not_found'}->{$file} = { + cache_time => time, + exception => $self->exception($err->type, $err->info." (cached)"), + }; + } die $err; } } @@ -473,21 +499,22 @@ sub load_parsed_tree { $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'}; } - local $self->{'_vars'}->{'component'} = $doc; - $doc->{'_tree'} = $self->parse_tree($doc->{'_content'}); # errors die + local $self->{'_component'} = $doc; + $doc->{'_tree'} = eval { $self->parse_tree($doc->{'_content'}) } + || do { my $e = $@; $e->doc($doc) if UNIVERSAL::can($e, 'doc') && ! $e->doc; die $e }; # errors die } ### cache parsed_tree in memory unless asked not to do so - if (! $doc->{'is_str_ref'} && (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'})) { + if (! $doc->{'_is_str_ref'} && (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'})) { $self->{'_documents'}->{$file} ||= $doc; - $doc->{'_cache_time'} = time; + $doc->{'cache_time'} = time; ### allow for config option to keep the cache size down if ($self->{'CACHE_SIZE'}) { my $all = $self->{'_documents'}; if (scalar(keys %$all) > $self->{'CACHE_SIZE'}) { my $n = 0; - foreach my $file (sort {$all->{$b}->{'_cache_time'} <=> $all->{$a}->{'_cache_time'}} keys %$all) { + foreach my $file (sort {$all->{$b}->{'cache_time'} <=> $all->{$a}->{'cache_time'}} keys %$all) { delete($all->{$file}) if ++$n > $self->{'CACHE_SIZE'}; } } @@ -513,6 +540,12 @@ sub load_parsed_tree { ###----------------------------------------------------------------### 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) { @@ -524,41 +557,37 @@ sub parse_tree { my $END = $self->{'END_TAG'} || $TAGS->{$STYLE}->[1]; local $self->{'_end_tag'} = $END; + local @{ $self }{@CONFIG_COMPILETIME} = @{ $self }{@CONFIG_COMPILETIME}; + my @tree; # the parsed tree my $pointer = \@tree; # pointer to current tree to handle nested blocks my @state; # maintain block levels local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS) - local $self->{'_in_perl'}; # no interpolation in perl - my @move_to_front; # items that need to be declared first (usually BLOCKS) + local $self->{'_no_interp'} = 0; # no interpolation in some blocks (usually PERL) + my @in_view; # let us know if we are in a view + my @blocks; # store blocks for later moving to front my @meta; # place to store any found meta information (to go into META) my $post_chomp = 0; # previous post_chomp setting my $continue = 0; # flag for multiple directives in the same tag - my $post_op; # 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 } @@ -582,12 +611,18 @@ sub parse_tree { 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 - $$str_ref =~ m{ \G (.*?) ($END) }gcxs # brute force - can't comment tags with nested %] + + ### leading # means to comment the entire section + if ($$str_ref =~ m{ \G \# }gcx) { + $$str_ref =~ m{ \G (.*?) ([+~=-]?) ($END) }gcxs # brute force - can't comment tags with nested %] || $self->throw('parse', "Missing closing tag", undef, pos($$str_ref)); $node->[0] = '#'; - $node->[2] = pos($$str_ref) - length($2); + $node->[2] = pos($$str_ref) - length($3); push @$pointer, $node; + + $post_chomp = $2; + $post_chomp ||= $self->{'POST_CHOMP'}; + $post_chomp =~ y/-=~+/1230/ if $post_chomp; next; } $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; @@ -599,21 +634,39 @@ sub parse_tree { && ($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) { @@ -626,7 +679,7 @@ sub parse_tree { $parent_node->[5] = $node; my $parent_type = $parent_node->[0]; if (! $DIRECTIVES->{$func}->[4]->{$parent_type}) { - $self->throw('parse', "Found unmatched nested block", $node, 0); + $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref)); } } @@ -635,94 +688,61 @@ sub parse_tree { ### normal end block if ($func eq 'END') { - if ($DIRECTIVES->{$parent_node->[0]}->[5]) { # move things like BLOCKS to front - push @move_to_front, $parent_node; - if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var + if ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front + if (defined($parent_node->[3]) && @in_view) { + push @{ $in_view[-1] }, $parent_node; + } else { + push @blocks, $parent_node; + } + if ($pointer->[-1] && ! $pointer->[-1]->[6]) { splice(@$pointer, -1, 1, ()); } - } elsif ($parent_node->[0] =~ /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] ||= []; } + ### handle block directives + } elsif ($DIRECTIVES->{$func}->[2] && ! $post_op) { + push @state, $node; + $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node + push @in_view, [] if $func eq 'VIEW'; + $self->{'_no_interp'}++ if $DIRECTIVES->{$node->[0]}->[5] # allow no_interp to turn on and off + } elsif ($func eq 'TAGS') { - my $end; - if ($$str_ref =~ m{ - \G (\w+) # tags name - \s* $QR_COMMENTS # optional comments - ([+~=-]?) ($END) # forced close - }gcx) { - my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref)); - ($START, $END) = @$ref; - ($post_chomp, $end) = ($2, $3); - - } elsif ($$str_ref =~ m{ - \G (\S+) \s+ (\S+) # two non-space things - (?:\s+(un|)quoted?)? # optional unquoted adjective - \s* $QR_COMMENTS # optional comments - ([+~=-]?) ($END) # forced close - }gcxo) { - ($START, $END, my $unquote, $post_chomp, $end) = ($1, $2, $3, $4, $5); - for ($START, $END) { - if ($unquote) { eval { "" =~ /$_/; 1 } || $self->throw('parse', "Invalid TAGS \"$_\": $@", undef, pos($$str_ref)) } - else { $_ = quotemeta $_ } - } - } else { - $self->throw('parse', "Invalid TAGS", undef, pos($$str_ref)); + ($START, $END) = @{ $node->[3] }; + + ### allow for one more closing tag of the old style + if ($$str_ref =~ m{ \G ([+~=-]?) $self->{'_end_tag'} }gcxs) { + $post_chomp = $1 || $self->{'POST_CHOMP'}; + $post_chomp =~ y/-=~+/1230/ if $post_chomp; + $continue = 0; + $post_op = 0; + $self->{'_end_tag'} = $END; # need to keep track so parse_expr knows when to stop + next; } - $post_chomp ||= $self->{'POST_CHOMP'}; - $post_chomp =~ y/-=~+/1230/ if $post_chomp; - - $node->[2] = pos($$str_ref) - length($end); - $continue = 0; - $post_op = undef; - - $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); - my $hash; - if (($hash = $self->play_expr($args->[-1])) - && 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] ||= []; - } + unshift @meta, %{ $node->[3] }; # first defined win + $node->[3] = undef; # only let these be defined once - at the front of the tree } - #} elsif (1) { - # $node->[0] = 'GET'; - # $node->[2] = $node->[1] + 5; - # $node->[3] = ['one',0]; - # $$str_ref =~ m{ $END }gcx; - # push @$pointer, $node; - # next; - ### 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) >? \s* $QR_COMMENTS }gcxo) { + if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? (?! [+=~-]? $END) \s* $QR_COMMENTS }gcx) { $node->[0] = 'SET'; $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, $str_ref, $node, $1, $var) }; if (my $err = $@) { @@ -733,94 +753,45 @@ sub parse_tree { $node->[0] = 'GET'; $node->[3] = $var; } - - ### now look for the closing tag - } elsif ($$str_ref =~ m{ \G ([+=~-]?) ($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; - - } else { # error - my $all = substr($$str_ref, $node->[1], pos($$str_ref) - $node->[1]); - $all =~ s/^\s+//; - $all =~ s/\s+$//; - $self->throw('parse', "Not sure how to handle tag \"$all\"", $node); - } - - ### 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; + $node->[2] = pos $$str_ref; } - ### look for the closing tag again - if ($$str_ref =~ m{ \G ([+=~-]?) ($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 } @@ -836,22 +807,36 @@ sub parse_tree { return \@tree; } +sub parse_tree_hte { + require CGI::Ex::Template::HTE; + &CGI::Ex::Template::HTE::parse_tree_hte; +} + sub parse_expr { my $self = shift; my $str_ref = shift; my $ARGS = shift || {}; my $is_aq = $ARGS->{'auto_quote'} ? 1 : 0; + my $mark = pos $$str_ref; ### allow for custom auto_quoting (such as hash constructors) if ($is_aq) { - if ($$str_ref =~ m{ \G $ARGS->{'auto_quote'} \s* $QR_COMMENTS }gcx) { + if ($$str_ref =~ m{ \G $ARGS->{'auto_quote'} }gcx) { return $1; - ### allow for auto-quoted $foo or ${foo.bar} type constructs - } elsif ($$str_ref =~ m{ \G \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }gcxo) { + ### allow for auto-quoted $foo + } elsif ($$str_ref =~ m{ \G \$ (\w+\b (?:\.\w+\b)*) \s* $QR_COMMENTS }gcxo) { my $name = $1; - return $self->parse_expr(\$name); + if ($$str_ref !~ m{ \G \( }gcx || $name =~ /^(?:qw|m|\d)/) { + return $self->parse_expr(\$name); + } + ### this is a little cryptic/odd - but TT allows items in + ### autoquote position to only be prefixed by a $ - gross + ### so we will defer to the regular parsing - but after the $ + pos($$str_ref) = $mark + 1; + $is_aq = undef; # but don't allow operators - false flag handed down + ### allow for ${foo.bar} type constructs } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) { my $var = $self->parse_expr($str_ref); $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo @@ -863,7 +848,6 @@ sub parse_expr { ### test for leading prefix operators my $has_prefix; - my $mark = pos $$str_ref; while (! $is_aq && $$str_ref =~ m{ \G ($QR_OP_PREFIX) }gcxo) { push @{ $has_prefix }, $1; $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; @@ -872,6 +856,7 @@ sub parse_expr { my @var; my $is_literal; my $is_namespace; + my $already_parsed_args; ### allow hex if ($$str_ref =~ m{ \G 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }gcxo) { @@ -886,39 +871,59 @@ sub parse_expr { $is_literal = 1; ### allow for quoted array constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G qw (\W) \s* }gcxo) { + } elsif (! $is_aq && $$str_ref =~ m{ \G qw ([^\w\s]) \s* }gcxo) { my $quote = $1; $quote =~ y|([{<|)]}>|; - $$str_ref =~ m{ \G (.*?) \Q$quote\E \s* $QR_COMMENTS }gcxs + $$str_ref =~ m{ \G (.*?) (?throw('parse.missing.array_close', "Missing close \"$quote\"", undef, pos($$str_ref)); my $str = $1; - $str =~ s{ ^ \s+ | \s+ $ }{}x; + $str =~ s{ ^ \s+ }{}x; + $str =~ s{ \s+ $ }{}x; + $str =~ s{ \\ \Q$quote\E }{$quote}gx; push @var, [undef, '[]', split /\s+/, $str]; + ### allow for regex constructor + } elsif (! $is_aq && $$str_ref =~ m{ \G / }gcx) { + $$str_ref =~ m{ \G (.*?) (?throw('parse', 'Unclosed regex tag "/"', undef, pos($$str_ref)); + my ($str, $opts) = ($1, $2); + $self->throw('parse', 'e option not allowed on regex', undef, pos($$str_ref)) if $opts =~ /e/; + $self->throw('parse', 'g option not supported on regex', undef, pos($$str_ref)) if $opts =~ /g/; + $str =~ s|\\n|\n|g; + $str =~ s|\\t|\t|g; + $str =~ s|\\r|\r|g; + $str =~ s|\\\/|\/|g; + $str =~ s|\\\$|\$|g; + $self->throw('parse', "Invalid regex: $@", undef, pos($$str_ref)) if ! eval { "" =~ /$str/; 1 }; + push @var, [undef, 'qr', $str, $opts]; + ### looks like a normal variable start } elsif ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxo) { push @var, $1; $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1}; ### allow for literal strings - } elsif ($$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }gcxos) { - if ($1 eq "'") { # no interpolation on single quoted strings - my $str = $2; + } elsif ($$str_ref =~ m{ \G ([\"\']) }gcx) { + my $quote = $1; + $$str_ref =~ m{ \G (.*?) (?throw('parse', "Unclosed quoted string ($1)", undef, pos($$str_ref)); + my $str = $1; + if ($quote eq "'") { # no interpolation on single quoted strings $str =~ s{ \\\' }{\'}xg; push @var, \ $str; $is_literal = 1; } else { - my $str = $2; $str =~ s/\\n/\n/g; $str =~ s/\\t/\t/g; $str =~ s/\\r/\r/g; $str =~ s/\\"/"/g; - my @pieces = $ARGS->{'auto_quote'} + my @pieces = $is_aq ? split(m{ (?: ^ | (?{'_operator_precedence'} = 0; # reset precedence my $hashref = [undef, '{}']; - while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+) $QR_AQ_NOTDOT"}))) { + while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))) { $$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo; my $val = $self->parse_expr($str_ref); push @$hashref, $key, $val; @@ -992,19 +996,36 @@ sub parse_expr { $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref)); - @var = @$var; - pop @var; # pull off the trailing args of the paren group - # TODO - we could forward lookahed for a period or pipe + + $self->throw('parse', 'Paren group cannot be followed by an open paren', undef, pos($$str_ref)) + if $$str_ref =~ m{ \G \( }gcx; + + $already_parsed_args = 1; + if (! ref $var) { + push @var, \$var, 0; + $is_literal = 1; + } elsif (! defined $var->[0]) { + push @var, $var, 0; + } else { + push @var, @$var; + } ### nothing to find - return failure } else { + pos($$str_ref) = $mark if $is_aq || $has_prefix; return; } - return if $is_aq; # auto_quoted thing was too complicated + # auto_quoted thing was too complicated + if ($is_aq) { + pos($$str_ref) = $mark; + return; + } ### looks for args for the initial - if ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) { + if ($already_parsed_args) { + # do nothing + } elsif ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) { local $self->{'_operator_precedence'} = 0; # reset precedence my $args = $self->parse_args($str_ref, {is_parened => 1}); $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo @@ -1014,10 +1035,18 @@ sub parse_expr { push @var, 0; } + ### allow for nested items - while ($$str_ref =~ m{ \G ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }gcxo) { + while ($$str_ref =~ m{ \G ( \.(?!\.) | \|(?!\|) ) }gcx) { + if ($1 eq '|' && $self->{'V2PIPE'}) { + pos($$str_ref) -= 1; + last; + } + push(@var, $1) if ! $ARGS->{'no_dots'}; + $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; + ### allow for interpolated variables in the middle - one.$foo.two if ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) { push @var, $self->{'V1DOLLAR'} ? $1 : [$1, 0]; @@ -1064,7 +1093,7 @@ sub parse_expr { } ### allow for all "operators" - if (! $self->{'_operator_precedence'}) { + if (! $self->{'_operator_precedence'} && defined $is_aq) { my $tree; my $found; while (1) { @@ -1082,6 +1111,9 @@ sub parse_expr { } 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 --) @@ -1222,34 +1254,75 @@ sub parse_args { my @args; my @named; + my $name; + my $end = $self->{'_end_tag'} || '(?!)'; while (1) { my $mark = pos $$str_ref; + + ### look to see if the next thing is a directive or a closing tag if (! $ARGS->{'is_parened'} - && $$str_ref =~ m{ \G $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$self->{'_end_tag'}))) }gcxo + && ! $ARGS->{'require_arg'} + && $$str_ref =~ m{ \G $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$end))) }gcxo && ((pos($$str_ref) = $mark) || 1) # always revert && $DIRECTIVES->{$self->{'ANYCASE'} ? uc($1) : $1} # looks like a directive - we are done ) { last; } + if ($$str_ref =~ m{ \G [+=~-]? $end }gcx) { + pos($$str_ref) = $mark; + last; + } - if (defined(my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+) $QR_AQ_NOTDOT"})) - && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # see if we also match assignment - || ((pos $$str_ref = $mark) && 0)) # if not - we need to rollback - ) { + ### find the initial arg + my $name; + if ($ARGS->{'allow_bare_filenames'}) { + $name = $self->parse_expr($str_ref, {auto_quote => " + ($QR_FILENAME # file name + | $QR_BLOCK # or block + (?= [+=~-]? $end # an end tag + | \\s*[+,;] # followed by explicit + , or ; + | \\s+ (?! [\\s=]) # or space not before an = + ) \\s* $QR_COMMENTS"}); + # filenames can be separated with a "+" - why a "+" ? + if ($$str_ref =~ m{ \G \+ (?! [+=~-]? $end) \s* $QR_COMMENTS }gcxo) { + push @args, $name; + $ARGS->{'require_arg'} = 1; + next; + } + } + if (! defined $name) { + $name = $self->parse_expr($str_ref); + if (! defined $name) { + if ($ARGS->{'require_arg'} && ! @args && ! $ARGS->{'positional_only'} && ! @named) { + $self->throw('parse', 'Argument required', undef, pos($$str_ref)); + } else { + last; + } + } + } + + $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; + + ### see if it is named or positional + if ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo) { $self->throw('parse', 'Named arguments not allowed', undef, $mark) if $ARGS->{'positional_only'}; my $val = $self->parse_expr($str_ref); - $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo; + $name = $name->[0] if ref($name) && @$name == 2 && ! $name->[1]; # strip a level of indirection on named arguments push @named, $name, $val; - } elsif (defined(my $arg = $self->parse_expr($str_ref))) { - push @args, $arg; - $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo; } else { - last; + push @args, $name; } + + ### look for trailing comma + $ARGS->{'require_arg'} = ($$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo) || 0; } - ### allow for named arguments to be added also - push @args, [[undef, '{}', @named], 0] if scalar @named; + ### allow for named arguments to be added at the front (if asked) + if ($ARGS->{'named_at_front'}) { + unshift @args, [[undef, '{}', @named], 0]; + } elsif (scalar @named) { # only add at end - if there are some + push @args, [[undef, '{}', @named], 0] + } return \@args; } @@ -1257,7 +1330,7 @@ sub parse_args { ### allow for looking for $foo or ${foo.bar} in TEXT "nodes" of the parse tree. sub interpolate_node { my ($self, $tree, $offset) = @_; - return if $self->{'_in_perl'}; + return if $self->{'_no_interp'}; ### split on variables while keeping the variables my @pieces = split m{ (?: ^ | (?[-1]; @@ -1303,16 +1376,13 @@ sub execute_tree { 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); } } @@ -1329,7 +1399,6 @@ sub play_expr { my $ref; 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 '..'; @@ -1337,7 +1406,7 @@ sub play_expr { } 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}; } @@ -1346,10 +1415,13 @@ sub play_expr { 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 = $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'}); + } } } @@ -1376,13 +1448,12 @@ sub play_expr { 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; } @@ -1390,7 +1461,7 @@ sub play_expr { 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; } @@ -1515,6 +1586,12 @@ sub play_expr { return $ref; } +sub is_empty_named_args { + my ($self, $hash_ident) = @_; + # [[undef, '{}', 'key1', 'val1', 'key2, 'val2'], 0] + return @{ $hash_ident->[0] } <= 2; +} + sub set_variable { my ($self, $var, $val, $ARGS) = @_; $ARGS ||= {}; @@ -1532,7 +1609,7 @@ sub set_variable { # 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 { @@ -1542,7 +1619,7 @@ sub set_variable { 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 { @@ -1581,7 +1658,7 @@ sub set_variable { 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; } @@ -1669,11 +1746,12 @@ sub play_operator { 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; @@ -1722,6 +1800,8 @@ sub play_operator { $last->[-1] = (ref $last->[-1] ? [@{ $last->[-1] }, @_] : [@_]) if @_; return $self->play_expr($last); } }; + } elsif ($op eq 'qr') { + return $tree->[3] ? qr{(?$tree->[3]:$tree->[2])} : qr{$tree->[2]}; } $self->throw('operator', "Un-implemented operation $op"); @@ -1732,18 +1812,19 @@ sub play_operator { sub parse_BLOCK { my ($self, $str_ref, $node) = @_; - my $block_name = ''; - if ($$str_ref =~ m{ \G (\w+ (?: :\w+)*) \s* (?! [\.\|]) }gcx - || $$str_ref =~ m{ \G '(|.*?[^\\])' \s* (?! [\.\|]) }gcx - || $$str_ref =~ m{ \G "(|.*?[^\\])" \s* (?! [\.\|]) }gcx - ) { - $block_name = $1; - ### allow for nested blocks to have nested names - my @names = map {$_->[3]} grep {$_->[0] eq 'BLOCK'} @{ $self->{'_state'} }; - $block_name = join("/", @names, $block_name) if scalar @names; - } + my $end = $self->{'_end_tag'} || '(?!)'; + my $block_name = $self->parse_expr($str_ref, {auto_quote => " + ($QR_FILENAME # file name + | $QR_BLOCK # or block + (?= [+=~-]? $end # an end tag + | \\s*[+,;] # followed by explicit + , or ; + | \\s+ (?! [\\s=]) # or space not before an = + ) \\s* $QR_COMMENTS"}); + + return '' if ! defined $block_name; - return $block_name; + my $prepend = join "/", map {$_->[3]} grep {ref($_) && $_->[0] eq 'BLOCK'} @{ $self->{'_state'} || {} }; + return $prepend ? "$prepend/$block_name" : $block_name; } sub play_BLOCK { @@ -1752,7 +1833,7 @@ sub play_BLOCK { ### store a named reference - but do nothing until something processes it $self->{'BLOCKS'}->{$block_name} = { _tree => $node->[4], - name => $self->{'_vars'}->{'component'}->{'name'} .'/'. $block_name, + name => $self->{'_component'}->{'name'} .'/'. $block_name, }; return; @@ -1760,7 +1841,12 @@ sub play_BLOCK { 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) = @_; @@ -1770,7 +1856,7 @@ sub parse_CASE { sub parse_CATCH { my ($self, $str_ref) = @_; - return $self->parse_expr($str_ref, {auto_quote => "(\\w+ (?: \\.\\w+)*) $QR_AQ_SPACE"}); + return $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"}); } sub play_control { @@ -1781,30 +1867,27 @@ sub play_control { sub play_CLEAR { my ($self, $undef, $node, $out_ref) = @_; $$out_ref = ''; + return; +} + +sub parse_CONFIG { + require CGI::Ex::Template::Extra; + &CGI::Ex::Template::Extra::parse_CONFIG; +} + +sub play_CONFIG { + require CGI::Ex::Template::Extra; + &CGI::Ex::Template::Extra::play_CONFIG; } sub parse_DEBUG { - 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]->(@_) } @@ -1825,73 +1908,22 @@ sub play_DEFAULT { sub parse_DUMP { my ($self, $str_ref) = @_; - my $ref = $self->parse_expr($str_ref); - return $ref; + return $self->parse_args($str_ref, {named_at_front => 1}); } sub play_DUMP { - my ($self, $ident, $node) = @_; - require Data::Dumper; - local $Data::Dumper::Sortkeys = 1; - my $info = $self->node_info($node); - my $out; - my $var; - if ($ident) { - $out = Data::Dumper::Dumper($self->play_expr($ident)); - $var = $info->{'text'}; - $var =~ s/^[+\-~=]?\s*DUMP\s+//; - $var =~ s/\s*[+\-~=]?$//; - } else { - my @were_never_here = (qw(template component), grep {$_ =~ $QR_PRIVATE} keys %{ $self->{'_vars'} }); - local @{ $self->{'_vars'} }{ @were_never_here }; - delete @{ $self->{'_vars'} }{ @were_never_here }; - $out = Data::Dumper::Dumper($self->{'_vars'}); - $var = 'EntireStash'; - } - if ($ENV{'REQUEST_METHOD'}) { - $out =~ s/$out"; - $out =~ s/\$VAR1/$var/; - $out = "DUMP: File \"$info->{file}\" line $info->{line}$out"; - } else { - $out =~ s/\$VAR1/$var/; - } - - 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 { @@ -1915,7 +1947,7 @@ sub play_FOREACH { return '' if ! defined $items; if (ref($items) !~ /Iterator$/) { - $items = $PACKAGE_ITERATOR->new($items); + $items = $self->iterator($items); } my $sub_tree = $node->[4]; @@ -1979,7 +2011,7 @@ sub play_FOREACH { die $error if $error && $error != 3; # Template::Constants::STATUS_DONE; } - return undef; + return; } sub parse_GET { @@ -1990,9 +2022,15 @@ 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 { @@ -2033,25 +2071,27 @@ sub play_INCLUDE { 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, $var, $node, $out_ref) = @_; - my ($names, $args) = @$var; + my ($self, $args, $node, $out_ref) = @_; + if ($self->{'NO_INCLUDES'}) { + $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive"); + } - foreach my $name (@$names) { + my ($named, @files) = @$args; + + foreach my $name (@files) { my $filename = $self->play_expr($name); $$out_ref .= $self->_insert($filename); } @@ -2059,176 +2099,80 @@ sub play_INSERT { return; } -sub parse_MACRO { - my ($self, $str_ref, $node) = @_; - - my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+) $QR_AQ_NOTDOT"}); - $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; if ($self->{'_top_level'}) { - $ref = $self->{'_vars'}->{'template'} ||= {}; + $ref = $self->{'_template'} ||= {}; } else { - $ref = $self->{'_vars'}->{'component'} ||= {}; - } - foreach my $key (keys %$hash) { - next if $key eq 'name' || $key eq 'modtime'; - $ref->{$key} = $hash->{$key}; + $ref = $self->{'_component'} ||= {}; } + + @{ $ref }{ @keys } = @{ $hash }{ @keys }; 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 { my ($self, $str_ref) = @_; - my $info = [[], []]; - while (defined(my $filename = $self->parse_expr($str_ref, { - auto_quote => "($QR_FILENAME | \\w+ (?: :\\w+)* ) $QR_AQ_SPACE", - }))) { - push @{$info->[0]}, $filename; - last if $$str_ref !~ m{ \G \+ \s* $QR_COMMENTS }gcxo; - } - - ### we can almost use parse_args - except we allow for nested key names (foo.bar) here - while (1) { - my $mark = pos $$str_ref; - if ($$str_ref =~ m{ \G $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$self->{'_end_tag'}))) }gcxo) { - pos($$str_ref) = $mark; - last if $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}; # looks like a directive - we are done - } - if ($$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) { - pos($$str_ref) = $mark; - last; - } - - my $var = $self->parse_expr($str_ref); - last if ! defined $var; - if ($$str_ref !~ m{ \G = >? \s* }gcx) { - $self->throw('parse.missing.equals', 'Missing equals while parsing args', undef, pos($$str_ref)); - } - - my $val = $self->parse_expr($str_ref); - push @{$info->[1]}, [$var, $val]; - $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo if $val; - } - - return $info; + return $self->parse_args($str_ref, { + named_at_front => 1, + allow_bare_filenames => 1, + require_arg => 1, + }); } sub play_PROCESS { my ($self, $info, $node, $out_ref) = @_; + if ($self->{'NO_INCLUDES'}) { + $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive"); + } - my ($files, $args) = @$info; + my ($args, @files) = @$info; ### set passed args - foreach (@$args) { - my $key = $_->[0]; - my $val = $self->play_expr($_->[1]); + # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0] + $args = $args->[0]; + foreach (my $i = 2; $i < @$args; $i+=2) { + my $key = $args->[$i]; + my $val = $self->play_expr($args->[$i+1]); if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever foreach my $key (keys %$val) { $self->set_variable([$key,0], $val->{$key}); @@ -2239,7 +2183,7 @@ sub play_PROCESS { } ### iterate on any passed block or filename - foreach my $ref (@$files) { + foreach my $ref (@files) { next if ! defined $ref; my $filename = $self->play_expr($ref); my $out = ''; # have temp item to allow clear to correctly clear @@ -2250,10 +2194,18 @@ sub play_PROCESS { ### allow for $template which is used in some odd instances } else { - $self->throw('process', "Unable to process document $filename") if $ref->[0] ne 'template'; + my $doc; + if ($ref->[0] eq 'template') { + $doc = $filename; + } else { + $doc = $self->play_expr($ref); + if (ref($doc) ne 'HASH' || ! $doc->{'_tree'}) { + $self->throw('process', "Passed item doesn't appear to be a valid document"); + } + } $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'}; local $self->{'_process_dollar_template'} = 1; - local $self->{'_vars'}->{'component'} = my $doc = $filename; + local $self->{'_component'} = $filename; return if ! $doc->{'_tree'}; ### execute and trim @@ -2282,37 +2234,8 @@ sub play_PROCESS { } 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 { @@ -2352,6 +2275,7 @@ sub parse_SET { push @SET, ['=', $set, undef]; } } + return \@SET; } @@ -2360,7 +2284,7 @@ sub play_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'; @@ -2421,20 +2345,52 @@ sub play_SWITCH { 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+ (?: \\.\\w+)*) $QR_AQ_SPACE"}); + my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"}); $self->throw('parse.missing', "Missing name in THROW", $node, pos($$str_ref)) if ! $name; - my $args = $self->parse_args($str_ref); + my $args = $self->parse_args($str_ref, {named_at_front => 1}); return [$name, $args]; } sub play_THROW { my ($self, $ref, $node) = @_; my ($name, $args) = @$ref; + $name = $self->play_expr($name); - my @args = $args ? map { $self->play_expr($_) } @$args : (); - $self->throw($name, \@args, $node); + + my ($named, @args) = @$args; + push @args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some + + @args = map { $self->play_expr($_) } @args; + $self->throw($name, \@args, $node); # dies + return; # but return just in case } sub play_TRY { @@ -2511,93 +2467,30 @@ sub parse_UNLESS { 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+) $QR_AQ_NOTDOT"})) - && ($$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+ (?: (?:\\.|::) \\w+)*) $QR_AQ_NOTDOT"}); - $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}); - - 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 '.' - - ### 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; - my @args = $args ? map { $self->play_expr($_) } @$args : (); - $obj = $shape->new($context, @args); - } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine) - $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($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; - my @args = $args ? map { $self->play_expr($_) } @$args : (); - $obj = $shape->new($context, @args); - } - } elsif ($self->{'LOAD_PERL'}) { - my $require = "$module.pm"; - $require =~ s|::|/|g; - if (eval {require $require}) { - my @args = $args ? map { $self->play_expr($_) } @$args : (); - $obj = $module->new(@args); - } - } - } - if (! defined $obj) { - my $err = "$module: plugin not found"; - $self->throw('plugin', $err); - } + require CGI::Ex::Template::Extra; + &CGI::Ex::Template::Extra::play_USE; +} - ### all good - $self->set_variable(\@var, $obj); +sub parse_VIEW { + require CGI::Ex::Template::Extra; + &CGI::Ex::Template::Extra::parse_VIEW; +} - return; +sub play_VIEW { + require CGI::Ex::Template::Extra; + &CGI::Ex::Template::Extra::play_VIEW; } +sub parse_WHILE { $DIRECTIVES->{'IF'}->[0]->(@_) } + sub play_WHILE { my ($self, $var, $node, $out_ref) = @_; - return '' if ! defined $var; + return if ! defined $var; my $sub_tree = $node->[4]; @@ -2619,24 +2512,24 @@ sub play_WHILE { } die "WHILE loop terminated (> $WHILE_MAX iterations)\n" if ! $count; - return undef; + return; } -sub parse_WRAPPER { $DIRECTIVES->{'INCLUDE'}->[0]->(@_) } +sub parse_WRAPPER { $DIRECTIVES->{'PROCESS'}->[0]->(@_) } sub play_WRAPPER { - my ($self, $var, $node, $out_ref) = @_; + my ($self, $args, $node, $out_ref) = @_; my $sub_tree = $node->[4] || return; - my ($names, $args) = @$var; + my ($named, @files) = @$args; my $out = ''; $self->execute_tree($sub_tree, \$out); - foreach my $name (reverse @$names) { + foreach my $name (reverse @files) { local $self->{'_vars'}->{'content'} = $out; $out = ''; - $DIRECTIVES->{'INCLUDE'}->[1]->($self, [[$name], $args], $node, \$out); + $DIRECTIVES->{'INCLUDE'}->[1]->($self, [$named, $name], $node, \$out); } $$out_ref .= $out; @@ -2663,7 +2556,7 @@ sub include_filename { my $paths = $self->{'INCLUDE_PATHS'} ||= do { # TT does this everytime a file is looked up - we are going to do it just in time - the first time - my $paths = $self->{'INCLUDE_PATH'} || $self->throw('file', "INCLUDE_PATH not set"); + my $paths = $self->{'INCLUDE_PATH'} || []; $paths = $paths->() if UNIVERSAL::isa($paths, 'CODE'); $paths = $self->split_paths($paths) if ! UNIVERSAL::isa($paths, 'ARRAY'); $paths; # return of the do @@ -2690,10 +2583,8 @@ sub _insert { 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; } @@ -2724,7 +2615,6 @@ sub process { 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; @@ -2759,47 +2649,82 @@ sub process { my $var2 = $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {}; $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing my $copy = {%$var2, %$var1, %$swap}; - local $copy->{'template'}; local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore + local $self->{'_template'}; delete $self->{'_debug_off'}; delete $self->{'_debug_format'}; ### handle pre process items that go before every document + my $pre = ''; if ($self->{'PRE_PROCESS'}) { + $self->_load_template_meta($content); foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) { - my $out = ''; - $self->_process($name, $copy, \$out); - $output = $out . $output; + $self->_process($name, $copy, \$pre); } } - ### handle the process config - which loads a template in place of the real one - if (exists $self->{'PROCESS'}) { - ### load the meta data for the top document - my $doc = $self->load_parsed_tree($content) || {}; - my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META') - ? $doc->{'_tree'}->[0]->[3] : {}; + ### process the central file now - catching errors to allow for the ERROR config + eval { + ### handle the PROCESS config - which loads another template in place of the real one + if (exists $self->{'PROCESS'}) { + $self->_load_template_meta($content); + foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) { + next if ! length $name; + $self->_process($name, $copy, \$output); + } - $copy->{'template'} = $doc; - @{ $doc }{keys %$meta} = values %$meta; + ### handle "normal" content + } else { + local $self->{'_start_top_level'} = 1; + $self->_process($content, $copy, \$output); + } + }; - ### process any other templates - foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) { - next if ! length $name; - $self->_process($name, $copy, \$output); + ### catch errors with ERROR config + if (my $err = $@) { + $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; + die $err if $err->type =~ /stop|return/; + my $catch = $self->{'ERRORS'} || $self->{'ERROR'} || die $err; + $catch = {default => $catch} if ! ref $catch; + my $type = $err->type; + my $last_found; + my $file; + foreach my $name (keys %$catch) { + my $_name = (! defined $name || lc($name) eq 'default') ? '' : $name; + if ($type =~ / ^ \Q$_name\E \b /x + && (! defined($last_found) || length($last_found) < length($_name))) { # more specific wins + $last_found = $_name; + $file = $catch->{$name}; + } } - ### handle "normal" content - } else { - local $self->{'_start_top_level'} = 1; - $self->_process($content, $copy, \$output); + ### found error handler - try it out + if (defined $file) { + $output = ''; + local $copy->{'error'} = local $copy->{'e'} = $err; + $self->_process($file, $copy, \$output); + } } + ### handle wrapper directives + if (exists $self->{'WRAPPER'}) { + $self->_load_template_meta($content); + foreach my $name (reverse @{ $self->split_paths($self->{'WRAPPER'}) }) { + next if ! length $name; + local $copy->{'content'} = $output; + my $out = ''; + $self->_process($name, $copy, \$out); + $output = $out; + } + } + + $output = $pre . $output if length $pre; ### handle post process items that go after every document if ($self->{'POST_PROCESS'}) { + $self->_load_template_meta($content); foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) { $self->_process($name, $copy, \$output); } @@ -2855,14 +2780,12 @@ sub process { } } 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: $!"); } @@ -2877,15 +2800,32 @@ sub process { sub error { shift->{'error'} } -sub DEBUG { +sub _load_template_meta { my $self = shift; - print STDERR "DEBUG: ", @_; + return if $self->{'_template'}; # only do once as need + + eval { + ### load the meta data for the top document + ### this is needed by some of the custom handlers such as PRE_PROCESS and POST_PROCESS + my $content = shift; + my $doc = $self->{'_template'} = $self->load_parsed_tree($content) || {}; + my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META') + ? $doc->{'_tree'}->[0]->[3] : {}; + + $self->{'_template'} = $doc; + @{ $doc }{keys %$meta} = values %$meta; + }; + + return; } + ###----------------------------------------------------------------### sub exception { - my ($self, $type, $info, $node) = @_; + my $self = shift; + my $type = shift; + my $info = shift; return $type if ref($type) =~ /Template::Exception$/; if (ref($info) eq 'ARRAY') { my $hash = ref($info->[-1]) eq 'HASH' ? pop(@$info) : {}; @@ -2901,14 +2841,20 @@ sub exception { $type = 'undef'; } } - return $PACKAGE_EXCEPTION->new($type, $info, $node); + return $PACKAGE_EXCEPTION->new($type, $info, @_); } sub throw { die shift->exception(@_) } 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 { @@ -2929,27 +2875,8 @@ sub list_filters { } 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 { @@ -2962,7 +2889,7 @@ sub debug_node { sub node_info { my ($self, $node) = @_; - my $doc = $self->{'_vars'}->{'component'}; + my $doc = $self->{'_component'}; my $i = $node->[1]; my $j = $node->[2] || return ''; # META can be 0 $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s }; @@ -2977,9 +2904,11 @@ sub node_info { } sub get_line_number_by_index { - my ($self, $doc, $index) = @_; + my ($self, $doc, $index, $include_char) = @_; + return 1 if $index <= 0; + ### get the line offsets for the doc - my $lines = $doc->{'line_offsets'} ||= do { + my $lines = $doc->{'_line_offsets'} ||= do { $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s }; my $i = 0; my @lines = (0); @@ -2990,15 +2919,20 @@ sub get_line_number_by_index { } \@lines; }; + ### binary search them (this is fast even on big docs) - return $#$lines + 1 if $index > $lines->[-1]; my ($i, $j) = (0, $#$lines); - while (1) { - return $i + 1 if abs($i - $j) <= 1; - my $k = int(($i + $j) / 2); - $j = $k if $lines->[$k] >= $index; - $i = $k if $lines->[$k] <= $index; + if ($index > $lines->[-1]) { + $i = $j; + } else { + while (1) { + last if abs($i - $j) <= 1; + my $k = int(($i + $j) / 2); + $j = $k if $lines->[$k] >= $index; + $i = $k if $lines->[$k] <= $index; + } } + return $include_char ? ($i + 1, $index - $lines->[$i]) : $i + 1; } ###----------------------------------------------------------------### @@ -3006,19 +2940,36 @@ sub get_line_number_by_index { ### 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 vmethod_as_scalar { +sub vmethod_fmt_scalar { my $str = shift; $str = '' if ! defined $str; my $pat = shift; $pat = '%s' if ! defined $pat; local $^W; @@ -3026,7 +2977,7 @@ sub vmethod_as_scalar { : sprintf($pat, $str); } -sub vmethod_as_list { +sub vmethod_fmt_list { my $ref = shift || return ''; my $pat = shift; $pat = '%s' if ! defined $pat; my $sep = shift; $sep = ' ' if ! defined $sep; @@ -3035,7 +2986,7 @@ sub vmethod_as_list { : join($sep, map {sprintf $pat, $_} @$ref); } -sub vmethod_as_hash { +sub vmethod_fmt_hash { my $ref = shift || return ''; my $pat = shift; $pat = "%s\t%s" if ! defined $pat; my $sep = shift; $sep = "\n" if ! defined $sep; @@ -3100,6 +3051,15 @@ sub vmethod_nsort { : [sort {$a <=> $b} @$list]; } +sub vmethod_pick { + my $ref = shift; + no warnings; + my $n = int(shift); + $n = 1 if $n < 1; + my @ind = map { $ref->[ rand @$ref ] } 1 .. $n; + return $n == 1 ? $ind[0] : \@ind; +} + sub vmethod_repeat { my ($str, $n, $join) = @_; return '' if ! defined $str || ! length $str; @@ -3177,8 +3137,16 @@ sub vmethod_uri { return $str; } +sub vmethod_url { + my $str = shift; + utf8::encode($str) if defined &utf8::encode; + $str =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg; + return $str; +} + sub filter_eval { my $context = shift; + my $syntax = shift; return sub { ### prevent recursion @@ -3189,6 +3157,7 @@ sub filter_eval { my $text = shift; + local $t->{'SYNTAX'} = $syntax || $t->{'SYNTAX'}; return $context->process(\$text); }; } @@ -3205,14 +3174,12 @@ sub filter_redirect { 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 ''; }; } @@ -3233,6 +3200,33 @@ sub dump_parse_expr { 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; @@ -3243,8 +3237,8 @@ use overload fallback => 1; sub new { - my ($class, $type, $info, $node, $pos, $str_ref) = @_; - return bless [$type, $info, $node, $pos, $str_ref], $class; + my ($class, $type, $info, $node, $pos, $doc) = @_; + return bless [$type, $info, $node, $pos, $doc], $class; } sub type { shift->[0] } @@ -3253,28 +3247,34 @@ sub info { shift->[1] } sub node { my $self = shift; - $self->[2] = shift if $#_ == 0; + $self->[2] = shift if @_; $self->[2]; } -sub offset { shift->[3] || 0 } +sub offset { + my $self = shift; + $self->[3] = shift if @_; + $self->[3]; +} sub doc { my $self = shift; - $self->[4] = shift if $#_ == 0; + $self->[4] = shift if @_; $self->[4]; } sub as_string { my $self = shift; - my $msg = $self->type .' error - '. $self->info; - if (my $node = $self->node) { -# $msg .= " (In tag $node->[0] starting at char ".($node->[1] + $self->offset).")"; - } if ($self->type =~ /^parse/) { - $msg .= " (At char ".$self->offset.")"; + if (my $doc = $self->doc) { + my ($line, $char) = CGI::Ex::Template->get_line_number_by_index($doc, $self->offset, 'include_char'); + return $self->type ." error - $doc->{'name'} line $line char $char: ". $self->info; + } else { + return $self->type .' error - '. $self->info .' (At char '. $self->offset .')'; + } + } else { + return $self->type .' error - '. $self->info; } - return $msg; } ###----------------------------------------------------------------### @@ -3336,148 +3336,6 @@ sub next { ###----------------------------------------------------------------### -package CGI::Ex::Template::_Context; - -use vars qw($AUTOLOAD); - -sub _template { shift->{'_template'} || die "Missing _template" } - -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 $vars = $self->_template->_vars; - my $out = ''; - $self->_template->_process($ref, $vars, \$out); - return $out; -} - -sub include { - my $self = shift; - my $file = shift; - my $args = shift || {}; - - $self->_template->set_variable($_, $args->{$_}) for keys %$args; - - my $out = ''; # have temp item to allow clear to correctly clear - eval { $self->_template->_process($file, $self->{'_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