1 package CGI
::Ex
::Template
;
3 ###----------------------------------------------------------------###
4 # See the perldoc in CGI/Ex/Template.pod
5 # Copyright 2006 - Paul Seamons #
6 # Distributed under the Perl Artistic License without warranty #
7 ###----------------------------------------------------------------###
10 use constant trace
=> $ENV{'CET_TRACE'} || 0; # enable for low level tracing
13 $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS $VOBJS
14 $DIRECTIVES $QR_DIRECTIVE
35 $PACKAGE_EXCEPTION $PACKAGE_ITERATOR $PACKAGE_CONTEXT $PACKAGE_STASH $PACKAGE_PERL_HANDLE
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';
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
63 as
=> \
&vmethod_as_scalar
,
64 chunk
=> \
&vmethod_chunk
,
65 collapse
=> sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
67 indent
=> \
&vmethod_indent
,
68 int => sub { local $^W; int $_[0] },
69 'format' => \
&vmethod_format
,
70 hash
=> sub { {value
=> $_[0]} },
71 html
=> sub { local $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; s/\"/"/g; $_ },
72 lcfirst => sub { lcfirst $_[0] },
73 length => sub { defined($_[0]) ? length($_[0]) : 0 },
74 list
=> sub { [$_[0]] },
75 lower
=> sub { lc $_[0] },
76 match
=> \
&vmethod_match
,
77 new
=> sub { defined $_[0] ? $_[0] : '' },
79 rand => sub { local $^W; rand shift },
80 remove
=> sub { vmethod_replace
(shift, shift, '', 1) },
81 repeat
=> \
&vmethod_repeat
,
82 replace
=> \
&vmethod_replace
,
83 search
=> sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return scalar $str =~ /$pat/ },
85 split => \
&vmethod_split
,
86 stderr
=> sub { print STDERR
$_[0]; '' },
87 substr => sub { my ($str, $i, $len) = @_; defined($len) ? substr($str, $i, $len) : substr($str, $i) },
88 trim
=> sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
89 ucfirst => sub { ucfirst $_[0] },
90 upper
=> sub { uc $_[0] },
94 $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops
95 eval => [\
&filter_eval
, 1],
96 evaltt
=> [\
&filter_eval
, 1],
97 file
=> [\
&filter_redirect
, 1],
98 redirect
=> [\
&filter_redirect
, 1],
102 as
=> \
&vmethod_as_list
,
103 first
=> sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
104 grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
105 hash
=> sub { local $^W; my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
106 join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
107 last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]},
108 list
=> sub { $_[0] },
109 max
=> sub { $#{ $_[0] } },
110 merge
=> sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
111 new
=> sub { local $^W; return [@_] },
112 nsort
=> \
&vmethod_nsort
,
113 pop => sub { pop @{ $_[0] } },
114 push => sub { my $ref = shift; push @$ref, @_; return '' },
115 random
=> sub { my $ref = shift; $ref->[ rand @$ref ] },
116 reverse => sub { [ reverse @{ $_[0] } ] },
117 shift => sub { shift @{ $_[0] } },
118 size
=> sub { scalar @{ $_[0] } },
119 slice
=> sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
120 sort => \
&vmethod_sort
,
121 splice => \
&vmethod_splice
,
122 unique
=> sub { my %u; return [ grep { ! $u{$_} ++ } @{ $_[0] } ] },
123 unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
127 as
=> \
&vmethod_as_hash
,
128 defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } },
129 delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } },
130 each => sub { [%{ $_[0] }] },
131 exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
132 hash
=> sub { $_[0] },
133 import
=> sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
134 item
=> sub { my ($h, $k) = @_; return '' if ! defined $k || $k =~ $QR_PRIVATE; $h->{$k} },
135 items
=> sub { [ %{ $_[0] } ] },
136 keys => sub { [keys %{ $_[0] }] },
137 list
=> sub { [$_[0]] },
138 new
=> sub { local $^W; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} },
139 nsort
=> sub { my $ref = shift; [sort {$ref->{$a} <=> $ref->{$b} } keys %$ref] },
140 pairs
=> sub { [map { {key
=> $_, value
=> $_[0]->{$_}} } keys %{ $_[0] } ] },
141 size
=> sub { scalar keys %{ $_[0] } },
142 sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] },
143 values => sub { [values %{ $_[0] }] },
151 foreach (values %$VOBJS) {
152 $_->{'Text'} = $_->{'as'};
153 $_->{'Hash'} = $_->{'hash'};
154 $_->{'List'} = $_->{'list'};
158 #name parse_sub play_sub block postdir continue move_to_front
159 BLOCK
=> [\
&parse_BLOCK
, \
&play_BLOCK
, 1, 0, 0, 1],
160 BREAK
=> [sub {}, \
&play_control
],
161 CALL
=> [\
&parse_CALL
, \
&play_CALL
],
162 CASE
=> [\
&parse_CASE
, undef, 0, 0, {SWITCH
=> 1, CASE
=> 1}],
163 CATCH => [\
&parse_CATCH
, undef, 0, 0, {TRY
=> 1, CATCH => 1}],
164 CLEAR
=> [sub {}, \
&play_CLEAR
],
165 '#' => [sub {}, sub {}],
166 DEBUG
=> [\
&parse_DEBUG
, \
&play_DEBUG
],
167 DEFAULT
=> [\
&parse_DEFAULT
, \
&play_DEFAULT
],
168 DUMP
=> [\
&parse_DUMP
, \
&play_DUMP
],
169 ELSE
=> [sub {}, undef, 0, 0, {IF
=> 1, ELSIF
=> 1, UNLESS
=> 1}],
170 ELSIF
=> [\
&parse_IF
, undef, 0, 0, {IF
=> 1, ELSIF
=> 1, UNLESS
=> 1}],
171 END => [undef, sub {}],
172 FILTER
=> [\
&parse_FILTER
, \
&play_FILTER
, 1, 1],
173 '|' => [\
&parse_FILTER
, \
&play_FILTER
, 1, 1],
174 FINAL
=> [sub {}, undef, 0, 0, {TRY
=> 1, CATCH => 1}],
175 FOR
=> [\
&parse_FOREACH
, \
&play_FOREACH
, 1, 1],
176 FOREACH
=> [\
&parse_FOREACH
, \
&play_FOREACH
, 1, 1],
177 GET
=> [\
&parse_GET
, \
&play_GET
],
178 IF
=> [\
&parse_IF
, \
&play_IF
, 1, 1],
179 INCLUDE
=> [\
&parse_INCLUDE
, \
&play_INCLUDE
],
180 INSERT
=> [\
&parse_INSERT
, \
&play_INSERT
],
181 LAST
=> [sub {}, \
&play_control
],
182 MACRO
=> [\
&parse_MACRO
, \
&play_MACRO
],
183 META
=> [undef, sub {}],
184 METADEF
=> [undef, \
&play_METADEF
],
185 NEXT => [sub {}, \
&play_control
],
186 PERL
=> [\
&parse_PERL
, \
&play_PERL
, 1],
187 PROCESS
=> [\
&parse_PROCESS
, \
&play_PROCESS
],
188 RAWPERL
=> [\
&parse_PERL
, \
&play_RAWPERL
, 1],
189 RETURN
=> [sub {}, \
&play_control
],
190 SET
=> [\
&parse_SET
, \
&play_SET
],
191 STOP
=> [sub {}, \
&play_control
],
192 SWITCH
=> [\
&parse_SWITCH
, \
&play_SWITCH
, 1],
193 TAGS
=> [undef, sub {}],
194 THROW
=> [\
&parse_THROW
, \
&play_THROW
],
195 TRY
=> [sub {}, \
&play_TRY
, 1],
196 UNLESS
=> [\
&parse_UNLESS
, \
&play_UNLESS
, 1, 1],
197 USE
=> [\
&parse_USE
, \
&play_USE
],
198 WHILE
=> [\
&parse_IF
, \
&play_WHILE
, 1, 1],
199 WRAPPER
=> [\
&parse_WRAPPER
, \
&play_WRAPPER
, 1, 1],
200 #name #parse_sub #play_sub #block #postdir #continue #move_to_front
202 $QR_DIRECTIVE = qr{ ^ (\w+|\|) (?= $|[\s;\#]) }x;
204 ### setup the operator parsing
206 # type precedence symbols action (undef means play_operator will handle)
207 ['prefix', 98, ['++'], undef ],
208 ['prefix', 98, ['--'], undef ],
209 ['postfix', 98, ['++'], undef ],
210 ['postfix', 98, ['--'], undef ],
211 ['infix', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ],
212 ['prefix', 93, ['!'], sub { ! $_[0] } ],
213 ['prefix', 93, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
214 ['infix', 90, ['*'], sub { $_[0] * $_[1] } ],
215 ['infix', 90, ['/'], sub { $_[0] / $_[1] } ],
216 ['infix', 90, ['div', 'DIV'], sub { int($_[0] / $_[1]) } ],
217 ['infix', 90, ['%', 'mod', 'MOD'], sub { $_[0] % $_[1] } ],
218 ['infix', 85, ['+'], sub { $_[0] + $_[1] } ],
219 ['infix', 85, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
220 ['infix', 85, ['~', '_'], sub { join "", @_ } ],
221 ['infix', 80, ['<'], sub { $_[0] < $_[1] } ],
222 ['infix', 80, ['>'], sub { $_[0] > $_[1] } ],
223 ['infix', 80, ['<='], sub { $_[0] <= $_[1] } ],
224 ['infix', 80, ['>='], sub { $_[0] >= $_[1] } ],
225 ['infix', 80, ['lt'], sub { $_[0] lt $_[1] } ],
226 ['infix', 80, ['gt'], sub { $_[0] gt $_[1] } ],
227 ['infix', 80, ['le'], sub { $_[0] le $_[1] } ],
228 ['infix', 80, ['ge'], sub { $_[0] ge $_[1] } ],
229 ['infix', 75, ['==', 'eq'], sub { $_[0] eq $_[1] } ],
230 ['infix', 75, ['!=', 'ne'], sub { $_[0] ne $_[1] } ],
231 ['infix', 70, ['&&'], undef ],
232 ['infix', 65, ['||'], undef ],
233 ['infix', 60, ['..'], sub { $_[0] .. $_[1] } ],
234 ['ternary', 55, ['?', ':'], undef ],
235 ['assign', 53, ['+='], sub { $_[0] + $_[1] } ],
236 ['assign', 53, ['-='], sub { $_[0] - $_[1] } ],
237 ['assign', 53, ['*='], sub { $_[0] * $_[1] } ],
238 ['assign', 53, ['/='], sub { $_[0] / $_[1] } ],
239 ['assign', 53, ['%='], sub { $_[0] % $_[1] } ],
240 ['assign', 53, ['**='], sub { $_[0]** $_[1] } ],
241 ['assign', 53, ['~=', '_='], sub { $_[0] . $_[1] } ],
242 ['assign', 52, ['='], undef ],
243 ['prefix', 50, ['not', 'NOT'], sub { ! $_[0] } ],
244 ['infix', 45, ['and', 'AND'], undef ],
245 ['infix', 40, ['or', 'OR'], undef ],
246 ['', 0, ['hash'], sub { return {@_}; } ],
247 ['', 0, ['array'], sub { return [@_] } ],
249 $OP = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] ne 'prefix' } @$OPERATORS}; # all non-prefix
250 $OP_PREFIX = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] eq 'prefix' } @$OPERATORS};
251 $OP_DISPATCH = {map {my $ref = $_; map {$_ => $ref->[3]} @{$ref->[2]}} grep {$_->[3] } @$OPERATORS};
252 $OP_ASSIGN = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'assign' } @$OPERATORS};
253 $OP_POSTFIX = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'postfix'} @$OPERATORS}; # bool is postfix
254 $OP_TERNARY = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'ternary'} @$OPERATORS}; # bool is ternary
255 sub _op_qr
{ # no mixed \w\W operators
257 my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_;
258 my $chr = join '', sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_;
259 my $word = join '|', reverse sort grep {++$used{$_} < 2} grep {/^\w+$/} @_;
260 $chr = "[$chr]" if $chr;
261 $word = "\\b(?:$word)\\b" if $word;
262 return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex";
264 sub _build_op_qr
{ _op_qr
(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS) }
265 sub _build_op_qr_prefix
{ _op_qr
(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS) }
266 sub _build_op_qr_assign
{ _op_qr
(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS) }
267 $QR_OP = _build_op_qr
();
268 $QR_OP_PREFIX = _build_op_qr_prefix
();
269 $QR_OP_ASSIGN = _build_op_qr_assign
();
271 $QR_COMMENTS = '(?-s: \# .* \s*)*';
272 $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\-\.]+ (?:/[\w\-\.]+)*';
273 $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?';
274 $QR_AQ_NOTDOT = "(?! \\s* $QR_COMMENTS \\.)";
275 $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=[;+]) )'; # the + comes into play on filenames
276 $QR_PRIVATE = qr/^_/;
279 $EXTRA_COMPILE_EXT = '.sto';
282 ###----------------------------------------------------------------###
286 my $args = ref($_[0]) ? { %{ shift() } } : {@_};
287 my $self = bless $args, $class;
289 ### "enable" debugging - we only support DEBUG_DIRS and DEBUG_UNDEF
290 if ($self->{'DEBUG'}) {
291 $self->{'_debug_dirs'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/;
292 $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/;
298 ###----------------------------------------------------------------###
303 local $self->{'_vars'} = shift || {};
304 my $out_ref = shift || $self->throw('undef', "Missing output ref");
305 local $self->{'_top_level'} = delete $self->{'_start_top_level'};
306 my $i = length $$out_ref;
308 ### parse and execute
311 ### load the document
312 $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");;
314 ### prevent recursion
315 $self->throw('file', "recursion into '$doc->{name}'")
316 if ! $self->{'RECURSION'} && $self->{'_in'}->{$doc->{'name'}} && $doc->{'name'} ne 'input text';
317 local $self->{'_in'}->{$doc->{'name'}} = 1;
319 ### execute the document
320 if (! @{ $doc->{'_tree'} }) { # no tags found - just return the content
321 $$out_ref = ${ $doc->{'_content'} };
323 local $self->{'_vars'}->{'component'} = $doc;
324 $self->{'_vars'}->{'template'} = $doc if $self->{'_top_level'};
325 $self->execute_tree($doc->{'_tree'}, $out_ref);
326 delete $self->{'_vars'}->{'template'} if $self->{'_top_level'};
330 ### trim whitespace from the beginning and the end of a block or template
331 if ($self->{'TRIM'}) {
332 substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ \s+ $ }{}x; # tail first
333 substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ ^ \s+ }{}x;
336 ### handle exceptions
338 $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
339 $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
340 die $err if ! $self->{'_top_level'} || $err->type !~ /stop|return/;
346 ###----------------------------------------------------------------###
348 sub load_parsed_tree
{
351 return if ! defined $file;
353 my $doc = {name
=> $file};
355 ### looks like a string reference
357 $doc->{'_content'} = $file;
358 $doc->{'name'} = 'input text';
359 $doc->{'is_str_ref'} = 1;
361 ### looks like a previously cached-in-memory document
362 } elsif ($self->{'_documents'}->{$file}
363 && ( ($self->{'_documents'}->{$file}->{'_cache_time'} == time) # don't stat more than once a second
364 || ($self->{'_documents'}->{$file}->{'modtime'}
365 == (stat $self->{'_documents'}->{$file}->{'_filename'})[9]))) {
366 $doc = $self->{'_documents'}->{$file};
367 $doc->{'_cache_time'} = time;
370 ### looks like a block name of some sort
371 } elsif ($self->{'BLOCKS'}->{$file}) {
372 my $block = $self->{'BLOCKS'}->{$file};
374 ### allow for predefined blocks that are a code or a string
375 if (UNIVERSAL
::isa
($block, 'CODE')) {
378 if (! UNIVERSAL
::isa
($block, 'HASH')) {
379 $self->throw('block', "Unsupported BLOCK type \"$block\"") if ref $block;
381 $block = eval { $self->load_parsed_tree(\
$copy) }
382 || $self->throw('block', 'Parse error on predefined block');
384 $doc->{'_tree'} = $block->{'_tree'} || $self->throw('block', "Invalid block definition (missing tree)");
388 ### go and look on the file system
390 $doc->{'_filename'} = eval { $self->include_filename($file) };
392 ### allow for blocks in other files
393 if ($self->{'EXPOSE_BLOCKS'}
394 && ! $self->{'_looking_in_block_file'}) {
395 local $self->{'_looking_in_block_file'} = 1;
397 while ($file =~ s
|/([^/.]+)$||) {
398 $block_name = length($block_name) ? "$1/$block_name" : $1;
399 my $ref = eval { $self->load_parsed_tree($file) } || next;
400 my $_tree = $ref->{'_tree'};
401 foreach my $node (@$_tree) {
403 next if $node->[0] eq 'METADEF';
404 last if $node->[0] ne 'BLOCK';
405 next if $block_name ne $node->[3];
406 $doc->{'_content'} = $ref->{'_content'};
407 $doc->{'_tree'} = $node->[4];
408 $doc->{'modtime'} = $ref->{'modtime'};
409 $file = $ref->{'name'};
413 die $err if ! $doc->{'_tree'};
414 } elsif ($self->{'DEFAULT'}) {
415 $doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) } || die $err;
421 ### no tree yet - look for a file cache
422 if (! $doc->{'_tree'}) {
423 $doc->{'modtime'} = (stat $doc->{'_filename'})[9];
424 if ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) {
425 if ($self->{'COMPILE_DIR'}) {
426 $doc->{'_compile_filename'} = $self->{'COMPILE_DIR'} .'/'. $file;
428 $doc->{'_compile_filename'} = $doc->{'_filename'};
430 $doc->{'_compile_filename'} .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'});
431 $doc->{'_compile_filename'} .= $EXTRA_COMPILE_EXT if defined $EXTRA_COMPILE_EXT;
433 if (-e
$doc->{'_compile_filename'} && (stat _
)[9] == $doc->{'modtime'}) {
435 $doc->{'_tree'} = Storable
::retrieve
($doc->{'_compile_filename'});
436 $doc->{'compile_was_used'} = 1;
438 my $str = $self->slurp($doc->{'_filename'});
439 $doc->{'_content'} = \
$str;
442 my $str = $self->slurp($doc->{'_filename'});
443 $doc->{'_content'} = \
$str;
449 ### haven't found a parsed tree yet - parse the content into a tree
450 if (! $doc->{'_tree'}) {
451 if ($self->{'CONSTANTS'}) {
452 my $key = $self->{'CONSTANT_NAMESPACE'} || 'constants';
453 $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'};
456 local $self->{'_vars'}->{'component'} = $doc;
457 $doc->{'_tree'} = $self->parse_tree($doc->{'_content'}); # errors die
460 ### cache parsed_tree in memory unless asked not to do so
461 if (! $doc->{'is_str_ref'} && (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'})) {
462 $self->{'_documents'}->{$file} ||= $doc;
463 $doc->{'_cache_time'} = time;
465 ### allow for config option to keep the cache size down
466 if ($self->{'CACHE_SIZE'}) {
467 my $all = $self->{'_documents'};
468 if (scalar(keys %$all) > $self->{'CACHE_SIZE'}) {
470 foreach my $file (sort {$all->{$b}->{'_cache_time'} <=> $all->{$a}->{'_cache_time'}} keys %$all) {
471 delete($all->{$file}) if ++$n > $self->{'CACHE_SIZE'};
477 ### save a cache on the fileside as asked
478 if ($doc->{'_compile_filename'} && ! $doc->{'compile_was_used'}) {
479 my $dir = $doc->{'_compile_filename'};
483 File
::Path
::mkpath
($dir);
486 Storable
::store
($doc->{'_tree'}, $doc->{'_compile_filename'});
487 utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_compile_filename'};
496 if (! $str_ref || ! defined $$str_ref) {
497 $self->throw('parse.no_string', "No string or undefined during parse");
500 my $STYLE = $self->{'TAG_STYLE'} || 'default';
501 my $START = $self->{'START_TAG'} || $TAGS->{$STYLE}->[0];
502 my $END = $self->{'END_TAG'} || $TAGS->{$STYLE}->[1];
503 my $len_s = length $START;
504 my $len_e = length $END;
506 my @tree; # the parsed tree
507 my $pointer = \
@tree; # pointer to current tree to handle nested blocks
508 my @state; # maintain block levels
509 local $self->{'_state'} = \
@state; # allow for items to introspect (usually BLOCKS)
510 local $self->{'_in_perl'}; # no interpolation in perl
511 my @move_to_front; # items that need to be declared first (usually BLOCKS)
512 my @meta; # place to store any found meta information (to go into METADEF)
513 my $i = 0; # start index
514 my $j = 0; # end index
515 my $last = 0; # previous end index
516 my $post_chomp = 0; # previous post_chomp setting
517 my $continue; # multiple directives in the same tag
518 my $post_op; # found a post-operative DIRECTIVE
519 my $capture; # flag to start capture
524 ### continue looking for information in a semi-colon delimited tag
527 $node = [undef, $i, $j];
529 ### look through the string using index
531 $i = index($$str_ref, $START, $last);
532 last if $i == -1; # no start tag found - we are done
533 if ($last != $i) { # found a text portion - chomp it, interpolate it and store it
534 my $text = substr($$str_ref, $last, $i - $last);
537 if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
538 elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
539 elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x }
542 push @$pointer, $text;
543 $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
546 $j = index($$str_ref, $END, $i + $len_s);
548 if ($j == -1) { # missing closing tag
549 $last = length($$str_ref);
552 $tag = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
553 $node = [undef, $i + $len_s, $j];
555 ### take care of whitespace and comments flags
556 my $pre_chomp = $tag =~ s{ ^ ([+=~-]) }{}x ? $1 : $self->{'PRE_CHOMP'};
557 $post_chomp = $tag =~ s{ ([+=~-]) $ }{}x ? $1 : $self->{'POST_CHOMP'};
558 $pre_chomp =~ y/-=~+/1230/ if $pre_chomp;
559 $post_chomp =~ y/-=~+/1230/ if $post_chomp;
560 if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) {
561 if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x }
562 elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x }
563 elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x }
564 splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length
566 if ($tag =~ /^\#/) { # leading # means to comment the entire section
568 push @$pointer, $node;
571 $tag =~ s{ ^ \s+ $QR_COMMENTS }{}ox;
580 ### look for DIRECTIVES
581 if ($tag =~ $QR_DIRECTIVE # find a word
582 && $DIRECTIVES->{$1} ) { # is it a directive
583 $node->[0] = $func = $1;
584 $tag =~ s{ ^ (\w+ | \|) \s* $QR_COMMENTS }{}ox;
586 ### store out this current node level
587 if ($post_op) { # on a post operator - replace the original node with the new one - store the old in the new
588 my @post_op = @$post_op;
591 $node->[4] = [\
@post_op];
593 # do nothing - it will be handled further down
595 push @$pointer, $node;
598 ### anything that behaves as a block ending
599 if ($func eq 'END' || $DIRECTIVES->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc)
601 $self->throw('parse', "Found an $func tag while not in a block", $node);
603 my $parent_node = pop @state;
605 if ($func ne 'END') {
606 pop @$pointer; # we will store the node in the parent instead
607 $parent_node->[5] = $node;
608 my $parent_type = $parent_node->[0];
609 if (! $DIRECTIVES->{$func}->[4]->{$parent_type}) {
610 $self->throw('parse', "Found unmatched nested block", $node, 0);
614 ### restore the pointer up one level (because we hit the end of a block)
615 $pointer = (! @state) ? \
@tree : $state[-1]->[4];
618 if ($func eq 'END') {
619 if ($DIRECTIVES->{$parent_node->[0]}->[5]) { # move things like BLOCKS to front
620 push @move_to_front, $parent_node;
621 if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var
622 splice(@$pointer, -1, 1, ());
624 } elsif ($parent_node->[0] =~ /PERL$/) {
625 delete $self->{'_in_perl'};
628 ### continuation block - such as an elsif
630 $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \
$tag, $node) };
632 $err->node($node) if UNIVERSAL
::can
($err, 'node') && ! $err->node;
636 $pointer = $node->[4] ||= [];
639 } elsif ($func eq 'TAGS') {
640 if ($tag =~ / ^ (\w+) /x && $TAGS->{$1}) {
641 $tag =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox;
642 ($START, $END) = @{ $TAGS->{$1} };
643 } elsif ($tag =~ s{ ^ (\S+) \s+ (\S+) \s* $QR_COMMENTS }{}ox) {
644 ($START, $END) = ($1, $2);
646 $len_s = length $START;
647 $len_e = length $END;
649 } elsif ($func eq 'META') {
650 my $args = $self->parse_args(\
$tag);
652 if (($hash = $self->get_variable($args->[-1]))
653 && UNIVERSAL
::isa
($hash, 'HASH')) {
654 unshift @meta, %$hash; # first defined win
657 ### all other "normal" tags
659 $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \
$tag, $node) };
661 $err->node($node) if UNIVERSAL
::can
($err, 'node') && ! $err->node;
664 if ($DIRECTIVES->{$func}->[2] && ! $post_op) { # this looks like a block directive
666 $pointer = $node->[4] ||= [];
670 ### allow for bare variable getting and setting
671 } elsif (defined(my $var = $self->parse_variable(\
$tag))) {
672 push @$pointer, $node;
673 if ($tag =~ s{ ^ ($QR_OP_ASSIGN) >? \s* $QR_COMMENTS }{}ox) {
675 $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, \
$tag, $node, $1, $var) };
677 $err->node($node) if UNIVERSAL
::can
($err, 'node') && ! $err->node;
686 my $all = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
689 $self->throw('parse', "Not sure how to handle tag \"$all\"", $node);
692 ### we now have the directive to capture for an item like "SET foo = BLOCK" - store it
694 my $parent_node = $capture;
695 push @{ $parent_node->[4] }, $node;
699 ### we are flagged to start capturing the output of the next directive - set it up
701 $continue = $j - length $tag;
702 $node->[2] = $continue;
706 ### semi-colon = end of statement - we will need to continue parsing this tag
707 } elsif ($tag =~ s{ ^ ; \s* $QR_COMMENTS }{}ox) {
708 $continue = $j - length $tag;
709 $node->[2] = $continue;
712 ### looking at a post operator ([% u FOREACH u IN [1..3] %])
713 } elsif ($tag =~ $QR_DIRECTIVE # find a word
714 && $DIRECTIVES->{$1} # is it a directive
715 && $DIRECTIVES->{$1}->[3]) { # it is a post operative directive
716 $continue = $j - length $tag;
717 $node->[2] = $continue;
720 ### unlink TT2 - look for another directive
721 } elsif (length $tag) {
722 #$self->throw('parse', "Found trailing info \"$tag\"", $node);
723 $continue = $j - length $tag;
724 $node->[2] = $continue;
733 if (@move_to_front) {
734 unshift @tree, @move_to_front;
737 unshift @tree, ['METADEF', 0, 0, {@meta}];
741 $self->throw('parse.missing.end', "Missing END", $state[-1], 0);
744 ### pull off the last text portion - if any
745 if ($last != length($$str_ref)) {
746 my $text = substr($$str_ref, $last, length($$str_ref) - $last);
749 if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
750 elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
751 elsif ($post_chomp == 3) { $_last += length($1) if $text =~ s{ ^ (\s+) }{}x }
754 push @$pointer, $text;
755 $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
763 my ($self, $tree, $out_ref) = @_;
765 # node contains (0: DIRECTIVE,
768 # 3: parsed tag details,
769 # 4: sub tree for block types
770 # 5: continuation sub trees for sub continuation block types (elsif, else, etc)
771 # 6: flag to capture next directive
772 for my $node (@$tree) {
773 ### text nodes are just the bare text
775 warn "NODE: TEXT\n" if trace
;
776 $$out_ref .= $node if defined $node;
780 warn "NODE: $node->[0] (char $node->[1])\n" if trace
;
781 $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};
783 my $val = $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref);
784 $$out_ref .= $val if defined $val;
788 ###----------------------------------------------------------------###
793 my $ARGS = shift || {};
795 ### allow for custom auto_quoting (such as hash constructors)
796 if ($ARGS->{'auto_quote'}) {
797 if ($$str_ref =~ $ARGS->{'auto_quote'}) {
799 substr($$str_ref, 0, length($str), '');
800 $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox;
802 ### allow for auto-quoted $foo or ${foo.bar} type constructs
803 } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox
804 || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
806 return $self->parse_variable(\
$name);
810 my $copy = $$str_ref; # copy while parsing to allow for errors
812 ### test for leading prefix operators
814 if ($copy =~ s{ ^ ($QR_OP_PREFIX) \s* $QR_COMMENTS }{}ox) {
815 return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
824 if ($copy =~ s{ ^ 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }{}ox) {
825 my $number = eval { hex $1 } || 0;
826 push @var, \
$number;
829 ### allow for numbers
830 } elsif ($copy =~ s{ ^ ( $QR_NUM ) \s* $QR_COMMENTS }{}ox) {
832 push @var, \
$number;
835 ### allow for quoted array constructor
836 } elsif ($copy =~ s{ ^ qw (\W) \s* }{}x) {
838 $quote =~ y
|([{<|)]}>|;
839 $copy =~ s{ ^ (.*) \Q$quote\E \s* $QR_COMMENTS }{}sx
840 || $self->throw('parse.missing.array_close', "Missing close \"$quote\"", undef, length($$str_ref) - length($copy));
842 $str =~ s{ ^ \s+ | \s+ $ }{}x;
843 my $arrayref = ['array', split /\s+/, $str];
844 push @var, \
$arrayref;
846 ### looks like a normal variable start
847 } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
849 $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
851 ### allow for literal strings
852 } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) {
853 if ($1 eq "'") { # no interpolation on single quoted strings
855 $str =~ s{ \\\' }{\'}xg;
863 $str =~ s/\\([\"\$])/$1/g;
864 my @pieces = $ARGS->{'auto_quote'}
865 ? split(m{ (\$\w+ | \$\{ [^\}]+ \
}) }x
, $str) # autoquoted items get a single $\w+ - no nesting
866 : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \
}) }x
, $str);
868 foreach my $piece (@pieces) {
869 next if ! ($n++ % 2);
870 next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
871 && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \
} $ }x
;
873 $piece = $self->parse_variable(\
$name);
875 @pieces = grep {defined && length} @pieces;
876 if (@pieces == 1 && ! ref $pieces[0]) {
877 push @var, \
$pieces[0];
879 } elsif (! @pieces) {
883 push @var, \
['~', @pieces];
886 if ($ARGS->{'auto_quote'}){
888 return ${ $var[0] } if $is_literal;
893 ### allow for leading $foo or ${foo.bar} type constructs
894 } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox
895 || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
897 push @var, $self->parse_variable(\
$name);
899 ### looks like an array constructor
900 } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) {
901 local $self->{'_operator_precedence'} = 0; # reset presedence
902 my $arrayref = ['array'];
903 while (defined(my $var = $self->parse_variable(\
$copy))) {
904 push @$arrayref, $var;
905 $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
907 $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox
908 || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, length($$str_ref) - length($copy));
909 push @var, \
$arrayref;
911 ### looks like a hash constructor
912 } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) {
913 local $self->{'_operator_precedence'} = 0; # reset precedence
914 my $hashref = ['hash'];
915 while (defined(my $key = $self->parse_variable(\
$copy, {auto_quote
=> qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) {
916 $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox;
917 my $val = $self->parse_variable(\
$copy);
918 push @$hashref, $key, $val;
919 $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
921 $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox
922 || $self->throw('parse.missing.curly_bracket', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy));
923 push @var, \
$hashref;
925 ### looks like a paren grouper
926 } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
927 local $self->{'_operator_precedence'} = 0; # reset precedence
928 my $var = $self->parse_variable(\
$copy, {allow_parened_ops
=> 1});
929 $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
930 || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
932 pop(@var); # pull off the trailing args of the paren group
934 ### nothing to find - return failure
939 return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
941 ### looks for args for the initial
942 if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
943 local $self->{'_operator_precedence'} = 0; # reset precedence
944 my $args = $self->parse_args(\
$copy);
945 $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
946 || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
952 ### allow for nested items
953 while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) {
954 push(@var, $1) if ! $ARGS->{'no_dots'};
956 ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two
957 if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox
958 || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) {
960 my $var = $self->parse_variable(\
$name);
964 } elsif ($copy =~ s{ ^ (-? \w+) \s* $QR_COMMENTS }{}ox) {
968 $self->throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)");
971 ### looks for args for the nested item
972 if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
973 local $self->{'_operator_precedence'} = 0; # reset precedence
974 my $args = $self->parse_args(\
$copy);
975 $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
976 || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
984 ### flatten literals and constants as much as possible
985 my $var = ($is_literal && $#var == 1) ? ${ $var[0] }
986 : $is_namespace ? $self->get_variable(\
@var, {is_namespace_during_compile
=> 1})
989 ### allow for all "operators"
990 if (! $self->{'_operator_precedence'}) {
993 while ($copy =~ s{ ^ ($QR_OP) (\s* $QR_COMMENTS) }{}ox) { ## look for operators - then move along
994 if (! $ARGS->{'allow_parened_ops'} && $OP_ASSIGN->{$1}) {
995 $copy = $1 . $2 . $copy;
999 local $self->{'_operator_precedence'} = 1;
1001 my $var2 = $OP_POSTFIX->{$op} ? 1 : $self->parse_variable(\
$copy); # cheat - give a "second value" to postfix ops
1003 ### allow for prefix operator precedence
1004 if ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix}->[1]) {
1006 if ($#$tree == 1) { # only one operator - keep simple things fast
1007 $var = [\
[$tree->[0], $var, $tree->[1]], 0];
1009 unshift @$tree, $var;
1010 $var = $self->apply_precedence($tree, $found);
1015 $var = [ \
[ $has_prefix, $var ], 0 ];
1019 ### add the operator to the tree
1020 push (@{ $tree ||= [] }, $op, $var2);
1021 $found->{$op} = $OP->{$op}->[1];
1024 ### if we found operators - tree the nodes by operator precedence
1026 if (@$tree == 2) { # only one operator - keep simple things fast
1027 $var = [\
[$tree->[0], $var, $tree->[1]], 0];
1029 unshift @$tree, $var;
1030 $var = $self->apply_precedence($tree, $found);
1035 ### allow for prefix on non-chained variables
1037 $var = [ \
[ $has_prefix, $var ], 0 ];
1040 $$str_ref = $copy; # commit the changes
1044 ### this is used to put the parsed variables into the correct operations tree
1045 sub apply_precedence
{
1046 my ($self, $tree, $found) = @_;
1050 ### look at the operators we found in the order we found them
1051 for my $op (sort {$found->{$a} <=> $found->{$b}} keys %$found) {
1052 local $found->{$op};
1053 delete $found->{$op};
1057 ### split the array on the current operator
1058 for (my $i = 0; $i <= $#$tree; $i ++) {
1059 my $is_ternary = $OP_TERNARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP->{$op}->[2] };
1060 next if $tree->[$i] ne $op && ! $is_ternary;
1061 push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator
1062 push @ternary, $tree->[0] if $is_ternary;
1063 shift @$tree; # pull off the operator
1066 next if ! @trees; # this iteration didn't have the current operator
1067 push @trees, $tree if scalar @$tree; # elements after last operator
1069 ### now - for this level split on remaining operators, or add the variable to the tree
1070 for my $node (@trees) {
1072 $node = $node->[0]; # single item - its not a tree
1073 } elsif (@$node == 3) {
1074 $node = [ \
[ $node->[1], $node->[0], $node->[2] ], 0 ]; # single operator - put it straight on
1076 $node = $self->apply_precedence($node, $found); # more complicated - recurse
1080 ### return infix and assign
1081 if (! $OP_TERNARY->{$op}) {
1082 my $val = $trees[-1];
1083 $val = [ \
[ $op, $trees[$_], $val ], 0 ] for reverse (0 .. $#trees - 1); # reverse order - helps out ||
1087 ### return simple ternary
1088 if (@ternary == 2) {
1089 return [ \
[ $op, @trees ], 0 ];
1092 ### reorder complex ternary - rare case
1093 while ($#ternary >= 1) {
1094 ### if we look starting from the back - the first lead ternary op will always be next to its matching op
1095 for (my $i = $#ternary; $i >= 0; $i --) {
1096 next if $OP->{$ternary[$i]}->[2]->[1] eq $ternary[$i];
1097 my ($op, $op2) = splice @ternary, $i, 2, (); # remove the pair of operators
1098 my $node = [ \
[$op, @trees[$i .. $i + 2] ], 0 ];
1099 splice @trees, $i, 3, $node;
1102 return $trees[0]; # at this point the ternary has been reduced to a single operator
1106 $self->throw('parse', "Couldn't apply precedence");
1109 ### look for arguments - both positional and named
1112 my $str_ref = shift;
1113 my $ARGS = shift || {};
1114 my $copy = $$str_ref;
1118 while (length $$str_ref) {
1119 my $copy = $$str_ref;
1120 if (defined(my $name = $self->parse_variable(\
$copy, {auto_quote
=> qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
1121 && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
1122 $self->throw('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'};
1123 my $val = $self->parse_variable(\
$copy);
1124 $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
1125 push @named, $name, $val;
1127 } elsif (defined(my $arg = $self->parse_variable($str_ref))) {
1129 $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
1135 ### allow for named arguments to be added also
1136 push @args, [\
['hash', @named], 0] if scalar @named;
1141 ### allow for looking for $foo or ${foo.bar} in TEXT "nodes" of the parse tree.
1142 sub interpolate_node
{
1143 my ($self, $tree, $offset) = @_;
1144 return if $self->{'_in_perl'};
1146 ### split on variables while keeping the variables
1147 my @pieces = split m{ (?: ^ | (?<! \\)) (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \
}) }x
, $tree->[-1];
1148 if ($#pieces <= 0) {
1149 $tree->[-1] =~ s{ \\ ([\"\$]) }{$1}xg;
1155 foreach my $piece (@pieces) {
1156 $offset += length $piece; # we track the offset to make sure DEBUG has the right location
1157 if (! ($n++ % 2)) { # odds will always be text chunks
1158 next if ! length $piece;
1159 $piece =~ s{ \\ ([\"\$]) }{$1}xg;
1160 push @sub_tree, $piece;
1161 } elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
1162 || $piece =~ m{ ^ \$\{ \s* ([^\}]+) \
} $ }x
) {
1164 push @sub_tree, ['GET', $offset - length($piece), $offset, $self->parse_variable(\
$name)];
1166 $self->throw('parse', "Parse error during interpolate node");
1170 ### replace the tree
1171 splice @$tree, -1, 1, @sub_tree;
1174 ###----------------------------------------------------------------###
1177 ### allow for the parse tree to store literals
1178 return $_[1] if ! ref $_[1];
1182 my $ARGS = shift || {};
1185 ### determine the top level of this particular variable access
1187 my $name = $var->[$i++];
1188 my $args = $var->[$i++];
1189 warn "get_variable: begin \"$name\"\n" if trace
;
1191 if (ref $name eq 'SCALAR') { # a scalar literal
1193 } elsif (ref $name eq 'REF') { # operator
1194 return $self->play_operator($$name) if ${ $name }->[0] eq '..';
1195 $ref = $self->play_operator($$name);
1196 } else { # a named variable access (ie via $name.foo)
1197 $name = $self->get_variable($name);
1198 if (defined $name) {
1199 return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
1200 $ref = $self->{'_vars'}->{$name};
1203 } elsif (defined $name) {
1204 if ($ARGS->{'is_namespace_during_compile'}) {
1205 $ref = $self->{'NAMESPACE'}->{$name};
1207 return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
1208 $ref = $self->{'_vars'}->{$name};
1209 $ref = $VOBJS->{$name} if ! defined $ref;
1215 while (defined $ref) {
1217 ### check at each point if the rurned thing was a code
1218 if (UNIVERSAL
::isa
($ref, 'CODE')) {
1219 my @results = $ref->($args ? map { $self->get_variable($_) } @$args : ());
1220 if (defined $results[0]) {
1221 $ref = ($#results > 0) ? \
@results : $results[0];
1222 } elsif (defined $results[1]) {
1223 die $results[1]; # TT behavior - why not just throw ?
1230 ### descend one chained level
1231 last if $i >= $#$var;
1232 my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
1233 $name = $var->[$i++];
1234 $args = $var->[$i++];
1235 warn "get_variable: nested \"$name\"\n" if trace
;
1237 ### allow for named portions of a variable name (foo.$name.bar)
1239 if (ref($name) eq 'ARRAY') {
1240 $name = $self->get_variable($name);
1241 if (! defined($name) || $name =~ $QR_PRIVATE || $name =~ /^\./) {
1246 die "Shouldn't get a ". ref($name) ." during a vivify on chain";
1249 if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
1254 ### allow for scalar and filter access (this happens for every non virtual method call)
1256 if ($SCALAR_OPS->{$name}) { # normal scalar op
1257 $ref = $SCALAR_OPS->{$name}->($ref, $args ? map { $self->get_variable($_) } @$args : ());
1259 } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
1260 $ref = $LIST_OPS->{$name}->([$ref], $args ? map { $self->get_variable($_) } @$args : ());
1262 } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args
1263 || $FILTER_OPS->{$name} # predefined filters in CET
1264 || (UNIVERSAL
::isa
($name, 'CODE') && $name) # looks like a filter sub passed in the stash
1265 || $self->list_filters->{$name}) { # filter defined in Template::Filters
1267 if (UNIVERSAL
::isa
($filter, 'CODE')) {
1268 $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
1270 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
1273 } elsif (! UNIVERSAL
::isa
($filter, 'ARRAY')) {
1274 $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
1276 } elsif (@$filter == 2 && UNIVERSAL
::isa
($filter->[0], 'CODE')) { # these are the TT style filters
1278 my $sub = $filter->[0];
1279 if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
1280 ($sub, my $err) = $sub->($self->context, $args ? map { $self->get_variable($_) } @$args : ());
1281 if (! $sub && $err) {
1282 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
1284 } elsif (! UNIVERSAL
::isa
($sub, 'CODE')) {
1285 $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
1286 if ref($sub) !~ /Template::Exception$/;
1290 $ref = $sub->($ref);
1293 $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
1296 } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
1297 $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
1298 $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree
1301 if (scalar keys %seen_filters
1302 && $seen_filters{$var->[$i - 5] || ''}) {
1303 $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)");
1311 ### method calls on objects
1312 if ($was_dot_call && UNIVERSAL
::can
($ref, 'can')) {
1313 my @args = $args ? map { $self->get_variable($_) } @$args : ();
1314 my @results = eval { $ref->$name(@args) };
1316 my $class = ref $ref;
1317 die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/;
1318 } elsif (defined $results[0]) {
1319 $ref = ($#results > 0) ? \
@results : $results[0];
1321 } elsif (defined $results[1]) {
1322 die $results[1]; # TT behavior - why not just throw ?
1327 # didn't find a method by that name - so fail down to hash and array access
1330 ### hash member access
1331 if (UNIVERSAL
::isa
($ref, 'HASH')) {
1332 if ($was_dot_call && exists($ref->{$name}) ) {
1333 $ref = $ref->{$name};
1334 } elsif ($HASH_OPS->{$name}) {
1335 $ref = $HASH_OPS->{$name}->($ref, $args ? map { $self->get_variable($_) } @$args : ());
1336 } elsif ($ARGS->{'is_namespace_during_compile'}) {
1337 return $var; # abort - can't fold namespace variable
1343 } elsif (UNIVERSAL
::isa
($ref, 'ARRAY')) {
1344 if ($name =~ m{ ^ -? $QR_NUM $ }ox) {
1345 $ref = $ref->[$name];
1346 } elsif ($LIST_OPS->{$name}) {
1347 $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->get_variable($_) } @$args : ());
1356 ### allow for undefinedness
1357 if (! defined $ref) {
1358 if ($self->{'_debug_undef'}) {
1359 my $chunk = $var->[$i - 2];
1360 $chunk = $self->get_variable($chunk) if ref($chunk) eq 'ARRAY';
1361 die "$chunk is undefined\n";
1363 $ref = $self->undefined_any($var);
1371 my ($self, $var, $val, $ARGS) = @_;
1375 ### allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %])
1376 $var = [$var, 0] if ! ref $var;
1378 ### determine the top level of this particular variable access
1379 my $ref = $var->[$i++];
1380 my $args = $var->[$i++];
1382 if (ref($ref) eq 'ARRAY') { # named access (ie via $name.foo)
1383 $ref = $self->get_variable($ref);
1384 if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _
1386 return $self->{'_vars'}->{$ref} = $val;
1388 $ref = $self->{'_vars'}->{$ref} ||= {};
1393 } else { # all other types can't be set
1396 } elsif (defined $ref) {
1397 return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
1399 return $self->{'_vars'}->{$ref} = $val;
1401 $ref = $self->{'_vars'}->{$ref} ||= {};
1405 while (defined $ref) {
1407 ### check at each point if the returned thing was a code
1408 if (UNIVERSAL
::isa
($ref, 'CODE')) {
1409 my @results = $ref->($args ? map { $self->get_variable($_) } @$args : ());
1410 if (defined $results[0]) {
1411 $ref = ($#results > 0) ? \
@results : $results[0];
1412 } elsif (defined $results[1]) {
1413 die $results[1]; # TT behavior - why not just throw ?
1419 ### descend one chained level
1420 last if $i >= $#$var;
1421 my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
1422 my $name = $var->[$i++];
1423 my $args = $var->[$i++];
1425 ### allow for named portions of a variable name (foo.$name.bar)
1427 if (ref($name) eq 'ARRAY') {
1428 $name = $self->get_variable($name);
1429 if (! defined($name) || $name =~ /^[_.]/) {
1433 die "Shouldn't get a ".ref($name)." during a vivify on chain";
1436 if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
1444 ### method calls on objects
1445 } elsif (UNIVERSAL
::can
($ref, 'can')) {
1447 my @args = $args ? map { $self->get_variable($_) } @$args : ();
1452 my @results = eval { $ref->$name(@args) };
1454 if (defined $results[0]) {
1455 $ref = ($#results > 0) ? \
@results : $results[0];
1456 } elsif (defined $results[1]) {
1457 die $results[1]; # TT behavior - why not just throw ?
1461 return if $lvalueish;
1464 my $class = ref $ref;
1465 die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/;
1466 # fall on down to "normal" accessors
1469 ### hash member access
1470 if (UNIVERSAL
::isa
($ref, 'HASH')) {
1472 return $ref->{$name} = $val;
1474 $ref = $ref->{$name} ||= {};
1479 } elsif (UNIVERSAL
::isa
($ref, 'ARRAY')) {
1480 if ($name =~ m{ ^ -? $QR_NUM $ }ox) {
1482 return $ref->[$name] = $val;
1484 $ref = $ref->[$name] ||= {};
1498 ###----------------------------------------------------------------###
1504 if ($OP_DISPATCH->{$tree->[0]}) {
1506 if ($OP_ASSIGN->{$tree->[0]}) {
1507 my $val = $OP_DISPATCH->{$tree->[0]}->( $self->get_variable($tree->[1]), $self->get_variable($tree->[2]) );
1508 $self->set_variable($tree->[1], $val);
1511 return $OP_DISPATCH->{$tree->[0]}->( map { $self->get_variable($tree->[$_]) } 1 .. $#$tree );
1515 my $op = $tree->[0];
1517 ### do custom and short-circuitable operators
1519 my $val = $self->get_variable($tree->[2]);
1520 $self->set_variable($tree->[1], $val);
1523 } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
1524 return $self->get_variable($tree->[1]) || $self->get_variable($tree->[2]) || '';
1526 } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') {
1527 my $var = $self->get_variable($tree->[1]) && $self->get_variable($tree->[2]);
1528 return $var ? $var : 0;
1530 } elsif ($op eq '?') {
1532 return $self->get_variable($tree->[1]) ? $self->get_variable($tree->[2]) : $self->get_variable($tree->[3]);
1534 } elsif ($op eq '++') {
1536 my $val = 0 + $self->get_variable($tree->[1]);
1537 $self->set_variable($tree->[1], $val + 1);
1538 return $tree->[2] ? $val : $val + 1; # ->[2] is set to 1 during parsing of postfix ops
1540 } elsif ($op eq '--') {
1542 my $val = 0 + $self->get_variable($tree->[1]);
1543 $self->set_variable($tree->[1], $val - 1);
1544 return $tree->[2] ? $val : $val - 1; # ->[2] is set to 1 during parsing of postfix ops
1547 $self->throw('operator', "Un-implemented operation $op");
1550 ###----------------------------------------------------------------###
1553 my ($self, $tag_ref, $node) = @_;
1555 my $block_name = '';
1556 if ($$tag_ref =~ s{ ^ (\w+ (?: :\w+)*) \s* (?! [\.\|]) }{}x
1557 || $$tag_ref =~ s{ ^ '(|.*?[^\\])' \s* (?! [\.\|]) }{}x
1558 || $$tag_ref =~ s{ ^ "(|.*?[^\\])" \s* (?! [\.\|]) }{}x
1561 ### allow for nested blocks to have nested names
1562 my @names = map {$_->[3]} grep {$_->[0] eq 'BLOCK'} @{ $self->{'_state'} };
1563 $block_name = join("/", @names, $block_name) if scalar @names;
1570 my ($self, $block_name, $node, $out_ref) = @_;
1572 ### store a named reference - but do nothing until something processes it
1573 $self->{'BLOCKS'}->{$block_name} = {
1574 _tree
=> $node->[4],
1575 name
=> $self->{'_vars'}->{'component'}->{'name'} .'/'. $block_name,
1581 sub parse_CALL
{ $DIRECTIVES->{'GET'}->[0]->(@_) }
1583 sub play_CALL
{ $DIRECTIVES->{'GET'}->[1]->(@_); return }
1586 my ($self, $tag_ref) = @_;
1587 return if $$tag_ref =~ s{ ^ DEFAULT \s* }{}x;
1588 return $self->parse_variable($tag_ref);
1592 my ($self, $tag_ref) = @_;
1593 return $self->parse_variable($tag_ref, {auto_quote
=> qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
1597 my ($self, $undef, $node) = @_;
1598 $self->throw(lc($node->[0]), 'Control exception', $node);
1602 my ($self, $undef, $node, $out_ref) = @_;
1607 my ($self, $tag_ref) = @_;
1608 $$tag_ref =~ s{ ^ (on | off | format) \s* }{}xi || $self->throw('parse', "Unknown DEBUG option");
1610 if ($ret->[0] eq 'format') {
1611 $$tag_ref =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* }{}xs || $self->throw('parse', "Missing format string");
1618 my ($self, $ref) = @_;
1619 if ($ref->[0] eq 'on') {
1620 delete $self->{'_debug_off'};
1621 } elsif ($ref->[0] eq 'off') {
1622 $self->{'_debug_off'} = 1;
1623 } elsif ($ref->[0] eq 'format') {
1624 $self->{'_debug_format'} = $ref->[1];
1628 sub parse_DEFAULT
{ $DIRECTIVES->{'SET'}->[0]->(@_) }
1631 my ($self, $set) = @_;
1633 my ($op, $set, $default) = @$_;
1634 next if ! defined $set;
1635 my $val = $self->get_variable($set);
1637 $default = defined($default) ? $self->get_variable($default) : '';
1638 $self->set_variable($set, $default);
1645 my ($self, $tag_ref) = @_;
1646 my $ref = $self->parse_variable($tag_ref);
1651 my ($self, $ident, $node) = @_;
1652 require Data
::Dumper
;
1653 my $info = $self->node_info($node);
1657 $out = Data
::Dumper
::Dumper
($self->get_variable($ident));
1658 $var = $info->{'text'};
1659 $var =~ s/^[+\-~=]?\s*DUMP\s+//;
1660 $var =~ s/\s*[+\-~=]?$//;
1662 my @were_never_here = (qw(template component), grep {$_ =~ $QR_PRIVATE} keys %{ $self->{'_vars'} });
1663 local @{ $self->{'_vars'} }{ @were_never_here };
1664 delete @{ $self->{'_vars'} }{ @were_never_here };
1665 $out = Data
::Dumper
::Dumper
($self->{'_vars'});
1666 $var = 'EntireStash';
1668 if ($ENV{'REQUEST_METHOD'}) {
1670 $out = "<pre>$out</pre>";
1671 $out =~ s/\$VAR1/$var/;
1672 $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out";
1674 $out =~ s/\$VAR1/$var/;
1681 my ($self, $tag_ref) = @_;
1683 if ($$tag_ref =~ s{ ^ ([^\W\d]\w*) \s* = \s* }{}x) {
1687 my $filter = $self->parse_variable($tag_ref);
1688 $filter = '' if ! defined $filter;
1690 return [$name, $filter];
1694 my ($self, $ref, $node, $out_ref) = @_;
1695 my ($name, $filter) = @$ref;
1697 return '' if ! @$filter;
1699 $self->{'FILTERS'}->{$name} = $filter if length $name;
1701 my $sub_tree = $node->[4];
1705 eval { $self->execute_tree($sub_tree, \
$out) };
1706 die $@ if $@ && ref($@) !~ /Template::Exception$/;
1708 my $var = [\
$out, 0, '|', @$filter]; # make a temporary var out of it
1711 return $DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
1715 my ($self, $tag_ref) = @_;
1716 my $items = $self->parse_variable($tag_ref);
1718 if ($$tag_ref =~ s{ ^ (= | [Ii][Nn]\b) \s* }{}x) {
1720 $items = $self->parse_variable($tag_ref);
1722 return [$var, $items];
1726 my ($self, $ref, $node, $out_ref) = @_;
1728 ### get the items - make sure it is an arrayref
1729 my ($var, $items) = @$ref;
1731 $items = $self->get_variable($items);
1732 return '' if ! defined $items;
1734 if (ref($items) !~ /Iterator$/) {
1735 $items = $PACKAGE_ITERATOR->new($items);
1738 my $sub_tree = $node->[4];
1740 local $self->{'_vars'}->{'loop'} = $items;
1742 ### if the FOREACH tag sets a var - then nothing but the loop var gets localized
1744 my ($item, $error) = $items->get_first;
1747 $self->set_variable($var, $item);
1749 ### execute the sub tree
1750 eval { $self->execute_tree($sub_tree, $out_ref) };
1752 if (UNIVERSAL
::isa
($err, $PACKAGE_EXCEPTION)) {
1753 if ($err->type eq 'next') {
1754 ($item, $error) = $items->get_next;
1757 last if $err->type =~ /last|break/;
1762 ($item, $error) = $items->get_next;
1764 die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
1765 ### if the FOREACH tag doesn't set a var - then everything gets localized
1768 ### localize variable access for the foreach
1769 my $swap = $self->{'_vars'};
1770 local $self->{'_vars'} = my $copy = {%$swap};
1772 ### iterate use the iterator object
1773 #foreach (my $i = $items->index; $i <= $#$vals; $items->index(++ $i)) {
1774 my ($item, $error) = $items->get_first;
1777 if (ref($item) eq 'HASH') {
1778 @$copy{keys %$item} = values %$item;
1781 ### execute the sub tree
1782 eval { $self->execute_tree($sub_tree, $out_ref) };
1784 if (UNIVERSAL
::isa
($err, $PACKAGE_EXCEPTION)) {
1785 if ($err->type eq 'next') {
1786 ($item, $error) = $items->get_next;
1789 last if $err->type =~ /last|break/;
1794 ($item, $error) = $items->get_next;
1796 die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
1803 my ($self, $tag_ref) = @_;
1804 my $ref = $self->parse_variable($tag_ref);
1805 $self->throw('parse', "Missing variable name") if ! defined $ref;
1810 my ($self, $ident, $node) = @_;
1811 my $var = $self->get_variable($ident);
1812 return (! defined $var) ? $self->undefined_get($ident, $node) : $var;
1816 my ($self, $tag_ref) = @_;
1817 return $self->parse_variable($tag_ref);
1821 my ($self, $var, $node, $out_ref) = @_;
1823 my $val = $self->get_variable($var);
1825 my $body_ref = $node->[4] ||= [];
1826 $self->execute_tree($body_ref, $out_ref);
1830 while ($node = $node->[5]) { # ELSE, ELSIF's
1831 if ($node->[0] eq 'ELSE') {
1832 my $body_ref = $node->[4] ||= [];
1833 $self->execute_tree($body_ref, $out_ref);
1836 my $var = $node->[3];
1837 my $val = $self->get_variable($var);
1839 my $body_ref = $node->[4] ||= [];
1840 $self->execute_tree($body_ref, $out_ref);
1847 sub parse_INCLUDE
{ $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
1850 my ($self, $tag_ref, $node, $out_ref) = @_;
1852 ### localize the swap
1853 my $swap = $self->{'_vars'};
1854 local $self->{'_vars'} = {%$swap};
1856 ### localize the blocks
1857 my $blocks = $self->{'BLOCKS'};
1858 local $self->{'BLOCKS'} = {%$blocks};
1860 my $str = $DIRECTIVES->{'PROCESS'}->[1]->($self, $tag_ref, $node, $out_ref);
1865 sub parse_INSERT
{ $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
1868 my ($self, $var, $node, $out_ref) = @_;
1869 my ($names, $args) = @$var;
1871 foreach my $name (@$names) {
1872 my $filename = $self->get_variable($name);
1873 $$out_ref .= $self->_insert($filename);
1880 my ($self, $tag_ref, $node) = @_;
1881 my $copy = $$tag_ref;
1883 my $name = $self->parse_variable(\
$copy, {auto_quote
=> qr{ ^ (\w+) $QR_AQ_NOTDOT }xo});
1884 $self->throw('parse', "Missing macro name") if ! defined $name;
1886 $name = [ $name, 0 ];
1890 if ($copy =~ s{ ^ \( \s* }{}x) {
1891 $args = $self->parse_args(\
$copy, {positional_only
=> 1});
1892 $copy =~ s
{ ^ \
) \s
* }{}x
|| $self->throw('parse.missing', "Missing close ')'");
1895 $node->[6] = 1; # set a flag to keep parsing
1897 return [$name, $args];
1901 my ($self, $ref, $node, $out_ref) = @_;
1902 my ($name, $args) = @$ref;
1904 ### get the sub tree
1905 my $sub_tree = $node->[4];
1906 if (! $sub_tree || ! $sub_tree->[0]) {
1907 $self->set_variable($name, undef);
1909 } elsif ($sub_tree->[0]->[0] eq 'BLOCK') {
1910 $sub_tree = $sub_tree->[0]->[4];
1913 my $self_copy = $self->weak_copy;
1915 ### install a closure in the stash that will handle the macro
1916 $self->set_variable($name, sub {
1918 my $copy = $self_copy->{'_vars'};
1919 local $self_copy->{'_vars'}= {%$copy};
1922 my $named = pop(@_) if $_[-1] && UNIVERSAL
::isa
($_[-1],'HASH') && $#_ > $#$args;
1923 my @positional = @_;
1924 foreach my $var (@$args) {
1925 $self_copy->set_variable($var, shift(@positional));
1927 foreach my $name (sort keys %$named) {
1928 $self_copy->set_variable([$name, 0], $named->{$name});
1931 ### finally - run the sub tree
1933 $self_copy->execute_tree($sub_tree, \
$out);
1941 my ($self, $hash) = @_;
1943 if ($self->{'_top_level'}) {
1944 $ref = $self->{'_vars'}->{'template'} ||= {};
1946 $ref = $self->{'_vars'}->{'component'} ||= {};
1948 foreach my $key (keys %$hash) {
1949 next if $key eq 'name' || $key eq 'modtime';
1950 $ref->{$key} = $hash->{$key};
1955 sub parse_PERL
{ shift-
>{'_in_perl'} = 1; return }
1958 my ($self, $info, $node, $out_ref) = @_;
1959 $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
1961 ### fill in any variables
1962 my $perl = $node->[4] || return;
1964 $self->execute_tree($perl, \
$out);
1965 $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
1970 package CGI
::Ex
::Template
::Perl
;
1972 my $context = $self->context;
1973 my $stash = $context->stash;
1975 ### setup a fake handle
1977 tie
*PERLOUT
, $CGI::Ex
::Template
::PACKAGE_PERL_HANDLE
, $out_ref;
1978 my $old_fh = select PERLOUT
;
1983 ### put the handle back
1991 $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
1999 my ($self, $tag_ref) = @_;
2000 my $info = [[], []];
2001 while (defined(my $filename = $self->parse_variable($tag_ref, {
2002 auto_quote
=> qr{ ^ ($QR_FILENAME | \w+ (?: :\w+)* ) $QR_AQ_SPACE }xo,
2004 push @{$info->[0]}, $filename;
2005 last if $$tag_ref !~ s{ ^ \+ \s* }{}x;
2008 ### allow for post process variables
2009 while (length $$tag_ref) {
2010 last if $$tag_ref =~ / ^ (\w+) (?: ;|$|\s)/x && $DIRECTIVES->{$1}; ### looks like a directive - we are done
2012 my $var = $self->parse_variable($tag_ref);
2013 last if ! defined $var;
2014 if ($$tag_ref !~ s{ ^ = >? \s* }{}x) {
2015 $self->throw('parse.missing.equals', 'Missing equals while parsing args');
2018 my $val = $self->parse_variable($tag_ref);
2019 push @{$info->[1]}, [$var, $val];
2020 $$tag_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox if $val;
2027 my ($self, $info, $node, $out_ref) = @_;
2029 my ($files, $args) = @$info;
2033 my ($key, $val) = @$_;
2034 $val = $self->get_variable($val);
2035 if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL
::isa
($val, 'HASH')) { # import ?! - whatever
2036 foreach my $key (keys %$val) {
2037 $self->set_variable([$key,0], $val->{$key});
2041 $self->set_variable($key, $val);
2044 ### iterate on any passed block or filename
2045 foreach my $ref (@$files) {
2046 next if ! defined $ref;
2047 my $filename = $self->get_variable($ref);
2048 my $out = ''; # have temp item to allow clear to correctly clear
2050 ### normal blocks or filenames
2051 if (! ref $filename) {
2052 eval { $self->_process($filename, $self->{'_vars'}, \
$out) }; # restart the swap - passing it our current stash
2054 ### allow for $template which is used in some odd instances
2056 $self->throw('process', "Unable to process document $filename") if $ref->[0] ne 'template';
2057 $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'};
2058 local $self->{'_process_dollar_template'} = 1;
2059 local $self->{'_vars'}->{'component'} = my $doc = $filename;
2060 return if ! $doc->{'_tree'};
2062 ### execute and trim
2063 eval { $self->execute_tree($doc->{'_tree'}, \
$out) };
2064 if ($self->{'TRIM'}) {
2065 $out =~ s{ \s+ $ }{}x;
2066 $out =~ s{ ^ \s+ }{}x;
2069 ### handle exceptions
2071 $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
2072 $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
2077 ### append any output
2080 die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
2088 my ($self, $info, $node, $out_ref) = @_;
2089 $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
2091 ### fill in any variables
2092 my $tree = $node->[4] || return;
2094 $self->execute_tree($tree, \
$perl);
2095 $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
2101 package CGI
::Ex
::Template
::Perl
;
2103 my $context = $self->context;
2104 my $stash = $context->stash;
2111 $$out_ref .= $output;
2114 $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
2122 my ($self, $tag_ref, $node, $initial_op, $initial_var) = @_;
2124 my $copy = $$tag_ref;
2128 if ($$tag_ref =~ $QR_DIRECTIVE # find a word
2129 && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing
2130 $node->[6] = 1; # set a flag to keep parsing
2131 my $val = $node->[4] ||= []; # setup storage
2132 return [[$initial_op, $initial_var, $val]];
2133 } else { # get a normal variable
2134 return [[$initial_op, $initial_var, $self->parse_variable($tag_ref)]];
2138 while (length $$tag_ref) {
2139 my $set = $self->parse_variable($tag_ref);
2140 last if ! defined $set;
2142 if ($$tag_ref =~ s{ ^ ($QR_OP_ASSIGN) >? \s* }{}x) {
2144 if ($$tag_ref =~ $QR_DIRECTIVE # find a word
2145 && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing
2146 $node->[6] = 1; # set a flag to keep parsing
2147 my $val = $node->[4] ||= []; # setup storage
2148 push @SET, [$op, $set, $val];
2150 } else { # get a normal variable
2151 push @SET, [$op, $set, $self->parse_variable($tag_ref)];
2154 push @SET, ['=', $set, undef];
2161 my ($self, $set, $node) = @_;
2163 my ($op, $set, $val) = @$_;
2164 if (! defined $val) { # not defined
2166 } elsif ($node->[4] && $val == $node->[4]) { # a captured directive
2167 my $sub_tree = $node->[4];
2168 $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK';
2170 $self->execute_tree($sub_tree, \
$val);
2171 } else { # normal var
2172 $val = $self->get_variable($val);
2175 if ($OP_DISPATCH->{$op}) {
2177 $val = $OP_DISPATCH->{$op}->($self->get_variable($set), $val);
2180 $self->set_variable($set, $val);
2185 sub parse_SWITCH
{ $DIRECTIVES->{'GET'}->[0]->(@_) }
2188 my ($self, $var, $node, $out_ref) = @_;
2190 my $val = $self->get_variable($var);
2191 $val = '' if ! defined $val;
2192 ### $node->[4] is thrown away
2195 while ($node = $node->[5]) { # CASES
2196 my $var = $node->[3];
2197 if (! defined $var) {
2198 $default = $node->[4];
2202 my $val2 = $self->get_variable($var);
2203 $val2 = [$val2] if ! UNIVERSAL
::isa
($val2, 'ARRAY');
2204 for my $test (@$val2) { # find matching values
2205 next if ! defined $val && defined $test;
2206 next if defined $val && ! defined $test;
2207 if ($val ne $test) { # check string-wise first - then numerical
2208 next if $val !~ m{ ^ -? $QR_NUM $ }ox;
2209 next if $test !~ m{ ^ -? $QR_NUM $ }ox;
2210 next if $val != $test;
2213 my $body_ref = $node->[4] ||= [];
2214 $self->execute_tree($body_ref, $out_ref);
2220 $self->execute_tree($default, $out_ref);
2227 my ($self, $tag_ref, $node) = @_;
2228 my $name = $self->parse_variable($tag_ref, {auto_quote
=> qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
2229 $self->throw('parse.missing', "Missing name in THROW", $node) if ! $name;
2230 my $args = $self->parse_args($tag_ref);
2231 return [$name, $args];
2235 my ($self, $ref, $node) = @_;
2236 my ($name, $args) = @$ref;
2237 $name = $self->get_variable($name);
2238 my @args = $args ? map { $self->get_variable($_) } @$args : ();
2239 $self->throw($name, \
@args, $node);
2243 my ($self, $foo, $node, $out_ref) = @_;
2246 my $body_ref = $node->[4];
2247 eval { $self->execute_tree($body_ref, \
$out) };
2250 if (! $node->[5]) { # no catch or final
2251 if (! $err) { # no final block and no error
2255 $self->throw('parse.missing', "Missing CATCH block", $node);
2258 $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
2259 if ($err->type =~ /stop|return/) {
2265 ### loop through the nested catch and final blocks
2268 my $type = $err ? $err->type : '';
2270 while ($node = $node->[5]) { # CATCH
2271 if ($node->[0] eq 'FINAL') {
2272 $final = $node->[4];
2276 my $name = $self->get_variable($node->[3]);
2277 $name = '' if ! defined $name || lc($name) eq 'default';
2278 if ($type =~ / ^ \Q$name\E \b /x
2279 && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins
2280 $catch_body_ref = $node->[4] || [];
2281 $last_found = $name;
2285 ### play the best catch block
2287 if (! $catch_body_ref) {
2291 local $self->{'_vars'}->{'error'} = $err;
2292 local $self->{'_vars'}->{'e'} = $err;
2293 eval { $self->execute_tree($catch_body_ref, \
$out) };
2301 $self->execute_tree($final, \
$out) if $final;
2309 my $ref = $DIRECTIVES->{'IF'}->[0]->(@_);
2310 return [ \
[ '!', $ref ], 0 ];
2313 sub play_UNLESS
{ return $DIRECTIVES->{'IF'}->[1]->(@_) }
2316 my ($self, $tag_ref) = @_;
2319 my $copy = $$tag_ref;
2320 if (defined(my $_var = $self->parse_variable(\
$copy, {auto_quote
=> qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
2321 && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
2327 my $module = $self->parse_variable(\
$copy, {auto_quote
=> qr{ ^ (\w+ (?: (?:\.|::) \w+)*) $QR_AQ_NOTDOT }xo});
2328 $self->throw('parse', "Missing plugin name while parsing $$tag_ref") if ! defined $module;
2329 $module =~ s/\./::/g;
2332 my $open = $copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox;
2333 $args = $self->parse_args(\
$copy);
2336 $copy =~ s
{ ^ \
) \s
* $QR_COMMENTS }{}ox
|| $self->throw('parse.missing', "Missing close ')'");
2340 return [$var, $module, $args];
2344 my ($self, $ref, $node, $out_ref) = @_;
2345 my ($var, $module, $args) = @$ref;
2347 ### get the stash storage location - default to the module
2348 $var = $module if ! defined $var;
2349 my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
2350 pop @var; # remove the trailing '.'
2352 ### look for a plugin_base
2353 my $base = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
2354 my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
2355 : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
2356 : "${base}::${module}";
2357 my $require = "$package.pm";
2358 $require =~ s
|::|/|g
;
2360 ### try and load the module - fall back to bare module if allowed
2362 if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
2363 my $shape = $package->load;
2364 my $context = $self->context;
2365 my @args = $args ? map { $self->get_variable($_) } @$args : ();
2366 $obj = $shape->new($context, @args);
2367 } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
2368 $obj = $PACKAGE_ITERATOR->new($args ? $self->get_variable($args->[0]) : []);
2369 } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base
=> $base}) }) {
2370 foreach my $package (@packages) {
2371 my $require = "$package.pm";
2372 $require =~ s
|::|/|g
;
2373 eval {require $require} || next;
2374 my $shape = $package->load;
2375 my $context = $self->context;
2376 my @args = $args ? map { $self->get_variable($_) } @$args : ();
2377 $obj = $shape->new($context, @args);
2379 } elsif ($self->{'LOAD_PERL'}) {
2380 my $require = "$module.pm";
2381 $require =~ s
|::|/|g
;
2382 if (eval {require $require}) {
2383 my @args = $args ? map { $self->get_variable($_) } @$args : ();
2384 $obj = $module->new(@args);
2387 if (! defined $obj) {
2388 my $err = "$module: plugin not found";
2389 $self->throw('plugin', $err);
2393 $self->set_variable(\
@var, $obj);
2399 my ($self, $var, $node, $out_ref) = @_;
2400 return '' if ! defined $var;
2402 my $sub_tree = $node->[4];
2404 ### iterate use the iterator object
2405 my $count = $WHILE_MAX;
2406 while (--$count > 0) {
2408 $self->get_variable($var) || last;
2410 ### execute the sub tree
2411 eval { $self->execute_tree($sub_tree, $out_ref) };
2413 if (UNIVERSAL
::isa
($err, $PACKAGE_EXCEPTION)) {
2414 next if $err->type =~ /next/;
2415 last if $err->type =~ /last|break/;
2420 die "WHILE loop terminated (> $WHILE_MAX iterations)\n" if ! $count;
2425 sub parse_WRAPPER
{ $DIRECTIVES->{'INCLUDE'}->[0]->(@_) }
2428 my ($self, $var, $node, $out_ref) = @_;
2429 my $sub_tree = $node->[4] || return;
2431 my ($names, $args) = @$var;
2434 $self->execute_tree($sub_tree, \
$out);
2436 foreach my $name (reverse @$names) {
2437 local $self->{'_vars'}->{'content'} = $out;
2439 $DIRECTIVES->{'INCLUDE'}->[1]->($self, [[$name], $args], $node, \
$out);
2446 ###----------------------------------------------------------------###
2450 $self->{'_vars'} = shift if $#_ == 0;
2451 return $self->{'_vars'} ||= {};
2454 sub include_filename
{
2455 my ($self, $file) = @_;
2456 if ($file =~ m
|^/|) {
2457 $self->throw('file', "$file absolute paths are not allowed (set ABSOLUTE option)") if ! $self->{'ABSOLUTE'};
2458 return $file if -e
$file;
2459 } elsif ($file =~ m{(^|/)\.\./}) {
2460 $self->throw('file', "$file relative paths are not allowed (set RELATIVE option)") if ! $self->{'RELATIVE'};
2461 return $file if -e
$file;
2464 my $paths = $self->{'INCLUDE_PATHS'} ||= do {
2465 # TT does this everytime a file is looked up - we are going to do it just in time - the first time
2466 my $paths = $self->{'INCLUDE_PATH'} || $self->throw('file', "INCLUDE_PATH not set");
2467 $paths = $paths->() if UNIVERSAL
::isa
($paths, 'CODE');
2468 $paths = $self->split_paths($paths) if ! UNIVERSAL
::isa
($paths, 'ARRAY');
2469 $paths; # return of the do
2471 foreach my $path (@$paths) {
2472 return "$path/$file" if -e
"$path/$file";
2475 $self->throw('file', "$file: not found");
2479 my ($self, $path) = @_;
2480 return $path if ref $path;
2481 my $delim = $self->{'DELIMITER'} || ':';
2482 $delim = ($delim eq ':' && $^O eq 'MSWin32') ? qr
|:(?!/)| : qr
|\Q
$delim\E
|;
2483 return [split $delim, $path];
2487 my ($self, $file) = @_;
2488 return $self->slurp($self->include_filename($file));
2492 my ($self, $file) = @_;
2494 open(FH
, "<$file") || $self->throw('file', "$file couldn't be opened: $!");
2495 read FH
, my $txt, -s
$file;
2500 sub process_simple
{
2502 my $in = shift || die "Missing input";
2503 my $swap = shift || die "Missing variable hash";
2504 my $out = shift || die "Missing output string ref";
2507 delete $self->{'_debug_off'};
2508 delete $self->{'_debug_format'};
2509 local $self->{'_start_top_level'} = 1;
2510 $self->_process($in, $swap, $out);
2513 if ($err->type !~ /stop|return|next|last|break/) {
2514 $self->{'error'} = $err;
2522 my ($self, $in, $swap, $out, @ARGS) = @_;
2523 delete $self->{'error'};
2526 $args = ($#ARGS == 0 && UNIVERSAL
::isa
($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS;
2527 $self->DEBUG("set binmode\n") if $DEBUG && $args->{'binmode'}; # holdover for TT2 tests
2532 if (UNIVERSAL
::isa
($in, 'SCALAR')) { # reference to a string
2534 } elsif (UNIVERSAL
::isa
($in, 'CODE')) {
2536 $content = \
$content;
2537 } else { # should be a file handle
2540 $content = \
$content;
2543 ### should be a filename
2548 ### prepare block localization
2549 my $blocks = $self->{'BLOCKS'} ||= {};
2556 ### localize the stash
2558 my $var1 = $self->{'_vars'} ||= {};
2559 my $var2 = $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {};
2560 $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing
2561 my $copy = {%$var2, %$var1, %$swap};
2562 local $copy->{'template'};
2564 local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore
2566 delete $self->{'_debug_off'};
2567 delete $self->{'_debug_format'};
2569 ### handle pre process items that go before every document
2570 if ($self->{'PRE_PROCESS'}) {
2571 foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) {
2573 $self->_process($name, $copy, \
$out);
2574 $output = $out . $output;
2578 ### handle the process config - which loads a template in place of the real one
2579 if (exists $self->{'PROCESS'}) {
2580 ### load the meta data for the top document
2581 my $doc = $self->load_parsed_tree($content) || {};
2582 my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'METADEF')
2583 ? $doc->{'_tree'}->[0]->[3] : {};
2585 $copy->{'template'} = $doc;
2586 @{ $doc }{keys %$meta} = values %$meta;
2588 ### process any other templates
2589 foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) {
2590 next if ! length $name;
2591 $self->_process($name, $copy, \
$output);
2594 ### handle "normal" content
2596 local $self->{'_start_top_level'} = 1;
2597 $self->_process($content, $copy, \
$output);
2601 ### handle post process items that go after every document
2602 if ($self->{'POST_PROCESS'}) {
2603 foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) {
2604 $self->_process($name, $copy, \
$output);
2610 $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
2611 if ($err->type !~ /stop|return|next|last|break/) {
2612 $self->{'error'} = $err;
2619 ### clear blocks as asked (AUTO_RESET) defaults to on
2620 $self->{'BLOCKS'} = $blocks if exists($self->{'AUTO_RESET'}) && ! $self->{'AUTO_RESET'};
2622 ### send the content back out
2623 $out ||= $self->{'OUTPUT'};
2625 if (UNIVERSAL
::isa
($out, 'CODE')) {
2627 } elsif (UNIVERSAL
::can
($out, 'print')) {
2628 $out->print($output);
2629 } elsif (UNIVERSAL
::isa
($out, 'SCALAR')) { # reference to a string
2631 } elsif (UNIVERSAL
::isa
($out, 'ARRAY')) {
2632 push @$out, $output;
2633 } else { # should be a file handle
2636 } elsif ($out) { # should be a filename
2638 if ($out =~ m
|^/|) {
2639 if (! $self->{'ABSOLUTE'}) {
2640 $self->{'error'} = $self->throw('file', "ABSOLUTE paths disabled");
2644 } elsif ($out =~ m
|^\
.\
.?/|) {
2645 if (! $self->{'RELATIVE'}) {
2646 $self->{'error'} = $self->throw('file', "RELATIVE paths disabled");
2651 if (! $self->{'OUTPUT_PATH'}) {
2652 $self->{'error'} = $self->throw('file', "OUTPUT_PATH not set");
2654 $file = $self->{'OUTPUT_PATH'} . '/' . $out;
2659 if (open FH
, ">$file") {
2660 if (my $bm = $args->{'binmode'}) {
2661 if (+$bm == 1) { binmode FH
}
2662 else { binmode FH
, $bm }
2667 $self->{'error'} = $self->throw('file', "$out couldn't be opened for writing: $!");
2674 return if $self->{'error'};
2678 sub error
{ shift-
>{'error'} }
2682 print STDERR
"DEBUG: ", @_;
2685 ###----------------------------------------------------------------###
2688 my ($self, $type, $info, $node) = @_;
2689 return $type if ref($type) =~ /Template::Exception$/;
2690 if (ref($info) eq 'ARRAY') {
2691 my $hash = ref($info->[-1]) eq 'HASH' ? pop(@$info) : {};
2692 if (@$info >= 2 || scalar keys %$hash) {
2694 $hash->{$_} = $info->[$_] for 0 .. $#$info;
2695 $hash->{'args'} = $info;
2697 } elsif (@$info == 1) {
2704 return $PACKAGE_EXCEPTION->new($type, $info, $node);
2707 sub throw
{ die shift-
>exception(@_) }
2711 return bless {_template
=> $self}, $PACKAGE_CONTEXT; # a fake context
2715 my ($self, $ident, $node) = @_;
2716 return $self->{'UNDEFINED_GET'}->($self, $ident, $node) if $self->{'UNDEFINED_GET'};
2721 my ($self, $ident) = @_;
2722 return $self->{'UNDEFINED_ANY'}->($self, $ident) if $self->{'UNDEFINED_ANY'};
2728 return $self->{'_filters'} ||= eval { require Template
::Filters
; $Template::Filters
::FILTERS
} || {};
2733 my $args = shift || {};
2734 my $base = $args->{'base'} || '';
2736 return $self->{'_plugins'}->{$base} ||= do {
2740 my @dirs = grep {-d
$_} map {"$_/$base"} @INC;
2742 foreach my $dir (@dirs) {
2744 File
::Find
::find
(sub {
2745 my $mod = $base .'/'. ($File::Find
::name
=~ m
|^ $dir / (.*\w
) \
.pm
$|x
? $1 : return);
2747 push @plugins, $mod;
2751 \
@plugins; # return of the do
2755 ### get a copy of self without circular refs for use in closures
2759 if (eval { require Scalar
::Util
}
2760 && defined &Scalar
::Util
::weaken
) {
2762 Scalar
::Util
::weaken
($self_copy);
2764 $self_copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on old perls (pre 5.8)
2770 my ($self, $node) = @_;
2771 my $info = $self->node_info($node);
2772 my $format = $self->{'_debug_format'} || $self->{'DEBUG_FORMAT'} || "\n## \$file line \$line : [% \$text %] ##\n";
2773 $format =~ s{\$(file|line|text)}{$info->{$1}}g
;
2778 my ($self, $node) = @_;
2779 my $doc = $self->{'_vars'}->{'component'};
2781 my $j = $node->[2] || return ''; # METADEF can be 0
2782 $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \
$s };
2783 my $s = substr(${ $doc->{'_content'} }, $i, $j - $i);
2787 file
=> $doc->{'name'},
2788 line
=> $self->get_line_number_by_index($doc, $i),
2793 sub get_line_number_by_index
{
2794 my ($self, $doc, $index) = @_;
2795 ### get the line offsets for the doc
2796 my $lines = $doc->{'line_offsets'} ||= do {
2797 $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \
$s };
2801 $i = index(${ $doc->{'_content'} }, "\n", $i) + 1;
2807 ### binary search them (this is fast even on big docs)
2808 return $#$lines + 1 if $index > $lines->[-1];
2809 my ($i, $j) = (0, $#$lines);
2811 return $i + 1 if abs($i - $j) <= 1;
2812 my $k = int(($i + $j) / 2);
2813 $j = $k if $lines->[$k] >= $index;
2814 $i = $k if $lines->[$k] <= $index;
2818 ###----------------------------------------------------------------###
2819 ### long virtual methods or filters
2820 ### many of these vmethods have used code from Template/Stash.pm to
2821 ### assure conformance with the TT spec.
2823 sub define_vmethod
{
2824 my ($self, $type, $name, $sub) = @_;
2825 if ( $type =~ /scalar|item/i) { $SCALAR_OPS->{$name} = $sub }
2826 elsif ($type =~ /array|list/i ) { $LIST_OPS->{ $name} = $sub }
2827 elsif ($type =~ /hash/i ) { $HASH_OPS->{ $name} = $sub }
2828 elsif ($type =~ /filter/i ) { $FILTER_OPS->{$name} = $sub }
2830 die "Invalid type vmethod type $type";
2835 sub vmethod_as_scalar
{
2836 my ($str, $pat) = @_;
2837 $pat = '%s' if ! defined $pat;
2839 return sprintf $pat, $str;
2842 sub vmethod_as_list
{
2843 my ($ref, $pat, $sep) = @_;
2844 $pat = '%s' if ! defined $pat;
2845 $sep = ' ' if ! defined $sep;
2847 return join($sep, map {sprintf $pat, $_} @$ref);
2850 sub vmethod_as_hash
{
2851 my ($ref, $pat, $sep) = @_;
2852 $pat = "%s\t%s" if ! defined $pat;
2853 $sep = "\n" if ! defined $sep;
2855 return join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref);
2860 my $size = shift || 1;
2862 if ($size < 0) { # chunk from the opposite end
2863 $str = reverse $str;
2865 unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg;
2867 push(@list, $1) while $str =~ /( .{$size} | .+ )/xg;
2872 sub vmethod_indent
{
2873 my $str = shift; $str = '' if ! defined $str;
2874 my $pre = shift; $pre = 4 if ! defined $pre;
2875 $pre = ' ' x
$pre if $pre =~ /^\d+$/;
2876 $str =~ s/^/$pre/mg;
2880 sub vmethod_format
{
2881 my $str = shift; $str = '' if ! defined $str;
2882 my $pat = shift; $pat = '%s' if ! defined $pat;
2883 return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
2887 my ($str, $pat, $global) = @_;
2888 return [] if ! defined $str || ! defined $pat;
2889 my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
2890 return (@res >= 2) ? \
@res : (@res == 1) ? $res[0] : '';
2894 my ($list, $field) = @_;
2895 return defined($field)
2896 ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field}
2897 : UNIVERSAL
::can
($_, $field) ? $_->$field()
2899 : [sort {$a <=> $b} @$list];
2902 sub vmethod_repeat
{
2903 my ($str, $n, $join) = @_;
2904 return if ! length $str;
2905 $n = 1 if ! defined($n) || ! length $n;
2906 $join = '' if ! defined $join;
2907 return join $join, ($str) x
$n;
2910 ### This method is a combination of my submissions along
2911 ### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum
2912 sub vmethod_replace
{
2913 my ($text, $pattern, $replace, $global) = @_;
2914 $text = '' unless defined $text;
2915 $pattern = '' unless defined $pattern;
2916 $replace = '' unless defined $replace;
2917 $global = 1 unless defined $global;
2919 my ($chunk, $start, $end) = @_;
2920 $chunk =~ s
{ \\(\\|\
$) | \
$ (\d
+) }{
2922 : ($2 > $#$start || $2 == 0) ? ''
2923 : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
2928 $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg;
2930 $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e;
2936 my ($list, $field) = @_;
2937 return defined($field)
2938 ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field}
2939 : UNIVERSAL
::can
($_, $field) ? $_->$field()
2941 : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive
2944 sub vmethod_splice
{
2945 my ($ref, $i, $len, @replace) = @_;
2946 @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
2948 return [splice @$ref, $i || 0, $len, @replace];
2950 return [splice @$ref, $i || 0];
2955 my ($str, $pat, @args) = @_;
2956 $str = '' if ! defined $str;
2957 return defined $pat ? [split $pat, $str, @args] : [split ' ', $str, @args];
2962 utf8
::encode
($str) if defined &utf8
::encode
;
2963 $str =~ s/([^A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg;
2968 my $context = shift;
2971 return $context->process(\
$text);
2975 sub filter_redirect
{
2976 my ($context, $file, $options) = @_;
2977 my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set');
2978 $context->throw('redirect', 'Invalid filename - cannot include "/../"')
2979 if $file =~ m{(^|/)\.\./};
2985 File
::Path
::mkpath
($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
2988 open (FH
, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
2989 if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) {
2990 if (+$bm == 1) { binmode FH
}
2991 else { binmode FH
, $bm}
2999 ###----------------------------------------------------------------###
3002 my $obj = UNIVERSAL
::isa
($_[0], __PACKAGE__
) ? shift : __PACKAGE__-
>new;
3004 require Data
::Dumper
;
3005 return Data
::Dumper
::Dumper
($obj->parse_variable(\
$str));
3008 ###----------------------------------------------------------------###
3010 package CGI
::Ex
::Template
::Exception
;
3013 '""' => \
&as_string
,
3014 bool
=> sub { defined shift },
3018 my ($class, $type, $info, $node, $pos, $str_ref) = @_;
3019 return bless [$type, $info, $node, $pos, $str_ref], $class;
3022 sub type
{ shift-
>[0] }
3024 sub info
{ shift-
>[1] }
3028 $self->[2] = shift if $#_ == 0;
3032 sub offset
{ shift-
>[3] || 0 }
3036 $self->[4] = shift if $#_ == 0;
3042 my $msg = $self->type .' error - '. $self->info;
3043 if (my $node = $self->node) {
3044 # $msg .= " (In tag $node->[0] starting at char ".($node->[1] + $self->offset).")";
3049 ###----------------------------------------------------------------###
3051 package CGI
::Ex
::Template
::Iterator
;
3054 my ($class, $items) = @_;
3055 $items = [] if ! defined $items;
3056 if (UNIVERSAL
::isa
($items, 'HASH')) {
3057 $items = [ map { {key
=> $_, value
=> $items->{ $_ }} } sort keys %$items ];
3058 } elsif (UNIVERSAL
::can
($items, 'as_list')) {
3059 $items = $items->as_list;
3060 } elsif (! UNIVERSAL
::isa
($items, 'ARRAY')) {
3063 return bless [$items, 0], $class;
3068 return (undef, 3) if ! @{ $self->[0] };
3069 return ($self->[0]->[$self->[1] = 0], undef);
3074 return (undef, 3) if ++ $self->[1] > $#{ $self->[0] };
3075 return ($self->items->[$self->[1]], undef);
3078 sub items
{ shift-
>[0] }
3080 sub index { shift-
>[1] }
3082 sub max
{ $#{ shift-
>[0] } }
3084 sub size
{ shift-
>max + 1 }
3086 sub count
{ shift-
>index + 1 }
3088 sub number
{ shift-
>index + 1 }
3090 sub first
{ (shift-
>index == 0) || 0 }
3092 sub last { my $self = shift; return ($self->index == $self->max) || 0 }
3096 return undef if $self->index <= 0;
3097 return $self->items->[$self->index - 1];
3102 return undef if $self->index >= $self->max;
3103 return $self->items->[$self->index + 1];
3106 ###----------------------------------------------------------------###
3108 package CGI
::Ex
::Template
::_Context
;
3110 use vars
qw($AUTOLOAD);
3112 sub _template
{ shift-
>{'_template'} || die "Missing _template" }
3114 sub config
{ shift-
>_template }
3118 return $self->{'stash'} ||= bless {_template
=> $self->_template}, $CGI::Ex
::Template
::PACKAGE_STASH
;
3121 sub insert
{ shift-
>_template->_insert(@_) }
3123 sub eval_perl
{ shift-
>_template->{'EVAL_PERL'} }
3128 my $vars = $self->_template->_vars;
3130 $self->_template->_process($ref, $vars, \
$out);
3137 my $args = shift || {};
3139 $self->_template->set_variable($_, $args->{$_}) for keys %$args;
3141 my $out = ''; # have temp item to allow clear to correctly clear
3142 eval { $self->_template->_process($file, $self->{'_vars'}, \
$out) };
3144 die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
3151 my ($self, $name, $filter, $is_dynamic) = @_;
3152 $filter = [ $filter, 1 ] if $is_dynamic;
3153 $self->define_vmethod('filter', $name, $filter);
3157 my ($self, $name, $args, $alias) = @_;
3158 my $t = $self->_template;
3162 $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex
::Template
::FILTER_OPS-
>{$name} || $CGI::Ex
::Template
::SCALAR_OPS-
>{$name};
3163 $t->throw('filter', $name) if ! $filter;
3164 } elsif (UNIVERSAL
::isa
($name, 'CODE') || UNIVERSAL
::isa
($name, 'ARRAY')) {
3166 } elsif (UNIVERSAL
::can
($name, 'factory')) {
3167 $filter = $name->factory || $t->throw($name->error);
3169 $t->throw('undef', "$name: filter not found");
3172 if (UNIVERSAL
::isa
($filter, 'ARRAY')) {
3173 $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
3174 } elsif ($args && @$args) {
3176 $filter = sub { $sub->(shift, @$args) };
3179 $t->{'FILTERS'}->{$alias} = $filter if $alias;
3184 sub define_vmethod
{ shift-
>_template->define_vmethod(@_) }
3187 my ($self, $type, $info) = @_;
3189 if (UNIVERSAL
::isa
($type, $CGI::Ex
::Template
::PACKAGE_EXCEPTION
)) {
3191 } elsif (defined $info) {
3192 $self->_template->throw($type, $info);
3194 $self->_template->throw('undef', $type);
3198 sub AUTOLOAD
{ shift-
>_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
3202 ###----------------------------------------------------------------###
3204 package CGI
::Ex
::Template
::_Stash
;
3206 use vars
qw($AUTOLOAD);
3208 sub _template
{ shift-
>{'_template'} || die "Missing _template" }
3211 my ($self, $var) = @_;
3213 if ($var =~ /^\w+$/) { $var = [$var, 0] }
3214 else { $var = $self->_template->parse_variable(\
$var, {no_dots
=> 1}) }
3216 return $self->_template->get_variable($var, {no_dots
=> 1});
3220 my ($self, $var, $val) = @_;
3222 if ($var =~ /^\w+$/) { $var = [$var, 0] }
3223 else { $var = $self->_template->parse_variable(\
$var, {no_dots
=> 1}) }
3225 $self->_template->set_variable($var, $val, {no_dots
=> 1});
3229 sub AUTOLOAD
{ shift-
>_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
3233 ###----------------------------------------------------------------###
3235 package CGI
::Ex
::Template
::EvalPerlHandle
;
3238 my ($class, $out_ref) = @_;
3239 return bless [$out_ref], $class;
3244 ${ $self->[0] } .= $_ for grep {defined && length} @_;
3248 ###----------------------------------------------------------------###
3252 ### See the perldoc in CGI/Ex/Template.pod