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