File Coverage

blib/lib/Template/Alloy/Play.pm
Criterion Covered Total %
statement 530 572 92.6
branch 232 322 72.0
condition 119 194 61.3
subroutine 44 46 95.6
pod 1 34 2.9
total 926 1168 79.2


line stmt bran cond sub pod time code
1             package Template::Alloy::Play;
2              
3             =head1 NAME
4              
5             Template::Alloy::Play - Play role - allows for playing out the AST
6              
7             =cut
8              
9 10     10   79 use strict;
  10         37  
  10         406  
10 10     10   62 use warnings;
  10         21  
  10         371  
11 10     10   58 use Template::Alloy;
  10         20  
  10         74  
12 10     10   5268 use Template::Alloy::Iterator;
  10         29  
  10         314  
13 10     10   5538 use Template::Alloy::Context;
  10         27  
  10         75609  
14              
15             our $VERSION = $Template::Alloy::VERSION;
16             our $QR_NUM = '(?:\d*\.\d+ | \d+)';
17             our $DIRECTIVES = {
18             BLOCK => \&play_BLOCK,
19             BREAK => \&play_control,
20             CALL => \&play_CALL,
21             CASE => undef,
22             CATCH => undef,
23             CLEAR => \&play_CLEAR,
24             '#' => sub {},
25             COMMENT => sub {},
26             CONFIG => \&play_CONFIG,
27             DEBUG => \&play_DEBUG,
28             DEFAULT => \&play_DEFAULT,
29             DUMP => \&play_DUMP,
30             ELSE => undef,
31             ELSIF => undef,
32             END => sub {},
33             EVAL => \&play_EVAL,
34             FILTER => \&play_FILTER,
35             '|' => \&play_FILTER,
36             FINAL => undef,
37             FOR => \&play_FOR,
38             FOREACH => \&play_FOR,
39             GET => \&play_GET,
40             IF => \&play_IF,
41             INCLUDE => \&play_INCLUDE,
42             INSERT => \&play_INSERT,
43             LAST => \&play_control,
44             LOOP => \&play_LOOP,
45             MACRO => \&play_MACRO,
46             META => \&play_META,
47             NEXT => \&play_control,
48             PERL => \&play_PERL,
49             PROCESS => \&play_PROCESS,
50             RAWPERL => \&play_RAWPERL,
51             RETURN => \&play_RETURN,
52             SET => \&play_SET,
53             STOP => \&play_control,
54             SWITCH => \&play_SWITCH,
55             TAGS => sub {},
56             THROW => \&play_THROW,
57             TRY => \&play_TRY,
58             UNLESS => \&play_UNLESS,
59             USE => \&play_USE,
60             VIEW => \&play_VIEW,
61             WHILE => \&play_WHILE,
62             WRAPPER => \&play_WRAPPER,
63             };
64              
65 0     0 0 0 sub new { die "This class is a role for use by packages such as Template::Alloy" }
66              
67             ###----------------------------------------------------------------###
68              
69             sub play_tree {
70 5220     5220 1 10110 my ($self, $tree, $out_ref) = @_;
71              
72 5220 100       13249 return $self->stream_tree($tree) if $self->{'STREAM'};
73              
74             # node contains (0: DIRECTIVE,
75             # 1: start_index,
76             # 2: end_index,
77             # 3: parsed tag details,
78             # 4: sub tree for block types
79             # 5: continuation sub trees for sub continuation block types (elsif, else, etc)
80             # 6: flag to capture next directive
81 3797         7858 for my $node (@$tree) {
82             ### text nodes are just the bare text
83 7172 100       14417 if (! ref $node) {
84 1532 50       3630 $$out_ref .= $node if defined $node;
85 1532         2970 next;
86             }
87              
88 5640 100 66     12357 $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};
89              
90 5640         14946 $DIRECTIVES->{$node->[0]}->($self, $node->[3], $node, $out_ref);
91             }
92             }
93              
94             sub _is_empty_named_args {
95 243     243   600 my ($hash_ident) = @_;
96             # [[undef, '{}', 'key1', 'val1', 'key2, 'val2'], 0]
97 243         473 return @{ $hash_ident->[0] } <= 2;
  243         1042  
98             }
99              
100             ###----------------------------------------------------------------###
101              
102             sub play_BLOCK {
103 202     202 0 556 my ($self, $block_name, $node, $out_ref) = @_;
104              
105             # store a named reference - but do nothing until something processes it
106 202         375 my $comp = $self->{'_component'};
107             $self->{'BLOCKS'}->{$block_name} = {
108             _tree => $node->[4],
109             name => $comp->{'name'} .'/'. $block_name,
110 202 50       1156 ($comp->{'_filename'} ? (_filename => $comp->{'_filename'}) : ()),
111             };
112              
113 202         494 return;
114             }
115              
116             sub play_CALL {
117 52     52 0 127 my ($self, $ident, $node) = @_;
118 52         155 my $var = $self->play_expr($ident);
119 52 50       211 $var = $self->undefined_get($ident, $node) if ! defined $var;
120 52         179 return;
121             }
122              
123             sub play_control {
124 26     26 0 69 my ($self, $undef, $node) = @_;
125 26         126 $self->throw(lc($node->[0]), 'Control exception', $node);
126             }
127              
128             sub play_CLEAR {
129 7     7 0 15 my ($self, $undef, $node, $out_ref) = @_;
130 7         14 $$out_ref = '';
131 7         16 return;
132             }
133              
134             sub play_CONFIG {
135 121     121 0 302 my ($self, $config, $node, $out_ref) = @_;
136              
137 121         311 my %rtime = map {$_ => 1} @Template::Alloy::CONFIG_RUNTIME;
  605         1279  
138              
139             ### do runtime config - not many options get these
140 121         305 my ($named, @the_rest) = @$config;
141 121         407 $named = $self->play_expr($named);
142 121 100 100     430 $self->throw("config.strict", "Cannot disable STRICT once it is enabled", $node) if exists $named->{'STRICT'} && ! $named->{'STRICT'};
143 118         379 @{ $self }{keys %$named} = @{ $named }{keys %$named};
  118         254  
  118         288  
144              
145             ### show what current values are
146 118 50       371 $$out_ref .= join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest);
  15 100       77  
147 118         1503 return;
148             }
149              
150             sub play_DEBUG {
151 2     2 0 7 my ($self, $ref) = @_;
152 2 50       33 if ($ref->[0] eq 'on') {
    50          
    50          
153 0         0 delete $self->{'_debug_off'};
154             } elsif ($ref->[0] eq 'off') {
155 0         0 $self->{'_debug_off'} = 1;
156             } elsif ($ref->[0] eq 'format') {
157 2         11 $self->{'_debug_format'} = $ref->[1];
158             }
159 2         7 return;
160             }
161              
162             sub play_DEFAULT {
163 6     6 0 14 my ($self, $set) = @_;
164 6         15 foreach my $item (@$set) {
165 6         19 my ($op, $set, $default) = @$item;
166 6 50       14 next if ! defined $set;
167 6         21 my $val = $self->play_expr($set);
168 6 100       18 if (! $val) {
169 4 50       16 $default = defined($default) ? $self->play_expr($default) : '';
170 4         14 $self->set_variable($set, $default);
171             }
172             }
173 6         14 return;
174             }
175              
176             sub play_DUMP {
177 84     84 0 216 my ($self, $dump, $node, $out_ref) = @_;
178              
179 84         171 my $conf = $self->{'DUMP'};
180 84 100 100     371 return if ! $conf && defined $conf; # DUMP => 0
181 78 100       216 $conf = {} if ref $conf ne 'HASH';
182              
183             ### allow for handler override
184 78         152 my $handler = $conf->{'handler'};
185 78 100       178 if (! $handler) {
186 75         1227 require Data::Dumper;
187 75         7954 my $obj = Data::Dumper->new([]);
188 75         2377 my $meth;
189 75 100 66     256 foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) }
  60         626  
190 75 100       307 my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1;
191 21 50 66 21   416 $obj->Sortkeys(sub { my $h = shift; [grep {! $Template::Alloy::QR_PRIVATE
  21         129  
  27         537  
192 75         595 || $_ !~ $Template::Alloy::QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] });
193 72     72   353 $handler = sub { $obj->Values([@_]); $obj->Dump }
  72         967  
194 75         644 }
195              
196 78         231 my ($named, @dump) = @$dump;
197 78 100       189 push @dump, $named if ! _is_empty_named_args($named); # add named args back on at end - if there are some
198 78         395 $_ = $self->play_expr($_) foreach @dump;
199              
200             ### look for the text describing what to dump
201 78   50     167 my $info = eval { $self->node_info($node) } || {text => 'unknown', file => 'unknown', line => 'unknown'};
202 78         138 my $out;
203 78 100 100     229 if (@dump) {
    100          
204 69 100 66     338 $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump);
205 69         1316 my $name = $info->{'text'};
206 69         404 $name =~ s/^[+=~-]?\s*DUMP\s+//;
207 69         318 $name =~ s/\s*[+=~-]?$//;
208 69         228 $out =~ s/\$VAR1/$name/;
209             } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) {
210 3         8 $out = '';
211             } else {
212 6         20 $out = $handler->($self->{'_vars'});
213 6         37 $out =~ s/\$VAR1/EntireStash/g;
214             }
215              
216 78 100 100     575 if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) {
      100        
217 9         54 $out = $Template::Alloy::SCALAR_OPS->{'xml'}->($out);
218 9         31 $out = "
$out
";
219 9 100 66     67 $out = "DUMP: File \"$info->{file}\" line $info->{line}$out" if $conf->{'header'} || ! defined $conf->{'header'};
220             } else {
221 69 100 66     408 $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'};
222             }
223              
224 78         190 $$out_ref .= $out;
225 78         1692 return;
226             }
227              
228             sub play_EVAL {
229 20     20 0 42 my ($self, $ref, $node, $out_ref) = @_;
230 20         50 my ($named, @strs) = @$ref;
231              
232 20         44 foreach my $str (@strs) {
233 20         58 $str = $self->play_expr($str);
234 20 50       52 next if ! defined $str;
235 20         98 $str = $self->play_expr([[undef, '-temp-', $str], 0, '|', 'eval', [$named]]);
236 17 50       66 $$out_ref .= $str if defined $str;
237             }
238 17         41 return;
239             }
240              
241             sub play_FILTER {
242 49     49 0 130 my ($self, $ref, $node, $out_ref) = @_;
243 49         108 my ($name, $filter) = @$ref;
244              
245 49 50       143 return '' if ! @$filter;
246              
247 49 100       122 $self->{'FILTERS'}->{$name} = $filter if length $name;
248              
249 49         86 my $sub_tree = $node->[4];
250              
251             ### play the block
252 49         78 my $out = '';
253 49         77 eval { local $self->{'STREAM'} = undef; $self->play_tree($sub_tree, \$out) };
  49         101  
  49         167  
254 49 50 33     158 die $@ if $@ && ! UNIVERSAL::can($@, 'type'); # TODO - shouldn't they all die ?
255              
256 49         300 $out = $self->play_expr([[undef, '-temp-', $out], 0, '|', @$filter]);
257 49 50       191 $$out_ref .= $out if defined $out;
258 49         131 return;
259             }
260              
261             sub play_FOR {
262 172     172 0 433 my ($self, $ref, $node, $out_ref) = @_;
263              
264             ### get the items - make sure it is an arrayref
265 172         468 my ($var, $items) = @$ref;
266              
267 172         560 $items = $self->play_expr($items);
268 172 100       423 return '' if ! defined $items;
269              
270 168 50       495 if (ref($items) !~ /Iterator$/) {
271 168         478 $items = $self->iterator($items);
272             }
273              
274 168         429 my $sub_tree = $node->[4];
275              
276 168         438 local $self->{'_vars'}->{'loop'} = $items;
277              
278             ### if the FOREACH tag sets a var - then nothing but the loop var gets localized
279 168 100       389 if (defined $var) {
280 129         412 my ($item, $error) = $items->get_first;
281 129         376 while (! $error) {
282 326         982 $self->set_variable($var, $item);
283              
284 326         585 eval { $self->play_tree($sub_tree, $out_ref) };
  326         780  
285 326 100       789 if (my $err = $@) {
286 18 50       67 die $err if ! UNIVERSAL::can($err, 'type');
287 18 100       65 last if $err->type =~ /last|break/;
288 14 100       38 die if $err->type ne 'next';
289             }
290 312         848 ($item, $error) = $items->get_next;
291             }
292 119 50 66     515 die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
293             ### if the FOREACH tag doesn't set a var - then everything gets localized
294             } else {
295              
296             ### localize variable access for the foreach
297 39         71 my $swap = $self->{'_vars'};
298 39         213 local $self->{'_vars'} = my $copy = {%$swap};
299              
300             ### iterate use the iterator object
301             #foreach (my $i = $items->index; $i <= $#$vals; $items->index(++ $i)) {
302 39         153 my ($item, $error) = $items->get_first;
303 39         101 while (! $error) {
304 129 100       352 @$copy{keys %$item} = values %$item if ref($item) eq 'HASH';
305              
306 129         199 eval { $self->play_tree($sub_tree, $out_ref) };
  129         281  
307 129 50       283 if (my $err = $@) {
308 0 0       0 die $err if ! UNIVERSAL::can($err, 'type');
309 0 0       0 last if $err->type =~ /last|break/;
310 0 0       0 die if $err->type ne 'next';
311             }
312 129         338 ($item, $error) = $items->get_next;
313             }
314 39 50 33     226 die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
315             }
316              
317 158         699 return;
318             }
319              
320             sub play_GET {
321 3757     3757 0 7640 my ($self, $ident, $node, $out_ref) = @_;
322 3757         10247 my $var = $self->play_expr($ident);
323 3711 100       8034 if (defined $var) {
324 3314         7149 $$out_ref .= $var;
325             } else {
326 397         1086 $var = $self->undefined_get($ident, $node);
327 397 50       1071 $$out_ref .= $var if defined $var;
328             }
329 3711         9000 return;
330             }
331              
332             sub play_IF {
333 152     152 0 349 my ($self, $var, $node, $out_ref) = @_;
334              
335 152         418 my $val = $self->play_expr($var);
336 150 100       362 if ($val) {
337 78   50     203 my $body_ref = $node->[4] ||= [];
338 78         260 $self->play_tree($body_ref, $out_ref);
339 56         142 return;
340             }
341              
342 72         200 while ($node = $node->[5]) { # ELSE, ELSIF's
343 29 100       81 if ($node->[0] eq 'ELSE') {
344 13   50     59 my $body_ref = $node->[4] ||= [];
345 13         56 $self->play_tree($body_ref, $out_ref);
346 13         37 return;
347             }
348 16         33 my $var = $node->[3];
349 16         41 my $val = $self->play_expr($var);
350 16 100       54 if ($val) {
351 6   50     32 my $body_ref = $node->[4] ||= [];
352 6         22 $self->play_tree($body_ref, $out_ref);
353 6         39 return;
354             }
355             }
356 53         122 return;
357             }
358              
359             sub play_INCLUDE {
360 146     146 0 357 my ($self, $str_ref, $node, $out_ref) = @_;
361              
362             ### localize the swap
363 146   50     418 my $swap = $self->{'_vars'} || {};
364 146         620 local $self->{'_vars'} = {%$swap};
365              
366             ### localize the blocks
367 146   50     397 my $blocks = $self->{'BLOCKS'} || {};
368 146         416 local $self->{'BLOCKS'} = {%$blocks};
369              
370 146         446 return $DIRECTIVES->{'PROCESS'}->($self, $str_ref, $node, $out_ref);
371             }
372              
373             sub play_INSERT {
374 21     21 0 56 my ($self, $args, $node, $out_ref) = @_;
375 21 50       52 if ($self->{'NO_INCLUDES'}) {
376 0         0 $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive");
377             }
378              
379 21         54 my ($named, @files) = @$args;
380              
381 21         45 foreach my $name (@files) {
382 21         67 my $file = $self->play_expr($name);
383 21         76 my $ref = $self->slurp($self->include_filename($file));
384 21         107 $$out_ref .= $$ref;
385             }
386              
387 21         272 return;
388             }
389              
390             sub play_JS {
391 0     0 0 0 my $self = shift;
392 0 0       0 $self->throw('js', 'COMPILE_JS not set while running a JS block') if ! $self->{'COMPILE_JS'};
393 0         0 $self->throw('js', 'Cannot run JS directly');
394             }
395              
396             sub play_LOOP {
397 23     23 0 55 my ($self, $ref, $node, $out_ref) = @_;
398              
399 23 100       93 my $var = $self->play_expr(ref($ref) ? $ref : [$ref,0]); # allow for "string" identified loops
400 23         50 my $sub_tree = $node->[4];
401              
402 23   100     99 my $global = ! $self->{'SYNTAX'} || $self->{'SYNTAX'} ne 'ht' || $self->{'GLOBAL_VARS'};
403              
404 23 100       79 my $items = ref($var) eq 'ARRAY' ? $var : ref($var) eq 'HASH' ? [$var] : [];
    100          
405              
406 23         38 my $i = 0;
407 23         45 for my $ref (@$items) {
408             ### setup the loop
409 46 50 66     162 $self->throw('loop', 'Scalar value used in LOOP') if $ref && ref($ref) ne 'HASH';
410 46 100 50     138 local $self->{'_vars'} = (! $global) ? ($ref || {}) : (ref($ref) eq 'HASH') ? {%{ $self->{'_vars'} }, %$ref} : $self->{'_vars'};
  36 100       213  
411 46 100 66     159 if ($self->{'LOOP_CONTEXT_VARS'} && ! $Template::Alloy::QR_PRIVATE) {
412 9         26 $self->{'_vars'}->{'__counter__'} = ++$i;
413 9 100       26 $self->{'_vars'}->{'__first__'} = $i == 1 ? 1 : 0;
414 9 100       37 $self->{'_vars'}->{'__last__'} = $i == @$items ? 1 : 0;
415 9 100 100     49 $self->{'_vars'}->{'__inner__'} = $i == 1 || $i == @$items ? 0 : 1;
416 9 100       39 $self->{'_vars'}->{'__odd__'} = ($i % 2) ? 1 : 0;
417             }
418              
419             ### execute the sub tree
420 46         153 $self->play_tree($sub_tree, $out_ref);
421             }
422              
423 23         55 return;
424             }
425              
426             sub play_MACRO {
427 44     44 0 112 my ($self, $ref, $node, $out_ref) = @_;
428 44         99 my ($name, $args) = @$ref;
429              
430             ### get the sub tree
431 44         75 my $sub_tree = $node->[4];
432 44 50 33     332 if (! $sub_tree || ! $sub_tree->[0]) {
    100 100        
433 0         0 $self->set_variable($name, undef);
434 0         0 return;
435             } elsif (ref($sub_tree->[0]) && $sub_tree->[0]->[0] eq 'BLOCK') {
436 31         69 $sub_tree = $sub_tree->[0]->[4];
437             }
438              
439             ### install a closure in the stash that will handle the macro
440 44         130 $self->set_variable($name, $self->_macro_sub($args, $sub_tree, $out_ref));
441              
442 44         113 return;
443             }
444              
445             sub _macro_sub {
446 71     71   173 my ($self, $args, $sub_tree, $out_ref) = @_;
447              
448 71         152 my $self_copy = $self;
449              
450             my $sub = sub {
451             ### macros localize
452 94     94   177 my $copy = $self_copy->{'_vars'};
453 94         444 local $self_copy->{'_vars'}= {%$copy};
454              
455             ### prevent recursion
456 94   100     417 local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0;
457 94   66     338 my $max = $self_copy->{'MAX_MACRO_RECURSE'} || $Template::Alloy::MAX_MACRO_RECURSE;
458             $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $max reached")
459 94 100       257 if ++$self_copy->{'_macro_recurse'} > $max;
460              
461             ### set arguments
462 92 50 100     456 my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
      66        
463 92         234 my @positional = @_;
464 92         217 foreach my $var (@$args) {
465 83         252 $self_copy->set_variable($var, shift(@positional));
466             }
467 92         338 foreach my $name (sort keys %$named) {
468 0         0 $self_copy->set_variable([$name, 0], $named->{$name});
469             }
470              
471 92         217 local $self->{'STREAM'} = undef;
472              
473             ### finally - run the sub tree
474 92         160 my $out = '';
475 92         167 eval { $self_copy->play_tree($sub_tree, \$out) };
  92         275  
476 92 50       255 if (my $err = $@) {
477 0 0       0 die $err if $err->type ne 'return';
478 0 0       0 return $err->info->{'return_val'} if UNIVERSAL::isa($err->info, 'HASH');
479 0         0 return;
480             }
481 92         647 return $out;
482 71         565 };
483              
484 71         157 eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
  71         448  
  71         248  
485 71         261 return $sub;
486             }
487              
488             sub play_META {
489 152     152 0 330 my ($self, $hash) = @_;
490 152 100       371 return if ! $hash;
491 76 50       278 $hash = {@$hash} if ref($hash) eq 'ARRAY';
492 76         265 my @keys = keys %$hash;
493              
494 76         122 my $ref;
495 76 100       178 if ($self->{'_top_level'}) {
496 52   50     151 $ref = $self->{'_template'} ||= {};
497             } else {
498 24   50     57 $ref = $self->{'_component'} ||= {};
499             }
500              
501 76         123 @{ $ref }{ @keys } = @{ $hash }{ @keys };
  76         211  
  76         132  
502 76         631 return;
503             }
504              
505             sub play_PERL {
506 12     12 0 32 my ($self, $info, $node, $out_ref) = @_;
507 12 100       43 $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
508              
509             ### fill in any variables
510 10   50     41 my $perl = $node->[4] || return;
511 10         21 my $out = '';
512             {
513 10         20 local $self->{'STREAM'} = undef;
  10         24  
514 10         40 $self->play_tree($perl, \$out);
515             };
516 10 50       72 $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
517              
518             ### try the code
519 10         20 my $err;
520 10         20 eval {
521             package Template::Alloy::Perl;
522              
523 10         39 my $context = $self->context;
524 10         35 my $stash = $context->stash;
525              
526             ### setup a fake handle
527 10         36 local *PERLOUT;
528 10         98 tie *PERLOUT, 'Template::Alloy::EvalPerlHandle', $out_ref;
529 10         34 my $old_fh = select PERLOUT;
530              
531 10         980 eval $out;
532 10         45 $err = $@;
533              
534             ### put the handle back
535 10         76 select $old_fh;
536              
537             };
538 10   33     54 $err ||= $@;
539              
540              
541 10 50       27 if ($err) {
542 0 0       0 $self->throw('undef', $err) if ! UNIVERSAL::can($err, 'type');
543 0         0 die $err;
544             }
545              
546 10         31 return;
547             }
548              
549             sub play_PROCESS {
550 541     541 0 1266 my ($self, $info, $node, $out_ref) = @_;
551 541 100       1350 if ($self->{'NO_INCLUDES'}) {
552 2         12 $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive");
553             }
554              
555 539         1385 my ($args, @files) = @$info;
556              
557             ### process files first
558 539         1176 foreach my $ref (@files) {
559 551 50       2027 $ref = $self->play_expr($ref) if defined $ref;
560             }
561              
562             ### set passed args
563             # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
564 539         995 $args = $args->[0];
565 539         1479 foreach (my $i = 2; $i < @$args; $i+=2) {
566 94         217 my $key = $args->[$i];
567 94         321 my $val = $self->play_expr($args->[$i+1]);
568 94 0 66     315 if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever
      33        
      33        
569 0         0 foreach my $key (keys %$val) {
570 0         0 $self->set_variable([$key,0], $val->{$key});
571             }
572 0         0 next;
573             }
574 94         254 $self->set_variable($key, $val);
575             }
576              
577             ### iterate on any passed block or filename
578 539         1075 foreach my $filename (@files) {
579 551 50       1125 next if ! defined $filename;
580 551         942 my $out = ''; # have temp item to allow clear to correctly clear
581              
582             ### normal blocks or filenames
583 551 100 100     1457 if (! ref($filename) || ref($filename) eq 'SCALAR') {
584 537         1295 eval { $self->_process($filename, $self->{'_vars'}, \$out) }; # restart the swap - passing it our current stash
  537         1893  
585              
586             ### allow for $template which is used in some odd instances
587             } else {
588 14         29 my $doc = $filename;
589              
590 14 50       45 $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'};
591 14         42 local $self->{'_process_dollar_template'} = 1;
592 14         35 local $self->{'_component'} = $doc;
593              
594             ### run the document however we can
595 14 50 66     117 if (ref($doc) ne 'HASH' || (! $doc->{'_perl'} && ! $doc->{'_tree'})) {
    100 33        
596 0         0 $self->throw('process', "Passed item doesn't appear to be a valid document");
597             } elsif ($doc->{'_perl'}) {
598 5         10 eval { $doc->{'_perl'}->{'code'}->($self, \$out) };
  5         131  
599             } else {
600 9         20 eval { $self->play_tree($doc->{'_tree'}, \$out) };
  9         31  
601             }
602              
603 14 50       47 if ($self->{'TRIM'}) {
604 0         0 $out =~ s{ \s+ $ }{}x;
605 0         0 $out =~ s{ ^ \s+ }{}x;
606             }
607              
608             ### handle exceptions
609 14 50       85 if (my $err = $@) {
610 0 0       0 $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type');
611 0 0 0     0 $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
      0        
612             }
613              
614             }
615              
616             ### append any output
617 551         1206 $$out_ref .= $out;
618 551 100       1521 if (my $err = $@) {
619 87 100 66     396 die $err if ! UNIVERSAL::can($err, 'type') || $err->type !~ /return/;
620             }
621             }
622              
623 455         4505 return;
624             }
625              
626             sub play_RAWPERL {
627 3     3 0 11 my ($self, $info, $node, $out_ref) = @_;
628 3 50       16 $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
629              
630             ### fill in any variables
631 3   50     13 my $tree = $node->[4] || return;
632 3         8 my $perl = '';
633             {
634 3         9 local $self->{'STREAM'} = undef;
  3         9  
635 3         14 $self->play_tree($tree, \$perl);
636             }
637 3 50       24 $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
638              
639             ### try the code
640 3         6 my $err;
641 3         8 my $output = '';
642 3         7 eval {
643             package Template::Alloy::Perl;
644              
645 3         11 my $context = $self->context;
646 3         11 my $stash = $context->stash;
647              
648 3         197 eval $perl;
649 3         22 $err = $@;
650             };
651 3   33     22 $err ||= $@;
652              
653 3         7 $$out_ref .= $output;
654              
655 3 50       10 if ($err) {
656 0 0       0 $self->throw('undef', $err) if ! UNIVERSAL::can($err, 'type');
657 0         0 die $err;
658             }
659              
660 3         29 return;
661             }
662              
663             sub play_RETURN {
664 10     10 0 25 my ($self, $undef, $node) = @_;
665 10         19 my $var = $node->[3];
666 10 50       24 $var = {return_val => $self->play_expr($var)} if defined $var;
667 10         34 $self->throw('return', $var, $node);
668             }
669              
670             sub play_SET {
671 1020     1020 0 2292 my ($self, $set, $node) = @_;
672 1020         2019 foreach my $item (@$set) {
673 1028         2344 my ($op, $set, $val) = @$item;
674 1028 100 66     3606 if (! defined $val) { # not defined
    100          
675             # do nothing - allow for setting to undef
676             } elsif ($node->[4] && $val == $node->[4]) { # a captured directive
677 54         104 my $sub_tree = $node->[4];
678 54 100 66     239 $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK';
679 54         96 $val = '';
680 54         124 local $self->{'STREAM'} = undef;
681 54         160 $self->play_tree($sub_tree, \$val);
682             } else { # normal var
683 956         2690 $val = $self->play_expr($val);
684             }
685              
686 1027         3194 $self->set_variable($set, $val);
687             }
688 1017         2405 return;
689             }
690              
691             sub play_SWITCH {
692 20     20 0 53 my ($self, $var, $node, $out_ref) = @_;
693              
694 20         58 my $val = $self->play_expr($var);
695 20 50       66 $val = '' if ! defined $val;
696             ### $node->[4] is thrown away
697              
698 20         35 my $default;
699 20         56 while ($node = $node->[5]) { # CASES
700 20         46 my $var = $node->[3];
701 20 100       46 if (! defined $var) {
702 6         12 $default = $node->[4];
703 6         18 next;
704             }
705              
706 14         32 my $val2 = $self->play_expr($var);
707 14 100       50 $val2 = [$val2] if ! UNIVERSAL::isa($val2, 'ARRAY');
708 14         28 for my $test (@$val2) { # find matching values
709 32 50 33     69 next if ! defined $val && defined $test;
710 32 100 66     100 next if defined $val && ! defined $test;
711 30 100       109 next if $val ne $test;
712 8   50     25 my $body_ref = $node->[4] ||= [];
713 8         61 $self->play_tree($body_ref, $out_ref);
714 8         23 return;
715             }
716             }
717              
718 12 100       31 if ($default) {
719 6         19 $self->play_tree($default, $out_ref);
720             }
721              
722 12         40 return;
723             }
724              
725             sub play_THROW {
726 67     67 0 139 my ($self, $ref, $node) = @_;
727 67         157 my ($name, $args) = @$ref;
728              
729 67         203 $name = $self->play_expr($name);
730              
731 67         192 my ($named, @args) = @$args;
732 67 50       149 push @args, $named if ! _is_empty_named_args($named); # add named args back on at end - if there are some
733              
734 67         168 @args = map { $self->play_expr($_) } @args;
  58         141  
735 67         266 $self->throw($name, \@args, $node); # dies
736 0         0 return; # but return just in case
737             }
738              
739             sub play_TRY {
740 156     156 0 370 my ($self, $foo, $node, $out_ref) = @_;
741 156         284 my $out = '';
742              
743 156         270 my $body_ref = $node->[4];
744 156         253 eval { $self->play_tree($body_ref, \$out) };
  156         430  
745 156         373 my $err = $@;
746              
747 156 100       418 if (! $node->[5]) { # no catch or final
748 10 100       34 if (! $err) { # no final block and no error
749 8         18 $$out_ref .= $out;
750 8         25 return;
751             }
752 2         11 $self->throw('parse.missing', "Missing CATCH block", $node);
753             }
754 146 100       389 if ($err) {
755 94 100       418 $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type');
756 94 50       288 if ($err->type =~ /stop|return/) {
757 0         0 $$out_ref .= $out;
758 0         0 die $err;
759             }
760             }
761              
762             ### loop through the nested catch and final blocks
763 146         589 my $catch_body_ref;
764             my $last_found;
765 146 100       329 my $type = $err ? $err->type : '';
766 146         242 my $final;
767 146         353 while ($node = $node->[5]) { # CATCH
768 152 100       360 if ($node->[0] eq 'FINAL') {
769 6         25 $final = $node->[4];
770 6         246 next;
771             }
772 146 100       335 next if ! $err;
773 96         285 my $name = $self->play_expr($node->[3]);
774 96 100 66     346 $name = '' if ! defined $name || lc($name) eq 'default';
775 96 50 66     1043 if ($type =~ / ^ \Q$name\E \b /x
      100        
776             && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins
777 88   50     247 $catch_body_ref = $node->[4] || [];
778 88         293 $last_found = $name;
779             }
780             }
781              
782             ### play the best catch block
783 146 100       342 if ($err) {
784 94 100       223 if (! $catch_body_ref) {
785 8         18 $$out_ref .= $out;
786 8         52 die $err;
787             }
788 86         257 local $self->{'_vars'}->{'error'} = $err;
789 86         201 local $self->{'_vars'}->{'e'} = $err;
790 86         169 eval { $self->play_tree($catch_body_ref, \$out) };
  86         266  
791 86 50       389 if (my $err = $@) {
792 0         0 $$out_ref .= $out;
793 0         0 die $err;
794             }
795             }
796              
797             ### the final block
798 138 100       329 $self->play_tree($final, \$out) if $final;
799              
800 138         270 $$out_ref .= $out;
801              
802 138         507 return;
803             }
804              
805 14     14 0 44 sub play_UNLESS { return $DIRECTIVES->{'IF'}->(@_) }
806              
807             sub play_USE {
808 98     98 0 318 my ($self, $ref, $node, $out_ref, $foreign) = @_; # foreign allows for usage from JS
809 98         310 my ($var, $module, $args) = @$ref;
810              
811             ### get the stash storage location - default to the module
812 98 100       367 $var = $module if ! defined $var;
813 98         672 my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
  98         543  
814 98         263 pop @var; # remove the trailing '.'
815              
816 98         275 my ($named, @args) = @$args;
817 98 100       343 push @args, $named if ! _is_empty_named_args($named); # add named args back on at end - if there are some
818              
819             ### try and load the module - fall back to bare module if allowed
820 98         211 my $obj;
821 98 50 33     1499 if (my $fact = $self->{'PLUGIN_FACTORY'}->{$module} || $self->{'PLUGIN_FACTORY'}->{lc $module}) {
    100 66        
    100          
822 0 0       0 if (UNIVERSAL::isa($fact, 'CODE')) {
823 0 0       0 $obj = $fact->($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args);
  0         0  
824             }
825              
826             } elsif (my $pkg = $self->{'PLUGINS'}->{$module} || $self->{'PLUGINS'}->{lc $module}) {
827 6         26 (my $req = "$pkg.pm") =~ s|::|/|g;
828 6 100 66     27 if ($INC{$req} || eval { require $req }) {
  3         786  
829 3         31 my $shape = $pkg->load;
830 3 50       19 $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args);
  3         13  
831             }
832              
833             } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works fine too)
834 3 50       21 $obj = $self->iterator($foreign ? @$foreign : map { $self->play_expr($_) } @args);
  3         16  
835              
836             } else {
837 89         173 my $found;
838 89         195 my $BASE = $self->{'PLUGIN_BASE'};
839 89 100       374 foreach my $base ((ref($BASE) eq 'ARRAY' ? @$BASE : $BASE), (my $e = 'TP-Fallback')) {
840 163 100 100     767 if ($base && $base eq 'TP-Fallback' && eval { require Template::Plugins }) { # want to allow Template::Plugins without requiring we use them
  71   66     2235  
841 71   50     3611 $base = $Template::Plugins::PLUGIN_BASE || next;
842 71 100 66     559 if ($Template::Plugins::STD_PLUGINS
843             && (my $pkg = $Template::Plugins::STD_PLUGINS->{lc $module})) {
844 62         462 (my $req = "$pkg.pm") =~ s|::|/|g;
845 62         172 $found = 1;
846 62 50       102 if (eval { require $req }) {
  62         942  
847 62         2108 my $shape = $pkg->load;
848 62 50       586 $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args);
  40         216  
849             }
850 62         9525 last;
851             }
852             }
853 101 100       276 next if ! $base;
854              
855 39         98 my $pkg = "${base}::${module}";
856 39         198 (my $req = "$pkg.pm") =~ s|::|/|g;
857 39 100 66     352 if ($pkg->can('load') || eval { require $req }) {
  21         4005  
858 18         66 my $shape = $pkg->load;
859 18 50       110 $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args);
  12         51  
860 18         161 $found = 1;
861 18         39 last;
862             }
863             }
864              
865 89 50 66     418 if (! $found && $self->{'LOAD_PERL'}) {
866 9         82 (my $req = "$module.pm") =~ s|::|/|g;
867 9 100 66     91 if ($module->can('new') || eval { require $req }) {
  3         735  
868 6 50       36 $obj = $module->new($foreign ? @$foreign : map { $self->play_expr($_) } @args);
  3         18  
869             }
870             }
871             }
872              
873 98 100       416 if (! defined $obj) {
874 6         21 my $err = "$module: plugin not found";
875 6         31 $self->throw('plugin', $err);
876             }
877              
878 92 50       304 return $obj if $foreign;
879 92         514 $self->set_variable(\@var, $obj);
880              
881 92         1732 return;
882             }
883              
884             sub play_VIEW {
885 28     28 0 95 my ($self, $ref, $node, $out_ref) = @_;
886              
887 28         90 my ($blocks, $args, $name) = @$ref;
888              
889             ### get args ready
890             # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
891 28         72 $args = $args->[0];
892 28         69 my $hash = {};
893 28         125 foreach (my $i = 2; $i < @$args; $i+=2) {
894 35         75 my $key = $args->[$i];
895 35         129 my $val = $self->play_expr($args->[$i+1]);
896 35 50       85 if (ref $key) {
897 0 0 0     0 if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
      0        
898 0         0 $key = $key->[0];
899             } else {
900 0         0 $self->set_variable($key, $val);
901 0         0 next; # what TT does
902             }
903             }
904 35         145 $hash->{$key} = $val;
905             }
906              
907             ### prepare the blocks
908 28 100 100     315 my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : '';
909 28         124 foreach my $key (keys %$blocks) {
910 19         91 $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}};
911             }
912 28         77 $hash->{'blocks'} = $blocks;
913              
914             ### get the view
915 28 50       58 if (! eval { require Template::View }) {
  28         310  
916 0         0 $self->throw('view', 'Could not load Template::View library');
917             }
918 28   33     152 my $view = Template::View->new($self->context, $hash)
919             || $self->throw('view', $Template::View::ERROR);
920              
921             ### 'play it'
922 28         3458 my $old_view = $self->play_expr(['view', 0]);
923 28         160 $self->set_variable($name, $view);
924 28         126 $self->set_variable(['view', 0], $view);
925              
926 28 50       108 if ($node->[4]) {
927 28         65 my $out = '';
928 28         98 $self->play_tree($node->[4], \$out);
929             # throw away $out
930             }
931              
932 28         127 $self->set_variable(['view', 0], $old_view);
933 28         116 $view->seal;
934              
935 28         178 return;
936             }
937              
938             sub play_WHILE {
939 26     26 0 70 my ($self, $var, $node, $out_ref) = @_;
940 26 50       73 return if ! defined $var;
941              
942 26         44 my $sub_tree = $node->[4];
943              
944             ### iterate use the iterator object
945 26         52 my $count = $Template::Alloy::WHILE_MAX;
946 26         71 while (--$count > 0) {
947              
948 2180 100       5022 $self->play_expr($var) || last;
949              
950             ### execute the sub tree
951 2158         3527 eval { $self->play_tree($sub_tree, $out_ref) };
  2158         4511  
952 2158 100       5788 if (my $err = $@) {
953 2 50       12 if (UNIVERSAL::can($err, 'type')) {
954 2 50       10 next if $err->type =~ /next/;
955 2 50       8 last if $err->type =~ /last|break/;
956             }
957 0         0 die $err;
958             }
959             }
960 26 100       127 die "WHILE loop terminated (> $Template::Alloy::WHILE_MAX iterations)\n" if ! $count;
961              
962 24         65 return;
963             }
964              
965             sub play_WRAPPER {
966 18     18 0 42 my ($self, $args, $node, $out_ref) = @_;
967 18   50     51 my $sub_tree = $node->[4] || return;
968              
969 18         49 my ($named, @files) = @$args;
970              
971 18         34 my $out = '';
972             {
973 18         34 local $self->{'STREAM'} = undef;
  18         43  
974 18         53 $self->play_tree($sub_tree, \$out);
975 18         41 foreach my $name (reverse @files) {
976 18         51 local $self->{'_vars'}->{'content'} = $out;
977 18         30 $out = '';
978 18         63 $DIRECTIVES->{'INCLUDE'}->($self, [$named, $name], $node, \$out);
979             }
980             }
981 18 100       53 if ($self->{'STREAM'}) {
982 9         28 print $out;
983 9         19 $out = '';
984             }
985              
986 18         37 $$out_ref .= $out;
987 18         46 return;
988             }
989              
990             ###----------------------------------------------------------------###
991              
992             package Template::Alloy::EvalPerlHandle;
993              
994             sub TIEHANDLE {
995 15     15   103 my ($class, $out_ref) = @_;
996 15         160 return bless [$out_ref], $class;
997             }
998              
999             sub PRINT {
1000 15     15   37 my $self = shift;
1001 15 50       42 ${ $self->[0] } .= $_ for grep {defined && length} @_;
  15         106  
  15         61  
1002 15         240 return 1;
1003             }
1004              
1005             ###----------------------------------------------------------------###
1006              
1007             1;
1008              
1009             __END__