← 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 11:58:52 2013
Reported on Tue Oct 15 12:01:44 2013

Filename/usr/lib/perl5/Template/Directive.pm
StatementsExecuted 15989 statements in 68.4ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
9152218.5ms28.1msTemplate::Directive::::textTemplate::Directive::text
914116.61ms34.7msTemplate::Directive::::textblockTemplate::Directive::textblock
1830215.83ms5.83msTemplate::Directive::::CORE:substTemplate::Directive::CORE:subst (opcode)
670225.31ms5.31msTemplate::Directive::::identTemplate::Directive::ident
286314.48ms4.48msTemplate::Directive::::ifTemplate::Directive::if
417214.30ms4.30msTemplate::Directive::::blockTemplate::Directive::block
2526113.77ms3.77msTemplate::Directive::::CORE:substcontTemplate::Directive::CORE:substcont (opcode)
303211.72ms1.72msTemplate::Directive::::getTemplate::Directive::get
74111.18ms1.68msTemplate::Directive::::filterTemplate::Directive::filter
27111.13ms1.31msTemplate::Directive::::foreachTemplate::Directive::foreach
7822534µs534µsTemplate::Directive::::argsTemplate::Directive::args
811302µs383µsTemplate::Directive::::templateTemplate::Directive::template
811103µs148µsTemplate::Directive::::includeTemplate::Directive::include
11181µs81µsTemplate::Directive::::BEGIN@33Template::Directive::BEGIN@33
81180µs80µsTemplate::Directive::::CORE:matchTemplate::Directive::CORE:match (opcode)
31163µs92µsTemplate::Directive::::setTemplate::Directive::set
81145µs45µsTemplate::Directive::::filenamesTemplate::Directive::filenames
11132µs113µsTemplate::Directive::::BEGIN@29Template::Directive::BEGIN@29
11129µs151µsTemplate::Directive::::BEGIN@31Template::Directive::BEGIN@31
31128µs28µsTemplate::Directive::::assignTemplate::Directive::assign
11122µs82µsTemplate::Directive::::BEGIN@30Template::Directive::BEGIN@30
11119µs68µsTemplate::Directive::::BEGIN@32Template::Directive::BEGIN@32
11114µs14µ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
293116µs2194µs
# spent 113µs (32+81) within Template::Directive::BEGIN@29 which was called: # once (32µs+81µs) by Template::Parser::BEGIN@40 at line 29
use strict;
# spent 113µs making 1 call to Template::Directive::BEGIN@29 # spent 81µs making 1 call to strict::import
30368µs2141µs
# spent 82µs (22+60) within Template::Directive::BEGIN@30 which was called: # once (22µs+60µs) by Template::Parser::BEGIN@40 at line 30
use warnings;
# spent 82µs making 1 call to Template::Directive::BEGIN@30 # spent 60µs making 1 call to warnings::import
31355µs2273µs
# spent 151µs (29+122) within Template::Directive::BEGIN@31 which was called: # once (29µs+122µs) by Template::Parser::BEGIN@40 at line 31
use base 'Template::Base';
# spent 151µs making 1 call to Template::Directive::BEGIN@31 # spent 122µs making 1 call to base::import
32351µs2118µs
# spent 68µs (19+49) within Template::Directive::BEGIN@32 which was called: # once (19µs+49µs) by Template::Parser::BEGIN@40 at line 32
use Template::Constants;
# spent 68µs making 1 call to Template::Directive::BEGIN@32 # spent 49µs making 1 call to Exporter::import
3339.35ms181µs
# spent 81µs within Template::Directive::BEGIN@33 which was called: # once (81µs+0s) by Template::Parser::BEGIN@40 at line 33
use Template::Exception;
# spent 81µs making 1 call to Template::Directive::BEGIN@33
34
3512µsour $VERSION = 2.20;
3612µsour $DEBUG = 0 unless defined $DEBUG;
371500nsour $WHILE_MAX = 1000 unless defined $WHILE_MAX;
381500nsour $PRETTY = 0 unless defined $PRETTY;
3912µsour $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 383µs (302+81) within Template::Directive::template which was called 8 times, avg 48µs/call: # 8 times (302µs+81µs) by Template::Grammar::__ANON__[Parser.yp:64] at line 64 of Parser.yp, avg 48µs/call
sub template {
6732439µs my ($class, $block) = @_;
68 $block = pad($block, 2) if $PRETTY;
69
70880µs return "sub { return '' }" unless $block =~ /\S/;
# spent 80µs making 8 calls to Template::Directive::CORE:match, avg 10µs/call
71
72 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.30ms within Template::Directive::block which was called 417 times, avg 10µs/call: # 416 times (4.29ms+0s) by Template::Grammar::__ANON__[Parser.yp:67] at line 67 of Parser.yp, avg 10µs/call # once (5µs+0s) by Template::Grammar::__ANON__[Parser.yp:68] at line 68 of Parser.yp
sub block {
1278345.42ms my ($class, $block) = @_;
128 return join("\n", @{ $block || [] });
129}
130
131
132#------------------------------------------------------------------------
133# textblock($text)
134#------------------------------------------------------------------------
135
136
# spent 34.7ms (6.61+28.1) within Template::Directive::textblock which was called 914 times, avg 38µs/call: # 914 times (6.61ms+28.1ms) by Template::Grammar::__ANON__[Parser.yp:76] at line 76 of Parser.yp, avg 38µs/call
sub textblock {
13718286.23ms my ($class, $text) = @_;
13891428.1ms return "$OUTPUT " . &text($class, $text) . ';';
# spent 28.1ms making 914 calls to Template::Directive::text, avg 31µs/call
139}
140
141
142#------------------------------------------------------------------------
143# text($text)
144#------------------------------------------------------------------------
145
146
# spent 28.1ms (18.5+9.60) within Template::Directive::text which was called 915 times, avg 31µs/call: # 914 times (18.5ms+9.60ms) by Template::Directive::textblock at line 138, avg 31µs/call # once (12µs+6µs) by Template::Grammar::__ANON__[Parser.yp:440] at line 440 of Parser.yp
sub text {
14727455.88ms my ($class, $text) = @_;
148 for ($text) {
149183023.2ms34417.04ms s/(["\$\@\\])/\\$1/g;
# spent 3.77ms making 2526 calls to Template::Directive::CORE:substcont, avg 1µs/call # spent 3.27ms making 915 calls to Template::Directive::CORE:subst, avg 4µs/call
1509152.57ms s/\n/\\n/g;
# spent 2.57ms making 915 calls to Template::Directive::CORE:subst, avg 3µs/call
151 }
152 return '"' . $text . '"';
153}
154
155
156#------------------------------------------------------------------------
157# quoted(\@items) "foo$bar"
158#------------------------------------------------------------------------
159
160
# spent 14µs within Template::Directive::quoted which was called: # once (14µs+0s) by Template::Grammar::__ANON__[Parser.yp:307] at line 307 of Parser.yp
sub quoted {
161320µs my ($class, $items) = @_;
162 return '' unless @$items;
163 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 5.31ms within Template::Directive::ident which was called 670 times, avg 8µs/call: # 643 times (5.13ms+0s) by Template::Grammar::__ANON__[Parser.yp:305] at line 305 of Parser.yp, avg 8µs/call # 27 times (179µs+0s) by Template::Directive::foreach at line 404, avg 7µs/call
sub ident {
17640205.60ms my ($class, $ident) = @_;
177 return "''" unless @$ident;
178 my $ns;
179
180 # does the first element of the identifier have a NAMESPACE
181 # handler defined?
182 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
1902701.01ms if (scalar @$ident <= 2 && ! $ident->[1]) {
191 $ident = $ident->[0];
192 }
193 else {
194 $ident = '[' . join(', ', @$ident) . ']';
195 }
196 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 28µs within Template::Directive::assign which was called 3 times, avg 9µs/call: # 3 times (28µs+0s) by Template::Directive::set at line 294, avg 9µs/call
sub assign {
2211236µs my ($class, $var, $val, $default) = @_;
222
223 if (ref $var) {
224 if (scalar @$var == 2 && ! $var->[1]) {
225 $var = $var->[0];
226 }
227 else {
228 $var = '[' . join(', ', @$var) . ']';
229 }
230 }
231 $val .= ', 1' if $default;
232 return "\$stash->set($var, $val)";
233}
234
235
236#------------------------------------------------------------------------
237# args(\@args) foo, bar, baz = qux
238#------------------------------------------------------------------------
239
240
# spent 534µs within Template::Directive::args which was called 78 times, avg 7µs/call: # 74 times (502µs+0s) by Template::Directive::filter at line 876, avg 7µs/call # 4 times (32µs+0s) by Template::Grammar::__ANON__[Parser.yp:342] at line 342 of Parser.yp, avg 8µs/call
sub args {
241318702µs my ($class, $args) = @_;
242 my $hash = shift @$args;
243 push(@$args, '{ ' . join(', ', @$hash) . ' }')
244 if @$hash;
245
246 return '0' unless @$args;
247 return '[ ' . join(', ', @$args) . ' ]';
248}
249
250#------------------------------------------------------------------------
251# filenames(\@names)
252#------------------------------------------------------------------------
253
254
# spent 45µs within Template::Directive::filenames which was called 8 times, avg 6µs/call: # 8 times (45µs+0s) by Template::Directive::include at line 339, avg 6µs/call
sub filenames {
2552452µs my ($class, $names) = @_;
25686µs if (@$names > 1) {
257 $names = '[ ' . join(', ', @$names) . ' ]';
258 }
259 else {
260 $names = shift @$names;
261 }
262 return $names;
263}
264
265
266#------------------------------------------------------------------------
267# get($expr) [% foo %]
268#------------------------------------------------------------------------
269
270
# spent 1.72ms within Template::Directive::get which was called 303 times, avg 6µs/call: # 236 times (1.36ms+0s) by Template::Grammar::__ANON__[Parser.yp:90] at line 90 of Parser.yp, avg 6µs/call # 67 times (368µs+0s) by Template::Grammar::__ANON__[Parser.yp:109] at line 109 of Parser.yp, avg 5µs/call
sub get {
2716062.38ms my ($class, $expr) = @_;
272 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 92µs (63+28) within Template::Directive::set which was called 3 times, avg 31µs/call: # 3 times (63µs+28µs) by Template::Grammar::__ANON__[Parser.yp:115] at line 115 of Parser.yp, avg 31µs/call
sub set {
2921560µs my ($class, $setlist) = @_;
293 my $output;
294328µs while (my ($var, $val) = splice(@$setlist, 0, 2)) {
# spent 28µs making 3 calls to Template::Directive::assign, avg 9µs/call
295 $output .= &assign($class, $var, $val) . ";\n";
296 }
297 chomp $output;
298 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 148µs (103+45) within Template::Directive::include which was called 8 times, avg 18µs/call: # 8 times (103µs+45µs) by Template::Grammar::__ANON__[Parser.yp:118] at line 118 of Parser.yp, avg 18µs/call
sub include {
33648102µs my ($class, $nameargs) = @_;
337 my ($file, $args) = @$nameargs;
338 my $hash = shift @$args;
339845µs $file = $class->filenames($file);
# spent 45µs making 8 calls to Template::Directive::filenames, avg 6µs/call
340 $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
341 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.48ms within Template::Directive::if which was called 286 times, avg 16µs/call: # 273 times (4.32ms+0s) by Template::Grammar::__ANON__[Parser.yp:141] at line 141 of Parser.yp, avg 16µs/call # 12 times (158µs+0s) by Template::Grammar::__ANON__[Parser.yp:144] at line 144 of Parser.yp, avg 13µs/call # once (7µs+0s) by Template::Grammar::__ANON__[Parser.yp:145] at line 145 of Parser.yp
sub if {
36922884.99ms my ($class, $expr, $block, $else) = @_;
370 my @else = $else ? @$else : ();
371 $else = pop @else;
372 $block = pad($block, 1) if $PRETTY;
373
374 my $output = "if ($expr) {\n$block\n}\n";
375
376 foreach my $elsif (@else) {
3771248µs ($expr, $block) = @$elsif;
378 $block = pad($block, 1) if $PRETTY;
379 $output .= "elsif ($expr) {\n$block\n}\n";
380 }
381186243µs if (defined $else) {
382 $else = pad($else, 1) if $PRETTY;
383 $output .= "else {\n$else\n}\n";
384 }
385
386 return $output;
387}
388
389
390#------------------------------------------------------------------------
391# foreach($target, $list, $args, $block) [% FOREACH x = [ foo bar ] %]
392# ...
393# [% END %]
394#------------------------------------------------------------------------
395
396
# spent 1.31ms (1.13+179µs) within Template::Directive::foreach which was called 27 times, avg 48µs/call: # 27 times (1.13ms+179µs) by Template::Grammar::__ANON__[Parser.yp:168] at line 168 of Parser.yp, avg 48µs/call
sub foreach {
397216808µs my ($class, $target, $list, $args, $block, $label) = @_;
398 $args = shift @$args;
399 $args = @$args ? ', { ' . join(', ', @$args) . ' }' : '';
400 $label ||= 'LOOP';
401
402 my ($loop_save, $loop_set, $loop_restore, $setiter);
40381299µs if ($target) {
40427179µs $loop_save = 'eval { $_tt_oldloop = ' . &ident($class, ["'loop'"]) . ' }';
# spent 179µs making 27 calls to Template::Directive::ident, avg 7µs/call
405 $loop_set = "\$stash->{'$target'} = \$_tt_value";
406 $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 }
416 $block = pad($block, 3) if $PRETTY;
417
418 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 1.68ms (1.18+502µs) within Template::Directive::filter which was called 74 times, avg 23µs/call: # 74 times (1.18ms+502µs) by Template::Grammar::__ANON__[Parser.yp:229] at line 229 of Parser.yp, avg 23µs/call
sub filter {
8735921.24ms my ($class, $lnameargs, $block) = @_;
874 my ($name, $args, $alias) = @$lnameargs;
875 $name = shift @$name;
87674502µs $args = &args($class, $args);
# spent 502µs making 74 calls to Template::Directive::args, avg 7µs/call
877 $args = $args ? "$args, $alias" : ", undef, $alias"
878 if $alias;
879 $name .= ", $args" if $args;
880 $block = pad($block, 1) if $PRETTY;
881
882 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
996113µs1;
997
998__END__
 
# spent 80µs within Template::Directive::CORE:match which was called 8 times, avg 10µs/call: # 8 times (80µs+0s) by Template::Directive::template at line 70, avg 10µs/call
sub Template::Directive::CORE:match; # opcode
# spent 5.83ms within Template::Directive::CORE:subst which was called 1830 times, avg 3µs/call: # 915 times (3.27ms+0s) by Template::Directive::text at line 149, avg 4µs/call # 915 times (2.57ms+0s) by Template::Directive::text at line 150, avg 3µs/call
sub Template::Directive::CORE:subst; # opcode
# spent 3.77ms within Template::Directive::CORE:substcont which was called 2526 times, avg 1µs/call: # 2526 times (3.77ms+0s) by Template::Directive::text at line 149, avg 1µs/call
sub Template::Directive::CORE:substcont; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.