treat _ followed by id text as an id rather than as an _ operator
[bse.git] / site / cgi-bin / modules / Squirrel / Template / Expr.pm
CommitLineData
4697e5c3
TC
1package Squirrel::Template::Expr;
2use strict;
3
19a77ade 4our $VERSION = "1.016";
ac507437
TC
5
6package Squirrel::Template::Expr::Eval;
7use Scalar::Util ();
f17f9f79
TC
8use Squirrel::Template::Expr::WrapScalar;
9use Squirrel::Template::Expr::WrapHash;
10use Squirrel::Template::Expr::WrapArray;
11use Squirrel::Template::Expr::WrapCode;
12use Squirrel::Template::Expr::WrapClass;
13
ac507437 14use constant TMPL => 0;
a96f9b25 15use constant ACTS => 1;
ac507437
TC
16
17sub new {
a96f9b25 18 my ($class, $templater, $acts) = @_;
ac507437 19
a96f9b25 20 return bless [ $templater, $acts ], $class;
ac507437
TC
21}
22
23sub _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") {
b83d0c53 33 return Squirrel::Template::Expr::WrapArray->new($val, $self->[TMPL], undef, $self);
ac507437
TC
34 }
35 elsif ($type eq "HASH") {
b83d0c53 36 return Squirrel::Template::Expr::WrapHash->new($val, $self->[TMPL], undef, $self);
ac507437
TC
37 }
38 elsif ($type eq "CODE") {
b83d0c53 39 return Squirrel::Template::Expr::WrapCode->new($val, $self->[TMPL], undef, $self);
ac507437
TC
40 }
41 }
42 }
43 else {
b83d0c53 44 return Squirrel::Template::Expr::WrapScalar->new($val, $self->[TMPL], $self->[ACTS], $self);
ac507437
TC
45 }
46}
47
48sub _process_var {
49 return $_[0][TMPL]->get_var($_[1][1]);
50}
51
52sub _process_add {
53 return $_[0]->process($_[1][1]) + $_[0]->process($_[1][2]);
54}
55
56sub _process_subtract {
57 return $_[0]->process($_[1][1]) - $_[0]->process($_[1][2]);
58}
59
60sub _process_mult {
61 return $_[0]->process($_[1][1]) * $_[0]->process($_[1][2]);
62}
63
64sub _process_fdiv {
65 return $_[0]->process($_[1][1]) / $_[0]->process($_[1][2]);
66}
67
68sub _process_div {
69 return int($_[0]->process($_[1][1]) / $_[0]->process($_[1][2]));
70}
71
72sub _process_mod {
73 return $_[0]->process($_[1][1]) % $_[0]->process($_[1][2]);
74}
75
e1e37937
TC
76sub _process_undef {
77 return undef;
78}
79
ac507437
TC
80# string relops
81sub _process_eq {
82 return $_[0]->process($_[1][1]) eq $_[0]->process($_[1][2]);
83}
84
85sub _process_ne {
86 return $_[0]->process($_[1][1]) ne $_[0]->process($_[1][2]);
87}
88
89sub _process_gt {
90 return $_[0]->process($_[1][1]) gt $_[0]->process($_[1][2]);
91}
92
93sub _process_lt {
94 return $_[0]->process($_[1][1]) lt $_[0]->process($_[1][2]);
95}
96
97sub _process_ge {
98 return $_[0]->process($_[1][1]) ge $_[0]->process($_[1][2]);
99}
100
101sub _process_le {
102 return $_[0]->process($_[1][1]) le $_[0]->process($_[1][2]);
103}
104
b83d0c53
TC
105sub _process_cmp {
106 return $_[0]->process($_[1][1]) cmp $_[0]->process($_[1][2]);
107}
108
ac507437
TC
109# number relops
110sub _process_neq {
111 return $_[0]->process($_[1][1]) == $_[0]->process($_[1][2]);
112}
113
114sub _process_nne {
115 return $_[0]->process($_[1][1]) != $_[0]->process($_[1][2]);
116}
117
118sub _process_ngt {
119 return $_[0]->process($_[1][1]) > $_[0]->process($_[1][2]);
120}
121
122sub _process_nlt {
123 return $_[0]->process($_[1][1]) < $_[0]->process($_[1][2]);
124}
125
126sub _process_nge {
127 return $_[0]->process($_[1][1]) >= $_[0]->process($_[1][2]);
128}
129
130sub _process_nle {
131 return $_[0]->process($_[1][1]) <= $_[0]->process($_[1][2]);
132}
133
134sub _process_match {
135 return $_[0]->process($_[1][1]) =~ $_[0]->process($_[1][2]);
136}
137
138sub _process_notmatch {
139 return $_[0]->process($_[1][1]) !~ $_[0]->process($_[1][2]);
140}
141
142sub _process_cond {
143 return $_[0]->process($_[1][1]) ? $_[0]->process($_[1][2]) : $_[0]->process($_[1][3]);
144}
145
b83d0c53
TC
146sub _process_ncmp {
147 return $_[0]->process($_[1][1]) <=> $_[0]->process($_[1][2]);
148}
149
ac507437
TC
150sub _process_uminus {
151 return - ($_[0]->process($_[1][1]));
152}
153
154sub _process_concat {
155 return $_[0]->process($_[1][1]) . $_[0]->process($_[1][2]);
156}
157
158sub _process_const {
159 return $_[1][1];
160}
161
b83d0c53
TC
162sub _process_block {
163 return bless [ $_[1][1], $_[1][2] ], "Squirrel::Template::Expr::Block";
164}
165
dd94dd8e
TC
166sub _do_call {
167 my ($self, $val, $args, $method, $ctx) = @_;
b12ea476 168
b12ea476
TC
169 if (Scalar::Util::blessed($val)
170 && !$val->isa("Squirrel::Template::Expr::WrapBase")) {
ac507437
TC
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
dd94dd8e
TC
186sub _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
198sub _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
b83d0c53
TC
210sub _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
227sub call_function {
228 my ($self, $code, $args, $ctx) = @_;
dd94dd8e
TC
229
230 $ctx ||= "";
dd94dd8e
TC
231
232 if (Scalar::Util::reftype($code) eq "CODE") {
233 return $ctx eq "LIST" ? $code->(@$args) : scalar($code->(@$args));
234 }
b83d0c53
TC
235 elsif (Scalar::Util::blessed($code)
236 && $code->isa("Squirrel::Template::Expr::Block")) {
237 return $self->_do_callblock($code->[0], $code->[1], $args);
238 }
dd94dd8e
TC
239 else {
240 die [ error => "can't call non code as a function" ];
241 }
242}
243
b83d0c53
TC
244sub _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
ac507437
TC
253sub _process_list {
254 my ($self, $node) = @_;
255
256 return $self->process_list($node->[1], 'LIST');
257}
258
259sub _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
f17f9f79
TC
268sub _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
ac507437
TC
281sub _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
300sub _process_not {
301 return !$_[0]->process($_[1][1]);
302}
303
304sub _process_or {
305 return $_[0]->process($_[1][1]) || $_[0]->process($_[1][2]);
306}
307
308sub _process_and {
309 return $_[0]->process($_[1][1]) && $_[0]->process($_[1][2]);
310}
311
312sub 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
320sub process_list {
321 my ($self, $list) = @_;
322
323 return [ map $self->process($_, 'LIST'), @$list ];
324}
4697e5c3
TC
325
326package Squirrel::Template::Expr::Parser;
327
328sub new {
329 my ($class) = @_;
330
331 return bless {}, $class;
332}
333
334sub parse {
335 my ($self, $text) = @_;
336
337 my $tokenizer = Squirrel::Template::Expr::Tokenizer->new($text);
c507244d
TC
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;
4697e5c3
TC
346}
347
231cecfb
TC
348sub parse_tokens {
349 my ($self, $tokenizer) = @_;
350
351 return $self->_parse_expr($tokenizer);
352}
353
4697e5c3
TC
354sub _parse_expr {
355 my ($self, $tok) = @_;
356
ac507437 357 return $self->_parse_cond($tok);
4697e5c3
TC
358}
359
360my %ops =
361 (
ac507437
TC
362 "op+" => "add",
363 "op-" => "subtract",
364 "op*" => "mult",
365 "op/" => "fdiv",
4697e5c3
TC
366 "div" => "div",
367 "mod" => "mod",
368 "op_" => "concat",
ac507437
TC
369
370 "opeq" => "eq",
371 "opne" => "ne",
372 "oplt" => "lt",
373 "opgt" => "gt",
374 "ople" => "le",
375 "opge" => "ge",
b83d0c53 376 "opcmp" => "cmp",
ac507437
TC
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",
b83d0c53 386 'op<=>' => 'ncmp',
4697e5c3
TC
387 );
388
ac507437
TC
389sub _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:'
46296d79 398 or die [ error => "Expected : for ? : operator but found $colon->[0]" ];
4742ac21 399 my $false = $self->_parse_cond($tok);
ac507437
TC
400
401 $result = [ cond => $result, $true, $false ];
402 }
403
404 return $result;
405}
406
4697e5c3
TC
407sub _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
420sub _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
b83d0c53 433my %relops = map {; "op$_" => 1 } qw(eq ne gt lt ge le cmp == != < > >= <= <=> =~ !~);
4697e5c3
TC
434
435sub _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);
ac507437 443 $result = [ $ops{$nexttype}, $result, $other ];
4697e5c3
TC
444 $nexttype = $tok->peektype;
445 }
446 return $result;
447}
448
449sub _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
463sub _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
478sub _parse_prefix {
479 my ($self, $tok) = @_;
480
481 my $nexttype = $tok->peektype('TERM');
961939b5 482 if ($nexttype eq 'op-') {
4697e5c3
TC
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
499sub _parse_list {
500 my ($self, $tok) = @_;
501
4742ac21 502 $tok->peektype("TERM") eq 'op)'
4697e5c3
TC
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
526sub _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
540sub _parse_call {
541 my ($self, $tok) = @_;
542
543 my $result = $self->_parse_postfix($tok);
544 my $next = $tok->peektype;
dd94dd8e 545 while ($next eq 'op.' || $next eq 'op[' || $next eq 'op(') {
4697e5c3
TC
546 if ($next eq 'op.') {
547 $tok->get;
548 my $name = $tok->get;
dd94dd8e
TC
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'
46296d79 560 or die [ error => "Expected an identifier after .\$ but found $name->[1]" ];
dd94dd8e
TC
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 {
46296d79 568 die [ error => "Expected a method name or \$var after '.' but found $name->[1]" ];
4697e5c3 569 }
4697e5c3
TC
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]'
46296d79 576 or die [ error => "Expected closing ']' but got $close->[0]" ];
4697e5c3
TC
577 $result = [ subscript => $result, $index ];
578 }
dd94dd8e
TC
579 elsif ($next eq 'op(') {
580 my $args = $self->_parse_paren_list($tok, "call");
581 $result = [ funccall => $result, $args ];
582 }
4697e5c3
TC
583 $next = $tok->peektype;
584 }
585
586 return $result;
587}
588
589sub _parse_postfix {
590 my ($self, $tok) = @_;
591
592 return $self->_parse_primary($tok);
593}
594
595sub _parse_primary {
596 my ($self, $tok) = @_;
597
598 my $t = $tok->get('TERM');
961939b5
TC
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') {
4697e5c3
TC
608 return [ const => $t->[2] ];
609 }
ac507437
TC
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 }
4697e5c3 620 elsif ($t->[0] eq 'id') {
e1e37937
TC
621 if ($t->[2] eq "undef") {
622 return [ "undef" ];
623 }
624 else {
625 return [ var => $t->[2] ];
626 }
4697e5c3
TC
627 }
628 elsif ($t->[0] eq 'op[') {
39fbca4a
TC
629 my $list = [];
630 if ($tok->peektype ne 'op]') {
631 $list = $self->_parse_list($tok);
632 }
4697e5c3
TC
633 my $close = $tok->get;
634 $close->[0] eq 'op]'
46296d79 635 or die [ error => "Expected list end ']' but got $close->[0]" ];
4697e5c3
TC
636 return [ list => $list ];
637 }
f17f9f79 638 elsif ($t->[0] eq 'op{') {
53c28223
TC
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]" ];
f17f9f79 643
53c28223 644 return [ hash => $pairs ];
f17f9f79 645 }
4697e5c3
TC
646 elsif ($t->[0] eq 're') {
647 return [ re => $t->[2], $t->[3] ];
648 }
e1e37937
TC
649 elsif ($t->[0] eq 'undef') {
650 return [ "undef" ];
651 }
b83d0c53
TC
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 }
4697e5c3
TC
690 else {
691 die [ error => "Expected term but got $t->[0]" ];
692 }
693}
694
53c28223
TC
695sub 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
4697e5c3
TC
729package Squirrel::Template::Expr::Tokenizer;
730
731use constant TEXT => 0;
732use constant QUEUE => 1;
733
734sub new {
735 my ($class, $text) = @_;
736
737 return bless [ $text, [] ], $class;
738}
739
740my %escapes =
741 (
742 n => "\n",
743 "\\" => "\\",
744 t => "\t",
745 '"' => '"',
746 );
747
748sub 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' &&
a97045d4 760 $self->[TEXT] =~ s/\A(\s*(div\b|mod\b|\.\.|and\b|or\b)\s*)//) {
4697e5c3
TC
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 }
19a77ade 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*)//) {
4697e5c3
TC
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 }
e1e37937
TC
793 elsif ($self->[TEXT] =~ s/\A(\s*\@undef\bs*)//) {
794 push @$queue, [ undef => $1 ];
795 }
b83d0c53
TC
796 elsif ($self->[TEXT] =~ s/\A(\s*@\{\s*)//) {
797 push @$queue, [ blockstart => $1 ];
798 }
4697e5c3
TC
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
810sub unget {
811 my ($self, $tok) = @_;
812
813 unshift @{$self->[QUEUE]}, $tok;
814}
815
816sub 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
828sub peektype {
829 my ($self, $what) = @_;
830
831 return $self->peek($what)->[0];
832}
833
834sub _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
856my $charnames_loaded;
857sub _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
8681;
6c291231
TC
869
870__END__
871
872=head1 NAME
873
874Squirrel::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
902Squirrel::Template::Expr provides expression parsing and evaluation
903for newer style tags for L<Squirrel::Template>.
904
905=head1 EXPRESSION SYNTAX
906
907=head2 Operators
908
909Listed highest precedence first.
910
911=over
912
913=item *
914
915C<<[ I<list> ]>>, C<<{ I<key>:I<value>, ... }>>, literals
916
917C<<[ I<list> ]>> allows you to build lists objects. Within C<[ ... ]>
918you can use the C<..> operator to produce a list of numerically or
919alphabetically ascending values per Perl's magic increment.
920
921eg.
922
923 [ "a", "c" .. "z" ]
924 [ 1 .. 10 ]
925
926Method calls within C<<[ ... ]>> are done in perl's list context.
927
928C<<{ ... }>> allows you to build hash objects.
929
930eg.
931
932 { "somekey":somevariable, somekeyinvar:"somevalue" }
933
934See L</Literals> for literals
935
936=item *
937
938method calls - methods are called as:
939
940 object.method;
941
942or
943
944 object.method(arguments)
945
946and may be chained.
947
948Virtual methods are defined for hashes, arrays and scalars, see
949L<Squirrel::Template::Expr::WrapHash>,
950L<Squirrel::Template::Expr::WrapArray>,
951L<Squirrel::Template::Expr::WrapScalar>,
952L<Squirrel::Template::Expr::WrapCode> and
953L<Squirrel::Template::Expr::WrapClass>.
954
955=item *
956
dd94dd8e
TC
957function calls - functions are called as:
958
959 somevar();
960
961or
962
963 somevar(arguments);
964
965or any other expression that doesn't look like a method call:
966
967 somehash.get["foo"]();
968
969=item *
970
6c291231
TC
971unary -, unary +, unary !, unary not
972
973=item *
974
975* / div mod - simple arithmetic operators. C<div> returns the integer
976portion of dividing the first operand by the second. C<mod> returns
977the remainder of integer division.
978
979=item *
980
981+ - _ - arithmetic addition and subtraction. C<_> does string
982concatenation.
983
984=item *
985
986eq ne le lt ge gt == != > < >= <= =~ !~ - relational operators as per
987Perl.
988
989=item *
990
991and - boolean and, with shortcut.
992
993=item *
994
995or - boolean or, with shortcut.
996
997=item *
998
999Conditional (C<< I<cond> ? I<true> : I<false> >>) - return the value
1000of I<true> or I<false> depending on I<cond>.
1001
1002=back
1003
1004=head2 Literals
1005
1006Numbers can be represented in several formats:
1007
1008=over
1009
1010=item *
1011
1012simple decimal - C<100>, C<3.14159>, C<1e10>.
1013
1014=item *
1015
1016hex - C<0x64>
1017
1018=item *
1019
1020octal - C<0o144>
1021
1022=item *
1023
1024binary - C<0b1100100>
1025
e1e37937
TC
1026=item *
1027
1028an undefined value - C<@undef>
1029
b83d0c53
TC
1030=item *
1031
1032blocks - C<< @{ I<idlist> : I<exprlist> } >> where C<< I<idlist> >> is
1033a comma separated list of local variables that arguments are assigned
1034to, and I<exprlist> is a semi-colon separated list of expressions.
1035The block literal can be called as if it's a function, or supplied to
1036methods like the array grep() method.
1037
6c291231
TC
1038=back
1039
1040Strings can be either " or ' delimited.
1041
1042Simple quote delimited strings allow no escaping, and may not contain
1043single quotes. The contents are treated literally.
1044
1045Double quoted strings allow escaping as follows:
1046
1047=over
1048
1049=item *
1050
1051Any of C<\">, C<\n>, C<\\>, C<\t> are treated as in C or perl,
1052replaced with double quote, newline, backslash or tab respectively.
1053
1054=item *
1055
1056C<<\x{I<hex-digits>}>> is replaced with the unicode code-point
1057indicated by the hex number.
1058
1059=item *
1060
1061C<< \xI<hex-digit>I<hex-digit> >> is replaced by the unicode
1062code-point indicated by the 2-digit hex number.
1063
1064=item *
1065
1066C<< \N{ I<unicode-character-name> } >> is replaced by the unicode
1067character named.
1068
1069=back
1070
1071=head1 Squirrel::Template::Expr::Parser
1072
1073Squirrel::Template::Expr::Parser provides parsing for expressions.
1074
1075=head1 Methods
1076
1077=over
1078
1079=item new()
1080
1081Create a new parser object.
1082
1083=item parse($text)
1084
1085Parse C<$text> as an expression. Parsing must reach the end of the
1086text or an exception will be thrown.
1087
1088=item parse_tokens($tokenizer)
1089
1090Process tokens from C<$tokenizer>, a
1091L</Squirrel::Template::Expr::Tokenizer> object. The caller can call
1092these method several times with the same C<$tokenizer> to parse
1093components of a statement, and should ensure the eof token is visible
1094after the final component.
1095
1096=back
1097
1098=head1 Squirrel::Template::Expr::Tokenizer
1099
1100Split text into tokens. Token parsing is occasionally context
1101sensitive.
1102
1103=head2 Methods
1104
1105=over
1106
1107=item new($text)
1108
1109Create a new tokenizer for parsing C<$text>.
1110
1111=item get()
1112
1113=item get($context)
1114
1115Retrieve 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
1120Push a token back into the stream.
1121
1122=item peek()
1123
1124=item peek($context)
1125
1126Retrieve the next token from the stream without consuming it.
1127
1128=item peektype()
1129
1130=item peektype($context)
1131
1132Retrieve the type of the next token from the stream without consuming
1133it.
1134
1135=back
1136
1137=head1 Squirrel::Template::Expr::Eval
1138
1139Used to evaluate an expression returned by
1140Squirrel::Template::Expr::parse().
1141
1142=head2 Methods
1143
1144=over
1145
1146=item new($templater)
1147
1148Create a new evaluator. C<$templater> should be a
1149L<Squirrel::Template> object.
1150
1151=back
1152
1153=head1 SEE ALSO
1154
1155L<Squirrel::Template>
1156
1157=head1 AUTHOR
1158
1159Tony Cook <tony@develop-help.com>
1160
1161=cut