File Coverage

lib/Template/Document.pm
Criterion Covered Total %
statement 79 90 87.7
branch 17 28 60.7
condition 10 17 58.8
subroutine 13 15 86.6
pod 8 8 100.0
total 127 158 80.3


line stmt bran cond sub pod time 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
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              
22             package Template::Document;
23              
24 85     85   1597 use strict;
  85         663  
  85         5407  
25 85     85   451 use warnings;
  85         168  
  85         2370  
26 85     85   431 use base 'Template::Base';
  85         179  
  85         6694  
27 85     85   1284 use Template::Constants;
  85         158  
  85         16313  
28              
29             our $VERSION = 2.79;
30             our $DEBUG = 0 unless defined $DEBUG;
31             our $ERROR = '';
32             our ($COMPERR, $AUTOLOAD, $UNICODE);
33              
34             BEGIN {
35             # UNICODE is supported in versions of Perl from 5.008 onwards
36 85 50   85   1178 if ($UNICODE = $] > 5.007 ? 1 : 0) {
    50          
37 85 50       327 if ($] > 5.008) {
    0          
38             # utf8::is_utf8() available from Perl 5.8.1 onwards
39 85         138085 *is_utf8 = \&utf8::is_utf8;
40             }
41             elsif ($] == 5.008) {
42             # use Encode::is_utf8() for Perl 5.8.0
43 0         0 require Encode;
44 0         0 *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              
63             sub new {
64 1302     1302 1 2895 my ($class, $doc) = @_;
65 1302         4527 my ($block, $defblocks, $variables, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS VARIABLES METADATA ) };
66 1302   50     3315 $defblocks ||= { };
67 1302   50     2877 $metadata ||= { };
68              
69             # evaluate Perl code in $block to create sub-routine reference if necessary
70 1302 100       3422 unless (ref $block) {
71 1284         9513 local $SIG{__WARN__} = \&catch_warnings;
72 1284         2883 $COMPERR = '';
73              
74             # DON'T LOOK NOW! - blindly untainting can make you go blind!
75 1284         5514 $block =~ /(.*)/s;
76 1284         5519 $block = $1;
77            
78 1284         450440 $block = eval $block;
79 1284 50       22087 return $class->error($@)
80             unless defined $block;
81             }
82              
83             # same for any additional BLOCK definitions
84 137 100 50     25925 @$defblocks{ keys %$defblocks } =
85             # MORE BLIND UNTAINTING - turn away if you're squeamish
86             map {
87 1302         5045 ref($_)
88             ? $_
89             : ( /(.*)/s && eval($1) or return $class->error($@) )
90             } values %$defblocks;
91            
92 1302         23079 bless {
93             %$metadata,
94             _BLOCK => $block,
95             _DEFBLOCKS => $defblocks,
96             _VARIABLES => $variables,
97             _HOT => 0,
98             }, $class;
99             }
100              
101              
102             #------------------------------------------------------------------------
103             # block()
104             #
105             # Returns a reference to the internal sub-routine reference, _BLOCK,
106             # that constitutes the main document template.
107             #------------------------------------------------------------------------
108              
109             sub block {
110 2     2 1 10 return $_[0]->{ _BLOCK };
111             }
112              
113              
114             #------------------------------------------------------------------------
115             # blocks()
116             #
117             # Returns a reference to a hash array containing any BLOCK definitions
118             # from the template. The hash keys are the BLOCK name and the values
119             # are references to Template::Document objects. Returns 0 (# an empty hash)
120             # if no blocks are defined.
121             #------------------------------------------------------------------------
122              
123             sub blocks {
124 1295     1295 1 10395 return $_[0]->{ _DEFBLOCKS };
125             }
126              
127              
128             #-----------------------------------------------------------------------
129             # variables()
130             #
131             # Returns a reference to a hash of variables used in the template.
132             # This requires the TRACE_VARS option to be enabled.
133             #-----------------------------------------------------------------------
134              
135             sub variables {
136 0     0 1 0 return $_[0]->{ _VARIABLES };
137             }
138              
139             #------------------------------------------------------------------------
140             # process($context)
141             #
142             # Process the document in a particular context. Checks for recursion,
143             # registers the document with the context via visit(), processes itself,
144             # and then unwinds with a large gin and tonic.
145             #------------------------------------------------------------------------
146              
147             sub process {
148 1355     1355 1 2376 my ($self, $context) = @_;
149 1355         2518 my $defblocks = $self->{ _DEFBLOCKS };
150 1355         1707 my $output;
151              
152              
153             # check we're not already visiting this template
154             return $context->throw(Template::Constants::ERROR_FILE,
155             "recursion into '$self->{ name }'")
156 1355 100 100     5178 if $self->{ _HOT } && ! $context->{ RECURSION }; ## RETURN ##
157              
158 1354         18439 $context->visit($self, $defblocks);
159              
160 1354         2611 $self->{ _HOT } = 1;
161 1354         2155 eval {
162 1354         2397 my $block = $self->{ _BLOCK };
163 1354         48267 $output = &$block($context);
164             };
165 1354         49853 $self->{ _HOT } = 0;
166              
167 1354         5760 $context->leave();
168              
169 1354 100       4663 die $context->catch($@)
170             if $@;
171            
172 1336         4269 return $output;
173             }
174              
175              
176             #------------------------------------------------------------------------
177             # AUTOLOAD
178             #
179             # Provides pseudo-methods for read-only access to various internal
180             # members.
181             #------------------------------------------------------------------------
182              
183             sub AUTOLOAD {
184 36     36   18783 my $self = shift;
185 36         79 my $method = $AUTOLOAD;
186              
187 36         189 $method =~ s/.*:://;
188 36 50       115 return if $method eq 'DESTROY';
189             # my ($pkg, $file, $line) = caller();
190             # print STDERR "called $self->AUTOLOAD($method) from $file line $line\n";
191 36         245 return $self->{ $method };
192             }
193              
194              
195             #========================================================================
196             # ----- PRIVATE METHODS -----
197             #========================================================================
198              
199              
200             #------------------------------------------------------------------------
201             # _dump()
202             #
203             # Debug method which returns a string representing the internal state
204             # of the object.
205             #------------------------------------------------------------------------
206              
207             sub _dump {
208 0     0   0 my $self = shift;
209 0         0 my $dblks;
210 0         0 my $output = "$self : $self->{ name }\n";
211              
212 0         0 $output .= "BLOCK: $self->{ _BLOCK }\nDEFBLOCKS:\n";
213              
214 0 0       0 if ($dblks = $self->{ _DEFBLOCKS }) {
215 0         0 foreach my $b (keys %$dblks) {
216 0         0 $output .= " $b: $dblks->{ $b }\n";
217             }
218             }
219              
220 0         0 return $output;
221             }
222              
223              
224             #========================================================================
225             # ----- CLASS METHODS -----
226             #========================================================================
227              
228             #------------------------------------------------------------------------
229             # as_perl($content)
230             #
231             # This method expects a reference to a hash passed as the first argument
232             # containing 3 items:
233             # METADATA # a hash of template metadata
234             # BLOCK # string containing Perl sub definition for main block
235             # DEFBLOCKS # hash containing further subs for addional BLOCK defs
236             # It returns a string containing Perl code which, when evaluated and
237             # executed, will instantiate a new Template::Document object with the
238             # above data. On error, it returns undef with an appropriate error
239             # message set in $ERROR.
240             #------------------------------------------------------------------------
241              
242             sub as_perl {
243 14     14 1 35 my ($class, $content) = @_;
244 14         78 my ($block, $defblocks, $metadata) = @$content{ qw( BLOCK DEFBLOCKS METADATA ) };
245              
246 14         359 $block =~ s/\s+$//;
247              
248 6         16 $defblocks = join('', map {
249 14         55 my $code = $defblocks->{ $_ };
250 6         739 $code =~ s/\s*$//;
251 6         80 " '$_' => $code,\n";
252             } keys %$defblocks);
253 14         171 $defblocks =~ s/\s+$//;
254              
255 34         64 $metadata = join('', map {
256 14         57 my $x = $metadata->{ $_ };
257 34         63 $x =~ s/(['\\])/\\$1/g;
258 34         119 " '$_' => '$x',\n";
259             } keys %$metadata);
260 14         102 $metadata =~ s/\s+$//;
261              
262             return <
263             #------------------------------------------------------------------------
264             # Compiled template generated by the Template Toolkit version $Template::VERSION
265             #------------------------------------------------------------------------
266              
267             $class->new({
268             METADATA => {
269             $metadata
270             },
271             BLOCK => $block,
272             DEFBLOCKS => {
273             $defblocks
274             },
275             });
276             EOF
277 14         175 }
278              
279              
280             #------------------------------------------------------------------------
281             # write_perl_file($filename, \%content)
282             #
283             # This method calls as_perl() to generate the Perl code to represent a
284             # compiled template with the content passed as the second argument.
285             # It then writes this to the file denoted by the first argument.
286             #
287             # Returns 1 on success. On error, sets the $ERROR package variable
288             # to contain an error message and returns undef.
289             #------------------------------------------------------------------------
290              
291             sub write_perl_file {
292 14     14 1 32 my ($class, $file, $content) = @_;
293 14         25 my ($fh, $tmpfile);
294            
295 14 50       78 return $class->error("invalid filename: $file")
296             unless $file =~ /^(.+)$/s;
297              
298 14         23 eval {
299 14         4687 require File::Temp;
300 14         65220 require File::Basename;
301 14         598 ($fh, $tmpfile) = File::Temp::tempfile(
302             DIR => File::Basename::dirname($file)
303             );
304 14   50     6592 my $perlcode = $class->as_perl($content) || die $!;
305            
306 14 100 66     123 if ($UNICODE && is_utf8($perlcode)) {
307 5         15 $perlcode = "use utf8;\n\n$perlcode";
308 5         27 binmode $fh, ":utf8";
309             }
310 14         166 print $fh $perlcode;
311 14         861 close($fh);
312             };
313 14 50       47 return $class->error($@) if $@;
314 14   33     1232 return rename($tmpfile, $file)
315             || $class->error($!);
316             }
317              
318              
319             #------------------------------------------------------------------------
320             # catch_warnings($msg)
321             #
322             # Installed as
323             #------------------------------------------------------------------------
324              
325             sub catch_warnings {
326 1     1 1 216 $COMPERR .= join('', @_);
327             }
328              
329            
330             1;
331              
332             __END__