X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FCGI%2FEx%2FTemplate.pm;h=773000cb1a8cf7442d276d2f383bf6fd9a907245;hb=83f0c6a9aaf9bc520cef93b958d51a5d85e8999c;hp=a2859027aee1f1de70c9b3d0cf3b673c5af3ee11;hpb=4eee158dce82376f2f37de29d91c53f60a24aebe;p=chaz%2Fp5-CGI-Ex diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index a285902..773000c 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -10,21 +10,24 @@ use strict; use constant trace => $ENV{'CET_TRACE'} || 0; # enable for low level tracing use vars qw($VERSION $TAGS - $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS + $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS $VOBJS $DIRECTIVES $QR_DIRECTIVE $OPERATORS - $OP_UNARY - $OP_BINARY - $OP_TRINARY $OP_DISPATCH + $OP_ASSIGN + $OP + $OP_PREFIX + $OP_POSTFIX + $OP_TERNARY $QR_OP - $QR_OP_UNARY - $QR_OP_PARENED + $QR_OP_PREFIX + $QR_OP_ASSIGN $QR_COMMENTS $QR_FILENAME + $QR_NUM $QR_AQ_NOTDOT $QR_AQ_SPACE $QR_PRIVATE @@ -36,7 +39,7 @@ use vars qw($VERSION ); BEGIN { - $VERSION = '2.00'; + $VERSION = '2.06'; $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception'; $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator'; @@ -44,7 +47,7 @@ BEGIN { $PACKAGE_STASH = 'CGI::Ex::Template::_Stash'; $PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle'; - $TAGS ||= { + $TAGS = { default => ['[%', '%]'], # default template => ['[%', '%]'], # default metatext => ['%%', '%%'], # Text::MetaText @@ -55,19 +58,26 @@ BEGIN { html => [''], # HTML comments }; - $SCALAR_OPS ||= { + $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; $_ }, 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, @@ -82,25 +92,29 @@ BEGIN { uri => \&vmethod_uri, }; - $FILTER_OPS ||= { # generally - non-dynamic filters belong in scalar ops + $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 ||= { + $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 { my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} }, + 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] } }, @@ -111,24 +125,40 @@ BEGIN { unshift => sub { my $ref = shift; unshift @$ref, @_; return '' }, }; - $HASH_OPS ||= { + $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]] }, - pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } keys %{ $_[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 + #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], @@ -175,68 +205,83 @@ BEGIN { $QR_DIRECTIVE = qr{ ^ (\w+|\|) (?= $|[\s;\#]) }x; ### setup the operator parsing - $OPERATORS ||= [ - # name => # order, precedence, symbols, only_in_parens, sub to create - [2, 96, ['**', '^', 'pow'], 0, sub { $_[0] ** $_[1] } ], - [1, 93, ['!'], 0, sub { ! $_[0] } ], - [1, 93, ['-'], 0, sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], - [2, 90, ['*'], 0, sub { $_[0] * $_[1] } ], - [2, 90, ['/'], 0, sub { $_[0] / $_[1] } ], - [2, 90, ['div', 'DIV'], 0, sub { int($_[0] / $_[1]) } ], - [2, 90, ['%', 'mod', 'MOD'], 0, sub { $_[0] % $_[1] } ], - [2, 85, ['+'], 0, sub { $_[0] + $_[1] } ], - [2, 85, ['-'], 0, sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], - [2, 85, ['_', '~'], 0, sub { join "", @_ } ], - [2, 80, ['<'], 0, sub { $_[0] < $_[1] } ], - [2, 80, ['>'], 0, sub { $_[0] > $_[1] } ], - [2, 80, ['<='], 0, sub { $_[0] <= $_[1] } ], - [2, 80, ['>='], 0, sub { $_[0] >= $_[1] } ], - [2, 80, ['lt'], 0, sub { $_[0] lt $_[1] } ], - [2, 80, ['gt'], 0, sub { $_[0] gt $_[1] } ], - [2, 80, ['le'], 0, sub { $_[0] le $_[1] } ], - [2, 80, ['ge'], 0, sub { $_[0] ge $_[1] } ], - [2, 75, ['==', 'eq'], 0, sub { $_[0] eq $_[1] } ], - [2, 75, ['!=', 'ne'], 0, sub { $_[0] ne $_[1] } ], - [2, 70, ['&&'], 0, undef ], - [2, 65, ['||'], 0, undef ], - [2, 60, ['..'], 0, sub { $_[0] .. $_[1] } ], - [3, 55, ['?', ':'], 0, undef ], - [2, 52, ['='], 1, undef ], - [1, 50, ['not', 'NOT'], 0, sub { ! $_[0] } ], - [2, 45, ['and', 'AND'], 0, undef ], - [2, 40, ['or', 'OR'], 0, undef ], - [0, 0, ['hash'], 0, sub { return {@_}; } ], - [0, 0, ['array'], 0, sub { return [@_] } ], + $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_DISPATCH ||= {map {my $ref = $_; map {$_ => $ref->[4]} @{$ref->[2]}} @$OPERATORS}; - $OP_UNARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 1} @$OPERATORS}; - $OP_BINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 2} @$OPERATORS}; - $OP_TRINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 3} @$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 sub _op_qr { # no mixed \w\W operators my %used; - my $chrs = join '|', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_; - my $chr = join '', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_; - my $word = join '|', grep {++$used{$_} < 2} grep {/^\w+$/} @_; + 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(sort map {@{ $_->[2] }} grep {$_->[0] > 1 && ! $_->[3]} @$OPERATORS) } # all binary, trinary, non-parened ops - sub _build_op_qr_unary { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] == 1 } @$OPERATORS) } # unary operators - sub _build_op_qr_paren { _op_qr(sort map {@{ $_->[2] }} grep { $_->[3]} @$OPERATORS) } # paren - $QR_OP ||= _build_op_qr(); - $QR_OP_UNARY ||= _build_op_qr_unary(); - $QR_OP_PARENED ||= _build_op_qr_paren(); - + 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/^_/; + $QR_PRIVATE = qr/^_/; - $WHILE_MAX ||= 1000; + $WHILE_MAX = 1000; $EXTRA_COMPILE_EXT = '.sto'; + + eval {require Scalar::Util}; }; ###----------------------------------------------------------------### @@ -609,7 +654,7 @@ sub parse_tree { } elsif ($func eq 'META') { my $args = $self->parse_args(\$tag); my $hash; - if (($hash = $self->vivify_args($args)->[-1]) + if (($hash = $self->play_expr($args->[-1])) && UNIVERSAL::isa($hash, 'HASH')) { unshift @meta, %$hash; # first defined win } @@ -628,11 +673,11 @@ sub parse_tree { } ### allow for bare variable getting and setting - } elsif (defined(my $var = $self->parse_variable(\$tag))) { + } elsif (defined(my $var = $self->parse_expr(\$tag))) { push @$pointer, $node; - if ($tag =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) { + if ($tag =~ s{ ^ ($QR_OP_ASSIGN) >? \s* $QR_COMMENTS }{}ox) { $node->[0] = 'SET'; - $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, \$tag, $node, $var) }; + $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; @@ -677,8 +722,14 @@ sub parse_tree { $node->[2] = $continue; $post_op = $node; - } else { # error - $self->throw('parse', "Found trailing info \"$tag\"", $node) if length $tag; + ### 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; } @@ -741,7 +792,7 @@ sub execute_tree { ###----------------------------------------------------------------### -sub parse_variable { +sub parse_expr { my $self = shift; my $str_ref = shift; my $ARGS = shift || {}; @@ -757,29 +808,46 @@ sub parse_variable { } 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_variable(\$name); + return $self->parse_expr(\$name); } } my $copy = $$str_ref; # copy while parsing to allow for errors - ### test for leading unary operators - my $has_unary; - if ($copy =~ s{ ^ ($QR_OP_UNARY) \s* $QR_COMMENTS }{}ox) { + ### 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 - $has_unary = $1; + 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 - if ($copy =~ s{ ^ ( (?:\d*\.\d+ | \d+) ) \s* $QR_COMMENTS }{}ox) { + } 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; @@ -807,7 +875,7 @@ sub parse_variable { next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x; my $name = $1; - $piece = $self->parse_variable(\$name); + $piece = $self->parse_expr(\$name); } @pieces = grep {defined && length} @pieces; if (@pieces == 1 && ! ref $pieces[0]) { @@ -831,13 +899,13 @@ sub parse_variable { } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) { my $name = $1; - push @var, $self->parse_variable(\$name); + 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_variable(\$copy))) { + while (defined(my $var = $self->parse_expr(\$copy))) { push @$arrayref, $var; $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox; } @@ -849,9 +917,9 @@ sub parse_variable { } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) { local $self->{'_operator_precedence'} = 0; # reset precedence my $hashref = ['hash']; - while (defined(my $key = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) { + 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_variable(\$copy); + my $val = $self->parse_expr(\$copy); push @$hashref, $key, $val; $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox; } @@ -862,7 +930,7 @@ sub parse_variable { ### looks like a paren grouper } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) { local $self->{'_operator_precedence'} = 0; # reset precedence - my $var = $self->parse_variable(\$copy, {allow_parened_ops => 1}); + 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; @@ -894,10 +962,13 @@ sub parse_variable { if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) { my $name = $1; - my $var = $self->parse_variable(\$name); + my $var = $self->parse_expr(\$name); push @var, $var; - } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) { + + ### 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)"); } @@ -917,22 +988,29 @@ sub parse_variable { ### flatten literals and constants as much as possible my $var = ($is_literal && $#var == 1) ? ${ $var[0] } - : $is_namespace ? $self->get_variable(\@var, {is_namespace_during_compile => 1}) + : $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 - || ($ARGS->{'allow_parened_ops'} - && $copy =~ s{ ^ ($QR_OP_PARENED) \s* $QR_COMMENTS }{}ox) ) { + 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; - my $var2 = $self->parse_variable(\$copy); + my $op = $1; - ### allow for unary operator precedence - if ($has_unary && (($OP_BINARY->{$op} || $OP_TRINARY->{$op})->[1] < $OP_UNARY->{$has_unary}->[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]; @@ -943,14 +1021,14 @@ sub parse_variable { undef $tree; undef $found; } - $var = [ \ [ $has_unary, $var ], 0 ]; - undef $has_unary; + $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); - my $ref = $OP_BINARY->{$op} || $OP_TRINARY->{$op}; - $found->{$op} = $ref->[1]; + $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op} } ### if we found operators - tree the nodes by operator precedence @@ -964,9 +1042,9 @@ sub parse_variable { } } - ### allow for unary on non-chained variables - if ($has_unary) { - $var = [ \ [ $has_unary, $var ], 0 ]; + ### allow for prefix on non-chained variables + if ($has_prefix) { + $var = [ \ [ $_, $var ], 0 ] for reverse @$has_prefix; } $$str_ref = $copy; # commit the changes @@ -980,26 +1058,26 @@ sub apply_precedence { my @var; my $trees; ### look at the operators we found in the order we found them - for my $op (sort {$found->{$a} <=> $found->{$b}} keys %$found) { - local $found->{$op}; - delete $found->{$op}; - my @trees; - my @trinary; - - ### split the array on the current operator - for (my $i = 0; $i <= $#$tree; $i ++) { - my $is_trinary = $OP_TRINARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP_TRINARY->{$op}->[2] }; - next if $tree->[$i] ne $op && ! $is_trinary; - push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator - push @trinary, $tree->[0] if $is_trinary; - shift @$tree; # pull off the operator + 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 ! @trees; # this iteration didn't have the current operator - push @trees, $tree if scalar @$tree; # elements after last operator + next if ! @exprs; # this iteration didn't have the current operator + push @exprs, $tree if scalar @$tree; # add on any remaining items - ### now - for this level split on remaining operators, or add the variable to the tree - for my $node (@trees) { + ### simplify sub expressions + for my $node (@exprs) { if (@$node == 1) { $node = $node->[0]; # single item - its not a tree } elsif (@$node == 3) { @@ -1009,30 +1087,48 @@ sub apply_precedence { } } - ### return binary - if ($OP_BINARY->{$op}) { - my $val = $trees[-1]; - $val = [ \ [ $op, $trees[$_], $val ], 0 ] for reverse (0 .. $#trees - 1); # reverse order - helps out || - return $val; - } + ### assemble this current level - ### return simple trinary - if (@trinary == 2) { - return [ \ [ $op, @trees ], 0 ]; - } + ### 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 - ### reorder complex trinary - rare case - while ($#trinary >= 1) { - ### if we look starting from the back - the first lead trinary op will always be next to its matching op - for (my $i = $#trinary; $i >= 0; $i --) { - next if $OP_TRINARY->{$trinary[$i]}->[2]->[1] eq $trinary[$i]; - my ($op, $op2) = splice @trinary, $i, 2, (); # remove the pair of operators - my $node = [ \ [$op, @trees[$i .. $i + 2] ], 0 ]; - splice @trees, $i, 3, $node; + ### 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 ]; } - } - return $trees[0]; # at this point the trinary has been reduced to a single operator + + ### 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"); @@ -1049,14 +1145,14 @@ sub parse_args { my @named; while (length $$str_ref) { my $copy = $$str_ref; - if (defined(my $name = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo})) + 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_variable(\$copy); + 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_variable($str_ref))) { + } elsif (defined(my $arg = $self->parse_expr($str_ref))) { push @args, $arg; $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox; } else { @@ -1093,7 +1189,7 @@ sub interpolate_node { } elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x || $piece =~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x) { my $name = $1; - push @sub_tree, ['GET', $offset - length($piece), $offset, $self->parse_variable(\$name)]; + push @sub_tree, ['GET', $offset - length($piece), $offset, $self->parse_expr(\$name)]; } else { $self->throw('parse', "Parse error during interpolate node"); } @@ -1105,7 +1201,7 @@ sub interpolate_node { ###----------------------------------------------------------------### -sub get_variable { +sub play_expr { ### allow for the parse tree to store literals return $_[1] if ! ref $_[1]; @@ -1115,28 +1211,30 @@ sub get_variable { my $i = 0; ### determine the top level of this particular variable access - my $ref = $var->[$i++]; + my $ref; + my $name = $var->[$i++]; my $args = $var->[$i++]; - warn "get_variable: begin \"$ref\"\n" if trace; - if (ref $ref) { - if (ref($ref) eq 'SCALAR') { # a scalar literal - $ref = $$ref; - } elsif (ref($ref) eq 'REF') { # operator - return $self->play_operator($$ref) if ${ $ref }->[0] eq '..'; - $ref = $self->play_operator($$ref); + 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) - $ref = $self->get_variable($ref); - if (defined $ref) { - return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ - $ref = $self->{'_vars'}->{$ref}; + $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 $ref) { + } elsif (defined $name) { if ($ARGS->{'is_namespace_during_compile'}) { - $ref = $self->{'NAMESPACE'}->{$ref}; + $ref = $self->{'NAMESPACE'}->{$name}; } else { - return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ - $ref = $self->{'_vars'}->{$ref}; + return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _ + $ref = $self->{'_vars'}->{$name}; + $ref = $VOBJS->{$name} if ! defined $ref; } } @@ -1146,7 +1244,7 @@ sub get_variable { ### check at each point if the rurned thing was a code if (UNIVERSAL::isa($ref, 'CODE')) { - my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); + my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ()); if (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; } elsif (defined $results[1]) { @@ -1160,14 +1258,14 @@ sub get_variable { ### 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++]; - warn "get_variable: nested \"$name\"\n" if trace; + $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->get_variable($name); + $name = $self->play_expr($name); if (! defined($name) || $name =~ $QR_PRIVATE || $name =~ /^\./) { $ref = undef; last; @@ -1184,10 +1282,10 @@ sub get_variable { ### 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 ? @{ $self->vivify_args($args) } : ()); + $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 ? @{ $self->vivify_args($args) } : ()); + $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 @@ -1207,7 +1305,7 @@ sub get_variable { 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 ? @{ $self->vivify_args($args) } : ()); + ($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; @@ -1240,7 +1338,7 @@ sub get_variable { ### method calls on objects if ($was_dot_call && UNIVERSAL::can($ref, 'can')) { - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->play_expr($_) } @$args : (); my @results = eval { $ref->$name(@args) }; if ($@) { my $class = ref $ref; @@ -1262,7 +1360,7 @@ sub get_variable { if ($was_dot_call && exists($ref->{$name}) ) { $ref = $ref->{$name}; } elsif ($HASH_OPS->{$name}) { - $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + $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 { @@ -1271,10 +1369,12 @@ sub get_variable { ### array access } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if ($name =~ /^\d+$/) { - $ref = ($name > $#$ref) ? undef : $ref->[$name]; + 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 = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + $ref = undef; } } } @@ -1285,7 +1385,7 @@ sub get_variable { if (! defined $ref) { if ($self->{'_debug_undef'}) { my $chunk = $var->[$i - 2]; - $chunk = $self->get_variable($chunk) if ref($chunk) eq 'ARRAY'; + $chunk = $self->play_expr($chunk) if ref($chunk) eq 'ARRAY'; die "$chunk is undefined\n"; } else { $ref = $self->undefined_any($var); @@ -1308,11 +1408,10 @@ sub set_variable { my $args = $var->[$i++]; if (ref $ref) { if (ref($ref) eq 'ARRAY') { # named access (ie via $name.foo) - $ref = $self->get_variable($ref); + $ref = $self->play_expr($ref); if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _ if ($#$var <= $i) { - $self->{'_vars'}->{$ref} = $val; - return; + return $self->{'_vars'}->{$ref} = $val; } else { $ref = $self->{'_vars'}->{$ref} ||= {}; } @@ -1325,20 +1424,28 @@ sub set_variable { } elsif (defined $ref) { return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ if ($#$var <= $i) { - $self->{'_vars'}->{$ref} = $val; - return; + return $self->{'_vars'}->{$ref} = $val; } else { $ref = $self->{'_vars'}->{$ref} ||= {}; } } - ### let the top level thing be a code block - if (UNIVERSAL::isa($ref, 'CODE')) { - return; - } + while (defined $ref) { - ### vivify the chained levels - while (defined $ref && $#$var > $i) { + ### 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++]; @@ -1346,10 +1453,9 @@ sub set_variable { ### allow for named portions of a variable name (foo.$name.bar) if (ref $name) { if (ref($name) eq 'ARRAY') { - $name = $self->get_variable($name); + $name = $self->play_expr($name); if (! defined($name) || $name =~ /^[_.]/) { - $ref = undef; - next; + return; } } else { die "Shouldn't get a ".ref($name)." during a vivify on chain"; @@ -1359,10 +1465,14 @@ sub set_variable { return; } + ### scalar access + if (! ref $ref) { + return; + ### method calls on objects - if (UNIVERSAL::can($ref, 'can')) { + } elsif (UNIVERSAL::can($ref, 'can')) { my $lvalueish; - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->play_expr($_) } @$args : (); if ($i >= $#$var) { $lvalueish = 1; push @args, $val; @@ -1374,20 +1484,20 @@ sub set_variable { } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { - $ref = undef; + return; } return if $lvalueish; next; } - die $@ if ref $@ || $@ !~ /Can\'t locate object method/; + 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) { - $ref->{$name} = $val; - return; + return $ref->{$name} = $val; } else { $ref = $ref->{$name} ||= {}; next; @@ -1395,10 +1505,9 @@ sub set_variable { ### array access } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if ($name =~ /^\d+$/) { + if ($name =~ m{ ^ -? $QR_NUM $ }ox) { if ($#$var <= $i) { - $ref->[$name] = $val; - return; + return $ref->[$name] = $val; } else { $ref = $ref->[$name] ||= {}; next; @@ -1407,32 +1516,11 @@ sub set_variable { return; } - ### scalar access - } elsif (! ref($ref) && defined($ref)) { - return; - } - - ### check at each point if the returned thing was a code - if (defined($ref) && UNIVERSAL::isa($ref, 'CODE')) { - my @results = $ref->($args ? @{ $self->vivify_args($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; - } } } - return $ref; -} - -sub vivify_args { - my $self = shift; - my $vars = shift; - return [map {$self->get_variable($_)} @$vars]; + return; } ###----------------------------------------------------------------### @@ -1442,29 +1530,46 @@ sub play_operator { my $tree = shift; if ($OP_DISPATCH->{$tree->[0]}) { - my @args = map { $self->get_variable($tree->[$_]) } 1 .. $#$tree; local $^W; - return $OP_DISPATCH->{$tree->[0]}->(@args); + 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->get_variable($tree->[2]); + 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->get_variable($tree->[1]) || $self->get_variable($tree->[2]) || ''; + return $self->play_expr($tree->[1]) || $self->play_expr($tree->[2]) || ''; } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') { - my $var = $self->get_variable($tree->[1]) && $self->get_variable($tree->[2]); + my $var = $self->play_expr($tree->[1]) && $self->play_expr($tree->[2]); return $var ? $var : 0; } elsif ($op eq '?') { local $^W; - return $self->get_variable($tree->[1]) ? $self->get_variable($tree->[2]) : $self->get_variable($tree->[3]); + 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"); @@ -1508,12 +1613,12 @@ 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_variable($tag_ref); + return $self->parse_expr($tag_ref); } sub parse_CATCH { my ($self, $tag_ref) = @_; - return $self->parse_variable($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo}); + return $self->parse_expr($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo}); } sub play_control { @@ -1553,11 +1658,11 @@ sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) } sub play_DEFAULT { my ($self, $set) = @_; foreach (@$set) { - my ($set, $default) = @$_; + my ($op, $set, $default) = @$_; next if ! defined $set; - my $val = $self->get_variable($set); + my $val = $self->play_expr($set); if (! $val) { - $default = defined($default) ? $self->get_variable($default) : ''; + $default = defined($default) ? $self->play_expr($default) : ''; $self->set_variable($set, $default); } } @@ -1566,7 +1671,7 @@ sub play_DEFAULT { sub parse_DUMP { my ($self, $tag_ref) = @_; - my $ref = $self->parse_variable($tag_ref); + my $ref = $self->parse_expr($tag_ref); return $ref; } @@ -1577,7 +1682,7 @@ sub play_DUMP { my $out; my $var; if ($ident) { - $out = Data::Dumper::Dumper($self->get_variable($ident)); + $out = Data::Dumper::Dumper($self->play_expr($ident)); $var = $info->{'text'}; $var =~ s/^[+\-~=]?\s*DUMP\s+//; $var =~ s/\s*[+\-~=]?$//; @@ -1607,7 +1712,7 @@ sub parse_FILTER { $name = $1; } - my $filter = $self->parse_variable($tag_ref); + my $filter = $self->parse_expr($tag_ref); $filter = '' if ! defined $filter; return [$name, $filter]; @@ -1636,11 +1741,11 @@ sub play_FILTER { sub parse_FOREACH { my ($self, $tag_ref) = @_; - my $items = $self->parse_variable($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_variable($tag_ref); + $items = $self->parse_expr($tag_ref); } return [$var, $items]; } @@ -1651,7 +1756,7 @@ sub play_FOREACH { ### get the items - make sure it is an arrayref my ($var, $items) = @$ref; - $items = $self->get_variable($items); + $items = $self->play_expr($items); return '' if ! defined $items; if (ref($items) !~ /Iterator$/) { @@ -1724,26 +1829,26 @@ sub play_FOREACH { sub parse_GET { my ($self, $tag_ref) = @_; - my $ref = $self->parse_variable($tag_ref); + my $ref = $self->parse_expr($tag_ref); $self->throw('parse', "Missing variable name") if ! defined $ref; return $ref; } sub play_GET { my ($self, $ident, $node) = @_; - my $var = $self->get_variable($ident); + my $var = $self->play_expr($ident); return (! defined $var) ? $self->undefined_get($ident, $node) : $var; } sub parse_IF { my ($self, $tag_ref) = @_; - return $self->parse_variable($tag_ref); + return $self->parse_expr($tag_ref); } sub play_IF { my ($self, $var, $node, $out_ref) = @_; - my $val = $self->get_variable($var); + my $val = $self->play_expr($var); if ($val) { my $body_ref = $node->[4] ||= []; $self->execute_tree($body_ref, $out_ref); @@ -1757,7 +1862,7 @@ sub play_IF { return; } my $var = $node->[3]; - my $val = $self->get_variable($var); + my $val = $self->play_expr($var); if ($val) { my $body_ref = $node->[4] ||= []; $self->execute_tree($body_ref, $out_ref); @@ -1792,7 +1897,7 @@ sub play_INSERT { my ($names, $args) = @$var; foreach my $name (@$names) { - my $filename = $self->get_variable($name); + my $filename = $self->play_expr($name); $$out_ref .= $self->_insert($filename); } @@ -1803,7 +1908,7 @@ sub parse_MACRO { my ($self, $tag_ref, $node) = @_; my $copy = $$tag_ref; - my $name = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}); + my $name = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}); $self->throw('parse', "Missing macro name") if ! defined $name; if (! ref $name) { $name = [ $name, 0 ]; @@ -1833,7 +1938,8 @@ sub play_MACRO { $sub_tree = $sub_tree->[0]->[4]; } - my $self_copy = $self->weak_copy; + my $self_copy = $self; + eval {require Scalar::Util; Scalar::Util::weaken($self_copy)}; ### install a closure in the stash that will handle the macro $self->set_variable($name, sub { @@ -1921,7 +2027,7 @@ sub play_PERL { sub parse_PROCESS { my ($self, $tag_ref) = @_; my $info = [[], []]; - while (defined(my $filename = $self->parse_variable($tag_ref, { + while (defined(my $filename = $self->parse_expr($tag_ref, { auto_quote => qr{ ^ ($QR_FILENAME | \w+ (?: :\w+)* ) $QR_AQ_SPACE }xo, }))) { push @{$info->[0]}, $filename; @@ -1932,13 +2038,13 @@ sub parse_PROCESS { while (length $$tag_ref) { last if $$tag_ref =~ / ^ (\w+) (?: ;|$|\s)/x && $DIRECTIVES->{$1}; ### looks like a directive - we are done - my $var = $self->parse_variable($tag_ref); + my $var = $self->parse_expr($tag_ref); last if ! defined $var; if ($$tag_ref !~ s{ ^ = >? \s* }{}x) { $self->throw('parse.missing.equals', 'Missing equals while parsing args'); } - my $val = $self->parse_variable($tag_ref); + my $val = $self->parse_expr($tag_ref); push @{$info->[1]}, [$var, $val]; $$tag_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox if $val; } @@ -1954,7 +2060,7 @@ sub play_PROCESS { ### set passed args foreach (@$args) { my ($key, $val) = @$_; - $val = $self->get_variable($val); + $val = $self->play_expr($val); if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever foreach my $key (keys %$val) { $self->set_variable([$key,0], $val->{$key}); @@ -1967,7 +2073,7 @@ sub play_PROCESS { ### iterate on any passed block or filename foreach my $ref (@$files) { next if ! defined $ref; - my $filename = $self->get_variable($ref); + my $filename = $self->play_expr($ref); my $out = ''; # have temp item to allow clear to correctly clear ### normal blocks or filenames @@ -2042,35 +2148,40 @@ sub play_RAWPERL { } sub parse_SET { - my ($self, $tag_ref, $node, $initial_var) = @_; + my ($self, $tag_ref, $node, $initial_op, $initial_var) = @_; my @SET; my $copy = $$tag_ref; my $func; + + if ($initial_op) { + if ($$tag_ref =~ $QR_DIRECTIVE # find a word + && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing + $node->[6] = 1; # set a flag to keep parsing + my $val = $node->[4] ||= []; # setup storage + return [[$initial_op, $initial_var, $val]]; + } else { # get a normal variable + return [[$initial_op, $initial_var, $self->parse_expr($tag_ref)]]; + } + } + while (length $$tag_ref) { - my $set; - my $get_val; - my $val; - if ($initial_var) { - $set = $initial_var; - undef $initial_var; - $get_val = 1; + my $set = $self->parse_expr($tag_ref); + last if ! defined $set; + + if ($$tag_ref =~ s{ ^ ($QR_OP_ASSIGN) >? \s* }{}x) { + my $op = $1; + if ($$tag_ref =~ $QR_DIRECTIVE # find a word + && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing + $node->[6] = 1; # set a flag to keep parsing + my $val = $node->[4] ||= []; # setup storage + push @SET, [$op, $set, $val]; + last; + } else { # get a normal variable + push @SET, [$op, $set, $self->parse_expr($tag_ref)]; + } } else { - $set = $self->parse_variable($tag_ref); - last if ! defined $set; - $get_val = $$tag_ref =~ s{ ^ = >? \s* }{}x; - } - if (! $get_val) { # no next val - $val = undef; - } elsif ($$tag_ref =~ $QR_DIRECTIVE # find a word - && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing - $node->[6] = 1; # set a flag to keep parsing - $val = $node->[4] ||= []; # setup storage - push @SET, [$set, $val]; - last; - } else { # get a normal variable - $val = $self->parse_variable($tag_ref); + push @SET, ['=', $set, undef]; } - push @SET, [$set, $val]; } return \@SET; } @@ -2078,7 +2189,7 @@ sub parse_SET { sub play_SET { my ($self, $set, $node) = @_; foreach (@$set) { - my ($set, $val) = @$_; + my ($op, $set, $val) = @$_; if (! defined $val) { # not defined $val = ''; } elsif ($node->[4] && $val == $node->[4]) { # a captured directive @@ -2087,7 +2198,12 @@ sub play_SET { $val = ''; $self->execute_tree($sub_tree, \$val); } else { # normal var - $val = $self->get_variable($val); + $val = $self->play_expr($val); + } + + if ($OP_DISPATCH->{$op}) { + local $^W; + $val = $OP_DISPATCH->{$op}->($self->play_expr($set), $val); } $self->set_variable($set, $val); @@ -2100,7 +2216,7 @@ sub parse_SWITCH { $DIRECTIVES->{'GET'}->[0]->(@_) } sub play_SWITCH { my ($self, $var, $node, $out_ref) = @_; - my $val = $self->get_variable($var); + my $val = $self->play_expr($var); $val = '' if ! defined $val; ### $node->[4] is thrown away @@ -2112,14 +2228,14 @@ sub play_SWITCH { next; } - my $val2 = $self->get_variable($var); + my $val2 = $self->play_expr($var); $val2 = [$val2] if ! UNIVERSAL::isa($val2, 'ARRAY'); for my $test (@$val2) { # find matching values next if ! defined $val && defined $test; next if defined $val && ! defined $test; if ($val ne $test) { # check string-wise first - then numerical - next if $val !~ /^ -? (?: \d*\.\d+ | \d+) $/x; - next if $test !~ /^ -? (?: \d*\.\d+ | \d+) $/x; + next if $val !~ m{ ^ -? $QR_NUM $ }ox; + next if $test !~ m{ ^ -? $QR_NUM $ }ox; next if $val != $test; } @@ -2138,7 +2254,7 @@ sub play_SWITCH { sub parse_THROW { my ($self, $tag_ref, $node) = @_; - my $name = $self->parse_variable($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo}); + my $name = $self->parse_expr($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo}); $self->throw('parse.missing', "Missing name in THROW", $node) if ! $name; my $args = $self->parse_args($tag_ref); return [$name, $args]; @@ -2147,8 +2263,8 @@ sub parse_THROW { sub play_THROW { my ($self, $ref, $node) = @_; my ($name, $args) = @$ref; - $name = $self->get_variable($name); - my @args = $args ? @{ $self->vivify_args($args) } : (); + $name = $self->play_expr($name); + my @args = $args ? map { $self->play_expr($_) } @$args : (); $self->throw($name, \@args, $node); } @@ -2186,7 +2302,7 @@ sub play_TRY { next; } next if ! $err; - my $name = $self->get_variable($node->[3]); + my $name = $self->play_expr($node->[3]); $name = '' if ! defined $name || lc($name) eq 'default'; if ($type =~ / ^ \Q$name\E \b /x && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins @@ -2230,14 +2346,14 @@ sub parse_USE { my $var; my $copy = $$tag_ref; - if (defined(my $_var = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo})) + if (defined(my $_var = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo})) && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) { $var = $_var; $$tag_ref = $copy; } $copy = $$tag_ref; - my $module = $self->parse_variable(\$copy, {auto_quote => qr{ ^ (\w+ (?: (?:\.|::) \w+)*) $QR_AQ_NOTDOT }xo}); + my $module = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+ (?: (?:\.|::) \w+)*) $QR_AQ_NOTDOT }xo}); $self->throw('parse', "Missing plugin name while parsing $$tag_ref") if ! defined $module; $module =~ s/\./::/g; @@ -2275,10 +2391,10 @@ sub play_USE { if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) { my $shape = $package->load; my $context = $self->context; - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->play_expr($_) } @$args : (); $obj = $shape->new($context, @args); } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine) - $obj = $PACKAGE_ITERATOR->new($args ? $self->get_variable($args->[0]) : []); + $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($args->[0]) : []); } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) { foreach my $package (@packages) { my $require = "$package.pm"; @@ -2286,14 +2402,14 @@ sub play_USE { eval {require $require} || next; my $shape = $package->load; my $context = $self->context; - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->play_expr($_) } @$args : (); $obj = $shape->new($context, @args); } } elsif ($self->{'LOAD_PERL'}) { my $require = "$module.pm"; $require =~ s|::|/|g; if (eval {require $require}) { - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->play_expr($_) } @$args : (); $obj = $module->new(@args); } } @@ -2318,7 +2434,7 @@ sub play_WHILE { my $count = $WHILE_MAX; while (--$count > 0) { - $self->get_variable($var) || last; + $self->play_expr($var) || last; ### execute the sub tree eval { $self->execute_tree($sub_tree, $out_ref) }; @@ -2665,20 +2781,6 @@ sub list_plugins { }; } -### get a copy of self without circular refs for use in closures -sub weak_copy { - my $self = shift; - my $self_copy; - if (eval { require Scalar::Util } - && defined &Scalar::Util::weaken) { - $self_copy = $self; - Scalar::Util::weaken($self_copy); - } else { - $self_copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on old perls (pre 5.8) - } - return $self_copy; -} - sub debug_node { my ($self, $node) = @_; my $info = $self->node_info($node); @@ -2745,6 +2847,29 @@ sub define_vmethod { return 1; } +sub vmethod_as_scalar { + my ($str, $pat) = @_; + $pat = '%s' if ! defined $pat; + local $^W; + return sprintf $pat, $str; +} + +sub vmethod_as_list { + my ($ref, $pat, $sep) = @_; + $pat = '%s' if ! defined $pat; + $sep = ' ' if ! defined $sep; + local $^W; + return join($sep, map {sprintf $pat, $_} @$ref); +} + +sub vmethod_as_hash { + my ($ref, $pat, $sep) = @_; + $pat = "%s\t%s" if ! defined $pat; + $sep = "\n" if ! defined $sep; + local $^W; + return join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref); +} + sub vmethod_chunk { my $str = shift; my $size = shift || 1; @@ -2892,7 +3017,7 @@ sub dump_parse { my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new; my $str = shift; require Data::Dumper; - return Data::Dumper::Dumper($obj->parse_variable(\$str)); + return Data::Dumper::Dumper($obj->parse_expr(\$str)); } ###----------------------------------------------------------------### @@ -3101,16 +3226,16 @@ sub get { my ($self, $var) = @_; if (! ref $var) { if ($var =~ /^\w+$/) { $var = [$var, 0] } - else { $var = $self->_template->parse_variable(\$var, {no_dots => 1}) } + else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) } } - return $self->_template->get_variable($var, {no_dots => 1}); + return $self->_template->play_expr($var, {no_dots => 1}); } sub set { my ($self, $var, $val) = @_; if (! ref $var) { if ($var =~ /^\w+$/) { $var = [$var, 0] } - else { $var = $self->_template->parse_variable(\$var, {no_dots => 1}) } + else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) } } $self->_template->set_variable($var, $val, {no_dots => 1}); return $val;