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


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