###----------------------------------------------------------------###
# See the perldoc in CGI/Ex/Template.pod
-# Copyright 2006 - Paul Seamons #
+# Copyright 2007 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
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
);
BEGIN {
- $VERSION = '2.00';
+ $VERSION = '2.08';
$PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
$PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
$PACKAGE_STASH = 'CGI::Ex::Template::_Stash';
$PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle';
- $TAGS ||= {
+ $TAGS = {
default => ['[%', '%]'], # default
template => ['[%', '%]'], # default
metatext => ['%%', '%%'], # Text::MetaText
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; 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,
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] } },
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],
$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};
};
###----------------------------------------------------------------###
} 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
}
}
### 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;
$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;
}
###----------------------------------------------------------------###
-sub parse_variable {
+sub parse_expr {
my $self = shift;
my $str_ref = shift;
my $ARGS = shift || {};
} 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;
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]) {
} 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;
}
} 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;
}
### 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;
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)");
}
### 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 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 unary operator precedence
- if ($has_unary && (($OP_BINARY->{$op} || $OP_TRINARY->{$op})->[1] < $OP_UNARY->{$has_unary}->[1])) {
+ ### 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];
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
}
}
- ### 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
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) {
}
}
- ### 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");
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 {
} 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");
}
###----------------------------------------------------------------###
-sub get_variable {
+sub play_expr {
### allow for the parse tree to store literals
return $_[1] if ! ref $_[1];
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;
}
}
### 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]) {
### 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;
### 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
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;
### 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;
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 {
### 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;
}
}
}
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);
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} ||= {};
}
} 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) {
+
+ ### 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;
+ }
+ }
- ### vivify the chained levels
- while (defined $ref && $#$var > $i) {
+ ### 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->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";
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;
} 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;
### 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;
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;
}
###----------------------------------------------------------------###
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");
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 {
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);
}
}
sub parse_DUMP {
my ($self, $tag_ref) = @_;
- my $ref = $self->parse_variable($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->get_variable($ident));
+ $out = Data::Dumper::Dumper($self->play_expr($ident));
$var = $info->{'text'};
$var =~ s/^[+\-~=]?\s*DUMP\s+//;
$var =~ s/\s*[+\-~=]?$//;
$name = $1;
}
- my $filter = $self->parse_variable($tag_ref);
+ my $filter = $self->parse_expr($tag_ref);
$filter = '' if ! defined $filter;
return [$name, $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];
}
### 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$/) {
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);
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);
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);
}
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 ];
$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 {
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;
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;
}
### 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});
### 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
}
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;
}
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
$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);
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
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;
}
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];
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);
}
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
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;
pop @var; # remove the trailing '.'
### look for a plugin_base
- my $base = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
- my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
- : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
- : "${base}::${module}";
- my $require = "$package.pm";
- $require =~ s|::|/|g;
-
- ### try and load the module - fall back to bare module if allowed
+ my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
my $obj;
- if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
- my $shape = $package->load;
- my $context = $self->context;
- my @args = $args ? @{ $self->vivify_args($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]) : []);
- } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
- foreach my $package (@packages) {
- my $require = "$package.pm";
- $require =~ s|::|/|g;
- eval {require $require} || next;
+
+ foreach my $base (ref($BASE) eq 'ARRAY' ? @$BASE : $BASE) {
+ my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
+ : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
+ : "${base}::${module}";
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+
+ ### try and load the module - fall back to bare module if allowed
+ if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
my $shape = $package->load;
my $context = $self->context;
- my @args = $args ? @{ $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) } : ();
- $obj = $module->new(@args);
+ } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
+ $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($args->[0]) : []);
+ } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
+ foreach my $package (@packages) {
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+ eval {require $require} || next;
+ my $shape = $package->load;
+ my $context = $self->context;
+ my @args = $args ? map { $self->play_expr($_) } @$args : ();
+ $obj = $shape->new($context, @args);
+ }
+ } elsif ($self->{'LOAD_PERL'}) {
+ my $require = "$module.pm";
+ $require =~ s|::|/|g;
+ if (eval {require $require}) {
+ my @args = $args ? map { $self->play_expr($_) } @$args : ();
+ $obj = $module->new(@args);
+ }
}
}
if (! defined $obj) {
my $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) };
};
}
-### 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);
return 1;
}
+sub vmethod_as_scalar {
+ my $str = shift; $str = '' if ! defined $str;
+ my $pat = shift; $pat = '%s' if ! defined $pat;
+ local $^W;
+ return @_ ? sprintf($pat, $_[0], $str)
+ : sprintf($pat, $str);
+}
+
+sub vmethod_as_list {
+ my $ref = shift || return '';
+ my $pat = shift; $pat = '%s' if ! defined $pat;
+ my $sep = shift; $sep = ' ' if ! defined $sep;
+ local $^W;
+ return @_ ? join($sep, map {sprintf $pat, $_[0], $_} @$ref)
+ : join($sep, map {sprintf $pat, $_} @$ref);
+}
+
+sub vmethod_as_hash {
+ my $ref = shift || return '';
+ my $pat = shift; $pat = "%s\t%s" if ! defined $pat;
+ my $sep = shift; $sep = "\n" if ! defined $sep;
+ local $^W;
+ return ! @_ ? join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref)
+ : @_ == 1 ? join($sep, map {sprintf $pat, $_[0], $_, $ref->{$_}} sort keys %$ref) # don't get to pick - it applies to the key
+ : join($sep, map {sprintf $pat, $_[0], $_, $_[1], $ref->{$_}} sort keys %$ref);
+}
+
sub vmethod_chunk {
my $str = shift;
my $size = shift || 1;
sub vmethod_format {
my $str = shift; $str = '' if ! defined $str;
my $pat = shift; $pat = '%s' if ! defined $pat;
- return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
+ if (@_) {
+ return join "\n", map{ sprintf $pat, $_[0], $_ } split(/\n/, $str);
+ } else {
+ return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
+ }
}
sub vmethod_match {
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_tree(\$str));
+}
+
+sub dump_parse_expr {
+ my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
+ my $str = shift;
+ require Data::Dumper;
+ return Data::Dumper::Dumper($obj->parse_expr(\$str));
}
###----------------------------------------------------------------###
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;
projects / chaz / p5-CGI-Ex / blobdiff