]> Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Template.pm
projects / chaz / p5-CGI-Ex / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
CGI::Ex 2.11
[chaz/p5-CGI-Ex] / lib / CGI / Ex / Template.pm
1 package CGI::Ex::Template;
2
3 #STAT_TTL
4 #memory leak in USE
5
6 ###----------------------------------------------------------------###
7 # See the perldoc in CGI/Ex/Template.pod
8 # Copyright 2007 - Paul Seamons #
9 # Distributed under the Perl Artistic License without warranty #
10 ###----------------------------------------------------------------###
11
12 use strict;
13 use constant trace => $ENV{'CET_TRACE'} || 0; # enable for low level tracing
14 use vars qw($VERSION
15 $TAGS
16 $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS $VOBJS
17 $DIRECTIVES $QR_DIRECTIVE
18
19 $OPERATORS
20 $OP_DISPATCH
21 $OP_ASSIGN
22 $OP
23 $OP_PREFIX
24 $OP_POSTFIX
25 $OP_TERNARY
26
27 $QR_OP
28 $QR_OP_PREFIX
29 $QR_OP_ASSIGN
30
31 $QR_COMMENTS
32 $QR_FILENAME
33 $QR_NUM
34 $QR_AQ_SPACE
35 $QR_PRIVATE
36
37 $PACKAGE_EXCEPTION $PACKAGE_ITERATOR $PACKAGE_CONTEXT $PACKAGE_STASH $PACKAGE_PERL_HANDLE
38 $MAX_EVAL_RECURSE $MAX_MACRO_RECURSE
39 $WHILE_MAX
40 $EXTRA_COMPILE_EXT
41 $DEBUG
42
43 @CONFIG_COMPILETIME
44 @CONFIG_RUNTIME
45 );
46
47 BEGIN {
48 $VERSION = '2.11';
49
50 $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
51 $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
52 $PACKAGE_CONTEXT = 'CGI::Ex::Template::_Context';
53 $PACKAGE_STASH = 'CGI::Ex::Template::_Stash';
54 $PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle';
55 $MAX_EVAL_RECURSE = 50;
56 $MAX_MACRO_RECURSE = 50;
57
58 $TAGS = {
59 asp => ['<%', '%>' ], # ASP
60 default => ['\[%', '%\]' ], # default
61 html => ['<!--', '-->' ], # HTML comments
62 mason => ['<%', '>' ], # HTML::Mason
63 metatext => ['%%', '%%' ], # Text::MetaText
64 php => ['<\?', '\?>' ], # PHP
65 star => ['\[\*', '\*\]' ], # TT alternate
66 template => ['\[%', '%\]' ], # Normal Template Toolkit
67 template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style
68 tt2 => ['\[%', '%\]' ], # TT2
69 };
70
71 $SCALAR_OPS = {
72 '0' => sub { $_[0] },
73 chunk => \&vmethod_chunk,
74 collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
75 defined => sub { defined $_[0] ? 1 : '' },
76 indent => \&vmethod_indent,
77 int => sub { local $^W; int $_[0] },
78 fmt => \&vmethod_fmt_scalar,
79 'format' => \&vmethod_format,
80 hash => sub { {value => $_[0]} },
81 html => sub { local $_ = $_[0]; s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; s/\"/&quot;/g; s/\'/&apos;/g; $_ },
82 item => sub { $_[0] },
83 lcfirst => sub { lcfirst $_[0] },
84 length => sub { defined($_[0]) ? length($_[0]) : 0 },
85 list => sub { [$_[0]] },
86 lower => sub { lc $_[0] },
87 match => \&vmethod_match,
88 new => sub { defined $_[0] ? $_[0] : '' },
89 null => sub { '' },
90 rand => sub { local $^W; rand shift },
91 remove => sub { vmethod_replace(shift, shift, '', 1) },
92 repeat => \&vmethod_repeat,
93 replace => \&vmethod_replace,
94 search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ },
95 size => sub { 1 },
96 split => \&vmethod_split,
97 stderr => sub { print STDERR $_[0]; '' },
98 substr => \&vmethod_substr,
99 trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
100 ucfirst => sub { ucfirst $_[0] },
101 upper => sub { uc $_[0] },
102 uri => \&vmethod_uri,
103 url => \&vmethod_url,
104 };
105
106 $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops
107 eval => [\&filter_eval, 1],
108 evaltt => [\&filter_eval, 1],
109 file => [\&filter_redirect, 1],
110 redirect => [\&filter_redirect, 1],
111 };
112
113 $LIST_OPS = {
114 defined => sub { return 1 if @_ == 1; defined $_[0]->[ defined($_[1]) ? $_[1] : 0 ] },
115 first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
116 fmt => \&vmethod_fmt_list,
117 grep => sub { local $^W; my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
118 hash => sub { local $^W; my $list = shift; return {@$list} if ! @_; my $i = shift || 0; return {map {$i++ => $_} @$list} },
119 import => sub { my $ref = shift; push @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_; '' },
120 item => sub { $_[0]->[ $_[1] || 0 ] },
121 join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
122 last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]},
123 list => sub { $_[0] },
124 max => sub { local $^W; $#{ $_[0] } },
125 merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
126 new => sub { local $^W; return [@_] },
127 null => sub { '' },
128 nsort => \&vmethod_nsort,
129 pick => \&vmethod_pick,
130 pop => sub { pop @{ $_[0] } },
131 push => sub { my $ref = shift; push @$ref, @_; return '' },
132 reverse => sub { [ reverse @{ $_[0] } ] },
133 shift => sub { shift @{ $_[0] } },
134 size => sub { local $^W; scalar @{ $_[0] } },
135 slice => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
136 sort => \&vmethod_sort,
137 splice => \&vmethod_splice,
138 unique => sub { my %u; return [ grep { ! $u{$_}++ } @{ $_[0] } ] },
139 unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
140 };
141
142 $HASH_OPS = {
143 defined => sub { return 1 if @_ == 1; defined $_[0]->{ defined($_[1]) ? $_[1] : '' } },
144 delete => sub { my $h = shift; delete @{ $h }{map {defined($_) ? $_ : ''} @_}; '' },
145 each => sub { [%{ $_[0] }] },
146 exists => sub { exists $_[0]->{ defined($_[1]) ? $_[1] : '' } },
147 fmt => \&vmethod_fmt_hash,
148 hash => sub { $_[0] },
149 import => sub { my ($a, $b) = @_; @{$a}{keys %$b} = values %$b if ref($b) eq 'HASH'; '' },
150 item => sub { my ($h, $k) = @_; $k = '' if ! defined $k; $k =~ $QR_PRIVATE ? undef : $h->{$k} },
151 items => sub { [ %{ $_[0] } ] },
152 keys => sub { [keys %{ $_[0] }] },
153 list => \&vmethod_list_hash,
154 new => sub { local $^W; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} },
155 null => sub { '' },
156 nsort => sub { my $ref = shift; [sort { $ref->{$a} <=> $ref->{$b}} keys %$ref] },
157 pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } sort keys %{ $_[0] } ] },
158 size => sub { scalar keys %{ $_[0] } },
159 sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] },
160 values => sub { [values %{ $_[0] }] },
161 };
162
163 $VOBJS = {
164 Text => $SCALAR_OPS,
165 List => $LIST_OPS,
166 Hash => $HASH_OPS,
167 };
168 foreach (values %$VOBJS) {
169 $_->{'Text'} = $_->{'as'};
170 $_->{'Hash'} = $_->{'hash'};
171 $_->{'List'} = $_->{'list'};
172 }
173
174 $DIRECTIVES = {
175 #name parse_sub play_sub block postdir continue move_to_front
176 BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1, 0, 0, 1],
177 BREAK => [sub {}, \&play_control],
178 CALL => [\&parse_CALL, \&play_CALL],
179 CASE => [\&parse_CASE, undef, 0, 0, {SWITCH => 1, CASE => 1}],
180 CATCH => [\&parse_CATCH, undef, 0, 0, {TRY => 1, CATCH => 1}],
181 CLEAR => [sub {}, \&play_CLEAR],
182 '#' => [sub {}, sub {}],
183 CONFIG => [\&parse_CONFIG, \&play_CONFIG],
184 DEBUG => [\&parse_DEBUG, \&play_DEBUG],
185 DEFAULT => [\&parse_DEFAULT, \&play_DEFAULT],
186 DUMP => [\&parse_DUMP, \&play_DUMP],
187 ELSE => [sub {}, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}],
188 ELSIF => [\&parse_IF, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}],
189 END => [undef, sub {}],
190 FILTER => [\&parse_FILTER, \&play_FILTER, 1, 1],
191 '|' => [\&parse_FILTER, \&play_FILTER, 1, 1],
192 FINAL => [sub {}, undef, 0, 0, {TRY => 1, CATCH => 1}],
193 FOR => [\&parse_FOREACH, \&play_FOREACH, 1, 1],
194 FOREACH => [\&parse_FOREACH, \&play_FOREACH, 1, 1],
195 GET => [\&parse_GET, \&play_GET],
196 IF => [\&parse_IF, \&play_IF, 1, 1],
197 INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE],
198 INSERT => [\&parse_INSERT, \&play_INSERT],
199 LAST => [sub {}, \&play_control],
200 MACRO => [\&parse_MACRO, \&play_MACRO],
201 META => [undef, \&play_META],
202 NEXT => [sub {}, \&play_control],
203 PERL => [\&parse_PERL, \&play_PERL, 1],
204 PROCESS => [\&parse_PROCESS, \&play_PROCESS],
205 RAWPERL => [\&parse_PERL, \&play_RAWPERL, 1],
206 RETURN => [sub {}, \&play_control],
207 SET => [\&parse_SET, \&play_SET],
208 STOP => [sub {}, \&play_control],
209 SWITCH => [\&parse_SWITCH, \&play_SWITCH, 1],
210 TAGS => [undef, sub {}],
211 THROW => [\&parse_THROW, \&play_THROW],
212 TRY => [sub {}, \&play_TRY, 1],
213 UNLESS => [\&parse_UNLESS, \&play_UNLESS, 1, 1],
214 USE => [\&parse_USE, \&play_USE],
215 VIEW => [\&parse_VIEW, \&play_VIEW, 1],
216 WHILE => [\&parse_WHILE, \&play_WHILE, 1, 1],
217 WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER, 1, 1],
218 #name #parse_sub #play_sub #block #postdir #continue #move_to_front
219 };
220
221 ### setup the operator parsing
222 $OPERATORS = [
223 # type precedence symbols action (undef means play_operator will handle)
224 ['prefix', 99, ['\\'], undef ],
225 ['postfix', 98, ['++'], undef ],
226 ['postfix', 98, ['--'], undef ],
227 ['prefix', 97, ['++'], undef ],
228 ['prefix', 97, ['--'], undef ],
229 ['right', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ],
230 ['prefix', 93, ['!'], sub { ! $_[0] } ],
231 ['prefix', 93, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
232 ['left', 90, ['*'], sub { $_[0] * $_[1] } ],
233 ['left', 90, ['/'], sub { $_[0] / $_[1] } ],
234 ['left', 90, ['div', 'DIV'], sub { int($_[0] / $_[1]) } ],
235 ['left', 90, ['%', 'mod', 'MOD'], sub { $_[0] % $_[1] } ],
236 ['left', 85, ['+'], sub { $_[0] + $_[1] } ],
237 ['left', 85, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
238 ['left', 85, ['~', '_'], undef ],
239 ['none', 80, ['<'], sub { $_[0] < $_[1] } ],
240 ['none', 80, ['>'], sub { $_[0] > $_[1] } ],
241 ['none', 80, ['<='], sub { $_[0] <= $_[1] } ],
242 ['none', 80, ['>='], sub { $_[0] >= $_[1] } ],
243 ['none', 80, ['lt'], sub { $_[0] lt $_[1] } ],
244 ['none', 80, ['gt'], sub { $_[0] gt $_[1] } ],
245 ['none', 80, ['le'], sub { $_[0] le $_[1] } ],
246 ['none', 80, ['ge'], sub { $_[0] ge $_[1] } ],
247 ['none', 75, ['==', 'eq'], sub { $_[0] eq $_[1] } ],
248 ['none', 75, ['!=', 'ne'], sub { $_[0] ne $_[1] } ],
249 ['left', 70, ['&&'], undef ],
250 ['right', 65, ['||'], undef ],
251 ['none', 60, ['..'], sub { $_[0] .. $_[1] } ],
252 ['ternary', 55, ['?', ':'], undef ],
253 ['assign', 53, ['+='], sub { $_[0] + $_[1] } ],
254 ['assign', 53, ['-='], sub { $_[0] - $_[1] } ],
255 ['assign', 53, ['*='], sub { $_[0] * $_[1] } ],
256 ['assign', 53, ['/='], sub { $_[0] / $_[1] } ],
257 ['assign', 53, ['%='], sub { $_[0] % $_[1] } ],
258 ['assign', 53, ['**='], sub { $_[0] ** $_[1] } ],
259 ['assign', 53, ['~=', '_='], sub { $_[0] . $_[1] } ],
260 ['assign', 52, ['='], undef ],
261 ['prefix', 50, ['not', 'NOT'], sub { ! $_[0] } ],
262 ['left', 45, ['and', 'AND'], undef ],
263 ['right', 40, ['or', 'OR'], undef ],
264 # ['', 0, ['{}'], undef ],
265 # ['', 0, ['[]'], undef ],
266 # ['', 0, ['qr'], undef ],
267 ];
268 $OP = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] ne 'prefix' } @$OPERATORS}; # all non-prefix
269 $OP_PREFIX = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] eq 'prefix' } @$OPERATORS};
270 $OP_DISPATCH = {map {my $ref = $_; map {$_ => $ref->[3]} @{$ref->[2]}} grep {$_->[3] } @$OPERATORS};
271 $OP_ASSIGN = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'assign' } @$OPERATORS};
272 $OP_POSTFIX = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'postfix'} @$OPERATORS}; # bool is postfix
273 $OP_TERNARY = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'ternary'} @$OPERATORS}; # bool is ternary
274 sub _op_qr { # no mixed \w\W operators
275 my %used;
276 my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {! /\{\}|\[\]/} grep {/^\W{2,}$/} @_;
277 my $chr = join '', sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_;
278 my $word = join '|', reverse sort grep {++$used{$_} < 2} grep {/^\w+$/} @_;
279 $chr = "[$chr]" if $chr;
280 $word = "\\b(?:$word)\\b" if $word;
281 return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex";
282 }
283 sub _build_op_qr { _op_qr(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS) }
284 sub _build_op_qr_prefix { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS) }
285 sub _build_op_qr_assign { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS) }
286 $QR_OP = _build_op_qr();
287 $QR_OP_PREFIX = _build_op_qr_prefix();
288 $QR_OP_ASSIGN = _build_op_qr_assign();
289
290 $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )';
291 $QR_COMMENTS = '(?-s: \# .* \s*)*';
292 $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\.][\w\-\.]* (?:/[\w\-\.]+)*';
293 $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?';
294 $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=;) )';
295 $QR_PRIVATE = qr/^[_.]/;
296
297 $WHILE_MAX = 1000;
298 $EXTRA_COMPILE_EXT = '.sto2';
299
300 @CONFIG_COMPILETIME = qw(ANYCASE INTERPOLATE PRE_CHOMP POST_CHOMP V1DOLLAR V2PIPE);
301 @CONFIG_RUNTIME = qw(DUMP);
302
303 eval {require Scalar::Util};
304 };
305
306 ###----------------------------------------------------------------###
307
308 sub new {
309 my $class = shift;
310 my $args = ref($_[0]) ? { %{ shift() } } : {@_};
311
312 ### allow for lowercase args
313 if (my @keys = grep {/^[a-z][a-z_]+$/} keys %$args) {
314 @{ $args }{ map { uc $_ } @keys } = delete @{ $args }{ @keys };
315 }
316
317 my $self = bless $args, $class;
318
319 ### "enable" debugging - we only support DEBUG_DIRS and DEBUG_UNDEF
320 if ($self->{'DEBUG'}) {
321 $self->{'_debug_dirs'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/;
322 $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/;
323 }
324
325 return $self;
326 }
327
328 ###----------------------------------------------------------------###
329
330 sub _process {
331 my $self = shift;
332 my $file = shift;
333 local $self->{'_vars'} = shift || {};
334 my $out_ref = shift || $self->throw('undef', "Missing output ref");
335 local $self->{'_top_level'} = delete $self->{'_start_top_level'};
336 my $i = length $$out_ref;
337
338 ### parse and execute
339 my $doc;
340 eval {
341 ### handed us a precompiled document
342 if (ref($file) eq 'HASH' && $file->{'_tree'}) {
343 $doc = $file;
344
345 ### load the document
346 } else {
347 $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");;
348 }
349
350 ### prevent recursion
351 $self->throw('file', "recursion into '$doc->{name}'")
352 if ! $self->{'RECURSION'} && $self->{'_in'}->{$doc->{'name'}} && $doc->{'name'} ne 'input text';
353 local $self->{'_in'}->{$doc->{'name'}} = 1;
354
355 ### execute the document
356 if (! @{ $doc->{'_tree'} }) { # no tags found - just return the content
357 $$out_ref = ${ $doc->{'_content'} };
358 } else {
359 local $self->{'_component'} = $doc;
360 local $self->{'_template'} = $self->{'_top_level'} ? $doc : $self->{'_template'};
361 local @{ $self }{@CONFIG_RUNTIME} = @{ $self }{@CONFIG_RUNTIME};
362 $self->execute_tree($doc->{'_tree'}, $out_ref);
363 }
364
365 ### trim whitespace from the beginning and the end of a block or template
366 if ($self->{'TRIM'}) {
367 substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ \s+ $ }{}x; # tail first
368 substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ ^ \s+ }{}x;
369 }
370 };
371
372 ### handle exceptions
373 if (my $err = $@) {
374 $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
375 $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
376 die $err if ! $self->{'_top_level'} || $err->type !~ /stop|return/;
377 }
378
379 return 1;
380 }
381
382 ###----------------------------------------------------------------###
383
384 sub load_parsed_tree {
385 my $self = shift;
386 my $file = shift;
387 return if ! defined $file;
388
389 my $doc = {name => $file};
390
391 ### looks like a string reference
392 if (ref $file) {
393 $doc->{'_content'} = $file;
394 $doc->{'name'} = 'input text';
395 $doc->{'_is_str_ref'} = 1;
396
397 ### looks like a previously cached-in-memory document
398 } elsif ($self->{'_documents'}->{$file}
399 && ( ($self->{'_documents'}->{$file}->{'_cache_time'} == time) # don't stat more than once a second
400 || ($self->{'_documents'}->{$file}->{'modtime'}
401 == (stat $self->{'_documents'}->{$file}->{'_filename'})[9]))) {
402 $doc = $self->{'_documents'}->{$file};
403 $doc->{'_cache_time'} = time;
404 return $doc;
405
406 ### looks like a block name of some sort
407 } elsif ($self->{'BLOCKS'}->{$file}) {
408 my $block = $self->{'BLOCKS'}->{$file};
409
410 ### allow for predefined blocks that are a code or a string
411 if (UNIVERSAL::isa($block, 'CODE')) {
412 $block = $block->();
413 }
414 if (! UNIVERSAL::isa($block, 'HASH')) {
415 $self->throw('block', "Unsupported BLOCK type \"$block\"") if ref $block;
416 my $copy = $block;
417 $block = eval { $self->load_parsed_tree(\$copy) }
418 || $self->throw('block', 'Parse error on predefined block');
419 }
420 $doc->{'_tree'} = $block->{'_tree'} || $self->throw('block', "Invalid block definition (missing tree)");
421 return $doc;
422
423
424 ### go and look on the file system
425 } else {
426 $doc->{'_filename'} = eval { $self->include_filename($file) };
427 if (my $err = $@) {
428 ### allow for blocks in other files
429 if ($self->{'EXPOSE_BLOCKS'}
430 && ! $self->{'_looking_in_block_file'}) {
431 local $self->{'_looking_in_block_file'} = 1;
432 my $block_name = '';
433 while ($file =~ s|/([^/.]+)$||) {
434 $block_name = length($block_name) ? "$1/$block_name" : $1;
435 my $ref = eval { $self->load_parsed_tree($file) } || next;
436 my $_tree = $ref->{'_tree'};
437 foreach my $node (@$_tree) {
438 next if ! ref $node;
439 next if $node->[0] eq 'META';
440 last if $node->[0] ne 'BLOCK';
441 next if $block_name ne $node->[3];
442 $doc->{'_content'} = $ref->{'_content'};
443 $doc->{'_tree'} = $node->[4];
444 $doc->{'modtime'} = $ref->{'modtime'};
445 $file = $ref->{'name'};
446 last;
447 }
448 }
449 die $err if ! $doc->{'_tree'};
450 } elsif ($self->{'DEFAULT'}) {
451 $doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) } || die $err;
452 } else {
453 die $err;
454 }
455 }
456
457 ### no tree yet - look for a file cache
458 if (! $doc->{'_tree'}) {
459 $doc->{'modtime'} = (stat $doc->{'_filename'})[9];
460 if ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) {
461 if ($self->{'COMPILE_DIR'}) {
462 $doc->{'_compile_filename'} = $self->{'COMPILE_DIR'} .'/'. $file;
463 } else {
464 $doc->{'_compile_filename'} = $doc->{'_filename'};
465 }
466 $doc->{'_compile_filename'} .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'});
467 $doc->{'_compile_filename'} .= $EXTRA_COMPILE_EXT if defined $EXTRA_COMPILE_EXT;
468
469 if (-e $doc->{'_compile_filename'} && (stat _)[9] == $doc->{'modtime'}) {
470 require Storable;
471 $doc->{'_tree'} = Storable::retrieve($doc->{'_compile_filename'});
472 $doc->{'compile_was_used'} = 1;
473 } else {
474 my $str = $self->slurp($doc->{'_filename'});
475 $doc->{'_content'} = \$str;
476 }
477 } else {
478 my $str = $self->slurp($doc->{'_filename'});
479 $doc->{'_content'} = \$str;
480 }
481 }
482
483 }
484
485 ### haven't found a parsed tree yet - parse the content into a tree
486 if (! $doc->{'_tree'}) {
487 if ($self->{'CONSTANTS'}) {
488 my $key = $self->{'CONSTANT_NAMESPACE'} || 'constants';
489 $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'};
490 }
491
492 local $self->{'_component'} = $doc;
493 $doc->{'_tree'} = eval { $self->parse_tree($doc->{'_content'}) }
494 || do { my $e = $@; $e->doc($doc) if UNIVERSAL::can($e, 'doc') && ! $e->doc; die $e }; # errors die
495 }
496
497 ### cache parsed_tree in memory unless asked not to do so
498 if (! $doc->{'_is_str_ref'} && (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'})) {
499 $self->{'_documents'}->{$file} ||= $doc;
500 $doc->{'_cache_time'} = time;
501
502 ### allow for config option to keep the cache size down
503 if ($self->{'CACHE_SIZE'}) {
504 my $all = $self->{'_documents'};
505 if (scalar(keys %$all) > $self->{'CACHE_SIZE'}) {
506 my $n = 0;
507 foreach my $file (sort {$all->{$b}->{'_cache_time'} <=> $all->{$a}->{'_cache_time'}} keys %$all) {
508 delete($all->{$file}) if ++$n > $self->{'CACHE_SIZE'};
509 }
510 }
511 }
512 }
513
514 ### save a cache on the fileside as asked
515 if ($doc->{'_compile_filename'} && ! $doc->{'compile_was_used'}) {
516 my $dir = $doc->{'_compile_filename'};
517 $dir =~ s|/[^/]+$||;
518 if (! -d $dir) {
519 require File::Path;
520 File::Path::mkpath($dir);
521 }
522 require Storable;
523 Storable::store($doc->{'_tree'}, $doc->{'_compile_filename'});
524 utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_compile_filename'};
525 }
526
527 return $doc;
528 }
529
530 ###----------------------------------------------------------------###
531
532 sub parse_tree {
533 my $self = shift;
534 my $str_ref = shift;
535 if (! $str_ref || ! defined $$str_ref) {
536 $self->throw('parse.no_string', "No string or undefined during parse");
537 }
538
539 my $STYLE = $self->{'TAG_STYLE'} || 'default';
540 my $START = $self->{'START_TAG'} || $TAGS->{$STYLE}->[0];
541 my $END = $self->{'END_TAG'} || $TAGS->{$STYLE}->[1];
542 local $self->{'_end_tag'} = $END;
543
544 local @{ $self }{@CONFIG_COMPILETIME} = @{ $self }{@CONFIG_COMPILETIME};
545
546 my @tree; # the parsed tree
547 my $pointer = \@tree; # pointer to current tree to handle nested blocks
548 my @state; # maintain block levels
549 local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS)
550 local $self->{'_in_perl'}; # no interpolation in perl
551 my @in_view; # let us know if we are in a view
552 my @move_to_front; # items that need to be declared first (usually BLOCKS)
553 my @meta; # place to store any found meta information (to go into META)
554 my $post_chomp = 0; # previous post_chomp setting
555 my $continue = 0; # flag for multiple directives in the same tag
556 my $post_op; # found a post-operative DIRECTIVE
557 my $capture; # flag to start capture
558 my $func;
559 my $node;
560 my $mark;
561 local pos $$str_ref = 0;
562
563 while (1) {
564 ### continue looking for information in a semi-colon delimited tag
565 if ($continue) {
566 $node = [undef, pos($$str_ref), undef];
567
568 ### look through the string using index
569 } else {
570 $$str_ref =~ m{ \G (.*?) $START }gcxs
571 || last;
572
573 ### found a text portion - chomp it, interpolate it and store it
574 if (length $1) {
575 my $text = $1;
576
577 if ($text =~ m{ ($END) }xs) {
578 my $char = pos($$str_ref) + $-[1] + 1;
579 $self->throw('parse', "Found unmatched closing tag \"$1\"", undef, $char);
580 }
581
582 my $_last = pos $$str_ref;
583 if ($post_chomp) {
584 if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
585 elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
586 elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x }
587 }
588 if (length $text) {
589 push @$pointer, $text;
590 $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
591 }
592 }
593
594 $node = [undef, pos($$str_ref), undef];
595
596 ### take care of whitespace and comments flags
597 my $pre_chomp = $$str_ref =~ m{ \G ([+=~-]) }gcx ? $1 : $self->{'PRE_CHOMP'};
598 $pre_chomp =~ y/-=~+/1230/ if $pre_chomp;
599 if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) {
600 if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x }
601 elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x }
602 elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x }
603 splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length
604 }
605 if ($$str_ref =~ m{ \G \# }gcx) { # leading # means to comment the entire section
606 $$str_ref =~ m{ \G (.*?) ([+~=-]?) ($END) }gcxs # brute force - can't comment tags with nested %]
607 || $self->throw('parse', "Missing closing tag", undef, pos($$str_ref));
608 $node->[0] = '#';
609 $node->[2] = pos($$str_ref) - length($3);
610 push @$pointer, $node;
611
612 $post_chomp = $2;
613 $post_chomp ||= $self->{'POST_CHOMP'};
614 $post_chomp =~ y/-=~+/1230/ if $post_chomp;
615 next;
616 }
617 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
618 }
619
620 ### look for DIRECTIVES
621 if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcxo # find a word
622 && ($func = $self->{'ANYCASE'} ? uc($1) : $1)
623 && ($DIRECTIVES->{$func}
624 || ((pos($$str_ref) -= length $1) && 0))
625 ) { # is it a directive
626 $node->[0] = $func;
627 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcx;
628
629 ### store out this current node level
630 if ($post_op) { # on a post operator - replace the original node with the new one - store the old in the new
631 my @post_op = @$post_op;
632 @$post_op = @$node;
633 $node = $post_op;
634 $node->[4] = [\@post_op];
635 } elsif ($capture) {
636 # do nothing - it will be handled further down
637 } else{
638 push @$pointer, $node;
639 }
640
641 ### anything that behaves as a block ending
642 if ($func eq 'END' || $DIRECTIVES->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc)
643 if (! @state) {
644 $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref));
645 }
646 my $parent_node = pop @state;
647
648 if ($func ne 'END') {
649 pop @$pointer; # we will store the node in the parent instead
650 $parent_node->[5] = $node;
651 my $parent_type = $parent_node->[0];
652 if (! $DIRECTIVES->{$func}->[4]->{$parent_type}) {
653 $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref));
654 }
655 }
656
657 ### restore the pointer up one level (because we hit the end of a block)
658 $pointer = (! @state) ? \@tree : $state[-1]->[4];
659
660 ### normal end block
661 if ($func eq 'END') {
662 if ($DIRECTIVES->{$parent_node->[0]}->[5]) { # move things like BLOCKS to front
663 if ($parent_node->[0] eq 'BLOCK'
664 && defined($parent_node->[3])
665 && @in_view) {
666 push @{ $in_view[-1] }, $parent_node;
667 } else {
668 push @move_to_front, $parent_node;
669 }
670 if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var
671 splice(@$pointer, -1, 1, ());
672 }
673 } elsif ($parent_node->[0] =~ /PERL$/) {
674 delete $self->{'_in_perl'};
675 } elsif ($parent_node->[0] eq 'VIEW') {
676 my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }};
677 unshift @{ $parent_node->[3] }, $ref;
678 }
679
680 ### continuation block - such as an elsif
681 } else {
682 $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) };
683 if (my $err = $@) {
684 $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
685 die $err;
686 }
687 push @state, $node;
688 $pointer = $node->[4] ||= [];
689 }
690
691 } elsif ($func eq 'TAGS') {
692 my $end;
693 if ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxs) {
694 my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref));
695 ($START, $END) = @$ref;
696
697 } else {
698 local $self->{'_operator_precedence'} = 1; # prevent operator matching
699 $START = $$str_ref =~ m{ \G (?= [\'\"\/]) }gcx
700 ? $self->parse_expr($str_ref)
701 : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s+ $QR_COMMENTS"})
702 || $self->throw('parse', "Invalid opening tag in TAGS", undef, pos($$str_ref));
703 $END = $$str_ref =~ m{ \G (?= [\'\"\/]) }gcx
704 ? $self->parse_expr($str_ref)
705 : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s* $QR_COMMENTS"})
706 || $self->throw('parse', "Invalid closing tag in TAGS", undef, pos($$str_ref));
707 for my $tag ($START, $END) {
708 $tag = $self->play_expr($tag);
709 $tag = quotemeta($tag) if ! ref $tag;
710 }
711 }
712
713 $node->[2] = pos $$str_ref;
714
715 ### allow for one more closing tag of the old style
716 if ($$str_ref =~ m{ \G ([+~=-]?) $self->{'_end_tag'} }gcxs) {
717 $post_chomp = $1 || $self->{'POST_CHOMP'};
718 $post_chomp =~ y/-=~+/1230/ if $post_chomp;
719 $continue = 0;
720 $post_op = undef;
721 $self->{'_end_tag'} = $END; # need to keep track so parse_expr knows when to stop
722 next;
723 }
724
725 $self->{'_end_tag'} = $END;
726
727 } elsif ($func eq 'META') {
728 my $args = $self->parse_args($str_ref, {named_at_front => 1});
729 my $hash;
730 if (($hash = $self->play_expr($args->[0]))
731 && UNIVERSAL::isa($hash, 'HASH')) {
732 unshift @meta, %$hash; # first defined win
733 }
734
735 ### all other "normal" tags
736 } else {
737 $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) };
738 if (my $err = $@) {
739 $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
740 die $err;
741 }
742 if ($DIRECTIVES->{$func}->[2] && ! $post_op) { # this looks like a block directive
743 push @state, $node;
744 $pointer = $node->[4] ||= [];
745 }
746 push @in_view, [] if $func eq 'VIEW';
747 }
748
749 ### allow for bare variable getting and setting
750 } elsif (defined(my $var = $self->parse_expr($str_ref))) {
751 push @$pointer, $node;
752 if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? (?! [+=~-]? $END) \s* $QR_COMMENTS }gcx) {
753 $node->[0] = 'SET';
754 $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, $str_ref, $node, $1, $var) };
755 if (my $err = $@) {
756 $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
757 die $err;
758 }
759 } else {
760 $node->[0] = 'GET';
761 $node->[3] = $var;
762 }
763
764 ### handle empty tags [% %]
765 } elsif ($$str_ref =~ m{ \G (?: ; \s* $QR_COMMENTS)? ([+=~-]?) ($END) }gcxs) {
766 my $end = $2;
767 $post_chomp = $1 || $self->{'POST_CHOMP'};
768 $post_chomp =~ y/-=~+/1230/ if $post_chomp;
769 $node->[2] = pos($$str_ref) - length($end);
770 $continue = 0;
771 $post_op = undef;
772 next;
773
774 } else { # error
775 $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref));
776 }
777
778 ### we now have the directive to capture for an item like "SET foo = BLOCK" - store it
779 if ($capture) {
780 my $parent_node = $capture;
781 push @{ $parent_node->[4] }, $node;
782 undef $capture;
783 }
784
785 ### look for the closing tag again
786 if ($$str_ref =~ m{ \G (?: ; \s* $QR_COMMENTS)? ([+=~-]?) ($END) }gcxs) {
787 my $end = $2;
788 $post_chomp = $1 || $self->{'POST_CHOMP'};
789 $post_chomp =~ y/-=~+/1230/ if $post_chomp;
790
791 $node->[2] = pos($$str_ref) - length($end);
792 $continue = 0;
793 $post_op = undef;
794 next;
795 }
796
797 ### we always continue - and always record our position now
798 $continue = 1;
799 $node->[2] = pos $$str_ref;
800
801 ### we are flagged to start capturing the output of the next directive - set it up
802 if ($node->[6]) {
803 $post_op = undef;
804 $capture = $node;
805
806 ### semi-colon = end of statement - we will need to continue parsing this tag
807 } elsif ($$str_ref =~ m{ \G ; \s* $QR_COMMENTS }gcxo) {
808 $post_op = undef;
809
810 } else {
811 ### looking at a post operator ([% u FOREACH u IN [1..3] %])
812 $mark = pos $$str_ref;
813 if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcxo # find a word without advancing position
814 && ($func = $self->{'ANYCASE'} ? uc($1) : $1)
815 && (($DIRECTIVES->{$func} # and its a directive
816 && $DIRECTIVES->{$func}->[3]) # that can be post operative
817 || ((pos($$str_ref) = $mark) && 0)) # otherwise rollback
818 ) {
819 $post_op = $node; # store flag so next loop puts items in this node
820 pos($$str_ref) = $mark;
821
822 } else {
823 $post_op = undef;
824 }
825 }
826 }
827
828 if (@move_to_front) {
829 unshift @tree, @move_to_front;
830 }
831 if (@meta) {
832 unshift @tree, ['META', 0, 0, {@meta}];
833 }
834
835 if ($#state > -1) {
836 $self->throw('parse.missing.end', "Missing END", $state[-1], 0);
837 }
838
839 ### pull off the last text portion - if any
840 if (pos($$str_ref) != length($$str_ref)) {
841 my $text = substr $$str_ref, pos($$str_ref);
842
843 if ($text =~ m{ ($END) }xs) {
844 my $char = pos($$str_ref) + $-[1] + 1;
845 $self->throw('parse', "Found unmatched closing tag \"$1\"", undef, $char);
846 }
847
848 my $_last = pos($$str_ref);
849 if ($post_chomp) {
850 if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
851 elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
852 elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x }
853 }
854 if (length $text) {
855 push @$pointer, $text;
856 $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
857 }
858 }
859
860 return \@tree;
861 }
862
863 sub parse_expr {
864 my $self = shift;
865 my $str_ref = shift;
866 my $ARGS = shift || {};
867 my $is_aq = $ARGS->{'auto_quote'} ? 1 : 0;
868 my $mark = pos $$str_ref;
869
870 ### allow for custom auto_quoting (such as hash constructors)
871 if ($is_aq) {
872 if ($$str_ref =~ m{ \G $ARGS->{'auto_quote'} }gcx) {
873 return $1;
874
875 ### allow for auto-quoted $foo
876 } elsif ($$str_ref =~ m{ \G \$ (\w+\b (?:\.\w+\b)*) \s* $QR_COMMENTS }gcxo) {
877 my $name = $1;
878 if ($$str_ref !~ m{ \G \( }gcx || $name =~ /^(?:qw|m|\d)/) {
879 return $self->parse_expr(\$name);
880 }
881 ### this is a little cryptic/odd - but TT allows items in
882 ### autoquote position to only be prefixed by a $ - gross
883 ### so we will defer to the regular parsing - but after the $
884 pos($$str_ref) = $mark + 1;
885 $is_aq = undef; # but don't allow operators - false flag handed down
886
887 ### allow for ${foo.bar} type constructs
888 } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) {
889 my $var = $self->parse_expr($str_ref);
890 $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo
891 || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
892 return $var;
893 }
894 }
895
896
897 ### test for leading prefix operators
898 my $has_prefix;
899 while (! $is_aq && $$str_ref =~ m{ \G ($QR_OP_PREFIX) }gcxo) {
900 push @{ $has_prefix }, $1;
901 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
902 }
903
904 my @var;
905 my $is_literal;
906 my $is_namespace;
907 my $already_parsed_args;
908
909 ### allow hex
910 if ($$str_ref =~ m{ \G 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }gcxo) {
911 my $number = eval { hex $1 } || 0;
912 push @var, \ $number;
913 $is_literal = 1;
914
915 ### allow for numbers
916 } elsif ($$str_ref =~ m{ \G ( $QR_NUM ) \s* $QR_COMMENTS }gcxo) {
917 my $number = $1;
918 push @var, \ $number;
919 $is_literal = 1;
920
921 ### allow for quoted array constructor
922 } elsif (! $is_aq && $$str_ref =~ m{ \G qw ([^\w\s]) \s* }gcxo) {
923 my $quote = $1;
924 $quote =~ y|([{<|)]}>|;
925 $$str_ref =~ m{ \G (.*?) (?<!\\) \Q$quote\E \s* $QR_COMMENTS }gcxs
926 || $self->throw('parse.missing.array_close', "Missing close \"$quote\"", undef, pos($$str_ref));
927 my $str = $1;
928 $str =~ s{ ^ \s+ }{}x;
929 $str =~ s{ \s+ $ }{}x;
930 $str =~ s{ \\ \Q$quote\E }{$quote}gx;
931 push @var, [undef, '[]', split /\s+/, $str];
932
933 ### allow for regex constructor
934 } elsif (! $is_aq && $$str_ref =~ m{ \G / }gcx) {
935 $$str_ref =~ m{ \G (.*?) (?<! \\) / ([msixeg]*) \s* $QR_COMMENTS }gcxos
936 || $self->throw('parse', 'Unclosed regex tag "/"', undef, pos($$str_ref));
937 my ($str, $opts) = ($1, $2);
938 $self->throw('parse', 'e option not allowed on regex', undef, pos($$str_ref)) if $opts =~ /e/;
939 $self->throw('parse', 'g option not supported on regex', undef, pos($$str_ref)) if $opts =~ /g/;
940 $str =~ s|\\n|\n|g;
941 $str =~ s|\\t|\t|g;
942 $str =~ s|\\r|\r|g;
943 $str =~ s|\\\/|\/|g;
944 $str =~ s|\\\$|\$|g;
945 $self->throw('parse', "Invalid regex: $@", undef, pos($$str_ref)) if ! eval { "" =~ /$str/; 1 };
946 push @var, [undef, 'qr', $str, $opts];
947
948 ### looks like a normal variable start
949 } elsif ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxo) {
950 push @var, $1;
951 $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
952
953 ### allow for literal strings
954 } elsif ($$str_ref =~ m{ \G ([\"\']) }gcx) {
955 my $quote = $1;
956 $$str_ref =~ m{ \G (.*?) (?<! \\) $quote \s* $QR_COMMENTS }gcxs
957 || $self->throw('parse', "Unclosed quoted string ($1)", undef, pos($$str_ref));
958 my $str = $1;
959 if ($quote eq "'") { # no interpolation on single quoted strings
960 $str =~ s{ \\\' }{\'}xg;
961 push @var, \ $str;
962 $is_literal = 1;
963 } else {
964 $str =~ s/\\n/\n/g;
965 $str =~ s/\\t/\t/g;
966 $str =~ s/\\r/\r/g;
967 $str =~ s/\\"/"/g;
968 my @pieces = $is_aq
969 ? split(m{ (?: ^ | (?<!\\)) (\$\w+ | \$\{ .*? (?<!\\) \}) }x, $str) # autoquoted items get a single $\w+ - no nesting
970 : split(m{ (?: ^ | (?<!\\)) (\$\w+ (?:\.\w+)* | \$\{ .*? (?<!\\) \}) }x, $str);
971 my $n = 0;
972 foreach my $piece (@pieces) {
973 $piece =~ s/\\\$/\$/g;
974 $piece =~ s/\\//g;
975 next if ! ($n++ % 2);
976 next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
977 && $piece !~ m{ ^ \$\{ \s* (.*?) (?<!\\) \} $ }x;
978 my $name = $1;
979 $name =~ s/\\\}/\}/g;
980 $piece = $self->parse_expr(\$name);
981 }
982 @pieces = grep {defined && length} @pieces;
983 if (@pieces == 1 && ! ref $pieces[0]) {
984 push @var, \ $pieces[0];
985 $is_literal = 1;
986 } elsif (! @pieces) {
987 push @var, \ '';
988 $is_literal = 1;
989 } else {
990 push @var, [undef, '~', @pieces];
991 }
992 }
993 if ($is_aq) {
994 return ${ $var[0] } if $is_literal;
995 push @var, 0;
996 return \@var;
997 }
998
999 ### allow for leading $foo type constructs
1000 } elsif ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) {
1001 if ($self->{'V1DOLLAR'}) {
1002 push @var, $1;
1003 $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
1004 } else {
1005 push @var, [$1, 0];
1006 }
1007
1008 ### allow for ${foo.bar} type constructs
1009 } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) {
1010 push @var, $self->parse_expr($str_ref);
1011 $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo
1012 || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
1013
1014 ### looks like an array constructor
1015 } elsif (! $is_aq && $$str_ref =~ m{ \G \[ \s* $QR_COMMENTS }gcxo) {
1016 local $self->{'_operator_precedence'} = 0; # reset presedence
1017 my $arrayref = [undef, '[]'];
1018 while (defined(my $var = $self->parse_expr($str_ref))) {
1019 push @$arrayref, $var;
1020 $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo;
1021 }
1022 $$str_ref =~ m{ \G \] \s* $QR_COMMENTS }gcxo
1023 || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, pos($$str_ref));
1024 push @var, $arrayref;
1025
1026 ### looks like a hash constructor
1027 } elsif (! $is_aq && $$str_ref =~ m{ \G \{ \s* $QR_COMMENTS }gcxo) {
1028 local $self->{'_operator_precedence'} = 0; # reset precedence
1029 my $hashref = [undef, '{}'];
1030 while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))) {
1031 $$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo;
1032 my $val = $self->parse_expr($str_ref);
1033 push @$hashref, $key, $val;
1034 $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo;
1035 }
1036 $$str_ref =~ m{ \G \} \s* $QR_COMMENTS }gcxo
1037 || $self->throw('parse.missing.curly_bracket', "Missing close \}", undef, pos($$str_ref));
1038 push @var, $hashref;
1039
1040 ### looks like a paren grouper
1041 } elsif (! $is_aq && $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) {
1042 local $self->{'_operator_precedence'} = 0; # reset precedence
1043 my $var = $self->parse_expr($str_ref, {allow_parened_ops => 1});
1044
1045 $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo
1046 || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref));
1047
1048 $self->throw('parse', 'Paren group cannot be followed by an open paren', undef, pos($$str_ref))
1049 if $$str_ref =~ m{ \G \( }gcx;
1050
1051 $already_parsed_args = 1;
1052 if (! ref $var) {
1053 push @var, \$var, 0;
1054 $is_literal = 1;
1055 } elsif (! defined $var->[0]) {
1056 push @var, $var, 0;
1057 } else {
1058 push @var, @$var;
1059 }
1060
1061 ### nothing to find - return failure
1062 } else {
1063 pos($$str_ref) = $mark if $is_aq || $has_prefix;
1064 return;
1065 }
1066
1067 # auto_quoted thing was too complicated
1068 if ($is_aq) {
1069 pos($$str_ref) = $mark;
1070 return;
1071 }
1072
1073 ### looks for args for the initial
1074 if ($already_parsed_args) {
1075 # do nothing
1076 } elsif ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) {
1077 local $self->{'_operator_precedence'} = 0; # reset precedence
1078 my $args = $self->parse_args($str_ref, {is_parened => 1});
1079 $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo
1080 || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref));
1081 push @var, $args;
1082 } else {
1083 push @var, 0;
1084 }
1085
1086
1087 ### allow for nested items
1088 while ($$str_ref =~ m{ \G ( \.(?!\.) | \|(?!\|) ) }gcx) {
1089 if ($1 eq '|' && $self->{'V2PIPE'}) {
1090 pos($$str_ref) -= 1;
1091 last;
1092 }
1093
1094 push(@var, $1) if ! $ARGS->{'no_dots'};
1095
1096 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
1097
1098 ### allow for interpolated variables in the middle - one.$foo.two
1099 if ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) {
1100 push @var, $self->{'V1DOLLAR'} ? $1 : [$1, 0];
1101
1102 ### or one.${foo.bar}.two
1103 } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) {
1104 push @var, $self->parse_expr($str_ref);
1105 $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo
1106 || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
1107
1108 ### allow for names
1109 } elsif ($$str_ref =~ m{ \G (-? \w+) \s* $QR_COMMENTS }gcxo) {
1110 push @var, $1;
1111
1112 } else {
1113 $self->throw('parse', "Not sure how to continue parsing", undef, pos($$str_ref));
1114 }
1115
1116 ### looks for args for the nested item
1117 if ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) {
1118 local $self->{'_operator_precedence'} = 0; # reset precedence
1119 my $args = $self->parse_args($str_ref, {is_parened => 1});
1120 $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo
1121 || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref));
1122 push @var, $args;
1123 } else {
1124 push @var, 0;
1125 }
1126
1127 }
1128
1129 ### flatten literals and constants as much as possible
1130 my $var;
1131 if ($is_literal) {
1132 $var = ${ $var[0] };
1133 if ($#var != 1) {
1134 $var[0] = [undef, '~', $var];
1135 $var = \@var;
1136 }
1137 } elsif ($is_namespace) {
1138 $var = $self->play_expr(\@var, {is_namespace_during_compile => 1});
1139 } else {
1140 $var = \@var;
1141 }
1142
1143 ### allow for all "operators"
1144 if (! $self->{'_operator_precedence'} && defined $is_aq) {
1145 my $tree;
1146 my $found;
1147 while (1) {
1148 my $mark = pos $$str_ref;
1149 if ($self->{'_end_tag'} && $$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) {
1150 pos($$str_ref) = $mark;
1151 last;
1152 } elsif ($$str_ref !~ m{ \G ($QR_OP) }gcxo) {
1153 pos($$str_ref) = $mark;
1154 last;
1155 }
1156 if ($OP_ASSIGN->{$1} && ! $ARGS->{'allow_parened_ops'}) { # only allow assignment in parens
1157 pos($$str_ref) = $mark;
1158 last;
1159 }
1160 local $self->{'_operator_precedence'} = 1;
1161 my $op = $1;
1162 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
1163
1164 ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --)
1165 if ($OP_POSTFIX->{$op}) {
1166 $var = [[undef, $op, $var, 1], 0]; # cheat - give a "second value" to postfix ops
1167 next;
1168
1169 ### allow for prefix operator precedence
1170 } elsif ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix->[-1]}->[1]) {
1171 if ($tree) {
1172 if ($#$tree == 1) { # only one operator - keep simple things fast
1173 $var = [[undef, $tree->[0], $var, $tree->[1]], 0];
1174 } else {
1175 unshift @$tree, $var;
1176 $var = $self->apply_precedence($tree, $found);
1177 }
1178 undef $tree;
1179 undef $found;
1180 }
1181 $var = [[undef, $has_prefix->[-1], $var ], 0];
1182 if (! @$has_prefix) { undef $has_prefix } else { pop @$has_prefix }
1183 }
1184
1185 ### add the operator to the tree
1186 my $var2 = $self->parse_expr($str_ref, {from_here => 1});
1187 $self->throw('parse', 'Missing variable after "'.$op.'"', undef, pos($$str_ref)) if ! defined $var2;
1188 push (@{ $tree ||= [] }, $op, $var2);
1189 $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op}
1190 }
1191
1192 ### if we found operators - tree the nodes by operator precedence
1193 if ($tree) {
1194 if (@$tree == 2) { # only one operator - keep simple things fast
1195 $var = [[undef, $tree->[0], $var, $tree->[1]], 0];
1196 } else {
1197 unshift @$tree, $var;
1198 $var = $self->apply_precedence($tree, $found);
1199 }
1200 }
1201 }
1202
1203 ### allow for prefix on non-chained variables
1204 if ($has_prefix) {
1205 $var = [[undef, $_, $var], 0] for reverse @$has_prefix;
1206 }
1207
1208 return $var;
1209 }
1210
1211 ### this is used to put the parsed variables into the correct operations tree
1212 sub apply_precedence {
1213 my ($self, $tree, $found) = @_;
1214
1215 my @var;
1216 my $trees;
1217 ### look at the operators we found in the order we found them
1218 for my $prec (sort keys %$found) {
1219 my $ops = $found->{$prec};
1220 local $found->{$prec};
1221 delete $found->{$prec};
1222
1223 ### split the array on the current operators for this level
1224 my @ops;
1225 my @exprs;
1226 for (my $i = 1; $i <= $#$tree; $i += 2) {
1227 next if ! $ops->{ $tree->[$i] };
1228 push @ops, $tree->[$i];
1229 push @exprs, [splice @$tree, 0, $i, ()];
1230 shift @$tree;
1231 $i = -1;
1232 }
1233 next if ! @exprs; # this iteration didn't have the current operator
1234 push @exprs, $tree if scalar @$tree; # add on any remaining items
1235
1236 ### simplify sub expressions
1237 for my $node (@exprs) {
1238 if (@$node == 1) {
1239 $node = $node->[0]; # single item - its not a tree
1240 } elsif (@$node == 3) {
1241 $node = [[undef, $node->[1], $node->[0], $node->[2]], 0]; # single operator - put it straight on
1242 } else {
1243 $node = $self->apply_precedence($node, $found); # more complicated - recurse
1244 }
1245 }
1246
1247 ### assemble this current level
1248
1249 ### some rules:
1250 # 1) items at the same precedence level must all be either right or left or ternary associative
1251 # 2) ternary items cannot share precedence with anybody else.
1252 # 3) there really shouldn't be another operator at the same level as a postfix
1253 my $type = $OP->{$ops[0]}->[0];
1254
1255 if ($type eq 'ternary') {
1256 my $op = $OP->{$ops[0]}->[2]->[0]; # use the first op as what we are using
1257
1258 ### return simple ternary
1259 if (@exprs == 3) {
1260 $self->throw('parse', "Ternary operator mismatch") if $ops[0] ne $op;
1261 $self->throw('parse', "Ternary operator mismatch") if ! $ops[1] || $ops[1] eq $op;
1262 return [[undef, $op, @exprs], 0];
1263 }
1264
1265
1266 ### reorder complex ternary - rare case
1267 while ($#ops >= 1) {
1268 ### if we look starting from the back - the first lead ternary op will always be next to its matching op
1269 for (my $i = $#ops; $i >= 0; $i --) {
1270 next if $OP->{$ops[$i]}->[2]->[1] eq $ops[$i];
1271 my ($op, $op2) = splice @ops, $i, 2, (); # remove the pair of operators
1272 my $node = [[undef, $op, @exprs[$i .. $i + 2]], 0];
1273 splice @exprs, $i, 3, $node;
1274 }
1275 }
1276 return $exprs[0]; # at this point the ternary has been reduced to a single operator
1277
1278 } elsif ($type eq 'right' || $type eq 'assign') {
1279 my $val = $exprs[-1];
1280 $val = [[undef, $ops[$_ - 1], $exprs[$_], $val], 0] for reverse (0 .. $#exprs - 1);
1281 return $val;
1282
1283 } else {
1284 my $val = $exprs[0];
1285 $val = [[undef, $ops[$_ - 1], $val, $exprs[$_]], 0] for (1 .. $#exprs);
1286 return $val;
1287
1288 }
1289 }
1290
1291 $self->throw('parse', "Couldn't apply precedence");
1292 }
1293
1294 ### look for arguments - both positional and named
1295 sub parse_args {
1296 my $self = shift;
1297 my $str_ref = shift;
1298 my $ARGS = shift || {};
1299
1300 my @args;
1301 my @named;
1302 my $name;
1303 my $end = $self->{'_end_tag'} || '(?!)';
1304 while (1) {
1305 my $mark = pos $$str_ref;
1306
1307 ### look to see if the next thing is a directive or a closing tag
1308 if (! $ARGS->{'is_parened'}
1309 && ! $ARGS->{'require_arg'}
1310 && $$str_ref =~ m{ \G $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$end))) }gcxo
1311 && ((pos($$str_ref) = $mark) || 1) # always revert
1312 && $DIRECTIVES->{$self->{'ANYCASE'} ? uc($1) : $1} # looks like a directive - we are done
1313 ) {
1314 last;
1315 }
1316 if ($$str_ref =~ m{ \G [+=~-]? $end }gcx) {
1317 pos($$str_ref) = $mark;
1318 last;
1319 }
1320
1321 ### find the initial arg
1322 my $name;
1323 if ($ARGS->{'allow_bare_filenames'}) {
1324 $name = $self->parse_expr($str_ref, {auto_quote => "
1325 ($QR_FILENAME # file name
1326 | \\w+\\b (?: :\\w+\\b)* ) # or block
1327 (?= [+=~-]? $end # an end tag
1328 | \\s*[+,;] # followed by explicit + , or ;
1329 | \\s+ (?! [\\s=]) # or space not before an =
1330 ) \\s* $QR_COMMENTS"});
1331 # filenames can be separated with a "+" - why a "+" ?
1332 if ($$str_ref =~ m{ \G \+ (?! [+=~-]? $end) \s* $QR_COMMENTS }gcxo) {
1333 push @args, $name;
1334 $ARGS->{'require_arg'} = 1;
1335 next;
1336 }
1337 }
1338 if (! defined $name) {
1339 $name = $self->parse_expr($str_ref);
1340 if (! defined $name) {
1341 if ($ARGS->{'require_arg'} && ! @args && ! $ARGS->{'positional_only'} && ! @named) {
1342 $self->throw('parse', 'Argument required', undef, pos($$str_ref));
1343 } else {
1344 last;
1345 }
1346 }
1347 }
1348
1349 $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
1350
1351 ### see if it is named or positional
1352 if ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo) {
1353 $self->throw('parse', 'Named arguments not allowed', undef, $mark) if $ARGS->{'positional_only'};
1354 my $val = $self->parse_expr($str_ref);
1355 $name = $name->[0] if ref($name) && @$name == 2 && ! $name->[1]; # strip a level of indirection on named arguments
1356 push @named, $name, $val;
1357 } else {
1358 push @args, $name;
1359 }
1360
1361 ### look for trailing comma
1362 $ARGS->{'require_arg'} = ($$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo) || 0;
1363 }
1364
1365 ### allow for named arguments to be added at the front (if asked)
1366 if ($ARGS->{'named_at_front'}) {
1367 unshift @args, [[undef, '{}', @named], 0];
1368 } elsif (scalar @named) { # only add at end - if there are some
1369 push @args, [[undef, '{}', @named], 0]
1370 }
1371
1372 return \@args;
1373 }
1374
1375 ### allow for looking for $foo or ${foo.bar} in TEXT "nodes" of the parse tree.
1376 sub interpolate_node {
1377 my ($self, $tree, $offset) = @_;
1378 return if $self->{'_in_perl'};
1379
1380 ### split on variables while keeping the variables
1381 my @pieces = split m{ (?: ^ | (?<! \\)) (\$\w+ (?:\.\w+)* | \$\{ .*? (?<!\\) \}) }x, $tree->[-1];
1382 if ($#pieces <= 0) {
1383 $tree->[-1] =~ s{ \\ ([\"\$]) }{$1}xg;
1384 return;
1385 }
1386
1387 my @sub_tree;
1388 my $n = 0;
1389 foreach my $piece (@pieces) {
1390 $offset += length $piece; # we track the offset to make sure DEBUG has the right location
1391 $piece =~ s{ \\ ([\"\$]) }{$1}xg;
1392 if (! ($n++ % 2)) { # odds will always be text chunks
1393 next if ! length $piece;
1394 push @sub_tree, $piece;
1395 } elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
1396 || $piece =~ m{ ^ \$\{ \s* (.*?) (?<!\\) \} $ }x) {
1397 my $name = $1;
1398 $name =~ s/\\\}/\}/g;
1399 push @sub_tree, ['GET', $offset - length($piece), $offset, $self->parse_expr(\$name)];
1400 } else {
1401 $self->throw('parse', "Parse error during interpolate node");
1402 }
1403 }
1404
1405 ### replace the tree
1406 splice @$tree, -1, 1, @sub_tree;
1407 }
1408
1409 ###----------------------------------------------------------------###
1410
1411 sub execute_tree {
1412 my ($self, $tree, $out_ref) = @_;
1413
1414 # node contains (0: DIRECTIVE,
1415 # 1: start_index,
1416 # 2: end_index,
1417 # 3: parsed tag details,
1418 # 4: sub tree for block types
1419 # 5: continuation sub trees for sub continuation block types (elsif, else, etc)
1420 # 6: flag to capture next directive
1421 for my $node (@$tree) {
1422 ### text nodes are just the bare text
1423 if (! ref $node) {
1424 warn "NODE: TEXT\n" if trace;
1425 $$out_ref .= $node if defined $node;
1426 next;
1427 }
1428
1429 warn "NODE: $node->[0] (char $node->[1])\n" if trace;
1430 $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};
1431
1432 my $val = $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref);
1433 $$out_ref .= $val if defined $val;
1434 }
1435 }
1436
1437 sub play_expr {
1438 ### allow for the parse tree to store literals
1439 return $_[1] if ! ref $_[1];
1440
1441 my $self = shift;
1442 my $var = shift;
1443 my $ARGS = shift || {};
1444 my $i = 0;
1445
1446 ### determine the top level of this particular variable access
1447 my $ref;
1448 my $name = $var->[$i++];
1449 my $args = $var->[$i++];
1450 warn "play_expr: begin \"$name\"\n" if trace;
1451 if (ref $name) {
1452 if (! defined $name->[0]) { # operator
1453 return $self->play_operator($name) if wantarray && $name->[1] eq '..';
1454 $ref = $self->play_operator($name);
1455 } else { # a named variable access (ie via $name.foo)
1456 $name = $self->play_expr($name);
1457 if (defined $name) {
1458 return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
1459 return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name};
1460 $ref = $self->{'_vars'}->{$name};
1461 }
1462 }
1463 } elsif (defined $name) {
1464 if ($ARGS->{'is_namespace_during_compile'}) {
1465 $ref = $self->{'NAMESPACE'}->{$name};
1466 } else {
1467 return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
1468 return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name};
1469 $ref = $self->{'_vars'}->{$name};
1470 $ref = ($name eq 'template' || $name eq 'component') ? $self->{"_$name"} : $VOBJS->{$name} if ! defined $ref;
1471 }
1472 }
1473
1474
1475 my %seen_filters;
1476 while (defined $ref) {
1477
1478 ### check at each point if the rurned thing was a code
1479 if (UNIVERSAL::isa($ref, 'CODE')) {
1480 return $ref if $i >= $#$var && $ARGS->{'return_ref'};
1481 my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ());
1482 if (defined $results[0]) {
1483 $ref = ($#results > 0) ? \@results : $results[0];
1484 } elsif (defined $results[1]) {
1485 die $results[1]; # TT behavior - why not just throw ?
1486 } else {
1487 $ref = undef;
1488 last;
1489 }
1490 }
1491
1492 ### descend one chained level
1493 last if $i >= $#$var;
1494 my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
1495 $name = $var->[$i++];
1496 $args = $var->[$i++];
1497 warn "play_expr: nested \"$name\"\n" if trace;
1498
1499 ### allow for named portions of a variable name (foo.$name.bar)
1500 if (ref $name) {
1501 if (ref($name) eq 'ARRAY') {
1502 $name = $self->play_expr($name);
1503 if (! defined($name) || $name =~ $QR_PRIVATE || $name =~ /^\./) {
1504 $ref = undef;
1505 last;
1506 }
1507 } else {
1508 die "Shouldn't get a ". ref($name) ." during a vivify on chain";
1509 }
1510 }
1511 if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
1512 $ref = undef;
1513 last;
1514 }
1515
1516 ### allow for scalar and filter access (this happens for every non virtual method call)
1517 if (! ref $ref) {
1518 if ($SCALAR_OPS->{$name}) { # normal scalar op
1519 $ref = $SCALAR_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
1520
1521 } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
1522 $ref = $LIST_OPS->{$name}->([$ref], $args ? map { $self->play_expr($_) } @$args : ());
1523
1524 } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args
1525 || $FILTER_OPS->{$name} # predefined filters in CET
1526 || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
1527 || $self->list_filters->{$name}) { # filter defined in Template::Filters
1528
1529 if (UNIVERSAL::isa($filter, 'CODE')) {
1530 $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
1531 if (my $err = $@) {
1532 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
1533 die $err;
1534 }
1535 } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
1536 $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
1537
1538 } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
1539 eval {
1540 my $sub = $filter->[0];
1541 if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
1542 ($sub, my $err) = $sub->($self->context, $args ? map { $self->play_expr($_) } @$args : ());
1543 if (! $sub && $err) {
1544 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
1545 die $err;
1546 } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
1547 $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
1548 if ref($sub) !~ /Template::Exception$/;
1549 die $sub;
1550 }
1551 }
1552 $ref = $sub->($ref);
1553 };
1554 if (my $err = $@) {
1555 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
1556 die $err;
1557 }
1558 } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
1559 $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
1560 $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree
1561 $i = 2;
1562 }
1563 if (scalar keys %seen_filters
1564 && $seen_filters{$var->[$i - 5] || ''}) {
1565 $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)");
1566 }
1567 } else {
1568 $ref = undef;
1569 }
1570
1571 } else {
1572
1573 ### method calls on objects
1574 if ($was_dot_call && UNIVERSAL::can($ref, 'can')) {
1575 return $ref if $i >= $#$var && $ARGS->{'return_ref'};
1576 my @args = $args ? map { $self->play_expr($_) } @$args : ();
1577 my @results = eval { $ref->$name(@args) };
1578 if ($@) {
1579 my $class = ref $ref;
1580 die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/;
1581 } elsif (defined $results[0]) {
1582 $ref = ($#results > 0) ? \@results : $results[0];
1583 next;
1584 } elsif (defined $results[1]) {
1585 die $results[1]; # TT behavior - why not just throw ?
1586 } else {
1587 $ref = undef;
1588 last;
1589 }
1590 # didn't find a method by that name - so fail down to hash and array access
1591 }
1592
1593 ### hash member access
1594 if (UNIVERSAL::isa($ref, 'HASH')) {
1595 if ($was_dot_call && exists($ref->{$name}) ) {
1596 return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->{$name};
1597 $ref = $ref->{$name};
1598 } elsif ($HASH_OPS->{$name}) {
1599 $ref = $HASH_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
1600 } elsif ($ARGS->{'is_namespace_during_compile'}) {
1601 return $var; # abort - can't fold namespace variable
1602 } else {
1603 return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'};
1604 $ref = undef;
1605 }
1606
1607 ### array access
1608 } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
1609 if ($name =~ m{ ^ -? $QR_NUM $ }ox) {
1610 return \ $ref->[$name] if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->[$name];
1611 $ref = $ref->[$name];
1612 } elsif ($LIST_OPS->{$name}) {
1613 $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
1614 } else {
1615 $ref = undef;
1616 }
1617 }
1618 }
1619
1620 } # end of while
1621
1622 ### allow for undefinedness
1623 if (! defined $ref) {
1624 if ($self->{'_debug_undef'}) {
1625 my $chunk = $var->[$i - 2];
1626 $chunk = $self->play_expr($chunk) if ref($chunk) eq 'ARRAY';
1627 die "$chunk is undefined\n";
1628 } else {
1629 $ref = $self->undefined_any($var);
1630 }
1631 }
1632
1633 return $ref;
1634 }
1635
1636 sub is_empty_named_args {
1637 my ($self, $hash_ident) = @_;
1638 # [[undef, '{}', 'key1', 'val1', 'key2, 'val2'], 0]
1639 return @{ $hash_ident->[0] } <= 2;
1640 }
1641
1642 sub set_variable {
1643 my ($self, $var, $val, $ARGS) = @_;
1644 $ARGS ||= {};
1645 my $i = 0;
1646
1647 ### allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %])
1648 $var = [$var, 0] if ! ref $var;
1649
1650 ### determine the top level of this particular variable access
1651 my $ref = $var->[$i++];
1652 my $args = $var->[$i++];
1653 if (ref $ref) {
1654 ### non-named types can't be set
1655 return if ref($ref) ne 'ARRAY' || ! defined $ref->[0];
1656
1657 # named access (ie via $name.foo)
1658 $ref = $self->play_expr($ref);
1659 if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _
1660 if ($#$var <= $i) {
1661 return $self->{'_vars'}->{$ref} = $val;
1662 } else {
1663 $ref = $self->{'_vars'}->{$ref} ||= {};
1664 }
1665 } else {
1666 return;
1667 }
1668 } elsif (defined $ref) {
1669 return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
1670 if ($#$var <= $i) {
1671 return $self->{'_vars'}->{$ref} = $val;
1672 } else {
1673 $ref = $self->{'_vars'}->{$ref} ||= {};
1674 }
1675 }
1676
1677 while (defined $ref) {
1678
1679 ### check at each point if the returned thing was a code
1680 if (UNIVERSAL::isa($ref, 'CODE')) {
1681 my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ());
1682 if (defined $results[0]) {
1683 $ref = ($#results > 0) ? \@results : $results[0];
1684 } elsif (defined $results[1]) {
1685 die $results[1]; # TT behavior - why not just throw ?
1686 } else {
1687 return;
1688 }
1689 }
1690
1691 ### descend one chained level
1692 last if $i >= $#$var;
1693 my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
1694 my $name = $var->[$i++];
1695 my $args = $var->[$i++];
1696
1697 ### allow for named portions of a variable name (foo.$name.bar)
1698 if (ref $name) {
1699 if (ref($name) eq 'ARRAY') {
1700 $name = $self->play_expr($name);
1701 if (! defined($name) || $name =~ /^[_.]/) {
1702 return;
1703 }
1704 } else {
1705 die "Shouldn't get a ".ref($name)." during a vivify on chain";
1706 }
1707 }
1708 if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
1709 return;
1710 }
1711
1712 ### scalar access
1713 if (! ref $ref) {
1714 return;
1715
1716 ### method calls on objects
1717 } elsif (UNIVERSAL::can($ref, 'can')) {
1718 my $lvalueish;
1719 my @args = $args ? map { $self->play_expr($_) } @$args : ();
1720 if ($i >= $#$var) {
1721 $lvalueish = 1;
1722 push @args, $val;
1723 }
1724 my @results = eval { $ref->$name(@args) };
1725 if (! $@) {
1726 if (defined $results[0]) {
1727 $ref = ($#results > 0) ? \@results : $results[0];
1728 } elsif (defined $results[1]) {
1729 die $results[1]; # TT behavior - why not just throw ?
1730 } else {
1731 return;
1732 }
1733 return if $lvalueish;
1734 next;
1735 }
1736 my $class = ref $ref;
1737 die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/;
1738 # fall on down to "normal" accessors
1739 }
1740
1741 ### hash member access
1742 if (UNIVERSAL::isa($ref, 'HASH')) {
1743 if ($#$var <= $i) {
1744 return $ref->{$name} = $val;
1745 } else {
1746 $ref = $ref->{$name} ||= {};
1747 next;
1748 }
1749
1750 ### array access
1751 } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
1752 if ($name =~ m{ ^ -? $QR_NUM $ }ox) {
1753 if ($#$var <= $i) {
1754 return $ref->[$name] = $val;
1755 } else {
1756 $ref = $ref->[$name] ||= {};
1757 next;
1758 }
1759 } else {
1760 return;
1761 }
1762
1763 }
1764
1765 }
1766
1767 return;
1768 }
1769
1770 ###----------------------------------------------------------------###
1771
1772 sub play_operator {
1773 my ($self, $tree) = @_;
1774 ### $tree looks like [undef, '+', 4, 5]
1775
1776 if ($OP_DISPATCH->{$tree->[1]}) {
1777 local $^W;
1778 if ($OP_ASSIGN->{$tree->[1]}) {
1779 my $val = $OP_DISPATCH->{$tree->[1]}->($self->play_expr($tree->[2]), $self->play_expr($tree->[3]));
1780 $self->set_variable($tree->[2], $val);
1781 return $val;
1782 } else {
1783 return $OP_DISPATCH->{$tree->[1]}->(@$tree == 3 ? $self->play_expr($tree->[2]) : ($self->play_expr($tree->[2]), $self->play_expr($tree->[3])));
1784 }
1785 }
1786
1787 my $op = $tree->[1];
1788
1789 ### do custom and short-circuitable operators
1790 if ($op eq '=') {
1791 my $val = $self->play_expr($tree->[3]);
1792 $self->set_variable($tree->[2], $val);
1793 return $val;
1794
1795 } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
1796 return $self->play_expr($tree->[2]) || $self->play_expr($tree->[3]) || '';
1797
1798 } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') {
1799 my $var = $self->play_expr($tree->[2]) && $self->play_expr($tree->[3]);
1800 return $var ? $var : 0;
1801
1802 } elsif ($op eq '?') {
1803 local $^W;
1804 return $self->play_expr($tree->[2]) ? $self->play_expr($tree->[3]) : $self->play_expr($tree->[4]);
1805
1806 } elsif ($op eq '~' || $op eq '_') {
1807 local $^W;
1808 my $s = '';
1809 $s .= $self->play_expr($tree->[$_]) for 2 .. $#$tree;
1810 return $s;
1811
1812 } elsif ($op eq '[]') {
1813 return [map {$self->play_expr($tree->[$_])} 2 .. $#$tree];
1814
1815 } elsif ($op eq '{}') {
1816 local $^W;
1817 my @e;
1818 push @e, $self->play_expr($tree->[$_]) for 2 .. $#$tree;
1819 return {@e};
1820
1821 } elsif ($op eq '++') {
1822 local $^W;
1823 my $val = 0 + $self->play_expr($tree->[2]);
1824 $self->set_variable($tree->[2], $val + 1);
1825 return $tree->[3] ? $val : $val + 1; # ->[3] is set to 1 during parsing of postfix ops
1826
1827 } elsif ($op eq '--') {
1828 local $^W;
1829 my $val = 0 + $self->play_expr($tree->[2]);
1830 $self->set_variable($tree->[2], $val - 1);
1831 return $tree->[3] ? $val : $val - 1; # ->[3] is set to 1 during parsing of postfix ops
1832
1833 } elsif ($op eq '\\') {
1834 my $var = $tree->[2];
1835
1836 my $ref = $self->play_expr($var, {return_ref => 1});
1837 return $ref if ! ref $ref;
1838 return sub { sub { $$ref } } if ref $ref eq 'SCALAR' || ref $ref eq 'REF';
1839
1840 my $self_copy = $self;
1841 eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
1842
1843 my $last = ['temp deref key', $var->[-1] ? [@{ $var->[-1] }] : 0];
1844 return sub { sub { # return a double sub so that the current play_expr will return a coderef
1845 local $self_copy->{'_vars'}->{'temp deref key'} = $ref;
1846 $last->[-1] = (ref $last->[-1] ? [@{ $last->[-1] }, @_] : [@_]) if @_;
1847 return $self->play_expr($last);
1848 } };
1849 } elsif ($op eq 'qr') {
1850 return $tree->[3] ? qr{(?$tree->[3]:$tree->[2])} : qr{$tree->[2]};
1851 }
1852
1853 $self->throw('operator', "Un-implemented operation $op");
1854 }
1855
1856 ###----------------------------------------------------------------###
1857
1858 sub parse_BLOCK {
1859 my ($self, $str_ref, $node) = @_;
1860
1861 my $end = $self->{'_end_tag'} || '(?!)';
1862 my $block_name = $self->parse_expr($str_ref, {auto_quote => "
1863 ($QR_FILENAME # file name
1864 | \\w+\\b (?: :\\w+\\b)* ) # or block
1865 (?= [+=~-]? $end # an end tag
1866 | \\s*[+,;] # followed by explicit + , or ;
1867 | \\s+ (?! [\\s=]) # or space not before an =
1868 ) \\s* $QR_COMMENTS"});
1869
1870 return '' if ! defined $block_name;
1871
1872 my $prepend = join "/", map {$_->[3]} grep {ref($_) && $_->[0] eq 'BLOCK'} @{ $self->{'_state'} || {} };
1873 return $prepend ? "$prepend/$block_name" : $block_name;
1874 }
1875
1876 sub play_BLOCK {
1877 my ($self, $block_name, $node, $out_ref) = @_;
1878
1879 ### store a named reference - but do nothing until something processes it
1880 $self->{'BLOCKS'}->{$block_name} = {
1881 _tree => $node->[4],
1882 name => $self->{'_component'}->{'name'} .'/'. $block_name,
1883 };
1884
1885 return;
1886 }
1887
1888 sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) }
1889
1890 sub play_CALL { $DIRECTIVES->{'GET'}->[1]->(@_); return }
1891
1892 sub parse_CASE {
1893 my ($self, $str_ref) = @_;
1894 return if $$str_ref =~ m{ \G DEFAULT \s* }gcx;
1895 return $self->parse_expr($str_ref);
1896 }
1897
1898 sub parse_CATCH {
1899 my ($self, $str_ref) = @_;
1900 return $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"});
1901 }
1902
1903 sub play_control {
1904 my ($self, $undef, $node) = @_;
1905 $self->throw(lc($node->[0]), 'Control exception', $node);
1906 }
1907
1908 sub play_CLEAR {
1909 my ($self, $undef, $node, $out_ref) = @_;
1910 $$out_ref = '';
1911 }
1912
1913 sub parse_CONFIG {
1914 my ($self, $str_ref) = @_;
1915
1916 my %ctime = map {$_ => 1} @CONFIG_COMPILETIME;
1917 my %rtime = map {$_ => 1} @CONFIG_RUNTIME;
1918
1919 my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1});
1920 my $ref = $config->[0]->[0];
1921 for (my $i = 2; $i < @$ref; $i += 2) {
1922 my $key = $ref->[$i] = uc $ref->[$i];
1923 my $val = $ref->[$i + 1];
1924 if ($ctime{$key}) {
1925 splice @$ref, $i, 2, (); # remove the options
1926 $self->{$key} = $self->play_expr($val);
1927 $i -= 2;
1928 } elsif (! $rtime{$key}) {
1929 $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
1930 }
1931 }
1932 for (my $i = 1; $i < @$config; $i++) {
1933 my $key = $config->[$i] = uc $config->[$i]->[0];
1934 if ($ctime{$key}) {
1935 $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef');
1936 } elsif (! $rtime{$key}) {
1937 $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
1938 }
1939 }
1940 return $config;
1941 }
1942
1943 sub play_CONFIG {
1944 my ($self, $config) = @_;
1945
1946 my %rtime = map {$_ => 1} @CONFIG_RUNTIME;
1947
1948 ### do runtime config - not many options get these
1949 my ($named, @the_rest) = @$config;
1950 $named = $self->play_expr($named);
1951 @{ $self }{keys %$named} = @{ $named }{keys %$named};
1952
1953 ### show what current values are
1954 return join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest);
1955 }
1956
1957 sub parse_DEBUG {
1958 my ($self, $str_ref) = @_;
1959 $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx
1960 || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref));
1961 my $ret = [lc($1)];
1962 if ($ret->[0] eq 'format') {
1963 $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs
1964 || $self->throw('parse', "Missing format string", undef, pos($$str_ref));
1965 $ret->[1] = $2;
1966 }
1967 return $ret;
1968 }
1969
1970 sub play_DEBUG {
1971 my ($self, $ref) = @_;
1972 if ($ref->[0] eq 'on') {
1973 delete $self->{'_debug_off'};
1974 } elsif ($ref->[0] eq 'off') {
1975 $self->{'_debug_off'} = 1;
1976 } elsif ($ref->[0] eq 'format') {
1977 $self->{'_debug_format'} = $ref->[1];
1978 }
1979 }
1980
1981 sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) }
1982
1983 sub play_DEFAULT {
1984 my ($self, $set) = @_;
1985 foreach (@$set) {
1986 my ($op, $set, $default) = @$_;
1987 next if ! defined $set;
1988 my $val = $self->play_expr($set);
1989 if (! $val) {
1990 $default = defined($default) ? $self->play_expr($default) : '';
1991 $self->set_variable($set, $default);
1992 }
1993 }
1994 return;
1995 }
1996
1997 sub parse_DUMP {
1998 my ($self, $str_ref) = @_;
1999 return $self->parse_args($str_ref, {named_at_front => 1});
2000 }
2001
2002 sub play_DUMP {
2003 my ($self, $dump, $node) = @_;
2004
2005 my $conf = $self->{'DUMP'};
2006 return if ! $conf && defined $conf; # DUMP => 0
2007 $conf = {} if ref $conf ne 'HASH';
2008
2009 ### allow for handler override
2010 my $handler = $conf->{'handler'};
2011 if (! $handler) {
2012 require Data::Dumper;
2013 my $obj = Data::Dumper->new([]);
2014 my $meth;
2015 foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) }
2016 my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1;
2017 $obj->Sortkeys(sub { my $h = shift; [grep {$_ !~ $QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] });
2018 $handler = sub { $obj->Values([@_]); $obj->Dump }
2019 }
2020
2021 my ($named, @dump) = @$dump;
2022 push @dump, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
2023 $_ = $self->play_expr($_) foreach @dump;
2024
2025 ### look for the text describing what to dump
2026 my $info = $self->node_info($node);
2027 my $out;
2028 if (@dump) {
2029 $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump);
2030 my $name = $info->{'text'};
2031 $name =~ s/^[+=~-]?\s*DUMP\s+//;
2032 $name =~ s/\s*[+=~-]?$//;
2033 $out =~ s/\$VAR1/$name/;
2034 } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) {
2035 $out = '';
2036 } else {
2037 $out = $handler->($self->{'_vars'});
2038 $out =~ s/\$VAR1/EntireStash/g;
2039 }
2040
2041 if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) {
2042 $out = $SCALAR_OPS->{'html'}->($out);
2043 $out = "<pre>$out</pre>";
2044 $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out" if $conf->{'header'} || ! defined $conf->{'header'};
2045 } else {
2046 $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'};
2047 }
2048
2049 return $out;
2050 }
2051
2052 sub parse_FILTER {
2053 my ($self, $str_ref) = @_;
2054 my $name = '';
2055 if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) {
2056 $name = $1;
2057 }
2058
2059 my $filter = $self->parse_expr($str_ref);
2060 $filter = '' if ! defined $filter;
2061
2062 return [$name, $filter];
2063 }
2064
2065 sub play_FILTER {
2066 my ($self, $ref, $node, $out_ref) = @_;
2067 my ($name, $filter) = @$ref;
2068
2069 return '' if ! @$filter;
2070
2071 $self->{'FILTERS'}->{$name} = $filter if length $name;
2072
2073 my $sub_tree = $node->[4];
2074
2075 ### play the block
2076 my $out = '';
2077 eval { $self->execute_tree($sub_tree, \$out) };
2078 die $@ if $@ && ref($@) !~ /Template::Exception$/;
2079
2080 my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it
2081
2082
2083 return $DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
2084 }
2085
2086 sub parse_FOREACH {
2087 my ($self, $str_ref) = @_;
2088 my $items = $self->parse_expr($str_ref);
2089 my $var;
2090 if ($$str_ref =~ m{ \G (= | [Ii][Nn]\b) \s* }gcx) {
2091 $var = [@$items];
2092 $items = $self->parse_expr($str_ref);
2093 }
2094 return [$var, $items];
2095 }
2096
2097 sub play_FOREACH {
2098 my ($self, $ref, $node, $out_ref) = @_;
2099
2100 ### get the items - make sure it is an arrayref
2101 my ($var, $items) = @$ref;
2102
2103 $items = $self->play_expr($items);
2104 return '' if ! defined $items;
2105
2106 if (ref($items) !~ /Iterator$/) {
2107 $items = $PACKAGE_ITERATOR->new($items);
2108 }
2109
2110 my $sub_tree = $node->[4];
2111
2112 local $self->{'_vars'}->{'loop'} = $items;
2113
2114 ### if the FOREACH tag sets a var - then nothing but the loop var gets localized
2115 if (defined $var) {
2116 my ($item, $error) = $items->get_first;
2117 while (! $error) {
2118
2119 $self->set_variable($var, $item);
2120
2121 ### execute the sub tree
2122 eval { $self->execute_tree($sub_tree, $out_ref) };
2123 if (my $err = $@) {
2124 if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
2125 if ($err->type eq 'next') {
2126 ($item, $error) = $items->get_next;
2127 next;
2128 }
2129 last if $err->type =~ /last|break/;
2130 }
2131 die $err;
2132 }
2133
2134 ($item, $error) = $items->get_next;
2135 }
2136 die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
2137 ### if the FOREACH tag doesn't set a var - then everything gets localized
2138 } else {
2139
2140 ### localize variable access for the foreach
2141 my $swap = $self->{'_vars'};
2142 local $self->{'_vars'} = my $copy = {%$swap};
2143
2144 ### iterate use the iterator object
2145 #foreach (my $i = $items->index; $i <= $#$vals; $items->index(++ $i)) {
2146 my ($item, $error) = $items->get_first;
2147 while (! $error) {
2148
2149 if (ref($item) eq 'HASH') {
2150 @$copy{keys %$item} = values %$item;
2151 }
2152
2153 ### execute the sub tree
2154 eval { $self->execute_tree($sub_tree, $out_ref) };
2155 if (my $err = $@) {
2156 if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
2157 if ($err->type eq 'next') {
2158 ($item, $error) = $items->get_next;
2159 next;
2160 }
2161 last if $err->type =~ /last|break/;
2162 }
2163 die $err;
2164 }
2165
2166 ($item, $error) = $items->get_next;
2167 }
2168 die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
2169 }
2170
2171 return undef;
2172 }
2173
2174 sub parse_GET {
2175 my ($self, $str_ref) = @_;
2176 my $ref = $self->parse_expr($str_ref);
2177 $self->throw('parse', "Missing variable name", undef, pos($$str_ref)) if ! defined $ref;
2178 return $ref;
2179 }
2180
2181 sub play_GET {
2182 my ($self, $ident, $node) = @_;
2183 my $var = $self->play_expr($ident);
2184 return (! defined $var) ? $self->undefined_get($ident, $node) : $var;
2185 }
2186
2187 sub parse_IF {
2188 my ($self, $str_ref) = @_;
2189 return $self->parse_expr($str_ref);
2190 }
2191
2192 sub play_IF {
2193 my ($self, $var, $node, $out_ref) = @_;
2194
2195 my $val = $self->play_expr($var);
2196 if ($val) {
2197 my $body_ref = $node->[4] ||= [];
2198 $self->execute_tree($body_ref, $out_ref);
2199 return;
2200 }
2201
2202 while ($node = $node->[5]) { # ELSE, ELSIF's
2203 if ($node->[0] eq 'ELSE') {
2204 my $body_ref = $node->[4] ||= [];
2205 $self->execute_tree($body_ref, $out_ref);
2206 return;
2207 }
2208 my $var = $node->[3];
2209 my $val = $self->play_expr($var);
2210 if ($val) {
2211 my $body_ref = $node->[4] ||= [];
2212 $self->execute_tree($body_ref, $out_ref);
2213 return;
2214 }
2215 }
2216 return;
2217 }
2218
2219 sub parse_INCLUDE { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
2220
2221 sub play_INCLUDE {
2222 my ($self, $str_ref, $node, $out_ref) = @_;
2223
2224 ### localize the swap
2225 my $swap = $self->{'_vars'};
2226 local $self->{'_vars'} = {%$swap};
2227
2228 ### localize the blocks
2229 my $blocks = $self->{'BLOCKS'};
2230 local $self->{'BLOCKS'} = {%$blocks};
2231
2232 my $str = $DIRECTIVES->{'PROCESS'}->[1]->($self, $str_ref, $node, $out_ref);
2233
2234 return $str;
2235 }
2236
2237 sub parse_INSERT { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
2238
2239 sub play_INSERT {
2240 my ($self, $args, $node, $out_ref) = @_;
2241
2242 my ($named, @files) = @$args;
2243
2244 foreach my $name (@files) {
2245 my $filename = $self->play_expr($name);
2246 $$out_ref .= $self->_insert($filename);
2247 }
2248
2249 return;
2250 }
2251
2252 sub parse_MACRO {
2253 my ($self, $str_ref, $node) = @_;
2254
2255 my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"});
2256 $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name;
2257 if (! ref $name) {
2258 $name = [ $name, 0 ];
2259 }
2260
2261 my $args;
2262 if ($$str_ref =~ m{ \G \( \s* }gcx) {
2263 $args = $self->parse_args($str_ref, {positional_only => 1});
2264 $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
2265 }
2266
2267 $node->[6] = 1; # set a flag to keep parsing
2268 return [$name, $args];
2269 }
2270
2271 sub play_MACRO {
2272 my ($self, $ref, $node, $out_ref) = @_;
2273 my ($name, $args) = @$ref;
2274
2275 ### get the sub tree
2276 my $sub_tree = $node->[4];
2277 if (! $sub_tree || ! $sub_tree->[0]) {
2278 $self->set_variable($name, undef);
2279 return;
2280 } elsif ($sub_tree->[0]->[0] eq 'BLOCK') {
2281 $sub_tree = $sub_tree->[0]->[4];
2282 }
2283
2284 my $self_copy = $self;
2285 eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
2286
2287 ### install a closure in the stash that will handle the macro
2288 $self->set_variable($name, sub {
2289 ### macros localize
2290 my $copy = $self_copy->{'_vars'};
2291 local $self_copy->{'_vars'}= {%$copy};
2292
2293 ### prevent recursion
2294 local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0;
2295 $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $MAX_MACRO_RECURSE reached")
2296 if ++$self_copy->{'_macro_recurse'} > ($self_copy->{'MAX_MACRO_RECURSE'} || $MAX_MACRO_RECURSE);
2297
2298
2299 ### set arguments
2300 my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
2301 my @positional = @_;
2302 foreach my $var (@$args) {
2303 $self_copy->set_variable($var, shift(@positional));
2304 }
2305 foreach my $name (sort keys %$named) {
2306 $self_copy->set_variable([$name, 0], $named->{$name});
2307 }
2308
2309 ### finally - run the sub tree
2310 my $out = '';
2311 $self_copy->execute_tree($sub_tree, \$out);
2312 return $out;
2313 });
2314
2315 return;
2316 }
2317
2318 sub play_META {
2319 my ($self, $hash) = @_;
2320
2321 my @keys = keys %$hash;
2322
2323 my $ref;
2324 if ($self->{'_top_level'}) {
2325 $ref = $self->{'_template'} ||= {};
2326 } else {
2327 $ref = $self->{'_component'} ||= {};
2328 }
2329
2330 @{ $ref }{ @keys } = @{ $hash }{ @keys };
2331 return;
2332 }
2333
2334 sub parse_PERL { shift->{'_in_perl'} = 1; return }
2335
2336 sub play_PERL {
2337 my ($self, $info, $node, $out_ref) = @_;
2338 $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
2339
2340 ### fill in any variables
2341 my $perl = $node->[4] || return;
2342 my $out = '';
2343 $self->execute_tree($perl, \$out);
2344 $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
2345
2346 ### try the code
2347 my $err;
2348 eval {
2349 package CGI::Ex::Template::Perl;
2350
2351 my $context = $self->context;
2352 my $stash = $context->stash;
2353
2354 ### setup a fake handle
2355 local *PERLOUT;
2356 tie *PERLOUT, $CGI::Ex::Template::PACKAGE_PERL_HANDLE, $out_ref;
2357 my $old_fh = select PERLOUT;
2358
2359 eval $out;
2360 $err = $@;
2361
2362 ### put the handle back
2363 select $old_fh;
2364
2365 };
2366 $err ||= $@;
2367
2368
2369 if ($err) {
2370 $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
2371 die $err;
2372 }
2373
2374 return;
2375 }
2376
2377 sub parse_PROCESS {
2378 my ($self, $str_ref) = @_;
2379
2380 return $self->parse_args($str_ref, {
2381 named_at_front => 1,
2382 allow_bare_filenames => 1,
2383 require_arg => 1,
2384 });
2385 }
2386
2387 sub play_PROCESS {
2388 my ($self, $info, $node, $out_ref) = @_;
2389
2390 my ($args, @files) = @$info;
2391
2392 ### set passed args
2393 # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
2394 $args = $args->[0];
2395 foreach (my $i = 2; $i < @$args; $i+=2) {
2396 my $key = $args->[$i];
2397 my $val = $self->play_expr($args->[$i+1]);
2398 if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever
2399 foreach my $key (keys %$val) {
2400 $self->set_variable([$key,0], $val->{$key});
2401 }
2402 next;
2403 }
2404 $self->set_variable($key, $val);
2405 }
2406
2407 ### iterate on any passed block or filename
2408 foreach my $ref (@files) {
2409 next if ! defined $ref;
2410 my $filename = $self->play_expr($ref);
2411 my $out = ''; # have temp item to allow clear to correctly clear
2412
2413 ### normal blocks or filenames
2414 if (! ref $filename) {
2415 eval { $self->_process($filename, $self->{'_vars'}, \$out) }; # restart the swap - passing it our current stash
2416
2417 ### allow for $template which is used in some odd instances
2418 } else {
2419 my $doc;
2420 if ($ref->[0] eq 'template') {
2421 $doc = $filename;
2422 } else {
2423 $doc = $self->play_expr($ref);
2424 if (ref($doc) ne 'HASH' || ! $doc->{'_tree'}) {
2425 $self->throw('process', "Passed item doesn't appear to be a valid document");
2426 }
2427 }
2428 $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'};
2429 local $self->{'_process_dollar_template'} = 1;
2430 local $self->{'_component'} = $filename;
2431 return if ! $doc->{'_tree'};
2432
2433 ### execute and trim
2434 eval { $self->execute_tree($doc->{'_tree'}, \$out) };
2435 if ($self->{'TRIM'}) {
2436 $out =~ s{ \s+ $ }{}x;
2437 $out =~ s{ ^ \s+ }{}x;
2438 }
2439
2440 ### handle exceptions
2441 if (my $err = $@) {
2442 $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
2443 $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
2444 }
2445
2446 }
2447
2448 ### append any output
2449 $$out_ref .= $out;
2450 if (my $err = $@) {
2451 die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
2452 }
2453 }
2454
2455 return;
2456 }
2457
2458 sub play_RAWPERL {
2459 my ($self, $info, $node, $out_ref) = @_;
2460 $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
2461
2462 ### fill in any variables
2463 my $tree = $node->[4] || return;
2464 my $perl = '';
2465 $self->execute_tree($tree, \$perl);
2466 $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
2467
2468 ### try the code
2469 my $err;
2470 my $output = '';
2471 eval {
2472 package CGI::Ex::Template::Perl;
2473
2474 my $context = $self->context;
2475 my $stash = $context->stash;
2476
2477 eval $perl;
2478 $err = $@;
2479 };
2480 $err ||= $@;
2481
2482 $$out_ref .= $output;
2483
2484 if ($err) {
2485 $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
2486 die $err;
2487 }
2488
2489 return;
2490 }
2491
2492 sub parse_SET {
2493 my ($self, $str_ref, $node, $initial_op, $initial_var) = @_;
2494 my @SET;
2495 my $func;
2496
2497 if ($initial_op) {
2498 if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcx # find a word
2499 && ((pos($$str_ref) -= length($1)) || 1) # always revert
2500 && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing
2501 $node->[6] = 1; # set a flag to keep parsing
2502 my $val = $node->[4] ||= []; # setup storage
2503 return [[$initial_op, $initial_var, $val]];
2504 } else { # get a normal variable
2505 return [[$initial_op, $initial_var, $self->parse_expr($str_ref)]];
2506 }
2507 }
2508
2509 while (1) {
2510 my $set = $self->parse_expr($str_ref);
2511 last if ! defined $set;
2512
2513 if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? \s* }gcx) {
2514 my $op = $1;
2515 if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcx # find a word
2516 && ((pos($$str_ref) -= length($1)) || 1) # always revert
2517 && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing
2518 $node->[6] = 1; # set a flag to keep parsing
2519 my $val = $node->[4] ||= []; # setup storage
2520 push @SET, [$op, $set, $val];
2521 last;
2522 } else { # get a normal variable
2523 push @SET, [$op, $set, $self->parse_expr($str_ref)];
2524 }
2525 } else {
2526 push @SET, ['=', $set, undef];
2527 }
2528 }
2529
2530 return \@SET;
2531 }
2532
2533 sub play_SET {
2534 my ($self, $set, $node) = @_;
2535 foreach (@$set) {
2536 my ($op, $set, $val) = @$_;
2537 if (! defined $val) { # not defined
2538 $val = '';
2539 } elsif ($node->[4] && $val == $node->[4]) { # a captured directive
2540 my $sub_tree = $node->[4];
2541 $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK';
2542 $val = '';
2543 $self->execute_tree($sub_tree, \$val);
2544 } else { # normal var
2545 $val = $self->play_expr($val);
2546 }
2547
2548 if ($OP_DISPATCH->{$op}) {
2549 local $^W;
2550 $val = $OP_DISPATCH->{$op}->($self->play_expr($set), $val);
2551 }
2552
2553 $self->set_variable($set, $val);
2554 }
2555 return;
2556 }
2557
2558 sub parse_SWITCH { $DIRECTIVES->{'GET'}->[0]->(@_) }
2559
2560 sub play_SWITCH {
2561 my ($self, $var, $node, $out_ref) = @_;
2562
2563 my $val = $self->play_expr($var);
2564 $val = '' if ! defined $val;
2565 ### $node->[4] is thrown away
2566
2567 my $default;
2568 while ($node = $node->[5]) { # CASES
2569 my $var = $node->[3];
2570 if (! defined $var) {
2571 $default = $node->[4];
2572 next;
2573 }
2574
2575 my $val2 = $self->play_expr($var);
2576 $val2 = [$val2] if ! UNIVERSAL::isa($val2, 'ARRAY');
2577 for my $test (@$val2) { # find matching values
2578 next if ! defined $val && defined $test;
2579 next if defined $val && ! defined $test;
2580 if ($val ne $test) { # check string-wise first - then numerical
2581 next if $val !~ m{ ^ -? $QR_NUM $ }ox;
2582 next if $test !~ m{ ^ -? $QR_NUM $ }ox;
2583 next if $val != $test;
2584 }
2585
2586 my $body_ref = $node->[4] ||= [];
2587 $self->execute_tree($body_ref, $out_ref);
2588 return;
2589 }
2590 }
2591
2592 if ($default) {
2593 $self->execute_tree($default, $out_ref);
2594 }
2595
2596 return;
2597 }
2598
2599 sub parse_THROW {
2600 my ($self, $str_ref, $node) = @_;
2601 my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"});
2602 $self->throw('parse.missing', "Missing name in THROW", $node, pos($$str_ref)) if ! $name;
2603 my $args = $self->parse_args($str_ref, {named_at_front => 1});
2604 return [$name, $args];
2605 }
2606
2607 sub play_THROW {
2608 my ($self, $ref, $node) = @_;
2609 my ($name, $args) = @$ref;
2610
2611 $name = $self->play_expr($name);
2612
2613 my $named = shift @$args;
2614 push @$args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
2615
2616 my @args = $args ? map { $self->play_expr($_) } @$args : ();
2617 $self->throw($name, \@args, $node);
2618 }
2619
2620 sub play_TRY {
2621 my ($self, $foo, $node, $out_ref) = @_;
2622 my $out = '';
2623
2624 my $body_ref = $node->[4];
2625 eval { $self->execute_tree($body_ref, \$out) };
2626 my $err = $@;
2627
2628 if (! $node->[5]) { # no catch or final
2629 if (! $err) { # no final block and no error
2630 $$out_ref .= $out;
2631 return;
2632 }
2633 $self->throw('parse.missing', "Missing CATCH block", $node);
2634 }
2635 if ($err) {
2636 $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
2637 if ($err->type =~ /stop|return/) {
2638 $$out_ref .= $out;
2639 die $err;
2640 }
2641 }
2642
2643 ### loop through the nested catch and final blocks
2644 my $catch_body_ref;
2645 my $last_found;
2646 my $type = $err ? $err->type : '';
2647 my $final;
2648 while ($node = $node->[5]) { # CATCH
2649 if ($node->[0] eq 'FINAL') {
2650 $final = $node->[4];
2651 next;
2652 }
2653 next if ! $err;
2654 my $name = $self->play_expr($node->[3]);
2655 $name = '' if ! defined $name || lc($name) eq 'default';
2656 if ($type =~ / ^ \Q$name\E \b /x
2657 && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins
2658 $catch_body_ref = $node->[4] || [];
2659 $last_found = $name;
2660 }
2661 }
2662
2663 ### play the best catch block
2664 if ($err) {
2665 if (! $catch_body_ref) {
2666 $$out_ref .= $out;
2667 die $err;
2668 }
2669 local $self->{'_vars'}->{'error'} = $err;
2670 local $self->{'_vars'}->{'e'} = $err;
2671 eval { $self->execute_tree($catch_body_ref, \$out) };
2672 if (my $err = $@) {
2673 $$out_ref .= $out;
2674 die $err;
2675 }
2676 }
2677
2678 ### the final block
2679 $self->execute_tree($final, \$out) if $final;
2680
2681 $$out_ref .= $out;
2682
2683 return;
2684 }
2685
2686 sub parse_UNLESS {
2687 my $ref = $DIRECTIVES->{'IF'}->[0]->(@_);
2688 return [[undef, '!', $ref], 0];
2689 }
2690
2691 sub play_UNLESS { return $DIRECTIVES->{'IF'}->[1]->(@_) }
2692
2693 sub parse_USE {
2694 my ($self, $str_ref) = @_;
2695
2696 my $var;
2697 my $mark = pos $$str_ref;
2698 if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))
2699 && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment
2700 || ((pos($$str_ref) = $mark) && 0)) # otherwise we need to rollback
2701 ) {
2702 $var = $_var;
2703 }
2704
2705 my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"});
2706 $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module;
2707 $module =~ s/\./::/g;
2708
2709 my $args;
2710 my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo;
2711 $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1});
2712
2713 if ($open) {
2714 $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
2715 }
2716
2717 return [$var, $module, $args];
2718 }
2719
2720 sub play_USE {
2721 my ($self, $ref, $node, $out_ref) = @_;
2722 my ($var, $module, $args) = @$ref;
2723
2724 ### get the stash storage location - default to the module
2725 $var = $module if ! defined $var;
2726 my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
2727 pop @var; # remove the trailing '.'
2728
2729 my $named = shift @$args;
2730 push @$args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
2731
2732 ### look for a plugin_base
2733 my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
2734 my $obj;
2735
2736 foreach my $base (ref($BASE) eq 'ARRAY' ? @$BASE : $BASE) {
2737 my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
2738 : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
2739 : "${base}::${module}";
2740 my $require = "$package.pm";
2741 $require =~ s|::|/|g;
2742
2743 ### try and load the module - fall back to bare module if allowed
2744 if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
2745 my $shape = $package->load;
2746 my $context = $self->context;
2747 my @args = $args ? map { $self->play_expr($_) } @$args : ();
2748 $obj = $shape->new($context, @args);
2749 } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
2750 $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($args->[0]) : []);
2751 } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
2752 foreach my $package (@packages) {
2753 my $require = "$package.pm";
2754 $require =~ s|::|/|g;
2755 eval {require $require} || next;
2756 my $shape = $package->load;
2757 my $context = $self->context;
2758 my @args = $args ? map { $self->play_expr($_) } @$args : ();
2759 $obj = $shape->new($context, @args);
2760 }
2761 } elsif ($self->{'LOAD_PERL'}) {
2762 my $require = "$module.pm";
2763 $require =~ s|::|/|g;
2764 if (eval {require $require}) {
2765 my @args = $args ? map { $self->play_expr($_) } @$args : ();
2766 $obj = $module->new(@args);
2767 }
2768 }
2769 }
2770 if (! defined $obj) {
2771 my $err = "$module: plugin not found";
2772 $self->throw('plugin', $err);
2773 }
2774
2775 ### all good
2776 $self->set_variable(\@var, $obj);
2777
2778 return;
2779 }
2780
2781 sub parse_VIEW {
2782 my ($self, $str_ref) = @_;
2783
2784 my $ref = $self->parse_args($str_ref, {
2785 named_at_front => 1,
2786 require_arg => 1,
2787 });
2788
2789 return $ref;
2790 }
2791 #sub parse_VIEW { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
2792
2793 sub play_VIEW {
2794 my ($self, $ref, $node, $out_ref) = @_;
2795
2796 my ($blocks, $args, $name) = @$ref;
2797
2798 ### get args ready
2799 # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
2800 $args = $args->[0];
2801 my $hash = {};
2802 foreach (my $i = 2; $i < @$args; $i+=2) {
2803 my $key = $args->[$i];
2804 my $val = $self->play_expr($args->[$i+1]);
2805 if (ref $key) {
2806 if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
2807 $key = $key->[0];
2808 } else {
2809 $self->set_variable($key, $val);
2810 next; # what TT does
2811 }
2812 }
2813 $hash->{$key} = $val;
2814 }
2815
2816 ### prepare the blocks
2817 my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : '';
2818 foreach my $key (keys %$blocks) {
2819 $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}};
2820 }
2821 $hash->{'blocks'} = $blocks;
2822
2823 ### get the view
2824 if (! eval { require Template::View }) {
2825 $self->throw('view', 'Could not load Template::View library');
2826 }
2827 my $view = Template::View->new($self->context, $hash)
2828 || $self->throw('view', $Template::View::ERROR);
2829
2830 ### 'play it'
2831 my $old_view = $self->play_expr(['view', 0]);
2832 $self->set_variable($name, $view);
2833 $self->set_variable(['view', 0], $view);
2834
2835 if ($node->[4]) {
2836 my $out = '';
2837 $self->execute_tree($node->[4], \$out);
2838 # throw away $out
2839 }
2840
2841 $self->set_variable(['view', 0], $old_view);
2842 $view->seal;
2843
2844 return '';
2845 }
2846
2847 sub parse_WHILE { $DIRECTIVES->{'IF'}->[0]->(@_) }
2848
2849 sub play_WHILE {
2850 my ($self, $var, $node, $out_ref) = @_;
2851 return '' if ! defined $var;
2852
2853 my $sub_tree = $node->[4];
2854
2855 ### iterate use the iterator object
2856 my $count = $WHILE_MAX;
2857 while (--$count > 0) {
2858
2859 $self->play_expr($var) || last;
2860
2861 ### execute the sub tree
2862 eval { $self->execute_tree($sub_tree, $out_ref) };
2863 if (my $err = $@) {
2864 if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
2865 next if $err->type =~ /next/;
2866 last if $err->type =~ /last|break/;
2867 }
2868 die $err;
2869 }
2870 }
2871 die "WHILE loop terminated (> $WHILE_MAX iterations)\n" if ! $count;
2872
2873 return undef;
2874 }
2875
2876 sub parse_WRAPPER { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
2877
2878 sub play_WRAPPER {
2879 my ($self, $args, $node, $out_ref) = @_;
2880 my $sub_tree = $node->[4] || return;
2881
2882 my ($named, @files) = @$args;
2883
2884 my $out = '';
2885 $self->execute_tree($sub_tree, \$out);
2886
2887 foreach my $name (reverse @files) {
2888 local $self->{'_vars'}->{'content'} = $out;
2889 $out = '';
2890 $DIRECTIVES->{'INCLUDE'}->[1]->($self, [$named, $name], $node, \$out);
2891 }
2892
2893 $$out_ref .= $out;
2894 return;
2895 }
2896
2897 ###----------------------------------------------------------------###
2898
2899 sub _vars {
2900 my $self = shift;
2901 $self->{'_vars'} = shift if $#_ == 0;
2902 return $self->{'_vars'} ||= {};
2903 }
2904
2905 sub include_filename {
2906 my ($self, $file) = @_;
2907 if ($file =~ m|^/|) {
2908 $self->throw('file', "$file absolute paths are not allowed (set ABSOLUTE option)") if ! $self->{'ABSOLUTE'};
2909 return $file if -e $file;
2910 } elsif ($file =~ m{(^|/)\.\./}) {
2911 $self->throw('file', "$file relative paths are not allowed (set RELATIVE option)") if ! $self->{'RELATIVE'};
2912 return $file if -e $file;
2913 }
2914
2915 my $paths = $self->{'INCLUDE_PATHS'} ||= do {
2916 # TT does this everytime a file is looked up - we are going to do it just in time - the first time
2917 my $paths = $self->{'INCLUDE_PATH'} || [];
2918 $paths = $paths->() if UNIVERSAL::isa($paths, 'CODE');
2919 $paths = $self->split_paths($paths) if ! UNIVERSAL::isa($paths, 'ARRAY');
2920 $paths; # return of the do
2921 };
2922 foreach my $path (@$paths) {
2923 return "$path/$file" if -e "$path/$file";
2924 }
2925
2926 $self->throw('file', "$file: not found");
2927 }
2928
2929 sub split_paths {
2930 my ($self, $path) = @_;
2931 return $path if ref $path;
2932 my $delim = $self->{'DELIMITER'} || ':';
2933 $delim = ($delim eq ':' && $^O eq 'MSWin32') ? qr|:(?!/)| : qr|\Q$delim\E|;
2934 return [split $delim, $path];
2935 }
2936
2937 sub _insert {
2938 my ($self, $file) = @_;
2939 return $self->slurp($self->include_filename($file));
2940 }
2941
2942 sub slurp {
2943 my ($self, $file) = @_;
2944 local *FH;
2945 open(FH, "<$file") || $self->throw('file', "$file couldn't be opened: $!");
2946 read FH, my $txt, -s $file;
2947 close FH;
2948 return $txt;
2949 }
2950
2951 sub process_simple {
2952 my $self = shift;
2953 my $in = shift || die "Missing input";
2954 my $swap = shift || die "Missing variable hash";
2955 my $out = shift || die "Missing output string ref";
2956
2957 eval {
2958 delete $self->{'_debug_off'};
2959 delete $self->{'_debug_format'};
2960 local $self->{'_start_top_level'} = 1;
2961 $self->_process($in, $swap, $out);
2962 };
2963 if (my $err = $@) {
2964 if ($err->type !~ /stop|return|next|last|break/) {
2965 $self->{'error'} = $err;
2966 return;
2967 }
2968 }
2969 return 1;
2970 }
2971
2972 sub process {
2973 my ($self, $in, $swap, $out, @ARGS) = @_;
2974 delete $self->{'error'};
2975
2976 my $args;
2977 $args = ($#ARGS == 0 && UNIVERSAL::isa($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS;
2978 $self->DEBUG("set binmode\n") if $DEBUG && $args->{'binmode'}; # holdover for TT2 tests
2979
2980 ### get the content
2981 my $content;
2982 if (ref $in) {
2983 if (UNIVERSAL::isa($in, 'SCALAR')) { # reference to a string
2984 $content = $in;
2985 } elsif (UNIVERSAL::isa($in, 'CODE')) {
2986 $content = $in->();
2987 $content = \$content;
2988 } else { # should be a file handle
2989 local $/ = undef;
2990 $content = <$in>;
2991 $content = \$content;
2992 }
2993 } else {
2994 ### should be a filename
2995 $content = $in;
2996 }
2997
2998
2999 ### prepare block localization
3000 my $blocks = $self->{'BLOCKS'} ||= {};
3001
3002
3003 ### do the swap
3004 my $output = '';
3005 eval {
3006
3007 ### localize the stash
3008 $swap ||= {};
3009 my $var1 = $self->{'_vars'} ||= {};
3010 my $var2 = $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {};
3011 $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing
3012 my $copy = {%$var2, %$var1, %$swap};
3013
3014 local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore
3015
3016 delete $self->{'_debug_off'};
3017 delete $self->{'_debug_format'};
3018
3019 ### handle pre process items that go before every document
3020 if ($self->{'PRE_PROCESS'}) {
3021 foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) {
3022 my $out = '';
3023 $self->_process($name, $copy, \$out);
3024 $output = $out . $output;
3025 }
3026 }
3027
3028 ### handle the process config - which loads a template in place of the real one
3029 if (exists $self->{'PROCESS'}) {
3030 ### load the meta data for the top document
3031 my $doc = $self->load_parsed_tree($content) || {};
3032 my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META')
3033 ? $doc->{'_tree'}->[0]->[3] : {};
3034
3035 local $self->{'_template'} = $doc;
3036 @{ $doc }{keys %$meta} = values %$meta;
3037
3038 ### process any other templates
3039 foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) {
3040 next if ! length $name;
3041 $self->_process($name, $copy, \$output);
3042 }
3043
3044 ### handle "normal" content
3045 } else {
3046 local $self->{'_start_top_level'} = 1;
3047 $self->_process($content, $copy, \$output);
3048 }
3049
3050
3051 ### handle post process items that go after every document
3052 if ($self->{'POST_PROCESS'}) {
3053 foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) {
3054 $self->_process($name, $copy, \$output);
3055 }
3056 }
3057
3058 };
3059 if (my $err = $@) {
3060 $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
3061 if ($err->type !~ /stop|return|next|last|break/) {
3062 $self->{'error'} = $err;
3063 return;
3064 }
3065 }
3066
3067
3068
3069 ### clear blocks as asked (AUTO_RESET) defaults to on
3070 $self->{'BLOCKS'} = $blocks if exists($self->{'AUTO_RESET'}) && ! $self->{'AUTO_RESET'};
3071
3072 ### send the content back out
3073 $out ||= $self->{'OUTPUT'};
3074 if (ref $out) {
3075 if (UNIVERSAL::isa($out, 'CODE')) {
3076 $out->($output);
3077 } elsif (UNIVERSAL::can($out, 'print')) {
3078 $out->print($output);
3079 } elsif (UNIVERSAL::isa($out, 'SCALAR')) { # reference to a string
3080 $$out = $output;
3081 } elsif (UNIVERSAL::isa($out, 'ARRAY')) {
3082 push @$out, $output;
3083 } else { # should be a file handle
3084 print $out $output;
3085 }
3086 } elsif ($out) { # should be a filename
3087 my $file;
3088 if ($out =~ m|^/|) {
3089 if (! $self->{'ABSOLUTE'}) {
3090 $self->{'error'} = $self->throw('file', "ABSOLUTE paths disabled");
3091 } else {
3092 $file = $out;
3093 }
3094 } elsif ($out =~ m|^\.\.?/|) {
3095 if (! $self->{'RELATIVE'}) {
3096 $self->{'error'} = $self->throw('file', "RELATIVE paths disabled");
3097 } else {
3098 $file = $out;
3099 }
3100 } else {
3101 if (! $self->{'OUTPUT_PATH'}) {
3102 $self->{'error'} = $self->throw('file', "OUTPUT_PATH not set");
3103 } else {
3104 $file = $self->{'OUTPUT_PATH'} . '/' . $out;
3105 }
3106 }
3107 if ($file) {
3108 local *FH;
3109 if (open FH, ">$file") {
3110 if (my $bm = $args->{'binmode'}) {
3111 if (+$bm == 1) { binmode FH }
3112 else { binmode FH, $bm }
3113 }
3114 print FH $output;
3115 close FH;
3116 } else {
3117 $self->{'error'} = $self->throw('file', "$out couldn't be opened for writing: $!");
3118 }
3119 }
3120 } else {
3121 print $output;
3122 }
3123
3124 return if $self->{'error'};
3125 return 1;
3126 }
3127
3128 sub error { shift->{'error'} }
3129
3130 sub DEBUG {
3131 my $self = shift;
3132 print STDERR "DEBUG: ", @_;
3133 }
3134
3135 ###----------------------------------------------------------------###
3136
3137 sub exception {
3138 my $self = shift;
3139 my $type = shift;
3140 my $info = shift;
3141 return $type if ref($type) =~ /Template::Exception$/;
3142 if (ref($info) eq 'ARRAY') {
3143 my $hash = ref($info->[-1]) eq 'HASH' ? pop(@$info) : {};
3144 if (@$info >= 2 || scalar keys %$hash) {
3145 my $i = 0;
3146 $hash->{$_} = $info->[$_] for 0 .. $#$info;
3147 $hash->{'args'} = $info;
3148 $info = $hash;
3149 } elsif (@$info == 1) {
3150 $info = $info->[0];
3151 } else {
3152 $info = $type;
3153 $type = 'undef';
3154 }
3155 }
3156 return $PACKAGE_EXCEPTION->new($type, $info, @_);
3157 }
3158
3159 sub throw { die shift->exception(@_) }
3160
3161 sub context {
3162 my $self = shift;
3163 return bless {_template => $self}, $PACKAGE_CONTEXT; # a fake context
3164 }
3165
3166 sub undefined_get {
3167 my ($self, $ident, $node) = @_;
3168 return $self->{'UNDEFINED_GET'}->($self, $ident, $node) if $self->{'UNDEFINED_GET'};
3169 return '';
3170 }
3171
3172 sub undefined_any {
3173 my ($self, $ident) = @_;
3174 return $self->{'UNDEFINED_ANY'}->($self, $ident) if $self->{'UNDEFINED_ANY'};
3175 return;
3176 }
3177
3178 sub list_filters {
3179 my $self = shift;
3180 return $self->{'_filters'} ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {};
3181 }
3182
3183 sub list_plugins {
3184 my $self = shift;
3185 my $args = shift || {};
3186 my $base = $args->{'base'} || '';
3187
3188 return $self->{'_plugins'}->{$base} ||= do {
3189 my @plugins;
3190
3191 $base =~ s|::|/|g;
3192 my @dirs = grep {-d $_} map {"$_/$base"} @INC;
3193
3194 foreach my $dir (@dirs) {
3195 require File::Find;
3196 File::Find::find(sub {
3197 my $mod = $base .'/'. ($File::Find::name =~ m|^ $dir / (.*\w) \.pm $|x ? $1 : return);
3198 $mod =~ s|/|::|g;
3199 push @plugins, $mod;
3200 }, $dir);
3201 }
3202
3203 \@plugins; # return of the do
3204 };
3205 }
3206
3207 sub debug_node {
3208 my ($self, $node) = @_;
3209 my $info = $self->node_info($node);
3210 my $format = $self->{'_debug_format'} || $self->{'DEBUG_FORMAT'} || "\n## \$file line \$line : [% \$text %] ##\n";
3211 $format =~ s{\$(file|line|text)}{$info->{$1}}g;
3212 return $format;
3213 }
3214
3215 sub node_info {
3216 my ($self, $node) = @_;
3217 my $doc = $self->{'_component'};
3218 my $i = $node->[1];
3219 my $j = $node->[2] || return ''; # META can be 0
3220 $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
3221 my $s = substr(${ $doc->{'_content'} }, $i, $j - $i);
3222 $s =~ s/^\s+//;
3223 $s =~ s/\s+$//;
3224 return {
3225 file => $doc->{'name'},
3226 line => $self->get_line_number_by_index($doc, $i),
3227 text => $s,
3228 };
3229 }
3230
3231 sub get_line_number_by_index {
3232 my ($self, $doc, $index, $include_char) = @_;
3233 return 1 if $index <= 0;
3234
3235 ### get the line offsets for the doc
3236 my $lines = $doc->{'_line_offsets'} ||= do {
3237 $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
3238 my $i = 0;
3239 my @lines = (0);
3240 while (1) {
3241 $i = index(${ $doc->{'_content'} }, "\n", $i) + 1;
3242 last if $i == 0;
3243 push @lines, $i;
3244 }
3245 \@lines;
3246 };
3247
3248 ### binary search them (this is fast even on big docs)
3249 my ($i, $j) = (0, $#$lines);
3250 if ($index > $lines->[-1]) {
3251 $i = $j;
3252 } else {
3253 while (1) {
3254 last if abs($i - $j) <= 1;
3255 my $k = int(($i + $j) / 2);
3256 $j = $k if $lines->[$k] >= $index;
3257 $i = $k if $lines->[$k] <= $index;
3258 }
3259 }
3260 return $include_char ? ($i + 1, $index - $lines->[$i]) : $i + 1;
3261 }
3262
3263 ###----------------------------------------------------------------###
3264 ### long virtual methods or filters
3265 ### many of these vmethods have used code from Template/Stash.pm to
3266 ### assure conformance with the TT spec.
3267
3268 sub define_vmethod {
3269 my ($self, $type, $name, $sub) = @_;
3270 if ( $type =~ /scalar|item/i) { $SCALAR_OPS->{$name} = $sub }
3271 elsif ($type =~ /array|list/i ) { $LIST_OPS->{ $name} = $sub }
3272 elsif ($type =~ /hash/i ) { $HASH_OPS->{ $name} = $sub }
3273 elsif ($type =~ /filter/i ) { $FILTER_OPS->{$name} = $sub }
3274 else {
3275 die "Invalid type vmethod type $type";
3276 }
3277 return 1;
3278 }
3279
3280 sub vmethod_fmt_scalar {
3281 my $str = shift; $str = '' if ! defined $str;
3282 my $pat = shift; $pat = '%s' if ! defined $pat;
3283 local $^W;
3284 return @_ ? sprintf($pat, $_[0], $str)
3285 : sprintf($pat, $str);
3286 }
3287
3288 sub vmethod_fmt_list {
3289 my $ref = shift || return '';
3290 my $pat = shift; $pat = '%s' if ! defined $pat;
3291 my $sep = shift; $sep = ' ' if ! defined $sep;
3292 local $^W;
3293 return @_ ? join($sep, map {sprintf $pat, $_[0], $_} @$ref)
3294 : join($sep, map {sprintf $pat, $_} @$ref);
3295 }
3296
3297 sub vmethod_fmt_hash {
3298 my $ref = shift || return '';
3299 my $pat = shift; $pat = "%s\t%s" if ! defined $pat;
3300 my $sep = shift; $sep = "\n" if ! defined $sep;
3301 local $^W;
3302 return ! @_ ? join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref)
3303 : @_ == 1 ? join($sep, map {sprintf $pat, $_[0], $_, $ref->{$_}} sort keys %$ref) # don't get to pick - it applies to the key
3304 : join($sep, map {sprintf $pat, $_[0], $_, $_[1], $ref->{$_}} sort keys %$ref);
3305 }
3306
3307 sub vmethod_chunk {
3308 my $str = shift;
3309 my $size = shift || 1;
3310 my @list;
3311 if ($size < 0) { # chunk from the opposite end
3312 $str = reverse $str;
3313 $size = -$size;
3314 unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg;
3315 } else {
3316 push(@list, $1) while $str =~ /( .{$size} | .+ )/xg;
3317 }
3318 return \@list;
3319 }
3320
3321 sub vmethod_indent {
3322 my $str = shift; $str = '' if ! defined $str;
3323 my $pre = shift; $pre = 4 if ! defined $pre;
3324 $pre = ' ' x $pre if $pre =~ /^\d+$/;
3325 $str =~ s/^/$pre/mg;
3326 return $str;
3327 }
3328
3329 sub vmethod_format {
3330 my $str = shift; $str = '' if ! defined $str;
3331 my $pat = shift; $pat = '%s' if ! defined $pat;
3332 if (@_) {
3333 return join "\n", map{ sprintf $pat, $_[0], $_ } split(/\n/, $str);
3334 } else {
3335 return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
3336 }
3337 }
3338
3339 sub vmethod_list_hash {
3340 my ($hash, $what) = @_;
3341 $what = 'pairs' if ! $what || $what !~ /^(keys|values|each|pairs)$/;
3342 return $HASH_OPS->{$what}->($hash);
3343 }
3344
3345
3346 sub vmethod_match {
3347 my ($str, $pat, $global) = @_;
3348 return [] if ! defined $str || ! defined $pat;
3349 my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
3350 return @res ? \@res : '';
3351 }
3352
3353 sub vmethod_nsort {
3354 my ($list, $field) = @_;
3355 return defined($field)
3356 ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field}
3357 : UNIVERSAL::can($_, $field) ? $_->$field()
3358 : $_)]} @$list ]
3359 : [sort {$a <=> $b} @$list];
3360 }
3361
3362 sub vmethod_pick {
3363 my $ref = shift;
3364 no warnings;
3365 my $n = int(shift);
3366 $n = 1 if $n < 1;
3367 my @ind = map { $ref->[ rand @$ref ] } 1 .. $n;
3368 return $n == 1 ? $ind[0] : \@ind;
3369 }
3370
3371 sub vmethod_repeat {
3372 my ($str, $n, $join) = @_;
3373 return '' if ! defined $str || ! length $str;
3374 $n = 1 if ! defined($n) || ! length $n;
3375 $join = '' if ! defined $join;
3376 return join $join, ($str) x $n;
3377 }
3378
3379 ### This method is a combination of my submissions along
3380 ### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum
3381 sub vmethod_replace {
3382 my ($text, $pattern, $replace, $global) = @_;
3383 $text = '' unless defined $text;
3384 $pattern = '' unless defined $pattern;
3385 $replace = '' unless defined $replace;
3386 $global = 1 unless defined $global;
3387 my $expand = sub {
3388 my ($chunk, $start, $end) = @_;
3389 $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{
3390 $1 ? $1
3391 : ($2 > $#$start || $2 == 0) ? ''
3392 : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
3393 }exg;
3394 $chunk;
3395 };
3396 if ($global) {
3397 $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg;
3398 } else {
3399 $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e;
3400 }
3401 return $text;
3402 }
3403
3404 sub vmethod_sort {
3405 my ($list, $field) = @_;
3406 return defined($field)
3407 ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field}
3408 : UNIVERSAL::can($_, $field) ? $_->$field()
3409 : $_)]} @$list ]
3410 : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive
3411 }
3412
3413 sub vmethod_splice {
3414 my ($ref, $i, $len, @replace) = @_;
3415 @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
3416 if (defined $len) {
3417 return [splice @$ref, $i || 0, $len, @replace];
3418 } elsif (defined $i) {
3419 return [splice @$ref, $i];
3420 } else {
3421 return [splice @$ref];
3422 }
3423 }
3424
3425 sub vmethod_split {
3426 my ($str, $pat, $lim) = @_;
3427 $str = '' if ! defined $str;
3428 if (defined $lim) { return defined $pat ? [split $pat, $str, $lim] : [split ' ', $str, $lim] }
3429 else { return defined $pat ? [split $pat, $str ] : [split ' ', $str ] }
3430 }
3431
3432 sub vmethod_substr {
3433 my ($str, $i, $len, $replace) = @_;
3434 $i ||= 0;
3435 return substr($str, $i) if ! defined $len;
3436 return substr($str, $i, $len) if ! defined $replace;
3437 substr($str, $i, $len, $replace);
3438 return $str;
3439 }
3440
3441 sub vmethod_uri {
3442 my $str = shift;
3443 utf8::encode($str) if defined &utf8::encode;
3444 $str =~ s/([^A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg;
3445 return $str;
3446 }
3447
3448 sub vmethod_url {
3449 my $str = shift;
3450 utf8::encode($str) if defined &utf8::encode;
3451 $str =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg;
3452 return $str;
3453 }
3454
3455 sub filter_eval {
3456 my $context = shift;
3457
3458 return sub {
3459 ### prevent recursion
3460 my $t = $context->_template;
3461 local $t->{'_eval_recurse'} = $t->{'_eval_recurse'} || 0;
3462 $context->throw('eval_recurse', "MAX_EVAL_RECURSE $MAX_EVAL_RECURSE reached")
3463 if ++$t->{'_eval_recurse'} > ($t->{'MAX_EVAL_RECURSE'} || $MAX_EVAL_RECURSE);
3464
3465
3466 my $text = shift;
3467 return $context->process(\$text);
3468 };
3469 }
3470
3471 sub filter_redirect {
3472 my ($context, $file, $options) = @_;
3473 my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set');
3474 $context->throw('redirect', 'Invalid filename - cannot include "/../"')
3475 if $file =~ m{(^|/)\.\./};
3476
3477 return sub {
3478 my $text = shift;
3479 if (! -d $path) {
3480 require File::Path;
3481 File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
3482 }
3483 local *FH;
3484 open (FH, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
3485 if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) {
3486 if (+$bm == 1) { binmode FH }
3487 else { binmode FH, $bm}
3488 }
3489 print FH $text;
3490 close FH;
3491 return '';
3492 };
3493 }
3494
3495 ###----------------------------------------------------------------###
3496
3497 sub dump_parse {
3498 my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
3499 my $str = shift;
3500 require Data::Dumper;
3501 return Data::Dumper::Dumper($obj->parse_tree(\$str));
3502 }
3503
3504 sub dump_parse_expr {
3505 my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
3506 my $str = shift;
3507 require Data::Dumper;
3508 return Data::Dumper::Dumper($obj->parse_expr(\$str));
3509 }
3510
3511 ###----------------------------------------------------------------###
3512
3513 package CGI::Ex::Template::Exception;
3514
3515 use overload
3516 '""' => \&as_string,
3517 bool => sub { defined shift },
3518 fallback => 1;
3519
3520 sub new {
3521 my ($class, $type, $info, $node, $pos, $doc) = @_;
3522 return bless [$type, $info, $node, $pos, $doc], $class;
3523 }
3524
3525 sub type { shift->[0] }
3526
3527 sub info { shift->[1] }
3528
3529 sub node {
3530 my $self = shift;
3531 $self->[2] = shift if @_;
3532 $self->[2];
3533 }
3534
3535 sub offset {
3536 my $self = shift;
3537 $self->[3] = shift if @_;
3538 $self->[3];
3539 }
3540
3541 sub doc {
3542 my $self = shift;
3543 $self->[4] = shift if @_;
3544 $self->[4];
3545 }
3546
3547 sub as_string {
3548 my $self = shift;
3549 if ($self->type =~ /^parse/) {
3550 if (my $doc = $self->doc) {
3551 my ($line, $char) = CGI::Ex::Template->get_line_number_by_index($doc, $self->offset, 'include_char');
3552 return $self->type ." error - $doc->{'name'} line $line char $char: ". $self->info;
3553 } else {
3554 return $self->type .' error - '. $self->info .' (At char '. $self->offset .')';
3555 }
3556 } else {
3557 return $self->type .' error - '. $self->info;
3558 }
3559 }
3560
3561 ###----------------------------------------------------------------###
3562
3563 package CGI::Ex::Template::Iterator;
3564
3565 sub new {
3566 my ($class, $items) = @_;
3567 $items = [] if ! defined $items;
3568 if (UNIVERSAL::isa($items, 'HASH')) {
3569 $items = [ map { {key => $_, value => $items->{ $_ }} } sort keys %$items ];
3570 } elsif (UNIVERSAL::can($items, 'as_list')) {
3571 $items = $items->as_list;
3572 } elsif (! UNIVERSAL::isa($items, 'ARRAY')) {
3573 $items = [$items];
3574 }
3575 return bless [$items, 0], $class;
3576 }
3577
3578 sub get_first {
3579 my $self = shift;
3580 return (undef, 3) if ! @{ $self->[0] };
3581 return ($self->[0]->[$self->[1] = 0], undef);
3582 }
3583
3584 sub get_next {
3585 my $self = shift;
3586 return (undef, 3) if ++ $self->[1] > $#{ $self->[0] };
3587 return ($self->items->[$self->[1]], undef);
3588 }
3589
3590 sub items { shift->[0] }
3591
3592 sub index { shift->[1] }
3593
3594 sub max { $#{ shift->[0] } }
3595
3596 sub size { shift->max + 1 }
3597
3598 sub count { shift->index + 1 }
3599
3600 sub number { shift->index + 1 }
3601
3602 sub first { (shift->index == 0) || 0 }
3603
3604 sub last { my $self = shift; return ($self->index == $self->max) || 0 }
3605
3606 sub prev {
3607 my $self = shift;
3608 return undef if $self->index <= 0;
3609 return $self->items->[$self->index - 1];
3610 }
3611
3612 sub next {
3613 my $self = shift;
3614 return undef if $self->index >= $self->max;
3615 return $self->items->[$self->index + 1];
3616 }
3617
3618 ###----------------------------------------------------------------###
3619
3620 package CGI::Ex::Template::_Context;
3621
3622 use vars qw($AUTOLOAD);
3623
3624 sub _template { shift->{'_template'} || die "Missing _template" }
3625
3626 sub template {
3627 my ($self, $name) = @_;
3628 return $self->_template->{'BLOCKS'}->{$name} || $self->_template->load_parsed_tree($name);
3629 }
3630
3631 sub config { shift->_template }
3632
3633 sub stash {
3634 my $self = shift;
3635 return $self->{'stash'} ||= bless {_template => $self->_template}, $CGI::Ex::Template::PACKAGE_STASH;
3636 }
3637
3638 sub insert { shift->_template->_insert(@_) }
3639
3640 sub eval_perl { shift->_template->{'EVAL_PERL'} }
3641
3642 sub process {
3643 my $self = shift;
3644 my $ref = shift;
3645 my $args = shift || {};
3646
3647 $self->_template->set_variable($_, $args->{$_}) for keys %$args;
3648
3649 my $out = '';
3650 $self->_template->_process($ref, $self->_template->_vars, \$out);
3651 return $out;
3652 }
3653
3654 sub include {
3655 my $self = shift;
3656 my $ref = shift;
3657 my $args = shift || {};
3658
3659 my $t = $self->_template;
3660
3661 my $swap = $t->{'_vars'};
3662 local $t->{'_vars'} = {%$swap};
3663
3664 $t->set_variable($_, $args->{$_}) for keys %$args;
3665
3666 my $out = ''; # have temp item to allow clear to correctly clear
3667 eval { $t->_process($ref, $t->_vars, \$out) };
3668 if (my $err = $@) {
3669 die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
3670 }
3671
3672 return $out;
3673 }
3674
3675 sub define_filter {
3676 my ($self, $name, $filter, $is_dynamic) = @_;
3677 $filter = [ $filter, 1 ] if $is_dynamic;
3678 $self->define_vmethod('filter', $name, $filter);
3679 }
3680
3681 sub filter {
3682 my ($self, $name, $args, $alias) = @_;
3683 my $t = $self->_template;
3684
3685 my $filter;
3686 if (! ref $name) {
3687 $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex::Template::FILTER_OPS->{$name} || $CGI::Ex::Template::SCALAR_OPS->{$name};
3688 $t->throw('filter', $name) if ! $filter;
3689 } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) {
3690 $filter = $name;
3691 } elsif (UNIVERSAL::can($name, 'factory')) {
3692 $filter = $name->factory || $t->throw($name->error);
3693 } else {
3694 $t->throw('undef', "$name: filter not found");
3695 }
3696
3697 if (UNIVERSAL::isa($filter, 'ARRAY')) {
3698 $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
3699 } elsif ($args && @$args) {
3700 my $sub = $filter;
3701 $filter = sub { $sub->(shift, @$args) };
3702 }
3703
3704 $t->{'FILTERS'}->{$alias} = $filter if $alias;
3705
3706 return $filter;
3707 }
3708
3709 sub define_vmethod { shift->_template->define_vmethod(@_) }
3710
3711 sub throw {
3712 my ($self, $type, $info) = @_;
3713
3714 if (UNIVERSAL::isa($type, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
3715 die $type;
3716 } elsif (defined $info) {
3717 $self->_template->throw($type, $info);
3718 } else {
3719 $self->_template->throw('undef', $type);
3720 }
3721 }
3722
3723 sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
3724
3725 sub DESTROY {}
3726
3727 ###----------------------------------------------------------------###
3728
3729 package CGI::Ex::Template::_Stash;
3730
3731 use vars qw($AUTOLOAD);
3732
3733 sub _template { shift->{'_template'} || die "Missing _template" }
3734
3735 sub get {
3736 my ($self, $var) = @_;
3737 if (! ref $var) {
3738 if ($var =~ /^\w+$/) { $var = [$var, 0] }
3739 else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
3740 }
3741 return $self->_template->play_expr($var, {no_dots => 1});
3742 }
3743
3744 sub set {
3745 my ($self, $var, $val) = @_;
3746 if (! ref $var) {
3747 if ($var =~ /^\w+$/) { $var = [$var, 0] }
3748 else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
3749 }
3750 $self->_template->set_variable($var, $val, {no_dots => 1});
3751 return $val;
3752 }
3753
3754 sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
3755
3756 sub DESTROY {}
3757
3758 ###----------------------------------------------------------------###
3759
3760 package CGI::Ex::Template::EvalPerlHandle;
3761
3762 sub TIEHANDLE {
3763 my ($class, $out_ref) = @_;
3764 return bless [$out_ref], $class;
3765 }
3766
3767 sub PRINT {
3768 my $self = shift;
3769 ${ $self->[0] } .= $_ for grep {defined && length} @_;
3770 return 1;
3771 }
3772
3773 ###----------------------------------------------------------------###
3774
3775 1;
3776
3777 ### See the perldoc in CGI/Ex/Template.pod
a CGI utility suite, the anti-framework application framework
This page took 0.361957 seconds and 4 git commands to generate.