-use strict;
-
-our $VERSION = '2.13';
-
-our $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
-our $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
-our $PACKAGE_CONTEXT = 'CGI::Ex::Template::Context';
-our $QR_PRIVATE = qr/^[_.]/;
-
-our $SYNTAX = {
- cet => \&parse_tree_tt3,
- ht => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; local $self->{'EXPR'} = 0; $self->parse_tree_hte(@_) },
- hte => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; $self->parse_tree_hte(@_) },
- tt3 => \&parse_tree_tt3,
- tt2 => sub { my $self = shift; local $self->{'V2PIPE'} = 1; $self->parse_tree_tt3(@_) },
- tt1 => sub { my $self = shift; local $self->{'V2PIPE'} = 1; local $self->{'V1DOLLAR'} = 1; $self->parse_tree_tt3(@_) },
-};
-
-our $TAGS = {
- asp => ['<%', '%>' ], # ASP
- default => ['\[%', '%\]' ], # default
- html => ['<!--', '-->' ], # HTML comments
- mason => ['<%', '>' ], # HTML::Mason
- metatext => ['%%', '%%' ], # Text::MetaText
- php => ['<\?', '\?>' ], # PHP
- star => ['\[\*', '\*\]' ], # TT alternate
- template => ['\[%', '%\]' ], # Normal Template Toolkit
- template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style
- tt2 => ['\[%', '%\]' ], # TT2
-};
-
-our $SCALAR_OPS = {
- '0' => sub { $_[0] },
- abs => sub { local $^W; abs shift },
- atan2 => sub { local $^W; atan2($_[0], $_[1]) },
- chunk => \&vmethod_chunk,
- collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
- cos => sub { local $^W; cos $_[0] },
- defined => sub { defined $_[0] ? 1 : '' },
- exp => sub { local $^W; exp $_[0] },
- fmt => \&vmethod_fmt_scalar,
- 'format' => \&vmethod_format,
- hash => sub { {value => $_[0]} },
- hex => sub { local $^W; hex $_[0] },
- html => sub { local $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; s/\"/"/g; s/\'/'/g; $_ },
- indent => \&vmethod_indent,
- int => sub { local $^W; int $_[0] },
- item => sub { $_[0] },
- js => sub { local $_ = $_[0]; return if ! $_; s/\n/\\n/g; s/\r/\\r/g; s/(?<!\\)([\"\'])/\\$1/g; $_ },
- lc => sub { lc $_[0] },
- lcfirst => sub { lcfirst $_[0] },
- length => sub { defined($_[0]) ? length($_[0]) : 0 },
- list => sub { [$_[0]] },
- log => sub { local $^W; log $_[0] },
- lower => sub { lc $_[0] },
- match => \&vmethod_match,
- new => sub { defined $_[0] ? $_[0] : '' },
- null => sub { '' },
- oct => sub { local $^W; oct $_[0] },
- rand => sub { local $^W; rand shift },
- remove => sub { vmethod_replace(shift, shift, '', 1) },
- repeat => \&vmethod_repeat,
- replace => \&vmethod_replace,
- search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ },
- sin => sub { local $^W; sin $_[0] },
- size => sub { 1 },
- split => \&vmethod_split,
- sprintf => sub { local $^W; my $pat = shift; sprintf($pat, @_) },
- sqrt => sub { local $^W; sqrt $_[0] },
- srand => sub { local $^W; srand $_[0]; '' },
- stderr => sub { print STDERR $_[0]; '' },
- substr => \&vmethod_substr,
- trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
- uc => sub { uc $_[0] },
- ucfirst => sub { ucfirst $_[0] },
- upper => sub { uc $_[0] },
- uri => \&vmethod_uri,
- url => \&vmethod_url,
-};
-
-our $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops
- eval => [\&filter_eval, 1],
- evaltt => [\&filter_eval, 1],
- file => [\&filter_redirect, 1],
- redirect => [\&filter_redirect, 1],
-};
-
-our $LIST_OPS = {
- defined => sub { return 1 if @_ == 1; defined $_[0]->[ defined($_[1]) ? $_[1] : 0 ] },
- first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
- fmt => \&vmethod_fmt_list,
- grep => sub { local $^W; my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
- hash => sub { local $^W; my $list = shift; return {@$list} if ! @_; my $i = shift || 0; return {map {$i++ => $_} @$list} },
- import => sub { my $ref = shift; push @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_; '' },
- item => sub { $_[0]->[ $_[1] || 0 ] },
- join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
- last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]},
- list => sub { $_[0] },
- max => sub { local $^W; $#{ $_[0] } },
- merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
- new => sub { local $^W; return [@_] },
- null => sub { '' },
- nsort => \&vmethod_nsort,
- pick => \&vmethod_pick,
- pop => sub { pop @{ $_[0] } },
- push => sub { my $ref = shift; push @$ref, @_; return '' },
- reverse => sub { [ reverse @{ $_[0] } ] },
- shift => sub { shift @{ $_[0] } },
- size => sub { local $^W; scalar @{ $_[0] } },
- slice => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
- sort => \&vmethod_sort,
- splice => \&vmethod_splice,
- unique => sub { my %u; return [ grep { ! $u{$_}++ } @{ $_[0] } ] },
- unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
-};
-
-our $HASH_OPS = {
- defined => sub { return 1 if @_ == 1; defined $_[0]->{ defined($_[1]) ? $_[1] : '' } },
- delete => sub { my $h = shift; delete @{ $h }{map {defined($_) ? $_ : ''} @_}; '' },
- each => sub { [%{ $_[0] }] },
- exists => sub { exists $_[0]->{ defined($_[1]) ? $_[1] : '' } },
- fmt => \&vmethod_fmt_hash,
- hash => sub { $_[0] },
- import => sub { my ($a, $b) = @_; @{$a}{keys %$b} = values %$b if ref($b) eq 'HASH'; '' },
- item => sub { my ($h, $k) = @_; $k = '' if ! defined $k; $QR_PRIVATE && $k =~ $QR_PRIVATE ? undef : $h->{$k} },
- items => sub { [ %{ $_[0] } ] },
- keys => sub { [keys %{ $_[0] }] },
- list => \&vmethod_list_hash,
- new => sub { local $^W; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} },
- null => sub { '' },
- nsort => sub { my $ref = shift; [sort { $ref->{$a} <=> $ref->{$b}} keys %$ref] },
- pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } sort keys %{ $_[0] } ] },
- size => sub { scalar keys %{ $_[0] } },
- sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] },
- values => sub { [values %{ $_[0] }] },
-};
-
-our $VOBJS = {
- Text => $SCALAR_OPS,
- List => $LIST_OPS,
- Hash => $HASH_OPS,
-};
-foreach (values %$VOBJS) {
- $_->{'Text'} = $_->{'fmt'};
- $_->{'Hash'} = $_->{'hash'};
- $_->{'List'} = $_->{'list'};
-}
-
-our $DIRECTIVES = {
- #name parse_sub play_sub block postdir continue no_interp
- BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1],
- BREAK => [sub {}, \&play_control],
- CALL => [\&parse_CALL, \&play_CALL],
- CASE => [\&parse_CASE, undef, 0, 0, {SWITCH => 1, CASE => 1}],
- CATCH => [\&parse_CATCH, undef, 0, 0, {TRY => 1, CATCH => 1}],
- CLEAR => [sub {}, \&play_CLEAR],
- '#' => [sub {}, sub {}],
- CONFIG => [\&parse_CONFIG, \&play_CONFIG],
- DEBUG => [\&parse_DEBUG, \&play_DEBUG],
- DEFAULT => [\&parse_DEFAULT, \&play_DEFAULT],
- DUMP => [\&parse_DUMP, \&play_DUMP],
- ELSE => [sub {}, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}],
- ELSIF => [\&parse_IF, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}],
- END => [sub {}, sub {}],
- FILTER => [\&parse_FILTER, \&play_FILTER, 1, 1],
- '|' => [\&parse_FILTER, \&play_FILTER, 1, 1],
- FINAL => [sub {}, undef, 0, 0, {TRY => 1, CATCH => 1}],
- FOR => [\&parse_FOREACH, \&play_FOREACH, 1, 1],
- FOREACH => [\&parse_FOREACH, \&play_FOREACH, 1, 1],
- GET => [\&parse_GET, \&play_GET],
- IF => [\&parse_IF, \&play_IF, 1, 1],
- INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE],
- INSERT => [\&parse_INSERT, \&play_INSERT],
- LAST => [sub {}, \&play_control],
- LOOP => [\&parse_LOOP, \&play_LOOP, 1, 1],
- MACRO => [\&parse_MACRO, \&play_MACRO],
- META => [\&parse_META, \&play_META],
- NEXT => [sub {}, \&play_control],
- PERL => [sub {}, \&play_PERL, 1, 0, 0, 1],
- PROCESS => [\&parse_PROCESS, \&play_PROCESS],
- RAWPERL => [sub {}, \&play_RAWPERL, 1, 0, 0, 1],
- RETURN => [sub {}, \&play_control],
- SET => [\&parse_SET, \&play_SET],
- STOP => [sub {}, \&play_control],
- SWITCH => [\&parse_SWITCH, \&play_SWITCH, 1],
- TAGS => [\&parse_TAGS, sub {}],
- THROW => [\&parse_THROW, \&play_THROW],
- TRY => [sub {}, \&play_TRY, 1],
- UNLESS => [\&parse_UNLESS, \&play_UNLESS, 1, 1],
- USE => [\&parse_USE, \&play_USE],
- VIEW => [\&parse_VIEW, \&play_VIEW, 1],
- WHILE => [\&parse_WHILE, \&play_WHILE, 1, 1],
- WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER, 1, 1],
- #name parse_sub play_sub block postdir continue no_interp
-};
-
-### setup the operator parsing
-our $OPERATORS = [
- # type precedence symbols action (undef means play_operator will handle)
- ['prefix', 99, ['\\'], undef ],
- ['postfix', 98, ['++'], undef ],
- ['postfix', 98, ['--'], undef ],
- ['prefix', 97, ['++'], undef ],
- ['prefix', 97, ['--'], undef ],
- ['right', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ],
- ['prefix', 93, ['!'], sub { ! $_[0] } ],
- ['prefix', 93, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
- ['left', 90, ['*'], sub { $_[0] * $_[1] } ],
- ['left', 90, ['/'], sub { $_[0] / $_[1] } ],
- ['left', 90, ['div', 'DIV'], sub { int($_[0] / $_[1]) } ],
- ['left', 90, ['%', 'mod', 'MOD'], sub { $_[0] % $_[1] } ],
- ['left', 85, ['+'], sub { $_[0] + $_[1] } ],
- ['left', 85, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
- ['left', 85, ['~', '_'], undef ],
- ['none', 80, ['<'], sub { $_[0] < $_[1] } ],
- ['none', 80, ['>'], sub { $_[0] > $_[1] } ],
- ['none', 80, ['<='], sub { $_[0] <= $_[1] } ],
- ['none', 80, ['>='], sub { $_[0] >= $_[1] } ],
- ['none', 80, ['lt'], sub { $_[0] lt $_[1] } ],
- ['none', 80, ['gt'], sub { $_[0] gt $_[1] } ],
- ['none', 80, ['le'], sub { $_[0] le $_[1] } ],
- ['none', 80, ['ge'], sub { $_[0] ge $_[1] } ],
- ['none', 75, ['=='], sub { $_[0] == $_[1] } ],
- ['none', 75, ['eq'], sub { $_[0] eq $_[1] } ],
- ['none', 75, ['!='], sub { $_[0] != $_[1] } ],
- ['none', 75, ['ne'], sub { $_[0] ne $_[1] } ],
- ['none', 75, ['<=>'], sub { $_[0] <=> $_[1] } ],
- ['none', 75, ['cmp'], sub { $_[0] cmp $_[1] } ],
- ['left', 70, ['&&'], undef ],
- ['right', 65, ['||'], undef ],
- ['none', 60, ['..'], sub { $_[0] .. $_[1] } ],
- ['ternary', 55, ['?', ':'], undef ],
- ['assign', 53, ['+='], sub { $_[0] + $_[1] } ],
- ['assign', 53, ['-='], sub { $_[0] - $_[1] } ],
- ['assign', 53, ['*='], sub { $_[0] * $_[1] } ],
- ['assign', 53, ['/='], sub { $_[0] / $_[1] } ],
- ['assign', 53, ['%='], sub { $_[0] % $_[1] } ],
- ['assign', 53, ['**='], sub { $_[0] ** $_[1] } ],
- ['assign', 53, ['~=', '_='], sub { $_[0] . $_[1] } ],
- ['assign', 52, ['='], undef ],
- ['prefix', 50, ['not', 'NOT'], sub { ! $_[0] } ],
- ['left', 45, ['and', 'AND'], undef ],
- ['right', 40, ['or', 'OR'], undef ],
-];
-our ($QR_OP, $QR_OP_PREFIX, $QR_OP_ASSIGN, $OP, $OP_PREFIX, $OP_DISPATCH, $OP_ASSIGN, $OP_POSTFIX, $OP_TERNARY);
-sub _op_qr { # no mixed \w\W operators
- my %used;
- my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {! /\{\}|\[\]/} grep {/^\W{2,}$/} @_;
- my $chr = join '', sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_;
- my $word = join '|', reverse sort grep {++$used{$_} < 2} grep {/^\w+$/} @_;
- $chr = "[$chr]" if $chr;
- $word = "\\b(?:$word)\\b" if $word;
- return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex";
-}
-sub _build_ops {
- $QR_OP = _op_qr(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS);
- $QR_OP_PREFIX = _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS);
- $QR_OP_ASSIGN = _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS);
- $OP = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] ne 'prefix' } @$OPERATORS}; # all non-prefix
- $OP_PREFIX = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] eq 'prefix' } @$OPERATORS};
- $OP_DISPATCH = {map {my $ref = $_; map {$_ => $ref->[3]} @{$ref->[2]}} grep {$_->[3] } @$OPERATORS};
- $OP_ASSIGN = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'assign' } @$OPERATORS};
- $OP_POSTFIX = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'postfix'} @$OPERATORS}; # bool is postfix
- $OP_TERNARY = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'ternary'} @$OPERATORS}; # bool is ternary
-}
-_build_ops();
-
-our $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )';
-our $QR_COMMENTS = '(?-s: \# .* \s*)*';
-our $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\.][\w\-\.]* (?:/[\w\-\.]+)*';
-our $QR_BLOCK = '\w+\b (?: :\w+\b)* )';
-our $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?';
-our $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=;) )';
-
-our $WHILE_MAX = 1000;
-our $EXTRA_COMPILE_EXT = '.sto';
-our $MAX_EVAL_RECURSE = 50;
-our $MAX_MACRO_RECURSE = 50;
-our $STAT_TTL ||= 1;
-
-our @CONFIG_COMPILETIME = qw(SYNTAX ANYCASE INTERPOLATE PRE_CHOMP POST_CHOMP SEMICOLONS V1DOLLAR V2PIPE V2EQUALS);
-our @CONFIG_RUNTIME = qw(DUMP VMETHOD_FUNCTIONS);
-
-BEGIN {
- if ($ENV{'MOD_PERL'}) {
- eval {require Scalar::Util};
- require CGI::Ex::Template::Extra;
- require CGI::Ex::Template::HTE;
- }
-};
-
-###----------------------------------------------------------------###
-
-sub new {
- my $class = shift;
- my $args = ref($_[0]) ? { %{ shift() } } : {@_};
-
- ### 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;
-
- ### parse and execute
- my $doc;
- eval {
- ### handed us a precompiled document
- if (ref($file) eq 'HASH' && $file->{'_tree'}) {
- $doc = $file;
-
- ### 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;
-
- ### 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);
- }
-
- ### 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};
- 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 $syntax = $_[0]->{'SYNTAX'} || 'cet';
- my $meth = $SYNTAX->{$syntax} || $_[0]->throw('parse', "Unknown SYNTAX \"$syntax\"");
- return $meth->(@_);
-}
-
-sub parse_tree_tt3 {
- my $self = shift;
- my $str_ref = shift;
- if (! $str_ref || ! defined $$str_ref) {
- $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->{'_no_interp'} = 0; # no interpolation in some blocks (usually PERL)
- my @in_view; # let us know if we are in a view
- my @blocks; # store blocks for later moving to front
- my @meta; # place to store any found meta information (to go into META)
- my $post_chomp = 0; # previous post_chomp setting
- my $continue = 0; # flag for multiple directives in the same tag
- my $post_op = 0; # found a post-operative DIRECTIVE
- my $capture; # flag to start capture
- my $func;
- my $node;
- local pos $$str_ref = 0;
-
- while (1) {
- ### continue looking for information in a semi-colon delimited tag
- if ($continue) {
- $node = [undef, $continue, undef];
-
- ### find the next opening tag
- } else {
- $$str_ref =~ m{ \G (.*?) $START }gcxs
- || last;
-
- ### found a text portion - chomp it, interpolate it and store it
- if (length $1) {
- my $text = $1;
- 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
- }
-
- ### leading # means to comment the entire section
- if ($$str_ref =~ m{ \G \# }gcx) {
- $$str_ref =~ m{ \G (.*?) ([+~=-]?) ($END) }gcxs # brute force - can't comment tags with nested %]
- || $self->throw('parse', "Missing closing tag", undef, pos($$str_ref));
- $node->[0] = '#';
- $node->[2] = pos($$str_ref) - length($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
- $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcx;
-
- $node->[0] = $func;
-
- ### store out this current node level to the appropriate tree location
- # on a post operator - replace the original node with the new one - store the old in the new
- if ($DIRECTIVES->{$func}->[3] && $post_op) {
- my @post_op = @$post_op;
- @$post_op = @$node;
- $node = $post_op;
- $node->[4] = [\@post_op];
- # if there was not a semi-colon - see if semis were required
- } elsif ($post_op && $self->{'SEMICOLONS'}) {
- $self->throw('parse', "Missing semi-colon with SEMICOLONS => 1", undef, $node->[1]);
-
- # handle directive captures for an item like "SET foo = BLOCK"
- } elsif ($capture) {
- push @{ $capture->[4] }, $node;
- undef $capture;
-
- # normal nodes
- } else{
- push @$pointer, $node;
- }
-
- ### parse any remaining tag details
- $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) };
- if (my $err = $@) {
- $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
- die $err;
- }
- $node->[2] = pos $$str_ref;
-
- ### anything that behaves as a block ending
- if ($func eq 'END' || $DIRECTIVES->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc)
- if (! @state) {
- $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 ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front
- if (defined($parent_node->[3]) && @in_view) {
- push @{ $in_view[-1] }, $parent_node;
- } else {
- push @blocks, $parent_node;
- }
- if ($pointer->[-1] && ! $pointer->[-1]->[6]) {
- splice(@$pointer, -1, 1, ());
- }
- } elsif ($parent_node->[0] eq 'VIEW') {
- my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }};
- unshift @{ $parent_node->[3] }, $ref;
- } elsif ($DIRECTIVES->{$parent_node->[0]}->[5]) { # allow no_interp to turn on and off
- $self->{'_no_interp'}--;
- }
-
- ### continuation block - such as an elsif
- } else {
- push @state, $node;
- $pointer = $node->[4] ||= [];
- }
-
- ### handle block directives
- } elsif ($DIRECTIVES->{$func}->[2] && ! $post_op) {
- push @state, $node;
- $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node
- push @in_view, [] if $func eq 'VIEW';
- $self->{'_no_interp'}++ if $DIRECTIVES->{$node->[0]}->[5] # allow no_interp to turn on and off
-
- } elsif ($func eq 'TAGS') {
- ($START, $END) = @{ $node->[3] };
-
- ### allow for one more closing tag of the old style
- if ($$str_ref =~ m{ \G ([+~=-]?) $self->{'_end_tag'} }gcxs) {
- $post_chomp = $1 || $self->{'POST_CHOMP'};
- $post_chomp =~ y/-=~+/1230/ if $post_chomp;
- $continue = 0;
- $post_op = 0;
- $self->{'_end_tag'} = $END; # need to keep track so parse_expr knows when to stop
- next;
- }
- $self->{'_end_tag'} = $END;
-
- } elsif ($func eq 'META') {
- unshift @meta, %{ $node->[3] }; # first defined win
- $node->[3] = undef; # only let these be defined once - at the front of the tree
- }
-
- ### allow for bare variable getting and setting
- } elsif (defined(my $var = $self->parse_expr($str_ref))) {
- if ($post_op && $self->{'SEMICOLONS'}) {
- $self->throw('parse', "Missing semi-colon with SEMICOLONS => 1", undef, $node->[1]);
- }
- push @$pointer, $node;
- if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? (?! [+=~-]? $END) \s* $QR_COMMENTS }gcx) {
- $node->[0] = 'SET';
- $node->[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;
- }
- $node->[2] = pos $$str_ref;
- }
-
- ### look for the closing tag
- if ($$str_ref =~ m{ \G (?: ; \s* $QR_COMMENTS)? ([+=~-]?) $END }gcxs) {
- $post_chomp = $1 || $self->{'POST_CHOMP'};
- $post_chomp =~ y/-=~+/1230/ if $post_chomp;
- $continue = 0;
- $post_op = 0;
- next;
- }
-
- ### semi-colon = end of statement - we will need to continue parsing this tag
- if ($$str_ref =~ m{ \G ; \s* $QR_COMMENTS }gcxo) {
- $post_op = 0;
-
- ### we are flagged to start capturing the output of the next directive - set it up
- } elsif ($node->[6]) {
- $post_op = 0;
- $capture = $node;
-
- ### allow next directive to be post-operative (or not)
- } else {
- $post_op = $node;
- }
-
- ### no closing tag yet - no need to get an opening tag on next loop
- $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref)) if $continue == pos $$str_ref;
- $continue = pos $$str_ref;
- }
-
- ### cleanup the tree
- unshift(@tree, @blocks) if @blocks;
- unshift(@tree, ['META', 0, 0, {@meta}]) if @meta;
- $self->throw('parse', "Missing END directive", $state[-1], pos($$str_ref)) if @state > 0;
-
- ### pull off the last text portion - if any
- if (pos($$str_ref) != length($$str_ref)) {
- my $text = substr $$str_ref, pos($$str_ref);
- 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_tree_hte {
- require CGI::Ex::Template::HTE;
- &CGI::Ex::Template::HTE::parse_tree_hte;
-}
-
-sub parse_expr {
- my $self = shift;
- my $str_ref = shift;
- my $ARGS = shift || {};
- my $is_aq = $ARGS->{'auto_quote'} ? 1 : 0;
- my $mark = pos $$str_ref;
-
- ### allow for custom auto_quoting (such as hash constructors)
- if ($is_aq) {
- if ($$str_ref =~ m{ \G $ARGS->{'auto_quote'} }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 (.*?) (?<!\\) \Q$quote\E \s* $QR_COMMENTS }gcxs
- || $self->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 (.*?) (?<! \\) / ([msixeg]*) \s* $QR_COMMENTS }gcxos
- || $self->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 (.*?) (?<! \\) $quote \s* $QR_COMMENTS }gcxs
- || $self->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{ (?: ^ | (?<!\\)) (\$\w+ | \$\{ .*? (?<!\\) \}) }x, $str) # autoquoted items get a single $\w+ - no nesting
- : split(m{ (?: ^ | (?<!\\)) (\$\w+ (?:\.\w+)* | \$\{ .*? (?<!\\) \}) }x, $str);
- my $n = 0;
- foreach my $piece (@pieces) {
- $piece =~ s/\\\$/\$/g;
- $piece =~ s/\\//g;
- next if ! ($n++ % 2);
- next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
- && $piece !~ m{ ^ \$\{ \s* (.*?) (?<!\\) \} $ }x;
- my $name = $1;
- $name =~ s/\\\}/\}/g;
- $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, [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;
- }