treat _ followed by id text as an id rather than as an _ operator
[bse.git] / 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