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