File Coverage

blib/lib/Template/Alloy/TT.pm
Criterion Covered Total %
statement 328 350 93.7
branch 238 286 83.2
condition 87 121 71.9
subroutine 8 9 88.8
pod 0 3 0.0
total 661 769 85.9


line stmt bran cond sub pod time code
1             package Template::Alloy::TT;
2              
3             =head1 NAME
4              
5             Template::Alloy::TT - Template::Toolkit role
6              
7             =cut
8              
9 8     8   55 use strict;
  8         20  
  8         427  
10 8     8   245 use warnings;
  8         24  
  8         373  
11              
12 8     8   49 use Template::Alloy;
  8         14  
  8         107  
13 8     8   81 use Template::Alloy::Operator qw($QR_OP_ASSIGN);
  8         18  
  8         2209  
14             our $VERSION = $Template::Alloy::VERSION;
15             our $QR_COMMENTS;
16 8   50 8   224 use constant posessive => ($^V >= 5.009) || 0; # perl 5.10 allows possessive
  8         18  
  8         60600  
17              
18 0     0 0 0 sub new { die "This class is a role for use by packages such as Template::Alloy" }
19              
20             ###----------------------------------------------------------------###
21              
22             sub parse_tree_tt3 {
23 4313     4313 0 6420 my $self = shift;
24 4313         6837 my $str_ref = shift;
25 4313 100       10213 my $one_tag_only = shift() ? 1 : 0;
26 4313 50 33     25545 if (! $str_ref || ! defined $$str_ref) {
27 0         0 $self->throw('parse.no_string', "No string or undefined during parse", undef, 1);
28             }
29              
30 4313   100     17789 my $STYLE = $self->{'TAG_STYLE'} || 'default';
31 4313   66     31303 local $self->{'_end_tag'} = $self->{'END_TAG'} || $Template::Alloy::Parse::TAGS->{$STYLE}->[1];
32 4313   66     28253 local $self->{'START_TAG'} = $self->{'START_TAG'} || $Template::Alloy::Parse::TAGS->{$STYLE}->[0];
33 4313 100       23218 local $self->{'_start_tag'} = (! $self->{'INTERPOLATE'}) ? $self->{'START_TAG'} : qr{(?: $self->{'START_TAG'} | (\$))}sx;
34              
35 4313   66     30238 local $QR_COMMENTS = $QR_COMMENTS || (posessive() ? (local $Template::Alloy::Parse::QR_COMMENTS = "(?sm: \\s*+ \\# .*? (?: \$ | (?=$self->{'_end_tag'}) ) )*+ \\s*+") : $Template::Alloy::Parse::QR_COMMENTS);
36 4313         6471 my $dirs = $Template::Alloy::Parse::DIRECTIVES;
37 4313         6973 my $aliases = $Template::Alloy::Parse::ALIASES;
38 4313         10658 local @{ $dirs }{ keys %$aliases } = values %$aliases; # temporarily add to the table
  4313         22216  
39 4313         9856 local @{ $self }{@Template::Alloy::CONFIG_COMPILETIME} = @{ $self }{@Template::Alloy::CONFIG_COMPILETIME};
  4313         59414  
  4313         22696  
40 4313 50       16886 delete $dirs->{'JS'} if ! $self->{'COMPILE_JS'};
41              
42 4313         6300 my @tree; # the parsed tree
43 4313         6863 my $pointer = \@tree; # pointer to current tree to handle nested blocks
44 4313         5504 my @state; # maintain block levels
45 4313         10525 local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS)
46 4313         10266 local $self->{'_no_interp'} = 0; # no interpolation in some blocks (usually PERL)
47 4313         5507 my @in_view; # let us know if we are in a view
48             my @blocks; # store blocks for later moving to front
49 0         0 my @meta; # place to store any found meta information (to go into META)
50 4313         9412 my $post_chomp = 0; # previous post_chomp setting
51 4313         4997 my $continue = 0; # flag for multiple directives in the same tag
52 4313         5437 my $post_op = 0; # found a post-operative DIRECTIVE
53 4313         6096 my $capture; # flag to start capture
54             my $func;
55 0         0 my $node;
56 4313 100       20786 pos($$str_ref) = 0 if ! $one_tag_only;
57              
58 4313         8690 while (1) {
59             ### continue looking for information in a semi-colon delimited tag
60 14081 100       35265 if ($continue) {
    100          
61 1844         4349 $node = [undef, $continue, undef];
62              
63             } elsif ($one_tag_only) {
64 27         89 $node = [undef, pos($$str_ref), undef];
65              
66             ### find the next opening tag
67             } else {
68 12210 100       105706 $$str_ref =~ m{ \G (.*?) $self->{'_start_tag'} }gcxs
69             || last;
70 8009         27707 my ($text, $dollar) = ($1, $2); # dollar is set only on an interpolated var
71              
72             ### found a text portion - chomp it and store it
73 8009 100       18789 if (length $text) {
74 2425 100       6700 if (! $post_chomp) { }
    100          
    50          
    50          
75 272         1191 elsif ($post_chomp == 1) { $text =~ s{ ^ [^\S\n]* \n }{}x }
76 0         0 elsif ($post_chomp == 2) { $text =~ s{ ^ \s+ }{ }x }
77 90         488 elsif ($post_chomp == 3) { $text =~ s{ ^ \s+ }{}x }
78 2425 100       8081 push @$pointer, $text if length $text;
79             }
80              
81             ### handle variable interpolation ($2 eq $)
82 8009 100       17331 if ($dollar) {
83             ### inspect previous text chunk for escape slashes
84 107 100       360 my $n = ($text =~ m{ (\\+) $ }x) ? length($1) : 0;
85 107 100 100     588 if ($self->{'_no_interp'} || $n % 2) { # were there odd escapes
86 18         23 my $prev_text;
87 18 50 33     104 $prev_text = \$pointer->[-1] if defined($pointer->[-1]) && ! ref($pointer->[-1]);
88 18 100       76 chop($$prev_text) if $n % 2;
89 18 50       38 if ($prev_text) { $$prev_text .= $dollar } else { push @$pointer, $dollar }
  18         211  
  0         0  
90 18         43 next;
91             }
92              
93 89         214 my $not = $$str_ref =~ m{ \G ! }gcx;
94 89         157 my $mark = pos($$str_ref);
95 89         117 my $ref;
96 89 100       306 if ($$str_ref =~ m{ \G \{ }gcx) {
97 37         92 local $self->{'_operator_precedence'} = 0; # allow operators
98 37         137 $ref = $self->parse_expr($str_ref);
99 37 50       436 $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcx
100             || $self->throw('parse', 'Missing close }', undef, pos($$str_ref));
101             } else {
102 52         117 local $self->{'_operator_precedence'} = 1; # no operators
103 52         240 local $QR_COMMENTS = local $Template::Alloy::Parse::QR_COMMENTS = qr{};
104 52         233 $ref = $self->parse_expr($str_ref);
105             }
106 89 50       249 $self->throw('parse', "Error while parsing for interpolated string", undef, pos($$str_ref))
107             if ! defined $ref;
108 89 100 100     498 if (! $not && $self->{'SHOW_UNDEFINED_INTERP'}) {
109 12         57 $ref = [[undef, '//', $ref, '$'.substr($$str_ref, $mark, pos($$str_ref)-$mark)], 0];
110             }
111 89         291 push @$pointer, ['GET', $mark, pos($$str_ref), $ref];
112 89         121 $post_chomp = 0; # no chomping after dollar vars
113 89         189 next;
114             }
115              
116 7902         22921 $node = [undef, pos($$str_ref), undef];
117              
118             ### take care of whitespace and comments flags
119 7902 100       28204 my $pre_chomp = $$str_ref =~ m{ \G ([+=~-]) }gcx ? $1 : $self->{'PRE_CHOMP'};
120 7902 100       16794 $pre_chomp =~ y/-=~+/1230/ if $pre_chomp;
121 7902 100 100     24563 if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) {
      100        
122 107 100       406 if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x }
  77 50       523  
    50          
123 0         0 elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x }
124 30         178 elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x }
125 107 100       452 splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length
126             }
127              
128             ### leading # means to comment the entire section
129 7902 100       29077 if ($$str_ref =~ m{ \G \# }gcx) {
130 21 50       229 $$str_ref =~ m{ \G (.*?) ([+~=-]?) ($self->{'_end_tag'}) }gcxs # brute force - can't comment tags with nested %]
131             || $self->throw('parse', "Missing closing tag", undef, pos($$str_ref));
132 21         41 $node->[0] = '#';
133 21         65 $node->[2] = pos($$str_ref) - length($3) - length($2);
134 21         41 push @$pointer, $node;
135              
136 21         29 $post_chomp = $2;
137 21   33     94 $post_chomp ||= $self->{'POST_CHOMP'};
138 21 50       46 $post_chomp =~ y/-=~+/1230/ if $post_chomp;
139 21         42 next;
140             }
141             #$$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
142             }
143              
144             ### look for DIRECTIVES
145 9752 100 66     154357 if ($$str_ref =~ m{ \G \s* $QR_COMMENTS $Template::Alloy::Parse::QR_DIRECTIVE }gcxo # find a word
    100 66        
    100 66        
146             && ($func = $self->{'ANYCASE'} ? uc($1) : $1)
147             && ($dirs->{$func}
148             || ((pos($$str_ref) -= length $1) && 0))
149             ) { # is it a directive
150 4430         26629 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcx;
151              
152 4430 100       12609 $func = $aliases->{$func} if $aliases->{$func};
153 4430         9007 $node->[0] = $func;
154              
155             ### store out this current node level to the appropriate tree location
156             # on a post operator - replace the original node with the new one - store the old in the new
157 4430 100 100     24946 if ($dirs->{$func}->[3] && $post_op) {
    100 100        
    100          
158 152         675 my @post_op = @$post_op;
159 152         462 @$post_op = @$node;
160 152         281 $node = $post_op;
161 152         495 $node->[4] = [\@post_op];
162             # if there was not a semi-colon - see if semis were required
163             } elsif ($post_op && $self->{'SEMICOLONS'}) {
164 3         33 $self->throw('parse', "Missing semi-colon with SEMICOLONS => 1", undef, $node->[1]);
165              
166             # handle directive captures for an item like "SET foo = BLOCK"
167             } elsif ($capture) {
168 136         192 push @{ $capture->[4] }, $node;
  136         317  
169 136         244 undef $capture;
170              
171             # normal nodes
172             } else{
173 4139         8458 push @$pointer, $node;
174             }
175              
176             ### parse any remaining tag details
177 4427         6144 $node->[3] = eval { $dirs->{$func}->[0]->($self, $str_ref, $node) };
  4427         18098  
178 4427 100       13269 if (my $err = $@) {
179 27 50 33     248 $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
180 27         435 die $err;
181             }
182 4400         8199 $node->[2] = pos $$str_ref;
183              
184             ### anything that behaves as a block ending
185 4400 100 100     34514 if ($func eq 'END' || $dirs->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc)
    100 100        
    100          
    100          
186 1291 100       3586 if (! @state) {
187 9         58 $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref));
188             }
189 1282         2595 my $parent_node = pop @state;
190              
191 1282 100       3538 if ($func ne 'END') {
192 219         378 pop @$pointer; # we will store the node in the parent instead
193 219         498 $parent_node->[5] = $node;
194 219         339 my $parent_type = $parent_node->[0];
195 219 100       2204 if (! $dirs->{$func}->[4]->{$parent_type}) {
196 3         16 $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref));
197             }
198             }
199              
200             ### restore the pointer up one level (because we hit the end of a block)
201 1279 100       3763 $pointer = (! @state) ? \@tree : $state[-1]->[4];
202              
203             ### normal end block
204 1279 100       2960 if ($func eq 'END') {
205 1063 100       5226 if ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front
    100          
    100          
206 433 100 66     2381 if (defined($parent_node->[3]) && @in_view) {
207 38         69 push @{ $in_view[-1] }, $parent_node;
  38         175  
208             } else {
209 395 100       3092 push @blocks, $parent_node
210             if length $parent_node->[3]; # macro blocks may not have a name
211             }
212 433 100 66     2355 if ($pointer->[-1] && ! $pointer->[-1]->[6]) {
213 380         1686 splice(@$pointer, -1, 1, ());
214             }
215             } elsif ($parent_node->[0] eq 'VIEW') {
216 56         86 my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }};
  38         255  
  56         143  
217 56         155 unshift @{ $parent_node->[3] }, $ref;
  56         235  
218             } elsif ($dirs->{$parent_node->[0]}->[5]) { # allow no_interp to turn on and off
219 21         65 $self->{'_no_interp'}--;
220             }
221              
222             ### continuation block - such as an elsif
223             } else {
224 216         316 push @state, $node;
225 216   50     1517 $pointer = $node->[4] ||= [];
226             }
227              
228             ### handle block directives
229             } elsif ($dirs->{$func}->[2] && ! $post_op) {
230 1081         1947 push @state, $node;
231 1081   50     5730 $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node
232 1081 100       2844 push @in_view, [] if $func eq 'VIEW';
233 1081 100       4137 $self->{'_no_interp'}++ if $dirs->{$node->[0]}->[5] # allow no_interp to turn on and off
234              
235             } elsif ($func eq 'TAGS') {
236 75         114 ($self->{'_start_tag'}, $self->{'_end_tag'}, my $old_end) = (@{ $node->[3] }[0,1], $self->{'_end_tag'});
  75         330  
237              
238             ### allow for one more closing tag of the old style
239 75 100       653 if ($$str_ref =~ m{ \G \s* $QR_COMMENTS ([+~=-]?) $old_end }gcxs) {
240 66         186 $Template::Alloy::Parse::QR_COMMENTS = "(?sm: \\s*+ \\# .*? (?: \$ | (?=$self->{'_end_tag'}) ) )*+ \\s*+" if posessive();
241 66         88 $QR_COMMENTS = $Template::Alloy::Parse::QR_COMMENTS;
242 66   33     317 $post_chomp = $1 || $self->{'POST_CHOMP'};
243 66 50       132 $post_chomp =~ y/-=~+/1230/ if $post_chomp;
244 66         83 $continue = 0;
245 66         78 $post_op = 0;
246 66         153 next;
247             }
248 9         32 $Template::Alloy::Parse::QR_COMMENTS = "(?sm: \\s*+ \\# .*? (?: \$ | (?=$self->{'_end_tag'}) ) )*+ \\s*+" if posessive();
249 9         25 $QR_COMMENTS = $Template::Alloy::Parse::QR_COMMENTS;
250              
251             } elsif ($func eq 'META') {
252 134         186 unshift @meta, @{ $node->[3] }; # first defined win
  134         392  
253 134         480 $node->[3] = undef; # only let these be defined once - at the front of the tree
254             }
255              
256             ### allow for bare variable getting and setting
257             } elsif (defined(my $var = $self->parse_expr($str_ref))) {
258 5094 100 100     22432 if ($post_op && $self->{'SEMICOLONS'}) {
259 15         95 $self->throw('parse', "Missing semi-colon with SEMICOLONS => 1", undef, $node->[1]);
260             }
261 5079         12043 push @$pointer, $node;
262 5079 100       60135 if ($$str_ref =~ m{ \G \s* $QR_COMMENTS ($QR_OP_ASSIGN) >? (?! [+=~-]? $self->{'_end_tag'}) \s* $QR_COMMENTS }gcx) {
263 804         1637 $node->[0] = 'SET';
264 804         1117 $node->[3] = eval { $dirs->{'SET'}->[0]->($self, $str_ref, $node, $1, $var) };
  804         3837  
265 804 50       6188 if (my $err = $@) {
266 0 0 0     0 $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
267 0         0 die $err;
268             }
269             } else {
270 4275 100       12262 if ($self->{'AUTO_FILTER'}) {
271 21 100       67 $var = [[undef, '~', $var], 0] if ! ref $var;
272 21 100 100     152 push @$var, '|', $self->{'AUTO_FILTER'}, 0 if @$var < 3 || $var->[-3] ne '|';
273             }
274 4275         11867 $node->[0] = 'GET';
275 4275         9260 $node->[3] = $var;
276             }
277 5079         12877 $node->[2] = pos $$str_ref;
278             }
279              
280             ### look for the closing tag
281 9608 100       105029 if ($$str_ref =~ m{ \G \s* $QR_COMMENTS (?: ; \s* $QR_COMMENTS)? ([+=~-]?) $self->{'_end_tag'} }gcxs) {
282 7757 100       17250 if ($one_tag_only) {
283 27 50       96 $self->throw('parse', "Invalid char \"$1\" found at end of block") if $1;
284 27 50       87 $self->throw('parse', "Missing END directive", $state[-1], pos($$str_ref)) if @state > 0;
285 27         346 return \@tree;
286             }
287              
288 7730   100     37716 $post_chomp = $1 || $self->{'POST_CHOMP'};
289 7730 100       18157 $post_chomp =~ y/-=~+/1230/ if $post_chomp;
290 7730         10464 $continue = 0;
291 7730         9451 $post_op = 0;
292 7730         16323 next;
293             }
294              
295             ### semi-colon = end of statement - we will need to continue parsing this tag
296 1851 100       8354 if ($$str_ref =~ m{ \G ; \s* $QR_COMMENTS }gcxo) {
    100          
297 1292         4866 $post_op = 0;
298              
299             ### we are flagged to start capturing the output of the next directive - set it up
300             } elsif ($node->[6]) {
301 136         210 $post_op = 0;
302 136         196 $capture = $node;
303              
304             ### allow next directive to be post-operative (or not)
305             } else {
306 423         591 $post_op = $node;
307             }
308              
309             ### no closing tag yet - no need to get an opening tag on next loop
310 1851 100       4418 $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref)) if $continue == pos $$str_ref;
311 1844         3615 $continue = pos $$str_ref;
312             }
313              
314             ### cleanup the tree
315 4201 100       11311 unshift(@tree, @blocks) if @blocks;
316 4201 100       12606 unshift(@tree, ['META', 1, 1, \@meta]) if @meta;
317 4201 100       10711 $self->throw('parse', "Missing END directive", $state[-1], pos($$str_ref)) if @state > 0;
318              
319             ### pull off the last text portion - if any
320 4186 100       11454 if (pos($$str_ref) != length($$str_ref)) {
321 1031         2359 my $text = substr $$str_ref, pos($$str_ref);
322 1031 100       2472 if (! $post_chomp) { }
    100          
    50          
    50          
323 29         131 elsif ($post_chomp == 1) { $text =~ s{ ^ [^\S\n]* \n }{}x }
324 0         0 elsif ($post_chomp == 2) { $text =~ s{ ^ \s+ }{ }x }
325 30         139 elsif ($post_chomp == 3) { $text =~ s{ ^ \s+ }{}x }
326 1031 100       3487 push @$pointer, $text if length $text;
327             }
328              
329 4186         80405 return \@tree;
330             }
331              
332             ###----------------------------------------------------------------###
333              
334             sub process {
335 3727     3727 0 160202 my ($self, $in, $swap, $out, @ARGS) = @_;
336 3727         7406 delete $self->{'error'};
337              
338 3727 100       10938 if ($self->{'DEBUG'}) { # "enable" some types of tt style debugging
339 24 50       292 $self->{'_debug_dirs'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/;
    100          
340 24 50       177 $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/;
    100          
341             }
342              
343 3727         5972 my $args;
344 3727 50 33     12598 $args = ($#ARGS == 0 && UNIVERSAL::isa($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS;
  1 100       5  
345              
346             ### get the content
347 3727         5739 my $content;
348 3727 100       9081 if (ref $in) {
349 3726 100       11420 if (ref($in) eq 'SCALAR') { # reference to a string
    100          
    100          
350 3722         6660 $content = $in;
351             } elsif (UNIVERSAL::isa($in, 'CODE')) {
352 1         4 $in = $in->();
353 1         6 $content = \$in;
354             } elsif (ref($in) eq 'HASH') { # pre-prepared document
355 1         2 $content = $in;
356             } else { # should be a file handle
357 2         10 local $/ = undef;
358 2         40 $in = <$in>;
359 2         6 $content = \$in;
360             }
361             } else {
362             ### should be a filename
363 1         3 $content = $in;
364             }
365              
366              
367             ### prepare block localization
368 3727   100     20355 my $blocks = $self->{'BLOCKS'} ||= {};
369              
370              
371             ### do the swap
372 3727         7363 my $output = '';
373 3727         10508 eval {
374              
375             ### localize the stash
376 3727   100     10672 $swap ||= {};
377 3727   100     18886 my $var1 = $self->{'_vars'} ||= {};
378 3727   100     36498 my $var2 = $self->{'STASH'} || $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {};
379 3727   100     20952 $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing
380 3727         16910 my $copy = {%$var2, %$var1, %$swap};
381              
382 3727         13718 local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore
383 3727         8044 local $self->{'_template'};
384              
385 3727         6670 delete $self->{'_debug_off'};
386 3727         5683 delete $self->{'_debug_format'};
387              
388             ### handle pre process items that go before every document
389 3727         10532 my $pre = '';
390 3727 100       10027 if ($self->{'PRE_PROCESS'}) {
391 36         173 _load_template_meta($self, $content);
392 36         60 foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) {
  36         167  
393 39         150 $self->_process($name, $copy, \$pre);
394             }
395             }
396              
397             ### process the central file now - catching errors to allow for the ERROR config
398 3724         6436 eval {
399 3724 100       8598 local $self->{'STREAM'} = undef if $self->{'WRAPPER'};
400              
401             ### handle the PROCESS config - which loads another template in place of the real one
402 3724 100       8834 if (exists $self->{'PROCESS'}) {
403 33         90 _load_template_meta($self, $content);
404 33         54 foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) {
  33         156  
405 39 50       133 next if ! length $name;
406 39         151 $self->_process($name, $copy, \$output);
407             }
408              
409             ### handle "normal" content
410             } else {
411 3691         11180 local $self->{'_start_top_level'} = 1;
412 3691         14951 $self->_process($content, $copy, \$output);
413             }
414             };
415              
416             ### catch errors with ERROR config
417 3724 100       12007 if (my $err = $@) {
418 201 50       898 $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type');
419 201 50       795 die $err if $err->type =~ /stop|return/;
420 201   100     2012 my $catch = $self->{'ERRORS'} || $self->{'ERROR'} || die $err;
421 45 100       187 $catch = {default => $catch} if ! ref $catch;
422 45         148 my $type = $err->type;
423 45         85 my $last_found;
424             my $file;
425 45         137 foreach my $name (keys %$catch) {
426 60 100 66     319 my $_name = (! defined $name || lc($name) eq 'default') ? '' : $name;
427 60 100 100     821 if ($type =~ / ^ \Q$_name\E \b /x
      66        
428             && (! defined($last_found) || length($last_found) < length($_name))) { # more specific wins
429 50         72 $last_found = $_name;
430 50         188 $file = $catch->{$name};
431             }
432             }
433              
434             ### found error handler - try it out
435 45 50       132 if (defined $file) {
436 45         72 $output = '';
437 45 50       217 local $copy->{'error'} = local $copy->{'e'} = $self->{'COMPILE_JS'} ? {type => $type, info => $err->info} : $err;
438 45 100       204 local $self->{'STREAM'} = undef if $self->{'WRAPPER'};
439 45         173 $self->_process($file, $copy, \$output);
440             }
441             }
442              
443             ### handle wrapper directives
444 3568 100       10712 if (exists $self->{'WRAPPER'}) {
445 39         141 _load_template_meta($self, $content);
446 39         58 foreach my $name (reverse @{ $self->split_paths($self->{'WRAPPER'}) }) {
  39         179  
447 42 50       161 next if ! length $name;
448 42         123 local $copy->{'content'} = $output;
449 42         69 my $out = '';
450 42         101 local $self->{'STREAM'} = undef;
451 42         168 $self->_process($name, $copy, \$out);
452 39         215 $output = $out;
453             }
454 36 100       156 if ($self->{'STREAM'}) {
455 12         100 print $output;
456 12         25 $output = 1;
457             }
458             }
459              
460 3565 100       8860 $output = $pre . $output if length $pre;
461              
462             ### handle post process items that go after every document
463 3565 100       22467 if ($self->{'POST_PROCESS'}) {
464 36         119 _load_template_meta($self, $content);
465 36         57 foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) {
  36         141  
466 39         165 $self->_process($name, $copy, \$output);
467             }
468             }
469              
470             };
471              
472             ### clear blocks as asked (AUTO_RESET) defaults to on
473 3727 50 33     24357 $self->{'BLOCKS'} = $blocks if exists($self->{'AUTO_RESET'}) && ! $self->{'AUTO_RESET'};
474              
475 3727 100       10139 if (my $err = $@) {
476 165 50       736 $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type');
477 165 50       545 if ($err->type !~ /stop|return|next|last|break/) {
478 165         446 $self->{'error'} = $err;
479 165 50       761 die $err if $self->{'RAISE_ERROR'};
480 165         666 return;
481             }
482             }
483              
484             ### send the content back out
485 3562   100     7944 $out ||= $self->{'OUTPUT'};
486 3562 100       8476 if (ref $out) {
    100          
487 3559 100       24574 if (UNIVERSAL::isa($out, 'CODE')) {
    100          
    100          
    100          
488 1         7 $out->($output);
489             } elsif (UNIVERSAL::can($out, 'print')) {
490 1         5 $out->print($output);
491             } elsif (UNIVERSAL::isa($out, 'SCALAR')) { # reference to a string
492 3554         6843 $$out = $output;
493             } elsif (UNIVERSAL::isa($out, 'ARRAY')) {
494 1         3 push @$out, $output;
495             } else { # should be a file handle
496 2         4 print {$out} $output;
  2         12  
497             }
498             } elsif ($out) { # should be a filename
499 2         3 my $file;
500 2 50       12 if ($out =~ m|^/|) {
    50          
501 0 0       0 if (! $self->{'ABSOLUTE'}) {
502 0         0 $self->throw($self->{'error'} = $self->exception('file', "ABSOLUTE paths disabled"));
503             } else {
504 0         0 $file = $out;
505             }
506             } elsif ($out =~ m|^\.\.?/|) {
507 0 0       0 if (! $self->{'RELATIVE'}) {
508 0         0 $self->throw($self->{'error'} = $self->exception('file', "RELATIVE paths disabled"));
509             } else {
510 0         0 $file = $out;
511             }
512             } else {
513 2         5 my $path = $self->{'OUTPUT_PATH'};
514 2 50       6 $path = '.' if ! defined $path;
515 2 50       34 if (! -d $path) {
516 0         0 require File::Path;
517 0         0 File::Path::mkpath($path);
518             }
519 2         5 $file = "$path/$out";
520             }
521 2 50       139 open(my $fh, '>', $file)
522             || $self->throw($self->{'error'} = $self->exception('file', "$out couldn't be opened for writing: $!"));
523 2 100       11 if (my $bm = $args->{'binmode'}) {
    50          
524 1 50       4 if (+$bm == 1) { binmode $fh }
  1         6  
525 0         0 else { binmode $fh, $bm }
526             } elsif ($self->{'ENCODING'}) {
527 0 0 0     0 if (eval { require Encode } && defined &Encode::encode) {
  0         0  
528 0         0 $output = Encode::encode($self->{'ENCODING'}, $output);
529             }
530             }
531 2         4 print {$fh} $output;
  2         18  
532             } else {
533 1         7 print $output;
534             }
535              
536 3562 100       10248 return if $self->{'error'};
537 3556         11898 return 1;
538             }
539              
540             sub _load_template_meta {
541 144     144   258 my $self = shift;
542 144 100       525 return if $self->{'_template'}; # only do once as need
543              
544 129         196 eval {
545             ### load the meta data for the top document
546             ### this is needed by some of the custom handlers such as PRE_PROCESS and POST_PROCESS
547 129         216 my $content = shift;
548 129 50 50     763 my $doc = $self->{'_template'} = ref($content) eq 'HASH' ? $content : $self->load_template($content) || {};
549 129 100 100     1044 my $meta = $doc->{'_perl'} ? $doc->{'_perl'}->{'meta'}
    100          
550             : ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META') ? $doc->{'_tree'}->[0]->[3]
551             : {};
552 129 100       441 $meta = {@$meta} if ref($meta) eq 'ARRAY';
553 129         236 $self->{'_template'} = $doc;
554 129         323 @{ $doc }{keys %$meta} = values %$meta;
  129         369  
555             };
556              
557 129         246 return;
558             }
559              
560             ###----------------------------------------------------------------###
561              
562             1;
563              
564             __END__