← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:12:56 2013

Filename/usr/lib/perl5/Template/Directive.pm
StatementsExecuted 15989 statements in 73.5ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
9152223.0ms34.2msTemplate::Directive::::textTemplate::Directive::text
914117.48ms41.7msTemplate::Directive::::textblockTemplate::Directive::textblock
1830216.43ms6.43msTemplate::Directive::::CORE:substTemplate::Directive::CORE:subst (opcode)
670226.35ms6.35msTemplate::Directive::::identTemplate::Directive::ident
2526114.81ms4.81msTemplate::Directive::::CORE:substcontTemplate::Directive::CORE:substcont (opcode)
286314.68ms4.68msTemplate::Directive::::ifTemplate::Directive::if
417214.40ms4.40msTemplate::Directive::::blockTemplate::Directive::block
303211.86ms1.86msTemplate::Directive::::getTemplate::Directive::get
74111.60ms2.06msTemplate::Directive::::filterTemplate::Directive::filter
27111.12ms1.40msTemplate::Directive::::foreachTemplate::Directive::foreach
7822494µs494µsTemplate::Directive::::argsTemplate::Directive::args
811347µs1.04msTemplate::Directive::::templateTemplate::Directive::template
811167µs698µsTemplate::Directive::::CORE:matchTemplate::Directive::CORE:match (opcode)
811115µs193µsTemplate::Directive::::includeTemplate::Directive::include
81178µs78µsTemplate::Directive::::filenamesTemplate::Directive::filenames
31159µs87µsTemplate::Directive::::setTemplate::Directive::set
11152µs57µsTemplate::Directive::::BEGIN@33Template::Directive::BEGIN@33
31127µs27µsTemplate::Directive::::assignTemplate::Directive::assign
11118µs23µsTemplate::Directive::::BEGIN@29Template::Directive::BEGIN@29
11117µs61µsTemplate::Directive::::BEGIN@32Template::Directive::BEGIN@32
11112µs26µsTemplate::Directive::::BEGIN@30Template::Directive::BEGIN@30
11112µs128µsTemplate::Directive::::BEGIN@31Template::Directive::BEGIN@31
1118µs8µsTemplate::Directive::::quotedTemplate::Directive::quoted
0000s0sTemplate::Directive::::OLD_breakTemplate::Directive::OLD_break
0000s0sTemplate::Directive::::_initTemplate::Directive::_init
0000s0sTemplate::Directive::::anon_blockTemplate::Directive::anon_block
0000s0sTemplate::Directive::::callTemplate::Directive::call
0000s0sTemplate::Directive::::captureTemplate::Directive::capture
0000s0sTemplate::Directive::::clearTemplate::Directive::clear
0000s0sTemplate::Directive::::debugTemplate::Directive::debug
0000s0sTemplate::Directive::::defaultTemplate::Directive::default
0000s0sTemplate::Directive::::identrefTemplate::Directive::identref
0000s0sTemplate::Directive::::insertTemplate::Directive::insert
0000s0sTemplate::Directive::::macroTemplate::Directive::macro
0000s0sTemplate::Directive::::multi_wrapperTemplate::Directive::multi_wrapper
0000s0sTemplate::Directive::::nextTemplate::Directive::next
0000s0sTemplate::Directive::::no_perlTemplate::Directive::no_perl
0000s0sTemplate::Directive::::padTemplate::Directive::pad
0000s0sTemplate::Directive::::perlTemplate::Directive::perl
0000s0sTemplate::Directive::::processTemplate::Directive::process
0000s0sTemplate::Directive::::rawperlTemplate::Directive::rawperl
0000s0sTemplate::Directive::::returnTemplate::Directive::return
0000s0sTemplate::Directive::::stopTemplate::Directive::stop
0000s0sTemplate::Directive::::switchTemplate::Directive::switch
0000s0sTemplate::Directive::::throwTemplate::Directive::throw
0000s0sTemplate::Directive::::tryTemplate::Directive::try
0000s0sTemplate::Directive::::useTemplate::Directive::use
0000s0sTemplate::Directive::::viewTemplate::Directive::view
0000s0sTemplate::Directive::::whileTemplate::Directive::while
0000s0sTemplate::Directive::::wrapperTemplate::Directive::wrapper
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1#================================================================= -*-Perl-*-
2#
3# Template::Directive
4#
5# DESCRIPTION
6# Factory module for constructing templates from Perl code.
7#
8# AUTHOR
9# Andy Wardley <abw@wardley.org>
10#
11# WARNING
12# Much of this module is hairy, even furry in places. It needs
13# a lot of tidying up and may even be moved into a different place
14# altogether. The generator code is often inefficient, particulary in
15# being very anal about pretty-printing the Perl code all neatly, but
16# at the moment, that's still high priority for the sake of easier
17# debugging.
18#
19# COPYRIGHT
20# Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved.
21#
22# This module is free software; you can redistribute it and/or
23# modify it under the same terms as Perl itself.
24#
25#============================================================================
26
27package Template::Directive;
28
29339µs227µs
# spent 23µs (18+4) within Template::Directive::BEGIN@29 which was called: # once (18µs+4µs) by Template::Parser::BEGIN@40 at line 29
use strict;
# spent 23µs making 1 call to Template::Directive::BEGIN@29 # spent 4µs making 1 call to strict::import
30333µs240µs
# spent 26µs (12+14) within Template::Directive::BEGIN@30 which was called: # once (12µs+14µs) by Template::Parser::BEGIN@40 at line 30
use warnings;
# spent 26µs making 1 call to Template::Directive::BEGIN@30 # spent 14µs making 1 call to warnings::import
31336µs2244µs
# spent 128µs (12+116) within Template::Directive::BEGIN@31 which was called: # once (12µs+116µs) by Template::Parser::BEGIN@40 at line 31
use base 'Template::Base';
# spent 128µs making 1 call to Template::Directive::BEGIN@31 # spent 116µs making 1 call to base::import
32347µs2104µs
# spent 61µs (17+43) within Template::Directive::BEGIN@32 which was called: # once (17µs+43µs) by Template::Parser::BEGIN@40 at line 32
use Template::Constants;
# spent 61µs making 1 call to Template::Directive::BEGIN@32 # spent 43µs making 1 call to Exporter::import
3334.45ms262µs
# spent 57µs (52+5) within Template::Directive::BEGIN@33 which was called: # once (52µs+5µs) by Template::Parser::BEGIN@40 at line 33
use Template::Exception;
# spent 57µs making 1 call to Template::Directive::BEGIN@33 # spent 5µs making 1 call to UNIVERSAL::import
34
351600nsour $VERSION = 2.20;
361600nsour $DEBUG = 0 unless defined $DEBUG;
371200nsour $WHILE_MAX = 1000 unless defined $WHILE_MAX;
381200nsour $PRETTY = 0 unless defined $PRETTY;
391400nsour $OUTPUT = '$output .= ';
40
41
42sub _init {
43 my ($self, $config) = @_;
44 $self->{ NAMESPACE } = $config->{ NAMESPACE };
45 return $self;
46}
47
48
49sub pad {
50 my ($text, $pad) = @_;
51 $pad = ' ' x ($pad * 4);
52 $text =~ s/^(?!#line)/$pad/gm;
53 $text;
54}
55
56#========================================================================
57# FACTORY METHODS
58#
59# These methods are called by the parser to construct directive instances.
60#========================================================================
61
62#------------------------------------------------------------------------
63# template($block)
64#------------------------------------------------------------------------
65
66
# spent 1.04ms (347µs+698µs) within Template::Directive::template which was called 8 times, avg 131µs/call: # 8 times (347µs+698µs) by Template::Grammar::__ANON__[Parser.yp:64] at line 64 of Parser.yp, avg 131µs/call
sub template {
67845µs my ($class, $block) = @_;
6883µs $block = pad($block, 2) if $PRETTY;
69
708222µs91.23ms return "sub { return '' }" unless $block =~ /\S/;
# spent 698µs making 8 calls to Template::Directive::CORE:match, avg 87µs/call # spent 530µs making 1 call to utf8::SWASHNEW
71
728259µs return <<EOF;
73sub {
74 my \$context = shift || die "template sub called without context\\n";
75 my \$stash = \$context->stash;
76 my \$output = '';
77 my \$_tt_error;
78
79 eval { BLOCK: {
80$block
81 } };
82 if (\$@) {
83 \$_tt_error = \$context->catch(\$@, \\\$output);
84 die \$_tt_error unless \$_tt_error->type eq 'return';
85 }
86
87 return \$output;
88}
89EOF
90}
91
92
93#------------------------------------------------------------------------
94# anon_block($block) [% BLOCK %] ... [% END %]
95#------------------------------------------------------------------------
96
97sub anon_block {
98 my ($class, $block) = @_;
99 $block = pad($block, 2) if $PRETTY;
100
101 return <<EOF;
102
103# BLOCK
104$OUTPUT do {
105 my \$output = '';
106 my \$_tt_error;
107
108 eval { BLOCK: {
109$block
110 } };
111 if (\$@) {
112 \$_tt_error = \$context->catch(\$@, \\\$output);
113 die \$_tt_error unless \$_tt_error->type eq 'return';
114 }
115
116 \$output;
117};
118EOF
119}
120
121
122#------------------------------------------------------------------------
123# block($blocktext)
124#------------------------------------------------------------------------
125
126
# spent 4.40ms within Template::Directive::block which was called 417 times, avg 11µs/call: # 416 times (4.40ms+0s) by Template::Grammar::__ANON__[Parser.yp:67] at line 67 of Parser.yp, avg 11µs/call # once (3µs+0s) by Template::Grammar::__ANON__[Parser.yp:68] at line 68 of Parser.yp
sub block {
127417545µs my ($class, $block) = @_;
1284175.17ms return join("\n", @{ $block || [] });
129}
130
131
132#------------------------------------------------------------------------
133# textblock($text)
134#------------------------------------------------------------------------
135
136
# spent 41.7ms (7.48+34.2) within Template::Directive::textblock which was called 914 times, avg 46µs/call: # 914 times (7.48ms+34.2ms) by Template::Grammar::__ANON__[Parser.yp:76] at line 76 of Parser.yp, avg 46µs/call
sub textblock {
1379141.04ms my ($class, $text) = @_;
1389146.20ms91434.2ms return "$OUTPUT " . &text($class, $text) . ';';
# spent 34.2ms making 914 calls to Template::Directive::text, avg 37µs/call
139}
140
141
142#------------------------------------------------------------------------
143# text($text)
144#------------------------------------------------------------------------
145
146
# spent 34.2ms (23.0+11.2) within Template::Directive::text which was called 915 times, avg 37µs/call: # 914 times (23.0ms+11.2ms) by Template::Directive::textblock at line 138, avg 37µs/call # once (15µs+4µs) by Template::Grammar::__ANON__[Parser.yp:440] at line 440 of Parser.yp
sub text {
147915971µs my ($class, $text) = @_;
1489151.86ms for ($text) {
14991520.6ms34418.19ms s/(["\$\@\\])/\\$1/g;
# spent 4.81ms making 2526 calls to Template::Directive::CORE:substcont, avg 2µs/call # spent 3.38ms making 915 calls to Template::Directive::CORE:subst, avg 4µs/call
1509157.52ms9153.05ms s/\n/\\n/g;
# spent 3.05ms making 915 calls to Template::Directive::CORE:subst, avg 3µs/call
151 }
1529154.37ms return '"' . $text . '"';
153}
154
155
156#------------------------------------------------------------------------
157# quoted(\@items) "foo$bar"
158#------------------------------------------------------------------------
159
160
# spent 8µs within Template::Directive::quoted which was called: # once (8µs+0s) by Template::Grammar::__ANON__[Parser.yp:307] at line 307 of Parser.yp
sub quoted {
16112µs my ($class, $items) = @_;
1621900ns return '' unless @$items;
163110µs return ("('' . " . $items->[0] . ')') if scalar @$items == 1;
164 return '(' . join(' . ', @$items) . ')';
165# my $r = '(' . join(' . ', @$items) . ' . "")';
166# print STDERR "[$r]\n";
167# return $r;
168}
169
170
171#------------------------------------------------------------------------
172# ident(\@ident) foo.bar(baz)
173#------------------------------------------------------------------------
174
175
# spent 6.35ms within Template::Directive::ident which was called 670 times, avg 9µs/call: # 643 times (6.07ms+0s) by Template::Grammar::__ANON__[Parser.yp:305] at line 305 of Parser.yp, avg 9µs/call # 27 times (281µs+0s) by Template::Directive::foreach at line 404, avg 10µs/call
sub ident {
176670808µs my ($class, $ident) = @_;
177670304µs return "''" unless @$ident;
178670171µs my $ns;
179
180 # does the first element of the identifier have a NAMESPACE
181 # handler defined?
182670308µs if (ref $class && @$ident > 2 && ($ns = $class->{ NAMESPACE })) {
183 my $key = $ident->[0];
184 $key =~ s/^'(.+)'$/$1/s;
185 if ($ns = $ns->{ $key }) {
186 return $ns->ident($ident);
187 }
188 }
189
1906701.13ms if (scalar @$ident <= 2 && ! $ident->[1]) {
191 $ident = $ident->[0];
192 }
193 else {
1942701.07ms $ident = '[' . join(', ', @$ident) . ']';
195 }
1966704.52ms return "\$stash->get($ident)";
197}
198
199#------------------------------------------------------------------------
200# identref(\@ident) \foo.bar(baz)
201#------------------------------------------------------------------------
202
203sub identref {
204 my ($class, $ident) = @_;
205 return "''" unless @$ident;
206 if (scalar @$ident <= 2 && ! $ident->[1]) {
207 $ident = $ident->[0];
208 }
209 else {
210 $ident = '[' . join(', ', @$ident) . ']';
211 }
212 return "\$stash->getref($ident)";
213}
214
215
216#------------------------------------------------------------------------
217# assign(\@ident, $value, $default) foo = bar
218#------------------------------------------------------------------------
219
220
# spent 27µs within Template::Directive::assign which was called 3 times, avg 9µs/call: # 3 times (27µs+0s) by Template::Directive::set at line 294, avg 9µs/call
sub assign {
22135µs my ($class, $var, $val, $default) = @_;
222
22336µs if (ref $var) {
224 if (scalar @$var == 2 && ! $var->[1]) {
225 $var = $var->[0];
226 }
227 else {
228 $var = '[' . join(', ', @$var) . ']';
229 }
230 }
23131µs $val .= ', 1' if $default;
232321µs return "\$stash->set($var, $val)";
233}
234
235
236#------------------------------------------------------------------------
237# args(\@args) foo, bar, baz = qux
238#------------------------------------------------------------------------
239
240
# spent 494µs within Template::Directive::args which was called 78 times, avg 6µs/call: # 74 times (460µs+0s) by Template::Directive::filter at line 876, avg 6µs/call # 4 times (33µs+0s) by Template::Grammar::__ANON__[Parser.yp:342] at line 342 of Parser.yp, avg 8µs/call
sub args {
2417877µs my ($class, $args) = @_;
2427861µs my $hash = shift @$args;
2437867µs push(@$args, '{ ' . join(', ', @$hash) . ' }')
244 if @$hash;
245
24678498µs return '0' unless @$args;
247652µs return '[ ' . join(', ', @$args) . ' ]';
248}
249
250#------------------------------------------------------------------------
251# filenames(\@names)
252#------------------------------------------------------------------------
253
254
# spent 78µs within Template::Directive::filenames which was called 8 times, avg 10µs/call: # 8 times (78µs+0s) by Template::Directive::include at line 339, avg 10µs/call
sub filenames {
255811µs my ($class, $names) = @_;
256812µs if (@$names > 1) {
257 $names = '[ ' . join(', ', @$names) . ' ]';
258 }
259 else {
26088µs $names = shift @$names;
261 }
262856µs return $names;
263}
264
265
266#------------------------------------------------------------------------
267# get($expr) [% foo %]
268#------------------------------------------------------------------------
269
270
# spent 1.86ms within Template::Directive::get which was called 303 times, avg 6µs/call: # 236 times (1.44ms+0s) by Template::Grammar::__ANON__[Parser.yp:90] at line 90 of Parser.yp, avg 6µs/call # 67 times (416µs+0s) by Template::Grammar::__ANON__[Parser.yp:109] at line 109 of Parser.yp, avg 6µs/call
sub get {
271303327µs my ($class, $expr) = @_;
2723032.31ms return "$OUTPUT $expr;";
273}
274
275
276#------------------------------------------------------------------------
277# call($expr) [% CALL bar %]
278#------------------------------------------------------------------------
279
280sub call {
281 my ($class, $expr) = @_;
282 $expr .= ';';
283 return $expr;
284}
285
286
287#------------------------------------------------------------------------
288# set(\@setlist) [% foo = bar, baz = qux %]
289#------------------------------------------------------------------------
290
291
# spent 87µs (59+27) within Template::Directive::set which was called 3 times, avg 29µs/call: # 3 times (59µs+27µs) by Template::Grammar::__ANON__[Parser.yp:115] at line 115 of Parser.yp, avg 29µs/call
sub set {
29234µs my ($class, $setlist) = @_;
29331µs my $output;
294322µs327µs while (my ($var, $val) = splice(@$setlist, 0, 2)) {
# spent 27µs making 3 calls to Template::Directive::assign, avg 9µs/call
295 $output .= &assign($class, $var, $val) . ";\n";
296 }
297310µs chomp $output;
298311µs return $output;
299}
300
301
302#------------------------------------------------------------------------
303# default(\@setlist) [% DEFAULT foo = bar, baz = qux %]
304#------------------------------------------------------------------------
305
306sub default {
307 my ($class, $setlist) = @_;
308 my $output;
309 while (my ($var, $val) = splice(@$setlist, 0, 2)) {
310 $output .= &assign($class, $var, $val, 1) . ";\n";
311 }
312 chomp $output;
313 return $output;
314}
315
316
317#------------------------------------------------------------------------
318# insert(\@nameargs) [% INSERT file %]
319# # => [ [ $file, ... ], \@args ]
320#------------------------------------------------------------------------
321
322sub insert {
323 my ($class, $nameargs) = @_;
324 my ($file, $args) = @$nameargs;
325 $file = $class->filenames($file);
326 return "$OUTPUT \$context->insert($file);";
327}
328
329
330#------------------------------------------------------------------------
331# include(\@nameargs) [% INCLUDE template foo = bar %]
332# # => [ [ $file, ... ], \@args ]
333#------------------------------------------------------------------------
334
335
# spent 193µs (115+78) within Template::Directive::include which was called 8 times, avg 24µs/call: # 8 times (115µs+78µs) by Template::Grammar::__ANON__[Parser.yp:118] at line 118 of Parser.yp, avg 24µs/call
sub include {
336811µs my ($class, $nameargs) = @_;
337810µs my ($file, $args) = @$nameargs;
33888µs my $hash = shift @$args;
339835µs878µs $file = $class->filenames($file);
# spent 78µs making 8 calls to Template::Directive::filenames, avg 10µs/call
34089µs $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
341839µs return "$OUTPUT \$context->include($file);";
342}
343
344
345#------------------------------------------------------------------------
346# process(\@nameargs) [% PROCESS template foo = bar %]
347# # => [ [ $file, ... ], \@args ]
348#------------------------------------------------------------------------
349
350sub process {
351 my ($class, $nameargs) = @_;
352 my ($file, $args) = @$nameargs;
353 my $hash = shift @$args;
354 $file = $class->filenames($file);
355 $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
356 return "$OUTPUT \$context->process($file);";
357}
358
359
360#------------------------------------------------------------------------
361# if($expr, $block, $else) [% IF foo < bar %]
362# ...
363# [% ELSE %]
364# ...
365# [% END %]
366#------------------------------------------------------------------------
367
368
# spent 4.68ms within Template::Directive::if which was called 286 times, avg 16µs/call: # 273 times (4.52ms+0s) by Template::Grammar::__ANON__[Parser.yp:141] at line 141 of Parser.yp, avg 17µs/call # 12 times (162µs+0s) by Template::Grammar::__ANON__[Parser.yp:144] at line 144 of Parser.yp, avg 13µs/call # once (6µs+0s) by Template::Grammar::__ANON__[Parser.yp:145] at line 145 of Parser.yp
sub if {
369286543µs my ($class, $expr, $block, $else) = @_;
370286373µs my @else = $else ? @$else : ();
371286216µs $else = pop @else;
372286108µs $block = pad($block, 1) if $PRETTY;
373
374286822µs my $output = "if ($expr) {\n$block\n}\n";
375
376286554µs foreach my $elsif (@else) {
37746µs ($expr, $block) = @$elsif;
37841µs $block = pad($block, 1) if $PRETTY;
379415µs $output .= "elsif ($expr) {\n$block\n}\n";
380 }
381286158µs if (defined $else) {
3829325µs $else = pad($else, 1) if $PRETTY;
38393276µs $output .= "else {\n$else\n}\n";
384 }
385
3862862.44ms return $output;
387}
388
389
390#------------------------------------------------------------------------
391# foreach($target, $list, $args, $block) [% FOREACH x = [ foo bar ] %]
392# ...
393# [% END %]
394#------------------------------------------------------------------------
395
396
# spent 1.40ms (1.12+281µs) within Template::Directive::foreach which was called 27 times, avg 52µs/call: # 27 times (1.12ms+281µs) by Template::Grammar::__ANON__[Parser.yp:168] at line 168 of Parser.yp, avg 52µs/call
sub foreach {
39727102µs my ($class, $target, $list, $args, $block, $label) = @_;
3982733µs $args = shift @$args;
3992751µs $args = @$args ? ', { ' . join(', ', @$args) . ' }' : '';
4002712µs $label ||= 'LOOP';
401
4022727µs my ($loop_save, $loop_set, $loop_restore, $setiter);
4032791µs if ($target) {
40427186µs27281µs $loop_save = 'eval { $_tt_oldloop = ' . &ident($class, ["'loop'"]) . ' }';
# spent 281µs making 27 calls to Template::Directive::ident, avg 10µs/call
4052739µs $loop_set = "\$stash->{'$target'} = \$_tt_value";
4062727µs $loop_restore = "\$stash->set('loop', \$_tt_oldloop)";
407 }
408 else {
409 $loop_save = '$stash = $context->localise()';
410# $loop_set = "\$stash->set('import', \$_tt_value) "
411# . "if ref \$value eq 'HASH'";
412 $loop_set = "\$stash->get(['import', [\$_tt_value]]) "
413 . "if ref \$_tt_value eq 'HASH'";
414 $loop_restore = '$stash = $context->delocalise()';
415 }
4162719µs $block = pad($block, 3) if $PRETTY;
417
41827484µs return <<EOF;
419
420# FOREACH
421do {
422 my (\$_tt_value, \$_tt_error, \$_tt_oldloop);
423 my \$_tt_list = $list;
424
425 unless (UNIVERSAL::isa(\$_tt_list, 'Template::Iterator')) {
426 \$_tt_list = Template::Config->iterator(\$_tt_list)
427 || die \$Template::Config::ERROR, "\\n";
428 }
429
430 (\$_tt_value, \$_tt_error) = \$_tt_list->get_first();
431 $loop_save;
432 \$stash->set('loop', \$_tt_list);
433 eval {
434$label: while (! \$_tt_error) {
435 $loop_set;
436$block;
437 (\$_tt_value, \$_tt_error) = \$_tt_list->get_next();
438 }
439 };
440 $loop_restore;
441 die \$@ if \$@;
442 \$_tt_error = 0 if \$_tt_error && \$_tt_error eq Template::Constants::STATUS_DONE;
443 die \$_tt_error if \$_tt_error;
444};
445EOF
446}
447
448#------------------------------------------------------------------------
449# next() [% NEXT %]
450#
451# Next iteration of a FOREACH loop (experimental)
452#------------------------------------------------------------------------
453
454sub next {
455 my ($class, $label) = @_;
456 $label ||= 'LOOP';
457 return <<EOF;
458(\$_tt_value, \$_tt_error) = \$_tt_list->get_next();
459next $label;
460EOF
461}
462
463
464#------------------------------------------------------------------------
465# wrapper(\@nameargs, $block) [% WRAPPER template foo = bar %]
466# # => [ [$file,...], \@args ]
467#------------------------------------------------------------------------
468
469sub wrapper {
470 my ($class, $nameargs, $block) = @_;
471 my ($file, $args) = @$nameargs;
472 my $hash = shift @$args;
473
474 local $" = ', ';
475# print STDERR "wrapper([@$file], { @$hash })\n";
476
477 return $class->multi_wrapper($file, $hash, $block)
478 if @$file > 1;
479 $file = shift @$file;
480
481 $block = pad($block, 1) if $PRETTY;
482 push(@$hash, "'content'", '$output');
483 $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
484
485 return <<EOF;
486
487# WRAPPER
488$OUTPUT do {
489 my \$output = '';
490$block
491 \$context->include($file);
492};
493EOF
494}
495
496
497sub multi_wrapper {
498 my ($class, $file, $hash, $block) = @_;
499 $block = pad($block, 1) if $PRETTY;
500
501 push(@$hash, "'content'", '$output');
502 $hash = @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
503
504 $file = join(', ', reverse @$file);
505# print STDERR "multi wrapper: $file\n";
506
507 return <<EOF;
508
509# WRAPPER
510$OUTPUT do {
511 my \$output = '';
512$block
513 foreach ($file) {
514 \$output = \$context->include(\$_$hash);
515 }
516 \$output;
517};
518EOF
519}
520
521
522#------------------------------------------------------------------------
523# while($expr, $block) [% WHILE x < 10 %]
524# ...
525# [% END %]
526#------------------------------------------------------------------------
527
528sub while {
529 my ($class, $expr, $block, $label) = @_;
530 $block = pad($block, 2) if $PRETTY;
531 $label ||= 'LOOP';
532
533 return <<EOF;
534
535# WHILE
536do {
537 my \$_tt_failsafe = $WHILE_MAX;
538$label:
539 while (--\$_tt_failsafe && ($expr)) {
540$block
541 }
542 die "WHILE loop terminated (> $WHILE_MAX iterations)\\n"
543 unless \$_tt_failsafe;
544};
545EOF
546}
547
548
549#------------------------------------------------------------------------
550# switch($expr, \@case) [% SWITCH %]
551# [% CASE foo %]
552# ...
553# [% END %]
554#------------------------------------------------------------------------
555
556sub switch {
557 my ($class, $expr, $case) = @_;
558 my @case = @$case;
559 my ($match, $block, $default);
560 my $caseblock = '';
561
562 $default = pop @case;
563
564 foreach $case (@case) {
565 $match = $case->[0];
566 $block = $case->[1];
567 $block = pad($block, 1) if $PRETTY;
568 $caseblock .= <<EOF;
569\$_tt_match = $match;
570\$_tt_match = [ \$_tt_match ] unless ref \$_tt_match eq 'ARRAY';
571if (grep(/^\\Q\$_tt_result\\E\$/, \@\$_tt_match)) {
572$block
573 last SWITCH;
574}
575EOF
576 }
577
578 $caseblock .= $default
579 if defined $default;
580 $caseblock = pad($caseblock, 2) if $PRETTY;
581
582return <<EOF;
583
584# SWITCH
585do {
586 my \$_tt_result = $expr;
587 my \$_tt_match;
588 SWITCH: {
589$caseblock
590 }
591};
592EOF
593}
594
595
596#------------------------------------------------------------------------
597# try($block, \@catch) [% TRY %]
598# ...
599# [% CATCH %]
600# ...
601# [% END %]
602#------------------------------------------------------------------------
603
604sub try {
605 my ($class, $block, $catch) = @_;
606 my @catch = @$catch;
607 my ($match, $mblock, $default, $final, $n);
608 my $catchblock = '';
609 my $handlers = [];
610
611 $block = pad($block, 2) if $PRETTY;
612 $final = pop @catch;
613 $final = "# FINAL\n" . ($final ? "$final\n" : '')
614 . 'die $_tt_error if $_tt_error;' . "\n" . '$output;';
615 $final = pad($final, 1) if $PRETTY;
616
617 $n = 0;
618 foreach $catch (@catch) {
619 $match = $catch->[0] || do {
620 $default ||= $catch->[1];
621 next;
622 };
623 $mblock = $catch->[1];
624 $mblock = pad($mblock, 1) if $PRETTY;
625 push(@$handlers, "'$match'");
626 $catchblock .= $n++
627 ? "elsif (\$_tt_handler eq '$match') {\n$mblock\n}\n"
628 : "if (\$_tt_handler eq '$match') {\n$mblock\n}\n";
629 }
630 $catchblock .= "\$_tt_error = 0;";
631 $catchblock = pad($catchblock, 3) if $PRETTY;
632 if ($default) {
633 $default = pad($default, 1) if $PRETTY;
634 $default = "else {\n # DEFAULT\n$default\n \$_tt_error = '';\n}";
635 }
636 else {
637 $default = '# NO DEFAULT';
638 }
639 $default = pad($default, 2) if $PRETTY;
640
641 $handlers = join(', ', @$handlers);
642return <<EOF;
643
644# TRY
645$OUTPUT do {
646 my \$output = '';
647 my (\$_tt_error, \$_tt_handler);
648 eval {
649$block
650 };
651 if (\$@) {
652 \$_tt_error = \$context->catch(\$@, \\\$output);
653 die \$_tt_error if \$_tt_error->type =~ /^return|stop\$/;
654 \$stash->set('error', \$_tt_error);
655 \$stash->set('e', \$_tt_error);
656 if (defined (\$_tt_handler = \$_tt_error->select_handler($handlers))) {
657$catchblock
658 }
659$default
660 }
661$final
662};
663EOF
664}
665
666
667#------------------------------------------------------------------------
668# throw(\@nameargs) [% THROW foo "bar error" %]
669# # => [ [$type], \@args ]
670#------------------------------------------------------------------------
671
672sub throw {
673 my ($class, $nameargs) = @_;
674 my ($type, $args) = @$nameargs;
675 my $hash = shift(@$args);
676 my $info = shift(@$args);
677 $type = shift @$type; # uses same parser production as INCLUDE
678 # etc., which allow multiple names
679 # e.g. INCLUDE foo+bar+baz
680
681 if (! $info) {
682 $args = "$type, undef";
683 }
684 elsif (@$hash || @$args) {
685 local $" = ', ';
686 my $i = 0;
687 $args = "$type, { args => [ "
688 . join(', ', $info, @$args)
689 . ' ], '
690 . join(', ',
691 (map { "'" . $i++ . "' => $_" } ($info, @$args)),
692 @$hash)
693 . ' }';
694 }
695 else {
696 $args = "$type, $info";
697 }
698
699 return "\$context->throw($args, \\\$output);";
700}
701
702
703#------------------------------------------------------------------------
704# clear() [% CLEAR %]
705#
706# NOTE: this is redundant, being hard-coded (for now) into Parser.yp
707#------------------------------------------------------------------------
708
709sub clear {
710 return "\$output = '';";
711}
712
713#------------------------------------------------------------------------
714# break() [% BREAK %]
715#
716# NOTE: this is redundant, being hard-coded (for now) into Parser.yp
717#------------------------------------------------------------------------
718
719sub OLD_break {
720 return 'last LOOP;';
721}
722
723#------------------------------------------------------------------------
724# return() [% RETURN %]
725#------------------------------------------------------------------------
726
727sub return {
728 return "\$context->throw('return', '', \\\$output);";
729}
730
731#------------------------------------------------------------------------
732# stop() [% STOP %]
733#------------------------------------------------------------------------
734
735sub stop {
736 return "\$context->throw('stop', '', \\\$output);";
737}
738
739
740#------------------------------------------------------------------------
741# use(\@lnameargs) [% USE alias = plugin(args) %]
742# # => [ [$file, ...], \@args, $alias ]
743#------------------------------------------------------------------------
744
745sub use {
746 my ($class, $lnameargs) = @_;
747 my ($file, $args, $alias) = @$lnameargs;
748 $file = shift @$file; # same production rule as INCLUDE
749 $alias ||= $file;
750 $args = &args($class, $args);
751 $file .= ", $args" if $args;
752# my $set = &assign($class, $alias, '$plugin');
753 return "# USE\n"
754 . "\$stash->set($alias,\n"
755 . " \$context->plugin($file));";
756}
757
758#------------------------------------------------------------------------
759# view(\@nameargs, $block) [% VIEW name args %]
760# # => [ [$file, ... ], \@args ]
761#------------------------------------------------------------------------
762
763sub view {
764 my ($class, $nameargs, $block, $defblocks) = @_;
765 my ($name, $args) = @$nameargs;
766 my $hash = shift @$args;
767 $name = shift @$name; # same production rule as INCLUDE
768 $block = pad($block, 1) if $PRETTY;
769
770 if (%$defblocks) {
771 $defblocks = join(",\n", map { "'$_' => $defblocks->{ $_ }" }
772 keys %$defblocks);
773 $defblocks = pad($defblocks, 1) if $PRETTY;
774 $defblocks = "{\n$defblocks\n}";
775 push(@$hash, "'blocks'", $defblocks);
776 }
777 $hash = @$hash ? '{ ' . join(', ', @$hash) . ' }' : '';
778
779 return <<EOF;
780# VIEW
781do {
782 my \$output = '';
783 my \$_tt_oldv = \$stash->get('view');
784 my \$_tt_view = \$context->view($hash);
785 \$stash->set($name, \$_tt_view);
786 \$stash->set('view', \$_tt_view);
787
788$block
789
790 \$stash->set('view', \$_tt_oldv);
791 \$_tt_view->seal();
792# \$output; # not used - commented out to avoid warning
793};
794EOF
795}
796
797
798#------------------------------------------------------------------------
799# perl($block)
800#------------------------------------------------------------------------
801
802sub perl {
803 my ($class, $block) = @_;
804 $block = pad($block, 1) if $PRETTY;
805
806 return <<EOF;
807
808# PERL
809\$context->throw('perl', 'EVAL_PERL not set')
810 unless \$context->eval_perl();
811
812$OUTPUT do {
813 my \$output = "package Template::Perl;\\n";
814
815$block
816
817 local(\$Template::Perl::context) = \$context;
818 local(\$Template::Perl::stash) = \$stash;
819
820 my \$_tt_result = '';
821 tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$_tt_result;
822 my \$_tt_save_stdout = select *Template::Perl::PERLOUT;
823
824 eval \$output;
825 select \$_tt_save_stdout;
826 \$context->throw(\$@) if \$@;
827 \$_tt_result;
828};
829EOF
830}
831
832
833#------------------------------------------------------------------------
834# no_perl()
835#------------------------------------------------------------------------
836
837sub no_perl {
838 my $class = shift;
839 return "\$context->throw('perl', 'EVAL_PERL not set');";
840}
841
842
843#------------------------------------------------------------------------
844# rawperl($block)
845#
846# NOTE: perhaps test context EVAL_PERL switch at compile time rather than
847# runtime?
848#------------------------------------------------------------------------
849
850sub rawperl {
851 my ($class, $block, $line) = @_;
852 for ($block) {
853 s/^\n+//;
854 s/\n+$//;
855 }
856 $block = pad($block, 1) if $PRETTY;
857 $line = $line ? " (starting line $line)" : '';
858
859 return <<EOF;
860# RAWPERL
861#line 1 "RAWPERL block$line"
862$block
863EOF
864}
865
- -
868#------------------------------------------------------------------------
869# filter()
870#------------------------------------------------------------------------
871
872
# spent 2.06ms (1.60+460µs) within Template::Directive::filter which was called 74 times, avg 28µs/call: # 74 times (1.60ms+460µs) by Template::Grammar::__ANON__[Parser.yp:229] at line 229 of Parser.yp, avg 28µs/call
sub filter {
87374216µs my ($class, $lnameargs, $block) = @_;
8747488µs my ($name, $args, $alias) = @$lnameargs;
87574154µs $name = shift @$name;
87674272µs74460µs $args = &args($class, $args);
# spent 460µs making 74 calls to Template::Directive::args, avg 6µs/call
8777432µs $args = $args ? "$args, $alias" : ", undef, $alias"
878 if $alias;
8797426µs $name .= ", $args" if $args;
8807433µs $block = pad($block, 1) if $PRETTY;
881
88274637µs return <<EOF;
883
884# FILTER
885$OUTPUT do {
886 my \$output = '';
887 my \$_tt_filter = \$context->filter($name)
888 || \$context->throw(\$context->error);
889
890$block
891
892 &\$_tt_filter(\$output);
893};
894EOF
895}
896
897
898#------------------------------------------------------------------------
899# capture($name, $block)
900#------------------------------------------------------------------------
901
902sub capture {
903 my ($class, $name, $block) = @_;
904
905 if (ref $name) {
906 if (scalar @$name == 2 && ! $name->[1]) {
907 $name = $name->[0];
908 }
909 else {
910 $name = '[' . join(', ', @$name) . ']';
911 }
912 }
913 $block = pad($block, 1) if $PRETTY;
914
915 return <<EOF;
916
917# CAPTURE
918\$stash->set($name, do {
919 my \$output = '';
920$block
921 \$output;
922});
923EOF
924
925}
926
927
928#------------------------------------------------------------------------
929# macro($name, $block, \@args)
930#------------------------------------------------------------------------
931
932sub macro {
933 my ($class, $ident, $block, $args) = @_;
934 $block = pad($block, 2) if $PRETTY;
935
936 if ($args) {
937 my $nargs = scalar @$args;
938 $args = join(', ', map { "'$_'" } @$args);
939 $args = $nargs > 1
940 ? "\@_tt_args{ $args } = splice(\@_, 0, $nargs)"
941 : "\$_tt_args{ $args } = shift";
942
943 return <<EOF;
944
945# MACRO
946\$stash->set('$ident', sub {
947 my \$output = '';
948 my (%_tt_args, \$_tt_params);
949 $args;
950 \$_tt_params = shift;
951 \$_tt_params = { } unless ref(\$_tt_params) eq 'HASH';
952 \$_tt_params = { \%_tt_args, %\$_tt_params };
953
954 my \$stash = \$context->localise(\$_tt_params);
955 eval {
956$block
957 };
958 \$stash = \$context->delocalise();
959 die \$@ if \$@;
960 return \$output;
961});
962EOF
963
964 }
965 else {
966 return <<EOF;
967
968# MACRO
969\$stash->set('$ident', sub {
970 my \$_tt_params = \$_[0] if ref(\$_[0]) eq 'HASH';
971 my \$output = '';
972
973 my \$stash = \$context->localise(\$_tt_params);
974 eval {
975$block
976 };
977 \$stash = \$context->delocalise();
978 die \$@ if \$@;
979 return \$output;
980});
981EOF
982 }
983}
984
985
986sub debug {
987 my ($class, $nameargs) = @_;
988 my ($file, $args) = @$nameargs;
989 my $hash = shift @$args;
990 $args = join(', ', @$file, @$args);
991 $args .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
992 return "$OUTPUT \$context->debugging($args); ## DEBUG ##";
993}
994
995
99616µs1;
997
998__END__
 
# spent 698µs (167+530) within Template::Directive::CORE:match which was called 8 times, avg 87µs/call: # 8 times (167µs+530µs) by Template::Directive::template at line 70, avg 87µs/call
sub Template::Directive::CORE:match; # opcode
# spent 6.43ms within Template::Directive::CORE:subst which was called 1830 times, avg 4µs/call: # 915 times (3.38ms+0s) by Template::Directive::text at line 149, avg 4µs/call # 915 times (3.05ms+0s) by Template::Directive::text at line 150, avg 3µs/call
sub Template::Directive::CORE:subst; # opcode
# spent 4.81ms within Template::Directive::CORE:substcont which was called 2526 times, avg 2µs/call: # 2526 times (4.81ms+0s) by Template::Directive::text at line 149, avg 2µs/call
sub Template::Directive::CORE:substcont; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.