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


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