1#!/usr/bin/perl -w 2 3=head1 NAME 4 5bench_optree.pl - Look at different ways of storing data that transform fast. 6 7=cut 8 9use strict; 10use Benchmark qw(cmpthese timethese); 11use CGI::Ex::Dump qw(debug); 12use constant skip_execute => 1; 13 14#my $obj = bless [1, 2], __PACKAGE__; 15#my $struct1 = \ [ '-', 1, 2 ]; 16#my $struct2 = ['-', 1, 2]; 17# 18#sub call { $_[0]->[0] - $_[0]->[1] } 19# 20#sub obj_meth { $obj->call } 21#sub ref_type { if (ref($struct1) eq 'REF') { if (${$struct1}->[0] eq '-') { ${$struct1}->[1] - ${$struct1}->[2] } } } 22# 23#print "(".obj_meth().")\n"; 24#print "(".ref_type().")\n"; 25#cmpthese timethese(-2, { 26# obj_meth => \&obj_meth, 27# ref_type => \&ref_type, 28#}, 'auto'); 29 30 31###----------------------------------------------------------------### 32### setup a new way of storing and executing the variable tree 33 34sub get_var2 { ref($_[1]) ? $_[1]->call($_[0]) : $_[1] } 35 36{ 37 package Num; 38 sub new { my $c = shift; bless \@_, $c }; 39 sub call { $_[0]->[0] } 40 package A::B; 41 sub new { my $c = shift; bless \@_, $c } 42# sub new { my $c = shift; bless [map{ref$_?$_:Num->new($_)} @_], $c } 43 package A::B::Minus; 44 our @ISA = qw(A::B); 45 sub call { $_[1]->get_var2($_[0]->[0]) - $_[1]->get_var2($_[0]->[1]) } 46 package A::B::Plus; 47 our @ISA = qw(A::B); 48 sub call { $_[1]->get_var2($_[0]->[0]) + $_[1]->get_var2($_[0]->[1]) } 49 package A::B::Mult; 50 our @ISA = qw(A::B); 51 sub call { $_[1]->get_var2($_[0]->[0]) * $_[1]->get_var2($_[0]->[1]) } 52 package A::B::Div; 53 our @ISA = qw(A::B); 54 sub call { $_[1]->get_var2($_[0]->[0]) / $_[1]->get_var2($_[0]->[1]) } 55 package A::B::Var; 56 our @ISA = qw(A::B); 57 58our $HASH_OPS = $CGI::Ex::Template::HASH_OPS; 59our $LIST_OPS = $CGI::Ex::Template::LIST_OPS; 60our $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS; 61our $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS; 62our $OP_FUNC = $CGI::Ex::Template::OP_FUNC; 63 64use constant trace => 0; 65sub call { 66 my $var = shift; 67 my $self = shift; 68 my $ARGS = shift || {}; 69 my $i = 0; 70 my $generated_list; 71 72 ### determine the top level of this particular variable access 73 my $ref = $var->[$i++]; 74 my $args = $var->[$i++]; 75 warn "get_variable: begin \"$ref\"\n" if trace; 76 77 if (defined $ref) { 78 if ($ARGS->{'is_namespace_during_compile'}) { 79 $ref = $self->{'NAMESPACE'}->{$ref}; 80 } else { 81 return if $ref =~ /^[_.]/; # don't allow vars that begin with _ 82 $ref = $self->{'_vars'}->{$ref}; 83 } 84 } 85 86 my %seen_filters; 87 while (defined $ref) { 88 89 ### check at each point if the returned thing was a code 90 if (UNIVERSAL::isa($ref, 'CODE')) { 91 my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); 92 if (defined $results[0]) { 93 $ref = ($#results > 0) ? \@results : $results[0]; 94 } elsif (defined $results[1]) { 95 die $results[1]; # TT behavior - why not just throw ? 96 } else { 97 $ref = undef; 98 last; 99 } 100 } 101 102 ### descend one chained level 103 last if $i >= $#$var; 104 my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; 105 my $name = $var->[$i++]; 106 my $args = $var->[$i++]; 107 warn "get_variable: nested \"$name\"\n" if trace; 108 109 ### allow for named portions of a variable name (foo.$name.bar) 110 if (ref $name) { 111 $name = $name->call($self); 112 if (! defined($name) || $name =~ /^[_.]/) { 113 $ref = undef; 114 last; 115 } 116 } 117 118 if ($name =~ /^_/) { # don't allow vars that begin with _ 119 $ref = undef; 120 last; 121 } 122 123 ### allow for scalar and filter access (this happens for every non virtual method call) 124 if (! ref $ref) { 125 if ($SCALAR_OPS->{$name}) { # normal scalar op 126 $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); 127 128 } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op 129 $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ()); 130 131 } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args 132 || $FILTER_OPS->{$name} # predefined filters in CET 133 || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash 134 || $self->list_filters->{$name}) { # filter defined in Template::Filters 135 136 if (UNIVERSAL::isa($filter, 'CODE')) { 137 $ref = eval { $filter->($ref) }; # non-dynamic filter - no args 138 if (my $err = $@) { 139 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; 140 die $err; 141 } 142 } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { 143 $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); 144 145 } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters 146 eval { 147 my $sub = $filter->[0]; 148 if ($filter->[1]) { # it is a "dynamic filter" that will return a sub 149 ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ()); 150 if (! $sub && $err) { 151 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; 152 die $err; 153 } elsif (! UNIVERSAL::isa($sub, 'CODE')) { 154 $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") 155 if ref($sub) !~ /Template::Exception$/; 156 die $sub; 157 } 158 } 159 $ref = $sub->($ref); 160 }; 161 if (my $err = $@) { 162 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; 163 die $err; 164 } 165 } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) 166 $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; 167 $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree 168 $i = 2; 169 } 170 if (scalar keys %seen_filters 171 && $seen_filters{$var->[$i - 5] || ''}) { 172 $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); 173 } 174 } else { 175 $ref = undef; 176 } 177 178 } else { 179 180 ### method calls on objects 181 if (UNIVERSAL::can($ref, 'can')) { 182 my @args = $args ? @{ $self->vivify_args($args) } : (); 183 my @results = eval { $ref->$name(@args) }; 184 if ($@) { 185 die $@ if ref $@ || $@ !~ /Can\'t locate object method/; 186 } elsif (defined $results[0]) { 187 $ref = ($#results > 0) ? \@results : $results[0]; 188 next; 189 } elsif (defined $results[1]) { 190 die $results[1]; # TT behavior - why not just throw ? 191 } else { 192 $ref = undef; 193 last; 194 } 195 # didn't find a method by that name - so fail down to hash and array access 196 } 197 198 ### hash member access 199 if (UNIVERSAL::isa($ref, 'HASH')) { 200 if ($was_dot_call && exists($ref->{$name}) ) { 201 $ref = $ref->{$name}; 202 } elsif ($HASH_OPS->{$name}) { 203 $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); 204 } elsif ($ARGS->{'is_namespace_during_compile'}) { 205 return $var; # abort - can't fold namespace variable 206 } else { 207 $ref = undef; 208 } 209 210 ### array access 211 } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { 212 if ($name =~ /^\d+$/) { 213 $ref = ($name > $#$ref) ? undef : $ref->[$name]; 214 } else { 215 $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); 216 } 217 } 218 } 219 220 } # end of while 221 222 ### allow for undefinedness 223 if (! defined $ref) { 224 if ($self->{'_debug_undef'}) { 225 my $chunk = $var->[$i - 2]; 226 $chunk = $chunk->call($self) if ref $chunk; 227 die "$chunk is undefined\n"; 228 } else { 229 $ref = $self->undefined_any($var); 230 } 231 } 232 233 ### allow for special behavior for the '..' operator 234 if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') { 235 return @$ref; 236 } 237 238 return $ref; 239} 240}; 241sub plus ($$) { A::B::Plus->new( @_) } 242sub minus ($$) { A::B::Minus->new(@_) } 243sub mult ($$) { A::B::Mult->new( @_) } 244sub div ($$) { A::B::Div->new( @_) } 245sub var { A::B::Var->new( @_) }; 246$INC{'A/B.pm'} = 1; 247$INC{'A/B/Plus.pm'} = 1; 248$INC{'A/B/Minus.pm'} = 1; 249$INC{'A/B/Mult.pm'} = 1; 250$INC{'A/B/Div.pm'} = 1; 251$INC{'A/B/Var.pm'} = 1; 252 253###----------------------------------------------------------------### 254### now benchmark the different variable storage methods 255 256my $vars = { 257 foo => {bar => {baz => [qw(a b c)]}}, 258 bing => 'bang', 259}; 260my $self = bless {'_vars' => $vars}, __PACKAGE__; 261 262#pauls@pslaptop:~/perl/CGI-Ex/lib$ perl -e 'my $a = "1 + 2 * (3 + (4 / 5) * 9) - 20"; 263# use CGI::Ex::Template; 264# use Data::Dumper; 265# print Dumper(CGI::Ex::Template->new->parse_variable(\$a));' 266 267###----------------------------------------------------------------### 268 269my $Y0 = '$self->{_vars}->{bing}'; 270my $Y1 = [ 'bing', 0 ]; 271my $Y2 = var('bing', 0); 272debug $Y2; 273 274### are they all the same 275print eval($Y0)."\n"; 276print $self->get_variable($Y1)."\n"; 277print $self->get_var2($Y2)."\n"; 278 279if (! skip_execute) { 280 cmpthese timethese (-2, { 281 perl => sub { eval $Y0 }, 282 bare_data => sub { $self->get_variable($Y1) }, 283 method_call => sub { $self->get_var2($Y2) }, 284 }, 'auto'); 285} 286 287###----------------------------------------------------------------### 288 289my $Z0 = '$self->{_vars}->{foo}->{bar}->{baz}->[1]'; 290my $Z1 = [ 'foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0]; 291my $Z2 = var('foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0); 292debug $Z2; 293 294### are they all the same 295print eval($Z0)."\n"; 296print $self->get_variable($Z1)."\n"; 297print $self->get_var2($Z2)."\n"; 298 299if (! skip_execute) { 300 cmpthese timethese (-2, { 301 perl => sub { eval $Z0 }, 302 bare_data => sub { $self->get_variable($Z1) }, 303 method_call => sub { $self->get_var2($Z2) }, 304 }, 'auto'); 305} 306 307###----------------------------------------------------------------### 308 309### $A0 = perl, $A1 = old optree, $A2 = new optree 310my $A0 = "1 + 2 * (3 + (4 / 5) * 9) - 20"; 311my $A1 = [ \[ '-', [ \[ '+', '1', [ \[ '*', '2', [ \[ '+', '3', [ \[ '*', [ \[ '/', '4', '5' ], 0 ], '9' ], 0 ] ], 0 ] ], 0 ] ], 0 ], '20' ], 0 ]; 312my $A2 = minus(plus(1, mult(2, plus(3, mult(div(4,5), 9)))), 20); 313debug $A2; 314 315### are they all the same 316print eval($A0)."\n"; 317print $self->get_variable($A1)."\n"; 318print $self->get_var2($A2)."\n"; 319 320if (! skip_execute) { 321 cmpthese timethese (-2, { 322 perl => sub { eval $A0 }, 323 bare_data => sub { $self->get_variable($A1) }, 324 method_call => sub { $self->get_var2($A2) }, 325 }, 'auto'); 326} 327 328###----------------------------------------------------------------### 329 330my $B0 = "1 + 2"; 331my $B1 = [ \[ '+', 1, 2] ]; 332my $B2 = plus(1, 2); 333debug $B2; 334 335### are they all the same 336print eval($B0)."\n"; 337print $self->get_variable($B1)."\n"; 338print $self->get_var2($B2)."\n"; 339 340if (! skip_execute) { 341 cmpthese timethese (-2, { 342 perl => sub { eval $B0 }, 343 bare_data => sub { $self->get_variable($B1) }, 344 method_call => sub { $self->get_var2($B2) }, 345 }, 'auto'); 346} 347 348###----------------------------------------------------------------### 349### Test (de)serialization speed 350 351use Storable; 352my $d1 = Storable::freeze($A1); 353my $d2 = Storable::freeze($A2); 354Storable::thaw($d1); # load lib 355print length($d1)."\n"; 356print length($d2)."\n"; 357 358cmpthese timethese (-2, { 359 freeze_bare => sub { Storable::freeze($A1) }, 360 freeze_meth => sub { Storable::freeze($A2) }, 361}, 'auto'); 362 363cmpthese timethese (-2, { 364 thaw_bare => sub { Storable::thaw($d1) }, 365 thaw_meth => sub { Storable::thaw($d2) }, 366}, 'auto'); 367 368###----------------------------------------------------------------### 369### create libraries similar to those from CGI::Ex::Template 1.201 370 371use CGI::Ex::Template; 372 373our $HASH_OPS = $CGI::Ex::Template::HASH_OPS; 374our $LIST_OPS = $CGI::Ex::Template::LIST_OPS; 375our $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS; 376our $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS; 377our $OP_FUNC = $CGI::Ex::Template::OP_FUNC; 378 379use constant trace => 0; 380 381sub get_variable { 382 ### allow for the parse tree to store literals 383 return $_[1] if ! ref $_[1]; 384 385 my $self = shift; 386 my $var = shift; 387 my $ARGS = shift || {}; 388 my $i = 0; 389 my $generated_list; 390 391 ### determine the top level of this particular variable access 392 my $ref = $var->[$i++]; 393 my $args = $var->[$i++]; 394 warn "get_variable: begin \"$ref\"\n" if trace; 395 if (ref $ref) { 396 if (ref($ref) eq 'SCALAR') { # a scalar literal 397 $ref = $$ref; 398 } elsif (ref($ref) eq 'REF') { # operator 399 return $self->play_operator($$ref) if ${ $ref }->[0] eq '\\'; # return the closure 400 $generated_list = 1 if ${ $ref }->[0] eq '..'; 401 $ref = $self->play_operator($$ref); 402 } else { # a named variable access (ie via $name.foo) 403 $ref = $self->get_variable($ref); 404 if (defined $ref) { 405 return if $ref =~ /^[_.]/; # don't allow vars that begin with _ 406 $ref = $self->{'_vars'}->{$ref}; 407 } 408 } 409 } elsif (defined $ref) { 410 if ($ARGS->{'is_namespace_during_compile'}) { 411 $ref = $self->{'NAMESPACE'}->{$ref}; 412 } else { 413 return if $ref =~ /^[_.]/; # don't allow vars that begin with _ 414 $ref = $self->{'_vars'}->{$ref}; 415 } 416 } 417 418 419 my %seen_filters; 420 while (defined $ref) { 421 422 ### check at each point if the returned thing was a code 423 if (UNIVERSAL::isa($ref, 'CODE')) { 424 my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); 425 if (defined $results[0]) { 426 $ref = ($#results > 0) ? \@results : $results[0]; 427 } elsif (defined $results[1]) { 428 die $results[1]; # TT behavior - why not just throw ? 429 } else { 430 $ref = undef; 431 last; 432 } 433 } 434 435 ### descend one chained level 436 last if $i >= $#$var; 437 my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; 438 my $name = $var->[$i++]; 439 my $args = $var->[$i++]; 440 warn "get_variable: nested \"$name\"\n" if trace; 441 442 ### allow for named portions of a variable name (foo.$name.bar) 443 if (ref $name) { 444 if (ref($name) eq 'ARRAY') { 445 $name = $self->get_variable($name); 446 if (! defined($name) || $name =~ /^[_.]/) { 447 $ref = undef; 448 last; 449 } 450 } else { 451 die "Shouldn't get a ". ref($name) ." during a vivify on chain"; 452 } 453 } 454 if ($name =~ /^_/) { # don't allow vars that begin with _ 455 $ref = undef; 456 last; 457 } 458 459 ### allow for scalar and filter access (this happens for every non virtual method call) 460 if (! ref $ref) { 461 if ($SCALAR_OPS->{$name}) { # normal scalar op 462 $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); 463 464 } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op 465 $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ()); 466 467 } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args 468 || $FILTER_OPS->{$name} # predefined filters in CET 469 || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash 470 || $self->list_filters->{$name}) { # filter defined in Template::Filters 471 472 if (UNIVERSAL::isa($filter, 'CODE')) { 473 $ref = eval { $filter->($ref) }; # non-dynamic filter - no args 474 if (my $err = $@) { 475 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; 476 die $err; 477 } 478 } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { 479 $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); 480 481 } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters 482 eval { 483 my $sub = $filter->[0]; 484 if ($filter->[1]) { # it is a "dynamic filter" that will return a sub 485 ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ()); 486 if (! $sub && $err) { 487 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; 488 die $err; 489 } elsif (! UNIVERSAL::isa($sub, 'CODE')) { 490 $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") 491 if ref($sub) !~ /Template::Exception$/; 492 die $sub; 493 } 494 } 495 $ref = $sub->($ref); 496 }; 497 if (my $err = $@) { 498 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; 499 die $err; 500 } 501 } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) 502 $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; 503 $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree 504 $i = 2; 505 } 506 if (scalar keys %seen_filters 507 && $seen_filters{$var->[$i - 5] || ''}) { 508 $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); 509 } 510 } else { 511 $ref = undef; 512 } 513 514 } else { 515 516 ### method calls on objects 517 if (UNIVERSAL::can($ref, 'can')) { 518 my @args = $args ? @{ $self->vivify_args($args) } : (); 519 my @results = eval { $ref->$name(@args) }; 520 if ($@) { 521 die $@ if ref $@ || $@ !~ /Can\'t locate object method/; 522 } elsif (defined $results[0]) { 523 $ref = ($#results > 0) ? \@results : $results[0]; 524 next; 525 } elsif (defined $results[1]) { 526 die $results[1]; # TT behavior - why not just throw ? 527 } else { 528 $ref = undef; 529 last; 530 } 531 # didn't find a method by that name - so fail down to hash and array access 532 } 533 534 ### hash member access 535 if (UNIVERSAL::isa($ref, 'HASH')) { 536 if ($was_dot_call && exists($ref->{$name}) ) { 537 $ref = $ref->{$name}; 538 } elsif ($HASH_OPS->{$name}) { 539 $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); 540 } elsif ($ARGS->{'is_namespace_during_compile'}) { 541 return $var; # abort - can't fold namespace variable 542 } else { 543 $ref = undef; 544 } 545 546 ### array access 547 } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { 548 if ($name =~ /^\d+$/) { 549 $ref = ($name > $#$ref) ? undef : $ref->[$name]; 550 } else { 551 $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); 552 } 553 } 554 } 555 556 } # end of while 557 558 ### allow for undefinedness 559 if (! defined $ref) { 560 if ($self->{'_debug_undef'}) { 561 my $chunk = $var->[$i - 2]; 562 $chunk = $self->get_variable($chunk) if ref($chunk) eq 'ARRAY'; 563 die "$chunk is undefined\n"; 564 } else { 565 $ref = $self->undefined_any($var); 566 } 567 } 568 569 ### allow for special behavior for the '..' operator 570 if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') { 571 return @$ref; 572 } 573 574 return $ref; 575} 576 577sub vivify_args { 578 my $self = shift; 579 my $vars = shift; 580 my $args = shift || {}; 581 return [map {$self->get_variable($_, $args)} @$vars]; 582} 583 584sub play_operator { 585 my $self = shift; 586 my $tree = shift; 587 my $ARGS = shift || {}; 588 my $op = $tree->[0]; 589 $tree = [@$tree[1..$#$tree]]; 590 591 ### allow for operator function override 592 if (exists $OP_FUNC->{$op}) { 593 return $OP_FUNC->{$op}->($self, $op, $tree, $ARGS); 594 } 595 596 ### do constructors and short-circuitable operators 597 if ($op eq '~' || $op eq '_') { 598 return join "", grep {defined} @{ $self->vivify_args($tree) }; 599 } elsif ($op eq 'arrayref') { 600 return $self->vivify_args($tree, {list_context => 1}); 601 } elsif ($op eq 'hashref') { 602 my $args = $self->vivify_args($tree); 603 push @$args, undef if ! ($#$args % 2); 604 return {@$args}; 605 } elsif ($op eq '?') { 606 if ($self->get_variable($tree->[0])) { 607 return defined($tree->[1]) ? $self->get_variable($tree->[1]) : undef; 608 } else { 609 return defined($tree->[2]) ? $self->get_variable($tree->[2]) : undef; 610 } 611 } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') { 612 for my $node (@$tree) { 613 my $var = $self->get_variable($node); 614 return $var if $var; 615 } 616 return ''; 617 } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') { 618 my $var; 619 for my $node (@$tree) { 620 $var = $self->get_variable($node); 621 return 0 if ! $var; 622 } 623 return $var; 624 625 } elsif ($op eq '!') { 626 my $var = ! $self->get_variable($tree->[0]); 627 return defined($var) ? $var : ''; 628 629 } 630 631 ### equality operators 632 local $^W = 0; 633 my $n = $self->get_variable($tree->[0]); 634 $tree = [@$tree[1..$#$tree]]; 635 if ($op eq '==') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 } 636 elsif ($op eq '!=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 } 637 elsif ($op eq 'eq') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 } 638 elsif ($op eq 'ne') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 } 639 elsif ($op eq '<') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n < $_); $n = $_ }; return 1 } 640 elsif ($op eq '>') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n > $_); $n = $_ }; return 1 } 641 elsif ($op eq '<=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n <= $_); $n = $_ }; return 1 } 642 elsif ($op eq '>=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n >= $_); $n = $_ }; return 1 } 643 elsif ($op eq 'lt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n lt $_); $n = $_ }; return 1 } 644 elsif ($op eq 'gt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n gt $_); $n = $_ }; return 1 } 645 elsif ($op eq 'le') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n le $_); $n = $_ }; return 1 } 646 elsif ($op eq 'ge') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ge $_); $n = $_ }; return 1 } 647 648 ### numeric operators 649 my $args = $self->vivify_args($tree); 650 if (! @$args) { 651 if ($op eq '-') { return - $n } 652 $self->throw('operator', "Not enough args for operator \"$op\""); 653 } 654 if ($op eq '..') { return [($n || 0) .. ($args->[-1] || 0)] } 655 elsif ($op eq '+') { $n += $_ for @$args; return $n } 656 elsif ($op eq '-') { $n -= $_ for @$args; return $n } 657 elsif ($op eq '*') { $n *= $_ for @$args; return $n } 658 elsif ($op eq '/') { $n /= $_ for @$args; return $n } 659 elsif ($op eq 'div' 660 || $op eq 'DIV') { $n = int($n / $_) for @$args; return $n } 661 elsif ($op eq '%' 662 || $op eq 'mod' 663 || $op eq 'MOD') { $n %= $_ for @$args; return $n } 664 elsif ($op eq '**' 665 || $op eq 'pow') { $n **= $_ for @$args; return $n } 666 667 $self->throw('operator', "Un-implemented operation $op"); 668} 669