site/cgi-bin/modules/Squirrel/Template/Expr.pm

   1 package Squirrel::Template::Expr;
   2 use strict;
   3
   4 our $VERSION = "1.016";
   5
   6 package Squirrel::Template::Expr::Eval;
   7 use Scalar::Util ();
   8 use Squirrel::Template::Expr::WrapScalar;
   9 use Squirrel::Template::Expr::WrapHash;
  10 use Squirrel::Template::Expr::WrapArray;
  11 use Squirrel::Template::Expr::WrapCode;
  12 use Squirrel::Template::Expr::WrapClass;
  13
  14 use constant TMPL => 0;
  15 use constant ACTS => 1;
  16
  17 sub new {
  18   my ($class, $templater, $acts) = @_;
  19
  20   return bless [ $templater, $acts ], $class;
  21 }
  22
  23 sub _wrapped {
  24   my ($self, $val) = @_;
  25
  26   if (ref($val)) {
  27     if (Scalar::Util::blessed($val)) {
  28       return $val;
  29     }
  30     else {
  31       my $type = Scalar::Util::reftype($val);
  32       if ($type eq "ARRAY") {
  33         return Squirrel::Template::Expr::WrapArray->new($val, $self->[TMPL], undef, $self);
  34       }
  35       elsif ($type eq "HASH") {
  36         return Squirrel::Template::Expr::WrapHash->new($val, $self->[TMPL], undef, $self);
  37       }
  38       elsif ($type eq "CODE") {
  39         return Squirrel::Template::Expr::WrapCode->new($val, $self->[TMPL], undef, $self);
  40       }
  41     }
  42   }
  43   else {
  44     return Squirrel::Template::Expr::WrapScalar->new($val, $self->[TMPL], $self->[ACTS], $self);
  45   }
  46 }
  47
  48 sub _process_var {
  49   return $_[0][TMPL]->get_var($_[1][1]);
  50 }
  51
  52 sub _process_add {
  53   return $_[0]->process($_[1][1]) + $_[0]->process($_[1][2]);
  54 }
  55
  56 sub _process_subtract {
  57   return $_[0]->process($_[1][1]) - $_[0]->process($_[1][2]);
  58 }
  59
  60 sub _process_mult {
  61   return $_[0]->process($_[1][1]) * $_[0]->process($_[1][2]);
  62 }
  63
  64 sub _process_fdiv {
  65   return $_[0]->process($_[1][1]) / $_[0]->process($_[1][2]);
  66 }
  67
  68 sub _process_div {
  69   return int($_[0]->process($_[1][1]) / $_[0]->process($_[1][2]));
  70 }
  71
  72 sub _process_mod {
  73   return $_[0]->process($_[1][1]) % $_[0]->process($_[1][2]);
  74 }
  75
  76 sub _process_undef {
  77   return undef;
  78 }
  79
  80 # string relops
  81 sub _process_eq {
  82   return $_[0]->process($_[1][1]) eq $_[0]->process($_[1][2]);
  83 }
  84
  85 sub _process_ne {
  86   return $_[0]->process($_[1][1]) ne $_[0]->process($_[1][2]);
  87 }
  88
  89 sub _process_gt {
  90   return $_[0]->process($_[1][1]) gt $_[0]->process($_[1][2]);
  91 }
  92
  93 sub _process_lt {
  94   return $_[0]->process($_[1][1]) lt $_[0]->process($_[1][2]);
  95 }
  96
  97 sub _process_ge {
  98   return $_[0]->process($_[1][1]) ge $_[0]->process($_[1][2]);
  99 }
 100
 101 sub _process_le {
 102   return $_[0]->process($_[1][1]) le $_[0]->process($_[1][2]);
 103 }
 104
 105 sub _process_cmp {
 106   return $_[0]->process($_[1][1]) cmp $_[0]->process($_[1][2]);
 107 }
 108
 109 # number relops
 110 sub _process_neq {
 111   return $_[0]->process($_[1][1]) == $_[0]->process($_[1][2]);
 112 }
 113
 114 sub _process_nne {
 115   return $_[0]->process($_[1][1]) != $_[0]->process($_[1][2]);
 116 }
 117
 118 sub _process_ngt {
 119   return $_[0]->process($_[1][1]) > $_[0]->process($_[1][2]);
 120 }
 121
 122 sub _process_nlt {
 123   return $_[0]->process($_[1][1]) < $_[0]->process($_[1][2]);
 124 }
 125
 126 sub _process_nge {
 127   return $_[0]->process($_[1][1]) >= $_[0]->process($_[1][2]);
 128 }
 129
 130 sub _process_nle {
 131   return $_[0]->process($_[1][1]) <= $_[0]->process($_[1][2]);
 132 }
 133
 134 sub _process_match {
 135   return $_[0]->process($_[1][1]) =~ $_[0]->process($_[1][2]);
 136 }
 137
 138 sub _process_notmatch {
 139   return $_[0]->process($_[1][1]) !~ $_[0]->process($_[1][2]);
 140 }
 141
 142 sub _process_cond {
 143   return $_[0]->process($_[1][1]) ? $_[0]->process($_[1][2]) : $_[0]->process($_[1][3]);
 144 }
 145
 146 sub _process_ncmp {
 147   return $_[0]->process($_[1][1]) <=> $_[0]->process($_[1][2]);
 148 }
 149
 150 sub _process_uminus {
 151   return - ($_[0]->process($_[1][1]));
 152 }
 153
 154 sub _process_concat {
 155   return $_[0]->process($_[1][1]) . $_[0]->process($_[1][2]);
 156 }
 157
 158 sub _process_const {
 159   return $_[1][1];
 160 }
 161
 162 sub _process_block {
 163   return bless [ $_[1][1], $_[1][2] ], "Squirrel::Template::Expr::Block";
 164 }
 165
 166 sub _do_call {
 167   my ($self, $val, $args, $method, $ctx) = @_;
 168
 169   if (Scalar::Util::blessed($val)
 170       && !$val->isa("Squirrel::Template::Expr::WrapBase")) {
 171     $val->can($method)
 172       or die [ error => "No such method $method" ];
 173     if ($val->can("restricted_method")) {
 174       $val->restricted_method($method)
 175         and die [ error => "method $method is restricted" ];
 176     }
 177     return $ctx && $ctx eq 'LIST' ? $val->$method(@$args)
 178       : scalar($val->$method(@$args));
 179   }
 180   else {
 181     my $wrapped = $self->_wrapped($val);
 182     return $wrapped->call($method, $args, $ctx);
 183   }
 184 }
 185
 186 sub _process_call {
 187   my ($self, $node, $ctx) = @_;
 188
 189   $ctx ||= "";
 190
 191   my $val = $self->process($node->[2]);
 192   my $args = $self->process_list($node->[3]);
 193   my $method = $node->[1];
 194
 195   return $self->_do_call($val, $args, $method, $ctx);
 196 }
 197
 198 sub _process_callvar {
 199   my ($self, $node, $ctx) = @_;
 200
 201   $ctx ||= "";
 202
 203   my $val = $self->process($node->[2]);
 204   my $args = $self->process_list($node->[3]);
 205   my $method = $self->[TMPL]->get_var($node->[1]);
 206
 207   return $self->_do_call($val, $args, $method, $ctx);
 208 }
 209
 210 sub _do_callblock {
 211   my ($self, $ids, $exprs, $args) = @_;
 212
 213   my $result;
 214   my %args;
 215   @args{@$ids} = @$args;
 216   $args{_arguments} = $args;
 217   if (eval { $self->[TMPL]->start_scope("calling block", \%args), 1}) {
 218     for my $expr (@$exprs) {
 219       $result = $self->process($expr);
 220     }
 221     $self->[TMPL]->end_scope();
 222   }
 223
 224   return $result;
 225 }
 226
 227 sub call_function {
 228   my ($self, $code, $args, $ctx) = @_;
 229
 230   $ctx ||= "";
 231
 232   if (Scalar::Util::reftype($code) eq "CODE") {
 233     return $ctx eq "LIST" ? $code->(@$args) : scalar($code->(@$args));
 234   }
 235   elsif (Scalar::Util::blessed($code)
 236          && $code->isa("Squirrel::Template::Expr::Block")) {
 237     return $self->_do_callblock($code->[0], $code->[1], $args);
 238   }
 239   else {
 240     die [ error => "can't call non code as a function" ];
 241   }
 242 }
 243
 244 sub _process_funccall {
 245   my ($self, $node, $ctx) = @_;
 246
 247   my $code = $self->process($node->[1]);
 248   my $args = $self->process_list($node->[2]);
 249
 250   return $self->call_function($code, $args, $ctx);
 251 }
 252
 253 sub _process_list {
 254   my ($self, $node) = @_;
 255
 256   return $self->process_list($node->[1], 'LIST');
 257 }
 258
 259 sub _process_range {
 260   my ($self, $node, $ctx) = @_;
 261
 262   my $start = $self->process($node->[1]);
 263   my $end = $self->process($node->[2]);
 264
 265   return $ctx eq 'LIST' ? ( $start .. $end ) : [ $start .. $end ];
 266 }
 267
 268 sub _process_hash {
 269   my ($self, $node) = @_;
 270
 271   my %result;
 272   for my $pair (@{$node->[1]}) {
 273     my $key = $self->process($pair->[0]);
 274     my $value = $self->process($pair->[1]);
 275     $result{$key} = $value;
 276   }
 277
 278   return \%result;
 279 }
 280
 281 sub _process_subscript {
 282   my ($self, $node) = @_;
 283
 284   my $list = $self->process($node->[1]);
 285   my $index = $self->process($node->[2]);
 286   Scalar::Util::blessed($list)
 287       and die [ error => "Cannot subscript an object" ];
 288   my $type = Scalar::Util::reftype($list);
 289   if ($type eq "HASH") {
 290     return $list->{$index};
 291   }
 292   elsif ($type eq "ARRAY") {
 293     return $list->[$index];
 294   }
 295   else {
 296     die [ error => "Cannot subscript a $type" ];
 297   }
 298 }
 299
 300 sub _process_not {
 301   return !$_[0]->process($_[1][1]);
 302 }
 303
 304 sub _process_or {
 305   return $_[0]->process($_[1][1]) || $_[0]->process($_[1][2]);
 306 }
 307
 308 sub _process_and {
 309   return $_[0]->process($_[1][1]) && $_[0]->process($_[1][2]);
 310 }
 311
 312 sub process {
 313   my ($self, $node, $ctx) = @_;
 314
 315   my $method = "_process_$node->[0]";
 316   $self->can($method) or die "No handler for $node->[0]";
 317   return $self->$method($node, $ctx);
 318 }
 319
 320 sub process_list {
 321   my ($self, $list) = @_;
 322
 323   return [ map $self->process($_, 'LIST'), @$list ];
 324 }
 325
 326 package Squirrel::Template::Expr::Parser;
 327
 328 sub new {
 329   my ($class) = @_;
 330
 331   return bless {}, $class;
 332 }
 333
 334 sub parse {
 335   my ($self, $text) = @_;
 336
 337   my $tokenizer = Squirrel::Template::Expr::Tokenizer->new($text);
 338   my $result = $self->_parse_expr($tokenizer);
 339
 340   my $last = $tokenizer->get;
 341   unless ($last->[0] eq 'eof') {
 342     die [ error => "Expected eof but found $last->[0]" ];
 343   }
 344
 345   return $result;
 346 }
 347
 348 sub parse_tokens {
 349   my ($self, $tokenizer) = @_;
 350
 351   return $self->_parse_expr($tokenizer);
 352 }
 353
 354 sub _parse_expr {
 355   my ($self, $tok) = @_;
 356
 357   return $self->_parse_cond($tok);
 358 }
 359
 360 my %ops =
 361   (
 362    "op+" => "add",
 363    "op-" => "subtract",
 364    "op*" => "mult",
 365    "op/" => "fdiv",
 366    "div" => "div",
 367    "mod" => "mod",
 368    "op_" => "concat",
 369
 370    "opeq" => "eq",
 371    "opne" => "ne",
 372    "oplt" => "lt",
 373    "opgt" => "gt",
 374    "ople" => "le",
 375    "opge" => "ge",
 376    "opcmp" => "cmp",
 377
 378    "op==" => "neq",
 379    "op!=" => "nne",
 380    "op<" => "nlt",
 381    "op>" => "ngt",
 382    "op<=" => "nle",
 383    "op>=" => "nge",
 384    'op=~' => "match",
 385    'op!~' => "notmatch",
 386    'op<=>' => 'ncmp',
 387   );
 388
 389 sub _parse_cond {
 390   my ($self, $tok) = @_;
 391
 392   my $result = $self->_parse_or($tok);
 393   if ($tok->peektype eq 'op?') {
 394     $tok->get;
 395     my $true = $self->_parse_or($tok);
 396     my $colon = $tok->get;
 397     $colon->[0] eq 'op:'
 398       or die [ error => "Expected : for ? : operator but found $colon->[0]" ];
 399     my $false = $self->_parse_cond($tok);
 400
 401     $result = [ cond => $result, $true, $false ];
 402   }
 403
 404   return $result;
 405 }
 406
 407 sub _parse_or {
 408   my ($self, $tok) = @_;
 409
 410   my $result = $self->_parse_and($tok);
 411   while ($tok->peektype eq 'or') {
 412     my $op = $tok->get;
 413     my $other = $self->_parse_and($tok);
 414     $result = [ or => $result, $other ];
 415   }
 416
 417   return $result;
 418 }
 419
 420 sub _parse_and {
 421   my ($self, $tok) = @_;
 422
 423   my $result = $self->_parse_rel($tok);
 424   while ($tok->peektype eq 'and') {
 425     my $op = $tok->get;
 426     my $other = $self->_parse_rel($tok);
 427     $result = [ and => $result, $other ];
 428   }
 429
 430   return $result;
 431 }
 432
 433 my %relops = map {; "op$_" => 1 } qw(eq ne gt lt ge le cmp == != < > >= <= <=> =~ !~);
 434
 435 sub _parse_rel {
 436   my ($self, $tok) = @_;
 437
 438   my $result = $self->_parse_additive($tok);
 439   my $nexttype = $tok->peektype;
 440   while ($relops{$nexttype}) {
 441     my $op = $tok->get;
 442     my $other = $self->_parse_additive($tok);
 443     $result = [ $ops{$nexttype}, $result, $other ];
 444     $nexttype = $tok->peektype;
 445   }
 446   return $result;
 447 }
 448
 449 sub _parse_additive {
 450   my ($self, $tok) = @_;
 451
 452   my $result = $self->_parse_mult($tok);
 453   my $nexttype = $tok->peektype;
 454   while ($nexttype eq 'op+' || $nexttype eq 'op-' || $nexttype eq 'op_') {
 455     my $op = $tok->get;
 456     my $other = $self->_parse_mult($tok);
 457     $result = [ $ops{$nexttype}, $result, $other ];
 458     $nexttype = $tok->peektype;
 459   }
 460   return $result;
 461 }
 462
 463 sub _parse_mult {
 464   my ($self, $tok) = @_;
 465
 466   my $result = $self->_parse_prefix($tok);
 467   my $nexttype = $tok->peektype;
 468   while ($nexttype eq 'op*' || $nexttype eq 'op/'
 469          || $nexttype eq 'div' || $nexttype eq 'mod') {
 470     my $op = $tok->get;
 471     my $other = $self->_parse_prefix($tok);
 472     $result = [ $ops{$op->[0]}, $result, $other ];
 473     $nexttype = $tok->peektype;
 474   }
 475   return $result;
 476 }
 477
 478 sub _parse_prefix {
 479   my ($self, $tok) = @_;
 480
 481   my $nexttype = $tok->peektype('TERM');
 482   if ($nexttype eq 'op-') {
 483     $tok->get;
 484     return [ uminus => $self->_parse_prefix($tok) ];
 485   }
 486   elsif ($nexttype eq 'op+') {
 487     $tok->get;
 488     return $self->_parse_prefix($tok);
 489   }
 490   elsif ($nexttype eq 'op!' || $nexttype eq 'opnot') {
 491     $tok->get;
 492     return [ not => $self->_parse_prefix($tok) ];
 493   }
 494   else {
 495     return $self->_parse_call($tok);
 496   }
 497 }
 498
 499 sub _parse_list {
 500   my ($self, $tok) = @_;
 501
 502   $tok->peektype("TERM") eq 'op)'
 503     and return [];
 504
 505   my @list;
 506   push @list, $self->_parse_expr($tok);
 507   my $peek = $tok->peektype;
 508   while ($peek eq 'op,' || $peek eq '..') {
 509     $tok->get;
 510     if ($peek eq '..') {
 511       my $start = pop @list;
 512       $start->[0] ne 'range'
 513         or die [ error => "Can't use a range as the start of a range" ];
 514       my $end = $self->_parse_expr($tok);
 515       push @list, [ range => $start, $end ];
 516     }
 517     else {
 518       push @list, $self->_parse_expr($tok);
 519     }
 520     $peek = $tok->peektype;
 521   }
 522
 523   return \@list;
 524 }
 525
 526 sub _parse_paren_list {
 527   my ($self, $tok, $what) = @_;
 528
 529   my $open = $tok->get;
 530   $open->[0] eq 'op('
 531     or die [ error => "Expected '(' for $what but found $open->[0]" ];
 532   my $list = $self->_parse_list($tok);
 533   my $close = $tok->get;
 534   $close->[0] eq 'op)'
 535     or die [ error => "Expected ')' for $what but found $close->[0]" ];
 536
 537   return $list;
 538 }
 539
 540 sub _parse_call {
 541   my ($self, $tok) = @_;
 542
 543   my $result = $self->_parse_postfix($tok);
 544   my $next = $tok->peektype;
 545   while ($next eq 'op.' || $next eq 'op[' || $next eq 'op(') {
 546     if ($next eq 'op.') {
 547       $tok->get;
 548       my $name = $tok->get;
 549       if ($name->[0] eq "id") {
 550         my $list = [];
 551         if ($tok->peektype eq 'op(') {
 552           $list = $self->_parse_paren_list($tok, "method");
 553         }
 554         $result = [ call => $name->[2], $result, $list ];
 555       }
 556       elsif ($name->[0] eq 'op$') {
 557         # get the real name
 558         $name = $tok->get;
 559         $name->[0] eq 'id'
 560           or die [ error => "Expected an identifier after .\$ but found $name->[1]" ];
 561         my $list = [];
 562         if ($tok->peektype eq 'op(') {
 563           $list = $self->_parse_paren_list($tok, "method");
 564         }
 565         $result = [ callvar => $name->[2], $result, $list ];
 566       }
 567       else {
 568         die [ error => "Expected a method name or \$var after '.' but found $name->[1]" ];
 569       }
 570     }
 571     elsif ($next eq 'op[') {
 572       $tok->get;
 573       my $index = $self->_parse_expr($tok);
 574       my $close = $tok->get;
 575       $close->[0] eq 'op]'
 576         or die [ error => "Expected closing ']' but got $close->[0]" ];
 577       $result = [ subscript => $result, $index ];
 578     }
 579     elsif ($next eq 'op(') {
 580       my $args = $self->_parse_paren_list($tok, "call");
 581       $result = [ funccall => $result, $args ];
 582     }
 583     $next = $tok->peektype;
 584   }
 585
 586   return $result;
 587 }
 588
 589 sub _parse_postfix {
 590   my ($self, $tok) = @_;
 591
 592   return $self->_parse_primary($tok);
 593 }
 594
 595 sub _parse_primary {
 596   my ($self, $tok) = @_;
 597
 598   my $t = $tok->get('TERM');
 599   if ($t->[0] eq 'op(') {
 600     my $r = $self->_parse_expr($tok);
 601     my $close = $tok->get;
 602     unless ($close->[0] eq 'op)') {
 603       die [ error => "Expected ')' but found $close->[0]" ];
 604     }
 605     return $r;
 606   }
 607   elsif ($t->[0] eq 'str' || $t->[0] eq 'num') {
 608     return [ const => $t->[2] ];
 609   }
 610   elsif ($t->[0] eq 're') {
 611     my $str = $t->[2];
 612     my $opts = $t->[3];
 613     my $sub = eval "sub { my \$str = shift; qr/\$str/$opts; }";
 614     my $re;
 615     $sub and $re = eval { $sub->($str) };
 616     $re
 617       or die [ error => "Cannot compile /$t->[2]/$opts: $@" ];
 618     return [ const => $re ];
 619   }
 620   elsif ($t->[0] eq 'id') {
 621     if ($t->[2] eq "undef") {
 622       return [ "undef" ];
 623     }
 624     else {
 625       return [ var => $t->[2] ];
 626     }
 627   }
 628   elsif ($t->[0] eq 'op[') {
 629     my $list = [];
 630     if ($tok->peektype ne 'op]') {
 631       $list = $self->_parse_list($tok);
 632     }
 633     my $close = $tok->get;
 634     $close->[0] eq 'op]'
 635       or die [ error => "Expected list end ']' but got $close->[0]" ];
 636     return [ list => $list ];
 637   }
 638   elsif ($t->[0] eq 'op{') {
 639     my $pairs = $self->parse_pairs($tok);
 640     my $next = $tok->get;
 641     $next->[0] eq 'op}'
 642       or die [ error => "Expected , or } but found $next->[1]" ];
 643
 644     return [ hash => $pairs ];
 645   }
 646   elsif ($t->[0] eq 're') {
 647     return [ re => $t->[2], $t->[3] ];
 648   }
 649   elsif ($t->[0] eq 'undef') {
 650     return [ "undef" ];
 651   }
 652   elsif ($t->[0] eq 'blockstart') {
 653     # @{ idlist: expr; ... }
 654     # idlist can be empty:
 655     # @{ : expr; ... }
 656     # the expr list will become more complex at some point
 657     my @ids;
 658     my $nexttype = $tok->peektype;
 659     if ($nexttype ne 'op:') {
 660       $nexttype eq 'id'
 661         or die [ error => "Expected id or : after \@{ but found $nexttype->[0]" ];
 662       push @ids, $tok->get->[2];
 663       while ($tok->peektype eq 'op,') {
 664         $tok->get;
 665         $tok->peektype eq 'id'
 666           or die [ error => "Expected id after , in \@{ but found $nexttype->[0]" ];
 667         push @ids, $tok->get->[2];
 668       }
 669       my $end = $tok->get;
 670       $end->[0] eq 'op:'
 671         or die [ error => "Expected :  or , in identifier list in \@{ but found $end->[0]" ];
 672     }
 673     else {
 674       # consume the :
 675       $tok->get;
 676     }
 677     my @exprs;
 678     push @exprs, $self->_parse_expr($tok);
 679     while ($tok->peektype eq 'op;') {
 680       $tok->get;
 681       push @exprs, $self->_parse_expr($tok);
 682     }
 683     $nexttype = $tok->peektype;
 684     $nexttype eq 'op}'
 685       or die [ error => "Expected } at end of \@{ but found $nexttype" ];
 686     # consume the }
 687     $tok->get;
 688     return [ block => \@ids, \@exprs ];
 689   }
 690   else {
 691     die [ error => "Expected term but got $t->[0]" ];
 692   }
 693 }
 694
 695 sub parse_pairs {
 696   my ($self, $tok) = @_;
 697
 698   my $nexttype = $tok->peektype;
 699   if ($nexttype eq 'op}' || $nexttype eq 'eof') {
 700     return [];
 701   }
 702   else {
 703     my $next;
 704     my @pairs;
 705     do {
 706       my $key;
 707       if ($tok->peektype eq 'id') {
 708         my $id = $tok->get;
 709         if ($tok->peektype eq 'op:') {
 710           $key = [ const => $id->[2] ];
 711         }
 712         else {
 713           $tok->unget($id);
 714         }
 715       }
 716       $key ||= $self->_parse_additive($tok);
 717       my $colon = $tok->get;
 718       $colon->[0] eq 'op:'
 719         or die [ error => "Expected : in hash but found $colon->[1]" ];
 720       my $value = $self->_parse_expr($tok);
 721       push @pairs, [ $key, $value ];
 722     } while ($next = $tok->get and $next->[0] eq 'op,');
 723     $tok->unget($next);
 724
 725     return \@pairs;
 726   }
 727 }
 728
 729 package Squirrel::Template::Expr::Tokenizer;
 730
 731 use constant TEXT => 0;
 732 use constant QUEUE => 1;
 733
 734 sub new {
 735   my ($class, $text) = @_;
 736
 737   return bless [ $text, [] ], $class;
 738 }
 739
 740 my %escapes =
 741   (
 742    n => "\n",
 743    "\\" => "\\",
 744    t => "\t",
 745    '"' => '"',
 746   );
 747
 748 sub get {
 749   my ($self, $want) = @_;
 750
 751   my $queue = $self->[QUEUE];
 752   @$queue
 753     and return shift @$queue;
 754   length $self->[TEXT]
 755     or return;
 756
 757   $want ||= '';
 758
 759   if ($want ne 'TERM' &&
 760          $self->[TEXT] =~ s/\A(\s*(div\b|mod\b|\.\.|and\b|or\b)\s*)//) {
 761     push @$queue, [ $2 => $1 ];
 762   }
 763   elsif ($self->[TEXT] =~ s/\A(\s*(0x[0-9A-Fa-f]+)\s*)//) {
 764     push @$queue, [ num => $1, oct $2 ];
 765   }
 766   elsif ($self->[TEXT] =~ s/\A(\s*(0b[01]+)\s*)//) {
 767     push @$queue, [ num => $1, oct $2 ];
 768   }
 769   elsif ($self->[TEXT] =~ s/\A(\s*0o([0-7]+)\s*)//) {
 770     push @$queue, [ num => $1, oct $2 ];
 771   }
 772   elsif ($self->[TEXT] =~ s/\A(\s*((?:\.[0-9]+|[0-9]+(?:\.[0-9]*)?)(?:[Ee][+-]?[0-9]+)?)\s*)//) {
 773     push @$queue, [ num => $1, $2 ];
 774   }
 775   elsif ($want eq 'TERM' &&
 776          $self->[TEXT] =~ s!\A(\s*/((?:[^/\\]|\\.)+)/([ismx]*\s)?\s*)!!) {
 777     push @$queue, [ re => $1, $2, $3 || "" ];
 778   }
 779   elsif ($self->[TEXT] =~ s/\A(\s*(not\b|eq\b|ne\b|le\b|lt\b|ge\b|gt\b|cmp\b|<=>|<=|>=|[!=]\=|\=\~|!~|[\?:,\[\]\(\)<>=!.*\/+\{\};\$-]|_(?![A-Za-z0-9_]))\s*)//) {
 780     push @$queue, [ "op$2" => $1 ];
 781   }
 782   elsif ($self->[TEXT] =~ s/\A(\s*([A-Za-z_][a-zA-Z_0-9]*)\s*)//) {
 783     push @$queue, [ id => $1, $2 ];
 784   }
 785   elsif ($self->[TEXT] =~ s/\A(\s*\"((?:[^"\\]|\\["\\nt]|\\x[0-9a-fA-F]{2}|\\x\{[0-9a-fA-F]+\}|\\N\{[A-Za-z0-9 ]+\})*)\"\s*)//) {
 786     my $orig = $1;
 787     my $str = _process_escapes($2);
 788     push @$queue, [ str => $1, $str ];
 789   }
 790   elsif ($self->[TEXT] =~ s/\A(\s*\'([^\']*)\'\s*)//) {
 791     push @$queue, [ str => $1, $2 ];
 792   }
 793   elsif ($self->[TEXT] =~ s/\A(\s*\@undef\bs*)//) {
 794     push @$queue, [ undef => $1 ];
 795   }
 796   elsif ($self->[TEXT] =~ s/\A(\s*@\{\s*)//) {
 797     push @$queue, [ blockstart => $1 ];
 798   }
 799   else {
 800     die [ error => "Unknown token '$self->[TEXT]'" ];
 801   }
 802
 803   unless (length $self->[TEXT]) {
 804     push @$queue, [ eof => "" ];
 805   }
 806
 807   return shift @$queue;
 808 }
 809
 810 sub unget {
 811   my ($self, $tok) = @_;
 812
 813   unshift @{$self->[QUEUE]}, $tok;
 814 }
 815
 816 sub peek {
 817   my ($self, $what) = @_;
 818
 819   unless (@{$self->[QUEUE]}) {
 820     my $t = $self->get($what)
 821       or return;
 822     unshift @{$self->[QUEUE]}, $t;
 823   }
 824
 825   return $self->[QUEUE][0];
 826 }
 827
 828 sub peektype {
 829   my ($self, $what) = @_;
 830
 831   return $self->peek($what)->[0];
 832 }
 833
 834 sub _process_escapes {
 835   my ($str) = @_;
 836
 837   $str =~
 838     s(
 839       \\([nt\\\"])
 840        |
 841          \\x\{([0-9A-Fa-f]+)\}
 842        |
 843          \\x([0-9A-Fa-f]{2})
 844        |
 845          \\N\{([A-Za-z0-9\ ]+)\}
 846     )(
 847       $1 ? $escapes{$1} :
 848       $2 ? chr(hex($2)) :
 849       $3 ? chr(hex($3)) :
 850       _vianame($4)
 851      )gex;
 852
 853   return $str;
 854 }
 855
 856 my $charnames_loaded;
 857 sub _vianame {
 858   my ($name, $errors) = @_;
 859
 860   require charnames;
 861   my $code = charnames::vianame($name);
 862   unless (defined $code) {
 863     die [ error => "Unknown \\N name '$name'" ];
 864   }
 865   return chr($code);
 866 }
 867
 868 1;
 869
 870 __END__
 871
 872 =head1 NAME
 873
 874 Squirrel::Template::Expr - expression handling for Squirrel::Template
 875
 876 =head1 SYNOPSIS
 877
 878   # code that uses it
 879   my $parser = Squirrel::Template::Expr::Parser->new;
 880
 881   my $expr = $parser->parse($expr_text);
 882
 883   my $tokens = Squirrel::Template::Expr::Tokenizer->new($expr_text);
 884
 885   my $expr = $parser->parse_tokens($tokenizer);
 886   # and possibly process more tokens here
 887
 888   my $eval = Squirrel::Template::Expr::Parser->new($templater);
 889
 890   my $value = $eval->process($expr);
 891   my $value = $eval->process($expr, "LIST");
 892
 893   my $arrayref = $eval->process(\@exprs);
 894
 895   # Expressions
 896
 897   <:= somevalue + 10 :>
 898   <:.if somevalue == 10 :>
 899
 900 =head1 DESCRIPTION
 901
 902 Squirrel::Template::Expr provides expression parsing and evaluation
 903 for newer style tags for L<Squirrel::Template>.
 904
 905 =head1 EXPRESSION SYNTAX
 906
 907 =head2 Operators
 908
 909 Listed highest precedence first.
 910
 911 =over
 912
 913 =item *
 914
 915 C<<[ I<list> ]>>, C<<{ I<key>:I<value>, ... }>>, literals
 916
 917 C<<[ I<list> ]>> allows you to build lists objects.  Within C<[ ... ]>
 918 you can use the C<..> operator to produce a list of numerically or
 919 alphabetically ascending values per Perl's magic increment.
 920
 921 eg.
 922
 923   [ "a", "c" .. "z" ]
 924   [ 1 .. 10 ]
 925
 926 Method calls within C<<[ ... ]>> are done in perl's list context.
 927
 928 C<<{ ... }>> allows you to build hash objects.
 929
 930 eg.
 931
 932   { "somekey":somevariable, somekeyinvar:"somevalue" }
 933
 934 See L</Literals> for literals
 935
 936 =item *
 937
 938 method calls - methods are called as:
 939
 940   object.method;
 941
 942 or
 943
 944   object.method(arguments)
 945
 946 and may be chained.
 947
 948 Virtual methods are defined for hashes, arrays and scalars, see
 949 L<Squirrel::Template::Expr::WrapHash>,
 950 L<Squirrel::Template::Expr::WrapArray>,
 951 L<Squirrel::Template::Expr::WrapScalar>,
 952 L<Squirrel::Template::Expr::WrapCode> and
 953 L<Squirrel::Template::Expr::WrapClass>.
 954
 955 =item *
 956
 957 function calls - functions are called as:
 958
 959   somevar();
 960
 961 or
 962
 963   somevar(arguments);
 964
 965 or any other expression that doesn't look like a method call:
 966
 967   somehash.get["foo"]();
 968
 969 =item *
 970
 971 unary -, unary +, unary !, unary not
 972
 973 =item *
 974
 975 * / div mod - simple arithmetic operators.  C<div> returns the integer
 976 portion of dividing the first operand by the second.  C<mod> returns
 977 the remainder of integer division.
 978
 979 =item *
 980
 981 + - _ - arithmetic addition and subtraction. C<_> does string
 982 concatenation.
 983
 984 =item *
 985
 986 eq ne le lt ge gt == != > < >= <= =~ !~ - relational operators as per
 987 Perl.
 988
 989 =item *
 990
 991 and - boolean and, with shortcut.
 992
 993 =item *
 994
 995 or - boolean or, with shortcut.
 996
 997 =item *
 998
 999 Conditional (C<< I<cond> ? I<true> : I<false> >>) - return the value
1000 of I<true> or I<false> depending on I<cond>.
1001
1002 =back
1003
1004 =head2 Literals
1005
1006 Numbers can be represented in several formats:
1007
1008 =over
1009
1010 =item *
1011
1012 simple decimal - C<100>, C<3.14159>, C<1e10>.
1013
1014 =item *
1015
1016 hex - C<0x64>
1017
1018 =item *
1019
1020 octal - C<0o144>
1021
1022 =item *
1023
1024 binary - C<0b1100100>
1025
1026 =item *
1027
1028 an undefined value - C<@undef>
1029
1030 =item *
1031
1032 blocks - C<< @{ I<idlist> : I<exprlist> } >> where C<< I<idlist> >> is
1033 a comma separated list of local variables that arguments are assigned
1034 to, and I<exprlist> is a semi-colon separated list of expressions.
1035 The block literal can be called as if it's a function, or supplied to
1036 methods like the array grep() method.
1037
1038 =back
1039
1040 Strings can be either " or ' delimited.
1041
1042 Simple quote delimited strings allow no escaping, and may not contain
1043 single quotes.  The contents are treated literally.
1044
1045 Double quoted strings allow escaping as follows:
1046
1047 =over
1048
1049 =item *
1050
1051 Any of C<\">, C<\n>, C<\\>, C<\t> are treated as in C or perl,
1052 replaced with double quote, newline, backslash or tab respectively.
1053
1054 =item *
1055
1056 C<<\x{I<hex-digits>}>> is replaced with the unicode code-point
1057 indicated by the hex number.
1058
1059 =item *
1060
1061 C<< \xI<hex-digit>I<hex-digit> >> is replaced by the unicode
1062 code-point indicated by the 2-digit hex number.
1063
1064 =item *
1065
1066 C<< \N{ I<unicode-character-name> } >> is replaced by the unicode
1067 character named.
1068
1069 =back
1070
1071 =head1 Squirrel::Template::Expr::Parser
1072
1073 Squirrel::Template::Expr::Parser provides parsing for expressions.
1074
1075 =head1 Methods
1076
1077 =over
1078
1079 =item new()
1080
1081 Create a new parser object.
1082
1083 =item parse($text)
1084
1085 Parse C<$text> as an expression.  Parsing must reach the end of the
1086 text or an exception will be thrown.
1087
1088 =item parse_tokens($tokenizer)
1089
1090 Process tokens from C<$tokenizer>, a
1091 L</Squirrel::Template::Expr::Tokenizer> object.  The caller can call
1092 these method several times with the same C<$tokenizer> to parse
1093 components of a statement, and should ensure the eof token is visible
1094 after the final component.
1095
1096 =back
1097
1098 =head1 Squirrel::Template::Expr::Tokenizer
1099
1100 Split text into tokens.  Token parsing is occasionally context
1101 sensitive.
1102
1103 =head2 Methods
1104
1105 =over
1106
1107 =item new($text)
1108
1109 Create a new tokenizer for parsing C<$text>.
1110
1111 =item get()
1112
1113 =item get($context)
1114
1115 Retrieve a token from the stream, consuming it.  If a term is expected
1116 $context should be set to C<'TERM'>.
1117
1118 =item unget()
1119
1120 Push a token back into the stream.
1121
1122 =item peek()
1123
1124 =item peek($context)
1125
1126 Retrieve the next token from the stream without consuming it.
1127
1128 =item peektype()
1129
1130 =item peektype($context)
1131
1132 Retrieve the type of the next token from the stream without consuming
1133 it.
1134
1135 =back
1136
1137 =head1 Squirrel::Template::Expr::Eval
1138
1139 Used to evaluate an expression returned by
1140 Squirrel::Template::Expr::parse().
1141
1142 =head2 Methods
1143
1144 =over
1145
1146 =item new($templater)
1147
1148 Create a new evaluator.  C<$templater> should be a
1149 L<Squirrel::Template> object.
1150
1151 =back
1152
1153 =head1 SEE ALSO
1154
1155 L<Squirrel::Template>
1156
1157 =head1 AUTHOR
1158
1159 Tony Cook <tony@develop-help.com>
1160
1161 =cut