--- /dev/null
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+bench_optree.pl - Look at different ways of storing data that transform fast.
+
+=cut
+
+use strict;
+use Benchmark qw(cmpthese timethese);
+use CGI::Ex::Dump qw(debug);
+use constant skip_execute => 1;
+
+#my $obj = bless [1, 2], __PACKAGE__;
+#my $struct1 = \ [ '-', 1, 2 ];
+#my $struct2 = ['-', 1, 2];
+#
+#sub call { $_[0]->[0] - $_[0]->[1] }
+#
+#sub obj_meth { $obj->call }
+#sub ref_type { if (ref($struct1) eq 'REF') { if (${$struct1}->[0] eq '-') { ${$struct1}->[1] - ${$struct1}->[2] } } }
+#
+#print "(".obj_meth().")\n";
+#print "(".ref_type().")\n";
+#cmpthese timethese(-2, {
+# obj_meth => \&obj_meth,
+# ref_type => \&ref_type,
+#}, 'auto');
+
+
+###----------------------------------------------------------------###
+### setup a new way of storing and executing the variable tree
+
+sub get_var2 { ref($_[1]) ? $_[1]->call($_[0]) : $_[1] }
+
+{
+ package Num;
+ sub new { my $c = shift; bless \@_, $c };
+ sub call { $_[0]->[0] }
+ package A::B;
+ sub new { my $c = shift; bless \@_, $c }
+# sub new { my $c = shift; bless [map{ref$_?$_:Num->new($_)} @_], $c }
+ package A::B::Minus;
+ our @ISA = qw(A::B);
+ sub call { $_[1]->get_var2($_[0]->[0]) - $_[1]->get_var2($_[0]->[1]) }
+ package A::B::Plus;
+ our @ISA = qw(A::B);
+ sub call { $_[1]->get_var2($_[0]->[0]) + $_[1]->get_var2($_[0]->[1]) }
+ package A::B::Mult;
+ our @ISA = qw(A::B);
+ sub call { $_[1]->get_var2($_[0]->[0]) * $_[1]->get_var2($_[0]->[1]) }
+ package A::B::Div;
+ our @ISA = qw(A::B);
+ sub call { $_[1]->get_var2($_[0]->[0]) / $_[1]->get_var2($_[0]->[1]) }
+ package A::B::Var;
+ our @ISA = qw(A::B);
+use vars qw($HASH_OPS $LIST_OPS $SCALAR_OPS $FILTER_OPS $OP_FUNC);
+BEGIN {
+ $HASH_OPS = $CGI::Ex::Template::HASH_OPS;
+ $LIST_OPS = $CGI::Ex::Template::LIST_OPS;
+ $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS;
+ $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS;
+ $OP_FUNC = $CGI::Ex::Template::OP_FUNC;
+}
+use constant trace => 0;
+sub call {
+ my $var = shift;
+ my $self = shift;
+ my $ARGS = shift || {};
+ my $i = 0;
+ my $generated_list;
+
+ ### determine the top level of this particular variable access
+ my $ref = $var->[$i++];
+ my $args = $var->[$i++];
+ warn "get_variable: begin \"$ref\"\n" if trace;
+
+ if (defined $ref) {
+ if ($ARGS->{'is_namespace_during_compile'}) {
+ $ref = $self->{'NAMESPACE'}->{$ref};
+ } else {
+ return if $ref =~ /^[_.]/; # don't allow vars that begin with _
+ $ref = $self->{'_vars'}->{$ref};
+ }
+ }
+
+ my %seen_filters;
+ while (defined $ref) {
+
+ ### check at each point if the returned thing was a code
+ if (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 {
+ $ref = undef;
+ last;
+ }
+ }
+
+ ### 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;
+
+ ### allow for named portions of a variable name (foo.$name.bar)
+ if (ref $name) {
+ $name = $name->call($self);
+ if (! defined($name) || $name =~ /^[_.]/) {
+ $ref = undef;
+ last;
+ }
+ }
+
+ if ($name =~ /^_/) { # don't allow vars that begin with _
+ $ref = undef;
+ last;
+ }
+
+ ### allow for scalar and filter access (this happens for every non virtual method call)
+ if (! ref $ref) {
+ if ($SCALAR_OPS->{$name}) { # normal scalar op
+ $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
+ $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args
+ || $FILTER_OPS->{$name} # predefined filters in CET
+ || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
+ || $self->list_filters->{$name}) { # filter defined in Template::Filters
+
+ if (UNIVERSAL::isa($filter, 'CODE')) {
+ $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
+ $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
+
+ } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
+ eval {
+ my $sub = $filter->[0];
+ if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
+ ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ());
+ if (! $sub && $err) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
+ $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
+ if ref($sub) !~ /Template::Exception$/;
+ die $sub;
+ }
+ }
+ $ref = $sub->($ref);
+ };
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
+ $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
+ $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree
+ $i = 2;
+ }
+ if (scalar keys %seen_filters
+ && $seen_filters{$var->[$i - 5] || ''}) {
+ $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)");
+ }
+ } else {
+ $ref = undef;
+ }
+
+ } else {
+
+ ### method calls on objects
+ if (UNIVERSAL::can($ref, 'can')) {
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ my @results = eval { $ref->$name(@args) };
+ if ($@) {
+ die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
+ } elsif (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ next;
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ # didn't find a method by that name - so fail down to hash and array access
+ }
+
+ ### hash member access
+ if (UNIVERSAL::isa($ref, 'HASH')) {
+ if ($was_dot_call && exists($ref->{$name}) ) {
+ $ref = $ref->{$name};
+ } elsif ($HASH_OPS->{$name}) {
+ $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ } elsif ($ARGS->{'is_namespace_during_compile'}) {
+ return $var; # abort - can't fold namespace variable
+ } else {
+ $ref = undef;
+ }
+
+ ### array access
+ } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
+ if ($name =~ /^\d+$/) {
+ $ref = ($name > $#$ref) ? undef : $ref->[$name];
+ } else {
+ $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ }
+ }
+ }
+
+ } # end of while
+
+ ### allow for undefinedness
+ if (! defined $ref) {
+ if ($self->{'_debug_undef'}) {
+ my $chunk = $var->[$i - 2];
+ $chunk = $chunk->call($self) if ref $chunk;
+ die "$chunk is undefined\n";
+ } else {
+ $ref = $self->undefined_any($var);
+ }
+ }
+
+ ### allow for special behavior for the '..' operator
+ if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') {
+ return @$ref;
+ }
+
+ return $ref;
+}
+};
+sub plus ($$) { A::B::Plus->new( @_) }
+sub minus ($$) { A::B::Minus->new(@_) }
+sub mult ($$) { A::B::Mult->new( @_) }
+sub div ($$) { A::B::Div->new( @_) }
+sub var { A::B::Var->new( @_) };
+$INC{'A/B.pm'} = 1;
+$INC{'A/B/Plus.pm'} = 1;
+$INC{'A/B/Minus.pm'} = 1;
+$INC{'A/B/Mult.pm'} = 1;
+$INC{'A/B/Div.pm'} = 1;
+$INC{'A/B/Var.pm'} = 1;
+
+###----------------------------------------------------------------###
+### now benchmark the different variable storage methods
+
+my $vars = {
+ foo => {bar => {baz => [qw(a b c)]}},
+ bing => 'bang',
+};
+my $self = bless {'_vars' => $vars}, __PACKAGE__;
+
+#pauls@pslaptop:~/perl/CGI-Ex/lib$ perl -e 'my $a = "1 + 2 * (3 + (4 / 5) * 9) - 20";
+# use CGI::Ex::Template;
+# use Data::Dumper;
+# print Dumper(CGI::Ex::Template->new->parse_variable(\$a));'
+
+###----------------------------------------------------------------###
+
+my $Y0 = '$self->{_vars}->{bing}';
+my $Y1 = [ 'bing', 0 ];
+my $Y2 = var('bing', 0);
+debug $Y2;
+
+### are they all the same
+print eval($Y0)."\n";
+print $self->get_variable($Y1)."\n";
+print $self->get_var2($Y2)."\n";
+
+if (! skip_execute) {
+ cmpthese timethese (-2, {
+ perl => sub { eval $Y0 },
+ bare_data => sub { $self->get_variable($Y1) },
+ method_call => sub { $self->get_var2($Y2) },
+ }, 'auto');
+}
+
+###----------------------------------------------------------------###
+
+my $Z0 = '$self->{_vars}->{foo}->{bar}->{baz}->[1]';
+my $Z1 = [ 'foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0];
+my $Z2 = var('foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0);
+debug $Z2;
+
+### are they all the same
+print eval($Z0)."\n";
+print $self->get_variable($Z1)."\n";
+print $self->get_var2($Z2)."\n";
+
+if (! skip_execute) {
+ cmpthese timethese (-2, {
+ perl => sub { eval $Z0 },
+ bare_data => sub { $self->get_variable($Z1) },
+ method_call => sub { $self->get_var2($Z2) },
+ }, 'auto');
+}
+
+###----------------------------------------------------------------###
+
+### $A0 = perl, $A1 = old optree, $A2 = new optree
+my $A0 = "1 + 2 * (3 + (4 / 5) * 9) - 20";
+my $A1 = [ \[ '-', [ \[ '+', '1', [ \[ '*', '2', [ \[ '+', '3', [ \[ '*', [ \[ '/', '4', '5' ], 0 ], '9' ], 0 ] ], 0 ] ], 0 ] ], 0 ], '20' ], 0 ];
+my $A2 = minus(plus(1, mult(2, plus(3, mult(div(4,5), 9)))), 20);
+debug $A2;
+
+### are they all the same
+print eval($A0)."\n";
+print $self->get_variable($A1)."\n";
+print $self->get_var2($A2)."\n";
+
+if (! skip_execute) {
+ cmpthese timethese (-2, {
+ perl => sub { eval $A0 },
+ bare_data => sub { $self->get_variable($A1) },
+ method_call => sub { $self->get_var2($A2) },
+ }, 'auto');
+}
+
+###----------------------------------------------------------------###
+
+my $B0 = "1 + 2";
+my $B1 = [ \[ '+', 1, 2] ];
+my $B2 = plus(1, 2);
+debug $B2;
+
+### are they all the same
+print eval($B0)."\n";
+print $self->get_variable($B1)."\n";
+print $self->get_var2($B2)."\n";
+
+if (! skip_execute) {
+ cmpthese timethese (-2, {
+ perl => sub { eval $B0 },
+ bare_data => sub { $self->get_variable($B1) },
+ method_call => sub { $self->get_var2($B2) },
+ }, 'auto');
+}
+
+###----------------------------------------------------------------###
+### Test (de)serialization speed
+
+use Storable;
+my $d1 = Storable::freeze($A1);
+my $d2 = Storable::freeze($A2);
+Storable::thaw($d1); # load lib
+print length($d1)."\n";
+print length($d2)."\n";
+
+cmpthese timethese (-2, {
+ freeze_bare => sub { Storable::freeze($A1) },
+ freeze_meth => sub { Storable::freeze($A2) },
+}, 'auto');
+
+cmpthese timethese (-2, {
+ thaw_bare => sub { Storable::thaw($d1) },
+ thaw_meth => sub { Storable::thaw($d2) },
+}, 'auto');
+
+###----------------------------------------------------------------###
+### create libraries similar to those from CGI::Ex::Template 1.201
+
+use CGI::Ex::Template;
+use vars qw($HASH_OPS $LIST_OPS $SCALAR_OPS $FILTER_OPS $OP_FUNC);
+BEGIN {
+ $HASH_OPS = $CGI::Ex::Template::HASH_OPS;
+ $LIST_OPS = $CGI::Ex::Template::LIST_OPS;
+ $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS;
+ $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS;
+ $OP_FUNC = $CGI::Ex::Template::OP_FUNC;
+}
+use constant trace => 0;
+
+sub get_variable {
+ ### allow for the parse tree to store literals
+ return $_[1] if ! ref $_[1];
+
+ my $self = shift;
+ my $var = shift;
+ my $ARGS = shift || {};
+ my $i = 0;
+ my $generated_list;
+
+ ### determine the top level of this particular variable access
+ my $ref = $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 '\\'; # return the closure
+ $generated_list = 1 if ${ $ref }->[0] eq '..';
+ $ref = $self->play_operator($$ref);
+ } else { # a named variable access (ie via $name.foo)
+ $ref = $self->get_variable($ref);
+ if (defined $ref) {
+ return if $ref =~ /^[_.]/; # don't allow vars that begin with _
+ $ref = $self->{'_vars'}->{$ref};
+ }
+ }
+ } elsif (defined $ref) {
+ if ($ARGS->{'is_namespace_during_compile'}) {
+ $ref = $self->{'NAMESPACE'}->{$ref};
+ } else {
+ return if $ref =~ /^[_.]/; # don't allow vars that begin with _
+ $ref = $self->{'_vars'}->{$ref};
+ }
+ }
+
+
+ my %seen_filters;
+ while (defined $ref) {
+
+ ### check at each point if the returned thing was a code
+ if (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 {
+ $ref = undef;
+ last;
+ }
+ }
+
+ ### 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;
+
+ ### allow for named portions of a variable name (foo.$name.bar)
+ if (ref $name) {
+ if (ref($name) eq 'ARRAY') {
+ $name = $self->get_variable($name);
+ if (! defined($name) || $name =~ /^[_.]/) {
+ $ref = undef;
+ last;
+ }
+ } else {
+ die "Shouldn't get a ". ref($name) ." during a vivify on chain";
+ }
+ }
+ if ($name =~ /^_/) { # don't allow vars that begin with _
+ $ref = undef;
+ last;
+ }
+
+ ### allow for scalar and filter access (this happens for every non virtual method call)
+ if (! ref $ref) {
+ if ($SCALAR_OPS->{$name}) { # normal scalar op
+ $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
+ $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ());
+
+ } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args
+ || $FILTER_OPS->{$name} # predefined filters in CET
+ || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
+ || $self->list_filters->{$name}) { # filter defined in Template::Filters
+
+ if (UNIVERSAL::isa($filter, 'CODE')) {
+ $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
+ $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
+
+ } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
+ eval {
+ my $sub = $filter->[0];
+ if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
+ ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ());
+ if (! $sub && $err) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
+ $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
+ if ref($sub) !~ /Template::Exception$/;
+ die $sub;
+ }
+ }
+ $ref = $sub->($ref);
+ };
+ if (my $err = $@) {
+ $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
+ die $err;
+ }
+ } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
+ $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
+ $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree
+ $i = 2;
+ }
+ if (scalar keys %seen_filters
+ && $seen_filters{$var->[$i - 5] || ''}) {
+ $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)");
+ }
+ } else {
+ $ref = undef;
+ }
+
+ } else {
+
+ ### method calls on objects
+ if (UNIVERSAL::can($ref, 'can')) {
+ my @args = $args ? @{ $self->vivify_args($args) } : ();
+ my @results = eval { $ref->$name(@args) };
+ if ($@) {
+ die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
+ } elsif (defined $results[0]) {
+ $ref = ($#results > 0) ? \@results : $results[0];
+ next;
+ } elsif (defined $results[1]) {
+ die $results[1]; # TT behavior - why not just throw ?
+ } else {
+ $ref = undef;
+ last;
+ }
+ # didn't find a method by that name - so fail down to hash and array access
+ }
+
+ ### hash member access
+ if (UNIVERSAL::isa($ref, 'HASH')) {
+ if ($was_dot_call && exists($ref->{$name}) ) {
+ $ref = $ref->{$name};
+ } elsif ($HASH_OPS->{$name}) {
+ $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ } elsif ($ARGS->{'is_namespace_during_compile'}) {
+ return $var; # abort - can't fold namespace variable
+ } else {
+ $ref = undef;
+ }
+
+ ### array access
+ } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
+ if ($name =~ /^\d+$/) {
+ $ref = ($name > $#$ref) ? undef : $ref->[$name];
+ } else {
+ $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ());
+ }
+ }
+ }
+
+ } # end of while
+
+ ### allow for undefinedness
+ if (! defined $ref) {
+ if ($self->{'_debug_undef'}) {
+ my $chunk = $var->[$i - 2];
+ $chunk = $self->get_variable($chunk) if ref($chunk) eq 'ARRAY';
+ die "$chunk is undefined\n";
+ } else {
+ $ref = $self->undefined_any($var);
+ }
+ }
+
+ ### allow for special behavior for the '..' operator
+ if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') {
+ return @$ref;
+ }
+
+ return $ref;
+}
+
+sub vivify_args {
+ my $self = shift;
+ my $vars = shift;
+ my $args = shift || {};
+ return [map {$self->get_variable($_, $args)} @$vars];
+}
+
+sub play_operator {
+ my $self = shift;
+ my $tree = shift;
+ my $ARGS = shift || {};
+ my $op = $tree->[0];
+ $tree = [@$tree[1..$#$tree]];
+
+ ### allow for operator function override
+ if (exists $OP_FUNC->{$op}) {
+ return $OP_FUNC->{$op}->($self, $op, $tree, $ARGS);
+ }
+
+ ### do constructors and short-circuitable operators
+ if ($op eq '~' || $op eq '_') {
+ return join "", grep {defined} @{ $self->vivify_args($tree) };
+ } elsif ($op eq 'arrayref') {
+ return $self->vivify_args($tree, {list_context => 1});
+ } elsif ($op eq 'hashref') {
+ my $args = $self->vivify_args($tree);
+ push @$args, undef if ! ($#$args % 2);
+ return {@$args};
+ } elsif ($op eq '?') {
+ if ($self->get_variable($tree->[0])) {
+ return defined($tree->[1]) ? $self->get_variable($tree->[1]) : undef;
+ } else {
+ return defined($tree->[2]) ? $self->get_variable($tree->[2]) : undef;
+ }
+ } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
+ for my $node (@$tree) {
+ my $var = $self->get_variable($node);
+ return $var if $var;
+ }
+ return '';
+ } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') {
+ my $var;
+ for my $node (@$tree) {
+ $var = $self->get_variable($node);
+ return 0 if ! $var;
+ }
+ return $var;
+
+ } elsif ($op eq '!') {
+ my $var = ! $self->get_variable($tree->[0]);
+ return defined($var) ? $var : '';
+
+ }
+
+ ### equality operators
+ local $^W = 0;
+ my $n = $self->get_variable($tree->[0]);
+ $tree = [@$tree[1..$#$tree]];
+ if ($op eq '==') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 }
+ elsif ($op eq '!=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 }
+ elsif ($op eq 'eq') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 }
+ elsif ($op eq 'ne') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 }
+ elsif ($op eq '<') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n < $_); $n = $_ }; return 1 }
+ elsif ($op eq '>') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n > $_); $n = $_ }; return 1 }
+ elsif ($op eq '<=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n <= $_); $n = $_ }; return 1 }
+ elsif ($op eq '>=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n >= $_); $n = $_ }; return 1 }
+ elsif ($op eq 'lt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n lt $_); $n = $_ }; return 1 }
+ elsif ($op eq 'gt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n gt $_); $n = $_ }; return 1 }
+ elsif ($op eq 'le') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n le $_); $n = $_ }; return 1 }
+ elsif ($op eq 'ge') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ge $_); $n = $_ }; return 1 }
+
+ ### numeric operators
+ my $args = $self->vivify_args($tree);
+ if (! @$args) {
+ if ($op eq '-') { return - $n }
+ $self->throw('operator', "Not enough args for operator \"$op\"");
+ }
+ if ($op eq '..') { return [($n || 0) .. ($args->[-1] || 0)] }
+ elsif ($op eq '+') { $n += $_ for @$args; return $n }
+ elsif ($op eq '-') { $n -= $_ for @$args; return $n }
+ elsif ($op eq '*') { $n *= $_ for @$args; return $n }
+ elsif ($op eq '/') { $n /= $_ for @$args; return $n }
+ elsif ($op eq 'div'
+ || $op eq 'DIV') { $n = int($n / $_) for @$args; return $n }
+ elsif ($op eq '%'
+ || $op eq 'mod'
+ || $op eq 'MOD') { $n %= $_ for @$args; return $n }
+ elsif ($op eq '**'
+ || $op eq 'pow') { $n **= $_ for @$args; return $n }
+
+ $self->throw('operator', "Un-implemented operation $op");
+}
+
projects / chaz / p5-CGI-Ex / blobdiff