← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:11 2021

Filename/usr/local/lib/perl5/site_perl/mach/5.32/Template/Document.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sTemplate::Document::::AUTOLOADTemplate::Document::AUTOLOAD
0000s0sTemplate::Document::::BEGIN@24Template::Document::BEGIN@24
0000s0sTemplate::Document::::BEGIN@25Template::Document::BEGIN@25
0000s0sTemplate::Document::::BEGIN@26Template::Document::BEGIN@26
0000s0sTemplate::Document::::BEGIN@27Template::Document::BEGIN@27
0000s0sTemplate::Document::::BEGIN@34Template::Document::BEGIN@34
0000s0sTemplate::Document::::_dumpTemplate::Document::_dump
0000s0sTemplate::Document::::as_perlTemplate::Document::as_perl
0000s0sTemplate::Document::::blockTemplate::Document::block
0000s0sTemplate::Document::::blocksTemplate::Document::blocks
0000s0sTemplate::Document::::catch_warningsTemplate::Document::catch_warnings
0000s0sTemplate::Document::::newTemplate::Document::new
0000s0sTemplate::Document::::processTemplate::Document::process
0000s0sTemplate::Document::::variablesTemplate::Document::variables
0000s0sTemplate::Document::::write_perl_fileTemplate::Document::write_perl_file
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::Document
4#
5# DESCRIPTION
6# Module defining a class of objects which encapsulate compiled
7# templates, storing additional block definitions and metadata
8# as well as the compiled Perl sub-routine representing the main
9# template content.
10#
11# AUTHOR
12# Andy Wardley <abw@wardley.org>
13#
14# COPYRIGHT
15# Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved.
16#
17# This module is free software; you can redistribute it and/or
18# modify it under the same terms as Perl itself.
19#
20#============================================================================
21
22package Template::Document;
23
24use strict;
25use warnings;
26use base 'Template::Base';
27use Template::Constants;
28
29our $VERSION = '3.009';
30our $DEBUG = 0 unless defined $DEBUG;
31our $ERROR = '';
32our ($COMPERR, $AUTOLOAD, $UNICODE);
33
34BEGIN {
35 # UNICODE is supported in versions of Perl from 5.008 onwards
36 if ($UNICODE = $] > 5.007 ? 1 : 0) {
37 if ($] > 5.008) {
38 # utf8::is_utf8() available from Perl 5.8.1 onwards
39 *is_utf8 = \&utf8::is_utf8;
40 }
41 elsif ($] == 5.008) {
42 # use Encode::is_utf8() for Perl 5.8.0
43 require Encode;
44 *is_utf8 = \&Encode::is_utf8;
45 }
46 }
47}
48
49
50#========================================================================
51# ----- PUBLIC METHODS -----
52#========================================================================
53
54#------------------------------------------------------------------------
55# new(\%document)
56#
57# Creates a new self-contained Template::Document object which
58# encapsulates a compiled Perl sub-routine, $block, any additional
59# BLOCKs defined within the document ($defblocks, also Perl sub-routines)
60# and additional $metadata about the document.
61#------------------------------------------------------------------------
62
63sub new {
64 my ($class, $doc) = @_;
65 my ($block, $defblocks, $variables, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS VARIABLES METADATA ) };
66 $defblocks ||= { };
67 $metadata ||= { };
68
69 # evaluate Perl code in $block to create sub-routine reference if necessary
70 unless (ref $block) {
71 local $SIG{__WARN__} = \&catch_warnings;
72 $COMPERR = '';
73
74 # DON'T LOOK NOW! - blindly untainting can make you go blind!
75 $block = each %{ { $block => undef } } if ${^TAINT}; #untaint
76
77 $block = eval $block;
78 return $class->error($@)
79 unless defined $block;
80 }
81
82 # same for any additional BLOCK definitions
83 @$defblocks{ keys %$defblocks } =
84 # MORE BLIND UNTAINTING - turn away if you're squeamish
85 map {
86 ref($_)
87 ? $_
88 : ( /(.*)/s && eval($1) or return $class->error($@) )
89 } values %$defblocks;
90
91 bless {
92 %$metadata,
93 _BLOCK => $block,
94 _DEFBLOCKS => $defblocks,
95 _VARIABLES => $variables,
96 _HOT => 0,
97 }, $class;
98}
99
100
101#------------------------------------------------------------------------
102# block()
103#
104# Returns a reference to the internal sub-routine reference, _BLOCK,
105# that constitutes the main document template.
106#------------------------------------------------------------------------
107
108sub block {
109 return $_[0]->{ _BLOCK };
110}
111
112
113#------------------------------------------------------------------------
114# blocks()
115#
116# Returns a reference to a hash array containing any BLOCK definitions
117# from the template. The hash keys are the BLOCK name and the values
118# are references to Template::Document objects. Returns 0 (# an empty hash)
119# if no blocks are defined.
120#------------------------------------------------------------------------
121
122sub blocks {
123 return $_[0]->{ _DEFBLOCKS };
124}
125
126
127#-----------------------------------------------------------------------
128# variables()
129#
130# Returns a reference to a hash of variables used in the template.
131# This requires the TRACE_VARS option to be enabled.
132#-----------------------------------------------------------------------
133
134sub variables {
135 return $_[0]->{ _VARIABLES };
136}
137
138#------------------------------------------------------------------------
139# process($context)
140#
141# Process the document in a particular context. Checks for recursion,
142# registers the document with the context via visit(), processes itself,
143# and then unwinds with a large gin and tonic.
144#------------------------------------------------------------------------
145
146sub process {
147 my ($self, $context) = @_;
148 my $defblocks = $self->{ _DEFBLOCKS };
149 my $output;
150
151
152 # check we're not already visiting this template
153 return $context->throw(Template::Constants::ERROR_FILE,
154 "recursion into '$self->{ name }'")
155 if $self->{ _HOT } && ! $context->{ RECURSION }; ## RETURN ##
156
157 $context->visit($self, $defblocks);
158
159 $self->{ _HOT } = 1;
160 eval {
161 my $block = $self->{ _BLOCK };
162 $output = &$block($context);
163 };
164 $self->{ _HOT } = 0;
165
166 $context->leave();
167
168 die $context->catch($@)
169 if $@;
170
171 return $output;
172}
173
174
175#------------------------------------------------------------------------
176# AUTOLOAD
177#
178# Provides pseudo-methods for read-only access to various internal
179# members.
180#------------------------------------------------------------------------
181
182sub AUTOLOAD {
183 my $self = shift;
184 my $method = $AUTOLOAD;
185
186 $method =~ s/.*:://;
187 return if $method eq 'DESTROY';
188# my ($pkg, $file, $line) = caller();
189# print STDERR "called $self->AUTOLOAD($method) from $file line $line\n";
190 return $self->{ $method };
191}
192
193
194#========================================================================
195# ----- PRIVATE METHODS -----
196#========================================================================
197
198
199#------------------------------------------------------------------------
200# _dump()
201#
202# Debug method which returns a string representing the internal state
203# of the object.
204#------------------------------------------------------------------------
205
206sub _dump {
207 my $self = shift;
208 my $dblks;
209 my $output = "$self : $self->{ name }\n";
210
211 $output .= "BLOCK: $self->{ _BLOCK }\nDEFBLOCKS:\n";
212
213 if ($dblks = $self->{ _DEFBLOCKS }) {
214 foreach my $b (keys %$dblks) {
215 $output .= " $b: $dblks->{ $b }\n";
216 }
217 }
218
219 return $output;
220}
221
222
223#========================================================================
224# ----- CLASS METHODS -----
225#========================================================================
226
227#------------------------------------------------------------------------
228# as_perl($content)
229#
230# This method expects a reference to a hash passed as the first argument
231# containing 3 items:
232# METADATA # a hash of template metadata
233# BLOCK # string containing Perl sub definition for main block
234# DEFBLOCKS # hash containing further subs for addional BLOCK defs
235# It returns a string containing Perl code which, when evaluated and
236# executed, will instantiate a new Template::Document object with the
237# above data. On error, it returns undef with an appropriate error
238# message set in $ERROR.
239#------------------------------------------------------------------------
240
241sub as_perl {
242 my ($class, $content) = @_;
243 my ($block, $defblocks, $metadata) = @$content{ qw( BLOCK DEFBLOCKS METADATA ) };
244
245 $block =~ s/\s+$//;
246
247 $defblocks = join('', map {
248 my $code = $defblocks->{ $_ };
249 $code =~ s/\s*$//;
250 " '$_' => $code,\n";
251 } keys %$defblocks);
252 $defblocks =~ s/\s+$//;
253
254 $metadata = join('', map {
255 my $x = $metadata->{ $_ };
256 $x =~ s/(['\\])/\\$1/g;
257 " '$_' => '$x',\n";
258 } keys %$metadata);
259 $metadata =~ s/\s+$//;
260
261 return <<EOF
262#------------------------------------------------------------------------
263# Compiled template generated by the Template Toolkit version $Template::VERSION
264#------------------------------------------------------------------------
265
266$class->new({
267 METADATA => {
268$metadata
269 },
270 BLOCK => $block,
271 DEFBLOCKS => {
272$defblocks
273 },
274});
275EOF
276}
277
278
279#------------------------------------------------------------------------
280# write_perl_file($filename, \%content)
281#
282# This method calls as_perl() to generate the Perl code to represent a
283# compiled template with the content passed as the second argument.
284# It then writes this to the file denoted by the first argument.
285#
286# Returns 1 on success. On error, sets the $ERROR package variable
287# to contain an error message and returns undef.
288#------------------------------------------------------------------------
289
290sub write_perl_file {
291 my ($class, $file, $content) = @_;
292 my ($fh, $tmpfile);
293
294 return $class->error("invalid filename: $file")
295 unless defined $file && length $file;
296
297 eval {
298 require File::Temp;
299 require File::Basename;
300 ($fh, $tmpfile) = File::Temp::tempfile(
301 DIR => File::Basename::dirname($file)
302 );
303 my $perlcode = $class->as_perl($content) || die $!;
304
305 if ($UNICODE && is_utf8($perlcode)) {
306 $perlcode = "use utf8;\n\n$perlcode";
307 binmode $fh, ":utf8";
308 }
309 print $fh $perlcode;
310 close($fh);
311 };
312 return $class->error($@) if $@;
313 return rename($tmpfile, $file)
314 || $class->error($!);
315}
316
317
318#------------------------------------------------------------------------
319# catch_warnings($msg)
320#
321# Installed as
322#------------------------------------------------------------------------
323
324sub catch_warnings {
325 $COMPERR .= join('', @_);
326}
327
328
3291;
330
331__END__