← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 14:31:06 2016
Reported on Fri Jan 8 14:31:39 2016

Filename/usr/lib/x86_64-linux-gnu/perl5/5.20/Template/Filters.pm
StatementsExecuted 25 statements in 3.29ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111290µs331µsTemplate::Filters::::BEGIN@24Template::Filters::BEGIN@24
11118µs27µsTemplate::Filters::::BEGIN@22Template::Filters::BEGIN@22
1119µs49µsTemplate::Filters::::BEGIN@25Template::Filters::BEGIN@25
1119µs14µsTemplate::Filters::::BEGIN@23Template::Filters::BEGIN@23
1119µs24µsTemplate::Filters::::BEGIN@26Template::Filters::BEGIN@26
1119µs29µsTemplate::Filters::::BEGIN@27Template::Filters::BEGIN@27
1117µs7µsTemplate::Filters::::_initTemplate::Filters::_init
0000s0sTemplate::Filters::::__ANON__[:450]Template::Filters::__ANON__[:450]
0000s0sTemplate::Filters::::__ANON__[:468]Template::Filters::__ANON__[:468]
0000s0sTemplate::Filters::::__ANON__[:486]Template::Filters::__ANON__[:486]
0000s0sTemplate::Filters::::__ANON__[:506]Template::Filters::__ANON__[:506]
0000s0sTemplate::Filters::::__ANON__[:524]Template::Filters::__ANON__[:524]
0000s0sTemplate::Filters::::__ANON__[:552]Template::Filters::__ANON__[:552]
0000s0sTemplate::Filters::::__ANON__[:55]Template::Filters::__ANON__[:55]
0000s0sTemplate::Filters::::__ANON__[:568]Template::Filters::__ANON__[:568]
0000s0sTemplate::Filters::::__ANON__[:56]Template::Filters::__ANON__[:56]
0000s0sTemplate::Filters::::__ANON__[:57]Template::Filters::__ANON__[:57]
0000s0sTemplate::Filters::::__ANON__[:58]Template::Filters::__ANON__[:58]
0000s0sTemplate::Filters::::__ANON__[:597]Template::Filters::__ANON__[:597]
0000s0sTemplate::Filters::::__ANON__[:59]Template::Filters::__ANON__[:59]
0000s0sTemplate::Filters::::__ANON__[:60]Template::Filters::__ANON__[:60]
0000s0sTemplate::Filters::::__ANON__[:61]Template::Filters::__ANON__[:61]
0000s0sTemplate::Filters::::__ANON__[:629]Template::Filters::__ANON__[:629]
0000s0sTemplate::Filters::::__ANON__[:63]Template::Filters::__ANON__[:63]
0000s0sTemplate::Filters::::__ANON__[:649]Template::Filters::__ANON__[:649]
0000s0sTemplate::Filters::::_dumpTemplate::Filters::_dump
0000s0sTemplate::Filters::::eval_filter_factoryTemplate::Filters::eval_filter_factory
0000s0sTemplate::Filters::::fetchTemplate::Filters::fetch
0000s0sTemplate::Filters::::format_filter_factoryTemplate::Filters::format_filter_factory
0000s0sTemplate::Filters::::html_entity_filter_factoryTemplate::Filters::html_entity_filter_factory
0000s0sTemplate::Filters::::html_filterTemplate::Filters::html_filter
0000s0sTemplate::Filters::::html_line_breakTemplate::Filters::html_line_break
0000s0sTemplate::Filters::::html_para_breakTemplate::Filters::html_para_break
0000s0sTemplate::Filters::::html_paragraphTemplate::Filters::html_paragraph
0000s0sTemplate::Filters::::indent_filter_factoryTemplate::Filters::indent_filter_factory
0000s0sTemplate::Filters::::perl_filter_factoryTemplate::Filters::perl_filter_factory
0000s0sTemplate::Filters::::redirect_filter_factoryTemplate::Filters::redirect_filter_factory
0000s0sTemplate::Filters::::remove_filter_factoryTemplate::Filters::remove_filter_factory
0000s0sTemplate::Filters::::repeat_filter_factoryTemplate::Filters::repeat_filter_factory
0000s0sTemplate::Filters::::replace_filter_factoryTemplate::Filters::replace_filter_factory
0000s0sTemplate::Filters::::stdout_filter_factoryTemplate::Filters::stdout_filter_factory
0000s0sTemplate::Filters::::storeTemplate::Filters::store
0000s0sTemplate::Filters::::truncate_filter_factoryTemplate::Filters::truncate_filter_factory
0000s0sTemplate::Filters::::uri_filterTemplate::Filters::uri_filter
0000s0sTemplate::Filters::::url_filterTemplate::Filters::url_filter
0000s0sTemplate::Filters::::use_apache_utilTemplate::Filters::use_apache_util
0000s0sTemplate::Filters::::use_html_entitiesTemplate::Filters::use_html_entities
0000s0sTemplate::Filters::::xml_filterTemplate::Filters::xml_filter
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::Filters
4#
5# DESCRIPTION
6# Defines filter plugins as used by the FILTER directive.
7#
8# AUTHORS
9# Andy Wardley <abw@wardley.org>, with a number of filters contributed
10# by Leslie Michael Orchard <deus_x@nijacode.com>
11#
12# COPYRIGHT
13# Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved.
14#
15# This module is free software; you can redistribute it and/or
16# modify it under the same terms as Perl itself.
17#
18#============================================================================
19
20package Template::Filters;
21
22242µs236µs
# spent 27µs (18+9) within Template::Filters::BEGIN@22 which was called: # once (18µs+9µs) by Template::Config::load at line 22
use strict;
# spent 27µs making 1 call to Template::Filters::BEGIN@22 # spent 9µs making 1 call to strict::import
23231µs219µs
# spent 14µs (9+5) within Template::Filters::BEGIN@23 which was called: # once (9µs+5µs) by Template::Config::load at line 23
use warnings;
# spent 14µs making 1 call to Template::Filters::BEGIN@23 # spent 5µs making 1 call to warnings::import
242175µs2334µs
# spent 331µs (290+40) within Template::Filters::BEGIN@24 which was called: # once (290µs+40µs) by Template::Config::load at line 24
use locale;
# spent 331µs making 1 call to Template::Filters::BEGIN@24 # spent 3µs making 1 call to locale::import
25270µs289µs
# spent 49µs (9+40) within Template::Filters::BEGIN@25 which was called: # once (9µs+40µs) by Template::Config::load at line 25
use base 'Template::Base';
# spent 49µs making 1 call to Template::Filters::BEGIN@25 # spent 40µs making 1 call to base::import
26243µs238µs
# spent 24µs (9+15) within Template::Filters::BEGIN@26 which was called: # once (9µs+15µs) by Template::Config::load at line 26
use Template::Constants;
# spent 24µs making 1 call to Template::Filters::BEGIN@26 # spent 15µs making 1 call to Exporter::import
2722.87ms249µs
# spent 29µs (9+20) within Template::Filters::BEGIN@27 which was called: # once (9µs+20µs) by Template::Config::load at line 27
use Scalar::Util 'blessed';
# spent 29µs making 1 call to Template::Filters::BEGIN@27 # spent 20µs making 1 call to Exporter::import
28
291400nsour $VERSION = 2.87;
301800nsour $AVAILABLE = { };
311200nsour $TRUNCATE_LENGTH = 32;
321200nsour $TRUNCATE_ADDON = '...';
33
34
35#------------------------------------------------------------------------
36# standard filters, defined in one of the following forms:
37# name => \&static_filter
38# name => [ \&subref, $is_dynamic ]
39# If the $is_dynamic flag is set then the sub-routine reference
40# is called to create a new filter each time it is requested; if
41# not set, then it is a single, static sub-routine which is returned
42# for every filter request for that name.
43#------------------------------------------------------------------------
44
45our $FILTERS = {
46 # static filters
47 'html' => \&html_filter,
48 'html_para' => \&html_paragraph,
49 'html_break' => \&html_para_break,
50 'html_para_break' => \&html_para_break,
51 'html_line_break' => \&html_line_break,
52 'xml' => \&xml_filter,
53 'uri' => \&uri_filter,
54 'url' => \&url_filter,
55 'upper' => sub { uc $_[0] },
56 'lower' => sub { lc $_[0] },
57 'ucfirst' => sub { ucfirst $_[0] },
58 'lcfirst' => sub { lcfirst $_[0] },
59 'stderr' => sub { print STDERR @_; return '' },
60 'trim' => sub { for ($_[0]) { s/^\s+//; s/\s+$// }; $_[0] },
61 'null' => sub { return '' },
62 'collapse' => sub { for ($_[0]) { s/^\s+//; s/\s+$//; s/\s+/ /g };
63 $_[0] },
64
65 # dynamic filters
66131µs 'html_entity' => [ \&html_entity_filter_factory, 1 ],
67 'indent' => [ \&indent_filter_factory, 1 ],
68 'format' => [ \&format_filter_factory, 1 ],
69 'truncate' => [ \&truncate_filter_factory, 1 ],
70 'repeat' => [ \&repeat_filter_factory, 1 ],
71 'replace' => [ \&replace_filter_factory, 1 ],
72 'remove' => [ \&remove_filter_factory, 1 ],
73 'eval' => [ \&eval_filter_factory, 1 ],
74 'evaltt' => [ \&eval_filter_factory, 1 ], # alias
75 'perl' => [ \&perl_filter_factory, 1 ],
76 'evalperl' => [ \&perl_filter_factory, 1 ], # alias
77 'redirect' => [ \&redirect_filter_factory, 1 ],
78 'file' => [ \&redirect_filter_factory, 1 ], # alias
79 'stdout' => [ \&stdout_filter_factory, 1 ],
80};
81
82# name of module implementing plugin filters
831200nsour $PLUGIN_FILTER = 'Template::Plugin::Filter';
84
- -
87#========================================================================
88# -- PUBLIC METHODS --
89#========================================================================
90
91#------------------------------------------------------------------------
92# fetch($name, \@args, $context)
93#
94# Attempts to instantiate or return a reference to a filter sub-routine
95# named by the first parameter, $name, with additional constructor
96# arguments passed by reference to a list as the second parameter,
97# $args. A reference to the calling Template::Context object is
98# passed as the third paramter.
99#
100# Returns a reference to a filter sub-routine or a pair of values
101# (undef, STATUS_DECLINED) or ($error, STATUS_ERROR) to decline to
102# deliver the filter or to indicate an error.
103#------------------------------------------------------------------------
104
105sub fetch {
106 my ($self, $name, $args, $context) = @_;
107 my ($factory, $is_dynamic, $filter, $error);
108
109 $self->debug("fetch($name, ",
110 defined $args ? ('[ ', join(', ', @$args), ' ]') : '<no args>', ', ',
111 defined $context ? $context : '<no context>',
112 ')') if $self->{ DEBUG };
113
114 # allow $name to be specified as a reference to
115 # a plugin filter object; any other ref is
116 # assumed to be a coderef and hence already a filter;
117 # non-refs are assumed to be regular name lookups
118
119 if (ref $name) {
120 if (blessed($name) && $name->isa($PLUGIN_FILTER)) {
121 $factory = $name->factory()
122 || return $self->error($name->error());
123 }
124 else {
125 return $name;
126 }
127 }
128 else {
129 return (undef, Template::Constants::STATUS_DECLINED)
130 unless ($factory = $self->{ FILTERS }->{ $name }
131 || $FILTERS->{ $name });
132 }
133
134 # factory can be an [ $code, $dynamic ] or just $code
135 if (ref $factory eq 'ARRAY') {
136 ($factory, $is_dynamic) = @$factory;
137 }
138 else {
139 $is_dynamic = 0;
140 }
141
142 if (ref $factory eq 'CODE') {
143 if ($is_dynamic) {
144 # if the dynamic flag is set then the sub-routine is a
145 # factory which should be called to create the actual
146 # filter...
147 eval {
148 ($filter, $error) = &$factory($context, $args ? @$args : ());
149 };
150 $error ||= $@;
151 $error = "invalid FILTER for '$name' (not a CODE ref)"
152 unless $error || ref($filter) eq 'CODE';
153 }
154 else {
155 # ...otherwise, it's a static filter sub-routine
156 $filter = $factory;
157 }
158 }
159 else {
160 $error = "invalid FILTER entry for '$name' (not a CODE ref)";
161 }
162
163 if ($error) {
164 return $self->{ TOLERANT }
165 ? (undef, Template::Constants::STATUS_DECLINED)
166 : ($error, Template::Constants::STATUS_ERROR) ;
167 }
168 else {
169 return $filter;
170 }
171}
172
173
174#------------------------------------------------------------------------
175# store($name, \&filter)
176#
177# Stores a new filter in the internal FILTERS hash. The first parameter
178# is the filter name, the second a reference to a subroutine or
179# array, as per the standard $FILTERS entries.
180#------------------------------------------------------------------------
181
182sub store {
183 my ($self, $name, $filter) = @_;
184
185 $self->debug("store($name, $filter)") if $self->{ DEBUG };
186
187 $self->{ FILTERS }->{ $name } = $filter;
188 return 1;
189}
190
191
192#========================================================================
193# -- PRIVATE METHODS --
194#========================================================================
195
196#------------------------------------------------------------------------
197# _init(\%config)
198#
199# Private initialisation method.
200#------------------------------------------------------------------------
201
202
# spent 7µs within Template::Filters::_init which was called: # once (7µs+0s) by Template::Base::new at line 65 of Template/Base.pm
sub _init {
2031700ns my ($self, $params) = @_;
204
20514µs $self->{ FILTERS } = $params->{ FILTERS } || { };
2061400ns $self->{ TOLERANT } = $params->{ TOLERANT } || 0;
2071700ns $self->{ DEBUG } = ( $params->{ DEBUG } || 0 )
208 & Template::Constants::DEBUG_FILTERS;
209
210
21113µs return $self;
212}
213
- -
216#------------------------------------------------------------------------
217# _dump()
218#
219# Debug method
220#------------------------------------------------------------------------
221
222sub _dump {
223 my $self = shift;
224 my $output = "[Template::Filters] {\n";
225 my $format = " %-16s => %s\n";
226 my $key;
227
228 foreach $key (qw( TOLERANT )) {
229 my $val = $self->{ $key };
230 $val = '<undef>' unless defined $val;
231 $output .= sprintf($format, $key, $val);
232 }
233
234 my $filters = $self->{ FILTERS };
235 $filters = join('', map {
236 sprintf(" $format", $_, $filters->{ $_ });
237 } keys %$filters);
238 $filters = "{\n$filters }";
239
240 $output .= sprintf($format, 'FILTERS (local)' => $filters);
241
242 $filters = $FILTERS;
243 $filters = join('', map {
244 my $f = $filters->{ $_ };
245 my ($ref, $dynamic) = ref $f eq 'ARRAY' ? @$f : ($f, 0);
246 sprintf(" $format", $_, $dynamic ? 'dynamic' : 'static');
247 } sort keys %$filters);
248 $filters = "{\n$filters }";
249
250 $output .= sprintf($format, 'FILTERS (global)' => $filters);
251
252 $output .= '}';
253 return $output;
254}
255
256
257#========================================================================
258# -- STATIC FILTER SUBS --
259#========================================================================
260
261#------------------------------------------------------------------------
262# uri_filter() [% FILTER uri %]
263#
264# URI escape a string. This code is borrowed from Gisle Aas' URI::Escape
265# module, copyright 1995-2004. See RFC2396 for details.
266#-----------------------------------------------------------------------
267
268# cache of escaped characters
26910sour $URI_ESCAPES;
270
271sub uri_filter {
272 my $text = shift;
273
274 $URI_ESCAPES ||= {
275 map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255),
276 };
277
278 if ($] >= 5.008 && utf8::is_utf8($text)) {
279 utf8::encode($text);
280 }
281
282 $text =~ s/([^A-Za-z0-9\-_.!~*'()])/$URI_ESCAPES->{$1}/eg;
283 $text;
284}
285
286#------------------------------------------------------------------------
287# url_filter() [% FILTER uri %]
288#
289# NOTE: the difference: url vs uri.
290# This implements the old-style, non-strict behaviour of the uri filter
291# which allows any valid URL characters to pass through so that
292# http://example.com/blah.html does not get the ':' and '/' characters
293# munged.
294#-----------------------------------------------------------------------
295
296sub url_filter {
297 my $text = shift;
298
299 $URI_ESCAPES ||= {
300 map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255),
301 };
302
303 if ($] >= 5.008 && utf8::is_utf8($text)) {
304 utf8::encode($text);
305 }
306
307 $text =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*'()])/$URI_ESCAPES->{$1}/eg;
308 $text;
309}
310
311
312#------------------------------------------------------------------------
313# html_filter() [% FILTER html %]
314#
315# Convert any '<', '>' or '&' characters to the HTML equivalents, '&lt;',
316# '&gt;' and '&amp;', respectively.
317#------------------------------------------------------------------------
318
319sub html_filter {
320 my $text = shift;
321 for ($text) {
322 s/&/&amp;/g;
323 s/</&lt;/g;
324 s/>/&gt;/g;
325 s/"/&quot;/g;
326 }
327 return $text;
328}
329
330
331#------------------------------------------------------------------------
332# xml_filter() [% FILTER xml %]
333#
334# Same as the html filter, but adds the conversion of ' to &apos; which
335# is native to XML.
336#------------------------------------------------------------------------
337
338sub xml_filter {
339 my $text = shift;
340 for ($text) {
341 s/&/&amp;/g;
342 s/</&lt;/g;
343 s/>/&gt;/g;
344 s/"/&quot;/g;
345 s/'/&apos;/g;
346 }
347 return $text;
348}
349
350
351#------------------------------------------------------------------------
352# html_paragraph() [% FILTER html_para %]
353#
354# Wrap each paragraph of text (delimited by two or more newlines) in the
355# <p>...</p> HTML tags.
356#------------------------------------------------------------------------
357
358sub html_paragraph {
359 my $text = shift;
360 return "<p>\n"
361 . join("\n</p>\n\n<p>\n", split(/(?:\r?\n){2,}/, $text))
362 . "</p>\n";
363}
364
365
366#------------------------------------------------------------------------
367# html_para_break() [% FILTER html_para_break %]
368#
369# Join each paragraph of text (delimited by two or more newlines) with
370# <br><br> HTML tags.
371#------------------------------------------------------------------------
372
373sub html_para_break {
374 my $text = shift;
375 $text =~ s|(\r?\n){2,}|$1<br />$1<br />$1|g;
376 return $text;
377}
378
379#------------------------------------------------------------------------
380# html_line_break() [% FILTER html_line_break %]
381#
382# replaces any newlines with <br> HTML tags.
383#------------------------------------------------------------------------
384
385sub html_line_break {
386 my $text = shift;
387 $text =~ s|(\r?\n)|<br />$1|g;
388 return $text;
389}
390
391#========================================================================
392# -- DYNAMIC FILTER FACTORIES --
393#========================================================================
394
395#------------------------------------------------------------------------
396# html_entity_filter_factory(\%options) [% FILTER html %]
397#
398# Dynamic version of the static html filter which attempts to locate the
399# Apache::Util or HTML::Entities modules to perform full entity encoding
400# of the text passed. Returns an exception if one or other of the
401# modules can't be located.
402#------------------------------------------------------------------------
403
404sub use_html_entities {
405 require HTML::Entities;
406 return ($AVAILABLE->{ HTML_ENTITY } = \&HTML::Entities::encode_entities);
407}
408
409sub use_apache_util {
410 require Apache::Util;
411 Apache::Util::escape_html(''); # TODO: explain this
412 return ($AVAILABLE->{ HTML_ENTITY } = \&Apache::Util::escape_html);
413}
414
415sub html_entity_filter_factory {
416 my $context = shift;
417 my $haz;
418
419 # if Apache::Util is installed then we use escape_html
420 $haz = $AVAILABLE->{ HTML_ENTITY }
421 || eval { use_apache_util() }
422 || eval { use_html_entities() }
423 || -1; # we use -1 for "not available" because it's a true value
424
425 return ref $haz eq 'CODE'
426 ? $haz
427 : (undef, Template::Exception->new(
428 html_entity => 'cannot locate Apache::Util or HTML::Entities' )
429 );
430}
431
432
433#------------------------------------------------------------------------
434# indent_filter_factory($pad) [% FILTER indent(pad) %]
435#
436# Create a filter to indent text by a fixed pad string or when $pad is
437# numerical, a number of space.
438#------------------------------------------------------------------------
439
440sub indent_filter_factory {
441 my ($context, $pad) = @_;
442 $pad = 4 unless defined $pad;
443 $pad = ' ' x $pad if $pad =~ /^\d+$/;
444
445 return sub {
446 my $text = shift;
447 $text = '' unless defined $text;
448 $text =~ s/^/$pad/mg;
449 return $text;
450 }
451}
452
453#------------------------------------------------------------------------
454# format_filter_factory() [% FILTER format(format) %]
455#
456# Create a filter to format text according to a printf()-like format
457# string.
458#------------------------------------------------------------------------
459
460sub format_filter_factory {
461 my ($context, $format) = @_;
462 $format = '%s' unless defined $format;
463
464 return sub {
465 my $text = shift;
466 $text = '' unless defined $text;
467 return join("\n", map{ sprintf($format, $_) } split(/\n/, $text));
468 }
469}
470
471
472#------------------------------------------------------------------------
473# repeat_filter_factory($n) [% FILTER repeat(n) %]
474#
475# Create a filter to repeat text n times.
476#------------------------------------------------------------------------
477
478sub repeat_filter_factory {
479 my ($context, $iter) = @_;
480 $iter = 1 unless defined $iter and length $iter;
481
482 return sub {
483 my $text = shift;
484 $text = '' unless defined $text;
485 return join('\n', $text) x $iter;
486 }
487}
488
489
490#------------------------------------------------------------------------
491# replace_filter_factory($s, $r) [% FILTER replace(search, replace) %]
492#
493# Create a filter to replace 'search' text with 'replace'
494#------------------------------------------------------------------------
495
496sub replace_filter_factory {
497 my ($context, $search, $replace) = @_;
498 $search = '' unless defined $search;
499 $replace = '' unless defined $replace;
500
501 return sub {
502 my $text = shift;
503 $text = '' unless defined $text;
504 $text =~ s/$search/$replace/g;
505 return $text;
506 }
507}
508
509
510#------------------------------------------------------------------------
511# remove_filter_factory($text) [% FILTER remove(text) %]
512#
513# Create a filter to remove 'search' string from the input text.
514#------------------------------------------------------------------------
515
516sub remove_filter_factory {
517 my ($context, $search) = @_;
518
519 return sub {
520 my $text = shift;
521 $text = '' unless defined $text;
522 $text =~ s/$search//g;
523 return $text;
524 }
525}
526
527
528#------------------------------------------------------------------------
529# truncate_filter_factory($n) [% FILTER truncate(n) %]
530#
531# Create a filter to truncate text after n characters.
532#------------------------------------------------------------------------
533
534sub truncate_filter_factory {
535 my ($context, $len, $char) = @_;
536 $len = $TRUNCATE_LENGTH unless defined $len;
537 $char = $TRUNCATE_ADDON unless defined $char;
538
539 # Length of char is the minimum length
540 my $lchar = length $char;
541 if ($len < $lchar) {
542 $char = substr($char, 0, $len);
543 $lchar = $len;
544 }
545
546 return sub {
547 my $text = shift;
548 return $text if length $text <= $len;
549 return substr($text, 0, $len - $lchar) . $char;
550
551
552 }
553}
554
555
556#------------------------------------------------------------------------
557# eval_filter_factory [% FILTER eval %]
558#
559# Create a filter to evaluate template text.
560#------------------------------------------------------------------------
561
562sub eval_filter_factory {
563 my $context = shift;
564
565 return sub {
566 my $text = shift;
567 $context->process(\$text);
568 }
569}
570
571
572#------------------------------------------------------------------------
573# perl_filter_factory [% FILTER perl %]
574#
575# Create a filter to process Perl text iff the context EVAL_PERL flag
576# is set.
577#------------------------------------------------------------------------
578
579sub perl_filter_factory {
580 my $context = shift;
581 my $stash = $context->stash;
582
583 return (undef, Template::Exception->new('perl', 'EVAL_PERL is not set'))
584 unless $context->eval_perl();
585
586 return sub {
587 my $text = shift;
588 local($Template::Perl::context) = $context;
589 local($Template::Perl::stash) = $stash;
590 my $out = eval <<EOF;
591package Template::Perl;
592\$stash = \$context->stash();
593$text
594EOF
595 $context->throw($@) if $@;
596 return $out;
597 }
598}
599
600
601#------------------------------------------------------------------------
602# redirect_filter_factory($context, $file) [% FILTER redirect(file) %]
603#
604# Create a filter to redirect the block text to a file.
605#------------------------------------------------------------------------
606
607sub redirect_filter_factory {
608 my ($context, $file, $options) = @_;
609 my $outpath = $context->config->{ OUTPUT_PATH };
610
611 return (undef, Template::Exception->new('redirect',
612 'OUTPUT_PATH is not set'))
613 unless $outpath;
614
615 $context->throw('redirect', "relative filenames are not supported: $file")
616 if $file =~ m{(^|/)\.\./};
617
618 $options = { binmode => $options } unless ref $options;
619
620 sub {
621 my $text = shift;
622 my $outpath = $context->config->{ OUTPUT_PATH }
623 || return '';
624 $outpath .= "/$file";
625 my $error = Template::_output($outpath, \$text, $options);
626 die Template::Exception->new('redirect', $error)
627 if $error;
628 return '';
629 }
630}
631
632
633#------------------------------------------------------------------------
634# stdout_filter_factory($context, $binmode) [% FILTER stdout(binmode) %]
635#
636# Create a filter to print a block to stdout, with an optional binmode.
637#------------------------------------------------------------------------
638
639sub stdout_filter_factory {
640 my ($context, $options) = @_;
641
642 $options = { binmode => $options } unless ref $options;
643
644 sub {
645 my $text = shift;
646 binmode(STDOUT) if $options->{ binmode };
647 print STDOUT $text;
648 return '';
649 }
650}
651
652
653111µs1;
654
655__END__
Report produced by the NYTProf 6.02 Perl profiler, developed by Tim Bunce and Adam Kaplan.