File Coverage

blib/lib/Text/Template.pm
Criterion Covered Total %
statement 305 316 96.5
branch 124 140 88.5
condition 24 25 96.0
subroutine 37 39 94.8
pod 7 13 53.8
total 497 533 93.2


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             # Text::Template.pm
3             #
4             # Fill in `templates'
5             #
6             # Copyright 2013 M. J. Dominus.
7             # You may copy and distribute this program under the
8             # same terms as Perl itself.
9             # If in doubt, write to mjd-perl-template+@plover.com for a license.
10             #
11              
12             package Text::Template;
13             $Text::Template::VERSION = '1.60';
14             # ABSTRACT: Expand template text with embedded Perl
15              
16 20     20   241187 use strict;
  20         69  
  20         644  
17 20     20   111 use warnings;
  20         34  
  20         730  
18              
19             require 5.008;
20              
21 20     20   111 use base 'Exporter';
  20         40  
  20         7975  
22              
23             our @EXPORT_OK = qw(fill_in_file fill_in_string TTerror);
24             our $ERROR;
25              
26             my %GLOBAL_PREPEND = ('Text::Template' => '');
27              
28             sub Version {
29 0     0 1 0 $Text::Template::VERSION;
30             }
31              
32             sub _param {
33 1958     1958   3756 my ($k, %h) = @_;
34              
35 1958         4657 for my $kk ($k, "\u$k", "\U$k", "-$k", "-\u$k", "-\U$k") {
36 10595 100       21372 return $h{$kk} if exists $h{$kk};
37             }
38              
39 1611         3913 return undef;
40             }
41              
42             sub always_prepend {
43 3     3 0 2912 my $pack = shift;
44              
45 3         6 my $old = $GLOBAL_PREPEND{$pack};
46              
47 3         6 $GLOBAL_PREPEND{$pack} = shift;
48              
49 3         7 $old;
50             }
51              
52             {
53             my %LEGAL_TYPE;
54              
55             BEGIN {
56 20     20   92 %LEGAL_TYPE = map { $_ => 1 } qw(FILE FILEHANDLE STRING ARRAY);
  80         34312  
57             }
58              
59             sub new {
60 112     112 1 58133 my ($pack, %a) = @_;
61              
62 112   100     391 my $stype = uc(_param('type', %a) || "FILE");
63 112         304 my $source = _param('source', %a);
64 112         268 my $untaint = _param('untaint', %a);
65 112         263 my $prepend = _param('prepend', %a);
66 112         260 my $alt_delim = _param('delimiters', %a);
67 112         249 my $broken = _param('broken', %a);
68 112         255 my $encoding = _param('encoding', %a);
69              
70 112 100       276 unless (defined $source) {
71 2         11 require Carp;
72 2         304 Carp::croak("Usage: $ {pack}::new(TYPE => ..., SOURCE => ...)");
73             }
74              
75 110 100       273 unless ($LEGAL_TYPE{$stype}) {
76 1         6 require Carp;
77 1         108 Carp::croak("Illegal value `$stype' for TYPE parameter");
78             }
79              
80 109 100       512 my $self = {
81             TYPE => $stype,
82             PREPEND => $prepend,
83             UNTAINT => $untaint,
84             BROKEN => $broken,
85             ENCODING => $encoding,
86             (defined $alt_delim ? (DELIM => $alt_delim) : ())
87             };
88              
89             # Under 5.005_03, if any of $stype, $prepend, $untaint, or $broken
90             # are tainted, all the others become tainted too as a result of
91             # sharing the expression with them. We install $source separately
92             # to prevent it from acquiring a spurious taint.
93 109         207 $self->{SOURCE} = $source;
94              
95 109         206 bless $self => $pack;
96 109 100       237 return unless $self->_acquire_data;
97              
98 108         548 $self;
99             }
100             }
101              
102             # Convert template objects of various types to type STRING,
103             # in which the template data is embedded in the object itself.
104             sub _acquire_data {
105 216     216   325 my $self = shift;
106              
107 216         412 my $type = $self->{TYPE};
108              
109 216 100       476 if ($type eq 'STRING') {
    100          
    100          
    50          
110             # nothing necessary
111             }
112             elsif ($type eq 'FILE') {
113 10         29 my $data = _load_text($self->{SOURCE});
114 10 100       47 unless (defined $data) {
115              
116             # _load_text already set $ERROR
117 1         16 return undef;
118             }
119              
120 9 100 100     41 if ($self->{UNTAINT} && _is_clean($self->{SOURCE})) {
121 1         3 _unconditionally_untaint($data);
122             }
123              
124 9 100       26 if (defined $self->{ENCODING}) {
125 2         13 require Encode;
126 2         12 $data = Encode::decode($self->{ENCODING}, $data, &Encode::FB_CROAK);
127             }
128              
129 9         125 $self->{TYPE} = 'STRING';
130 9         19 $self->{FILENAME} = $self->{SOURCE};
131 9         25 $self->{SOURCE} = $data;
132             }
133             elsif ($type eq 'ARRAY') {
134 5         8 $self->{TYPE} = 'STRING';
135 5         13 $self->{SOURCE} = join '', @{ $self->{SOURCE} };
  5         19  
136             }
137             elsif ($type eq 'FILEHANDLE') {
138 8         16 $self->{TYPE} = 'STRING';
139 8         30 local $/;
140 8         12 my $fh = $self->{SOURCE};
141 8         238 my $data = <$fh>; # Extra assignment avoids bug in Solaris perl5.00[45].
142 8 100       37 if ($self->{UNTAINT}) {
143 1         3 _unconditionally_untaint($data);
144             }
145 8         38 $self->{SOURCE} = $data;
146             }
147             else {
148             # This should have been caught long ago, so it represents a
149             # drastic `can't-happen' sort of failure
150 0         0 my $pack = ref $self;
151 0         0 die "Can only acquire data for $pack objects of subtype STRING, but this is $type; aborting";
152             }
153              
154 215         591 $self->{DATA_ACQUIRED} = 1;
155             }
156              
157             sub source {
158 7     7 0 12 my $self = shift;
159              
160 7 50       18 $self->_acquire_data unless $self->{DATA_ACQUIRED};
161              
162 7         20 return $self->{SOURCE};
163             }
164              
165             sub set_source_data {
166 7     7 0 16 my ($self, $newdata, $type) = @_;
167              
168 7         13 $self->{SOURCE} = $newdata;
169 7         10 $self->{DATA_ACQUIRED} = 1;
170 7   50     18 $self->{TYPE} = $type || 'STRING';
171              
172 7         17 1;
173             }
174              
175             sub compile {
176 107     107 1 194 my $self = shift;
177              
178 107 50       283 return 1 if $self->{TYPE} eq 'PREPARSED';
179              
180 107 50       201 return undef unless $self->_acquire_data;
181              
182 107 50       263 unless ($self->{TYPE} eq 'STRING') {
183 0         0 my $pack = ref $self;
184              
185             # This should have been caught long ago, so it represents a
186             # drastic `can't-happen' sort of failure
187 0         0 die "Can only compile $pack objects of subtype STRING, but this is $self->{TYPE}; aborting";
188             }
189              
190 107         150 my @tokens;
191 107   100     428 my $delim_pats = shift() || $self->{DELIM};
192              
193 107         218 my ($t_open, $t_close) = ('{', '}');
194 107         156 my $DELIM; # Regex matches a delimiter if $delim_pats
195              
196 107 100       238 if (defined $delim_pats) {
197 21         42 ($t_open, $t_close) = @$delim_pats;
198 21         105 $DELIM = "(?:(?:\Q$t_open\E)|(?:\Q$t_close\E))";
199 21         402 @tokens = split /($DELIM|\n)/, $self->{SOURCE};
200             }
201             else {
202 86         961 @tokens = split /(\\\\(?=\\*[{}])|\\[{}]|[{}\n])/, $self->{SOURCE};
203             }
204              
205 107         203 my $state = 'TEXT';
206 107         157 my $depth = 0;
207 107         146 my $lineno = 1;
208 107         158 my @content;
209 107         175 my $cur_item = '';
210 107         151 my $prog_start;
211              
212 107         247 while (@tokens) {
213 659         992 my $t = shift @tokens;
214              
215 659 100       1238 next if $t eq '';
216              
217 571 100 100     2333 if ($t eq $t_open) { # Brace or other opening delimiter
    100 100        
    100          
    100          
    100          
218 127 100       256 if ($depth == 0) {
219 118 100       345 push @content, [ $state, $cur_item, $lineno ] if $cur_item ne '';
220 118         216 $cur_item = '';
221 118         173 $state = 'PROG';
222 118         187 $prog_start = $lineno;
223             }
224             else {
225 9         17 $cur_item .= $t;
226             }
227 127         256 $depth++;
228             }
229             elsif ($t eq $t_close) { # Brace or other closing delimiter
230 137         178 $depth--;
231 137 100       367 if ($depth < 0) {
    100          
232 10         24 $ERROR = "Unmatched close brace at line $lineno";
233 10         50 return undef;
234             }
235             elsif ($depth == 0) {
236 118 50       363 push @content, [ $state, $cur_item, $prog_start ] if $cur_item ne '';
237 118         198 $state = 'TEXT';
238 118         250 $cur_item = '';
239             }
240             else {
241 9         26 $cur_item .= $t;
242             }
243             }
244             elsif (!$delim_pats && $t eq '\\\\') { # precedes \\\..\\\{ or \\\..\\\}
245 6         13 $cur_item .= '\\';
246             }
247             elsif (!$delim_pats && $t =~ /^\\([{}])$/) { # Escaped (literal) brace?
248 6         17 $cur_item .= $1;
249             }
250             elsif ($t eq "\n") { # Newline
251 44         56 $lineno++;
252 44         94 $cur_item .= $t;
253             }
254             else { # Anything else
255 251         620 $cur_item .= $t;
256             }
257             }
258              
259 97 50       267 if ($state eq 'PROG') {
    50          
260 0         0 $ERROR = "End of data inside program text that began at line $prog_start";
261 0         0 return undef;
262             }
263             elsif ($state eq 'TEXT') {
264 97 100       298 push @content, [ $state, $cur_item, $lineno ] if $cur_item ne '';
265             }
266             else {
267 0         0 die "Can't happen error #1";
268             }
269              
270 97         188 $self->{TYPE} = 'PREPARSED';
271 97         195 $self->{SOURCE} = \@content;
272              
273 97         339 1;
274             }
275              
276             sub prepend_text {
277 116     116 0 180 my $self = shift;
278              
279 116         190 my $t = $self->{PREPEND};
280              
281 116 100       242 unless (defined $t) {
282 112         248 $t = $GLOBAL_PREPEND{ ref $self };
283 112 100       252 unless (defined $t) {
284 10         20 $t = $GLOBAL_PREPEND{'Text::Template'};
285             }
286             }
287              
288 116 50       294 $self->{PREPEND} = $_[1] if $#_ >= 1;
289              
290 116         249 return $t;
291             }
292              
293             sub fill_in {
294 130     130 1 21187 my ($fi_self, %fi_a) = @_;
295              
296 130 100       398 unless ($fi_self->{TYPE} eq 'PREPARSED') {
297 90         247 my $delims = _param('delimiters', %fi_a);
298 90 100       229 my @delim_arg = (defined $delims ? ($delims) : ());
299 90 100       229 $fi_self->compile(@delim_arg)
300             or return undef;
301             }
302              
303 120         423 my $fi_varhash = _param('hash', %fi_a);
304 120         296 my $fi_package = _param('package', %fi_a);
305 120   100     267 my $fi_broken = _param('broken', %fi_a) || $fi_self->{BROKEN} || \&_default_broken;
306 120   100     290 my $fi_broken_arg = _param('broken_arg', %fi_a) || [];
307 120         258 my $fi_safe = _param('safe', %fi_a);
308 120         252 my $fi_ofh = _param('output', %fi_a);
309 120   100     307 my $fi_filename = _param('filename', %fi_a) || $fi_self->{FILENAME} || 'template';
310 120         272 my $fi_strict = _param('strict', %fi_a);
311 120         289 my $fi_prepend = _param('prepend', %fi_a);
312              
313 120         233 my $fi_eval_package;
314 120         167 my $fi_scrub_package = 0;
315              
316 120 100       296 unless (defined $fi_prepend) {
317 116         305 $fi_prepend = $fi_self->prepend_text;
318             }
319              
320 120 100       466 if (defined $fi_safe) {
    100          
    100          
321 12         37 $fi_eval_package = 'main';
322             }
323             elsif (defined $fi_package) {
324 31         67 $fi_eval_package = $fi_package;
325             }
326             elsif (defined $fi_varhash) {
327 21         61 $fi_eval_package = _gensym();
328 21         38 $fi_scrub_package = 1;
329             }
330             else {
331 56         110 $fi_eval_package = caller;
332             }
333              
334 120         228 my @fi_varlist;
335             my $fi_install_package;
336              
337 120 100       296 if (defined $fi_varhash) {
338 31 100       92 if (defined $fi_package) {
    100          
339 9         18 $fi_install_package = $fi_package;
340             }
341             elsif (defined $fi_safe) {
342 1         9 $fi_install_package = $fi_safe->root;
343             }
344             else {
345 21         72 $fi_install_package = $fi_eval_package; # The gensymmed one
346             }
347 31         106 @fi_varlist = _install_hash($fi_varhash => $fi_install_package);
348 31 100       78 if ($fi_strict) {
349 2 50       20 $fi_prepend = "use vars qw(@fi_varlist);$fi_prepend" if @fi_varlist;
350 2         7 $fi_prepend = "use strict;$fi_prepend";
351             }
352             }
353              
354 120 100 100     348 if (defined $fi_package && defined $fi_safe) {
355 20     20   220 no strict 'refs';
  20         46  
  20         2182  
356              
357             # Big fat magic here: Fix it so that the user-specified package
358             # is the default one available in the safe compartment.
359 2         4 *{ $fi_safe->root . '::' } = \%{ $fi_package . '::' }; # LOD
  2         14  
  2         8  
360             }
361              
362 120         280 my $fi_r = '';
363 120         163 my $fi_item;
364 120         167 foreach $fi_item (@{ $fi_self->{SOURCE} }) {
  120         315  
365 276         644 my ($fi_type, $fi_text, $fi_lineno) = @$fi_item;
366 276 100       644 if ($fi_type eq 'TEXT') {
    50          
367 139         444 $fi_self->append_text_to_output(
368             text => $fi_text,
369             handle => $fi_ofh,
370             out => \$fi_r,
371             type => $fi_type,);
372             }
373             elsif ($fi_type eq 'PROG') {
374 20     20   196 no strict;
  20         56  
  20         1448  
375              
376 137         326 my $fi_lcomment = "#line $fi_lineno $fi_filename";
377 137         368 my $fi_progtext = "package $fi_eval_package; $fi_prepend;\n$fi_lcomment\n$fi_text;\n;";
378 137         216 my $fi_res;
379 137         194 my $fi_eval_err = '';
380              
381 137 100       254 if ($fi_safe) {
382 20     20   130 no strict;
  20         52  
  20         591  
383 20     20   114 no warnings;
  20         53  
  20         2265  
384              
385 15         88 $fi_safe->reval(q{undef $OUT});
386 15         7952 $fi_res = $fi_safe->reval($fi_progtext);
387 15         6669 $fi_eval_err = $@;
388 15         41 my $OUT = $fi_safe->reval('$OUT');
389 15 100       6336 $fi_res = $OUT if defined $OUT;
390             }
391             else {
392 20     20   132 no strict;
  20         53  
  20         623  
393 20     20   123 no warnings;
  20         47  
  20         16912  
394              
395 122         165 my $OUT;
396 122     1   9694 $fi_res = eval $fi_progtext;
  1     1   7  
  1     1   12  
  1     1   31  
  1         5  
  1         2  
  1         90  
  1         7  
  1         2  
  1         42  
  1         6  
  1         2  
  1         37  
397 114         1349 $fi_eval_err = $@;
398 114 100       328 $fi_res = $OUT if defined $OUT;
399             }
400              
401             # If the value of the filled-in text really was undef,
402             # change it to an explicit empty string to avoid undefined
403             # value warnings later.
404 129 100       310 $fi_res = '' unless defined $fi_res;
405              
406 129 100       323 if ($fi_eval_err) {
407 11         36 $fi_res = $fi_broken->(
408             text => $fi_text,
409             error => $fi_eval_err,
410             lineno => $fi_lineno,
411             arg => $fi_broken_arg,);
412 11 100       83 if (defined $fi_res) {
413 10         45 $fi_self->append_text_to_output(
414             text => $fi_res,
415             handle => $fi_ofh,
416             out => \$fi_r,
417             type => $fi_type,);
418             }
419             else {
420 1         6 return $fi_r; # Undefined means abort processing
421             }
422             }
423             else {
424 118         420 $fi_self->append_text_to_output(
425             text => $fi_res,
426             handle => $fi_ofh,
427             out => \$fi_r,
428             type => $fi_type,);
429             }
430             }
431             else {
432 0         0 die "Can't happen error #2";
433             }
434             }
435              
436 111 100       303 _scrubpkg($fi_eval_package) if $fi_scrub_package;
437              
438 111 100       669 defined $fi_ofh ? 1 : $fi_r;
439             }
440              
441             sub append_text_to_output {
442 267     267 0 935 my ($self, %arg) = @_;
443              
444 267 100       606 if (defined $arg{handle}) {
445 2         3 print { $arg{handle} } $arg{text};
  2         19  
446             }
447             else {
448 265         364 ${ $arg{out} } .= $arg{text};
  265         630  
449             }
450              
451 267         890 return;
452             }
453              
454             sub fill_this_in {
455 6     6 1 1145 my ($pack, $text) = splice @_, 0, 2;
456              
457 6 50       21 my $templ = $pack->new(TYPE => 'STRING', SOURCE => $text, @_)
458             or return undef;
459              
460 6 50       21 $templ->compile or return undef;
461              
462 6         23 my $result = $templ->fill_in(@_);
463              
464 6         53 $result;
465             }
466              
467             sub fill_in_string {
468 4     4 1 3772 my $string = shift;
469              
470 4         16 my $package = _param('package', @_);
471              
472 4 100       19 push @_, 'package' => scalar(caller) unless defined $package;
473              
474 4         16 Text::Template->fill_this_in($string, @_);
475             }
476              
477             sub fill_in_file {
478 2     2 1 1448 my $fn = shift;
479 2 50       14 my $templ = Text::Template->new(TYPE => 'FILE', SOURCE => $fn, @_) or return undef;
480              
481 2 50       5 $templ->compile or return undef;
482              
483 2         5 my $text = $templ->fill_in(@_);
484              
485 2         13 $text;
486             }
487              
488             sub _default_broken {
489 5     5   27 my %a = @_;
490              
491 5         22 my $prog_text = $a{text};
492 5         9 my $err = $a{error};
493 5         10 my $lineno = $a{lineno};
494              
495 5         17 chomp $err;
496              
497             # $err =~ s/\s+at .*//s;
498 5         24 "Program fragment delivered error ``$err''";
499             }
500              
501             sub _load_text {
502 10     10   18 my $fn = shift;
503              
504 10 100       405 open my $fh, '<', $fn or do {
505 1         20 $ERROR = "Couldn't open file $fn: $!";
506 1         6 return undef;
507             };
508              
509 9         52 local $/;
510              
511 9         377 <$fh>;
512             }
513              
514             sub _is_clean {
515 8     8   2663 my $z;
516              
517 8         14 eval { ($z = join('', @_)), eval '#' . substr($z, 0, 0); 1 } # LOD
  8         203  
  5         28  
518             }
519              
520             sub _unconditionally_untaint {
521 4     4   624 for (@_) {
522 4         26 ($_) = /(.*)/s;
523             }
524             }
525              
526             {
527             my $seqno = 0;
528              
529             sub _gensym {
530 21     21   63 __PACKAGE__ . '::GEN' . $seqno++;
531             }
532              
533             sub _scrubpkg {
534 22     22   578 my $s = shift;
535              
536 22         118 $s =~ s/^Text::Template:://;
537              
538 20     20   178 no strict 'refs';
  20         91  
  20         3471  
539              
540 22         86 my $hash = $Text::Template::{ $s . "::" };
541              
542 22         69 foreach my $key (keys %$hash) {
543 39         98 undef $hash->{$key};
544             }
545              
546 22         131 %$hash = ();
547              
548 22         211 delete $Text::Template::{ $s . "::" };
549             }
550             }
551              
552             # Given a hashful of variables (or a list of such hashes)
553             # install the variables into the specified package,
554             # overwriting whatever variables were there before.
555             sub _install_hash {
556 31     31   59 my $hashlist = shift;
557 31         57 my $dest = shift;
558              
559 31 100       170 if (UNIVERSAL::isa($hashlist, 'HASH')) {
560 29         72 $hashlist = [$hashlist];
561             }
562              
563 31         62 my @varlist;
564              
565 31         72 for my $hash (@$hashlist) {
566 34         92 for my $name (keys %$hash) {
567 50         162 my $val = $hash->{$name};
568              
569 20     20   145 no strict 'refs';
  20         41  
  20         702  
570 20     20   120 no warnings 'redefine';
  20         46  
  20         5445  
571              
572 50         79 local *SYM = *{"$ {dest}::$name"};
  50         343  
573              
574 50 100       143 if (!defined $val) {
    100          
575 2         3 delete ${"$ {dest}::"}{$name};
  2         8  
576 2         34 my $match = qr/^.\Q$name\E$/;
577 2         10 @varlist = grep { $_ !~ $match } @varlist;
  1         11  
578             }
579             elsif (ref $val) {
580 10         23 *SYM = $val;
581 10         18 push @varlist, do {
582 10 100       52 if (UNIVERSAL::isa($val, 'ARRAY')) { '@' }
  1 50       3  
583 0         0 elsif (UNIVERSAL::isa($val, 'HASH')) { '%' }
584 9         41 else { '$' }
585             }
586             . $name;
587             }
588             else {
589 38         71 *SYM = \$val;
590 38         121 push @varlist, '$' . $name;
591             }
592             }
593             }
594              
595 31         144 @varlist;
596             }
597              
598 0     0 0 0 sub TTerror { $ERROR }
599              
600             1;
601              
602             __END__