← Index
NYTProf Performance Profile   « line view »
For rbm/rbm
  Run on Wed Feb 12 03:38:15 2020
Reported on Wed Feb 12 04:56:37 2020

Filename/usr/lib/x86_64-linux-gnu/perl5/5.28/Template/Filters.pm
StatementsExecuted 1915826 statements in 4.23s
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
383161112.71s2.71sTemplate::Filters::::_initTemplate::Filters::_init
111752µs787µsTemplate::Filters::::BEGIN@24Template::Filters::BEGIN@24
11169µs123µsTemplate::Filters::::BEGIN@25Template::Filters::BEGIN@25
11114µs16µsTemplate::Filters::::BEGIN@22Template::Filters::BEGIN@22
1119µs38µsTemplate::Filters::::BEGIN@27Template::Filters::BEGIN@27
1119µs27µsTemplate::Filters::::BEGIN@26Template::Filters::BEGIN@26
1116µs26µsTemplate::Filters::::BEGIN@23Template::Filters::BEGIN@23
0000s0sTemplate::Filters::::__ANON__[:478]Template::Filters::__ANON__[:478]
0000s0sTemplate::Filters::::__ANON__[:496]Template::Filters::__ANON__[:496]
0000s0sTemplate::Filters::::__ANON__[:514]Template::Filters::__ANON__[:514]
0000s0sTemplate::Filters::::__ANON__[:534]Template::Filters::__ANON__[:534]
0000s0sTemplate::Filters::::__ANON__[:552]Template::Filters::__ANON__[:552]
0000s0sTemplate::Filters::::__ANON__[:55]Template::Filters::__ANON__[:55]
0000s0sTemplate::Filters::::__ANON__[:56]Template::Filters::__ANON__[:56]
0000s0sTemplate::Filters::::__ANON__[:57]Template::Filters::__ANON__[:57]
0000s0sTemplate::Filters::::__ANON__[:580]Template::Filters::__ANON__[:580]
0000s0sTemplate::Filters::::__ANON__[:58]Template::Filters::__ANON__[:58]
0000s0sTemplate::Filters::::__ANON__[:596]Template::Filters::__ANON__[:596]
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__[:625]Template::Filters::__ANON__[:625]
0000s0sTemplate::Filters::::__ANON__[:63]Template::Filters::__ANON__[:63]
0000s0sTemplate::Filters::::__ANON__[:657]Template::Filters::__ANON__[:657]
0000s0sTemplate::Filters::::__ANON__[:677]Template::Filters::__ANON__[:677]
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_escapesTemplate::Filters::uri_escapes
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::::use_rfc2732Template::Filters::use_rfc2732
0000s0sTemplate::Filters::::use_rfc3986Template::Filters::use_rfc3986
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-2014 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µs218µs
# spent 16µs (14+2) within Template::Filters::BEGIN@22 which was called: # once (14µs+2µs) by Template::Config::load at line 22
use strict;
# spent 16µs making 1 call to Template::Filters::BEGIN@22 # spent 2µs making 1 call to strict::import
23219µs244µs
# spent 26µs (6+19) within Template::Filters::BEGIN@23 which was called: # once (6µs+19µs) by Template::Config::load at line 23
use warnings;
# spent 26µs making 1 call to Template::Filters::BEGIN@23 # spent 19µs making 1 call to warnings::import
242404µs2792µs
# spent 787µs (752+35) within Template::Filters::BEGIN@24 which was called: # once (752µs+35µs) by Template::Config::load at line 24
use locale;
# spent 787µs making 1 call to Template::Filters::BEGIN@24 # spent 5µs making 1 call to locale::import
25228µs2176µs
# spent 123µs (69+54) within Template::Filters::BEGIN@25 which was called: # once (69µs+54µs) by Template::Config::load at line 25
use base 'Template::Base';
# spent 123µs making 1 call to Template::Filters::BEGIN@25 # spent 54µs making 1 call to base::import
26227µs245µs
# spent 27µs (9+18) within Template::Filters::BEGIN@26 which was called: # once (9µs+18µs) by Template::Config::load at line 26
use Template::Constants;
# spent 27µs making 1 call to Template::Filters::BEGIN@26 # spent 18µs making 1 call to Exporter::import
2723.26ms266µs
# spent 38µs (9+28) within Template::Filters::BEGIN@27 which was called: # once (9µs+28µs) by Template::Config::load at line 27
use Scalar::Util 'blessed';
# spent 38µs making 1 call to Template::Filters::BEGIN@27 # spent 28µs making 1 call to Exporter::import
28
291400nsour $VERSION = 2.87;
301500nsour $AVAILABLE = { };
311100nsour $TRUNCATE_LENGTH = 32;
321300nsour $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
66124µ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 parameter.
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 2.71s within Template::Filters::_init which was called 383161 times, avg 7µs/call: # 383161 times (2.71s+0s) by Template::Base::new at line 65 of Template/Base.pm, avg 7µs/call
sub _init {
203383161222ms my ($self, $params) = @_;
204
205383161774ms $self->{ FILTERS } = $params->{ FILTERS } || { };
206383161562ms $self->{ TOLERANT } = $params->{ TOLERANT } || 0;
207383161467ms $self->{ DEBUG } = ( $params->{ DEBUG } || 0 )
208 & Template::Constants::DEBUG_FILTERS;
209
210
2113831612.20s 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() and url_filter() below can match using either RFC3986 or
263# RFC2732. See https://github.com/abw/Template2/issues/13
264#-----------------------------------------------------------------------
265
2661800nsour $UNSAFE_SPEC = {
267 RFC2732 => q{A-Za-z0-9\-_.!~*'()},
268 RFC3986 => q{A-Za-z0-9\-\._~},
269};
2701400nsour $UNSAFE_CHARS = $UNSAFE_SPEC->{ RFC2732 };
271our $URI_REGEX;
272our $URL_REGEX;
273our $URI_ESCAPES;
274
275sub use_rfc2732 {
276 $UNSAFE_CHARS = $UNSAFE_SPEC->{ RFC2732 };
277 $URI_REGEX = $URL_REGEX = undef;
278}
279
280sub use_rfc3986 {
281 $UNSAFE_CHARS = $UNSAFE_SPEC->{ RFC3986 };
282 $URI_REGEX = $URL_REGEX = undef;
283}
284
285sub uri_escapes {
286 return {
287 map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255),
288 };
289}
290
291#------------------------------------------------------------------------
292# uri_filter() [% FILTER uri %]
293#
294# URI escape a string. This code is borrowed from Gisle Aas' URI::Escape
295# module, copyright 1995-2004. See RFC2396, RFC2732 and RFC3986 for
296# details.
297#-----------------------------------------------------------------------
298
299sub uri_filter {
300 my $text = shift;
301
302 $URI_REGEX ||= qr/([^$UNSAFE_CHARS])/;
303 $URI_ESCAPES ||= uri_escapes();
304
305 if ($] >= 5.008 && utf8::is_utf8($text)) {
306 utf8::encode($text);
307 }
308
309 $text =~ s/$URI_REGEX/$URI_ESCAPES->{$1}/eg;
310 $text;
311}
312
- -
315#------------------------------------------------------------------------
316# url_filter() [% FILTER uri %]
317#
318# NOTE: the difference: url vs uri.
319# This implements the old-style, non-strict behaviour of the uri filter
320# which allows any valid URL characters to pass through so that
321# http://example.com/blah.html does not get the ':' and '/' characters
322# munged.
323#-----------------------------------------------------------------------
324
325sub url_filter {
326 my $text = shift;
327
328 $URL_REGEX ||= qr/([^;\/?:@&=+\$,$UNSAFE_CHARS])/;
329 $URI_ESCAPES ||= uri_escapes();
330
331 if ($] >= 5.008 && utf8::is_utf8($text)) {
332 utf8::encode($text);
333 }
334
335 $text =~ s/$URL_REGEX/$URI_ESCAPES->{$1}/eg;
336 $text;
337}
338
339
340#------------------------------------------------------------------------
341# html_filter() [% FILTER html %]
342#
343# Convert any '<', '>' or '&' characters to the HTML equivalents, '&lt;',
344# '&gt;' and '&amp;', respectively.
345#------------------------------------------------------------------------
346
347sub html_filter {
348 my $text = shift;
349 for ($text) {
350 s/&/&amp;/g;
351 s/</&lt;/g;
352 s/>/&gt;/g;
353 s/"/&quot;/g;
354 }
355 return $text;
356}
357
358
359#------------------------------------------------------------------------
360# xml_filter() [% FILTER xml %]
361#
362# Same as the html filter, but adds the conversion of ' to &apos; which
363# is native to XML.
364#------------------------------------------------------------------------
365
366sub xml_filter {
367 my $text = shift;
368 for ($text) {
369 s/&/&amp;/g;
370 s/</&lt;/g;
371 s/>/&gt;/g;
372 s/"/&quot;/g;
373 s/'/&apos;/g;
374 }
375 return $text;
376}
377
378
379#------------------------------------------------------------------------
380# html_paragraph() [% FILTER html_para %]
381#
382# Wrap each paragraph of text (delimited by two or more newlines) in the
383# <p>...</p> HTML tags.
384#------------------------------------------------------------------------
385
386sub html_paragraph {
387 my $text = shift;
388 return "<p>\n"
389 . join("\n</p>\n\n<p>\n", split(/(?:\r?\n){2,}/, $text))
390 . "</p>\n";
391}
392
393
394#------------------------------------------------------------------------
395# html_para_break() [% FILTER html_para_break %]
396#
397# Join each paragraph of text (delimited by two or more newlines) with
398# <br><br> HTML tags.
399#------------------------------------------------------------------------
400
401sub html_para_break {
402 my $text = shift;
403 $text =~ s|(\r?\n){2,}|$1<br />$1<br />$1|g;
404 return $text;
405}
406
407#------------------------------------------------------------------------
408# html_line_break() [% FILTER html_line_break %]
409#
410# replaces any newlines with <br> HTML tags.
411#------------------------------------------------------------------------
412
413sub html_line_break {
414 my $text = shift;
415 $text =~ s|(\r?\n)|<br />$1|g;
416 return $text;
417}
418
419#========================================================================
420# -- DYNAMIC FILTER FACTORIES --
421#========================================================================
422
423#------------------------------------------------------------------------
424# html_entity_filter_factory(\%options) [% FILTER html %]
425#
426# Dynamic version of the static html filter which attempts to locate the
427# Apache::Util or HTML::Entities modules to perform full entity encoding
428# of the text passed. Returns an exception if one or other of the
429# modules can't be located.
430#------------------------------------------------------------------------
431
432sub use_html_entities {
433 require HTML::Entities;
434 return ($AVAILABLE->{ HTML_ENTITY } = \&HTML::Entities::encode_entities);
435}
436
437sub use_apache_util {
438 require Apache::Util;
439 Apache::Util::escape_html(''); # TODO: explain this
440 return ($AVAILABLE->{ HTML_ENTITY } = \&Apache::Util::escape_html);
441}
442
443sub html_entity_filter_factory {
444 my $context = shift;
445 my $haz;
446
447 # if Apache::Util is installed then we use escape_html
448 $haz = $AVAILABLE->{ HTML_ENTITY }
449 || eval { use_apache_util() }
450 || eval { use_html_entities() }
451 || -1; # we use -1 for "not available" because it's a true value
452
453 return ref $haz eq 'CODE'
454 ? $haz
455 : (undef, Template::Exception->new(
456 html_entity => 'cannot locate Apache::Util or HTML::Entities' )
457 );
458}
459
460
461#------------------------------------------------------------------------
462# indent_filter_factory($pad) [% FILTER indent(pad) %]
463#
464# Create a filter to indent text by a fixed pad string or when $pad is
465# numerical, a number of space.
466#------------------------------------------------------------------------
467
468sub indent_filter_factory {
469 my ($context, $pad) = @_;
470 $pad = 4 unless defined $pad;
471 $pad = ' ' x $pad if $pad =~ /^\d+$/;
472
473 return sub {
474 my $text = shift;
475 $text = '' unless defined $text;
476 $text =~ s/^/$pad/mg;
477 return $text;
478 }
479}
480
481#------------------------------------------------------------------------
482# format_filter_factory() [% FILTER format(format) %]
483#
484# Create a filter to format text according to a printf()-like format
485# string.
486#------------------------------------------------------------------------
487
488sub format_filter_factory {
489 my ($context, $format) = @_;
490 $format = '%s' unless defined $format;
491
492 return sub {
493 my $text = shift;
494 $text = '' unless defined $text;
495 return join("\n", map{ sprintf($format, $_) } split(/\n/, $text));
496 }
497}
498
499
500#------------------------------------------------------------------------
501# repeat_filter_factory($n) [% FILTER repeat(n) %]
502#
503# Create a filter to repeat text n times.
504#------------------------------------------------------------------------
505
506sub repeat_filter_factory {
507 my ($context, $iter) = @_;
508 $iter = 1 unless defined $iter and length $iter;
509
510 return sub {
511 my $text = shift;
512 $text = '' unless defined $text;
513 return join('\n', $text) x $iter;
514 }
515}
516
517
518#------------------------------------------------------------------------
519# replace_filter_factory($s, $r) [% FILTER replace(search, replace) %]
520#
521# Create a filter to replace 'search' text with 'replace'
522#------------------------------------------------------------------------
523
524sub replace_filter_factory {
525 my ($context, $search, $replace) = @_;
526 $search = '' unless defined $search;
527 $replace = '' unless defined $replace;
528
529 return sub {
530 my $text = shift;
531 $text = '' unless defined $text;
532 $text =~ s/$search/$replace/g;
533 return $text;
534 }
535}
536
537
538#------------------------------------------------------------------------
539# remove_filter_factory($text) [% FILTER remove(text) %]
540#
541# Create a filter to remove 'search' string from the input text.
542#------------------------------------------------------------------------
543
544sub remove_filter_factory {
545 my ($context, $search) = @_;
546
547 return sub {
548 my $text = shift;
549 $text = '' unless defined $text;
550 $text =~ s/$search//g;
551 return $text;
552 }
553}
554
555
556#------------------------------------------------------------------------
557# truncate_filter_factory($n) [% FILTER truncate(n) %]
558#
559# Create a filter to truncate text after n characters.
560#------------------------------------------------------------------------
561
562sub truncate_filter_factory {
563 my ($context, $len, $char) = @_;
564 $len = $TRUNCATE_LENGTH unless defined $len;
565 $char = $TRUNCATE_ADDON unless defined $char;
566
567 # Length of char is the minimum length
568 my $lchar = length $char;
569 if ($len < $lchar) {
570 $char = substr($char, 0, $len);
571 $lchar = $len;
572 }
573
574 return sub {
575 my $text = shift;
576 return $text if length $text <= $len;
577 return substr($text, 0, $len - $lchar) . $char;
578
579
580 }
581}
582
583
584#------------------------------------------------------------------------
585# eval_filter_factory [% FILTER eval %]
586#
587# Create a filter to evaluate template text.
588#------------------------------------------------------------------------
589
590sub eval_filter_factory {
591 my $context = shift;
592
593 return sub {
594 my $text = shift;
595 $context->process(\$text);
596 }
597}
598
599
600#------------------------------------------------------------------------
601# perl_filter_factory [% FILTER perl %]
602#
603# Create a filter to process Perl text iff the context EVAL_PERL flag
604# is set.
605#------------------------------------------------------------------------
606
607sub perl_filter_factory {
608 my $context = shift;
609 my $stash = $context->stash;
610
611 return (undef, Template::Exception->new('perl', 'EVAL_PERL is not set'))
612 unless $context->eval_perl();
613
614 return sub {
615 my $text = shift;
616 local($Template::Perl::context) = $context;
617 local($Template::Perl::stash) = $stash;
618 my $out = eval <<EOF;
619package Template::Perl;
620\$stash = \$context->stash();
621$text
622EOF
623 $context->throw($@) if $@;
624 return $out;
625 }
626}
627
628
629#------------------------------------------------------------------------
630# redirect_filter_factory($context, $file) [% FILTER redirect(file) %]
631#
632# Create a filter to redirect the block text to a file.
633#------------------------------------------------------------------------
634
635sub redirect_filter_factory {
636 my ($context, $file, $options) = @_;
637 my $outpath = $context->config->{ OUTPUT_PATH };
638
639 return (undef, Template::Exception->new('redirect',
640 'OUTPUT_PATH is not set'))
641 unless $outpath;
642
643 $context->throw('redirect', "relative filenames are not supported: $file")
644 if $file =~ m{(^|/)\.\./};
645
646 $options = { binmode => $options } unless ref $options;
647
648 sub {
649 my $text = shift;
650 my $outpath = $context->config->{ OUTPUT_PATH }
651 || return '';
652 $outpath .= "/$file";
653 my $error = Template::_output($outpath, \$text, $options);
654 die Template::Exception->new('redirect', $error)
655 if $error;
656 return '';
657 }
658}
659
660
661#------------------------------------------------------------------------
662# stdout_filter_factory($context, $binmode) [% FILTER stdout(binmode) %]
663#
664# Create a filter to print a block to stdout, with an optional binmode.
665#------------------------------------------------------------------------
666
667sub stdout_filter_factory {
668 my ($context, $options) = @_;
669
670 $options = { binmode => $options } unless ref $options;
671
672 sub {
673 my $text = shift;
674 binmode(STDOUT) if $options->{ binmode };
675 print STDOUT $text;
676 return '';
677 }
678}
679
680
681118µs1;
682
683__END__
Report produced by the NYTProf 6.06 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.