###----------------------------------------------------------------###
# See the perldoc in CGI/Ex/Template.pod
-# Copyright 2006 - Paul Seamons #
+# Copyright 2007 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
);
BEGIN {
- $VERSION = '2.02';
+ $VERSION = '2.08';
$PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
$PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
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; $_ },
$LIST_OPS = {
as => \&vmethod_as_list,
first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
+ fmt => \&vmethod_as_list,
grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
hash => sub { local $^W; my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
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} },
### setup the operator parsing
$OPERATORS = [
# type precedence symbols action (undef means play_operator will handle)
+ ['postfix', 99, ['++'], undef ],
+ ['postfix', 99, ['--'], undef ],
['prefix', 98, ['++'], undef ],
['prefix', 98, ['--'], undef ],
- ['postfix', 98, ['++'], undef ],
- ['postfix', 98, ['--'], undef ],
- ['infix', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ],
+ ['right', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ],
['prefix', 93, ['!'], sub { ! $_[0] } ],
['prefix', 93, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
- ['infix', 90, ['*'], sub { $_[0] * $_[1] } ],
- ['infix', 90, ['/'], sub { $_[0] / $_[1] } ],
- ['infix', 90, ['div', 'DIV'], sub { int($_[0] / $_[1]) } ],
- ['infix', 90, ['%', 'mod', 'MOD'], sub { $_[0] % $_[1] } ],
- ['infix', 85, ['+'], sub { $_[0] + $_[1] } ],
- ['infix', 85, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
- ['infix', 85, ['~', '_'], sub { join "", @_ } ],
- ['infix', 80, ['<'], sub { $_[0] < $_[1] } ],
- ['infix', 80, ['>'], sub { $_[0] > $_[1] } ],
- ['infix', 80, ['<='], sub { $_[0] <= $_[1] } ],
- ['infix', 80, ['>='], sub { $_[0] >= $_[1] } ],
- ['infix', 80, ['lt'], sub { $_[0] lt $_[1] } ],
- ['infix', 80, ['gt'], sub { $_[0] gt $_[1] } ],
- ['infix', 80, ['le'], sub { $_[0] le $_[1] } ],
- ['infix', 80, ['ge'], sub { $_[0] ge $_[1] } ],
- ['infix', 75, ['==', 'eq'], sub { $_[0] eq $_[1] } ],
- ['infix', 75, ['!=', 'ne'], sub { $_[0] ne $_[1] } ],
- ['infix', 70, ['&&'], undef ],
- ['infix', 65, ['||'], undef ],
- ['infix', 60, ['..'], sub { $_[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', 52, ['='], undef ],
['prefix', 50, ['not', 'NOT'], sub { ! $_[0] } ],
- ['infix', 45, ['and', 'AND'], undef ],
- ['infix', 40, ['or', 'OR'], undef ],
+ ['left', 45, ['and', 'AND'], undef ],
+ ['right', 40, ['or', 'OR'], undef ],
['', 0, ['hash'], sub { return {@_}; } ],
['', 0, ['array'], sub { return [@_] } ],
];
$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;
$EXTRA_COMPILE_EXT = '.sto';
+
+ eval {require Scalar::Util};
};
###----------------------------------------------------------------###
} elsif ($func eq 'META') {
my $args = $self->parse_args(\$tag);
my $hash;
- if (($hash = $self->get_variable($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{ ^ ($QR_OP_ASSIGN) >? \s* $QR_COMMENTS }{}ox) {
$node->[0] = 'SET';
###----------------------------------------------------------------###
-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);
}
}
### test for leading prefix operators
my $has_prefix;
- if ($copy =~ s{ ^ ($QR_OP_PREFIX) \s* $QR_COMMENTS }{}ox) {
+ while ($copy =~ s{ ^ ($QR_OP_PREFIX) \s* $QR_COMMENTS }{}ox) {
return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
- $has_prefix = $1;
+ push @{ $has_prefix }, $1;
}
my @var;
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;
### allow for names
### 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"
}
local $self->{'_operator_precedence'} = 1;
- my $op = $1;
- my $var2 = $OP_POSTFIX->{$op} ? 1 : $self->parse_variable(\$copy); # cheat - give a "second value" to postfix ops
+ my $op = $1;
+
+ ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --)
+ if ($OP_POSTFIX->{$op}) {
+ $var = [\ [$op, $var, 1], 0]; # cheat - give a "second value" to postfix ops
+ next;
### allow for prefix operator precedence
- if ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix}->[1]) {
+ } 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_prefix, $var ], 0 ];
- undef $has_prefix;
+ $var = [ \ [ $has_prefix->[-1], $var ], 0 ];
+ if (! @$has_prefix) { undef $has_prefix } else { pop @$has_prefix }
}
### add the operator to the tree
+ my $var2 = $self->parse_expr(\$copy);
push (@{ $tree ||= [] }, $op, $var2);
- $found->{$op} = $OP->{$op}->[1];
+ $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op}
}
### if we found operators - tree the nodes by operator precedence
### allow for prefix on non-chained variables
if ($has_prefix) {
- $var = [ \ [ $has_prefix, $var ], 0 ];
+ $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 @ternary;
-
- ### split the array on the current operator
- for (my $i = 0; $i <= $#$tree; $i ++) {
- my $is_ternary = $OP_TERNARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP->{$op}->[2] };
- next if $tree->[$i] ne $op && ! $is_ternary;
- push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator
- push @ternary, $tree->[0] if $is_ternary;
- 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 infix and assign
- if (! $OP_TERNARY->{$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 ternary
- if (@ternary == 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 ternary - rare case
- while ($#ternary >= 1) {
- ### if we look starting from the back - the first lead ternary op will always be next to its matching op
- for (my $i = $#ternary; $i >= 0; $i --) {
- next if $OP->{$ternary[$i]}->[2]->[1] eq $ternary[$i];
- my ($op, $op2) = splice @ternary, $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 ternary 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 $ref;
my $name = $var->[$i++];
my $args = $var->[$i++];
- warn "get_variable: begin \"$name\"\n" if trace;
+ warn "play_expr: begin \"$name\"\n" if trace;
if (ref $name) {
if (ref $name eq 'SCALAR') { # a scalar literal
$ref = $$name;
return $self->play_operator($$name) if ${ $name }->[0] eq '..';
$ref = $self->play_operator($$name);
} else { # a named variable access (ie via $name.foo)
- $name = $self->get_variable($name);
+ $name = $self->play_expr($name);
if (defined $name) {
return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
$ref = $self->{'_vars'}->{$name};
### check at each point if the rurned thing was a code
if (UNIVERSAL::isa($ref, 'CODE')) {
- my @results = $ref->($args ? map { $self->get_variable($_) } @$args : ());
+ my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ());
if (defined $results[0]) {
$ref = ($#results > 0) ? \@results : $results[0];
} elsif (defined $results[1]) {
my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
$name = $var->[$i++];
$args = $var->[$i++];
- warn "get_variable: nested \"$name\"\n" if trace;
+ 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 ? map { $self->get_variable($_) } @$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 ? map { $self->get_variable($_) } @$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 ? map { $self->get_variable($_) } @$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 ? map { $self->get_variable($_) } @$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 ? map { $self->get_variable($_) } @$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 {
if ($name =~ m{ ^ -? $QR_NUM $ }ox) {
$ref = $ref->[$name];
} elsif ($LIST_OPS->{$name}) {
- $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->get_variable($_) } @$args : ());
+ $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
} else {
$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) {
return $self->{'_vars'}->{$ref} = $val;
### check at each point if the returned thing was a code
if (UNIVERSAL::isa($ref, 'CODE')) {
- my @results = $ref->($args ? map { $self->get_variable($_) } @$args : ());
+ my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ());
if (defined $results[0]) {
$ref = ($#results > 0) ? \@results : $results[0];
} elsif (defined $results[1]) {
### 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 =~ /^[_.]/) {
return;
}
### method calls on objects
} elsif (UNIVERSAL::can($ref, 'can')) {
my $lvalueish;
- my @args = $args ? map { $self->get_variable($_) } @$args : ();
+ my @args = $args ? map { $self->play_expr($_) } @$args : ();
if ($i >= $#$var) {
$lvalueish = 1;
push @args, $val;
if ($OP_DISPATCH->{$tree->[0]}) {
local $^W;
if ($OP_ASSIGN->{$tree->[0]}) {
- my $val = $OP_DISPATCH->{$tree->[0]}->( $self->get_variable($tree->[1]), $self->get_variable($tree->[2]) );
+ 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->get_variable($tree->[$_]) } 1 .. $#$tree );
+ return $OP_DISPATCH->{$tree->[0]}->( map { $self->play_expr($tree->[$_]) } 1 .. $#$tree );
}
}
### 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->get_variable($tree->[1]);
+ 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->get_variable($tree->[1]);
+ 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
}
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 {
foreach (@$set) {
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
my $val = $node->[4] ||= []; # setup storage
return [[$initial_op, $initial_var, $val]];
} else { # get a normal variable
- return [[$initial_op, $initial_var, $self->parse_variable($tag_ref)]];
+ return [[$initial_op, $initial_var, $self->parse_expr($tag_ref)]];
}
}
while (length $$tag_ref) {
- my $set = $self->parse_variable($tag_ref);
+ my $set = $self->parse_expr($tag_ref);
last if ! defined $set;
if ($$tag_ref =~ s{ ^ ($QR_OP_ASSIGN) >? \s* }{}x) {
push @SET, [$op, $set, $val];
last;
} else { # get a normal variable
- push @SET, [$op, $set, $self->parse_variable($tag_ref)];
+ push @SET, [$op, $set, $self->parse_expr($tag_ref)];
}
} else {
push @SET, ['=', $set, undef];
$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->get_variable($set), $val);
+ $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;
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 ? map { $self->get_variable($_) } @$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 ? map { $self->get_variable($_) } @$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 ? map { $self->get_variable($_) } @$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 ? map { $self->get_variable($_) } @$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);
}
sub vmethod_as_scalar {
- my ($str, $pat) = @_;
- $pat = '%s' if ! defined $pat;
+ my $str = shift; $str = '' if ! defined $str;
+ my $pat = shift; $pat = '%s' if ! defined $pat;
local $^W;
- return sprintf $pat, $str;
+ return @_ ? sprintf($pat, $_[0], $str)
+ : sprintf($pat, $str);
}
sub vmethod_as_list {
- my ($ref, $pat, $sep) = @_;
- $pat = '%s' if ! defined $pat;
- $sep = ' ' if ! defined $sep;
+ 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, $_} @$ref);
+ return @_ ? join($sep, map {sprintf $pat, $_[0], $_} @$ref)
+ : 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;
+ 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);
+ 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 {
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