File Coverage

blib/lib/Text/Xslate/Parser.pm
Criterion Covered Total %
statement 865 890 97.1
branch 217 248 87.5
condition 65 77 84.4
subroutine 116 118 98.3
pod 1 99 1.0
total 1264 1432 88.2


line stmt bran cond sub pod time code
1             package Text::Xslate::Parser;
2 172     172   222871 use Mouse;
  172         130245  
  172         1005  
3              
4 172     172   48869 use Scalar::Util ();
  172         370  
  172         3165  
5              
6 172     172   93445 use Text::Xslate::Symbol;
  172         18277  
  172         7578  
7 172         30030 use Text::Xslate::Util qw(
8             $DEBUG
9             $STRING $NUMBER
10             is_int any_in
11             neat
12             literal_to_value
13             make_error
14             p
15 172     172   1097 );
  172         316  
16              
17 172     172   1036 use constant _DUMP_PROTO => scalar($DEBUG =~ /\b dump=proto \b/xmsi);
  172         319  
  172         12186  
18 172     172   868 use constant _DUMP_TOKEN => scalar($DEBUG =~ /\b dump=token \b/xmsi);
  172         327  
  172         2016264  
19              
20             our @CARP_NOT = qw(Text::Xslate::Compiler Text::Xslate::Symbol);
21              
22             my $CODE = qr/ (?: $STRING | [^'"] ) /xms;
23             my $COMMENT = qr/\# [^\n;]* (?= [;\n] | \z)/xms;
24              
25             # Operator tokens that the parser recognizes.
26             # All the single characters are tokenized as an operator.
27             my $OPERATOR_TOKEN = sprintf '(?:%s|[^ \t\r\n])', join('|', map{ quotemeta } qw(
28             ...
29             ..
30             == != <=> <= >=
31             << >>
32             += -= *= /= %= ~=
33             &&= ||= //=
34             ~~ =~
35              
36             && || //
37             -> =>
38             ::
39             ++ --
40             +| +& +^ +< +> +~
41             ), ',');
42              
43             my %shortcut_table = (
44             '=' => 'print',
45             );
46              
47             my $CHOMP_FLAGS = qr/-/xms;
48              
49              
50             has identity_pattern => (
51             is => 'ro',
52             isa => 'RegexpRef',
53              
54             builder => '_build_identity_pattern',
55             init_arg => undef,
56             );
57              
58             sub _build_identity_pattern {
59 182     182   29605 return qr/(?: (?:[A-Za-z_]|\$\~?) [A-Za-z0-9_]* )/xms;
60             }
61              
62             has [qw(compiler engine)] => (
63             is => 'rw',
64             required => 0,
65             weak_ref => 1,
66             );
67              
68             has symbol_table => ( # the global symbol table
69             is => 'ro',
70             isa => 'HashRef',
71              
72             default => sub{ {} },
73              
74             init_arg => undef,
75             );
76              
77             has iterator_element => (
78             is => 'ro',
79             isa => 'HashRef',
80              
81             lazy => 1,
82             builder => '_build_iterator_element',
83              
84             init_arg => undef,
85             );
86              
87             has scope => (
88             is => 'rw',
89             isa => 'ArrayRef[HashRef]',
90              
91             clearer => 'init_scope',
92              
93             lazy => 1,
94             default => sub{ [ {} ] },
95              
96             init_arg => undef,
97             );
98              
99             has token => (
100             is => 'rw',
101             isa => 'Maybe[Object]',
102              
103             init_arg => undef,
104             );
105              
106             has next_token => ( # to peek the next token
107             is => 'rw',
108             isa => 'Maybe[ArrayRef]',
109              
110             init_arg => undef,
111             );
112              
113             has statement_is_finished => (
114             is => 'rw',
115             isa => 'Bool',
116              
117             init_arg => undef,
118             );
119              
120             has following_newline => (
121             is => 'rw',
122             isa => 'Int',
123              
124             default => 0,
125             init_arg => undef,
126             );
127              
128             has input => (
129             is => 'rw',
130             isa => 'Str',
131              
132             init_arg => undef,
133             );
134              
135             has line_start => (
136             is => 'ro',
137             isa => 'Maybe[Str]',
138             builder => '_build_line_start',
139             );
140 176     176   6711 sub _build_line_start { ':' }
141              
142             has tag_start => (
143             is => 'ro',
144             isa => 'Str',
145             builder => '_build_tag_start',
146             );
147 177     177   6467 sub _build_tag_start { '<:' }
148              
149             has tag_end => (
150             is => 'ro',
151             isa => 'Str',
152             builder => '_build_tag_end',
153             );
154 177     177   6514 sub _build_tag_end { ':>' }
155              
156             has comment_pattern => (
157             is => 'ro',
158             isa => 'RegexpRef',
159             builder => '_build_comment_pattern',
160             );
161 241     241   7177 sub _build_comment_pattern { $COMMENT }
162              
163             has shortcut_table => (
164             is => 'ro',
165             isa => 'HashRef[Str]',
166             builder => '_build_shortcut_table',
167             );
168 241     241   5638 sub _build_shortcut_table { \%shortcut_table }
169              
170             has in_given => (
171             is => 'rw',
172             isa => 'Bool',
173             init_arg => undef,
174             );
175              
176             # attributes for error messages
177              
178             has near_token => (
179             is => 'rw',
180              
181             init_arg => undef,
182             );
183              
184             has file => (
185             is => 'rw',
186             required => 0,
187             );
188              
189             has line => (
190             is => 'rw',
191             required => 0,
192             );
193              
194             has input_layer => (
195             is => 'ro',
196             default => ':utf8',
197             );
198              
199             sub symbol_class() { 'Text::Xslate::Symbol' }
200              
201             # the entry point
202             sub parse {
203 3459     3459 0 34831 my($parser, $input, %args) = @_;
204              
205 3459   100     16522 local $parser->{file} = $args{file} || \$input;
206 3459   50     17569 local $parser->{line} = $args{line} || 1;
207 3459         8468 local $parser->{in_given} = 0;
208 3459         6190 local $parser->{scope} = [ map { +{ %{$_} } } @{ $parser->scope } ];
  3459         6049  
  3459         20470  
  3459         15361  
209 3459         6681 local $parser->{symbol_table} = { %{ $parser->symbol_table } };
  3459         183573  
210 3459         29887 local $parser->{near_token};
211 3459         8167 local $parser->{next_token};
212 3459         7974 local $parser->{token};
213 3459         7935 local $parser->{input};
214              
215 3459         11810 $parser->input( $parser->preprocess($input) );
216              
217 3454         11247 $parser->next_token( $parser->tokenize() );
218 3454         10856 $parser->advance();
219 3453         10553 my $ast = $parser->statements();
220              
221 3412 100       14280 if(my $input_pos = pos $parser->{input}) {
222 3409 100       13053 if($input_pos != length($parser->{input})) {
223 2         9 $parser->_error("Syntax error", $parser->token);
224             }
225             }
226              
227 3410         79232 return $ast;
228             }
229              
230             sub trim_code {
231 5198     5198 0 10412 my($parser, $s) = @_;
232              
233 5198         15971 $s =~ s/\A [ \t]+ //xms;
234 5198         22366 $s =~ s/ [ \t]+ \n?\z//xms;
235              
236 5198         15542 return $s;
237             }
238              
239             sub auto_chomp {
240 10379     10379 0 20006 my($parser, $tokens_ref, $i, $s_ref) = @_;
241              
242 10379         14775 my $p;
243 10379         16279 my $nl = 0;
244              
245             # postchomp
246 10379 100 100     52083 if($i >= 1
247             and ($p = $tokens_ref->[$i-1])->[0] eq 'postchomp') {
248             # [ CODE ][*][ TEXT ]
249             # <: ... -:> \nfoobar
250             # ^^^^
251 391         456 ${$s_ref} =~ s/\A [ \t]* (\n)//xms;
  391         1578  
252 391 100       1276 if($1) {
253 386         564 $nl++;
254             }
255             }
256              
257             # prechomp
258 10379 100 100     17584 if(($i+1) < @{$tokens_ref}
  10379 100 100     59651  
      66        
      100        
259             and ($p = $tokens_ref->[$i+1])->[0] eq 'prechomp') {
260 51 100       69 if(${$s_ref} !~ / [^ \t] /xms) {
  51         164  
261             # HERE
262             # [ TEXT ][*][ CODE ]
263             # <:- ... :>
264             # ^^^^^^^^
265 34         48 ${$s_ref} = '';
  34         66  
266             }
267             else {
268             # HERE
269             # [ TEXT ][*][ CODE ]
270             # \n<:- ... :>
271             # ^^
272 17         26 $nl += chomp ${$s_ref};
  17         57  
273             }
274             }
275 10328         64799 elsif(($i+2) < @{$tokens_ref}
276             and ($p = $tokens_ref->[$i+2])->[0] eq 'prechomp'
277             and ($p = $tokens_ref->[$i+1])->[0] eq 'text'
278             and $p->[1] !~ / [^ \t] /xms) {
279             # HERE
280             # [ TEXT ][ TEXT ][*][ CODE ]
281             # \n <:- ... :>
282             # ^^^^^^^^^^
283 16         27 $p->[1] = '';
284 16         24 $nl += (${$s_ref} =~ s/\n\z//xms);
  16         48  
285             }
286 10379         28525 return $nl;
287             }
288              
289             # split templates by tags before tokenizing
290             sub split :method {
291 3459     3459 0 6336 my $parser = shift;
292 3459         8595 local($_) = @_;
293              
294 3459         6359 my @tokens;
295              
296 3459         10941 my $line_start = $parser->line_start;
297 3459         10019 my $tag_start = $parser->tag_start;
298 3459         10060 my $tag_end = $parser->tag_end;
299              
300 3459   66     38291 my $lex_line_code = defined($line_start)
301             && qr/\A ^ [ \t]* \Q$line_start\E ([^\n]* \n?) /xms;
302              
303 3459         20579 my $lex_tag_start = qr/\A \Q$tag_start\E ($CHOMP_FLAGS?)/xms;
304              
305             # 'text' is a something without newlines
306             # following a newline, $tag_start, or end of the input
307 3459         19713 my $lex_text = qr/\A ( [^\n]*? (?: \n | (?= \Q$tag_start\E ) | \z ) ) /xms;
308              
309 3459         11165 my $lex_comment = $parser->comment_pattern;
310 3459         30261 my $lex_code = qr/(?: $lex_comment | $CODE )/xms;
311              
312 3459         7577 my $in_tag = 0;
313              
314 3459         11082 while($_ ne '') {
315 18248 100 100     3204720 if($in_tag) {
    100 66        
    100 100        
    50          
316 2653         5181 my $start = 0;
317 2653         5004 my $pos;
318 2653         11602 while( ($pos = index $_, $tag_end, $start) >= 0 ) {
319 2652         8489 my $code = substr $_, 0, $pos;
320 2652         47785 $code =~ s/$lex_code//xmsg;
321 2652 100       8945 if(length($code) == 0) {
322 2649         7923 last;
323             }
324 3         11 $start = $pos + 1;
325             }
326              
327 2653 100       7037 if($pos >= 0) {
328 2649         9396 my $code = substr $_, 0, $pos, '';
329 2649         16446 $code =~ s/($CHOMP_FLAGS?) \z//xmso;
330 2649         7185 my $chomp = $1;
331              
332 2649 50       16611 s/\A \Q$tag_end\E //xms or die "Oops!";
333              
334 2649         9275 push @tokens, [ code => $code ];
335 2649 100       7875 if($chomp) {
336 393         1007 push @tokens, [ postchomp => $chomp ];
337             }
338 2649         14264 $in_tag = 0;
339             }
340             else {
341 4         11 last; # the end tag is not found
342             }
343             }
344             # not $in_tag
345             elsif($lex_line_code
346             && (@tokens == 0 || $tokens[-1][1] =~ /\n\z/xms)
347             && s/$lex_line_code//xms) {
348 2554         12847 push @tokens, [ code => $1 ];
349             }
350             elsif(s/$lex_tag_start//xms) {
351 2654         5456 $in_tag = 1;
352              
353 2654         6868 my $chomp = $1;
354 2654 100       13531 if($chomp) {
355 60         295 push @tokens, [ prechomp => $chomp ];
356             }
357             }
358             elsif(s/$lex_text//xms) {
359 10387         59238 push @tokens, [ text => $1 ];
360             }
361             else {
362 0         0 confess "Oops: Unreached code, near" . p($_);
363             }
364             }
365              
366 3459 100       9347 if($in_tag) {
367             # calculate line number
368 5         11 my $orig_src = $_[0];
369 5         28 substr $orig_src, -length($_), length($_), '';
370 5         14 my $line = ($orig_src =~ tr/\n/\n/);
371 5         50 $parser->_error("Malformed templates detected",
372             neat((split /\n/, $_)[0]), ++$line,
373             );
374             }
375             #p(\@tokens);
376 3454         20619 return \@tokens;
377             }
378              
379             sub preprocess {
380 3459     3459 0 7330 my($parser, $input) = @_;
381              
382             # tokenization
383              
384 3459         10399 my $tokens_ref = $parser->split($input);
385 3454         7621 my $code = '';
386              
387 3454         11405 my $shortcut_table = $parser->shortcut_table;
388 3454         9195 my $shortcut = join('|', map{ quotemeta } keys %shortcut_table);
  3454         13911  
389 3454         17324 my $shortcut_rx = qr/\A ($shortcut)/xms;
390              
391 3454         7694 for(my $i = 0; $i < @{$tokens_ref}; $i++) {
  19488         65495  
392 16034         23404 my($type, $s) = @{ $tokens_ref->[$i] };
  16034         44615  
393              
394 16034 100       44019 if($type eq 'text') {
    100          
    100          
    50          
395 10379         28640 my $nl = $parser->auto_chomp($tokens_ref, $i, \$s);
396              
397 10379         25967 $s =~ s/(["\\])/\\$1/gxms; # " for poor editors
398              
399             # $s may have single new line
400 10379         35774 $nl += ($s =~ s/\n/\\n/xms);
401              
402 10379         30318 $code .= qq{print_raw "$s";}; # must set even if $s is empty
403 10379 100       47592 $code .= qq{\n} if $nl > 0;
404             }
405             elsif($type eq 'code') {
406             # shortcut commands
407 5202 50       27314 $s =~ s/$shortcut_rx/$shortcut_table->{$1}/xms
408             if $shortcut;
409              
410 5202         14835 $s = $parser->trim_code($s);
411              
412 5202 100       25212 if($s =~ /\A \s* [}] \s* \z/xms){
    100          
413 546         1268 $code .= $s;
414             }
415             elsif($s =~ s/\n\z//xms) {
416 2028         6555 $code .= qq{$s\n};
417             }
418             else {
419 2628         15056 $code .= qq{$s;}; # auto semicolon insertion
420             }
421             }
422             elsif($type eq 'prechomp') {
423             # noop, just a marker
424             }
425             elsif($type eq 'postchomp') {
426             # noop, just a marker
427             }
428             else {
429 0         0 $parser->_error("Oops: Unknown token: $s ($type)");
430             }
431             }
432 3454         6087 print STDOUT $code, "\n" if _DUMP_PROTO;
433 3454         28350 return $code;
434             }
435              
436             sub BUILD {
437 241     241 1 2305 my($parser) = @_;
438 241         3637 $parser->_init_basic_symbols();
439 241         3498 $parser->init_symbols();
440 241         7088 return;
441             }
442              
443             # The grammer
444              
445             sub _init_basic_symbols {
446 241     241   2259 my($parser) = @_;
447              
448 241         3345 $parser->symbol('(end)')->is_block_end(1); # EOF
449              
450             # prototypes of value symbols
451 241         2344 foreach my $type (qw(name variable literal)) {
452 723         7879 my $s = $parser->symbol("($type)");
453 723         7784 $s->arity($type);
454 723         18361 $s->set_nud( $parser->can("nud_$type") );
455             }
456              
457             # common separators
458 241         2562 $parser->symbol(';')->set_nud(\&nud_separator);
459 241         3228 $parser->define_pair('(' => ')');
460 241         2622 $parser->define_pair('{' => '}');
461 241         2382 $parser->define_pair('[' => ']');
462 241         2679 $parser->symbol(',') ->is_comma(1);
463 241         2435 $parser->symbol('=>') ->is_comma(1);
464              
465             # common commands
466 241         2512 $parser->symbol('print') ->set_std(\&std_print);
467 241         2563 $parser->symbol('print_raw')->set_std(\&std_print);
468              
469             # special literals
470 241         3229 $parser->define_literal(nil => undef);
471 241         2401 $parser->define_literal(true => 1);
472 241         2491 $parser->define_literal(false => 0);
473              
474             # special tokens
475 241         2502 $parser->symbol('__FILE__')->set_nud(\&nud_current_file);
476 241         2561 $parser->symbol('__LINE__')->set_nud(\&nud_current_line);
477 241         2517 $parser->symbol('__ROOT__')->set_nud(\&nud_current_vars);
478              
479 241         4876 return;
480             }
481              
482             sub init_basic_operators {
483 241     241 0 2669 my($parser) = @_;
484              
485             # define operator precedence
486              
487 241         3738 $parser->prefix('{', 256, \&nud_brace);
488 241         2719 $parser->prefix('[', 256, \&nud_brace);
489              
490 241         3379 $parser->infix('(', 256, \&led_call);
491 241         3374 $parser->infix('.', 256, \&led_dot);
492 241         3240 $parser->infix('[', 256, \&led_fetch);
493              
494 241         4200 $parser->prefix('(', 256, \&nud_paren);
495              
496 241         3370 $parser->prefix('!', 200)->is_logical(1);
497 241         3296 $parser->prefix('+', 200);
498 241         2467 $parser->prefix('-', 200);
499 241         2723 $parser->prefix('+^', 200); # numeric bitwise negate
500              
501 241         2473 $parser->infix('*', 190);
502 241         2515 $parser->infix('/', 190);
503 241         2995 $parser->infix('%', 190);
504 241         2501 $parser->infix('x', 190);
505 241         2620 $parser->infix('+&', 190); # numeric bitwise and
506              
507 241         2747 $parser->infix('+', 180);
508 241         2980 $parser->infix('-', 180);
509 241         2503 $parser->infix('~', 180); # connect
510 241         2708 $parser->infix('+|', 180); # numeric bitwise or
511 241         2854 $parser->infix('+^', 180); # numeric bitwise xor
512              
513              
514 241         3080 $parser->prefix('defined', 170, \&nud_defined); # named unary operator
515              
516 241         2473 $parser->infix('<', 160)->is_logical(1);
517 241         2925 $parser->infix('<=', 160)->is_logical(1);
518 241         2583 $parser->infix('>', 160)->is_logical(1);
519 241         2615 $parser->infix('>=', 160)->is_logical(1);
520              
521 241         2640 $parser->infix('==', 150)->is_logical(1);
522 241         2653 $parser->infix('!=', 150)->is_logical(1);
523 241         2459 $parser->infix('<=>', 150);
524 241         2712 $parser->infix('cmp', 150);
525 241         2624 $parser->infix('~~', 150);
526              
527 241         2839 $parser->infix('|', 140, \&led_pipe);
528              
529 241         2499 $parser->infix('&&', 130)->is_logical(1);
530              
531 241         2605 $parser->infix('||', 120)->is_logical(1);
532 241         2716 $parser->infix('//', 120)->is_logical(1);
533 241         2470 $parser->infix('min', 120);
534 241         2502 $parser->infix('max', 120);
535              
536 241         3081 $parser->infix('..', 110, \&led_range);
537              
538 241         2596 $parser->symbol(':');
539 241         3528 $parser->infixr('?', 100, \&led_ternary);
540              
541 241         4408 $parser->assignment('=', 90);
542 241         2635 $parser->assignment('+=', 90);
543 241         2798 $parser->assignment('-=', 90);
544 241         2607 $parser->assignment('*=', 90);
545 241         2750 $parser->assignment('/=', 90);
546 241         2487 $parser->assignment('%=', 90);
547 241         2519 $parser->assignment('~=', 90);
548 241         2395 $parser->assignment('&&=', 90);
549 241         2883 $parser->assignment('||=', 90);
550 241         2575 $parser->assignment('//=', 90);
551              
552 241         3439 $parser->make_alias('!' => 'not')->ubp(70);
553 241         3821 $parser->make_alias('&&' => 'and')->lbp(60);
554 241         2692 $parser->make_alias('||' => 'or') ->lbp(50);
555 241         4093 return;
556             }
557              
558             sub init_symbols {
559 182     182 0 2420 my($parser) = @_;
560 182         2438 my $s;
561              
562             # syntax specific separators
563 182         2574 $parser->symbol('{');
564 182         2396 $parser->symbol('}')->is_block_end(1); # block end
565 182         2399 $parser->symbol('->');
566 182         2411 $parser->symbol('else');
567 182         2390 $parser->symbol('with');
568 182         2808 $parser->symbol('::');
569              
570             # operators
571 182         3230 $parser->init_basic_operators();
572              
573             # statements
574 182         2203 $s = $parser->symbol('if');
575 182         2489 $s->set_std(\&std_if);
576 182         2646 $s->can_be_modifier(1);
577              
578 182         2279 $parser->symbol('for') ->set_std(\&std_for);
579 182         2264 $parser->symbol('while' ) ->set_std(\&std_while);
580 182         2369 $parser->symbol('given') ->set_std(\&std_given);
581 182         2268 $parser->symbol('when') ->set_std(\&std_when);
582 182         2194 $parser->symbol('default') ->set_std(\&std_when);
583              
584 182         2204 $parser->symbol('include') ->set_std(\&std_include);
585              
586 182         2266 $parser->symbol('last') ->set_std(\&std_last);
587 182         2239 $parser->symbol('next') ->set_std(\&std_next);
588              
589             # macros
590              
591 182         2177 $parser->symbol('cascade') ->set_std(\&std_cascade);
592 182         2185 $parser->symbol('macro') ->set_std(\&std_proc);
593 182         2265 $parser->symbol('around') ->set_std(\&std_proc);
594 182         2317 $parser->symbol('before') ->set_std(\&std_proc);
595 182         2192 $parser->symbol('after') ->set_std(\&std_proc);
596 182         2251 $parser->symbol('block') ->set_std(\&std_macro_block);
597 182         2341 $parser->symbol('super') ->set_std(\&std_super);
598 182         2232 $parser->symbol('override') ->set_std(\&std_override);
599              
600 182         2261 $parser->symbol('->') ->set_nud(\&nud_lambda);
601              
602             # lexical variables/constants stuff
603 182         2281 $parser->symbol('constant')->set_nud(\&nud_constant);
604 182         2317 $parser->symbol('my' )->set_nud(\&nud_constant);
605              
606 182         3816 return;
607             }
608              
609             sub _build_iterator_element {
610             return {
611 4     4   92 index => \&iterator_index,
612             count => \&iterator_count,
613             is_first => \&iterator_is_first,
614             is_last => \&iterator_is_last,
615             body => \&iterator_body,
616             size => \&iterator_size,
617             max_index => \&iterator_max_index,
618             peek_next => \&iterator_peek_next,
619             peek_prev => \&iterator_peek_prev,
620             cycle => \&iterator_cycle,
621             };
622             }
623              
624              
625             sub symbol {
626 52957     52957 0 304673 my($parser, $id, $lbp) = @_;
627              
628 52957         333424 my $stash = $parser->symbol_table;
629 52957         304909 my $s = $stash->{$id};
630 52957 100       318892 if(defined $s) {
631 25242 100       104204 if(defined $lbp) {
632 1205         32727 $s->lbp($lbp);
633             }
634             }
635             else { # create a new symbol
636 27715   100     532631 $s = $parser->symbol_class->new(id => $id, lbp => $lbp || 0);
637 27715         496869 $stash->{$id} = $s;
638             }
639              
640 52957         613426 return $s;
641             }
642              
643             sub define_pair {
644 723     723 0 6313 my($parser, $left, $right) = @_;
645 723         6918 $parser->symbol($left) ->counterpart($right);
646 723         6926 $parser->symbol($right)->counterpart($left);
647 723         11462 return;
648             }
649              
650             # the low-level tokenizer. Don't use it directly, use advance() instead.
651             sub tokenize {
652 64606     64606 0 105495 my($parser) = @_;
653              
654 64606         144040 local *_ = \$parser->{input};
655              
656 64606         157394 my $comment_rx = $parser->comment_pattern;
657 64606         143754 my $id_rx = $parser->identity_pattern;
658 64606         96240 my $count = 0;
659             TRY: {
660 64606         95399 /\G (\s*) /xmsgc;
  64652         178529  
661 64652         146850 $count += ( $1 =~ tr/\n/\n/);
662 64652         173263 $parser->following_newline( $count );
663              
664 64652 100       624648 if(/\G $comment_rx /xmsgc) {
    100          
    100          
    100          
    50          
665 46         116 redo TRY; # retry
666             }
667             elsif(/\G ($id_rx)/xmsgc){
668 19450         128094 return [ name => $1 ];
669             }
670             elsif(/\G ($NUMBER | $STRING)/xmsogc){
671 17593         109476 return [ literal => $1 ];
672             }
673             elsif(/\G ($OPERATOR_TOKEN)/xmsogc){
674 24146         145613 return [ operator => $1 ];
675             }
676             elsif(/\G (\S+)/xmsgc) {
677 0         0 Carp::confess("Oops: Unexpected token '$1'");
678             }
679             else { # empty
680 3417         20827 return [ special => '(end)' ];
681             }
682             }
683             }
684              
685             sub next_token_is {
686 19489     19489 0 35685 my($parser, $token) = @_;
687 19489         120858 return $parser->next_token->[1] eq $token;
688             }
689              
690             # the high-level tokenizer
691             sub advance {
692 64577     64577 0 110436 my($parser, $expect) = @_;
693              
694 64577         147479 my $t = $parser->token;
695 64577 100 100     184996 if(defined($expect) && $t->id ne $expect) {
696 7         25 $parser->_unexpected(neat($expect), $t);
697             }
698              
699 64570         155053 $parser->near_token($t);
700              
701 64570         267125 my $stash = $parser->symbol_table;
702              
703 64570         149433 $t = $parser->next_token;
704              
705 64570 100       166750 if($t->[0] eq 'special') {
706 3418         19587 return $parser->token( $stash->{ $t->[1] } );
707             }
708 61152         213285 $parser->statement_is_finished( $parser->following_newline != 0 );
709 61152         247986 my $line = $parser->line( $parser->line + $parser->following_newline );
710              
711 61152         145842 $parser->next_token( $parser->tokenize() );
712              
713 61152         100190 my($arity, $id) = @{$t};
  61152         155714  
714 61152 100 100     195265 if( $arity eq "name" && $parser->next_token_is("=>") ) {
715 63         109 $arity = "literal";
716             }
717              
718 61152         85571 print STDOUT "[$arity => $id] #$line\n" if _DUMP_TOKEN;
719              
720 61152         81720 my $symbol;
721 61152 100       155638 if($arity eq "literal") {
    100          
722 17655         42124 $symbol = $parser->symbol('(literal)')->clone(
723             id => $id,
724             value => $parser->parse_literal($id)
725             );
726             }
727             elsif($arity eq "operator") {
728 24117         48406 $symbol = $stash->{$id};
729 24117 100       56292 if(not defined $symbol) {
730 3         12 $parser->_error("Unknown operator '$id'");
731             }
732 24114         74467 $symbol = $symbol->clone(
733             arity => $arity, # to make error messages clearer
734             );
735             }
736             else { # name
737             # find_or_create() returns a cloned symbol,
738             # so there's not need to clone() here
739 19380         47302 $symbol = $parser->find_or_create($id);
740             }
741              
742 61149         902447 $symbol->line($line);
743 61149         287076 return $parser->token($symbol);
744             }
745              
746             sub parse_literal {
747 17655     17655 0 29594 my($parser, $literal) = @_;
748 17655         53314 return literal_to_value($literal);
749             }
750              
751             sub nud_name {
752 341     341 0 552 my($parser, $symbol) = @_;
753 341         939 return $symbol->clone(
754             arity => 'name',
755             );
756             }
757             sub nud_variable {
758 2775     2775 0 6010 my($parser, $symbol) = @_;
759 2775         8940 return $symbol->clone(
760             arity => 'variable',
761             );
762             }
763             sub nud_literal {
764 17634     17634 0 28077 my($parser, $symbol) = @_;
765 17634         48168 return $symbol->clone(
766             arity => 'literal',
767             );
768             }
769              
770             sub default_nud {
771 377     377 0 558 my($parser, $symbol) = @_;
772 377         1009 return $symbol->clone(); # as is
773             }
774              
775             sub default_led {
776 0     0 0 0 my($parser, $symbol) = @_;
777 0         0 $parser->near_token($parser->token);
778 0         0 $parser->_error(
779             sprintf 'Missing operator (%s): %s',
780             $symbol->arity, $symbol->id);
781             }
782              
783             sub default_std {
784 0     0 0 0 my($parser, $symbol) = @_;
785 0         0 $parser->near_token($parser->token);
786 0         0 $parser->_error(
787             sprintf 'Not a statement (%s): %s',
788             $symbol->arity, $symbol->id);
789             }
790              
791             sub expression {
792 21886     21886 0 35469 my($parser, $rbp) = @_;
793              
794 21886         49678 my $t = $parser->token;
795              
796 21886         46600 $parser->advance();
797              
798 21886         67428 my $left = $t->nud($parser);
799              
800 21871         545521 while($rbp < $parser->token->lbp) {
801 1923         9466 $t = $parser->token;
802 1923         5090 $parser->advance();
803 1923         5683 $left = $t->led($parser, $left);
804             }
805              
806 21853         90278 return $left;
807             }
808              
809             sub expression_list {
810 12214     12214 0 21337 my($parser) = @_;
811 12214         19081 my @list;
812 12214         19095 while(1) {
813 17524 100       71023 if($parser->token->is_value) {
814 17276         41589 push @list, $parser->expression(0);
815             }
816              
817 17524 100       74148 if(!$parser->token->is_comma) {
818 12214         27585 last;
819             }
820              
821 5310         10517 $parser->advance(); # comma
822             }
823 12214         40920 return \@list;
824             }
825              
826             # for left associative infix operators
827             sub led_infix {
828 863     863 0 1265 my($parser, $symbol, $left) = @_;
829 863         2831 return $parser->binary( $symbol, $left, $parser->expression($symbol->lbp) );
830             }
831              
832             sub infix {
833 6989     6989 0 67276 my($parser, $id, $bp, $led) = @_;
834              
835 6989         69551 my $symbol = $parser->symbol($id, $bp);
836 6989   100     88802 $symbol->set_led($led || \&led_infix);
837 6989         125667 return $symbol;
838             }
839              
840             # for right associative infix operators
841             sub led_infixr {
842 26     26 0 49 my($parser, $symbol, $left) = @_;
843 26         136 return $parser->binary( $symbol, $left, $parser->expression($symbol->lbp - 1) );
844             }
845              
846             sub infixr {
847 241     241 0 2806 my($parser, $id, $bp, $led) = @_;
848              
849 241         4885 my $symbol = $parser->symbol($id, $bp);
850 241   50     3482 $symbol->set_led($led || \&led_infixr);
851 241         4573 return $symbol;
852             }
853              
854             # for prefix operators
855             sub prefix {
856 1928     1928 0 18233 my($parser, $id, $bp, $nud) = @_;
857              
858 1928         18833 my $symbol = $parser->symbol($id);
859 1928         21451 $symbol->ubp($bp);
860 1928   100     44073 $symbol->set_nud($nud || \&nud_prefix);
861 1928         34898 return $symbol;
862             }
863              
864             sub nud_prefix {
865 51     51 0 96 my($parser, $symbol) = @_;
866 51         250 my $un = $symbol->clone(arity => 'unary');
867 51         1079 $parser->reserve($un);
868 51         200 $un->first($parser->expression($symbol->ubp));
869 50         120 return $un;
870             }
871              
872             sub led_assignment {
873 11     11 0 21 my($parser, $symbol, $left) = @_;
874              
875 11         42 $parser->_error("Assignment ($symbol) is forbidden", $left);
876             }
877              
878             sub assignment {
879 1820     1820 0 22410 my($parser, $id, $bp) = @_;
880              
881 1820         24166 $parser->symbol($id, $bp)->set_led(\&led_assignment);
882 1820         38136 return;
883             }
884              
885             # the ternary is a right associative operator
886             sub led_ternary {
887 115     115 0 184 my($parser, $symbol, $left) = @_;
888              
889 115         329 my $if = $symbol->clone(arity => 'if');
890              
891 115         2280 $if->first($left);
892 115         459 $if->second([$parser->expression( $symbol->lbp - 1 )]);
893 113         307 $parser->advance(":");
894 113         426 $if->third([$parser->expression( $symbol->lbp - 1 )]);
895 113         617 return $if;
896             }
897              
898             sub is_valid_field {
899 447     447 0 663 my($parser, $token) = @_;
900 447         1174 my $arity = $token->arity;
901              
902 447 100       1133 if($arity eq "name") {
    100          
903 409         1434 return 1;
904             }
905             elsif($arity eq "literal") {
906 9         40 return is_int($token->id);
907             }
908 29         279 return 0;
909             }
910              
911             sub led_dot {
912 447     447 0 738 my($parser, $symbol, $left) = @_;
913              
914 447         1044 my $t = $parser->token;
915 447 50       1254 if(!$parser->is_valid_field($t)) {
916 0         0 $parser->_unexpected("a field name", $t);
917             }
918              
919 447         1520 my $dot = $symbol->clone(
920             arity => "field",
921             first => $left,
922             second => $t->clone(arity => 'literal'),
923             );
924              
925 447         9922 $t = $parser->advance();
926 447 100       1747 if($t->id eq "(") {
927 230         632 $parser->advance(); # "("
928 230         623 $dot->third( $parser->expression_list() );
929 230         602 $parser->advance(")");
930 230         680 $dot->arity("methodcall");
931             }
932              
933 447         3287 return $dot;
934             }
935              
936             sub led_fetch { # $h[$field]
937 90     90 0 164 my($parser, $symbol, $left) = @_;
938              
939 90         282 my $fetch = $symbol->clone(
940             arity => "field",
941             first => $left,
942             second => $parser->expression(0),
943             );
944 90         2169 $parser->advance("]");
945 90         530 return $fetch;
946             }
947              
948             sub call {
949 193     193 0 403 my($parser, $function, @args) = @_;
950 193 100       568 if(not ref $function) {
951 4         9 $function = $parser->symbol('(name)')->clone(
952             arity => 'name',
953             id => $function,
954             line => $parser->line,
955             );
956             }
957              
958 193         586 return $parser->symbol('(call)')->clone(
959             arity => 'call',
960             first => $function,
961             second => \@args,
962             );
963             }
964              
965             sub led_call {
966 295     295 0 497 my($parser, $symbol, $left) = @_;
967              
968 295         837 my $call = $symbol->clone(arity => 'call');
969 295         6158 $call->first($left);
970 295         799 $call->second( $parser->expression_list() );
971 295         699 $parser->advance(")");
972              
973 294         1675 return $call;
974             }
975              
976             sub led_pipe { # filter
977 64     64 0 106 my($parser, $symbol, $left) = @_;
978             # a | b -> b(a)
979 64         241 return $parser->call($parser->expression($symbol->lbp), $left);
980             }
981              
982             sub led_range { # x .. y
983 7     7 0 12 my($parser, $symbol, $left) = @_;
984 7         24 return $symbol->clone(
985             arity => 'range',
986             first => $left,
987             second => $parser->expression(0),
988             );
989             }
990              
991             sub nil {
992 26     26 0 117 my($parser) = @_;
993 26         80 return $parser->symbol('nil')->nud($parser);
994             }
995              
996             sub nud_defined {
997 23     23 0 42 my($parser, $symbol) = @_;
998 23         62 $parser->reserve( $symbol->clone() );
999             # prefix: is a syntactic sugar to $a != nil
1000 23         143 return $parser->binary(
1001             '!=',
1002             $parser->expression($symbol->ubp),
1003             $parser->nil,
1004             );
1005             }
1006              
1007             # for special literals (e.g. nil, true, false)
1008             sub nud_special {
1009 170     170 0 307 my($parser, $symbol) = @_;
1010 170         670 return $symbol->first;
1011             }
1012              
1013             sub define_literal { # special literals
1014 723     723 0 6501 my($parser, $id, $value) = @_;
1015              
1016 723         6889 my $symbol = $parser->symbol($id);
1017 723 100       8813 $symbol->first( $symbol->clone(
1018             arity => defined($value) ? 'literal' : 'nil',
1019             value => $value,
1020             ) );
1021 723         15235 $symbol->set_nud(\&nud_special);
1022 723         7716 $symbol->is_defined(1);
1023 723         11404 return $symbol;
1024             }
1025              
1026             sub new_scope {
1027 918     918 0 1347 my($parser) = @_;
1028 918         1178 push @{ $parser->scope }, {};
  918         2954  
1029 918         1722 return;
1030             }
1031              
1032             sub pop_scope {
1033 901     901 0 1355 my($parser) = @_;
1034 901         1157 pop @{ $parser->scope };
  901         2341  
1035 901         2574 return;
1036             }
1037              
1038             sub undefined_name {
1039 3616     3616 0 7766 my($parser, $name) = @_;
1040 3616 100       12738 if($name =~ /\A \$/xms) {
1041 2845         13936 return $parser->symbol_table->{'(variable)'}->clone(
1042             id => $name,
1043             );
1044             }
1045             else {
1046 771         3368 return $parser->symbol_table->{'(name)'}->clone(
1047             id => $name,
1048             );
1049             }
1050             }
1051              
1052             sub find_or_create { # find a name from all the scopes
1053 19439     19439 0 36405 my($parser, $name) = @_;
1054 19439         29127 my $s;
1055 19439         29622 foreach my $scope(reverse @{$parser->scope}){
  19439         70791  
1056 22632         43160 $s = $scope->{$name};
1057 22632 100       67679 if(defined $s) {
1058 6016         19586 return $s->clone();
1059             }
1060             }
1061 13423         43805 $s = $parser->symbol_table->{$name};
1062 13423 100       48983 return defined($s) ? $s : $parser->undefined_name($name);
1063             }
1064              
1065             sub reserve { # reserve a name to the scope
1066 13817     13817 0 25693 my($parser, $symbol) = @_;
1067 13817 100 100     97042 if($symbol->arity ne 'name' or $symbol->is_reserved) {
1068 13246         24809 return $symbol;
1069             }
1070              
1071 571         5433 my $top = $parser->scope->[-1];
1072 571         5479 my $t = $top->{$symbol->id};
1073 571 50       5099 if($t) {
1074 0 0       0 if($t->is_reserved) {
1075 0         0 return $symbol;
1076             }
1077 0 0       0 if($t->arity eq "name") {
1078 0         0 $parser->_error("Already defined: $symbol");
1079             }
1080             }
1081 571         5523 $top->{$symbol->id} = $symbol;
1082 571         5709 $symbol->is_reserved(1);
1083             #$symbol->scope($top);
1084 571         8255 return $symbol;
1085             }
1086              
1087             sub define { # define a name to the scope
1088 595     595 0 938 my($parser, $symbol) = @_;
1089 595         1514 my $top = $parser->scope->[-1];
1090              
1091 595         1598 my $t = $top->{$symbol->id};
1092 595 100       1453 if(defined $t) {
1093 1 50       8 $parser->_error($t->is_reserved ? "Already is_reserved: $t" : "Already defined: $t");
1094             }
1095              
1096 594         1940 $top->{$symbol->id} = $symbol;
1097              
1098 594         1619 $symbol->is_defined(1);
1099 594         1801 $symbol->is_reserved(0);
1100 594         1507 $symbol->remove_nud();
1101 594         1405 $symbol->remove_led();
1102 594         1313 $symbol->remove_std();
1103 594         1322 $symbol->lbp(0);
1104             #$symbol->scope($top);
1105 594         1173 return $symbol;
1106             }
1107              
1108             sub print {
1109 1223     1223 0 2549 my($parser, @args) = @_;
1110 1223         2965 return $parser->symbol('print')->clone(
1111             arity => 'print',
1112             first => \@args,
1113             line => $parser->line,
1114             );
1115             }
1116              
1117             sub binary {
1118 994     994 0 1902 my($parser, $symbol, $lhs, $rhs) = @_;
1119 994 100       2353 if(!ref $symbol) {
1120             # operator
1121 109         249 $symbol = $parser->symbol($symbol);
1122             }
1123 994 50       2165 if(!ref $lhs) {
1124             # literal
1125 0         0 $lhs = $parser->symbol('(literal)')->clone(
1126             id => $lhs,
1127             );
1128             }
1129 994 100       2165 if(!ref $rhs) {
1130             # literal
1131 39         81 $rhs = $parser->symbol('(literal)')->clone(
1132             id => $rhs,
1133             );
1134             }
1135 994         3708 return $symbol->clone(
1136             arity => 'binary',
1137             first => $lhs,
1138             second => $rhs,
1139             );
1140             }
1141              
1142             sub define_function {
1143 497     497 0 12645 my($parser, @names) = @_;
1144              
1145 497         2851 foreach my $name(@names) {
1146 6035         53680 my $s = $parser->symbol($name);
1147 6035         111482 $s->set_nud(\&nud_name);
1148 6035         60735 $s->is_defined(1);
1149             }
1150 497         6943 return;
1151             }
1152              
1153             sub finish_statement {
1154 14066     14066 0 27663 my($parser, $expr) = @_;
1155              
1156 14066         37288 my $t = $parser->token;
1157 14066 100       47286 if($t->can_be_modifier) {
1158 30         63 $parser->advance();
1159 30         93 $expr = $t->std($parser, $expr);
1160 30         78 $t = $parser->token;
1161             }
1162              
1163 14066 100 100     107437 if($t->is_block_end or $parser->statement_is_finished) {
    100          
1164             # noop
1165             }
1166             elsif($t->id eq ";") {
1167 12617         30915 $parser->advance();
1168             }
1169             else {
1170 4         28 $parser->_unexpected("a semicolon or block end", $t);
1171             }
1172 14060         140305 return $expr;
1173             }
1174              
1175             sub statement { # process one or more statements
1176 15329     15329 0 25862 my($parser) = @_;
1177 15329         37400 my $t = $parser->token;
1178              
1179 15329 100       52559 if($t->id eq ";"){
1180 448         941 $parser->advance(); # ";"
1181 448         2230 return;
1182             }
1183              
1184 14881 100       49253 if($t->has_std) { # is $t a statement?
1185 13655         34457 $parser->reserve($t);
1186 13655         32820 $parser->advance();
1187              
1188             # std() can return a list of nodes
1189 13655         44585 return $t->std($parser);
1190             }
1191              
1192 1226         3056 my $expr = $parser->auto_command( $parser->expression(0) );
1193 1200         25609 return $parser->finish_statement($expr);
1194             }
1195              
1196             sub auto_command {
1197 1200     1200 0 1930 my($parser, $expr) = @_;
1198 1200 100       3817 if($expr->is_statement) {
1199             # expressions can produce pure statements (e.g. assignment )
1200 81         154 return $expr;
1201             }
1202             else {
1203 1119         3129 return $parser->print($expr);
1204             }
1205             }
1206              
1207             sub statements { # process statements
1208 4317     4317 0 7599 my($parser) = @_;
1209 4317         7370 my @a;
1210              
1211 4317         20841 for(my $t = $parser->token; !$t->is_block_end; $t = $parser->token) {
1212 15279         40652 push @a, $parser->statement();
1213             }
1214              
1215 4266         13799 return \@a;
1216             }
1217              
1218             sub block {
1219 212     212 0 317 my($parser) = @_;
1220 212         490 $parser->new_scope();
1221 212         447 $parser->advance("{");
1222 212         458 my $a = $parser->statements();
1223 212         486 $parser->advance("}");
1224 211         478 $parser->pop_scope();
1225 211         648 return $a;
1226             }
1227              
1228             sub nud_paren {
1229 121     121 0 198 my($parser, $symbol) = @_;
1230 121         329 my $expr = $parser->expression(0);
1231 121         462 $parser->advance( $symbol->counterpart );
1232 121         272 return $expr;
1233             }
1234              
1235             # for object literals
1236             sub nud_brace {
1237 141     141 0 251 my($parser, $symbol) = @_;
1238              
1239 141         429 my $list = $parser->expression_list();
1240              
1241 141         567 $parser->advance($symbol->counterpart);
1242 141         470 return $symbol->clone(
1243             arity => 'composer',
1244             first => $list,
1245             );
1246             }
1247              
1248             # iterator variables ($~iterator)
1249             # $~iterator . NAME | NAME()
1250             sub nud_iterator {
1251 55     55 0 111 my($parser, $symbol) = @_;
1252              
1253 55         140 my $iterator = $symbol->clone();
1254 55 100       1262 if($parser->token->id eq ".") {
1255 51         111 $parser->advance();
1256              
1257 51         183 my $t = $parser->token;
1258 51 50       229 if(!any_in($t->arity, qw(variable name))) {
1259 0         0 $parser->_unexpected("a field name", $t);
1260             }
1261              
1262 51         424 my $generator = $parser->iterator_element->{$t->value};
1263 51 50       189 if(!$generator) {
1264 0         0 $parser->_error("Undefined iterator element: $t");
1265             }
1266              
1267 51         118 $parser->advance(); # element name
1268              
1269 51         64 my $args;
1270 51 100       224 if($parser->token->id eq "(") {
1271 15         35 $parser->advance();
1272 15         35 $args = $parser->expression_list();
1273 15         37 $parser->advance(")");
1274             }
1275              
1276 51         146 $iterator->second($t);
1277 51         66 return $generator->($parser, $iterator, @{$args});
  51         173  
1278             }
1279 4         10 return $iterator;
1280             }
1281              
1282             sub nud_constant {
1283 70     70 0 112 my($parser, $symbol) = @_;
1284 70         176 my $t = $parser->token;
1285              
1286 70 50       318 my $expect = $symbol->id eq 'constant' ? 'name'
    100          
1287             : $symbol->id eq 'my' ? 'variable'
1288             : die "Oops: $symbol";
1289              
1290 70 50       245 if($t->arity ne $expect) {
1291 0         0 $parser->_unexpected("a $expect", $t);
1292             }
1293 70         200 $parser->define($t)->arity("name");
1294              
1295 69         152 $parser->advance();
1296 69         153 $parser->advance("=");
1297              
1298 69         182 return $symbol->clone(
1299             arity => 'constant',
1300             first => $t,
1301             second => $parser->expression(0),
1302             is_statement => 1,
1303             );
1304             }
1305              
1306             my $lambda_id = 0;
1307             sub lambda {
1308 56     56 0 556 my($parser, $proto) = @_;
1309 56         146 my $name = $parser->symbol('(name)')->clone(
1310             id => sprintf('lambda@%s:%d', $parser->file, $lambda_id++),
1311             );
1312              
1313 56         1187 return $parser->symbol('(name)')->clone(
1314             arity => 'proc',
1315             id => 'macro',
1316             first => $name,
1317             line => $proto->line,
1318             );
1319             }
1320              
1321             # -> $x { ... }
1322             sub nud_lambda {
1323 39     39 0 61 my($parser, $symbol) = @_;
1324              
1325 39         114 my $pointy = $parser->lambda($symbol);
1326              
1327 39         963 $parser->new_scope();
1328 39         49 my @params;
1329 39 50       178 if($parser->token->id ne "{") { # has params
1330 39         125 my $paren = ($parser->token->id eq "(");
1331              
1332 39 50       89 $parser->advance("(") if $paren; # optional
1333              
1334 39         83 my $t = $parser->token;
1335 39         150 while($t->arity eq "variable") {
1336 54         93 push @params, $t;
1337 54         132 $parser->define($t);
1338              
1339 54         116 $t = $parser->advance();
1340 54 100       183 if($t->id eq ",") {
1341 15         30 $t = $parser->advance(); # ","
1342             }
1343             else {
1344 39         61 last;
1345             }
1346             }
1347              
1348 39 50       107 $parser->advance(")") if $paren;
1349             }
1350 39         140 $pointy->second( \@params );
1351              
1352 39         92 $parser->advance("{");
1353 39         103 $pointy->third($parser->statements());
1354 39         91 $parser->advance("}");
1355 39         94 $parser->pop_scope();
1356              
1357 39         112 return $symbol->clone(
1358             arity => 'lambda',
1359             first => $pointy,
1360             );
1361             }
1362              
1363             sub nud_current_file {
1364 1     1 0 3 my($self, $symbol) = @_;
1365 1         7 my $file = $self->file;
1366 1 50       6 return $symbol->clone(
1367             arity => 'literal',
1368             value => ref($file) ? '' : $file,
1369             );
1370             }
1371              
1372             sub nud_current_line {
1373 14     14 0 29 my($self, $symbol) = @_;
1374 14         54 return $symbol->clone(
1375             arity => 'literal',
1376             value => $symbol->line,
1377             );
1378             }
1379              
1380             sub nud_current_vars {
1381 5     5 0 10 my($self, $symbol) = @_;
1382 5         14 return $symbol->clone(
1383             arity => 'vars',
1384             );
1385             }
1386              
1387             sub nud_separator {
1388 4     4 0 6 my($self, $symbol) = @_;
1389 4         12 $self->_error("Invalid expression found", $symbol);
1390             }
1391              
1392             # -> VARS { STATEMENTS }
1393             # -> { STATEMENTS }
1394             # { STATEMENTS }
1395             sub pointy {
1396 436     436 0 790 my($parser, $pointy, $in_for) = @_;
1397              
1398 436         556 my @params;
1399              
1400 436         1200 $parser->new_scope();
1401              
1402 436 100       2028 if($parser->token->id eq "->") {
1403 416         880 $parser->advance();
1404 416 100       2054 if($parser->token->id ne "{") {
1405 225         835 my $paren = ($parser->token->id eq "(");
1406              
1407 225 100       654 $parser->advance("(") if $paren;
1408              
1409 225         549 my $t = $parser->token;
1410 225         867 while($t->arity eq "variable") {
1411 231         447 push @params, $t;
1412 231         692 $parser->define($t);
1413              
1414 231 100       564 if($in_for) {
1415 149         492 $parser->define_iterator($t);
1416             }
1417              
1418 231         548 $t = $parser->advance();
1419              
1420 231 100       1056 if($t->id eq ",") {
1421 7         22 $t = $parser->advance(); # ","
1422             }
1423             else {
1424 224         350 last;
1425             }
1426             }
1427              
1428 225 100       709 $parser->advance(")") if $paren;
1429             }
1430             }
1431 434         1606 $pointy->second( \@params );
1432              
1433 434         1213 $parser->advance("{");
1434 432         1156 $pointy->third($parser->statements());
1435 422         1057 $parser->advance("}");
1436 422         1298 $parser->pop_scope();
1437              
1438 422         779 return;
1439             }
1440              
1441             sub iterator_name {
1442 149     149 0 224 my($parser, $var) = @_;
1443             # $foo -> $~foo
1444 149         1194 (my $it_name = $var->id) =~ s/\A (\$?) /${1}~/xms;
1445 149         603 return $it_name;
1446             }
1447              
1448             sub define_iterator {
1449 184     184 0 370 my($parser, $var) = @_;
1450              
1451 184         592 my $it = $parser->symbol( $parser->iterator_name($var) )->clone(
1452             arity => 'iterator',
1453             first => $var,
1454             );
1455 184         4046 $parser->define($it);
1456 184         1236 $it->set_nud(\&nud_iterator);
1457 184         425 return $it;
1458             }
1459              
1460             sub std_for {
1461 149     149 0 296 my($parser, $symbol) = @_;
1462              
1463 149         482 my $proc = $symbol->clone(arity => 'for');
1464 149         3181 $proc->first( $parser->expression(0) );
1465 149         610 $parser->pointy($proc, 1);
1466              
1467             # for-else support
1468 139 100       2114 if($parser->token eq 'else') {
1469 5         13 $parser->advance();
1470 5         19 my $else = $parser->block();
1471 5         20 $proc = $symbol->clone( arity => 'for_else',
1472             first => $proc,
1473             second => $else,
1474             )
1475             }
1476 139         1048 return $proc;
1477             }
1478              
1479             sub std_while {
1480 15     15 0 23 my($parser, $symbol) = @_;
1481              
1482 15         51 my $proc = $symbol->clone(arity => 'while');
1483 15         321 $proc->first( $parser->expression(0) );
1484 15         46 $parser->pointy($proc);
1485 15         97 return $proc;
1486             }
1487              
1488             # macro name -> { ... }
1489             sub std_proc {
1490 150     150 0 379 my($parser, $symbol) = @_;
1491              
1492 150         458 my $macro = $symbol->clone(arity => "proc");
1493 150         3009 my $name = $parser->token;
1494              
1495 150 50       688 if($name->arity ne "name") {
1496 0         0 $parser->_unexpected("a name", $name);
1497             }
1498              
1499 150         572 $parser->define_function($name->id);
1500 150         409 $macro->first($name);
1501 150         346 $parser->advance();
1502 150         473 $parser->pointy($macro);
1503 146         881 return $macro;
1504             }
1505              
1506             # block name -> { ... }
1507             # block name | filter -> { ... }
1508             sub std_macro_block {
1509 92     92 0 169 my($parser, $symbol) = @_;
1510              
1511 92         295 my $macro = $symbol->clone(arity => "proc");
1512 92         1907 my $name = $parser->token;
1513              
1514 92 50       418 if($name->arity ne "name") {
1515 0         0 $parser->_unexpected("a name", $name);
1516             }
1517              
1518             # auto filters
1519 92         137 my @filters;
1520 92         262 my $t = $parser->advance();
1521 92         420 while($t->id eq "|") {
1522 11         48 $t = $parser->advance();
1523              
1524 11 50       63 if($t->arity ne "name") {
1525 0         0 $parser->_unexpected("a name", $name);
1526             }
1527 11         35 my $filter = $t->clone();
1528 11         184 $t = $parser->advance();
1529              
1530 11         15 my $args;
1531 11 100       42 if($t->id eq "(") {
1532 2         6 $parser->advance();
1533 2         6 $args = $parser->expression_list();
1534 2         7 $t = $parser->advance(")");
1535             }
1536             push @filters, $args
1537 11 100       85 ? $parser->call($filter, @{$args})
  2         8  
1538             : $filter;
1539             }
1540              
1541 92         387 $parser->define_function($name->id);
1542 92         246 $macro->first($name);
1543 92         288 $parser->pointy($macro);
1544              
1545 92         478 my $call = $parser->call($macro->first);
1546 92 100       2059 if(@filters) {
1547 9         18 foreach my $filter(@filters) { # apply filters
1548 11         63 $call = $parser->call($filter, $call);
1549             }
1550             }
1551             # std() can return a list
1552 92         502 return( $macro, $parser->print($call) );
1553             }
1554              
1555             sub std_override { # synonym to 'around'
1556 6     6 0 13 my($parser, $symbol) = @_;
1557              
1558 6         20 return $parser->std_proc($symbol->clone(id => 'around'));
1559             }
1560              
1561             sub std_if {
1562 112     112 0 186 my($parser, $symbol, $expr) = @_;
1563              
1564 112         317 my $if = $symbol->clone(arity => "if");
1565              
1566 112         2317 $if->first( $parser->expression(0) );
1567              
1568 112 100       291 if(defined $expr) { # statement modifier
1569 13         47 $if->second([$expr]);
1570 13         35 return $if;
1571             }
1572              
1573 99         293 $if->second( $parser->block() );
1574              
1575 98         128 my $top_if = $if;
1576              
1577 98         227 my $t = $parser->token;
1578 98         375 while($t->id eq "elsif") {
1579 3         8 $parser->reserve($t);
1580 3         7 $parser->advance(); # "elsif"
1581              
1582 3         10 my $elsif = $t->clone(arity => "if");
1583 3         57 $elsif->first( $parser->expression(0) );
1584 3         9 $elsif->second( $parser->block() );
1585 3         11 $if->third([$elsif]);
1586 3         3 $if = $elsif;
1587 3         14 $t = $parser->token;
1588             }
1589              
1590 98 100       356 if($t->id eq "else") {
1591 56         146 $parser->reserve($t);
1592 56         117 $t = $parser->advance(); # "else"
1593              
1594 56 100       263 $if->third( $t->id eq "if"
1595             ? [$parser->statement()]
1596             : $parser->block());
1597             }
1598 98         762 return $top_if;
1599             }
1600              
1601             sub std_given {
1602 30     30 0 46 my($parser, $symbol) = @_;
1603              
1604 30         85 my $given = $symbol->clone(arity => 'given');
1605 30         616 $given->first( $parser->expression(0) );
1606              
1607 30         68 local $parser->{in_given} = 1;
1608 30         85 $parser->pointy($given);
1609              
1610 30 100 66     124 if(!(defined $given->second && @{$given->second})) { # if no topic vars
  30         164  
1611 14         39 $given->second([
1612             $parser->symbol('($_)')->clone(arity => 'variable' )
1613             ]);
1614             }
1615              
1616 30         435 $parser->build_given_body($given, "when");
1617 30         196 return $given;
1618             }
1619              
1620             # when/default
1621             sub std_when {
1622 60     60 0 84 my($parser, $symbol) = @_;
1623              
1624 60 50       205 if(!$parser->in_given) {
1625 0         0 $parser->_error("You cannot use $symbol blocks outside given blocks");
1626             }
1627 60         163 my $proc = $symbol->clone(arity => 'when');
1628 60 100       1240 if($symbol->id eq "when") {
1629 31         204 $proc->first( $parser->expression(0) );
1630             }
1631 60         139 $proc->second( $parser->block() );
1632 60         338 return $proc;
1633             }
1634              
1635             sub _only_white_spaces {
1636 21     21   31 my($s) = @_;
1637 21   33     230 return $s->arity eq "literal"
1638             && $s->value =~ m{\A [ \t\r\n]* \z}xms
1639             }
1640              
1641             sub build_given_body {
1642 40     40 0 75 my($parser, $given, $expect) = @_;
1643 40         47 my($topic) = @{$given->second};
  40         127  
1644              
1645             # make if-elsif-else chain from given-when
1646 40         55 my $if;
1647             my $elsif;
1648 0         0 my $else;
1649 40         61 foreach my $when(@{$given->third}) {
  40         122  
1650 101 100       309 if($when->arity ne $expect) {
1651             # ignore white space
1652 22 100 66     81 if($when->id eq "print_raw"
1653 21         39 && !grep { !_only_white_spaces($_) } @{$when->first}) {
  21         49  
1654 21         38 next;
1655             }
1656 1         5 $parser->_unexpected("$expect blocks", $when);
1657             }
1658 79         184 $when->arity("if"); # change the arity
1659              
1660 79 100       221 if(defined(my $test = $when->first)) { # when
1661 43 100       143 if(!$test->is_logical) {
1662 31         86 $when->first( $parser->binary('~~', $topic, $test) );
1663             }
1664             }
1665             else { # default
1666 36         96 $when->first( $parser->symbol('true')->nud($parser) );
1667 36         50 $else = $when;
1668 36         81 next;
1669             }
1670              
1671 43 100       733 if(!defined $if) {
1672 35         39 $if = $when;
1673 35         63 $elsif = $when;
1674             }
1675             else {
1676 8         25 $elsif->third([$when]);
1677 8         17 $elsif = $when;
1678             }
1679             }
1680 39 100       101 if(defined $else) { # default
1681 36 100       81 if(defined $elsif) {
1682 33         97 $elsif->third([$else]);
1683             }
1684             else {
1685 3         8 $if = $else; # only default
1686             }
1687             }
1688 39 100       138 $given->third(defined $if ? [$if] : undef);
1689 39         133 return;
1690             }
1691              
1692             sub std_include {
1693 1253     1253 0 1917 my($parser, $symbol) = @_;
1694              
1695 1253         2727 my $arg = $parser->barename();
1696 1253         2865 my $vars = $parser->localize_vars();
1697 1253         3589 my $stmt = $symbol->clone(
1698             first => $arg,
1699             second => $vars,
1700             arity => 'include',
1701             );
1702 1253         27609 return $parser->finish_statement($stmt);
1703             }
1704              
1705             sub std_print {
1706 11518     11518 0 21695 my($parser, $symbol) = @_;
1707 11518         18756 my $args;
1708 11518 50       54060 if($parser->token->id ne ";") {
1709 11518         29691 $args = $parser->expression_list();
1710             }
1711 11518         39173 my $stmt = $symbol->clone(
1712             arity => 'print',
1713             first => $args,
1714             );
1715 11518         288768 return $parser->finish_statement($stmt);
1716             }
1717              
1718             # for cascade() and include()
1719             sub barename {
1720 1333     1333 0 1730 my($parser) = @_;
1721              
1722 1333         2852 my $t = $parser->token;
1723 1333 100 100     5312 if($t->arity ne 'name' or $t->is_defined) {
1724             # string literal for 'cascade', or any expression for 'include'
1725 1264         2698 return $parser->expression(0);
1726             }
1727              
1728             # path::to::name
1729 69         96 my @parts;
1730 69         147 push @parts, $t;
1731 69         158 $parser->advance();
1732              
1733 69         97 while(1) {
1734 121         281 my $t = $parser->token;
1735              
1736 121 100       463 if($t->id eq "::") {
1737 52         115 $t = $parser->advance(); # "::"
1738              
1739 52 50       210 if($t->arity ne "name") {
1740 0         0 $parser->_unexpected("a name", $t);
1741             }
1742              
1743 52         89 push @parts, $t;
1744 52         113 $parser->advance();
1745             }
1746             else {
1747 69         136 last;
1748             }
1749             }
1750 69         169 return \@parts;
1751             }
1752              
1753             # NOTHING | { expression-list }
1754             sub localize_vars {
1755 1299     1299 0 1927 my($parser) = @_;
1756 1299 100       4923 if($parser->token->id eq "{") {
1757 13         28 $parser->advance();
1758 13         49 $parser->new_scope();
1759 13         43 my $vars = $parser->expression_list();
1760 13         40 $parser->pop_scope();
1761 13         27 $parser->advance("}");
1762 13         29 return $vars;
1763             }
1764 1286         2186 return undef;
1765             }
1766              
1767             sub std_cascade {
1768 64     64 0 110 my($parser, $symbol) = @_;
1769              
1770 64         99 my $base;
1771 64 100       352 if($parser->token->id ne "with") {
1772 57         216 $base = $parser->barename();
1773             }
1774              
1775 64         99 my $components;
1776 64 100       328 if($parser->token->id eq "with") {
1777 11         27 $parser->advance(); # "with"
1778              
1779 11         35 my @c = $parser->barename();
1780 11         65 while($parser->token->id eq ",") {
1781 2         4 $parser->advance(); # ","
1782 2         5 push @c, $parser->barename();
1783             }
1784 11         26 $components = \@c;
1785             }
1786              
1787 64         241 my $vars = $parser->localize_vars();
1788 64         243 my $stmt = $symbol->clone(
1789             arity => 'cascade',
1790             first => $base,
1791             second => $components,
1792             third => $vars,
1793             );
1794 64         1592 return $parser->finish_statement($stmt);
1795             }
1796              
1797             sub std_super {
1798 7     7 0 14 my($parser, $symbol) = @_;
1799 7         23 my $stmt = $symbol->clone(arity => 'super');
1800 7         137 return $parser->finish_statement($stmt);
1801             }
1802              
1803             sub std_next {
1804 5     5 0 10 my($parser, $symbol) = @_;
1805 5         16 my $stmt = $symbol->clone(arity => 'loop_control', id => 'next');
1806 5         116 return $parser->finish_statement($stmt);
1807             }
1808              
1809             sub std_last {
1810 7     7 0 13 my($parser, $symbol) = @_;
1811 7         21 my $stmt = $symbol->clone(arity => 'loop_control', id => 'last');
1812 7         177 return $parser->finish_statement($stmt);
1813             }
1814              
1815             # iterator elements
1816              
1817             sub bad_iterator_args {
1818 8     8 0 14 my($parser, $iterator) = @_;
1819 8         33 $parser->_error("Wrong number of arguments for $iterator." . $iterator->second);
1820             }
1821              
1822             sub iterator_index {
1823 16     16 0 157 my($parser, $iterator, @args) = @_;
1824 16 100       66 $parser->bad_iterator_args($iterator) if @args != 0;
1825             # $~iterator
1826 15         52 return $iterator;
1827             }
1828              
1829             sub iterator_count {
1830 10     10 0 21 my($parser, $iterator, @args) = @_;
1831 10 100       33 $parser->bad_iterator_args($iterator) if @args != 0;
1832             # $~iterator + 1
1833 9         35 return $parser->binary('+', $iterator, 1);
1834             }
1835              
1836             sub iterator_is_first {
1837 7     7 0 18 my($parser, $iterator, @args) = @_;
1838 7 100       26 $parser->bad_iterator_args($iterator) if @args != 0;
1839             # $~iterator == 0
1840 6         22 return $parser->binary('==', $iterator, 0);
1841             }
1842              
1843             sub iterator_is_last {
1844 4     4 0 10 my($parser, $iterator, @args) = @_;
1845 4 100       19 $parser->bad_iterator_args($iterator) if @args != 0;
1846             # $~iterator == $~iterator.max_index
1847 3         25 return $parser->binary('==', $iterator, $parser->iterator_max_index($iterator));
1848             }
1849              
1850             sub iterator_body {
1851 16     16 0 30 my($parser, $iterator, @args) = @_;
1852 16 50       57 $parser->bad_iterator_args($iterator) if @args != 0;
1853             # $~iterator.body
1854 16         49 return $iterator->clone(
1855             arity => 'iterator_body',
1856             );
1857             }
1858              
1859             sub iterator_size {
1860 3     3 0 77 my($parser, $iterator, @args) = @_;
1861 3 100       17 $parser->bad_iterator_args($iterator) if @args != 0;
1862             # $~iterator.max_index + 1
1863 2         9 return $parser->binary('+', $parser->iterator_max_index($iterator), 1);
1864             }
1865              
1866             sub iterator_max_index {
1867 8     8 0 18 my($parser, $iterator, @args) = @_;
1868 8 100       37 $parser->bad_iterator_args($iterator) if @args != 0;
1869             # __builtin_max_index($~iterator.body)
1870 7         18 return $parser->symbol('max_index')->clone(
1871             arity => 'unary',
1872             first => $parser->iterator_body($iterator),
1873             );
1874             }
1875              
1876             sub _iterator_peek {
1877 6     6   13 my($parser, $iterator, $pos) = @_;
1878             # $~iterator.body[ $~iterator.index + $pos ]
1879 6         19 return $parser->binary('[',
1880             $parser->iterator_body($iterator),
1881             $parser->binary('+', $parser->iterator_index($iterator), $pos),
1882             );
1883             }
1884              
1885             sub iterator_peek_next {
1886 3     3 0 9 my($parser, $iterator, @args) = @_;
1887 3 50       13 $parser->bad_iterator_args($iterator) if @args != 0;
1888 3         24 return $parser->_iterator_peek($iterator, +1);
1889             }
1890              
1891             sub iterator_peek_prev {
1892 5     5 0 16 my($parser, $iterator, @args) = @_;
1893 5 100       23 $parser->bad_iterator_args($iterator) if @args != 0;
1894             # $~iterator.is_first ? nil :
1895 3         11 return $parser->symbol('?')->clone(
1896             arity => 'if',
1897             first => $parser->iterator_is_first($iterator),
1898             second => [$parser->nil],
1899             third => [$parser->_iterator_peek($iterator, -1)],
1900             );
1901             }
1902              
1903             sub iterator_cycle {
1904 6     6 0 14 my($parser, $iterator, @args) = @_;
1905 6 50       19 $parser->bad_iterator_args($iterator) if @args < 2;
1906             # $iterator.cycle("foo", "bar", "baz") makes:
1907             # ($tmp = $~iterator % n) == 0 ? "foo"
1908             # : $tmp == 1 ? "bar"
1909             # : "baz"
1910 6         15 $parser->new_scope();
1911              
1912 6         18 my $mod = $parser->binary('%', $iterator, scalar @args);
1913              
1914             # for the second time
1915 6         131 my $tmp = $parser->symbol('($cycle)')->clone(arity => 'name');
1916              
1917             # for the first time
1918 6         111 my $cond = $iterator->clone(
1919             arity => 'constant',
1920             first => $tmp,
1921             second => $mod,
1922             );
1923              
1924 6         126 my $parent = $iterator->clone(
1925             arity => 'if',
1926             first => $parser->binary('==', $cond, 0),
1927             second => [ $args[0] ],
1928             );
1929 6         125 my $child = $parent;
1930              
1931 6         12 my $last = pop @args;
1932 6         19 for(my $i = 1; $i < @args; $i++) {
1933 4         20 my $nth = $iterator->clone(
1934             arity => 'if',
1935             id => "$iterator.cycle: $i",
1936             first => $parser->binary('==', $tmp, $i),
1937             second => [$args[$i]],
1938             );
1939              
1940 4         99 $child->third([$nth]);
1941 4         14 $child = $nth;
1942             }
1943 6         21 $child->third([$last]);
1944              
1945 6         18 $parser->pop_scope();
1946 6         20 return $parent;
1947             }
1948              
1949             # utils
1950              
1951             sub make_alias { # alas(from => to)
1952 3260     3260 0 10917 my($parser, $from, $to) = @_;
1953              
1954 3260         12575 my $stash = $parser->symbol_table;
1955 3260 50       15353 if(exists $parser->symbol_table->{$to}) {
1956             Carp::confess(
1957             "Cannot make an alias to an existing symbol ($from => $to / "
1958 0         0 . p($parser->symbol_table->{$to}) .")");
1959             }
1960              
1961             # make a snapshot
1962 3260         11602 return $stash->{$to} = $parser->symbol($from)->clone(
1963             value => $to, # real id
1964             );
1965             }
1966              
1967             sub not_supported {
1968 2     2 0 4 my($parser, $symbol) = @_;
1969 2         52 $parser->_error("'$symbol' is not supported");
1970             }
1971              
1972             sub _unexpected {
1973 13     13   26 my($parser, $expected, $got) = @_;
1974 13 100 66     160 if(defined($got) && $got ne ";") {
1975 12 100       57 if($got eq '(end)') {
1976 2         14 $parser->_error("Expected $expected, but reached EOF");
1977             }
1978             else {
1979 10         36 $parser->_error("Expected $expected, but got " . neat("$got"));
1980             }
1981             }
1982             else {
1983 1         5 $parser->_error("Expected $expected");
1984             }
1985             }
1986              
1987             sub _error {
1988 49     49   98 my($parser, $message, $near, $line) = @_;
1989              
1990 49   100     393 $near ||= $parser->near_token || ";";
      66        
1991 49 100 100     255 if($near ne ";" && $message !~ /\b \Q$near\E \b/xms) {
1992 39         118 $message .= ", near $near";
1993             }
1994 49   66     480 die $parser->make_error($message . ", while parsing templates",
1995             $parser->file, $line || $parser->line);
1996             }
1997              
1998 172     172   1833 no Mouse;
  172         410  
  172         1466  
1999             __PACKAGE__->meta->make_immutable;
2000             __END__