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