File Coverage

blib/lib/Template/Alloy/Parse.pm
Criterion Covered Total %
statement 480 547 87.7
branch 283 348 81.3
condition 131 190 68.9
subroutine 38 45 84.4
pod 5 38 13.1
total 937 1168 80.2


line stmt bran cond sub pod time code
1             package Template::Alloy::Parse;
2              
3             =head1 NAME
4              
5             Template::Alloy::Parse - Common parsing role for creating AST from templates
6              
7             =cut
8              
9 10     10   63 use strict;
  10         22  
  10         471  
10 10     10   58 use warnings;
  10         20  
  10         366  
11 10     10   56 use base qw(Exporter);
  10         26  
  10         1000  
12 10     10   61 use Template::Alloy;
  10         47  
  10         80  
13 10         210343 use Template::Alloy::Operator qw($QR_OP $QR_OP_ASSIGN $QR_OP_PREFIX
14 10     10   54 $OP $OP_ASSIGN $OP_PREFIX $OP_POSTFIX);
  10         18  
15              
16             our $VERSION = $Template::Alloy::VERSION;
17             our @EXPORT_OK = qw(define_directive define_syntax
18             $ALIASES $DIRECTIVES $TAGS $QR_DIRECTIVE $QR_COMMENTS);
19              
20 0     0 0 0 sub new { die "This class is a role for use by packages such as Template::Alloy" }
21              
22             ###----------------------------------------------------------------###
23              
24             our $TAGS = {
25             asp => ['<%', '%>' ], # ASP
26             default => ['\[%', '%\]' ], # default
27             html => ['' ], # HTML comments
28             mason => ['<%', '>' ], # HTML::Mason
29             metatext => ['%%', '%%' ], # Text::MetaText
30             php => ['<\?', '\?>' ], # PHP
31             star => ['\[\*', '\*\]' ], # TT alternate
32             template => ['\[%', '%\]' ], # Normal Template Toolkit
33             template1 => ['[\[%]%', '%[%\]]'], # TT1
34             tt2 => ['\[%', '%\]' ], # TT2
35             };
36              
37             our $SYNTAX = {
38             alloy => sub { shift->parse_tree_tt3(@_) },
39             js => sub { shift->parse_tree_js(@_) },
40             jsr => sub { shift->parse_tree_jsr(@_) },
41             ht => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; local $self->{'EXPR'} = 0; $self->parse_tree_hte(@_) },
42             hte => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; $self->parse_tree_hte(@_) },
43             tt3 => sub { shift->parse_tree_tt3(@_) },
44             tt2 => sub { my $self = shift; local $self->{'V2PIPE'} = 1; $self->parse_tree_tt3(@_) },
45             tt1 => sub { my $self = shift; local $self->{'V2PIPE'} = 1; local $self->{'V1DOLLAR'} = 1; $self->parse_tree_tt3(@_) },
46             tmpl => sub { shift->parse_tree_tmpl(@_) },
47             velocity => sub { shift->parse_tree_velocity(@_) },
48             };
49              
50             our $DIRECTIVES = {
51             #name parse_sub play_sub block postdir continue no_interp
52             BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1],
53             BREAK => [sub {}, \&play_control],
54             CALL => [\&parse_CALL, \&play_CALL],
55             CASE => [\&parse_CASE, undef, 0, 0, {SWITCH => 1, CASE => 1}],
56             CATCH => [\&parse_CATCH, undef, 0, 0, {TRY => 1, CATCH => 1}],
57             CLEAR => [sub {}, \&play_CLEAR],
58             '#' => [sub {}, sub {}],
59             COMMENT => [sub {}, sub {}, 1],
60             CONFIG => [\&parse_CONFIG, \&play_CONFIG],
61             DEBUG => [\&parse_DEBUG, \&play_DEBUG],
62             DEFAULT => [\&parse_DEFAULT, \&play_DEFAULT],
63             DUMP => [\&parse_DUMP, \&play_DUMP],
64             ELSE => [sub {}, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}],
65             ELSIF => [\&parse_IF, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}],
66             END => [sub {}, sub {}],
67             EVAL => [\&parse_EVAL, \&play_EVAL],
68             FILTER => [\&parse_FILTER, \&play_FILTER, 1, 1],
69             '|' => [\&parse_FILTER, \&play_FILTER, 1, 1],
70             FINAL => [sub {}, undef, 0, 0, {TRY => 1, CATCH => 1}],
71             FOR => [\&parse_FOR, \&play_FOR, 1, 1],
72             FOREACH => [\&parse_FOR, \&play_FOR, 1, 1],
73             GET => [\&parse_GET, \&play_GET],
74             IF => [\&parse_IF, \&play_IF, 1, 1],
75             INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE],
76             INSERT => [\&parse_INSERT, \&play_INSERT],
77             JS => [sub {}, \&play_JS, 1, 0, 0, 1],
78             LAST => [sub {}, \&play_control],
79             LOOP => [\&parse_LOOP, \&play_LOOP, 1, 1],
80             MACRO => [\&parse_MACRO, \&play_MACRO],
81             META => [\&parse_META, \&play_META],
82             NEXT => [sub {}, \&play_control],
83             PERL => [sub {}, \&play_PERL, 1, 0, 0, 1],
84             PROCESS => [\&parse_PROCESS, \&play_PROCESS],
85             RAWPERL => [sub {}, \&play_RAWPERL, 1, 0, 0, 1],
86             RETURN => [\&parse_RETURN, \&play_control],
87             SET => [\&parse_SET, \&play_SET],
88             STOP => [sub {}, \&play_control],
89             SWITCH => [\&parse_SWITCH, \&play_SWITCH, 1],
90             TAGS => [\&parse_TAGS, sub {}],
91             THROW => [\&parse_THROW, \&play_THROW],
92             TRY => [sub {}, \&play_TRY, 1],
93             UNLESS => [\&parse_UNLESS, \&play_UNLESS, 1, 1],
94             USE => [\&parse_USE, \&play_USE],
95             VIEW => [\&parse_VIEW, \&play_VIEW, 1],
96             WHILE => [\&parse_WHILE, \&play_WHILE, 1, 1],
97             WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER, 1, 1],
98             #name parse_sub play_sub block postdir continue no_interp
99             };
100             our $ALIASES = {
101             EVALUATE => 'EVAL',
102             };
103              
104              
105             our $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )';
106             our $QR_COMMENTS = '(?-s: \# .* \s*)*';
107             our $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\.][\w\-\.]* (?:/[\w\-\.]+)*';
108             our $QR_BLOCK = '\w+\b (?: :\w+\b)* )';
109             our $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]?\d+ )?';
110             our $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=;) )';
111              
112             our $_escapes = {n => "\n", r => "\r", t => "\t", '"' => '"', '\\' => '\\', '$' => '$'};
113             our $QR_ESCAPES = qr{[nrt\"\$\\]};
114              
115             sub define_directive {
116 0     0 0 0 my ($self, $name, $args) = @_;
117 0         0 $DIRECTIVES->{$name} = [@{ $args }{qw(parse_sub play_sub is_block is_postop continues no_interp)}];
  0         0  
118 0         0 return 1;
119             }
120              
121             sub define_syntax {
122 0     0 0 0 my ($self, $name, $sub) = @_;
123 0         0 $SYNTAX->{$name} = $sub;
124 0         0 return 1;
125             }
126              
127             ###----------------------------------------------------------------###
128              
129             sub parse_tree {
130 4852   100 4852 1 25602 my $syntax = $_[0]->{'SYNTAX'} || 'alloy';
131 4852   66     18850 my $meth = $SYNTAX->{$syntax} || $_[0]->throw('config', "Unknown SYNTAX \"$syntax\"");
132 4849         13370 return $meth->(@_);
133             }
134              
135             ###----------------------------------------------------------------###
136              
137             sub parse_expr {
138 17654     17654 1 30237 my $self = shift;
139 17654         22231 my $str_ref = shift;
140 17654   100     69468 my $ARGS = shift || {};
141 17654 100       41033 my $is_aq = $ARGS->{'auto_quote'} ? 1 : 0;
142 17654         30784 my $mark = pos $$str_ref;
143              
144             ### allow for custom auto_quoting (such as hash constructors)
145 17654 100       51963 if ($is_aq) {
146 2183 100       999740 if ($$str_ref =~ m{ \G \s* $QR_COMMENTS $ARGS->{'auto_quote'} }gcx) {
    100          
    100          
147 1485         7775 return $1;
148              
149             ### allow for ${foo.bar} type constructs
150             } elsif ($$str_ref =~ m{ \G \$\{ }gcx) {
151 12         39 my $var = $self->parse_expr($str_ref);
152 12 50       266 $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
153             || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
154 12         49 return $var;
155              
156             ### allow for auto-quoted $foo
157             } elsif ($$str_ref =~ m{ \G \$ }gcx) {
158 45   33     186 return $self->parse_expr($str_ref)
159             || $self->throw('parse', "Missing variable", undef, pos($$str_ref));
160             }
161             }
162              
163 16112         64401 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
164              
165             ### allow for macro definer
166 16112 100       52212 if ($$str_ref =~ m{ \G -> \s* }gcxo) { # longest token would be nice - until then this comes before prefix
167 27         84 local $self->{'_operator_precedence'} = 0; # reset presedence
168 27         39 my $args;
169 27 100       117 if ($$str_ref =~ m{ \G \( \s* }gcx) {
170 18         124 $args = $self->parse_args($str_ref, {positional_only => 1});
171 18 50       110 $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
172             }
173 27 50       220 $$str_ref =~ m{ \G \{ $QR_COMMENTS }gcx || $self->throw('parse.missing', "Missing open '{'", undef, pos($$str_ref));
174 27         165 local $self->{'END_TAG'} = qr{ \} }x;
175 27         161 my $tree = $self->parse_tree_tt3($str_ref, 'one_tag_only');
176 27   100     305 return [[undef, '->', $args || [['this',0]], $tree]];
177             }
178              
179             ### test for leading prefix operators
180 16085         18422 my $has_prefix;
181 16085   100     93959 while (! $is_aq && $$str_ref =~ m{ \G ($QR_OP_PREFIX) }gcxo) {
182 102         195 push @{ $has_prefix }, $1;
  102         360  
183 102         918 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
184             }
185              
186 16085         22467 my @var;
187             my $is_literal;
188 0         0 my $is_namespace;
189 0         0 my $already_parsed_args;
190              
191             ### allow hex
192 16085 50 100     290783 if ($$str_ref =~ m{ \G 0x ( [a-fA-F0-9]+ ) }gcx) {
    100 100        
    100 100        
    100 100        
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
193 0   0     0 my $number = eval { hex $1 } || 0;
194 0         0 push @var, \ $number;
195 0         0 $is_literal = 1;
196              
197             ### allow for numbers
198             } elsif ($$str_ref =~ m{ \G ( $QR_NUM ) }gcx) {
199 2845         8133 my $number = 0 + $1;
200 2845         5323 push @var, \ $number;
201 2845         10790 $is_literal = 1;
202              
203             ### allow for quoted array constructor
204             } elsif (! $is_aq && $$str_ref =~ m{ \G qw ([^\w\s]) \s* }gcxo) {
205 18         54 my $quote = $1;
206 18         51 $quote =~ y|([{<|)]}>|;
207 18 50       657 $$str_ref =~ m{ \G (.*?) (?
208             || $self->throw('parse.missing.array_close', "Missing close \"$quote\"", undef, pos($$str_ref));
209 18         65 my $str = $1;
210 18         49 $str =~ s{ ^ \s+ }{}x;
211 18         61 $str =~ s{ \s+ $ }{}x;
212 18         185 $str =~ s{ \\ \Q$quote\E }{$quote}gx;
213 18         126 push @var, [undef, '[]', split /\s+/, $str];
214              
215             ### looks like a normal variable start
216             } elsif ($$str_ref =~ m{ \G (\w+) }gcx) {
217 6978         19523 push @var, $1;
218 6978 100 100     22386 $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
219              
220             ### allow for regex constructor
221             } elsif (! $is_aq && $$str_ref =~ m{ \G / }gcx) {
222 47 100       303 $$str_ref =~ m{ \G (.*?) (?
223             || $self->throw('parse', 'Unclosed regex tag "/"', undef, pos($$str_ref));
224 39         124 my ($str, $opts) = ($1, $2);
225 39 100       125 $self->throw('parse', 'e option not allowed on regex', undef, pos($$str_ref)) if $opts =~ /e/;
226 36 100       105 $self->throw('parse', 'g option not supported on regex', undef, pos($$str_ref)) if $opts =~ /g/;
227 33         56 $str =~ s|\\n|\n|g;
228 33         56 $str =~ s|\\t|\t|g;
229 33         49 $str =~ s|\\r|\r|g;
230 33         110 $str =~ s|\\\/|\/|g;
231 33         49 $str =~ s|\\\$|\$|g;
232 33 100       46 $self->throw('parse', "Invalid regex: $@", undef, pos($$str_ref)) if ! eval { "" =~ /$str/; 1 };
  33         527  
  27         95  
233 27         103 push @var, [undef, 'qr', $str, $opts];
234              
235             ### allow for single quoted strings
236             } elsif ($$str_ref =~ m{ \G \' (.*?) (?
237 1400         3741 my $str = $1;
238 1400         2590 $str =~ s{ \\\' }{\'}xg;
239 1400 100       3216 return $str if $is_aq;
240 1375         3294 push @var, \ $str;
241 1375         2496 $is_literal = 1;
242              
243             ### allow for double quoted strings
244             } elsif ($$str_ref =~ m{ \G \" }gcx) {
245 724         1340 my @pieces;
246 724         3200 while ($$str_ref =~ m{ \G (.*?) ([\"\$\\]) }gcxs) {
247 864         2330 my ($str, $item) = ($1, $2);
248 864 100       2061 if (length $str) {
249 735 100 100     2331 if (defined($pieces[-1]) && ! ref($pieces[-1])) { $pieces[-1] .= $str; } else { push @pieces, $str }
  40         66  
  695         1540  
250             }
251 864 100       2870 if ($item eq '\\') {
    100          
    100          
252 21 50       163 my $chr = ($$str_ref =~ m{ \G ($QR_ESCAPES) }gcxo) ? $_escapes->{$1} : '\\';
253 21 50 33     89 if (defined($pieces[-1]) && ! ref($pieces[-1])) { $pieces[-1] .= $chr; } else { push @pieces, $chr }
  21         36  
  0         0  
254 21         77 next;
255             } elsif ($item eq '"') {
256 721         1094 last;
257             } elsif ($self->{'AUTO_EVAL'}) {
258 16 50 33     82 if (defined($pieces[-1]) && ! ref($pieces[-1])) { $pieces[-1] .= '$'; } else { push @pieces, '$' }
  16         30  
  0         0  
259 16         70 next;
260             }
261              
262 106         264 my $not = $$str_ref =~ m{ \G ! }gcx;
263 106         166 my $mark = pos($$str_ref);
264 106         167 my $ref;
265 106 100       313 if ($$str_ref =~ m{ \G \{ }gcx) {
266 42         117 local $self->{'_operator_precedence'} = 0; # allow operators
267 42         119 $ref = $self->parse_expr($str_ref);
268 42 50       404 $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
269             || $self->throw('parse', 'Missing close }', undef, pos($$str_ref));
270             } else {
271 64         188 local $self->{'_operator_precedence'} = 1; # no operators
272 64   33     182 $ref = $self->parse_expr($str_ref)
273             || $self->throw('parse', "Error while parsing for interpolated string", undef, pos($$str_ref));
274             }
275 106 100 100     634 if (! $not && $self->{'SHOW_UNDEFINED_INTERP'}) {
276 8         41 $ref = [[undef, '//', $ref, '$'.substr($$str_ref, $mark, pos($$str_ref)-$mark)], 0];
277             }
278 106 50       629 push @pieces, $ref if defined $ref;
279             }
280 724 100 100     5461 if (! @pieces) { # [% "" %]
    100          
    100          
    100          
281 3 50       10 return '' if $is_aq;
282 3         9 push @var, \ '';
283 3         7 $is_literal = 1;
284             } elsif (@pieces == 1 && ref $pieces[0]) { # [% "$foo" %] or [% "${ 1 + 2 }" %]
285 51 100       159 return $pieces[0] if $is_aq;
286 39         56 push @var, @{ $pieces[0] };
  39         104  
287 39         94 $already_parsed_args = 1;
288             } elsif ($self->{'AUTO_EVAL'}) {
289 44         239 push @var, [undef, '~', @pieces], 0, '|', 'eval', 0;
290 44 100       138 return \@var if $is_aq;
291 30         65 $already_parsed_args = 1;
292             } elsif (@pieces == 1) { # [% "foo" %]
293 573 100       1152 return $pieces[0] if $is_aq;
294 565         948 push @var, \ $pieces[0];
295 565         1051 $is_literal = 1;
296             } else { # [% "foo $bar baz" %]
297 53         213 push @var, [undef, '~', @pieces];
298 53 100       207 return [$var[0], 0] if $is_aq;
299             }
300              
301             ### allow for leading $foo type constructs
302             } elsif ($$str_ref =~ m{ \G \$ (\w+) \b }gcx) {
303 302 100       948 if ($self->{'V1DOLLAR'}) {
304 203         550 push @var, $1;
305 203 100 66     716 $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
306             } else {
307 99         435 push @var, [$1, 0];
308             }
309              
310             ### allow for ${foo.bar} type constructs
311             } elsif ($$str_ref =~ m{ \G \$\{ }gcx) {
312 126         416 push @var, $self->parse_expr($str_ref);
313 126 50       785 $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
314             || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
315              
316             ### looks like an array constructor
317             } elsif (! $is_aq && $$str_ref =~ m{ \G \[ }gcx) {
318 315         2261 local $self->{'_operator_precedence'} = 0; # reset presedence
319 315         980 my $arrayref = [undef, '[]'];
320 315         938 while (defined(my $var = $self->parse_expr($str_ref))) {
321 400         977 push @$arrayref, $var;
322 400         2022 $$str_ref =~ m{ \G \s* $QR_COMMENTS , }gcxo;
323             }
324 312 100       2014 $$str_ref =~ m{ \G \s* $QR_COMMENTS \] }gcxo
325             || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, pos($$str_ref));
326 309         968 push @var, $arrayref;
327              
328             ### looks like a hash constructor
329             } elsif (! $is_aq && $$str_ref =~ m{ \G \{ }gcx) {
330 197         589 local $self->{'_operator_precedence'} = 0; # reset precedence
331 197         512 my $hashref = [undef, '{}'];
332 197         1106 while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))) {
333 226         946 $$str_ref =~ m{ \G \s* $QR_COMMENTS (?: = >? | [:,]) }gcxo;
334 226         543 my $val = $self->parse_expr($str_ref);
335 226         630 push @$hashref, $key, $val;
336 226         1816 $$str_ref =~ m{ \G \s* $QR_COMMENTS , }gcxo;
337             }
338 197 50       1253 $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
339             || $self->throw('parse.missing.curly_bracket', "Missing close \}", undef, pos($$str_ref));
340 197         572 push @var, $hashref;
341              
342             ### looks like a paren grouper or a context specifier
343             } elsif (! $is_aq && $$str_ref =~ m{ \G ([\$\@]?) \( }gcx) {
344 228         758 local $self->{'_operator_precedence'} = 0; # reset precedence
345 228         660 my $ctx = $1;
346 228         1201 my $var = $self->parse_expr($str_ref, {allow_parened_ops => 1});
347              
348 228 50       1482 $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo
349             || $self->throw('parse.missing.paren', "Missing close \) in group", undef, pos($$str_ref));
350              
351 228 100       752 $self->throw('parse', 'Paren group cannot be followed by an open paren', undef, pos($$str_ref))
352             if $$str_ref =~ m{ \G \( }gcx;
353 225         365 $already_parsed_args = 1;
354              
355 225 100       836 if (! ref $var) {
    50          
356 3         9 push @var, \$var, 0;
357 3         7 $is_literal = 1;
358             } elsif (! defined $var->[0]) {
359 0         0 push @var, $var, 0;
360             } else {
361 222         615 push @var, @$var;
362             }
363 225 100       940 if ($ctx) {
364 90         281 my $copy = [@var];
365 90         578 @var = ([undef, "$ctx()", $copy], 0);
366             }
367              
368             ### nothing to find - return failure
369             } else {
370 2905 100 100     18697 pos($$str_ref) = $mark if $is_aq || $has_prefix;
371 2905         15511 return;
372             }
373              
374             # auto_quoted thing was too complicated
375 13083 100       29611 if ($is_aq) {
376 101         257 pos($$str_ref) = $mark;
377 101         343 return;
378             }
379              
380             ### looks for args for the initial
381 12982 100       42714 if ($already_parsed_args) {
    100          
382             # do nothing
383             } elsif ($$str_ref =~ m{ \G \( }gcxo) {
384 185         618 local $self->{'_operator_precedence'} = 0; # reset precedence
385 185         1042 my $args = $self->parse_args($str_ref, {is_parened => 1});
386 185 50       1482 $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo
387             || $self->throw('parse.missing.paren', "Missing close \) in args", undef, pos($$str_ref));
388 185         499 push @var, $args;
389             } else {
390 12503         17698 push @var, 0;
391             }
392              
393             ### allow for nested items
394 12982         118619 while ($$str_ref =~ m{ \G \s* $QR_COMMENTS ( \.(?!\.) | \|(?!\|) ) }gcx) {
395 3265 100 100     11772 if ($1 eq '|' && $self->{'V2PIPE'}) {
396 15         43 pos($$str_ref) -= 1;
397 15         32 last;
398             }
399              
400 3250 100       13445 push(@var, $1) if ! $ARGS->{'no_dots'};
401              
402 3250         10091 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
403              
404             ### allow for interpolated variables in the middle - one.$foo.two
405 3250 100       19084 if ($$str_ref =~ m{ \G \$ (\w+) \b }gcxo) {
    100          
    50          
406 54 100       291 push @var, $self->{'V1DOLLAR'} ? $1 : [$1, 0];
407              
408             ### or one.${foo.bar}.two
409             } elsif ($$str_ref =~ m{ \G \$\{ }gcx) {
410 29         113 push @var, $self->parse_expr($str_ref);
411 29 50       366 $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
412             || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
413              
414             ### allow for names (foo.bar or foo.0 or foo.-1)
415             } elsif ($$str_ref =~ m{ \G (-? \w+) }gcx) {
416 3167         8190 push @var, $1;
417              
418             } else {
419 0         0 $self->throw('parse', "Not sure how to continue parsing", undef, pos($$str_ref));
420             }
421              
422             ### looks for args for the nested item
423 3250 100       7943 if ($$str_ref =~ m{ \G \( }gcx) {
424 713         2274 local $self->{'_operator_precedence'} = 0; # reset precedence
425 713         3491 my $args = $self->parse_args($str_ref, {is_parened => 1});
426 698 50       5696 $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo
427             || $self->throw('parse.missing.paren', "Missing close \) in args of nested item", undef, pos($$str_ref));
428 698         14131 push @var, $args;
429             } else {
430 2537         27375 push @var, 0;
431             }
432              
433             }
434              
435             ### flatten literals and constants as much as possible
436 12967         16817 my $var;
437 12967 100       28221 if ($is_literal) {
    100          
438 4776         5472 $var = ${ $var[0] };
  4776         9590  
439 4776 100       12877 if ($#var != 1) {
440 114         365 $var[0] = [undef, '~', $var];
441 114         267 $var = \@var;
442             }
443             } elsif ($is_namespace) {
444 48         67 my $name = $var[0];
445 48         162 local $self->{'_vars'}->{$name} = $self->{'NAMESPACE'}->{$name};
446 48         246 $var = $self->play_expr(\@var, {is_namespace_during_compile => 1});
447             } else {
448 8143         18289 $var = \@var;
449             }
450              
451             ### allow for all "operators"
452 12967 100       33740 if (! $self->{'_operator_precedence'}) {
453 11586         14237 my $tree;
454             my $found;
455 11586         13579 while (1) {
456 12670         18760 my $mark = pos $$str_ref;
457              
458 12670         41918 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
459              
460 12670 100 100     140979 if ($self->{'_end_tag'} && $$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) {
    100          
461 5849         14262 pos($$str_ref) = $mark;
462 5849         12388 last;
463             } elsif ($$str_ref !~ m{ \G ($QR_OP) }gcxo) {
464 3774         8939 pos($$str_ref) = $mark;
465 3774         8875 last;
466             }
467 3047 100 100     17506 if ($OP_ASSIGN->{$1} && ! $ARGS->{'allow_parened_ops'}) { # only allow assignment in parens
468 1955         4520 pos($$str_ref) = $mark;
469 1955         4934 last;
470             }
471 1092         2720 local $self->{'_operator_precedence'} = 1;
472 1092         1971 my $op = $1;
473 1092 100 100     3087 $op = 'eq' if $op eq '==' && (! defined($self->{'V2EQUALS'}) || $self->{'V2EQUALS'});
      66        
474 1092 100 100     2551 $op = 'ne' if $op eq '!=' && (! defined($self->{'V2EQUALS'}) || $self->{'V2EQUALS'});
      66        
475              
476             ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --)
477 1092 100 66     5397 if ($OP_POSTFIX->{$op}) {
    100          
478 9         37 $var = [[undef, $op, $var, 1], 0]; # cheat - give a "second value" to postfix ops
479 9         27 next;
480              
481             ### allow for prefix operator precedence
482             } elsif ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix->[-1]}->[1]) {
483 9 50       25 if ($tree) {
484 0 0       0 if ($#$tree == 1) { # only one operator - keep simple things fast
485 0         0 $var = [[undef, $tree->[0], $var, $tree->[1]], 0];
486             } else {
487 0         0 unshift @$tree, $var;
488 0         0 $var = $self->apply_precedence($tree, $found, $str_ref);
489             }
490 0         0 undef $tree;
491 0         0 undef $found;
492             }
493 9         57 $var = [[undef, $has_prefix->[-1], $var ], 0];
494 9         326 pop @$has_prefix;
495 9 50       33 $has_prefix = undef if ! @$has_prefix;
496             }
497              
498             ### add the operator to the tree
499 1083         3025 my $var2 = $self->parse_expr($str_ref);
500 1081 100       2865 $self->throw('parse', 'Missing variable after "'.$op.'"', undef, pos($$str_ref)) if ! defined $var2;
501 1075   100     1384 push (@{ $tree ||= [] }, $op, $var2);
  1075         5207  
502 1075         6847 $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op}
503             }
504              
505             ### if we found operators - tree the nodes by operator precedence
506 11578 100       25644 if ($tree) {
507 863 100       5264 if (@$tree == 2) { # only one operator - keep simple things fast
508 744 100 100     3463 if ($OP->{$tree->[0]}->[0] eq 'assign' && $tree->[0] =~ /(.+)=/) {
509 30         249 $var = [[undef, '=', $var, [[undef, $1, $var, $tree->[1]], 0]], 0]; # "a += b" => "a = a + b"
510             } else {
511 714         4607 $var = [[undef, $tree->[0], $var, $tree->[1]], 0];
512             }
513             } else {
514 119         319 unshift @$tree, $var;
515 119         416 $var = $self->apply_precedence($tree, $found, $str_ref);
516             }
517             }
518             }
519              
520             ### allow for prefix on non-chained variables
521 12959 100       26000 if ($has_prefix) {
522 89         668 $var = [[undef, $_, $var], 0] for reverse @$has_prefix;
523             }
524              
525 12959         67359 return $var;
526             }
527              
528             ### this is used to put the parsed variables into the correct operations tree
529             sub apply_precedence {
530 146     146 0 287 my ($self, $tree, $found, $str_ref) = @_;
531              
532 146         198 my @var;
533             my $trees;
534             ### look at the operators we found in the order we found them
535 146         757 for my $prec (sort keys %$found) {
536 146         275 my $ops = $found->{$prec};
537 146         269 local $found->{$prec};
538 146         256 delete $found->{$prec};
539              
540             ### split the array on the current operators for this level
541 146         274 my @ops;
542             my @exprs;
543 146         482 for (my $i = 1; $i <= $#$tree; $i += 2) {
544 383 100       974 next if ! $ops->{ $tree->[$i] };
545 290         576 push @ops, $tree->[$i];
546 290         728 push @exprs, [splice @$tree, 0, $i, ()];
547 290         422 shift @$tree;
548 290         817 $i = -1;
549             }
550 146 50       312 next if ! @exprs; # this iteration didn't have the current operator
551 146 50       373 push @exprs, $tree if scalar @$tree; # add on any remaining items
552              
553             ### simplify sub expressions
554 146         267 for my $node (@exprs) {
555 436 100       821 if (@$node == 1) {
    100          
556 370         753 $node = $node->[0]; # single item - its not a tree
557             } elsif (@$node == 3) {
558 39         190 $node = [[undef, $node->[1], $node->[0], $node->[2]], 0]; # single operator - put it straight on
559             } else {
560 27         104 $node = $self->apply_precedence($node, $found, $str_ref); # more complicated - recurse
561             }
562             }
563              
564             ### assemble this current level
565              
566             ### some rules:
567             # 1) items at the same precedence level must all be either right or left or ternary associative
568             # 2) ternary items cannot share precedence with anybody else.
569             # 3) there really shouldn't be another operator at the same level as a postfix
570 146         342 my $type = $OP->{$ops[0]}->[0];
571              
572 146 100 100     588 if ($type eq 'ternary') {
    100          
573 72         160 my $op = $OP->{$ops[0]}->[2]->[0]; # use the first op as what we are using
574              
575             ### return simple ternary
576 72 100       211 if (@exprs == 3) {
577 57 50       147 $self->throw('parse', "Ternary operator mismatch", undef, pos($$str_ref)) if $ops[0] ne $op;
578 57 50 33     270 $self->throw('parse', "Ternary operator mismatch", undef, pos($$str_ref)) if ! $ops[1] || $ops[1] eq $op;
579 57         596 return [[undef, $op, @exprs], 0];
580             }
581              
582              
583             ### reorder complex ternary - rare case
584 15         47 while ($#ops >= 1) {
585             ### if we look starting from the back - the first lead ternary op will always be next to its matching op
586 15         53 for (my $i = $#ops; $i >= 0; $i --) {
587 60 100       205 next if $OP->{$ops[$i]}->[2]->[1] eq $ops[$i];
588 30         67 my ($op, $op2) = splice @ops, $i, 2, (); # remove the pair of operators
589 30         129 my $node = [[undef, $op, @exprs[$i .. $i + 2]], 0];
590 30         120 splice @exprs, $i, 3, $node;
591             }
592             }
593 15         106 return $exprs[0]; # at this point the ternary has been reduced to a single operator
594              
595             } elsif ($type eq 'right' || $type eq 'assign') {
596 27         60 my $val = $exprs[-1];
597 27         125 for (reverse (0 .. $#exprs - 1)) {
598 39 100 100     183 if ($type eq 'assign' && $ops[$_ - 1] =~ /(.+)=$/) {
599 9         67 $val = [[undef, '=', $exprs[$_], [[undef, $1, $exprs[$_], $val], 0]], 0];
600             } else {
601 30         150 $val = [[undef, $ops[$_ - 1], $exprs[$_], $val], 0];
602             }
603             }
604 27         196 return $val;
605              
606             } else {
607 47         70 my $val = $exprs[0];
608 47         406 $val = [[undef, $ops[$_ - 1], $val, $exprs[$_]], 0] for (1 .. $#exprs);
609 47         300 return $val;
610              
611             }
612             }
613              
614 0         0 $self->throw('parse', "Couldn't apply precedence", undef, pos($$str_ref));
615             }
616              
617             ### look for arguments - both positional and named
618             sub parse_args {
619 2153     2153 1 3564 my $self = shift;
620 2153         3616 my $str_ref = shift;
621 2153   50     5214 my $ARGS = shift || {};
622              
623 2153         3004 my @args;
624             my @named;
625 0         0 my $name;
626 2153   100     6651 my $end = $self->{'_end_tag'} || '(?!)';
627 2153         2675 while (1) {
628 4679         7308 my $mark = pos $$str_ref;
629              
630             ### look to see if the next thing is a directive or a closing tag
631 4679 100 100     32193 if (! $ARGS->{'is_parened'}
    100 100        
      50        
      66        
      66        
632             && ! $ARGS->{'require_arg'}
633             && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$end))) }gcxo
634             && ((pos($$str_ref) = $mark) || 1) # always revert
635             && $DIRECTIVES->{$self->{'ANYCASE'} ? uc($1) : $1} # looks like a directive - we are done
636             ) {
637 26         113 last;
638             }
639 4653 100       24625 if ($$str_ref =~ m{ \G [+=~-]? $end }gcx) {
640 645         1460 pos($$str_ref) = $mark;
641 645         1750 last;
642             }
643              
644             ### find the initial arg
645 4008         4723 my $name;
646 4008 100       8873 if ($ARGS->{'allow_bare_filenames'}) {
647 755         6635 $name = $self->parse_expr($str_ref, {auto_quote => "
648             ($QR_FILENAME # file name
649             | $QR_BLOCK # or block
650             (?= [+=~-]? $end # an end tag
651             | \\s*[+,;] # followed by explicit + , or ;
652             | \\s+ (?! [\\s=]) # or space not before an =
653             ) \\s* $QR_COMMENTS"});
654             # filenames can be separated with a "+" - why a "+" ?
655 755 100       3868 if ($$str_ref =~ m{ \G \+ (?! \s* $QR_COMMENTS [+=~-]? $end) }gcxo) {
656 6         15 push @args, $name;
657 6         14 $ARGS->{'require_arg'} = 1;
658 6         14 next;
659             }
660             }
661 4002 100       8865 if (! defined $name) {
662 3450         13551 $name = $self->parse_expr($str_ref);
663 3435 100       9331 if (! defined $name) {
664 1467 50 33     6902 if ($ARGS->{'require_arg'} && ! @args && ! $ARGS->{'positional_only'} && ! @named) {
      33        
      0        
665 0         0 $self->throw('parse', 'Argument required', undef, pos($$str_ref));
666             } else {
667 1467         3880 last;
668             }
669             }
670             }
671              
672 2520         8676 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
673              
674             ### see if it is named or positional
675 2520 100       8921 if ($$str_ref =~ m{ \G \s* $QR_COMMENTS = >? }gcxo) {
676 597 50       1843 $self->throw('parse', 'Named arguments not allowed', undef, $mark) if $ARGS->{'positional_only'};
677 597         1486 my $val = $self->parse_expr($str_ref);
678 597 100 66     6094 $name = $name->[0] if ref($name) && @$name == 2 && ! $name->[1]; # strip a level of indirection on named arguments
      66        
679 597         1775 push @named, $name, $val;
680             } else {
681 1923         3958 push @args, $name;
682             }
683              
684             ### look for trailing comma
685 2520   100     15259 $ARGS->{'require_arg'} = ($$str_ref =~ m{ \G \s* $QR_COMMENTS , }gcxo) || 0;
686             }
687              
688             ### allow for named arguments to be added at the front (if asked)
689 2138 100       6889 if ($ARGS->{'named_at_front'}) {
    100          
690 1178         5023 unshift @args, [[undef, '{}', @named], 0];
691             } elsif (scalar @named) { # only add at end - if there are some
692 82         371 push @args, [[undef, '{}', @named], 0]
693             }
694              
695 2138         9147 return \@args;
696             }
697              
698             ###----------------------------------------------------------------###
699              
700             sub parse_BLOCK {
701 459     459 0 999 my ($self, $str_ref, $node) = @_;
702              
703 459   50     5960 my $end = $self->{'_end_tag'} || '(?!)';
704 459         8230 my $block_name = $self->parse_expr($str_ref, {auto_quote => "
705             ($QR_FILENAME # file name
706             | $QR_BLOCK # or block
707             (?= [+=~-]? $end # an end tag
708             | \\s*[+,;] # followed by explicit + , or ;
709             | \\s+ (?! [\\s=]) # or space not before an =
710             ) \\s* $QR_COMMENTS"});
711              
712 459 100       3139 return '' if ! defined $block_name;
713              
714 391 50       784 my $prepend = join "/", map {$_->[3]} grep {ref($_) && $_->[0] eq 'BLOCK'} @{ $self->{'_state'} || {} };
  6 50       20  
  44         359  
  391         3719  
715 391 100       2159 return $prepend ? "$prepend/$block_name" : $block_name;
716             }
717              
718 78     78 0 555 sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) }
719              
720             sub parse_CASE {
721 30     30 0 55 my ($self, $str_ref) = @_;
722 30 100       111 return if $$str_ref =~ m{ \G DEFAULT \s* }gcx;
723 27         77 return $self->parse_expr($str_ref);
724             }
725              
726             sub parse_CATCH {
727 131     131 0 268 my ($self, $str_ref) = @_;
728 131         890 return $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"});
729             }
730              
731             sub parse_CONFIG {
732 124     124 0 275 my ($self, $str_ref) = @_;
733              
734 124         258 my %ctime = map {$_ => 1} @Template::Alloy::CONFIG_COMPILETIME;
  1736         6366  
735 124         474 my %rtime = map {$_ => 1} @Template::Alloy::CONFIG_RUNTIME;
  620         1736  
736              
737 124         378 my $mark = pos($$str_ref);
738 124         605 my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1});
739 124         369 my $ref = $config->[0]->[0];
740 124         408 for (my $i = 2; $i < @$ref; $i += 2) {
741 109         326 my $key = $ref->[$i] = uc $ref->[$i];
742 109         191 my $val = $ref->[$i + 1];
743 109 100       512 if ($ctime{$key}) {
    100          
744 52         208 $self->{$key} = $self->play_expr($val);
745 52 100       239 if ($key eq 'INTERPOLATE') {
746 7 50       167 $self->{'_start_tag'} = (! $self->{'INTERPOLATE'}) ? $self->{'START_TAG'} : qr{(?: $self->{'START_TAG'} | (\$))}sx;
747             }
748             } elsif (! $rtime{$key}) {
749 3         27 $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
750             }
751             }
752 121         400 for (my $i = 1; $i < @$config; $i++) {
753 15         183 my $key = $config->[$i] = uc $config->[$i]->[0];
754 15 100       64 if ($ctime{$key}) {
    50          
755 12 100       61 $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef');
756             } elsif (! $rtime{$key}) {
757 0         0 $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
758             }
759             }
760 121         784 return $config;
761             }
762              
763             sub parse_DEBUG {
764 3     3 0 11 my ($self, $str_ref) = @_;
765 3 50       20 $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx
766             || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref));
767 3         16 my $ret = [lc($1)];
768 3 50       19 if ($ret->[0] eq 'format') {
769 3 50       22 $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs
770             || $self->throw('parse', "Missing format string", undef, pos($$str_ref));
771 3         13 $ret->[1] = $2;
772             }
773 3         15 return $ret;
774             }
775              
776 9     9 0 38 sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) }
777              
778             sub parse_DUMP {
779 84     84 0 154 my ($self, $str_ref) = @_;
780 84         372 return $self->parse_args($str_ref, {named_at_front => 1});
781             }
782              
783             sub parse_EVAL {
784 22     22 0 39 my ($self, $str_ref) = @_;
785 22         104 return $self->parse_args($str_ref, {named_at_front => 1});
786             }
787              
788             sub parse_FILTER {
789 74     74 0 130 my ($self, $str_ref) = @_;
790 74         125 my $name = '';
791 74 100       250 if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) {
792 18         37 $name = $1;
793             }
794              
795 74         332 my $filter = $self->parse_expr($str_ref);
796 74 50       192 $filter = '' if ! defined $filter;
797              
798 74         357 return [$name, $filter];
799             }
800              
801             sub parse_FOR {
802 253     253 0 2341 my ($self, $str_ref) = @_;
803 253         883 my $items = $self->parse_expr($str_ref);
804 253         473 my $var;
805 253 100       1623 if ($$str_ref =~ m{ \G \s* $QR_COMMENTS (= | [Ii][Nn]\b) \s* }gcxo) {
806 184         609 $var = [@$items];
807 184         529 $items = $self->parse_expr($str_ref);
808             }
809 253         1515 return [$var, $items];
810             }
811              
812             sub parse_GET {
813 385     385 0 599 my ($self, $str_ref) = @_;
814 385         1268 my $ref = $self->parse_expr($str_ref);
815 385 100       1139 $self->throw('parse', "Missing variable name", undef, pos($$str_ref)) if ! defined $ref;
816 368 100       1038 if ($self->{'AUTO_FILTER'}) {
817 13 100       48 $ref = [[undef, '~', $ref], 0] if ! ref $ref;
818 13 100 66     77 push @$ref, '|', $self->{'AUTO_FILTER'}, 0 if @$ref < 3 || $ref->[-3] ne '|';
819             }
820 368         1504 return $ref;
821             }
822              
823             sub parse_IF {
824 244     244 0 454 my ($self, $str_ref) = @_;
825 244         694 return $self->parse_expr($str_ref);
826             }
827              
828 119     119 0 519 sub parse_INCLUDE { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
829              
830 21     21 0 81 sub parse_INSERT { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
831              
832             sub parse_LOOP {
833 18     18 0 35 my ($self, $str_ref, $node) = @_;
834 18   33     48 return $self->parse_expr($str_ref)
835             || $self->throw('parse', 'Missing variable on LOOP directive', undef, pos($$str_ref));
836             }
837              
838             sub parse_MACRO {
839 86     86 0 179 my ($self, $str_ref, $node) = @_;
840              
841 86         458 my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.)"});
842 86 50       477 $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name;
843 86 50       250 if (! ref $name) {
844 86         263 $name = [ $name, 0 ];
845             }
846              
847 86         139 my $args;
848 86 100       451 if ($$str_ref =~ m{ \G \( \s* }gcx) {
    100          
849 47         233 $args = $self->parse_args($str_ref, {positional_only => 1});
850 47 50       368 $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
851             } elsif ($self->{'V1DOLLAR'}) { # allow for Velocity style macro args (no parens - but dollars are fine)
852 24         174 while ($$str_ref =~ m{ \G (\s+ \$) }gcx) {
853 22         57 my $lead = $1;
854 22         61 my $arg = $self->parse_expr($str_ref);
855 22 50       67 if (! defined $arg) {
856 0         0 pos($$str_ref) -= length($lead);
857 0         0 last;
858             }
859 22         118 push @$args, $arg;
860             }
861             }
862              
863 86         227 $node->[6] = 1; # set a flag to keep parsing
864 86         415 return [$name, $args];
865             }
866              
867             sub parse_META {
868 136     136 0 284 my ($self, $str_ref) = @_;
869 136         683 my $args = $self->parse_args($str_ref, {named_at_front => 1});
870 136         299 my $hash;
871 136 50 33     707 return [%$hash] if ($hash = $self->play_expr($args->[0])) && UNIVERSAL::isa($hash, 'HASH');
872 0         0 return undef;
873             }
874              
875             sub parse_PROCESS {
876 546     546 0 963 my ($self, $str_ref) = @_;
877              
878 546         7652 return $self->parse_args($str_ref, {
879             named_at_front => 1,
880             allow_bare_filenames => 1,
881             require_arg => 1,
882             });
883             }
884              
885             sub parse_RETURN {
886 15     15 0 26 my ($self, $str_ref) = @_;
887 15         38 my $ref = $self->parse_expr($str_ref); # optional return value
888 15         55 return $ref;
889             }
890              
891             sub parse_SET {
892 1220     1220 0 2928 my ($self, $str_ref, $node, $initial_op, $initial_var) = @_;
893 1220         1780 my @SET;
894             my $func;
895              
896 1220 100       3228 if ($initial_op) {
897 804 50 100     10156 if ($initial_op eq '='
    100 50        
      66        
      66        
898             && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE }gcx # find a word
899             && ((pos($$str_ref) -= length($1)) || 1) # always revert
900             && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing
901 75         183 $node->[6] = 1; # set a flag to keep parsing
902 75   50     353 my $val = $node->[4] ||= []; # setup storage
903 75         505 return [[$initial_op, $initial_var, $val]];
904             } else { # get a normal variable
905 729         1803 my $val = $self->parse_expr($str_ref);
906 729 100       2126 if ($initial_op =~ /(.+)=$/) {
907 33         70 $initial_op = '=';
908 33         135 $val = [[undef, $1, $initial_var, $val], 0];
909             }
910 729         6852 return [[$initial_op, $initial_var, $val]];
911             }
912             }
913              
914 416         578 while (1) {
915 829         2223 my $set = $self->parse_expr($str_ref);
916 829 100       2179 last if ! defined $set;
917              
918 426 100       4455 if ($$str_ref =~ m{ \G \s* $QR_COMMENTS ($QR_OP_ASSIGN) >? }gcx) {
919 399         832 my $op = $1;
920 399 100 66     5091 if ($op eq '='
    100 50        
      66        
      66        
921             && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE }gcx # find a word
922             && ((pos($$str_ref) -= length($1)) || 1) # always revert
923             && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing
924 7         22 $node->[6] = 1; # set a flag to keep parsing
925 7   50     41 my $val = $node->[4] ||= []; # setup storage
926 7 50       25 if ($op =~ /(.+)=$/) {
927 0         0 $op = '=';
928 0         0 $val = [[undef, $1, $set, $val], 0];
929             }
930 7         25 push @SET, [$op, $set, $val];
931 7         18 last;
932             } else { # get a normal variable
933 392         1108 push @SET, [$op, $set, $self->parse_expr($str_ref)];
934             }
935             } else {
936 27         196 push @SET, ['=', $set, undef];
937             }
938             }
939              
940 410         2028 return \@SET;
941             }
942              
943 30     30 0 125 sub parse_SWITCH { $DIRECTIVES->{'GET'}->[0]->(@_) }
944              
945             sub parse_TAGS {
946 78     78 0 135 my ($self, $str_ref, $node) = @_;
947              
948 78         96 my ($start, $end);
949 78 100       399 if ($$str_ref =~ m{ \G (\w+) }gcxs) {
950 57   33     292 my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref));
951 57         165 ($start, $end) = @$ref;
952              
953             } else {
954 21         59 local $self->{'_operator_precedence'} = 1; # prevent operator matching
955 21 100 33     247 $start = $$str_ref =~ m{ \G (?= \s* $QR_COMMENTS [\'\"\/]) }gcx
956             ? $self->parse_expr($str_ref)
957             : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s+ $QR_COMMENTS"})
958             || $self->throw('parse', "Invalid opening tag in TAGS", undef, pos($$str_ref));
959 18 100 33     235 $end = $$str_ref =~ m{ \G (?= \s* $QR_COMMENTS [\'\"\/]) }gcx
960             ? $self->parse_expr($str_ref)
961             : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s* $QR_COMMENTS"})
962             || $self->throw('parse', "Invalid closing tag in TAGS", undef, pos($$str_ref));
963 18         68 for my $tag ($start, $end) {
964 36         117 $tag = $self->play_expr($tag);
965 36 100       165 $tag = quotemeta($tag) if ! ref $tag;
966             }
967             }
968 75         374 return [$start, $end];
969             }
970              
971             sub parse_THROW {
972 109     109 0 243 my ($self, $str_ref, $node) = @_;
973 109         623 my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"});
974 109 50       414 $self->throw('parse.missing', "Missing name in THROW", $node, pos($$str_ref)) if ! $name;
975 109         638 my $args = $self->parse_args($str_ref, {named_at_front => 1});
976 109         593 return [$name, $args];
977             }
978              
979             sub parse_UNLESS {
980 22     22 0 88 my $ref = $DIRECTIVES->{'IF'}->[0]->(@_);
981 22         123 return [[undef, '!', $ref], 0];
982             }
983              
984             sub parse_USE {
985 101     101 0 191 my ($self, $str_ref) = @_;
986              
987 101         147 my $var;
988 101         217 my $mark = pos $$str_ref;
989 101 100 66     650 if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))
      66        
990             && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment
991             || ((pos($$str_ref) = $mark) && 0)) # otherwise we need to rollback
992             ) {
993 7         14 $var = $_var;
994             }
995              
996 101         869 my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"});
997 101 50       574 $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module;
998 101         258 $module =~ s/\./::/g;
999              
1000 101         139 my $args;
1001 101         644 my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo;
1002 101         1027 $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1});
1003              
1004 101 100       478 if ($open) {
1005 64 50       431 $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
1006             }
1007              
1008 101         597 return [$var, $module, $args];
1009             }
1010              
1011             sub parse_VIEW {
1012 56     56 0 124 my ($self, $str_ref) = @_;
1013              
1014 56         377 my $ref = $self->parse_args($str_ref, {
1015             named_at_front => 1,
1016             require_arg => 1,
1017             });
1018              
1019 56         291 return $ref;
1020             }
1021              
1022 42     42 0 216 sub parse_WHILE { $DIRECTIVES->{'IF'}->[0]->(@_) }
1023              
1024 30     30 0 124 sub parse_WRAPPER { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
1025              
1026             ###----------------------------------------------------------------###
1027              
1028             sub dump_parse_tree {
1029 0     0 1   my $self = shift;
1030 0 0         $self = $self->new if ! ref $self;
1031 0           my $str = shift;
1032 0 0         my $ref = ref($str) ? $str : \$str;
1033 0           my $sub;
1034             my $nest;
1035             $sub = sub {
1036 0     0     my ($tree, $indent) = @_;
1037 0           my $out = "[\n";
1038 0           foreach my $node (@$tree) {
1039 0 0 0       if (! ref($node) || (! $node->[4] && ! $node->[5])) {
      0        
1040 0           $out .= "$indent ".$self->ast_string($node).",\n";
1041 0           next;
1042             }
1043 0           $out .= "$indent " . $nest->($node, "$indent ");
1044             }
1045 0           $out .= "$indent]";
1046 0           };
1047             $nest = sub {
1048 0     0     my ($node, $indent) = @_;
1049 0           my $out = $self->ast_string([@{$node}[0..3]]);
  0            
1050 0           chop $out;
1051 0 0         if ($node->[4]) {
1052 0           $out .= ", ";
1053 0           $out .= $sub->($node->[4], "$indent");
1054             }
1055 0 0         if ($node->[5]) {
    0          
1056 0           $out .= ", ". $nest->($node->[5], "$indent") . $indent;
1057             } elsif (@$node >= 6) {
1058 0           $out .= ", ". $self->ast_string($node->[5]);
1059             }
1060 0 0         if (@$node >= 7) { $out.= ", ". $self->ast_string($node->[6]) };
  0            
1061 0           $out .= "],\n";
1062 0           return $out;
1063 0           };
1064              
1065 0           return $sub->($self->parse_tree($ref), '') ."\n";
1066             }
1067              
1068             sub dump_parse_expr {
1069 0     0 1   my $self = shift;
1070 0 0         $self = $self->new if ! ref $self;
1071 0           my $str = shift;
1072 0 0         my $ref = ref($str) ? $str : \$str;
1073 0           return $self->ast_string($self->parse_expr($ref));
1074             }
1075              
1076             ###----------------------------------------------------------------###
1077              
1078             1;
1079              
1080             __END__