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


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