]> Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Template.pm
projects / chaz / p5-CGI-Ex / blob
? search:


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