Dogcows Code - chaz/p5-CGI-Ex/blob - samples/benchmark/bench_optree.pl

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