-BEGIN {
- $VERSION = '2.08';
-
- $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 = {
- default => ['[%', '%]'], # default
- template => ['[%', '%]'], # default
- metatext => ['%%', '%%'], # Text::MetaText
- star => ['[*', '*]'], # TT alternate
- php => ['<?', '?>'], # PHP
- asp => ['<%', '%>'], # ASP
- mason => ['<%', '>' ], # HTML::Mason
- html => ['<!--', '-->'], # HTML comments
- };
-
- $SCALAR_OPS = {
- '0' => sub { shift },
- as => \&vmethod_as_scalar,
- chunk => \&vmethod_chunk,
- collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
- defined => sub { 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; s/\"/"/g; $_ },
- 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 scalar $str =~ /$pat/ },
- size => sub { 1 },
- split => \&vmethod_split,
- stderr => sub { print STDERR $_[0]; '' },
- substr => sub { my ($str, $i, $len) = @_; defined($len) ? substr($str, $i, $len) : substr($str, $i) },
- trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
- ucfirst => sub { ucfirst $_[0] },
- upper => sub { uc $_[0] },
- uri => \&vmethod_uri,
- };
-
- $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],
- };
-
- $LIST_OPS = {
- as => \&vmethod_as_list,
- first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
- fmt => \&vmethod_as_list,
- grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
- hash => sub { local $^W; my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
- 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 { $#{ $_[0] } },
- merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
- new => sub { local $^W; return [@_] },
- 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 { 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 '' },
- };
-
- $HASH_OPS = {
- as => \&vmethod_as_hash,
- defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } },
- delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } },
- each => sub { [%{ $_[0] }] },
- exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
- fmt => \&vmethod_as_hash,
- hash => sub { $_[0] },
- import => sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
- item => sub { my ($h, $k) = @_; return '' if ! defined $k || $k =~ $QR_PRIVATE; $h->{$k} },
- items => sub { [ %{ $_[0] } ] },
- keys => sub { [keys %{ $_[0] }] },
- list => sub { [$_[0]] },
- new => sub { local $^W; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} },
- nsort => sub { my $ref = shift; [sort {$ref->{$a} <=> $ref->{$b} } keys %$ref] },
- pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } 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] }] },
- };
-
- $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, sub {}],
- METADEF => [undef, \&play_METADEF],
- 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
- };
- $QR_DIRECTIVE = qr{ ^ (\w+|\|) (?= $|[\s;\#]) }x;
-
- ### setup the operator parsing
- $OPERATORS = [
- # type precedence symbols action (undef means play_operator will handle)
- ['postfix', 99, ['++'], undef ],
- ['postfix', 99, ['--'], undef ],
- ['prefix', 98, ['++'], undef ],
- ['prefix', 98, ['--'], 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, ['~', '_'], sub { join "", @_ } ],
- ['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, ['hash'], sub { return {@_}; } ],
- ['', 0, ['array'], sub { return [@_] } ],
- ];
- $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 {/^\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_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 = '.sto';
-
- eval {require Scalar::Util};
-};
-
-###----------------------------------------------------------------###
-
-sub new {
- my $class = shift;
- my $args = ref($_[0]) ? { %{ shift() } } : {@_};
- my $self = bless $args, $class;
-
- ### "enable" debugging - we only support DEBUG_DIRS and DEBUG_UNDEF
- if ($self->{'DEBUG'}) {
- $self->{'_debug_dirs'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/;
- $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/;
- }
-
- return $self;
-}
-
-###----------------------------------------------------------------###
-
-sub _process {
- my $self = shift;
- my $file = shift;
- local $self->{'_vars'} = shift || {};
- my $out_ref = shift || $self->throw('undef', "Missing output ref");
- local $self->{'_top_level'} = delete $self->{'_start_top_level'};
- my $i = length $$out_ref;
-
- ### parse and execute
- my $doc;
- eval {
- ### load the document
- $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");;
-
- ### prevent recursion
- $self->throw('file', "recursion into '$doc->{name}'")
- if ! $self->{'RECURSION'} && $self->{'_in'}->{$doc->{'name'}} && $doc->{'name'} ne 'input text';
- local $self->{'_in'}->{$doc->{'name'}} = 1;
-
- ### execute the document
- if (! @{ $doc->{'_tree'} }) { # no tags found - just return the content
- $$out_ref = ${ $doc->{'_content'} };
- } else {
- local $self->{'_vars'}->{'component'} = $doc;
- $self->{'_vars'}->{'template'} = $doc if $self->{'_top_level'};
- $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;
- }
-
- ### 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};
-
- ### 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 ($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]))) {
- $doc = $self->{'_documents'}->{$file};
- $doc->{'_cache_time'} = time;
- 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;
-
-
- ### 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 'METADEF';
- 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;
- }
- }
- die $err if ! $doc->{'_tree'};
- } elsif ($self->{'DEFAULT'}) {
- $doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) } || die $err;
- } else {
- 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->{'_vars'}->{'component'} = $doc;
- $doc->{'_tree'} = $self->parse_tree($doc->{'_content'}); # 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];
- my $len_s = length $START;
- my $len_e = length $END;
-
- 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)
- my @meta; # place to store any found meta information (to go into METADEF)
- my $i = 0; # start index
- my $j = 0; # end index
- my $last = 0; # previous end index
- my $post_chomp = 0; # previous post_chomp setting
- my $continue; # 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 $tag;
- while (1) {
- ### continue looking for information in a semi-colon delimited tag
- if ($continue) {
- $i = $continue;
- $node = [undef, $i, $j];
-
- ### look through the string using index
- } else {
- $i = index($$str_ref, $START, $last);
- last if $i == -1; # no start tag found - we are done
- if ($last != $i) { # found a text portion - chomp it, interpolate it and store it
- my $text = substr($$str_ref, $last, $i - $last);
- my $_last = $last;
- 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'};
- }
- }
- $j = index($$str_ref, $END, $i + $len_s);
- $last = $j + $len_e;
- if ($j == -1) { # missing closing tag
- $last = length($$str_ref);
- last;
- }
- $tag = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
- $node = [undef, $i + $len_s, $j];
-
- ### take care of whitespace and comments flags
- my $pre_chomp = $tag =~ s{ ^ ([+=~-]) }{}x ? $1 : $self->{'PRE_CHOMP'};
- $post_chomp = $tag =~ s{ ([+=~-]) $ }{}x ? $1 : $self->{'POST_CHOMP'};
- $pre_chomp =~ y/-=~+/1230/ if $pre_chomp;
- $post_chomp =~ y/-=~+/1230/ if $post_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 ($tag =~ /^\#/) { # leading # means to comment the entire section
- $node->[0] = '#';
- push @$pointer, $node;
- next;
- }
- $tag =~ s{ ^ \s+ $QR_COMMENTS }{}ox;
- }
-
- if (! length $tag) {
- undef $continue;
- undef $post_op;
- next;
- }
-
- ### look for DIRECTIVES
- if ($tag =~ $QR_DIRECTIVE # find a word
- && $DIRECTIVES->{$1} ) { # is it a directive
- $node->[0] = $func = $1;
- $tag =~ s{ ^ (\w+ | \|) \s* $QR_COMMENTS }{}ox;
-
- ### 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);
- }
- 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, 0);
- }
- }
-
- ### 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
- 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'};
- }
-
- ### continuation block - such as an elsif
- } else {
- $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \$tag, $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') {
- if ($tag =~ / ^ (\w+) /x && $TAGS->{$1}) {
- $tag =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox;
- ($START, $END) = @{ $TAGS->{$1} };
- } elsif ($tag =~ s{ ^ (\S+) \s+ (\S+) \s* $QR_COMMENTS }{}ox) {
- ($START, $END) = ($1, $2);
- }
- $len_s = length $START;
- $len_e = length $END;
-
- } elsif ($func eq 'META') {
- my $args = $self->parse_args(\$tag);
- 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, \$tag, $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] ||= [];
- }
- }
-
- ### allow for bare variable getting and setting
- } elsif (defined(my $var = $self->parse_expr(\$tag))) {
- push @$pointer, $node;
- if ($tag =~ s{ ^ ($QR_OP_ASSIGN) >? \s* $QR_COMMENTS }{}ox) {
- $node->[0] = 'SET';
- $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, \$tag, $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;
- }
-
- } else { # error
- my $all = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
- $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;
- }
-
- ### we are flagged to start capturing the output of the next directive - set it up
- if ($node->[6]) {
- $continue = $j - length $tag;
- $node->[2] = $continue;
- $post_op = undef;
- $capture = $node;
-
- ### semi-colon = end of statement - we will need to continue parsing this tag
- } elsif ($tag =~ s{ ^ ; \s* $QR_COMMENTS }{}ox) {
- $continue = $j - length $tag;
- $node->[2] = $continue;
- $post_op = undef;
-
- ### looking at a post operator ([% u FOREACH u IN [1..3] %])
- } elsif ($tag =~ $QR_DIRECTIVE # find a word
- && $DIRECTIVES->{$1} # is it a directive
- && $DIRECTIVES->{$1}->[3]) { # it is a post operative directive
- $continue = $j - length $tag;
- $node->[2] = $continue;
- $post_op = $node;
-
- ### unlink TT2 - look for another directive
- } elsif (length $tag) {
- #$self->throw('parse', "Found trailing info \"$tag\"", $node);
- $continue = $j - length $tag;
- $node->[2] = $continue;
- $post_op = undef;
-
- } else {
- $continue = undef;
- $post_op = undef;
- }
- }
-
- if (@move_to_front) {
- unshift @tree, @move_to_front;
- }
- if (@meta) {
- unshift @tree, ['METADEF', 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 ($last != length($$str_ref)) {
- my $text = substr($$str_ref, $last, length($$str_ref) - $last);
- my $_last = $last;
- 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 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 parse_expr {
- my $self = shift;
- my $str_ref = shift;
- my $ARGS = shift || {};
-
- ### allow for custom auto_quoting (such as hash constructors)
- if ($ARGS->{'auto_quote'}) {
- if ($$str_ref =~ $ARGS->{'auto_quote'}) {
- my $str = $1;
- substr($$str_ref, 0, length($str), '');
- $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox;
- return $str;
- ### allow for auto-quoted $foo or ${foo.bar} type constructs
- } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox
- || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
- my $name = $1;
- return $self->parse_expr(\$name);
- }
- }
-
- my $copy = $$str_ref; # copy while parsing to allow for errors
-
- ### test for leading prefix operators
- my $has_prefix;
- while ($copy =~ s{ ^ ($QR_OP_PREFIX) \s* $QR_COMMENTS }{}ox) {
- return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
- push @{ $has_prefix }, $1;
- }
-
- my @var;
- my $is_literal;
- my $is_namespace;
-
- ### allow hex
- if ($copy =~ s{ ^ 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }{}ox) {
- my $number = eval { hex $1 } || 0;
- push @var, \ $number;
- $is_literal = 1;
-
- ### allow for numbers
- } elsif ($copy =~ s{ ^ ( $QR_NUM ) \s* $QR_COMMENTS }{}ox) {
- my $number = $1;
- push @var, \ $number;
- $is_literal = 1;
-
- ### allow for quoted array constructor
- } elsif ($copy =~ s{ ^ qw (\W) \s* }{}x) {
- my $quote = $1;
- $quote =~ y|([{<|)]}>|;
- $copy =~ s{ ^ (.*) \Q$quote\E \s* $QR_COMMENTS }{}sx
- || $self->throw('parse.missing.array_close', "Missing close \"$quote\"", undef, length($$str_ref) - length($copy));
- my $str = $1;
- $str =~ s{ ^ \s+ | \s+ $ }{}x;
- my $arrayref = ['array', split /\s+/, $str];
- push @var, \ $arrayref;
-
- ### looks like a normal variable start
- } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
- push @var, $1;
- $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
-
- ### allow for literal strings
- } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) {
- if ($1 eq "'") { # no interpolation on single quoted strings
- my $str = $2;
- $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/\\([\"\$])/$1/g;
- my @pieces = $ARGS->{'auto_quote'}
- ? split(m{ (\$\w+ | \$\{ [^\}]+ \}) }x, $str) # autoquoted items get a single $\w+ - no nesting
- : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $str);
- my $n = 0;
- foreach my $piece (@pieces) {
- next if ! ($n++ % 2);
- next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
- && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x;
- my $name = $1;
- $piece = $self->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, \ ['~', @pieces];
- }
- }
- if ($ARGS->{'auto_quote'}){
- $$str_ref = $copy;
- return ${ $var[0] } if $is_literal;
- push @var, 0;
- return \@var;
- }
-
- ### allow for leading $foo or ${foo.bar} type constructs
- } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox
- || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
- my $name = $1;
- push @var, $self->parse_expr(\$name);
-
- ### looks like an array constructor
- } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) {
- local $self->{'_operator_precedence'} = 0; # reset presedence
- my $arrayref = ['array'];
- while (defined(my $var = $self->parse_expr(\$copy))) {
- push @$arrayref, $var;
- $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
- }
- $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, length($$str_ref) - length($copy));
- push @var, \ $arrayref;
-
- ### looks like a hash constructor
- } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) {
- local $self->{'_operator_precedence'} = 0; # reset precedence
- my $hashref = ['hash'];
- while (defined(my $key = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) {
- $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox;
- my $val = $self->parse_expr(\$copy);
- push @$hashref, $key, $val;
- $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
- }
- $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.curly_bracket', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy));
- push @var, \ $hashref;
-
- ### looks like a paren grouper
- } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
- local $self->{'_operator_precedence'} = 0; # reset precedence
- my $var = $self->parse_expr(\$copy, {allow_parened_ops => 1});
- $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
- @var = @$var;
- pop(@var); # pull off the trailing args of the paren group
-
- ### nothing to find - return failure
- } else {
- return;
- }
-
- return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
-
- ### looks for args for the initial
- if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
- local $self->{'_operator_precedence'} = 0; # reset precedence
- my $args = $self->parse_args(\$copy);
- $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
- push @var, $args;
- } else {
- push @var, 0;
- }
-
- ### allow for nested items
- while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) {
- push(@var, $1) if ! $ARGS->{'no_dots'};
-
- ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two
- if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox
- || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) {
- my $name = $1;
- my $var = $self->parse_expr(\$name);
- push @var, $var;
-
- ### allow for names
- } elsif ($copy =~ s{ ^ (-? \w+) \s* $QR_COMMENTS }{}ox) {
- push @var, $1;
-
- } else {
- $self->throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)");
- }
-
- ### looks for args for the nested item
- if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
- local $self->{'_operator_precedence'} = 0; # reset precedence
- my $args = $self->parse_args(\$copy);
- $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
- push @var, $args;
- } else {
- push @var, 0;
- }
-
- }
-
- ### flatten literals and constants as much as possible
- my $var = ($is_literal && $#var == 1) ? ${ $var[0] }
- : $is_namespace ? $self->play_expr(\@var, {is_namespace_during_compile => 1})
- : \@var;
-
- ### allow for all "operators"
- if (! $self->{'_operator_precedence'}) {
- my $tree;
- my $found;
- while ($copy =~ s{ ^ ($QR_OP) (\s* $QR_COMMENTS) }{}ox) { ## look for operators - then move along
- if (! $ARGS->{'allow_parened_ops'} && $OP_ASSIGN->{$1}) {
- $copy = $1 . $2 . $copy;
- last;
- }
-
- local $self->{'_operator_precedence'} = 1;
- my $op = $1;
-
- ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --)
- if ($OP_POSTFIX->{$op}) {
- $var = [\ [$op, $var, 1], 0]; # cheat - give a "second value" to postfix ops
- next;
-
- ### allow for prefix operator precedence
- } elsif ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix->[-1]}->[1]) {
- if ($tree) {
- if ($#$tree == 1) { # only one operator - keep simple things fast
- $var = [\ [$tree->[0], $var, $tree->[1]], 0];
- } else {
- unshift @$tree, $var;
- $var = $self->apply_precedence($tree, $found);
- }
- undef $tree;
- undef $found;
- }
- $var = [ \ [ $has_prefix->[-1], $var ], 0 ];
- if (! @$has_prefix) { undef $has_prefix } else { pop @$has_prefix }
- }
-
- ### add the operator to the tree
- my $var2 = $self->parse_expr(\$copy);
- push (@{ $tree ||= [] }, $op, $var2);
- $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op}
- }
-
- ### if we found operators - tree the nodes by operator precedence
- if ($tree) {
- if (@$tree == 2) { # only one operator - keep simple things fast
- $var = [\ [$tree->[0], $var, $tree->[1]], 0];
- } else {
- unshift @$tree, $var;
- $var = $self->apply_precedence($tree, $found);
- }
- }
- }
-
- ### allow for prefix on non-chained variables
- if ($has_prefix) {
- $var = [ \ [ $_, $var ], 0 ] for reverse @$has_prefix;
- }
-
- $$str_ref = $copy; # commit the changes
- 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 = [ \ [ $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 [ \ [ $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 = [ \ [$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 = [ \ [ $ops[$_ - 1], $exprs[$_], $val ], 0 ] for reverse (0 .. $#exprs - 1);
- return $val;
-
- } else {
- my $val = $exprs[0];
- $val = [ \ [ $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 $copy = $$str_ref;
-
- my @args;
- my @named;
- while (length $$str_ref) {
- my $copy = $$str_ref;
- if (defined(my $name = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
- && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
- $self->throw('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'};
- my $val = $self->parse_expr(\$copy);
- $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
- push @named, $name, $val;
- $$str_ref = $copy;
- } elsif (defined(my $arg = $self->parse_expr($str_ref))) {
- push @args, $arg;
- $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
- } else {
- last;
- }
- }
-
- ### allow for named arguments to be added also
- push @args, [\ ['hash', @named], 0] if scalar @named;
-
- 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{ (?: ^ | (?<! \\)) (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $tree->[-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
- if (! ($n++ % 2)) { # odds will always be text chunks
- next if ! length $piece;
- $piece =~ s{ \\ ([\"\$]) }{$1}xg;
- push @sub_tree, $piece;
- } elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
- || $piece =~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x) {
- my $name = $1;
- push @sub_tree, ['GET', $offset - length($piece), $offset, $self->parse_expr(\$name)];
- } else {
- $self->throw('parse', "Parse error during interpolate node");
- }
- }
-
- ### replace the tree
- splice @$tree, -1, 1, @sub_tree;
-}
-
-###----------------------------------------------------------------###
-
-sub play_expr {
- ### allow for the parse tree to store literals
- return $_[1] if ! ref $_[1];
-
- my $self = shift;
- my $var = shift;
- my $ARGS = shift || {};
- my $i = 0;
-
- ### determine the top level of this particular variable access
- my $ref;
- my $name = $var->[$i++];
- my $args = $var->[$i++];
- warn "play_expr: begin \"$name\"\n" if trace;
- if (ref $name) {
- if (ref $name eq 'SCALAR') { # a scalar literal
- $ref = $$name;
- } elsif (ref $name eq 'REF') { # operator
- return $self->play_operator($$name) if ${ $name }->[0] 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 _
- $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 _
- $ref = $self->{'_vars'}->{$name};
- $ref = $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')) {
- 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')) {
- 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}) ) {
- $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 {
- $ref = undef;
- }
-
- ### array access
- } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
- if ($name =~ m{ ^ -? $QR_NUM $ }ox) {
- $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 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) {
- if (ref($ref) eq 'ARRAY') { # 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;
- }
- } else { # all other types can't be set
- 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 = shift;
- my $tree = shift;
-
- if ($OP_DISPATCH->{$tree->[0]}) {
- local $^W;
- if ($OP_ASSIGN->{$tree->[0]}) {
- my $val = $OP_DISPATCH->{$tree->[0]}->( $self->play_expr($tree->[1]), $self->play_expr($tree->[2]) );
- $self->set_variable($tree->[1], $val);
- return $val;
- } else {
- return $OP_DISPATCH->{$tree->[0]}->( map { $self->play_expr($tree->[$_]) } 1 .. $#$tree );
- }
- }
-
- my $op = $tree->[0];
-
- ### do custom and short-circuitable operators
- if ($op eq '=') {
- my $val = $self->play_expr($tree->[2]);
- $self->set_variable($tree->[1], $val);
- return $val;
-
- } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
- return $self->play_expr($tree->[1]) || $self->play_expr($tree->[2]) || '';
-
- } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') {
- my $var = $self->play_expr($tree->[1]) && $self->play_expr($tree->[2]);
- return $var ? $var : 0;
-
- } elsif ($op eq '?') {
- local $^W;
- return $self->play_expr($tree->[1]) ? $self->play_expr($tree->[2]) : $self->play_expr($tree->[3]);
-
- } elsif ($op eq '++') {
- local $^W;
- my $val = 0 + $self->play_expr($tree->[1]);
- $self->set_variable($tree->[1], $val + 1);
- return $tree->[2] ? $val : $val + 1; # ->[2] is set to 1 during parsing of postfix ops
-
- } elsif ($op eq '--') {
- local $^W;
- my $val = 0 + $self->play_expr($tree->[1]);
- $self->set_variable($tree->[1], $val - 1);
- return $tree->[2] ? $val : $val - 1; # ->[2] is set to 1 during parsing of postfix ops
- }
-
- $self->throw('operator', "Un-implemented operation $op");
-}
-
-###----------------------------------------------------------------###
-
-sub parse_BLOCK {
- my ($self, $tag_ref, $node) = @_;
-
- my $block_name = '';
- if ($$tag_ref =~ s{ ^ (\w+ (?: :\w+)*) \s* (?! [\.\|]) }{}x
- || $$tag_ref =~ s{ ^ '(|.*?[^\\])' \s* (?! [\.\|]) }{}x
- || $$tag_ref =~ s{ ^ "(|.*?[^\\])" \s* (?! [\.\|]) }{}x
- ) {
- $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;
- }
-
- return $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->{'_vars'}->{'component'}->{'name'} .'/'. $block_name,
- };
-
- return;
-}
-
-sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) }
-
-sub play_CALL { $DIRECTIVES->{'GET'}->[1]->(@_); return }
-
-sub parse_CASE {
- my ($self, $tag_ref) = @_;
- return if $$tag_ref =~ s{ ^ DEFAULT \s* }{}x;
- return $self->parse_expr($tag_ref);
-}
-
-sub parse_CATCH {
- my ($self, $tag_ref) = @_;
- return $self->parse_expr($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
-}
-
-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 = '';
-}
-
-sub parse_DEBUG {
- my ($self, $tag_ref) = @_;
- $$tag_ref =~ s{ ^ (on | off | format) \s* }{}xi || $self->throw('parse', "Unknown DEBUG option");
- my $ret = [lc($1)];
- if ($ret->[0] eq 'format') {
- $$tag_ref =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* }{}xs || $self->throw('parse', "Missing format string");
- $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, $tag_ref) = @_;
- my $ref = $self->parse_expr($tag_ref);
- return $ref;
-}
-
-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/</</g;
- $out = "<pre>$out</pre>";
- $out =~ s/\$VAR1/$var/;
- $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out";
- } else {
- $out =~ s/\$VAR1/$var/;
- }
-
- return $out;
-}
-
-sub parse_FILTER {
- my ($self, $tag_ref) = @_;
- my $name = '';
- if ($$tag_ref =~ s{ ^ ([^\W\d]\w*) \s* = \s* }{}x) {
- $name = $1;
- }
-
- my $filter = $self->parse_expr($tag_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 = [\$out, 0, '|', @$filter]; # make a temporary var out of it
-
-
- return $DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
-}
-
-sub parse_FOREACH {
- my ($self, $tag_ref) = @_;
- my $items = $self->parse_expr($tag_ref);
- my $var;
- if ($$tag_ref =~ s{ ^ (= | [Ii][Nn]\b) \s* }{}x) {
- $var = [@$items];
- $items = $self->parse_expr($tag_ref);
- }
- return [$var, $items];
-}
-
-sub play_FOREACH {
- my ($self, $ref, $node, $out_ref) = @_;
-
- ### get the items - make sure it is an arrayref
- my ($var, $items) = @$ref;
-
- $items = $self->play_expr($items);
- return '' if ! defined $items;
-
- if (ref($items) !~ /Iterator$/) {
- $items = $PACKAGE_ITERATOR->new($items);
- }
-
- my $sub_tree = $node->[4];
-
- local $self->{'_vars'}->{'loop'} = $items;
-
- ### if the FOREACH tag sets a var - then nothing but the loop var gets localized
- if (defined $var) {
- my ($item, $error) = $items->get_first;
- while (! $error) {
-
- $self->set_variable($var, $item);