Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Var.pm

   1 package CGI::Ex::Var;
   2
   3 =head1 NAME
   4
   5 CGI::Ex::Var - Variable and expression parsing and execution for CGI::Ex::Template (and other takers)
   6
   7 =head1 DESCRIPTION
   8
   9 Experimental - The storage structure will change to match CGI::Ex::Template by the next release.
  10
  11 =cut
  12
  13 ###----------------------------------------------------------------###
  14 #  Copyright 2006 - Paul Seamons                                     #
  15 #  Distributed under the Perl Artistic License without warranty      #
  16 ###----------------------------------------------------------------###
  17
  18 use strict;
  19
  20 use vars qw(
  21             $SCALAR_OPS
  22             $FILTER_OPS
  23             $LIST_OPS
  24             $HASH_OPS
  25             $FILTERS
  26
  27             $OPERATORS
  28             $OP_UNARY
  29             $OP_BINARY
  30             $OP_TRINARY
  31
  32             $QR_OP
  33             $QR_OP_UNARY
  34             $QR_OP_PARENED
  35             $QR_COMMENTS
  36             $QR_AQ_NOTDOT
  37             $QR_PRIVATE
  38
  39             $RT_NAMESPACE
  40             $RT_FILTERS
  41             $RT_CONTEXT_SUB
  42             $RT_DEBUG_UNDEF
  43             $RT_UNDEFINED_SUB
  44             $RT_OPERATOR_PRECEDENCE
  45             $RT_DURING_COMPILE
  46
  47             $TT_FILTERS
  48             );
  49 use constant trace => 0;
  50
  51 BEGIN {
  52     $SCALAR_OPS = {
  53         chunk    => \&vmethod_chunk,
  54         collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
  55         defined  => sub { 1 },
  56         indent   => \&vmethod_indent,
  57         'format' => \&vmethod_format,
  58         hash     => sub { {value => $_[0]} },
  59         html     => sub { local $_ = $_[0]; s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; s/\"/&quot;/g; $_ },
  60         lcfirst  => sub { lcfirst $_[0] },
  61         length   => sub { defined($_[0]) ? length($_[0]) : 0 },
  62         lower    => sub { lc $_[0] },
  63         match    => \&vmethod_match,
  64         null     => sub { '' },
  65         remove   => sub { vmethod_replace(shift, shift, '', 1) },
  66         repeat   => \&vmethod_repeat,
  67         replace  => \&vmethod_replace,
  68         search   => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ },
  69         size     => sub { 1 },
  70         split    => \&vmethod_split,
  71         stderr   => sub { print STDERR $_[0]; '' },
  72         substr   => sub { my ($str, $i, $len) = @_; defined($len) ? substr($str, $i, $len) : substr($str, $i) },
  73         trim     => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
  74         ucfirst  => sub { ucfirst $_[0] },
  75         upper    => sub { uc $_[0] },
  76         uri      => sub { local $_ = $_[0]; s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg; $_ },
  77     };
  78
  79     $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops
  80         eval     => [\&filter_eval, 1],
  81         evaltt   => [\&filter_eval, 1],
  82         file     => [\&filter_redirect, 1],
  83         redirect => [\&filter_redirect, 1],
  84     };
  85
  86     $LIST_OPS = {
  87         first   => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
  88         grep    => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
  89         hash    => sub { my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
  90         join    => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
  91         last    => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]},
  92         list    => sub { $_[0] },
  93         max     => sub { $#{ $_[0] } },
  94         merge   => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
  95         nsort   => \&vmethod_nsort,
  96         pop     => sub { pop @{ $_[0] } },
  97         push    => sub { my $ref = shift; push @$ref, @_; return '' },
  98         reverse => sub { [ reverse @{ $_[0] } ] },
  99         shift   => sub { shift  @{ $_[0] } },
 100         size    => sub { scalar @{ $_[0] } },
 101         slice   => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
 102         sort    => \&vmethod_sort,
 103         splice  => \&vmethod_splice,
 104         unique  => sub { my %u; return [ grep { ! $u{$_} ++ } @{ $_[0] } ] },
 105         unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
 106     };
 107
 108     $HASH_OPS = {
 109         defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } },
 110         delete  => sub { return '' if ! defined $_[1]; delete  $_[0]->{ $_[1] } },
 111         each    => sub { [%{ $_[0] }] },
 112         exists  => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
 113         hash    => sub { $_[0] },
 114         import  => sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
 115         keys    => sub { [keys %{ $_[0] }] },
 116         list    => sub { [$_[0]] },
 117         pairs   => sub { [map { {key => $_, value => $_[0]->{$_}} } keys %{ $_[0] } ] },
 118         nsort   => sub { my $ref = shift; [sort {$ref->{$a}    <=> $ref->{$b}   } keys %$ref] },
 119         size    => sub { scalar keys %{ $_[0] } },
 120         sort    => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] },
 121         values  => sub { [values %{ $_[0] }] },
 122     };
 123
 124     ### Runtime set variables that control lookups of various pieces of info
 125     $RT_NAMESPACE   = {};
 126     $RT_FILTERS     = {};
 127     $RT_CONTEXT_SUB = sub { {} };
 128     $RT_DEBUG_UNDEF = 0;
 129     $RT_OPERATOR_PRECEDENCE = 0;
 130
 131     ### setup the operator parsing
 132     $OPERATORS ||= [
 133         # name => # order, precedence, symbols, only_in_parens, sub to create
 134         [2, 96, ['**', '^', 'pow'],  0, sub {bless(shift(), 'CGI::Ex::_pow')}    ],
 135         [1, 93, ['!'],               0, sub {bless(shift(), 'CGI::Ex::_not')}    ],
 136         [1, 93, ['-'],               0, sub {bless(shift(), 'CGI::Ex::_negate')} ],
 137         [2, 90, ['*'],               0, sub {bless(shift(), 'CGI::Ex::_mult')}   ],
 138         [2, 90, ['/'],               0, sub {bless(shift(), 'CGI::Ex::_div')}    ],
 139         [2, 90, ['div', 'DIV'],      0, sub {bless(shift(), 'CGI::Ex::_intdiv')} ],
 140         [2, 90, ['%', 'mod', 'MOD'], 0, sub {bless(shift(), 'CGI::Ex::_mod')}    ],
 141         [2, 85, ['+'],               0, sub {bless(shift(), 'CGI::Ex::_plus')}   ],
 142         [2, 85, ['-'],               0, sub {bless(shift(), 'CGI::Ex::_subtr')}  ],
 143         [2, 85, ['_', '~'],          0, \&_concat                                ],
 144         [2, 80, ['<'],               0, sub {bless(shift(), 'CGI::Ex::_num_lt')} ],
 145         [2, 80, ['>'],               0, sub {bless(shift(), 'CGI::Ex::_num_gt')} ],
 146         [2, 80, ['<='],              0, sub {bless(shift(), 'CGI::Ex::_num_le')} ],
 147         [2, 80, ['>='],              0, sub {bless(shift(), 'CGI::Ex::_num_ge')} ],
 148         [2, 80, ['lt'],              0, sub {bless(shift(), 'CGI::Ex::_str_lt')} ],
 149         [2, 80, ['gt'],              0, sub {bless(shift(), 'CGI::Ex::_str_gt')} ],
 150         [2, 80, ['le'],              0, sub {bless(shift(), 'CGI::Ex::_str_le')} ],
 151         [2, 80, ['ge'],              0, sub {bless(shift(), 'CGI::Ex::_str_ge')} ],
 152         [2, 75, ['==', 'eq'],        0, sub {bless(shift(), 'CGI::Ex::_eq')}     ],
 153         [2, 75, ['!=', 'ne'],        0, sub {bless(shift(), 'CGI::Ex::_ne')}     ],
 154         [2, 70, ['&&'],              0, sub {bless(shift(), 'CGI::Ex::_and')}    ],
 155         [2, 65, ['||'],              0, sub {bless(shift(), 'CGI::Ex::_or')}     ],
 156         [2, 60, ['..'],              0, sub {bless(shift(), 'CGI::Ex::_range')}  ],
 157         [3, 55, ['?', ':'],          0, sub {bless(shift(), 'CGI::Ex::_ifelse')} ],
 158         [2, 52, ['='],               1, sub {bless(shift(), 'CGI::Ex::_set')}    ],
 159         [1, 50, ['not', 'NOT'],      0, sub {bless(shift(), 'CGI::Ex::_not')}    ],
 160         [2, 45, ['and', 'AND'],      0, sub {bless(shift(), 'CGI::Ex::_and')}    ],
 161         [2, 40, ['or', 'OR'],        0, sub {bless(shift(), 'CGI::Ex::_or')}     ],
 162     ];
 163
 164     $OP_UNARY   ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 1} @$OPERATORS};
 165     $OP_BINARY  ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 2} @$OPERATORS};
 166     $OP_TRINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 3} @$OPERATORS};
 167     sub _op_qr { # no mixed \w\W operators
 168         my %used;
 169         my $chrs = join '|', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_;
 170         my $chr  = join '',  map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/}     @_;
 171         my $word = join '|',                    grep {++$used{$_} < 2} grep {/^\w+$/}    @_;
 172         $chr = "[$chr]" if $chr;
 173         $word = "\\b(?:$word)\\b" if $word;
 174         return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex";
 175     }
 176     sub _build_op_qr       { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] > 1 && ! $_->[3]} @$OPERATORS) } # all binary, trinary, non-parened ops
 177     sub _build_op_qr_unary { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] == 1            } @$OPERATORS) } # unary operators
 178     sub _build_op_qr_paren { _op_qr(sort map {@{ $_->[2] }} grep {                 $_->[3]} @$OPERATORS) } # paren
 179     $QR_OP         ||= _build_op_qr();
 180     $QR_OP_UNARY   ||= _build_op_qr_unary();
 181     $QR_OP_PARENED ||= _build_op_qr_paren();
 182
 183     $QR_COMMENTS   = '(?-s: \# .* \s*)*';
 184     $QR_AQ_NOTDOT  = "(?! \\s* $QR_COMMENTS \\.)";
 185     $QR_PRIVATE    = qr/^_/;
 186 };
 187
 188 ###----------------------------------------------------------------###
 189
 190 sub _var     { return bless(shift(), __PACKAGE__        ) }
 191 sub _literal { return bless(shift(), 'CGI::Ex::_literal') }
 192 sub _hash    { return bless(shift(), 'CGI::Ex::_hash'   ) }
 193 sub _array   { return bless(shift(), 'CGI::Ex::_array'  ) }
 194 sub _concat  { return bless(shift(), 'CGI::Ex::_concat' ) }
 195 sub _autobox { return bless(shift(), 'CGI::Ex::_autobox') }
 196 sub _not     { return bless(shift(), 'CGI::Ex::_not'    ) }
 197
 198 sub throw {
 199     require CGI::Ex::Template;
 200     CGI::Ex::Template->throw(@_);
 201 }
 202
 203 ###----------------------------------------------------------------###
 204
 205 sub parse_exp {
 206     my $str_ref = shift;
 207     my $ARGS    = shift || {};
 208
 209     ### allow for custom auto_quoting (such as hash constructors)
 210     if ($ARGS->{'auto_quote'}) {
 211         if ($$str_ref =~ $ARGS->{'auto_quote'}) {
 212             my $str = $1;
 213             substr($$str_ref, 0, length($str), '');
 214             $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox;
 215             return $str;
 216         ### allow for auto-quoted $foo or ${foo.bar} type constructs
 217         } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox
 218                  || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
 219             my $name = $1;
 220             return parse_exp(\$name);
 221         }
 222     }
 223
 224     my $copy = $$str_ref; # copy while parsing to allow for errors
 225
 226     ### test for leading unary operators
 227     my $has_unary;
 228     if ($copy =~ s{ ^ ($QR_OP_UNARY) \s* $QR_COMMENTS }{}ox) {
 229         return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
 230         $has_unary = $1;
 231     }
 232
 233     my @var;
 234     my $is_literal;
 235     my $is_construct;
 236     my $is_namespace;
 237
 238     ### allow for numbers
 239     if ($copy =~ s{ ^ ( (?:\d*\.\d+ | \d+) ) \s* $QR_COMMENTS }{}ox) {
 240         my $number = $1;
 241         push @var, _literal(\ $number);
 242         $is_literal = 1;
 243
 244     ### looks like a normal variable start
 245     } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
 246         push @var, $1;
 247         $is_namespace = 1 if $RT_NAMESPACE->{$1};
 248
 249     ### allow for literal strings
 250     } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) {
 251         if ($1 eq "'") { # no interpolation on single quoted strings
 252             my $str = $2;
 253             $str =~ s{ \\\' }{\'}xg;
 254             push @var, _literal(\ $str);
 255             $is_literal = 1;
 256         } else {
 257             my $str = $2;
 258             $str =~ s/\\n/\n/g;
 259             $str =~ s/\\t/\t/g;
 260             $str =~ s/\\r/\r/g;
 261             $str =~ s/\\([\"\$])/$1/g;
 262             my @pieces = $ARGS->{'auto_quote'}
 263                 ? split(m{ (\$\w+            | \$\{ [^\}]+ \}) }x, $str)  # autoquoted items get a single $\w+ - no nesting
 264                 : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $str);
 265             my $n = 0;
 266             foreach my $piece (@pieces) {
 267                 next if ! ($n++ % 2);
 268                 next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
 269                     && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x;
 270                 my $name = $1;
 271                 $piece = parse_exp(\$name);
 272             }
 273             @pieces = grep {defined && length} @pieces;
 274             if (@pieces == 1 && ! ref $pieces[0]) {
 275                 push @var, _literal(\ $pieces[0]);
 276                 $is_literal = 1;
 277             } elsif (! @pieces) {
 278                 my $str = '';
 279                 push @var, _literal(\ $str);
 280                 $is_literal = 1;
 281             } else {
 282                 push @var, _concat(\@pieces);
 283                 $is_construct = 1;
 284             }
 285         }
 286         if ($ARGS->{'auto_quote'}){
 287             $$str_ref = $copy;
 288             return ${ $var[0] } if $is_literal;
 289             return _var([@var, 0]);
 290         }
 291
 292     ### allow for leading $foo or ${foo.bar} type constructs
 293     } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox
 294         || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
 295         my $name = $1;
 296         push @var, parse_exp(\$name);
 297
 298     ### looks like an array constructor
 299     } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) {
 300         local $RT_OPERATOR_PRECEDENCE = 0; # reset presedence
 301         my $arrayref = [];
 302         while (defined(my $var = parse_exp(\$copy))) {
 303             push @$arrayref, $var;
 304             $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
 305         }
 306         $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox
 307             || throw('parse.missing.square', "Missing close \]", undef, length($$str_ref) - length($copy));
 308         push @var, _array($arrayref);
 309         $is_construct = 1;
 310
 311     ### looks like a hash constructor
 312     } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) {
 313         local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
 314         my $hashref = [];
 315         while (defined(my $key = parse_exp(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) {
 316             $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox;
 317             my $val = parse_exp(\$copy);
 318             push @$hashref, $key, $val;
 319             $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
 320         }
 321         $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox
 322             || throw('parse.missing.curly', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy));
 323         push @var, _hash($hashref);
 324         $is_construct = 1;
 325
 326     ### looks like a paren grouper
 327     } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
 328         local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
 329         my $var = parse_exp(\$copy, {allow_parened_ops => 1});
 330         $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
 331             || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
 332         push @var, $var;
 333         $is_construct = 1;
 334
 335     ### nothing to find - return failure
 336     } else {
 337         return;
 338     }
 339
 340     return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
 341
 342     ### looks for args for the initial
 343     if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
 344         local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
 345         my $args = parse_args(\$copy);
 346         $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
 347             || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
 348         push @var, $args;
 349     } else {
 350         push @var, 0;
 351     }
 352
 353     ### allow for nested items
 354     while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) {
 355         push(@var, $1) if ! $ARGS->{'no_dots'};
 356
 357         ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two
 358         if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox
 359             || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) {
 360             my $name = $1;
 361             my $var = parse_exp(\$name);
 362             push @var, $var;
 363         } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
 364             push @var, $1;
 365         } else {
 366             throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)");
 367         }
 368
 369         ### looks for args for the nested item
 370         if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
 371             local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
 372             my $args = parse_args(\$copy);
 373             $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
 374                 || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
 375             push @var, $args;
 376         } else {
 377             push @var, 0;
 378         }
 379
 380     }
 381
 382     ### flatten literals and constants as much as possible
 383     my $var;
 384     if (@var == 2) {
 385         if ($is_literal) {
 386             $var = ${ $var[0] };
 387         } elsif ($is_construct) {
 388             $var = $var[0];
 389         } else {
 390             $var = _var(\@var);
 391         }
 392     } else {
 393         if ($is_construct && ! $var[0]->does_autobox) {
 394             $var[0] = _autobox([$var[0]]);
 395         }
 396
 397         if ($is_namespace) { # attempt to "fold" constant variables into the parse tree
 398             local $RT_DURING_COMPILE = 1;
 399             $var = _var(\@var)->call({});
 400         } else {
 401             $var = _var(\@var);
 402         }
 403     }
 404
 405     ### allow for all "operators"
 406     if (! $RT_OPERATOR_PRECEDENCE) {
 407         my $tree;
 408         my $found;
 409         while ($copy =~ s{ ^ ($QR_OP) \s* $QR_COMMENTS }{}ox ## look for operators - then move along
 410                || ($ARGS->{'allow_parened_ops'}
 411                    && $copy =~ s{ ^ ($QR_OP_PARENED) \s* $QR_COMMENTS }{}ox) ) {
 412             local $RT_OPERATOR_PRECEDENCE = 1;
 413             my $op   = $1;
 414             my $var2 = parse_exp(\$copy);
 415
 416             ### allow for unary operator precedence
 417             if ($has_unary && (($OP_BINARY->{$op} || $OP_TRINARY->{$op})->[1] < $OP_UNARY->{$has_unary}->[1])) {
 418                 if ($tree) {
 419                     if (@$tree == 2) { # only one operator - keep simple things fast
 420                         $var = $OP_BINARY->{$tree->[0]}->[4]->([$var, $tree->[1]]);
 421                     } else {
 422                         unshift @$tree, $var;
 423                         $var = apply_precedence($tree, $found);
 424                     }
 425                     undef $tree;
 426                     undef $found;
 427                 }
 428                 $var = $OP_UNARY->{$has_unary}->[4]->([$var]);
 429                 undef $has_unary;
 430             }
 431
 432             ### add the operator to the tree
 433             push (@{ $tree ||= [] }, $op, $var2);
 434             my $ref = $OP_BINARY->{$op} || $OP_TRINARY->{$op};
 435             $found->{$op} = $ref->[1];
 436         }
 437
 438         ### if we found operators - tree the nodes by operator precedence
 439         if ($tree) {
 440             if (@$tree == 2 && $OP_BINARY->{$tree->[0]}) { # only one operator - keep simple things fast
 441                 $var = $OP_BINARY->{$tree->[0]}->[4]->([$var, $tree->[1]]);
 442             } else {
 443                 unshift @$tree, $var;
 444                 $var = apply_precedence($tree, $found);
 445             }
 446         }
 447     }
 448
 449     ### allow for unary on non-chained variables
 450     if ($has_unary) {
 451         $var = $OP_UNARY->{$has_unary}->[4]->([$var]);
 452     }
 453
 454     $$str_ref = $copy; # commit the changes
 455     return $var;
 456 }
 457
 458 ### this is used to put the parsed variables into the correct operations tree
 459 sub apply_precedence {
 460     my ($tree, $found) = @_;
 461
 462     my @var;
 463     my $trees;
 464     ### look at the operators we found in the order we found them
 465     for my $op (sort {$found->{$a} <=> $found->{$b}} keys %$found) {
 466         local $found->{$op};
 467         delete $found->{$op};
 468         my @trees;
 469         my @trinary;
 470
 471         ### split the array on the current operator
 472         for (my $i = 0; $i <= $#$tree; $i ++) {
 473             my $is_trinary = $OP_TRINARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP_TRINARY->{$op}->[2] };
 474             next if $tree->[$i] ne $op && ! $is_trinary;
 475             push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator
 476             push @trinary, $tree->[0] if $is_trinary;
 477             shift @$tree; # pull off the operator
 478             $i = -1;
 479         }
 480         next if ! @trees; # this iteration didn't have the current operator
 481         push @trees, $tree if scalar @$tree; # elements after last operator
 482
 483         ### now - for this level split on remaining operators, or add the variable to the tree
 484         for my $node (@trees) {
 485             if (@$node == 1) {
 486                 $node = $node->[0]; # single item - its not a tree
 487             } elsif (@$node == 3) {
 488                 my $ref = $OP_BINARY->{$node->[1]} || $OP_TRINARY->{$node->[1]};
 489                 $node = $ref->[4]->([$node->[0], $node->[2]]); # single operator - put it straight on
 490             } else {
 491                 $node = apply_precedence($node, $found); # more complicated - recurse
 492             }
 493         }
 494
 495         ### return binary
 496         if ($OP_BINARY->{$op}) {
 497             my $val = $trees[0];
 498             $val = $OP_BINARY->{$op}->[4]->([$val, $trees[$_]]) for 1 .. $#trees;
 499             return $val;
 500         }
 501
 502         ### return simple trinary
 503         if (@trinary == 2) {
 504             return $OP_TRINARY->{$op}->[4]->(\@trees);
 505         }
 506
 507         ### reorder complex trinary - rare case
 508         while ($#trinary >= 1) {
 509             ### if we look starting from the back - the first lead trinary op will always be next to its matching op
 510             for (my $i = $#trinary; $i >= 0; $i --) {
 511                 next if $OP_TRINARY->{$trinary[$i]}->[2]->[1] eq $trinary[$i];
 512                 my ($op, $op2) = splice @trinary, $i, 2, (); # remove the found pair of operators
 513                 my $node = $OP_TRINARY->{$op}->[4]->([@trees[$i .. $i + 2]]);
 514                 splice @trees, $i, 3, $node; # replace the previous 3 pieces with the one new node
 515             }
 516         }
 517         return $trees[0]; # at this point the trinary has been reduced to a single operator
 518
 519     }
 520
 521     throw('parse', "Couldn't apply precedence");
 522 }
 523
 524 ### look for arguments - both positional and named
 525 sub parse_args {
 526     my $str_ref = shift;
 527     my $ARGS    = shift || {};
 528     my $copy    = $$str_ref;
 529
 530     my @args;
 531     my @named;
 532     while (length $$str_ref) {
 533         my $copy = $$str_ref;
 534         if (defined(my $name = parse_exp(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
 535             && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
 536             throw('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'};
 537             my $val = parse_exp(\$copy);
 538             $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
 539             push @named, $name, $val;
 540             $$str_ref = $copy;
 541         } elsif (defined(my $arg = parse_exp($str_ref))) {
 542             push @args, $arg;
 543             $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
 544         } else {
 545             last;
 546         }
 547     }
 548
 549     ### allow for named arguments to be added also
 550     push @args, _hash(\@named) if scalar @named;
 551
 552     return \@args;
 553 }
 554
 555 sub get_exp { ref($_[0]) ? $_[0]->call($_[1]) : $_[0] }
 556
 557 sub set_exp {
 558     my $var = shift;
 559     $var = _var([$var, 0]) if ! ref $var; # allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %])
 560     return $var->set($_[0], $_[1]);
 561 }
 562
 563
 564 sub dump_parse {
 565     my $str = shift;
 566     require Data::Dumper;
 567     return Data::Dumper::Dumper(parse_exp(\$str));
 568 }
 569
 570 sub dump_get {
 571     my ($str, $hash) = @_;
 572     require Data::Dumper;
 573     return Data::Dumper::Dumper(get_exp(parse_exp(\$str), $hash));
 574 }
 575
 576 sub dump_set {
 577     my ($str, $val, $hash) = @_;
 578     $hash ||= {};
 579     require Data::Dumper;
 580     set_exp(parse_exp(\$str), $val, $hash);
 581     return Data::Dumper::Dumper($hash);
 582 }
 583
 584 sub vivify_args {
 585     my $vars = shift;
 586     my $hash = shift;
 587     return [map {get_exp($_, $hash)} @$vars];
 588 }
 589
 590 ###----------------------------------------------------------------###
 591
 592 sub new {
 593     my $class = shift;
 594     return bless $_[0], $class;
 595 }
 596
 597 sub does_autobox { 0 }
 598
 599 sub call {
 600     my $self = shift;
 601     my $hash = shift || {};
 602     my $i    = 0;
 603
 604     ### determine the top level of this particular variable access
 605     my $ref  = $self->[$i++];
 606     my $args = $self->[$i++];
 607     warn "CGI::Ex::Var::call: begin \"$ref\"\n" if trace;
 608
 609     if (ref $ref) {
 610         if ($ref->does_autobox) {
 611             $ref = $ref->call($hash);
 612         } else {
 613             $ref = $ref->call($hash);
 614             return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
 615             $ref = $hash->{$ref};
 616         }
 617     } else {
 618         if ($RT_DURING_COMPILE) {
 619             $ref = $RT_NAMESPACE->{$ref};
 620         } else {
 621             return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
 622             $ref = $hash->{$ref};
 623         }
 624     }
 625
 626     my %seen_filters;
 627     while (defined $ref) {
 628
 629         ### check at each point if the returned thing was a code
 630         if (UNIVERSAL::isa($ref, 'CODE')) {
 631             my @results = $ref->($args ? (map {get_exp($_, $hash)} @$args) : ());
 632             if (defined $results[0]) {
 633                 $ref = ($#results > 0) ? \@results : $results[0];
 634             } elsif (defined $results[1]) {
 635                 die $results[1]; # TT behavior - why not just throw ?
 636             } else {
 637                 $ref = undef;
 638                 last;
 639             }
 640         }
 641
 642         ### descend one chained level
 643         last if $i >= $#$self;
 644         my $was_dot_call = $self->[$i++] eq '.';
 645         my $name         = $self->[$i++];
 646         my $args         = $self->[$i++];
 647         warn "CGI::Ex::Var::get_exp: nested \"$name\"\n" if trace;
 648
 649         ### allow for named portions of a variable name (foo.$name.bar)
 650         if (ref $name) {
 651             $name = $name->call($hash);
 652             if (! defined $name) {
 653                 $ref = undef;
 654                 last;
 655             }
 656         }
 657
 658         if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
 659             $ref = undef;
 660             last;
 661         }
 662
 663         ### allow for scalar and filter access (this happens for every non virtual method call)
 664         if (! ref $ref) {
 665             if ($SCALAR_OPS->{$name}) {                        # normal scalar op
 666                 $ref = $SCALAR_OPS->{$name}->($ref, $args ? (map {get_exp($_, $hash)} @$args) : ());
 667
 668             } elsif ($LIST_OPS->{$name}) {                     # auto-promote to list and use list op
 669                 $ref = $LIST_OPS->{$name}->([$ref], $args ? (map {get_exp($_, $hash)} @$args) : ());
 670
 671             } elsif (my $filter = $RT_FILTERS->{$name}           # filter configured in Template args
 672                      || $FILTER_OPS->{$name}                     # predefined filters in CET
 673                      || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
 674                      || list_filters()->{$name}) {               # filter defined in Template::Filters
 675
 676                 if (UNIVERSAL::isa($filter, 'CODE')) {
 677                     $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
 678                     if (my $err = $@) {
 679                         throw('filter', $err) if ref($err) !~ /Template::Exception$/;
 680                         die $err;
 681                     }
 682                 } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
 683                     throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
 684
 685                 } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
 686                     eval {
 687                         my $sub = $filter->[0];
 688                         if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
 689                             ($sub, my $err) = $sub->($RT_CONTEXT_SUB->(), $args ? (map {get_exp($_, $hash)} @$args) : ());
 690                             if (! $sub && $err) {
 691                                 throw('filter', $err) if ref($err) !~ /Template::Exception$/;
 692                                 die $err;
 693                             } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
 694                                 throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
 695                                     if ref($sub) !~ /Template::Exception$/;
 696                                 die $sub;
 697                             }
 698                         }
 699                         $ref = $sub->($ref);
 700                     };
 701                     if (my $err = $@) {
 702                         throw('filter', $err) if ref($err) !~ /Template::Exception$/;
 703                         die $err;
 704                     }
 705                 } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
 706                     throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
 707                     $self = [$name, 0, '|', @$filter, @{$self}[$i..$#$self]]; # splice the filter into our current tree
 708                     $i = 2;
 709                 }
 710                 if (scalar keys %seen_filters
 711                     && $seen_filters{$self->[$i - 5] || ''}) {
 712                     throw('filter', "invalid FILTER entry for '".$self->[$i - 5]."' (not a CODE ref)");
 713                 }
 714             } else {
 715                 $ref = undef;
 716             }
 717
 718         } else {
 719
 720             ### method calls on objects
 721             if (UNIVERSAL::can($ref, 'can')) {
 722                 my @args = $args ? (map {get_exp($_, $hash)} @$args) : ();
 723                 my @results = eval { $ref->$name(@args) };
 724                 if ($@) {
 725                     die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
 726                 } elsif (defined $results[0]) {
 727                     $ref = ($#results > 0) ? \@results : $results[0];
 728                     next;
 729                 } elsif (defined $results[1]) {
 730                     die $results[1]; # TT behavior - why not just throw ?
 731                 } else {
 732                     $ref = undef;
 733                     last;
 734                 }
 735                 # didn't find a method by that name - so fail down to hash and array access
 736             }
 737
 738             ### hash member access
 739             if (UNIVERSAL::isa($ref, 'HASH')) {
 740                 if ($was_dot_call && exists($ref->{$name}) ) {
 741                     $ref = $ref->{$name};
 742                 } elsif ($HASH_OPS->{$name}) {
 743                     $ref = $HASH_OPS->{$name}->($ref, $args ? (map {get_exp($_, $hash)} @$args) : ());
 744                 } elsif ($RT_DURING_COMPILE) {
 745                     return $self; # abort - can't fold namespace variable
 746                 } else {
 747                     $ref = undef;
 748                 }
 749
 750             ### array access
 751             } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
 752                 if ($name =~ /^\d+$/) {
 753                     $ref = ($name > $#$ref) ? undef : $ref->[$name];
 754                 } else {
 755                     $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? (map {get_exp($_, $hash)} @$args) : ());
 756                 }
 757             }
 758         }
 759
 760     } # end of while
 761
 762     ### allow for undefinedness
 763     if (! defined $ref) {
 764         if ($RT_DEBUG_UNDEF) {
 765             my $chunk = $self->[$i - 2];
 766             $chunk = $chunk->call($hash) if ref $chunk;
 767             die "$chunk is undefined\n";
 768         } else {
 769             $ref = $self->undefined_any($self);
 770         }
 771     }
 772
 773     return $ref;
 774 }
 775
 776 sub undefined_any { $RT_UNDEFINED_SUB ? $RT_UNDEFINED_SUB->(@_) : undef }
 777
 778 sub set {
 779     my ($self, $val, $hash) = @_;
 780     my $i = 0;
 781
 782     ### determine the top level of this particular variable access
 783     my $ref  = $self->[$i++];
 784     my $args = $self->[$i++];
 785
 786     if (ref $ref) {
 787         $ref = $ref->call($hash);
 788         return if ! defined $ref;
 789     }
 790
 791     return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
 792
 793     if ($#$self <= $i) {
 794         $hash->{$ref} = $val;
 795         return;
 796     } else {
 797         $ref = $hash->{$ref} ||= {};
 798     }
 799
 800     ### let the top level thing be a code block
 801     return if UNIVERSAL::isa($ref, 'CODE');
 802
 803     ### vivify the chained levels
 804     while (defined $ref && $#$self > $i) {
 805         my $was_dot_call = $self->[$i++] eq '.';
 806         my $name         = $self->[$i++];
 807         my $args         = $self->[$i++];
 808
 809         ### allow for named portions of a variable name (foo.$name.bar)
 810         if (ref $name) {
 811             $name = $name->call($hash);
 812             if (! defined $name) {
 813                 $ref = undef;
 814                 last;
 815             }
 816         }
 817
 818         if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
 819             return;
 820         }
 821
 822         ### method calls on objects
 823         if (UNIVERSAL::can($ref, 'can')) {
 824             my $lvalueish;
 825             my @args = $args ? (map {get_exp($_, $hash)} @$args) : ();
 826             if ($i >= $#$self) {
 827                 $lvalueish = 1;
 828                 push @args, $val;
 829             }
 830             my @results = eval { $ref->$name(@args) };
 831             if ($@) {
 832                 die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
 833             } elsif (defined $results[0]) {
 834                 $ref = ($#results > 0) ? \@results : $results[0];
 835             } elsif (defined $results[1]) {
 836                 die $results[1]; # TT behavior - why not just throw ?
 837             } else {
 838                 $ref = undef;
 839             }
 840             return if $lvalueish;
 841             next;
 842         }
 843
 844         ### hash member access
 845         if (UNIVERSAL::isa($ref, 'HASH')) {
 846             if ($#$self <= $i) {
 847                 $ref->{$name} = $val;
 848                 return;
 849             } else {
 850                 $ref = $ref->{$name} ||= {};
 851                 next;
 852             }
 853
 854         ### array access
 855         } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
 856             if ($name =~ /^\d+$/) {
 857                 if ($#$self <= $i) {
 858                     $ref->[$name] = $val;
 859                     return;
 860                 } else {
 861                     $ref = $ref->[$name] ||= {};
 862                     next;
 863                 }
 864             } else {
 865                 return;
 866             }
 867
 868         ### scalar access
 869         } elsif (! ref($ref) && defined($ref)) {
 870             return;
 871         }
 872
 873         ### check at each point if the returned thing was a code
 874         if (defined($ref) && UNIVERSAL::isa($ref, 'CODE')) {
 875             my @results = $ref->($args ? (map {get_exp($_, $hash)} @$args) : ());
 876             if (defined $results[0]) {
 877                 $ref = ($#results > 0) ? \@results : $results[0];
 878             } elsif (defined $results[1]) {
 879                 die $results[1]; # TT behavior - why not just throw ?
 880             } else {
 881                 return;
 882             }
 883         }
 884
 885     }
 886
 887     return $ref;
 888 }
 889
 890 ###----------------------------------------------------------------###
 891 ### filters and vmethod definition
 892
 893 sub list_filters {
 894     return $TT_FILTERS ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {};
 895 }
 896
 897 sub vmethod_chunk {
 898     my $str  = shift;
 899     my $size = shift || 1;
 900     my @list;
 901     if ($size < 0) { # chunk from the opposite end
 902         $str = reverse $str;
 903         $size = -$size;
 904         unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg;
 905     } else {
 906         push(@list, $1)                   while $str =~ /( .{$size} | .+ )/xg;
 907     }
 908     return \@list;
 909 }
 910
 911 sub vmethod_indent {
 912     my $str = shift; $str = '' if ! defined $str;
 913     my $pre = shift; $pre = 4  if ! defined $pre;
 914     $pre = ' ' x $pre if $pre =~ /^\d+$/;
 915     $str =~ s/^/$pre/mg;
 916     return $str;
 917 }
 918
 919 sub vmethod_format {
 920     my $str = shift; $str = ''   if ! defined $str;
 921     my $pat = shift; $pat = '%s' if ! defined $pat;
 922     return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
 923 }
 924
 925 sub vmethod_match {
 926     my ($str, $pat, $global) = @_;
 927     return [] if ! defined $str || ! defined $pat;
 928     my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
 929     return (@res >= 2) ? \@res : (@res == 1) ? $res[0] : '';
 930 }
 931
 932 sub vmethod_nsort {
 933     my ($list, $field) = @_;
 934     return defined($field)
 935         ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field}
 936                                                                : UNIVERSAL::can($_, $field) ? $_->$field()
 937                                                                : $_)]} @$list ]
 938         : [sort {$a <=> $b} @$list];
 939 }
 940
 941 sub vmethod_repeat {
 942     my ($str, $n, $join) = @_;
 943     return if ! length $str;
 944     $n = 1 if ! defined($n) || ! length $n;
 945     $join = '' if ! defined $join;
 946     return join $join, ($str) x $n;
 947 }
 948
 949 ### This method is a combination of my submissions along
 950 ### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum
 951 sub vmethod_replace {
 952     my ($text, $pattern, $replace, $global) = @_;
 953     $text      = '' unless defined $text;
 954     $pattern   = '' unless defined $pattern;
 955     $replace   = '' unless defined $replace;
 956     $global    = 1  unless defined $global;
 957     my $expand = sub {
 958         my ($chunk, $start, $end) = @_;
 959         $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{
 960             $1 ? $1
 961                 : ($2 > $#$start || $2 == 0) ? ''
 962                 : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
 963         }exg;
 964         $chunk;
 965     };
 966     if ($global) {
 967         $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg;
 968     } else {
 969         $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e;
 970     }
 971     return $text;
 972 }
 973
 974 sub vmethod_sort {
 975     my ($list, $field) = @_;
 976     return defined($field)
 977         ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field}
 978                                                                  : UNIVERSAL::can($_, $field) ? $_->$field()
 979                                                                  : $_)]} @$list ]
 980         : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive
 981 }
 982
 983 sub vmethod_splice {
 984     my ($ref, $i, $len, @replace) = @_;
 985     @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
 986     if (defined $len) {
 987         return [splice @$ref, $i || 0, $len, @replace];
 988     } else {
 989         return [splice @$ref, $i || 0];
 990     }
 991 }
 992
 993 sub vmethod_split {
 994     my ($str, $pat, @args) = @_;
 995     $str = '' if ! defined $str;
 996     return defined $pat ? [split $pat, $str, @args] : [split ' ', $str, @args];
 997 }
 998
 999 sub filter_eval {
1000     my $context = shift;
1001     return sub {
1002         my $text = shift;
1003         return $context->process(\$text);
1004     };
1005 }
1006
1007 sub filter_redirect {
1008     my ($context, $file, $options) = @_;
1009     my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set');
1010
1011     return sub {
1012         my $text = shift;
1013         if (! -d $path) {
1014             require File::Path;
1015             File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
1016         }
1017         local *FH;
1018         open (FH, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
1019         if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) {
1020             if (+$bm == 1) { binmode FH }
1021             else { binmode FH, $bm}
1022         }
1023         print FH $text;
1024         close FH;
1025         return '';
1026     };
1027 }
1028
1029 ###----------------------------------------------------------------###
1030 ### "here be dragons"
1031
1032 package CGI::Ex::_literal;
1033 sub call { ${ $_[0] } }
1034 sub set {}
1035 sub does_autobox { 1 }
1036
1037 package CGI::Ex::_autobox;
1038 sub call { $_[0]->[0]->call($_[1]) }
1039 sub set {}
1040 sub does_autobox { 1 }
1041
1042 package CGI::Ex::_concat;
1043 sub call { join "", grep {defined} map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] } }
1044 sub set {}
1045 sub does_autobox { 1 }
1046
1047 package CGI::Ex::_hash;
1048 sub call { return {map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] }} }
1049 sub set {}
1050 sub does_autobox { 1 }
1051
1052 package CGI::Ex::_array;
1053 sub call { return [map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] }] }
1054 sub set {}
1055 sub does_autobox { 1 }
1056
1057 package CGI::Ex::_set;
1058 sub call {
1059     my ($var, $val) = @{ $_[0] };
1060     $val = CGI::Ex::Var::get_exp($val, $_[1]);
1061     CGI::Ex::Var::set_exp($var, $val, $_[1]);
1062     return $val;
1063 }
1064 sub set {}
1065 sub does_autobox { 1 }
1066
1067
1068 package CGI::Ex::_not;
1069 sub call { ! (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || '' }
1070 sub set {}
1071 sub does_autobox { 0 }
1072
1073 package CGI::Ex::_and;
1074 sub call { (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  &&  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1075 sub set {}
1076 sub does_autobox { 0 }
1077
1078 package CGI::Ex::_or;
1079 sub call { ((ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  ||  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1])) || '' }
1080 sub set {}
1081 sub does_autobox { 0 }
1082
1083 package CGI::Ex::_ifelse;
1084 sub call {
1085     (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])
1086         ? (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1])
1087         : (ref($_[0]->[2]) ? $_[0]->[2]->call($_[1]) : $_[0]->[2]);
1088 }
1089 sub set {}
1090 sub does_autobox { 0 }
1091
1092 package CGI::Ex::_str_lt;
1093 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  lt  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1094 sub set {}
1095 sub does_autobox { 0 }
1096
1097 package CGI::Ex::_str_gt;
1098 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  gt  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1099 sub set {}
1100 sub does_autobox { 0 }
1101
1102 package CGI::Ex::_str_le;
1103 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  le  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1104 sub set {}
1105 sub does_autobox { 0 }
1106
1107 package CGI::Ex::_str_ge;
1108 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  ge  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1109 sub set {}
1110 sub does_autobox { 0 }
1111
1112 package CGI::Ex::_eq;
1113 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  eq  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1114 sub set {}
1115 sub does_autobox { 0 }
1116
1117 package CGI::Ex::_ne;
1118 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  ne  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1119 sub set {}
1120 sub does_autobox { 0 }
1121
1122 package CGI::Ex::_negate;
1123 sub call { local $^W; 0 - (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) }
1124 sub set {}
1125 sub does_autobox { 0 }
1126
1127 package CGI::Ex::_pow;
1128 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  **  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1129 sub set {}
1130 sub does_autobox { 0 }
1131
1132 package CGI::Ex::_mult;
1133 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  *   (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1134 sub set {}
1135 sub does_autobox { 0 }
1136
1137 package CGI::Ex::_div;
1138 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  /   (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1139 sub set {}
1140 sub does_autobox { 0 }
1141
1142 package CGI::Ex::_intdiv;
1143 sub call { local $^W; int( (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  /   (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) ) }
1144 sub set {}
1145 sub does_autobox { 0 }
1146
1147 package CGI::Ex::_mod;
1148 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  %   (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1149 sub set {}
1150 sub does_autobox { 0 }
1151
1152 package CGI::Ex::_plus;
1153 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  +   (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1154 sub set {}
1155 sub does_autobox { 0 }
1156
1157 package CGI::Ex::_subtr;
1158 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  -   (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1159 sub set {}
1160 sub does_autobox { 0 }
1161
1162 package CGI::Ex::_num_lt;
1163 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  <   (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1164 sub set {}
1165 sub does_autobox { 0 }
1166
1167 package CGI::Ex::_num_gt;
1168 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  >   (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1169 sub set {}
1170 sub does_autobox { 0 }
1171
1172 package CGI::Ex::_num_le;
1173 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  <=  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1174 sub set {}
1175 sub does_autobox { 0 }
1176
1177 package CGI::Ex::_num_ge;
1178 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])  >=  (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1179 sub set {}
1180 sub does_autobox { 0 }
1181
1182 package CGI::Ex::_range;
1183 sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || 0 .. (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) || 0 }
1184 sub set {}
1185 sub does_autobox { 0 }
1186
1187 ###----------------------------------------------------------------###
1188
1189 =head1 DESCRIPTION
1190
1191 Experimental.  An attempt for abstracting out a fast parser and hash
1192 from CGI::Ex::Template.  It is functional - but currently too
1193 cumbersome for use in CET.
1194
1195 =cut
1196
1197 1;