File Coverage

lib/Template/Document.pm
Criterion Covered Total %
statement 80 90 88.8
branch 18 28 64.2
condition 10 17 58.8
subroutine 14 15 93.3
pod 8 8 100.0
total 130 158 82.2


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 92     92   293 use strict;
  92         81  
  92         4052  
25 92     92   311 use warnings;
  92         81  
  92         1897  
26 92     92   255 use base 'Template::Base';
  92         713  
  92         4813  
27 92     92   805 use Template::Constants;
  92         108  
  92         11683  
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 92 50   92   572 if ($UNICODE = $] > 5.007 ? 1 : 0) {
    50          
37 92 50       188 if ($] > 5.008) {
    0          
38             # utf8::is_utf8() available from Perl 5.8.1 onwards
39 92         82336 *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 1321     1321 1 1799 my ($class, $doc) = @_;
65 1321         2205 my ($block, $defblocks, $variables, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS VARIABLES METADATA ) };
66 1321   50     2008 $defblocks ||= { };
67 1321   50     1754 $metadata ||= { };
68              
69             # evaluate Perl code in $block to create sub-routine reference if necessary
70 1321 100       1938 unless (ref $block) {
71 1305         4972 local $SIG{__WARN__} = \&catch_warnings;
72 1305         1351 $COMPERR = '';
73              
74             # DON'T LOOK NOW! - blindly untainting can make you go blind!
75 1305         3289 $block =~ /(.*)/s;
76 1305         3114 $block = $1;
77            
78 1305         228828 $block = eval $block;
79 1305 50       14773 return $class->error($@)
80             unless defined $block;
81             }
82              
83             # same for any additional BLOCK definitions
84             @$defblocks{ keys %$defblocks } =
85             # MORE BLIND UNTAINTING - turn away if you're squeamish
86             map {
87 1321 100 50     3535 ref($_)
  140         16701  
88             ? $_
89             : ( /(.*)/s && eval($1) or return $class->error($@) )
90             } values %$defblocks;
91            
92 1321         14749 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 4 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 1313     1313 1 4796 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 1     1 1 6 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 1373     1373 1 1246 my ($self, $context) = @_;
149 1373         1337 my $defblocks = $self->{ _DEFBLOCKS };
150 1373         989 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 1373 100 100     2486 if $self->{ _HOT } && ! $context->{ RECURSION }; ## RETURN ##
157              
158 1372         2859 $context->visit($self, $defblocks);
159              
160 1372         1371 $self->{ _HOT } = 1;
161 1372         1137 eval {
162 1372         1298 my $block = $self->{ _BLOCK };
163 1372         26394 $output = &$block($context);
164             };
165 1372         17885 $self->{ _HOT } = 0;
166              
167 1372         2617 $context->leave();
168              
169 1372 100       2232 die $context->catch($@)
170             if $@;
171            
172 1352         2029 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 1338     1338   1729 my $self = shift;
185 1338         1213 my $method = $AUTOLOAD;
186              
187 1338         4703 $method =~ s/.*:://;
188 1338 100       27630 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         148 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 17     17 1 65 my ($class, $content) = @_;
244 17         48 my ($block, $defblocks, $metadata) = @$content{ qw( BLOCK DEFBLOCKS METADATA ) };
245              
246 17         259 $block =~ s/\s+$//;
247              
248             $defblocks = join('', map {
249 17         51 my $code = $defblocks->{ $_ };
  6         11  
250 6         410 $code =~ s/\s*$//;
251 6         28 " '$_' => $code,\n";
252             } keys %$defblocks);
253 17         104 $defblocks =~ s/\s+$//;
254              
255             $metadata = join('', map {
256 17         43 my $x = $metadata->{ $_ };
  40         47  
257 40         52 $x =~ s/(['\\])/\\$1/g;
258 40         102 " '$_' => '$x',\n";
259             } keys %$metadata);
260 17         68 $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 17         122 }
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 17     17 1 26 my ($class, $file, $content) = @_;
293 17         14 my ($fh, $tmpfile);
294            
295 17 50       67 return $class->error("invalid filename: $file")
296             unless $file =~ /^(.+)$/s;
297              
298 17         24 eval {
299 17         2521 require File::Temp;
300 17         49779 require File::Basename;
301 17         459 ($fh, $tmpfile) = File::Temp::tempfile(
302             DIR => File::Basename::dirname($file)
303             );
304 17   50     4648 my $perlcode = $class->as_perl($content) || die $!;
305            
306 17 100 66     104 if ($UNICODE && is_utf8($perlcode)) {
307 5         10 $perlcode = "use utf8;\n\n$perlcode";
308 5         18 binmode $fh, ":utf8";
309             }
310 17         156 print $fh $perlcode;
311 17         619 close($fh);
312             };
313 17 50       43 return $class->error($@) if $@;
314 17   33     832 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 121 $COMPERR .= join('', @_);
327             }
328              
329            
330             1;
331              
332             __END__