X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FCGI%2FEx%2FTemplate.pm;h=0e00f76a481a85ec149454731052d570490b354c;hb=419d9570723c210429e2be23875160f57dd36156;hp=72b56c742d1f7da7fd904a8cfe14d25edf8e3ad2;hpb=8cd30501f5be7e40e26b3dc885dfe25520d39df9;p=chaz%2Fp5-CGI-Ex diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 72b56c7..0e00f76 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -1,3842 +1,159 @@ package CGI::Ex::Template; -###----------------------------------------------------------------### -# See the perldoc in CGI/Ex/Template.pod -# Copyright 2007 - Paul Seamons # -# Distributed under the Perl Artistic License without warranty # -###----------------------------------------------------------------### +=head1 NAME -use strict; -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 +CGI::Ex::Template - Template::Alloy based TT2/TT3/HT/HTE/Tmpl/Velocity engine. - $OPERATORS - $OP_DISPATCH - $OP_ASSIGN - $OP - $OP_PREFIX - $OP_POSTFIX - $OP_TERNARY +=cut - $QR_OP - $QR_OP_PREFIX - $QR_OP_ASSIGN - - $QR_COMMENTS - $QR_FILENAME - $QR_NUM - $QR_AQ_SPACE +use strict; +use warnings; +use Template::Alloy 1.003; +use base qw(Template::Alloy); +use vars qw($VERSION $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 + $MAX_EVAL_RECURSE + $MAX_MACRO_RECURSE $STAT_TTL - - @CONFIG_COMPILETIME - @CONFIG_RUNTIME + $EXTRA_COMPILE_EXT + $PERL_COMPILE_EXT + $SCALAR_OPS + $FILTER_OPS + $LIST_OPS + $HASH_OPS + $VOBJS ); -BEGIN { - $VERSION = '2.12'; - - $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception'; - $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator'; - $PACKAGE_CONTEXT = 'CGI::Ex::Template::_Context'; - $PACKAGE_STASH = 'CGI::Ex::Template::_Stash'; - $PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle'; - - $TAGS = { - asp => ['<%', '%>' ], # ASP - default => ['\[%', '%\]' ], # default - html => ['' ], # HTML comments - mason => ['<%', '>' ], # HTML::Mason - metatext => ['%%', '%%' ], # Text::MetaText - php => ['<\?', '\?>' ], # PHP - star => ['\[\*', '\*\]' ], # TT alternate - template => ['\[%', '%\]' ], # Normal Template Toolkit - template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style - tt2 => ['\[%', '%\]' ], # TT2 - }; +$VERSION = '2.15'; + +### install true symbol table aliases that can be localized +*QR_PRIVATE = *Template::Alloy::QR_PRIVATE; +*WHILE_MAX = *Template::Alloy::WHILE_MAX; +*MAX_EVAL_RECURSE = *Template::Alloy::MAX_EVAL_RECURSE; +*MAX_MACRO_RECURSE = *Template::Alloy::MAX_MACRO_RECURSE; +*STAT_TTL = *Template::Alloy::STAT_TTL; +*EXTRA_COMPILE_EXT = *Template::Alloy::EXTRA_COMPILE_EXT; +*PERL_COMPILE_EXT = *Template::Alloy::PERL_COMPILE_EXT; +*SCALAR_OPS = *Template::Alloy::SCALAR_OPS; +*FILTER_OPS = *Template::Alloy::FILTER_OPS; +*LIST_OPS = *Template::Alloy::LIST_OPS; +*HASH_OPS = *Template::Alloy::HASH_OPS; +*VOBJS = *Template::Alloy::VOBJS; - $SCALAR_OPS = { - '0' => sub { $_[0] }, - chunk => \&vmethod_chunk, - collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ }, - defined => sub { defined $_[0] ? 1 : '' }, - indent => \&vmethod_indent, - int => sub { local $^W; int $_[0] }, - fmt => \&vmethod_fmt_scalar, - 'format' => \&vmethod_format, - hash => sub { {value => $_[0]} }, - html => sub { local $_ = $_[0]; s/&/&/g; s/</g; s/>/>/g; s/\"/"/g; s/\'/'/g; $_ }, - item => sub { $_[0] }, - lcfirst => sub { lcfirst $_[0] }, - length => sub { defined($_[0]) ? length($_[0]) : 0 }, - list => sub { [$_[0]] }, - lower => sub { lc $_[0] }, - match => \&vmethod_match, - new => sub { defined $_[0] ? $_[0] : '' }, - null => sub { '' }, - rand => sub { local $^W; rand shift }, - remove => sub { vmethod_replace(shift, shift, '', 1) }, - repeat => \&vmethod_repeat, - replace => \&vmethod_replace, - search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ }, - size => sub { 1 }, - split => \&vmethod_split, - stderr => sub { print STDERR $_[0]; '' }, - substr => \&vmethod_substr, - trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ }, - ucfirst => sub { ucfirst $_[0] }, - upper => sub { uc $_[0] }, - uri => \&vmethod_uri, - url => \&vmethod_url, - }; +1; - $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], - }; +__END__ - $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 '' }, - }; +=head1 SYNOPSIS - $HASH_OPS = { - defined => sub { return 1 if @_ == 1; defined $_[0]->{ defined($_[1]) ? $_[1] : '' } }, - delete => sub { my $h = shift; delete @{ $h }{map {defined($_) ? $_ : ''} @_}; '' }, - each => sub { [%{ $_[0] }] }, - exists => sub { exists $_[0]->{ defined($_[1]) ? $_[1] : '' } }, - fmt => \&vmethod_fmt_hash, - hash => sub { $_[0] }, - import => sub { my ($a, $b) = @_; @{$a}{keys %$b} = values %$b if ref($b) eq 'HASH'; '' }, - item => sub { my ($h, $k) = @_; $k = '' if ! defined $k; $k =~ $QR_PRIVATE ? undef : $h->{$k} }, - items => sub { [ %{ $_[0] } ] }, - keys => sub { [keys %{ $_[0] }] }, - list => \&vmethod_list_hash, - new => sub { local $^W; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} }, - null => sub { '' }, - nsort => sub { my $ref = shift; [sort { $ref->{$a} <=> $ref->{$b}} keys %$ref] }, - pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } sort keys %{ $_[0] } ] }, - size => sub { scalar keys %{ $_[0] } }, - sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] }, - values => sub { [values %{ $_[0] }] }, - }; +=head2 Template::Toolkit style usage - $VOBJS = { - Text => $SCALAR_OPS, - List => $LIST_OPS, - Hash => $HASH_OPS, - }; - foreach (values %$VOBJS) { - $_->{'Text'} = $_->{'as'}; - $_->{'Hash'} = $_->{'hash'}; - $_->{'List'} = $_->{'list'}; - } + my $t = Template::Alloy->new( + INCLUDE_PATH => ['/path/to/templates'], + ); - $DIRECTIVES = { - #name parse_sub play_sub block postdir continue move_to_front - BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1, 0, 0, 1], - BREAK => [sub {}, \&play_control], - CALL => [\&parse_CALL, \&play_CALL], - CASE => [\&parse_CASE, undef, 0, 0, {SWITCH => 1, CASE => 1}], - CATCH => [\&parse_CATCH, undef, 0, 0, {TRY => 1, CATCH => 1}], - CLEAR => [sub {}, \&play_CLEAR], - '#' => [sub {}, sub {}], - CONFIG => [\&parse_CONFIG, \&play_CONFIG], - DEBUG => [\&parse_DEBUG, \&play_DEBUG], - DEFAULT => [\&parse_DEFAULT, \&play_DEFAULT], - DUMP => [\&parse_DUMP, \&play_DUMP], - ELSE => [sub {}, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}], - ELSIF => [\&parse_IF, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}], - END => [undef, sub {}], - FILTER => [\&parse_FILTER, \&play_FILTER, 1, 1], - '|' => [\&parse_FILTER, \&play_FILTER, 1, 1], - FINAL => [sub {}, undef, 0, 0, {TRY => 1, CATCH => 1}], - FOR => [\&parse_FOREACH, \&play_FOREACH, 1, 1], - FOREACH => [\&parse_FOREACH, \&play_FOREACH, 1, 1], - GET => [\&parse_GET, \&play_GET], - IF => [\&parse_IF, \&play_IF, 1, 1], - INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE], - INSERT => [\&parse_INSERT, \&play_INSERT], - LAST => [sub {}, \&play_control], - MACRO => [\&parse_MACRO, \&play_MACRO], - META => [undef, \&play_META], - NEXT => [sub {}, \&play_control], - PERL => [\&parse_PERL, \&play_PERL, 1], - PROCESS => [\&parse_PROCESS, \&play_PROCESS], - RAWPERL => [\&parse_PERL, \&play_RAWPERL, 1], - RETURN => [sub {}, \&play_control], - SET => [\&parse_SET, \&play_SET], - STOP => [sub {}, \&play_control], - SWITCH => [\&parse_SWITCH, \&play_SWITCH, 1], - TAGS => [undef, sub {}], - THROW => [\&parse_THROW, \&play_THROW], - TRY => [sub {}, \&play_TRY, 1], - UNLESS => [\&parse_UNLESS, \&play_UNLESS, 1, 1], - USE => [\&parse_USE, \&play_USE], - VIEW => [\&parse_VIEW, \&play_VIEW, 1], - WHILE => [\&parse_WHILE, \&play_WHILE, 1, 1], - WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER, 1, 1], - #name #parse_sub #play_sub #block #postdir #continue #move_to_front + my $swap = { + key1 => 'val1', + key2 => 'val2', + code => sub { 42 }, + hash => {a => 'b'}, }; - ### setup the operator parsing - $OPERATORS = [ - # type precedence symbols action (undef means play_operator will handle) - ['prefix', 99, ['\\'], undef ], - ['postfix', 98, ['++'], undef ], - ['postfix', 98, ['--'], undef ], - ['prefix', 97, ['++'], undef ], - ['prefix', 97, ['--'], undef ], - ['right', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ], - ['prefix', 93, ['!'], sub { ! $_[0] } ], - ['prefix', 93, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], - ['left', 90, ['*'], sub { $_[0] * $_[1] } ], - ['left', 90, ['/'], sub { $_[0] / $_[1] } ], - ['left', 90, ['div', 'DIV'], sub { int($_[0] / $_[1]) } ], - ['left', 90, ['%', 'mod', 'MOD'], sub { $_[0] % $_[1] } ], - ['left', 85, ['+'], sub { $_[0] + $_[1] } ], - ['left', 85, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], - ['left', 85, ['~', '_'], undef ], - ['none', 80, ['<'], sub { $_[0] < $_[1] } ], - ['none', 80, ['>'], sub { $_[0] > $_[1] } ], - ['none', 80, ['<='], sub { $_[0] <= $_[1] } ], - ['none', 80, ['>='], sub { $_[0] >= $_[1] } ], - ['none', 80, ['lt'], sub { $_[0] lt $_[1] } ], - ['none', 80, ['gt'], sub { $_[0] gt $_[1] } ], - ['none', 80, ['le'], sub { $_[0] le $_[1] } ], - ['none', 80, ['ge'], sub { $_[0] ge $_[1] } ], - ['none', 75, ['==', 'eq'], sub { $_[0] eq $_[1] } ], - ['none', 75, ['!=', 'ne'], sub { $_[0] ne $_[1] } ], - ['left', 70, ['&&'], undef ], - ['right', 65, ['||'], undef ], - ['none', 60, ['..'], sub { $_[0] .. $_[1] } ], - ['ternary', 55, ['?', ':'], undef ], - ['assign', 53, ['+='], sub { $_[0] + $_[1] } ], - ['assign', 53, ['-='], sub { $_[0] - $_[1] } ], - ['assign', 53, ['*='], sub { $_[0] * $_[1] } ], - ['assign', 53, ['/='], sub { $_[0] / $_[1] } ], - ['assign', 53, ['%='], sub { $_[0] % $_[1] } ], - ['assign', 53, ['**='], sub { $_[0] ** $_[1] } ], - ['assign', 53, ['~=', '_='], sub { $_[0] . $_[1] } ], - ['assign', 52, ['='], undef ], - ['prefix', 50, ['not', 'NOT'], sub { ! $_[0] } ], - ['left', 45, ['and', 'AND'], undef ], - ['right', 40, ['or', 'OR'], undef ], - ]; - $OP = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] ne 'prefix' } @$OPERATORS}; # all non-prefix - $OP_PREFIX = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] eq 'prefix' } @$OPERATORS}; - $OP_DISPATCH = {map {my $ref = $_; map {$_ => $ref->[3]} @{$ref->[2]}} grep {$_->[3] } @$OPERATORS}; - $OP_ASSIGN = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'assign' } @$OPERATORS}; - $OP_POSTFIX = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'postfix'} @$OPERATORS}; # bool is postfix - $OP_TERNARY = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'ternary'} @$OPERATORS}; # bool is ternary - sub _op_qr { # no mixed \w\W operators - my %used; - my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {! /\{\}|\[\]/} grep {/^\W{2,}$/} @_; - my $chr = join '', sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_; - my $word = join '|', reverse sort grep {++$used{$_} < 2} grep {/^\w+$/} @_; - $chr = "[$chr]" if $chr; - $word = "\\b(?:$word)\\b" if $word; - return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex"; - } - sub _build_op_qr { _op_qr(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS) } - sub _build_op_qr_prefix { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS) } - sub _build_op_qr_assign { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS) } - $QR_OP = _build_op_qr(); - $QR_OP_PREFIX = _build_op_qr_prefix(); - $QR_OP_ASSIGN = _build_op_qr_assign(); - - $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )'; - $QR_COMMENTS = '(?-s: \# .* \s*)*'; - $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\.][\w\-\.]* (?:/[\w\-\.]+)*'; - $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?'; - $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=;) )'; - $QR_PRIVATE = qr/^[_.]/; - - $WHILE_MAX = 1000; - $EXTRA_COMPILE_EXT = '.sto'; - $MAX_EVAL_RECURSE = 50; - $MAX_MACRO_RECURSE = 50; - $STAT_TTL ||= 1; - - @CONFIG_COMPILETIME = qw(ANYCASE INTERPOLATE PRE_CHOMP POST_CHOMP V1DOLLAR V2PIPE); - @CONFIG_RUNTIME = qw(DUMP); - - eval {require Scalar::Util}; -}; - -###----------------------------------------------------------------### - -sub new { - my $class = shift; - my $args = ref($_[0]) ? { %{ shift() } } : {@_}; + # print to STDOUT + $t->process('my/template.tt', $swap) + || die $t->error; - ### allow for lowercase args - if (my @keys = grep {/^[a-z][a-z_]+$/} keys %$args) { - @{ $args }{ map { uc $_ } @keys } = delete @{ $args }{ @keys }; - } - - my $self = bless $args, $class; - - ### "enable" debugging - we only support DEBUG_DIRS and DEBUG_UNDEF - if ($self->{'DEBUG'}) { - $self->{'_debug_dirs'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/; - $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/; - } - - return $self; -} - -###----------------------------------------------------------------### - -sub _process { - my $self = shift; - my $file = shift; - local $self->{'_vars'} = shift || {}; - my $out_ref = shift || $self->throw('undef', "Missing output ref"); - local $self->{'_top_level'} = delete $self->{'_start_top_level'}; - my $i = length $$out_ref; + # process into a variable + my $out = ''; + $t->process('my/template.tt', $swap, \$out); - ### parse and execute - my $doc; - eval { - ### handed us a precompiled document - if (ref($file) eq 'HASH' && $file->{'_tree'}) { - $doc = $file; + ### Alloy uses the same syntax and configuration as Template::Toolkit - ### load the document - } else { - $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");; - } - ### prevent recursion - $self->throw('file', "recursion into '$doc->{name}'") - if ! $self->{'RECURSION'} && $self->{'_in'}->{$doc->{'name'}} && $doc->{'name'} ne 'input text'; - local $self->{'_in'}->{$doc->{'name'}} = 1; +=head2 HTML::Template::Expr style usage - ### execute the document - if (! @{ $doc->{'_tree'} }) { # no tags found - just return the content - $$out_ref = ${ $doc->{'_content'} }; - } else { - local $self->{'_component'} = $doc; - local $self->{'_template'} = $self->{'_top_level'} ? $doc : $self->{'_template'}; - local @{ $self }{@CONFIG_RUNTIME} = @{ $self }{@CONFIG_RUNTIME}; - $self->execute_tree($doc->{'_tree'}, $out_ref); - } + my $t = Template::Alloy->new( + filename => 'my/template.ht', + path => ['/path/to/templates'], + ); - ### 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; - } + my $swap = { + key1 => 'val1', + key2 => 'val2', + code => sub { 42 }, + hash => {a => 'b'}, }; - ### handle exceptions - if (my $err = $@) { - $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; - $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc; - die $err if ! $self->{'_top_level'} || $err->type !~ /stop|return/; - } - - return 1; -} - -###----------------------------------------------------------------### - -sub load_parsed_tree { - my $self = shift; - my $file = shift; - return if ! defined $file; - - my $doc = {name => $file}; - my $ref = $self->{'_documents'}->{$file}; - - ### looks like a string reference - if (ref $file) { - $doc->{'_content'} = $file; - $doc->{'name'} = 'input text'; - $doc->{'_is_str_ref'} = 1; - - ### looks like a previously cached-in-memory document - } elsif ($ref - && ( time - $ref->{'cache_time'} < ($self->{'STAT_TTL'} || $STAT_TTL) # don't stat more than once a second - || $ref->{'modtime'} == (stat $ref->{'_filename'})[9] # otherwise see if the file was modified - )) { - $doc = $self->{'_documents'}->{$file}; - return $doc; - - ### looks like a block name of some sort - } elsif ($self->{'BLOCKS'}->{$file}) { - my $block = $self->{'BLOCKS'}->{$file}; - - ### allow for predefined blocks that are a code or a string - if (UNIVERSAL::isa($block, 'CODE')) { - $block = $block->(); - } - if (! UNIVERSAL::isa($block, 'HASH')) { - $self->throw('block', "Unsupported BLOCK type \"$block\"") if ref $block; - my $copy = $block; - $block = eval { $self->load_parsed_tree(\$copy) } - || $self->throw('block', 'Parse error on predefined block'); - } - $doc->{'_tree'} = $block->{'_tree'} || $self->throw('block', "Invalid block definition (missing tree)"); - return $doc; - - ### handle cached not_founds - } elsif ($self->{'_not_found'}->{$file} - && ((time - $self->{'_not_found'}->{$file}->{'cache_time'} - < ($self->{'NEGATIVE_STAT_TTL'} || $self->{'STAT_TTL'} || $STAT_TTL)) # negative cache for a second - || do { delete $self->{'_not_found'}->{$file}; 0 } # clear cache on failure - )) { - die $self->{'_not_found'}->{$file}->{'exception'}; - - ### go and look on the file system - } else { - $doc->{'_filename'} = eval { $self->include_filename($file) }; - if (my $err = $@) { - ### allow for blocks in other files - if ($self->{'EXPOSE_BLOCKS'} - && ! $self->{'_looking_in_block_file'}) { - local $self->{'_looking_in_block_file'} = 1; - my $block_name = ''; - while ($file =~ s|/([^/.]+)$||) { - $block_name = length($block_name) ? "$1/$block_name" : $1; - my $ref = eval { $self->load_parsed_tree($file) } || next; - my $_tree = $ref->{'_tree'}; - foreach my $node (@$_tree) { - next if ! ref $node; - next if $node->[0] eq 'META'; - last if $node->[0] ne 'BLOCK'; - next if $block_name ne $node->[3]; - $doc->{'_content'} = $ref->{'_content'}; - $doc->{'_tree'} = $node->[4]; - $doc->{'modtime'} = $ref->{'modtime'}; - $file = $ref->{'name'}; - last; - } - } - $err = '' if ! $doc->{'_tree'}; - } elsif ($self->{'DEFAULT'}) { - $err = '' if ($doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) }); - } - if ($err) { - ### cache the negative error - if (! defined($self->{'NEGATIVE_STAT_TTL'}) || $self->{'NEGATIVE_STAT_TTL'}) { - $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/; - $self->{'_not_found'}->{$file} = { - cache_time => time, - exception => $self->exception($err->type, $err->info." (cached)"), - }; - } - die $err; - } - } - - ### no tree yet - look for a file cache - if (! $doc->{'_tree'}) { - $doc->{'modtime'} = (stat $doc->{'_filename'})[9]; - if ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) { - if ($self->{'COMPILE_DIR'}) { - $doc->{'_compile_filename'} = $self->{'COMPILE_DIR'} .'/'. $file; - } else { - $doc->{'_compile_filename'} = $doc->{'_filename'}; - } - $doc->{'_compile_filename'} .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'}); - $doc->{'_compile_filename'} .= $EXTRA_COMPILE_EXT if defined $EXTRA_COMPILE_EXT; - - if (-e $doc->{'_compile_filename'} && (stat _)[9] == $doc->{'modtime'}) { - require Storable; - $doc->{'_tree'} = Storable::retrieve($doc->{'_compile_filename'}); - $doc->{'compile_was_used'} = 1; - } else { - my $str = $self->slurp($doc->{'_filename'}); - $doc->{'_content'} = \$str; - } - } else { - my $str = $self->slurp($doc->{'_filename'}); - $doc->{'_content'} = \$str; - } - } - - } - - ### haven't found a parsed tree yet - parse the content into a tree - if (! $doc->{'_tree'}) { - if ($self->{'CONSTANTS'}) { - my $key = $self->{'CONSTANT_NAMESPACE'} || 'constants'; - $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'}; - } - - local $self->{'_component'} = $doc; - $doc->{'_tree'} = eval { $self->parse_tree($doc->{'_content'}) } - || do { my $e = $@; $e->doc($doc) if UNIVERSAL::can($e, 'doc') && ! $e->doc; die $e }; # errors die - } - - ### cache parsed_tree in memory unless asked not to do so - if (! $doc->{'_is_str_ref'} && (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'})) { - $self->{'_documents'}->{$file} ||= $doc; - $doc->{'cache_time'} = time; - - ### allow for config option to keep the cache size down - if ($self->{'CACHE_SIZE'}) { - my $all = $self->{'_documents'}; - if (scalar(keys %$all) > $self->{'CACHE_SIZE'}) { - my $n = 0; - foreach my $file (sort {$all->{$b}->{'cache_time'} <=> $all->{$a}->{'cache_time'}} keys %$all) { - delete($all->{$file}) if ++$n > $self->{'CACHE_SIZE'}; - } - } - } - } - - ### save a cache on the fileside as asked - if ($doc->{'_compile_filename'} && ! $doc->{'compile_was_used'}) { - my $dir = $doc->{'_compile_filename'}; - $dir =~ s|/[^/]+$||; - if (! -d $dir) { - require File::Path; - File::Path::mkpath($dir); - } - require Storable; - Storable::store($doc->{'_tree'}, $doc->{'_compile_filename'}); - utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_compile_filename'}; - } - - return $doc; -} - -###----------------------------------------------------------------### - -sub parse_tree { - my $self = shift; - my $str_ref = shift; - if (! $str_ref || ! defined $$str_ref) { - $self->throw('parse.no_string', "No string or undefined during parse"); - } - - my $STYLE = $self->{'TAG_STYLE'} || 'default'; - my $START = $self->{'START_TAG'} || $TAGS->{$STYLE}->[0]; - my $END = $self->{'END_TAG'} || $TAGS->{$STYLE}->[1]; - local $self->{'_end_tag'} = $END; - - local @{ $self }{@CONFIG_COMPILETIME} = @{ $self }{@CONFIG_COMPILETIME}; - - my @tree; # the parsed tree - my $pointer = \@tree; # pointer to current tree to handle nested blocks - my @state; # maintain block levels - local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS) - local $self->{'_in_perl'}; # no interpolation in perl - my @in_view; # let us know if we are in a view - my @move_to_front; # items that need to be declared first (usually BLOCKS) - my @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 $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]; - - ### look through the string using index - } 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 $_last = pos $$str_ref; - if ($post_chomp) { - if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x } - elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x } - elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x } - } - if (length $text) { - push @$pointer, $text; - $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'}; - } - } - - $node = [undef, pos($$str_ref), undef]; - - ### take care of whitespace and comments flags - my $pre_chomp = $$str_ref =~ m{ \G ([+=~-]) }gcx ? $1 : $self->{'PRE_CHOMP'}; - $pre_chomp =~ y/-=~+/1230/ if $pre_chomp; - if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) { - if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x } - elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x } - elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x } - splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length - } - 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 %] - || $self->throw('parse', "Missing closing tag", undef, pos($$str_ref)); - $node->[0] = '#'; - $node->[2] = pos($$str_ref) - length($3); - push @$pointer, $node; - - $post_chomp = $2; - $post_chomp ||= $self->{'POST_CHOMP'}; - $post_chomp =~ y/-=~+/1230/ if $post_chomp; - next; - } - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - } - - ### look for DIRECTIVES - if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcxo # find a word - && ($func = $self->{'ANYCASE'} ? uc($1) : $1) - && ($DIRECTIVES->{$func} - || ((pos($$str_ref) -= length $1) && 0)) - ) { # is it a directive - $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 - my @post_op = @$post_op; - @$post_op = @$node; - $node = $post_op; - $node->[4] = [\@post_op]; - } elsif ($capture) { - # do nothing - it will be handled further down - } else{ - push @$pointer, $node; - } - - ### anything that behaves as a block ending - if ($func eq 'END' || $DIRECTIVES->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc) - if (! @state) { - $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref)); - } - my $parent_node = pop @state; - - if ($func ne 'END') { - pop @$pointer; # we will store the node in the parent instead - $parent_node->[5] = $node; - my $parent_type = $parent_node->[0]; - if (! $DIRECTIVES->{$func}->[4]->{$parent_type}) { - $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref)); - } - } - - ### restore the pointer up one level (because we hit the end of a block) - $pointer = (! @state) ? \@tree : $state[-1]->[4]; - - ### normal end block - if ($func eq 'END') { - if ($DIRECTIVES->{$parent_node->[0]}->[5]) { # move things like BLOCKS to front - if ($parent_node->[0] eq 'BLOCK' - && defined($parent_node->[3]) - && @in_view) { - push @{ $in_view[-1] }, $parent_node; - } else { - push @move_to_front, $parent_node; - } - if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var - 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; - } - - ### continuation block - such as an elsif - } else { - $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) }; - if (my $err = $@) { - $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; - die $err; - } - push @state, $node; - $pointer = $node->[4] ||= []; - } - - } elsif ($func eq 'TAGS') { - my $end; - if ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxs) { - my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref)); - ($START, $END) = @$ref; - - } else { - local $self->{'_operator_precedence'} = 1; # prevent operator matching - $START = $$str_ref =~ m{ \G (?= [\'\"\/]) }gcx - ? $self->parse_expr($str_ref) - : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s+ $QR_COMMENTS"}) - || $self->throw('parse', "Invalid opening tag in TAGS", undef, pos($$str_ref)); - $END = $$str_ref =~ m{ \G (?= [\'\"\/]) }gcx - ? $self->parse_expr($str_ref) - : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s* $QR_COMMENTS"}) - || $self->throw('parse', "Invalid closing tag in TAGS", undef, pos($$str_ref)); - for my $tag ($START, $END) { - $tag = $self->play_expr($tag); - $tag = quotemeta($tag) if ! ref $tag; - } - } - - $node->[2] = pos $$str_ref; - - ### allow for one more closing tag of the old style - if ($$str_ref =~ m{ \G ([+~=-]?) $self->{'_end_tag'} }gcxs) { - $post_chomp = $1 || $self->{'POST_CHOMP'}; - $post_chomp =~ y/-=~+/1230/ if $post_chomp; - $continue = 0; - $post_op = undef; - $self->{'_end_tag'} = $END; # need to keep track so parse_expr knows when to stop - next; - } - - $self->{'_end_tag'} = $END; - - } elsif ($func eq 'META') { - my $args = $self->parse_args($str_ref, {named_at_front => 1}); - my $hash; - if (($hash = $self->play_expr($args->[0])) - && UNIVERSAL::isa($hash, 'HASH')) { - unshift @meta, %$hash; # first defined win - } - - ### all other "normal" tags - } else { - $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) }; - if (my $err = $@) { - $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; - die $err; - } - if ($DIRECTIVES->{$func}->[2] && ! $post_op) { # this looks like a block directive - push @state, $node; - $pointer = $node->[4] ||= []; - } - push @in_view, [] if $func eq 'VIEW'; - } - - ### allow for bare variable getting and setting - } elsif (defined(my $var = $self->parse_expr($str_ref))) { - push @$pointer, $node; - if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? (?! [+=~-]? $END) \s* $QR_COMMENTS }gcx) { - $node->[0] = 'SET'; - $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, $str_ref, $node, $1, $var) }; - if (my $err = $@) { - $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; - die $err; - } - } else { - $node->[0] = 'GET'; - $node->[3] = $var; - } - - ### handle empty tags [% %] - } elsif ($$str_ref =~ m{ \G (?: ; \s* $QR_COMMENTS)? ([+=~-]?) ($END) }gcxs) { - my $end = $2; - $post_chomp = $1 || $self->{'POST_CHOMP'}; - $post_chomp =~ y/-=~+/1230/ if $post_chomp; - $node->[2] = pos($$str_ref) - length($end); - $continue = 0; - $post_op = undef; - next; - - } else { # error - $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref)); - } - - ### we now have the directive to capture for an item like "SET foo = BLOCK" - store it - if ($capture) { - my $parent_node = $capture; - push @{ $parent_node->[4] }, $node; - undef $capture; - } - - ### look for the closing tag again - if ($$str_ref =~ m{ \G (?: ; \s* $QR_COMMENTS)? ([+=~-]?) ($END) }gcxs) { - my $end = $2; - $post_chomp = $1 || $self->{'POST_CHOMP'}; - $post_chomp =~ y/-=~+/1230/ if $post_chomp; - - $node->[2] = pos($$str_ref) - length($end); - $continue = 0; - $post_op = undef; - next; - } - - ### we always continue - and always record our position now - $continue = 1; - $node->[2] = pos $$str_ref; - - ### 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; - - } 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; - } - } - } - - if (@move_to_front) { - unshift @tree, @move_to_front; - } - if (@meta) { - unshift @tree, ['META', 0, 0, {@meta}]; - } - - if ($#state > -1) { - $self->throw('parse.missing.end', "Missing END", $state[-1], 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 } - elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x } - elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x } - } - if (length $text) { - push @$pointer, $text; - $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'}; - } - } - - return \@tree; -} - -sub parse_expr { - my $self = shift; - my $str_ref = shift; - my $ARGS = shift || {}; - my $is_aq = $ARGS->{'auto_quote'} ? 1 : 0; - my $mark = pos $$str_ref; - - ### allow for custom auto_quoting (such as hash constructors) - if ($is_aq) { - if ($$str_ref =~ m{ \G $ARGS->{'auto_quote'} }gcx) { - return $1; - - ### allow for auto-quoted $foo - } elsif ($$str_ref =~ m{ \G \$ (\w+\b (?:\.\w+\b)*) \s* $QR_COMMENTS }gcxo) { - my $name = $1; - if ($$str_ref !~ m{ \G \( }gcx || $name =~ /^(?:qw|m|\d)/) { - return $self->parse_expr(\$name); - } - ### this is a little cryptic/odd - but TT allows items in - ### autoquote position to only be prefixed by a $ - gross - ### so we will defer to the regular parsing - but after the $ - pos($$str_ref) = $mark + 1; - $is_aq = undef; # but don't allow operators - false flag handed down - - ### allow for ${foo.bar} type constructs - } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) { - my $var = $self->parse_expr($str_ref); - $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo - || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); - return $var; - } - } - - - ### test for leading prefix operators - my $has_prefix; - while (! $is_aq && $$str_ref =~ m{ \G ($QR_OP_PREFIX) }gcxo) { - push @{ $has_prefix }, $1; - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - } - - my @var; - my $is_literal; - my $is_namespace; - my $already_parsed_args; - - ### allow hex - if ($$str_ref =~ m{ \G 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }gcxo) { - my $number = eval { hex $1 } || 0; - push @var, \ $number; - $is_literal = 1; - - ### allow for numbers - } elsif ($$str_ref =~ m{ \G ( $QR_NUM ) \s* $QR_COMMENTS }gcxo) { - my $number = $1; - push @var, \ $number; - $is_literal = 1; - - ### allow for quoted array constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G qw ([^\w\s]) \s* }gcxo) { - my $quote = $1; - $quote =~ y|([{<|)]}>|; - $$str_ref =~ m{ \G (.*?) (?throw('parse.missing.array_close', "Missing close \"$quote\"", undef, pos($$str_ref)); - my $str = $1; - $str =~ s{ ^ \s+ }{}x; - $str =~ s{ \s+ $ }{}x; - $str =~ s{ \\ \Q$quote\E }{$quote}gx; - push @var, [undef, '[]', split /\s+/, $str]; - - ### allow for regex constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G / }gcx) { - $$str_ref =~ m{ \G (.*?) (?throw('parse', 'Unclosed regex tag "/"', undef, pos($$str_ref)); - my ($str, $opts) = ($1, $2); - $self->throw('parse', 'e option not allowed on regex', undef, pos($$str_ref)) if $opts =~ /e/; - $self->throw('parse', 'g option not supported on regex', undef, pos($$str_ref)) if $opts =~ /g/; - $str =~ s|\\n|\n|g; - $str =~ s|\\t|\t|g; - $str =~ s|\\r|\r|g; - $str =~ s|\\\/|\/|g; - $str =~ s|\\\$|\$|g; - $self->throw('parse', "Invalid regex: $@", undef, pos($$str_ref)) if ! eval { "" =~ /$str/; 1 }; - push @var, [undef, 'qr', $str, $opts]; - - ### looks like a normal variable start - } elsif ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxo) { - push @var, $1; - $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1}; - - ### allow for literal strings - } elsif ($$str_ref =~ m{ \G ([\"\']) }gcx) { - my $quote = $1; - $$str_ref =~ m{ \G (.*?) (?throw('parse', "Unclosed quoted string ($1)", undef, pos($$str_ref)); - my $str = $1; - if ($quote eq "'") { # no interpolation on single quoted strings - $str =~ s{ \\\' }{\'}xg; - push @var, \ $str; - $is_literal = 1; - } else { - $str =~ s/\\n/\n/g; - $str =~ s/\\t/\t/g; - $str =~ s/\\r/\r/g; - $str =~ s/\\"/"/g; - my @pieces = $is_aq - ? split(m{ (?: ^ | (?parse_expr(\$name); - } - @pieces = grep {defined && length} @pieces; - if (@pieces == 1 && ! ref $pieces[0]) { - push @var, \ $pieces[0]; - $is_literal = 1; - } elsif (! @pieces) { - push @var, \ ''; - $is_literal = 1; - } else { - push @var, [undef, '~', @pieces]; - } - } - if ($is_aq) { - return ${ $var[0] } if $is_literal; - push @var, 0; - return \@var; - } - - ### allow for leading $foo type constructs - } elsif ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) { - if ($self->{'V1DOLLAR'}) { - push @var, $1; - $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1}; - } else { - push @var, [$1, 0]; - } - - ### allow for ${foo.bar} type constructs - } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) { - push @var, $self->parse_expr($str_ref); - $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo - || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); - - ### looks like an array constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G \[ \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset presedence - my $arrayref = [undef, '[]']; - while (defined(my $var = $self->parse_expr($str_ref))) { - push @$arrayref, $var; - $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo; - } - $$str_ref =~ m{ \G \] \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, pos($$str_ref)); - push @var, $arrayref; - - ### looks like a hash constructor - } elsif (! $is_aq && $$str_ref =~ m{ \G \{ \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset precedence - my $hashref = [undef, '{}']; - while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))) { - $$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo; - my $val = $self->parse_expr($str_ref); - push @$hashref, $key, $val; - $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo; - } - $$str_ref =~ m{ \G \} \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.curly_bracket', "Missing close \}", undef, pos($$str_ref)); - push @var, $hashref; - - ### looks like a paren grouper - } elsif (! $is_aq && $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset precedence - my $var = $self->parse_expr($str_ref, {allow_parened_ops => 1}); - - $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref)); - - $self->throw('parse', 'Paren group cannot be followed by an open paren', undef, pos($$str_ref)) - if $$str_ref =~ m{ \G \( }gcx; - - $already_parsed_args = 1; - if (! ref $var) { - push @var, \$var, 0; - $is_literal = 1; - } elsif (! defined $var->[0]) { - push @var, $var, 0; - } else { - push @var, @$var; - } - - ### nothing to find - return failure - } else { - pos($$str_ref) = $mark if $is_aq || $has_prefix; - return; - } - - # auto_quoted thing was too complicated - if ($is_aq) { - pos($$str_ref) = $mark; - return; - } - - ### looks for args for the initial - if ($already_parsed_args) { - # do nothing - } elsif ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset precedence - my $args = $self->parse_args($str_ref, {is_parened => 1}); - $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref)); - push @var, $args; - } else { - push @var, 0; - } - - - ### allow for nested items - while ($$str_ref =~ m{ \G ( \.(?!\.) | \|(?!\|) ) }gcx) { - if ($1 eq '|' && $self->{'V2PIPE'}) { - pos($$str_ref) -= 1; - last; - } - - push(@var, $1) if ! $ARGS->{'no_dots'}; - - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - - ### allow for interpolated variables in the middle - one.$foo.two - if ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) { - push @var, $self->{'V1DOLLAR'} ? $1 : [$1, 0]; - - ### or one.${foo.bar}.two - } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) { - push @var, $self->parse_expr($str_ref); - $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo - || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); - - ### allow for names - } elsif ($$str_ref =~ m{ \G (-? \w+) \s* $QR_COMMENTS }gcxo) { - push @var, $1; - - } else { - $self->throw('parse', "Not sure how to continue parsing", undef, pos($$str_ref)); - } - - ### looks for args for the nested item - if ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) { - local $self->{'_operator_precedence'} = 0; # reset precedence - my $args = $self->parse_args($str_ref, {is_parened => 1}); - $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo - || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref)); - push @var, $args; - } else { - push @var, 0; - } - - } - - ### flatten literals and constants as much as possible - my $var; - if ($is_literal) { - $var = ${ $var[0] }; - if ($#var != 1) { - $var[0] = [undef, '~', $var]; - $var = \@var; - } - } elsif ($is_namespace) { - $var = $self->play_expr(\@var, {is_namespace_during_compile => 1}); - } else { - $var = \@var; - } + $t->param($swap); - ### allow for all "operators" - if (! $self->{'_operator_precedence'} && defined $is_aq) { - my $tree; - my $found; - while (1) { - my $mark = pos $$str_ref; - if ($self->{'_end_tag'} && $$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) { - pos($$str_ref) = $mark; - last; - } elsif ($$str_ref !~ m{ \G ($QR_OP) }gcxo) { - pos($$str_ref) = $mark; - last; - } - if ($OP_ASSIGN->{$1} && ! $ARGS->{'allow_parened_ops'}) { # only allow assignment in parens - pos($$str_ref) = $mark; - last; - } - local $self->{'_operator_precedence'} = 1; - my $op = $1; - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; + # print to STDOUT (errors die) + $t->output(print_to => \*STDOUT); - ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --) - if ($OP_POSTFIX->{$op}) { - $var = [[undef, $op, $var, 1], 0]; # cheat - give a "second value" to postfix ops - next; + # process into a variable + my $out = $t->output; - ### allow for prefix operator precedence - } elsif ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix->[-1]}->[1]) { - if ($tree) { - if ($#$tree == 1) { # only one operator - keep simple things fast - $var = [[undef, $tree->[0], $var, $tree->[1]], 0]; - } else { - unshift @$tree, $var; - $var = $self->apply_precedence($tree, $found); - } - undef $tree; - undef $found; - } - $var = [[undef, $has_prefix->[-1], $var ], 0]; - if (! @$has_prefix) { undef $has_prefix } else { pop @$has_prefix } - } + ### Alloy can also use the same syntax and configuration as HTML::Template - ### add the operator to the tree - my $var2 = $self->parse_expr($str_ref, {from_here => 1}); - $self->throw('parse', 'Missing variable after "'.$op.'"', undef, pos($$str_ref)) if ! defined $var2; - push (@{ $tree ||= [] }, $op, $var2); - $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op} - } +=head2 Text::Tmpl style usage - ### if we found operators - tree the nodes by operator precedence - if ($tree) { - if (@$tree == 2) { # only one operator - keep simple things fast - $var = [[undef, $tree->[0], $var, $tree->[1]], 0]; - } else { - unshift @$tree, $var; - $var = $self->apply_precedence($tree, $found); - } - } - } + my $t = Template::Alloy->new; - ### allow for prefix on non-chained variables - if ($has_prefix) { - $var = [[undef, $_, $var], 0] for reverse @$has_prefix; - } - - return $var; -} - -### this is used to put the parsed variables into the correct operations tree -sub apply_precedence { - my ($self, $tree, $found) = @_; - - my @var; - my $trees; - ### look at the operators we found in the order we found them - for my $prec (sort keys %$found) { - my $ops = $found->{$prec}; - local $found->{$prec}; - delete $found->{$prec}; - - ### split the array on the current operators for this level - my @ops; - my @exprs; - for (my $i = 1; $i <= $#$tree; $i += 2) { - next if ! $ops->{ $tree->[$i] }; - push @ops, $tree->[$i]; - push @exprs, [splice @$tree, 0, $i, ()]; - shift @$tree; - $i = -1; - } - next if ! @exprs; # this iteration didn't have the current operator - push @exprs, $tree if scalar @$tree; # add on any remaining items - - ### simplify sub expressions - for my $node (@exprs) { - if (@$node == 1) { - $node = $node->[0]; # single item - its not a tree - } elsif (@$node == 3) { - $node = [[undef, $node->[1], $node->[0], $node->[2]], 0]; # single operator - put it straight on - } else { - $node = $self->apply_precedence($node, $found); # more complicated - recurse - } - } - - ### assemble this current level - - ### some rules: - # 1) items at the same precedence level must all be either right or left or ternary associative - # 2) ternary items cannot share precedence with anybody else. - # 3) there really shouldn't be another operator at the same level as a postfix - my $type = $OP->{$ops[0]}->[0]; - - if ($type eq 'ternary') { - my $op = $OP->{$ops[0]}->[2]->[0]; # use the first op as what we are using - - ### return simple ternary - if (@exprs == 3) { - $self->throw('parse', "Ternary operator mismatch") if $ops[0] ne $op; - $self->throw('parse', "Ternary operator mismatch") if ! $ops[1] || $ops[1] eq $op; - return [[undef, $op, @exprs], 0]; - } - - - ### reorder complex ternary - rare case - while ($#ops >= 1) { - ### if we look starting from the back - the first lead ternary op will always be next to its matching op - for (my $i = $#ops; $i >= 0; $i --) { - next if $OP->{$ops[$i]}->[2]->[1] eq $ops[$i]; - my ($op, $op2) = splice @ops, $i, 2, (); # remove the pair of operators - my $node = [[undef, $op, @exprs[$i .. $i + 2]], 0]; - splice @exprs, $i, 3, $node; - } - } - return $exprs[0]; # at this point the ternary has been reduced to a single operator - - } elsif ($type eq 'right' || $type eq 'assign') { - my $val = $exprs[-1]; - $val = [[undef, $ops[$_ - 1], $exprs[$_], $val], 0] for reverse (0 .. $#exprs - 1); - return $val; - - } else { - my $val = $exprs[0]; - $val = [[undef, $ops[$_ - 1], $val, $exprs[$_]], 0] for (1 .. $#exprs); - return $val; - - } - } - - $self->throw('parse', "Couldn't apply precedence"); -} - -### look for arguments - both positional and named -sub parse_args { - my $self = shift; - my $str_ref = shift; - my $ARGS = shift || {}; - - my @args; - my @named; - my $name; - my $end = $self->{'_end_tag'} || '(?!)'; - while (1) { - my $mark = pos $$str_ref; - - ### look to see if the next thing is a directive or a closing tag - if (! $ARGS->{'is_parened'} - && ! $ARGS->{'require_arg'} - && $$str_ref =~ m{ \G $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$end))) }gcxo - && ((pos($$str_ref) = $mark) || 1) # always revert - && $DIRECTIVES->{$self->{'ANYCASE'} ? uc($1) : $1} # looks like a directive - we are done - ) { - last; - } - if ($$str_ref =~ m{ \G [+=~-]? $end }gcx) { - pos($$str_ref) = $mark; - last; - } - - ### find the initial arg - my $name; - if ($ARGS->{'allow_bare_filenames'}) { - $name = $self->parse_expr($str_ref, {auto_quote => " - ($QR_FILENAME # file name - | \\w+\\b (?: :\\w+\\b)* ) # or block - (?= [+=~-]? $end # an end tag - | \\s*[+,;] # followed by explicit + , or ; - | \\s+ (?! [\\s=]) # or space not before an = - ) \\s* $QR_COMMENTS"}); - # filenames can be separated with a "+" - why a "+" ? - if ($$str_ref =~ m{ \G \+ (?! [+=~-]? $end) \s* $QR_COMMENTS }gcxo) { - push @args, $name; - $ARGS->{'require_arg'} = 1; - next; - } - } - if (! defined $name) { - $name = $self->parse_expr($str_ref); - if (! defined $name) { - if ($ARGS->{'require_arg'} && ! @args && ! $ARGS->{'positional_only'} && ! @named) { - $self->throw('parse', 'Argument required', undef, pos($$str_ref)); - } else { - last; - } - } - } - - $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; - - ### see if it is named or positional - if ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo) { - $self->throw('parse', 'Named arguments not allowed', undef, $mark) if $ARGS->{'positional_only'}; - my $val = $self->parse_expr($str_ref); - $name = $name->[0] if ref($name) && @$name == 2 && ! $name->[1]; # strip a level of indirection on named arguments - push @named, $name, $val; - } else { - push @args, $name; - } - - ### look for trailing comma - $ARGS->{'require_arg'} = ($$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo) || 0; - } - - ### allow for named arguments to be added at the front (if asked) - if ($ARGS->{'named_at_front'}) { - unshift @args, [[undef, '{}', @named], 0]; - } elsif (scalar @named) { # only add at end - if there are some - push @args, [[undef, '{}', @named], 0] - } - - return \@args; -} - -### allow for looking for $foo or ${foo.bar} in TEXT "nodes" of the parse tree. -sub interpolate_node { - my ($self, $tree, $offset) = @_; - return if $self->{'_in_perl'}; - - ### split on variables while keeping the variables - my @pieces = split m{ (?: ^ | (?[-1]; - if ($#pieces <= 0) { - $tree->[-1] =~ s{ \\ ([\"\$]) }{$1}xg; - return; - } - - my @sub_tree; - my $n = 0; - foreach my $piece (@pieces) { - $offset += length $piece; # we track the offset to make sure DEBUG has the right location - $piece =~ s{ \\ ([\"\$]) }{$1}xg; - if (! ($n++ % 2)) { # odds will always be text chunks - next if ! length $piece; - push @sub_tree, $piece; - } elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x - || $piece =~ m{ ^ \$\{ \s* (.*?) (?parse_expr(\$name)]; - } else { - $self->throw('parse', "Parse error during interpolate node"); - } - } - - ### replace the tree - splice @$tree, -1, 1, @sub_tree; -} - -###----------------------------------------------------------------### - -sub execute_tree { - my ($self, $tree, $out_ref) = @_; - - # node contains (0: DIRECTIVE, - # 1: start_index, - # 2: end_index, - # 3: parsed tag details, - # 4: sub tree for block types - # 5: continuation sub trees for sub continuation block types (elsif, else, etc) - # 6: flag to capture next directive - for my $node (@$tree) { - ### text nodes are just the bare text - if (! ref $node) { - 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; - } -} - -sub play_expr { - ### allow for the parse tree to store literals - return $_[1] if ! ref $_[1]; - - my $self = shift; - my $var = shift; - my $ARGS = shift || {}; - my $i = 0; - - ### determine the top level of this particular variable access - my $ref; - use CGI::Ex::Dump qw(debug dex_trace); - debug dex_trace - if ref $var ne 'ARRAY'; - my $name = $var->[$i++]; - my $args = $var->[$i++]; - warn "play_expr: begin \"$name\"\n" if trace; - if (ref $name) { - if (! defined $name->[0]) { # operator - return $self->play_operator($name) if wantarray && $name->[1] eq '..'; - $ref = $self->play_operator($name); - } 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 \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name}; - $ref = $self->{'_vars'}->{$name}; - } - } - } elsif (defined $name) { - if ($ARGS->{'is_namespace_during_compile'}) { - $ref = $self->{'NAMESPACE'}->{$name}; - } else { - return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _ - return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name}; - $ref = $self->{'_vars'}->{$name}; - $ref = ($name eq 'template' || $name eq 'component') ? $self->{"_$name"} : $VOBJS->{$name} if ! defined $ref; - } - } - - - my %seen_filters; - while (defined $ref) { - - ### check at each point if the rurned thing was a code - if (UNIVERSAL::isa($ref, 'CODE')) { - return $ref if $i >= $#$var && $ARGS->{'return_ref'}; - my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ()); - if (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - $ref = undef; - last; - } - } - - ### descend one chained level - last if $i >= $#$var; - my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; - $name = $var->[$i++]; - $args = $var->[$i++]; - 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 =~ /^\./) { - $ref = undef; - last; - } - } else { - die "Shouldn't get a ". ref($name) ." during a vivify on chain"; - } - } - if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _ - $ref = undef; - last; - } - - ### allow for scalar and filter access (this happens for every non virtual method call) - if (! ref $ref) { - if ($SCALAR_OPS->{$name}) { # normal scalar op - $ref = $SCALAR_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); - - } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op - $ref = $LIST_OPS->{$name}->([$ref], $args ? map { $self->play_expr($_) } @$args : ()); - - } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args - || $FILTER_OPS->{$name} # predefined filters in CET - || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash - || $self->list_filters->{$name}) { # filter defined in Template::Filters - - if (UNIVERSAL::isa($filter, 'CODE')) { - $ref = eval { $filter->($ref) }; # non-dynamic filter - no args - if (my $err = $@) { - $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; - die $err; - } - } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { - $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); - - } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters - eval { - my $sub = $filter->[0]; - if ($filter->[1]) { # it is a "dynamic filter" that will return a sub - ($sub, my $err) = $sub->($self->context, $args ? map { $self->play_expr($_) } @$args : ()); - if (! $sub && $err) { - $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; - die $err; - } elsif (! UNIVERSAL::isa($sub, 'CODE')) { - $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") - if ref($sub) !~ /Template::Exception$/; - die $sub; - } - } - $ref = $sub->($ref); - }; - if (my $err = $@) { - $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; - die $err; - } - } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) - $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; - $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree - $i = 2; - } - if (scalar keys %seen_filters - && $seen_filters{$var->[$i - 5] || ''}) { - $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); - } - } else { - $ref = undef; - } - - } else { - - ### method calls on objects - if ($was_dot_call && UNIVERSAL::can($ref, 'can')) { - return $ref if $i >= $#$var && $ARGS->{'return_ref'}; - my @args = $args ? map { $self->play_expr($_) } @$args : (); - my @results = eval { $ref->$name(@args) }; - if ($@) { - my $class = ref $ref; - die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/; - } elsif (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - next; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - $ref = undef; - last; - } - # didn't find a method by that name - so fail down to hash and array access - } - - ### hash member access - if (UNIVERSAL::isa($ref, 'HASH')) { - if ($was_dot_call && exists($ref->{$name}) ) { - return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->{$name}; - $ref = $ref->{$name}; - } elsif ($HASH_OPS->{$name}) { - $ref = $HASH_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); - } elsif ($ARGS->{'is_namespace_during_compile'}) { - return $var; # abort - can't fold namespace variable - } else { - return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'}; - $ref = undef; - } - - ### array access - } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if ($name =~ m{ ^ -? $QR_NUM $ }ox) { - return \ $ref->[$name] if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->[$name]; - $ref = $ref->[$name]; - } elsif ($LIST_OPS->{$name}) { - $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); - } else { - $ref = undef; - } - } - } - - } # end of while - - ### allow for undefinedness - if (! defined $ref) { - if ($self->{'_debug_undef'}) { - my $chunk = $var->[$i - 2]; - $chunk = $self->play_expr($chunk) if ref($chunk) eq 'ARRAY'; - die "$chunk is undefined\n"; - } else { - $ref = $self->undefined_any($var); - } - } - - return $ref; -} - -sub is_empty_named_args { - my ($self, $hash_ident) = @_; - # [[undef, '{}', 'key1', 'val1', 'key2, 'val2'], 0] - return @{ $hash_ident->[0] } <= 2; -} - -sub set_variable { - my ($self, $var, $val, $ARGS) = @_; - $ARGS ||= {}; - my $i = 0; - - ### allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %]) - $var = [$var, 0] if ! ref $var; - - ### determine the top level of this particular variable access - my $ref = $var->[$i++]; - my $args = $var->[$i++]; - if (ref $ref) { - ### non-named types can't be set - return if ref($ref) ne 'ARRAY' || ! defined $ref->[0]; - - # named access (ie via $name.foo) - $ref = $self->play_expr($ref); - if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _ - if ($#$var <= $i) { - return $self->{'_vars'}->{$ref} = $val; - } else { - $ref = $self->{'_vars'}->{$ref} ||= {}; - } - } else { - return; - } - } elsif (defined $ref) { - return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ - if ($#$var <= $i) { - return $self->{'_vars'}->{$ref} = $val; - } else { - $ref = $self->{'_vars'}->{$ref} ||= {}; - } - } - - while (defined $ref) { - - ### check at each point if the returned thing was a code - if (UNIVERSAL::isa($ref, 'CODE')) { - my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ()); - if (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - return; - } - } - - ### descend one chained level - last if $i >= $#$var; - my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; - my $name = $var->[$i++]; - my $args = $var->[$i++]; - - ### allow for named portions of a variable name (foo.$name.bar) - if (ref $name) { - if (ref($name) eq 'ARRAY') { - $name = $self->play_expr($name); - if (! defined($name) || $name =~ /^[_.]/) { - return; - } - } else { - die "Shouldn't get a ".ref($name)." during a vivify on chain"; - } - } - if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _ - return; - } - - ### scalar access - if (! ref $ref) { - return; - - ### method calls on objects - } elsif (UNIVERSAL::can($ref, 'can')) { - my $lvalueish; - my @args = $args ? map { $self->play_expr($_) } @$args : (); - if ($i >= $#$var) { - $lvalueish = 1; - push @args, $val; - } - my @results = eval { $ref->$name(@args) }; - if (! $@) { - if (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - return; - } - return if $lvalueish; - next; - } - my $class = ref $ref; - die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/; - # fall on down to "normal" accessors - } - - ### hash member access - if (UNIVERSAL::isa($ref, 'HASH')) { - if ($#$var <= $i) { - return $ref->{$name} = $val; - } else { - $ref = $ref->{$name} ||= {}; - next; - } - - ### array access - } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if ($name =~ m{ ^ -? $QR_NUM $ }ox) { - if ($#$var <= $i) { - return $ref->[$name] = $val; - } else { - $ref = $ref->[$name] ||= {}; - next; - } - } else { - return; - } - - } - - } - - return; -} - -###----------------------------------------------------------------### - -sub play_operator { - my ($self, $tree) = @_; - ### $tree looks like [undef, '+', 4, 5] - - if ($OP_DISPATCH->{$tree->[1]}) { - local $^W; - if ($OP_ASSIGN->{$tree->[1]}) { - my $val = $OP_DISPATCH->{$tree->[1]}->($self->play_expr($tree->[2]), $self->play_expr($tree->[3])); - $self->set_variable($tree->[2], $val); - return $val; - } else { - return $OP_DISPATCH->{$tree->[1]}->(@$tree == 3 ? $self->play_expr($tree->[2]) : ($self->play_expr($tree->[2]), $self->play_expr($tree->[3]))); - } - } - - my $op = $tree->[1]; - - ### do custom and short-circuitable operators - if ($op eq '=') { - my $val = $self->play_expr($tree->[3]); - $self->set_variable($tree->[2], $val); - return $val; - - } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') { - return $self->play_expr($tree->[2]) || $self->play_expr($tree->[3]) || ''; - - } 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; - - } elsif ($op eq '?') { - local $^W; - return $self->play_expr($tree->[2]) ? $self->play_expr($tree->[3]) : $self->play_expr($tree->[4]); - - } elsif ($op eq '~' || $op eq '_') { - local $^W; - my $s = ''; - $s .= $self->play_expr($tree->[$_]) for 2 .. $#$tree; - return $s; - - } elsif ($op eq '[]') { - return [map {$self->play_expr($tree->[$_])} 2 .. $#$tree]; - - } elsif ($op eq '{}') { - local $^W; - my @e; - push @e, $self->play_expr($tree->[$_]) for 2 .. $#$tree; - return {@e}; - - } elsif ($op eq '++') { - local $^W; - my $val = 0 + $self->play_expr($tree->[2]); - $self->set_variable($tree->[2], $val + 1); - return $tree->[3] ? $val : $val + 1; # ->[3] is set to 1 during parsing of postfix ops - - } elsif ($op eq '--') { - local $^W; - my $val = 0 + $self->play_expr($tree->[2]); - $self->set_variable($tree->[2], $val - 1); - return $tree->[3] ? $val : $val - 1; # ->[3] is set to 1 during parsing of postfix ops - - } elsif ($op eq '\\') { - my $var = $tree->[2]; - - my $ref = $self->play_expr($var, {return_ref => 1}); - return $ref if ! ref $ref; - return sub { sub { $$ref } } if ref $ref eq 'SCALAR' || ref $ref eq 'REF'; - - my $self_copy = $self; - eval {require Scalar::Util; Scalar::Util::weaken($self_copy)}; - - my $last = ['temp deref key', $var->[-1] ? [@{ $var->[-1] }] : 0]; - return sub { sub { # return a double sub so that the current play_expr will return a coderef - local $self_copy->{'_vars'}->{'temp deref key'} = $ref; - $last->[-1] = (ref $last->[-1] ? [@{ $last->[-1] }, @_] : [@_]) if @_; - return $self->play_expr($last); - } }; - } elsif ($op eq 'qr') { - return $tree->[3] ? qr{(?$tree->[3]:$tree->[2])} : qr{$tree->[2]}; - } - - $self->throw('operator', "Un-implemented operation $op"); -} - -###----------------------------------------------------------------### - -sub parse_BLOCK { - my ($self, $str_ref, $node) = @_; - - my $end = $self->{'_end_tag'} || '(?!)'; - my $block_name = $self->parse_expr($str_ref, {auto_quote => " - ($QR_FILENAME # file name - | \\w+\\b (?: :\\w+\\b)* ) # or block - (?= [+=~-]? $end # an end tag - | \\s*[+,;] # followed by explicit + , or ; - | \\s+ (?! [\\s=]) # or space not before an = - ) \\s* $QR_COMMENTS"}); - - return '' if ! defined $block_name; - - my $prepend = join "/", map {$_->[3]} grep {ref($_) && $_->[0] eq 'BLOCK'} @{ $self->{'_state'} || {} }; - return $prepend ? "$prepend/$block_name" : $block_name; -} - -sub play_BLOCK { - my ($self, $block_name, $node, $out_ref) = @_; - - ### store a named reference - but do nothing until something processes it - $self->{'BLOCKS'}->{$block_name} = { - _tree => $node->[4], - name => $self->{'_component'}->{'name'} .'/'. $block_name, + my $swap = { + key1 => 'val1', + key2 => 'val2', + code => sub { 42 }, + hash => {a => 'b'}, }; - return; -} - -sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) } - -sub play_CALL { $DIRECTIVES->{'GET'}->[1]->(@_); return } + $t->set_delimiters('#[', ']#'); + $t->set_strip(0); + $t->set_values($swap); + $t->set_dir('/path/to/templates'); -sub parse_CASE { - my ($self, $str_ref) = @_; - return if $$str_ref =~ m{ \G DEFAULT \s* }gcx; - return $self->parse_expr($str_ref); -} + my $out = $t->parse_file('my/template.tmpl'); -sub parse_CATCH { - my ($self, $str_ref) = @_; - return $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"}); -} + my $str = "Foo #[echo $key1]# Bar"; + my $out = $t->parse_string($str); -sub play_control { - my ($self, $undef, $node) = @_; - $self->throw(lc($node->[0]), 'Control exception', $node); -} -sub play_CLEAR { - my ($self, $undef, $node, $out_ref) = @_; - $$out_ref = ''; -} + ### Alloy uses the same syntax and configuration as Text::Tmpl -sub parse_CONFIG { - my ($self, $str_ref) = @_; +=head2 Velocity (VTL) style usage - my %ctime = map {$_ => 1} @CONFIG_COMPILETIME; - my %rtime = map {$_ => 1} @CONFIG_RUNTIME; + my $t = Template::Alloy->new; - my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1}); - my $ref = $config->[0]->[0]; - for (my $i = 2; $i < @$ref; $i += 2) { - my $key = $ref->[$i] = uc $ref->[$i]; - my $val = $ref->[$i + 1]; - if ($ctime{$key}) { - splice @$ref, $i, 2, (); # remove the options - $self->{$key} = $self->play_expr($val); - $i -= 2; - } elsif (! $rtime{$key}) { - $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref)); - } - } - for (my $i = 1; $i < @$config; $i++) { - my $key = $config->[$i] = uc $config->[$i]->[0]; - if ($ctime{$key}) { - $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef'); - } elsif (! $rtime{$key}) { - $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref)); - } - } - return $config; -} - -sub play_CONFIG { - my ($self, $config) = @_; - - my %rtime = map {$_ => 1} @CONFIG_RUNTIME; - - ### do runtime config - not many options get these - my ($named, @the_rest) = @$config; - $named = $self->play_expr($named); - @{ $self }{keys %$named} = @{ $named }{keys %$named}; - - ### show what current values are - return join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest); -} - -sub parse_DEBUG { - my ($self, $str_ref) = @_; - $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx - || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref)); - my $ret = [lc($1)]; - if ($ret->[0] eq 'format') { - $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs - || $self->throw('parse', "Missing format string", undef, pos($$str_ref)); - $ret->[1] = $2; - } - return $ret; -} - -sub play_DEBUG { - my ($self, $ref) = @_; - if ($ref->[0] eq 'on') { - delete $self->{'_debug_off'}; - } elsif ($ref->[0] eq 'off') { - $self->{'_debug_off'} = 1; - } elsif ($ref->[0] eq 'format') { - $self->{'_debug_format'} = $ref->[1]; - } -} - -sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) } - -sub play_DEFAULT { - my ($self, $set) = @_; - foreach (@$set) { - my ($op, $set, $default) = @$_; - next if ! defined $set; - my $val = $self->play_expr($set); - if (! $val) { - $default = defined($default) ? $self->play_expr($default) : ''; - $self->set_variable($set, $default); - } - } - return; -} - -sub parse_DUMP { - my ($self, $str_ref) = @_; - return $self->parse_args($str_ref, {named_at_front => 1}); -} - -sub play_DUMP { - my ($self, $dump, $node) = @_; - - my $conf = $self->{'DUMP'}; - return if ! $conf && defined $conf; # DUMP => 0 - $conf = {} if ref $conf ne 'HASH'; - - ### allow for handler override - my $handler = $conf->{'handler'}; - if (! $handler) { - require Data::Dumper; - my $obj = Data::Dumper->new([]); - my $meth; - foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) } - my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1; - $obj->Sortkeys(sub { my $h = shift; [grep {$_ !~ $QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] }); - $handler = sub { $obj->Values([@_]); $obj->Dump } - } - - my ($named, @dump) = @$dump; - push @dump, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some - $_ = $self->play_expr($_) foreach @dump; - - ### look for the text describing what to dump - my $info = $self->node_info($node); - my $out; - if (@dump) { - $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump); - my $name = $info->{'text'}; - $name =~ s/^[+=~-]?\s*DUMP\s+//; - $name =~ s/\s*[+=~-]?$//; - $out =~ s/\$VAR1/$name/; - } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) { - $out = ''; - } else { - $out = $handler->($self->{'_vars'}); - $out =~ s/\$VAR1/EntireStash/g; - } - - if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) { - $out = $SCALAR_OPS->{'html'}->($out); - $out = "
$out"; - $out = "DUMP: File \"$info->{file}\" line $info->{line}$out" if $conf->{'header'} || ! defined $conf->{'header'}; - } else { - $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'}; - } - - return $out; -} - -sub parse_FILTER { - my ($self, $str_ref) = @_; - my $name = ''; - if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) { - $name = $1; - } - - my $filter = $self->parse_expr($str_ref); - $filter = '' if ! defined $filter; - - return [$name, $filter]; -} - -sub play_FILTER { - my ($self, $ref, $node, $out_ref) = @_; - my ($name, $filter) = @$ref; - - return '' if ! @$filter; - - $self->{'FILTERS'}->{$name} = $filter if length $name; - - my $sub_tree = $node->[4]; - - ### play the block - my $out = ''; - eval { $self->execute_tree($sub_tree, \$out) }; - die $@ if $@ && ref($@) !~ /Template::Exception$/; - - my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it - - - return $DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref); -} - -sub parse_FOREACH { - my ($self, $str_ref) = @_; - my $items = $self->parse_expr($str_ref); - my $var; - if ($$str_ref =~ m{ \G (= | [Ii][Nn]\b) \s* }gcx) { - $var = [@$items]; - $items = $self->parse_expr($str_ref); - } - return [$var, $items]; -} - -sub play_FOREACH { - my ($self, $ref, $node, $out_ref) = @_; - - ### get the items - make sure it is an arrayref - my ($var, $items) = @$ref; + my $swap = { + key1 => 'val1', + key2 => 'val2', + code => sub { 42 }, + hash => {a => 'b'}, + }; - $items = $self->play_expr($items); - return '' if ! defined $items; + my $out = $t->merge('my/template.vtl', $swap); - if (ref($items) !~ /Iterator$/) { - $items = $PACKAGE_ITERATOR->new($items); - } + my $str = "#set($foo 1 + 3) ($foo) ($bar) ($!baz)"; + my $out = $t->merge(\$str, $swap); - my $sub_tree = $node->[4]; +=head1 DESCRIPTION - local $self->{'_vars'}->{'loop'} = $items; +CGI::Ex::Template is the original base for the code that is now +Template::Alloy. Template::Alloy employed enough complexity and +featureset to warrant moving it out to a separate namespace. - ### if the FOREACH tag sets a var - then nothing but the loop var gets localized - if (defined $var) { - my ($item, $error) = $items->get_first; - while (! $error) { +CGI::Ex::Template is now a place holder subclass of Template::Alloy. +You can use CGI::Ex::Template as a standalone module - but it is +suggested that you use Template::Alloy directly instead. - $self->set_variable($var, $item); +For examples of usage, configuration, syntax, bugs, vmethods, +directives, etc please refer to the L