template re-work: add a preload template to allow for common definitions
[bse.git] / site / cgi-bin / modules / Squirrel / Template / Expr.pm
CommitLineData
4697e5c3
TC
1package Squirrel::Template::Expr;
2use strict;
3
f75af510 4our $VERSION = "1.003";
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
TC
14use constant TMPL => 0;
15
16sub new {
17 my ($class, $templater) = @_;
18
19 return bless [ $templater ], $class;
20}
21
22sub _wrapped {
23 my ($self, $val) = @_;
24
25 if (ref($val)) {
26 if (Scalar::Util::blessed($val)) {
27 return $val;
28 }
29 else {
30 my $type = Scalar::Util::reftype($val);
31 if ($type eq "ARRAY") {
32 return Squirrel::Template::Expr::WrapArray->new($val);
33 }
34 elsif ($type eq "HASH") {
35 return Squirrel::Template::Expr::WrapHash->new($val);
36 }
37 elsif ($type eq "CODE") {
38 return Squirrel::Template::Expr::WrapCode->new($val);
39 }
40 }
41 }
42 else {
43 return Squirrel::Template::Expr::WrapScalar->new($val);
44 }
45}
46
47sub _process_var {
48 return $_[0][TMPL]->get_var($_[1][1]);
49}
50
51sub _process_add {
52 return $_[0]->process($_[1][1]) + $_[0]->process($_[1][2]);
53}
54
55sub _process_subtract {
56 return $_[0]->process($_[1][1]) - $_[0]->process($_[1][2]);
57}
58
59sub _process_mult {
60 return $_[0]->process($_[1][1]) * $_[0]->process($_[1][2]);
61}
62
63sub _process_fdiv {
64 return $_[0]->process($_[1][1]) / $_[0]->process($_[1][2]);
65}
66
67sub _process_div {
68 return int($_[0]->process($_[1][1]) / $_[0]->process($_[1][2]));
69}
70
71sub _process_mod {
72 return $_[0]->process($_[1][1]) % $_[0]->process($_[1][2]);
73}
74
75# string relops
76sub _process_eq {
77 return $_[0]->process($_[1][1]) eq $_[0]->process($_[1][2]);
78}
79
80sub _process_ne {
81 return $_[0]->process($_[1][1]) ne $_[0]->process($_[1][2]);
82}
83
84sub _process_gt {
85 return $_[0]->process($_[1][1]) gt $_[0]->process($_[1][2]);
86}
87
88sub _process_lt {
89 return $_[0]->process($_[1][1]) lt $_[0]->process($_[1][2]);
90}
91
92sub _process_ge {
93 return $_[0]->process($_[1][1]) ge $_[0]->process($_[1][2]);
94}
95
96sub _process_le {
97 return $_[0]->process($_[1][1]) le $_[0]->process($_[1][2]);
98}
99
100# number relops
101sub _process_neq {
102 return $_[0]->process($_[1][1]) == $_[0]->process($_[1][2]);
103}
104
105sub _process_nne {
106 return $_[0]->process($_[1][1]) != $_[0]->process($_[1][2]);
107}
108
109sub _process_ngt {
110 return $_[0]->process($_[1][1]) > $_[0]->process($_[1][2]);
111}
112
113sub _process_nlt {
114 return $_[0]->process($_[1][1]) < $_[0]->process($_[1][2]);
115}
116
117sub _process_nge {
118 return $_[0]->process($_[1][1]) >= $_[0]->process($_[1][2]);
119}
120
121sub _process_nle {
122 return $_[0]->process($_[1][1]) <= $_[0]->process($_[1][2]);
123}
124
125sub _process_match {
126 return $_[0]->process($_[1][1]) =~ $_[0]->process($_[1][2]);
127}
128
129sub _process_notmatch {
130 return $_[0]->process($_[1][1]) !~ $_[0]->process($_[1][2]);
131}
132
133sub _process_cond {
134 return $_[0]->process($_[1][1]) ? $_[0]->process($_[1][2]) : $_[0]->process($_[1][3]);
135}
136
137sub _process_uminus {
138 return - ($_[0]->process($_[1][1]));
139}
140
141sub _process_concat {
142 return $_[0]->process($_[1][1]) . $_[0]->process($_[1][2]);
143}
144
145sub _process_const {
146 return $_[1][1];
147}
148
149sub _process_call {
150 my ($self, $node, $ctx) = @_;
151
b12ea476
TC
152 $ctx ||= "";
153
ac507437
TC
154 my $val = $self->process($node->[2]);
155 my $args = $self->process_list($node->[3]);
156 my $method = $node->[1];
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
174sub _process_list {
175 my ($self, $node) = @_;
176
177 return $self->process_list($node->[1], 'LIST');
178}
179
180sub _process_range {
181 my ($self, $node, $ctx) = @_;
182
183 my $start = $self->process($node->[1]);
184 my $end = $self->process($node->[2]);
185
186 return $ctx eq 'LIST' ? ( $start .. $end ) : [ $start .. $end ];
187}
188
f17f9f79
TC
189sub _process_hash {
190 my ($self, $node) = @_;
191
192 my %result;
193 for my $pair (@{$node->[1]}) {
194 my $key = $self->process($pair->[0]);
195 my $value = $self->process($pair->[1]);
196 $result{$key} = $value;
197 }
198
199 return \%result;
200}
201
ac507437
TC
202sub _process_subscript {
203 my ($self, $node) = @_;
204
205 my $list = $self->process($node->[1]);
206 my $index = $self->process($node->[2]);
207 Scalar::Util::blessed($list)
208 and die [ error => "Cannot subscript an object" ];
209 my $type = Scalar::Util::reftype($list);
210 if ($type eq "HASH") {
211 return $list->{$index};
212 }
213 elsif ($type eq "ARRAY") {
214 return $list->[$index];
215 }
216 else {
217 die [ error => "Cannot subscript a $type" ];
218 }
219}
220
221sub _process_not {
222 return !$_[0]->process($_[1][1]);
223}
224
225sub _process_or {
226 return $_[0]->process($_[1][1]) || $_[0]->process($_[1][2]);
227}
228
229sub _process_and {
230 return $_[0]->process($_[1][1]) && $_[0]->process($_[1][2]);
231}
232
233sub process {
234 my ($self, $node, $ctx) = @_;
235
236 my $method = "_process_$node->[0]";
237 $self->can($method) or die "No handler for $node->[0]";
238 return $self->$method($node, $ctx);
239}
240
241sub process_list {
242 my ($self, $list) = @_;
243
244 return [ map $self->process($_, 'LIST'), @$list ];
245}
4697e5c3
TC
246
247package Squirrel::Template::Expr::Parser;
248
249sub new {
250 my ($class) = @_;
251
252 return bless {}, $class;
253}
254
255sub parse {
256 my ($self, $text) = @_;
257
258 my $tokenizer = Squirrel::Template::Expr::Tokenizer->new($text);
c507244d
TC
259 my $result = $self->_parse_expr($tokenizer);
260
261 my $last = $tokenizer->get;
262 unless ($last->[0] eq 'eof') {
263 die [ error => "Expected eof but found $last->[0]" ];
264 }
265
266 return $result;
4697e5c3
TC
267}
268
231cecfb
TC
269sub parse_tokens {
270 my ($self, $tokenizer) = @_;
271
272 return $self->_parse_expr($tokenizer);
273}
274
4697e5c3
TC
275sub _parse_expr {
276 my ($self, $tok) = @_;
277
ac507437 278 return $self->_parse_cond($tok);
4697e5c3
TC
279}
280
281my %ops =
282 (
ac507437
TC
283 "op+" => "add",
284 "op-" => "subtract",
285 "op*" => "mult",
286 "op/" => "fdiv",
4697e5c3
TC
287 "div" => "div",
288 "mod" => "mod",
289 "op_" => "concat",
ac507437
TC
290
291 "opeq" => "eq",
292 "opne" => "ne",
293 "oplt" => "lt",
294 "opgt" => "gt",
295 "ople" => "le",
296 "opge" => "ge",
297
298 "op==" => "neq",
299 "op!=" => "nne",
300 "op<" => "nlt",
301 "op>" => "ngt",
302 "op<=" => "nle",
303 "op>=" => "nge",
304 'op=~' => "match",
305 'op!~' => "notmatch",
4697e5c3
TC
306 );
307
ac507437
TC
308sub _parse_cond {
309 my ($self, $tok) = @_;
310
311 my $result = $self->_parse_or($tok);
312 if ($tok->peektype eq 'op?') {
313 $tok->get;
314 my $true = $self->_parse_or($tok);
315 my $colon = $tok->get;
316 $colon->[0] eq 'op:'
317 or die [ error => "Expected : for ? : operator but found $tok->[1]" ];
318 my $false = $self->_parse_or($tok);
319
320 $result = [ cond => $result, $true, $false ];
321 }
322
323 return $result;
324}
325
4697e5c3
TC
326sub _parse_or {
327 my ($self, $tok) = @_;
328
329 my $result = $self->_parse_and($tok);
330 while ($tok->peektype eq 'or') {
331 my $op = $tok->get;
332 my $other = $self->_parse_and($tok);
333 $result = [ or => $result, $other ];
334 }
335
336 return $result;
337}
338
339sub _parse_and {
340 my ($self, $tok) = @_;
341
342 my $result = $self->_parse_rel($tok);
343 while ($tok->peektype eq 'and') {
344 my $op = $tok->get;
345 my $other = $self->_parse_rel($tok);
346 $result = [ and => $result, $other ];
347 }
348
349 return $result;
350}
351
352my %relops = map {; "op$_" => 1 } qw(eq ne gt lt ge le == != < > >= <= =~ !~);
353
354sub _parse_rel {
355 my ($self, $tok) = @_;
356
357 my $result = $self->_parse_additive($tok);
358 my $nexttype = $tok->peektype;
359 while ($relops{$nexttype}) {
360 my $op = $tok->get;
361 my $other = $self->_parse_additive($tok);
ac507437 362 $result = [ $ops{$nexttype}, $result, $other ];
4697e5c3
TC
363 $nexttype = $tok->peektype;
364 }
365 return $result;
366}
367
368sub _parse_additive {
369 my ($self, $tok) = @_;
370
371 my $result = $self->_parse_mult($tok);
372 my $nexttype = $tok->peektype;
373 while ($nexttype eq 'op+' || $nexttype eq 'op-' || $nexttype eq 'op_') {
374 my $op = $tok->get;
375 my $other = $self->_parse_mult($tok);
376 $result = [ $ops{$nexttype}, $result, $other ];
377 $nexttype = $tok->peektype;
378 }
379 return $result;
380}
381
382sub _parse_mult {
383 my ($self, $tok) = @_;
384
385 my $result = $self->_parse_prefix($tok);
386 my $nexttype = $tok->peektype;
387 while ($nexttype eq 'op*' || $nexttype eq 'op/'
388 || $nexttype eq 'div' || $nexttype eq 'mod') {
389 my $op = $tok->get;
390 my $other = $self->_parse_prefix($tok);
391 $result = [ $ops{$op->[0]}, $result, $other ];
392 $nexttype = $tok->peektype;
393 }
394 return $result;
395}
396
397sub _parse_prefix {
398 my ($self, $tok) = @_;
399
400 my $nexttype = $tok->peektype('TERM');
401 if ($nexttype eq 'op(') {
402 $tok->get;
403 my $r = $self->_parse_expr($tok);
404 my $close = $tok->get;
405 unless ($close->[0] eq 'op)') {
406 die [ error => "Expected ')' but found $close->[0]" ];
407 }
408 return $r;
409 }
410 elsif ($nexttype eq 'op-') {
411 $tok->get;
412 return [ uminus => $self->_parse_prefix($tok) ];
413 }
414 elsif ($nexttype eq 'op+') {
415 $tok->get;
416 return $self->_parse_prefix($tok);
417 }
418 elsif ($nexttype eq 'op!' || $nexttype eq 'opnot') {
419 $tok->get;
420 return [ not => $self->_parse_prefix($tok) ];
421 }
422 else {
423 return $self->_parse_call($tok);
424 }
425}
426
427sub _parse_list {
428 my ($self, $tok) = @_;
429
430 $tok->peektype eq 'op)'
431 and return [];
432
433 my @list;
434 push @list, $self->_parse_expr($tok);
435 my $peek = $tok->peektype;
436 while ($peek eq 'op,' || $peek eq '..') {
437 $tok->get;
438 if ($peek eq '..') {
439 my $start = pop @list;
440 $start->[0] ne 'range'
441 or die [ error => "Can't use a range as the start of a range" ];
442 my $end = $self->_parse_expr($tok);
443 push @list, [ range => $start, $end ];
444 }
445 else {
446 push @list, $self->_parse_expr($tok);
447 }
448 $peek = $tok->peektype;
449 }
450
451 return \@list;
452}
453
454sub _parse_paren_list {
455 my ($self, $tok, $what) = @_;
456
457 my $open = $tok->get;
458 $open->[0] eq 'op('
459 or die [ error => "Expected '(' for $what but found $open->[0]" ];
460 my $list = $self->_parse_list($tok);
461 my $close = $tok->get;
462 $close->[0] eq 'op)'
463 or die [ error => "Expected ')' for $what but found $close->[0]" ];
464
465 return $list;
466}
467
468sub _parse_call {
469 my ($self, $tok) = @_;
470
471 my $result = $self->_parse_postfix($tok);
472 my $next = $tok->peektype;
473 while ($next eq 'op.' || $next eq 'op[') {
474 if ($next eq 'op.') {
475 $tok->get;
476 my $name = $tok->get;
477 $name->[0] eq 'id'
f75af510 478 or die [ error => "Expected method name after '.' but found $name->[1]" ];
4697e5c3
TC
479 my $list = [];
480 if ($tok->peektype eq 'op(') {
481 $list = $self->_parse_paren_list($tok, "method");
482 }
483 $result = [ call => $name->[2], $result, $list ];
484 }
485 elsif ($next eq 'op[') {
486 $tok->get;
487 my $index = $self->_parse_expr($tok);
488 my $close = $tok->get;
489 $close->[0] eq 'op]'
490 or die [ error => "Expected list end ']' but got $close->[0]" ];
491 $result = [ subscript => $result, $index ];
492 }
493 $next = $tok->peektype;
494 }
495
496 return $result;
497}
498
499sub _parse_postfix {
500 my ($self, $tok) = @_;
501
502 return $self->_parse_primary($tok);
503}
504
505sub _parse_primary {
506 my ($self, $tok) = @_;
507
508 my $t = $tok->get('TERM');
509 if ($t->[0] eq 'str' || $t->[0] eq 'num') {
510 return [ const => $t->[2] ];
511 }
ac507437
TC
512 elsif ($t->[0] eq 're') {
513 my $str = $t->[2];
514 my $opts = $t->[3];
515 my $sub = eval "sub { my \$str = shift; qr/\$str/$opts; }";
516 my $re;
517 $sub and $re = eval { $sub->($str) };
518 $re
519 or die [ error => "Cannot compile /$t->[2]/$opts: $@" ];
520 return [ const => $re ];
521 }
4697e5c3
TC
522 elsif ($t->[0] eq 'id') {
523 return [ var => $t->[2] ];
524 }
525 elsif ($t->[0] eq 'op[') {
39fbca4a
TC
526 my $list = [];
527 if ($tok->peektype ne 'op]') {
528 $list = $self->_parse_list($tok);
529 }
4697e5c3
TC
530 my $close = $tok->get;
531 $close->[0] eq 'op]'
532 or die [ error => "Expected ] but got $close->[0]" ];
533 return [ list => $list ];
534 }
f17f9f79
TC
535 elsif ($t->[0] eq 'op{') {
536 my @pairs;
537 if ($tok->peektype eq 'op}') {
538 $tok->get; # discard '}'
539 }
540 else {
541 my $next;
542 do {
543 my $key = $self->_parse_additive($tok);
544 my $colon = $tok->get;
545 $colon->[0] eq 'op:'
546 or die [ error => "Expected : in hash but found $colon->[1]" ];
547 my $value = $self->_parse_expr($tok);
548 push @pairs, [ $key, $value ];
549 } while ($next = $tok->get and $next->[0] eq 'op,');
550 $next->[0] eq 'op}'
551 or die [ error => "Expected , or } but found $tok->[1]" ];
552 }
553
554 return [ hash => \@pairs ];
555 }
4697e5c3
TC
556 elsif ($t->[0] eq 're') {
557 return [ re => $t->[2], $t->[3] ];
558 }
559 else {
560 die [ error => "Expected term but got $t->[0]" ];
561 }
562}
563
564package Squirrel::Template::Expr::Tokenizer;
565
566use constant TEXT => 0;
567use constant QUEUE => 1;
568
569sub new {
570 my ($class, $text) = @_;
571
572 return bless [ $text, [] ], $class;
573}
574
575my %escapes =
576 (
577 n => "\n",
578 "\\" => "\\",
579 t => "\t",
580 '"' => '"',
581 );
582
583sub get {
584 my ($self, $want) = @_;
585
586 my $queue = $self->[QUEUE];
587 @$queue
588 and return shift @$queue;
589 length $self->[TEXT]
590 or return;
591
592 $want ||= '';
593
594 if ($want ne 'TERM' &&
595 $self->[TEXT] =~ s/\A(\s*(div|mod|\.\.|and|or)\s*)//) {
596 push @$queue, [ $2 => $1 ];
597 }
598 elsif ($self->[TEXT] =~ s/\A(\s*(0x[0-9A-Fa-f]+)\s*)//) {
599 push @$queue, [ num => $1, oct $2 ];
600 }
601 elsif ($self->[TEXT] =~ s/\A(\s*(0b[01]+)\s*)//) {
602 push @$queue, [ num => $1, oct $2 ];
603 }
604 elsif ($self->[TEXT] =~ s/\A(\s*0o([0-7]+)\s*)//) {
605 push @$queue, [ num => $1, oct $2 ];
606 }
607 elsif ($self->[TEXT] =~ s/\A(\s*((?:\.[0-9]+|[0-9]+(?:\.[0-9]*)?)(?:[Ee][+-]?[0-9]+)?)\s*)//) {
608 push @$queue, [ num => $1, $2 ];
609 }
610 elsif ($want eq 'TERM' &&
611 $self->[TEXT] =~ s!\A(\s*/((?:[^/\\]|\\.)+)/([ismx]*\s)?\s*)!!) {
612 push @$queue, [ re => $1, $2, $3 || "" ];
613 }
f75af510 614 elsif ($self->[TEXT] =~ s/\A(\s*(not\b|eq\b|ne\b|le\b|lt\b|ge\b|gt\b|<=|>=|[!=]\=|\=\~|[_\?:,\[\]\(\)<>=!.*\/+\{\};-])\s*)//) {
4697e5c3
TC
615 push @$queue, [ "op$2" => $1 ];
616 }
617 elsif ($self->[TEXT] =~ s/\A(\s*([A-Za-z_][a-zA-Z_0-9]*)\s*)//) {
618 push @$queue, [ id => $1, $2 ];
619 }
620 elsif ($self->[TEXT] =~ s/\A(\s*\"((?:[^"\\]|\\["\\nt]|\\x[0-9a-fA-F]{2}|\\x\{[0-9a-fA-F]+\}|\\N\{[A-Za-z0-9 ]+\})*)\"\s*)//) {
621 my $orig = $1;
622 my $str = _process_escapes($2);
623 push @$queue, [ str => $1, $str ];
624 }
625 elsif ($self->[TEXT] =~ s/\A(\s*\'([^\']*)\'\s*)//) {
626 push @$queue, [ str => $1, $2 ];
627 }
628 else {
629 die [ error => "Unknown token '$self->[TEXT]'" ];
630 }
631
632 unless (length $self->[TEXT]) {
633 push @$queue, [ eof => "" ];
634 }
635
636 return shift @$queue;
637}
638
639sub unget {
640 my ($self, $tok) = @_;
641
642 unshift @{$self->[QUEUE]}, $tok;
643}
644
645sub peek {
646 my ($self, $what) = @_;
647
648 unless (@{$self->[QUEUE]}) {
649 my $t = $self->get($what)
650 or return;
651 unshift @{$self->[QUEUE]}, $t;
652 }
653
654 return $self->[QUEUE][0];
655}
656
657sub peektype {
658 my ($self, $what) = @_;
659
660 return $self->peek($what)->[0];
661}
662
663sub _process_escapes {
664 my ($str) = @_;
665
666 $str =~
667 s(
668 \\([nt\\\"])
669 |
670 \\x\{([0-9A-Fa-f]+)\}
671 |
672 \\x([0-9A-Fa-f]{2})
673 |
674 \\N\{([A-Za-z0-9\ ]+)\}
675 )(
676 $1 ? $escapes{$1} :
677 $2 ? chr(hex($2)) :
678 $3 ? chr(hex($3)) :
679 _vianame($4)
680 )gex;
681
682 return $str;
683}
684
685my $charnames_loaded;
686sub _vianame {
687 my ($name, $errors) = @_;
688
689 require charnames;
690 my $code = charnames::vianame($name);
691 unless (defined $code) {
692 die [ error => "Unknown \\N name '$name'" ];
693 }
694 return chr($code);
695}
696
6971;