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