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