File Coverage

blib/lib/HTML/Template/Pro.pm
Criterion Covered Total %
statement 146 200 73.0
branch 56 100 56.0
condition 12 30 40.0
subroutine 19 25 76.0
pod 0 9 0.0
total 233 364 64.0


line stmt bran cond sub pod time code
1             package HTML::Template::Pro;
2              
3 14     14   730466 use 5.005;
  14         147  
4 14     14   106 use strict;
  14         29  
  14         400  
5 14     14   7206 use integer; # no floating point math so far!
  14         215  
  14         65  
6 14     14   6391 use HTML::Template::Pro::WrapAssociate;
  14         39  
  14         440  
7 14     14   89 use File::Spec; # generate paths that work on all platforms
  14         27  
  14         366  
8 14     14   72 use Scalar::Util qw(tainted);
  14         23  
  14         889  
9 14     14   84 use Carp;
  14         27  
  14         899  
10             require DynaLoader;
11             require Exporter;
12 14     14   83 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
  14         27  
  14         1961  
13             @ISA = qw(DynaLoader Exporter);
14              
15             $VERSION = '0.9524';
16              
17             @EXPORT_OK = qw/ASK_NAME_DEFAULT ASK_NAME_AS_IS ASK_NAME_LOWERCASE ASK_NAME_UPPERCASE ASK_NAME_MASK/;
18             %EXPORT_TAGS = (const => [qw/ASK_NAME_DEFAULT ASK_NAME_AS_IS ASK_NAME_LOWERCASE ASK_NAME_UPPERCASE ASK_NAME_MASK/]);
19              
20             # constants for tmpl_var_case
21             use constant {
22 14         2158 ASK_NAME_DEFAULT => 0,
23             ASK_NAME_AS_IS => 1,
24             ASK_NAME_LOWERCASE => 2,
25             ASK_NAME_UPPERCASE => 4,
26 14     14   109 };
  14         26  
27 14     14   164 use constant ASK_NAME_MASK => ASK_NAME_AS_IS | ASK_NAME_LOWERCASE | ASK_NAME_UPPERCASE;
  14         54  
  14         1618  
28              
29              
30             bootstrap HTML::Template::Pro $VERSION;
31              
32             ## when HTML::Template is not loaded,
33             ## all calls to HTML::Template will be sent to HTML::Template::Pro,
34             ## otherwise native HTML::Template will be used
35             push @HTML::Template::ISA, qw/HTML::Template::Pro/;
36             push @HTML::Template::Expr::ISA, qw/HTML::Template::Pro/;
37              
38             # Preloaded methods go here.
39              
40             # internal C library init -- required
41             _init();
42             # internal C library unload -- it is better to comment it:
43             # when process terminates, memory is freed anyway
44             # but END {} can be called between calls (as SpeedyCGI does)
45             # END {_done()}
46              
47             # initialize preset function table
48 14     14   107 use vars qw(%FUNC);
  14         30  
  14         33192  
49             %FUNC =
50             (
51             # note that length,defined,sin,cos,log,tan,... are built-in
52             'sprintf' => sub { sprintf(shift, @_); },
53             'substr' => sub {
54             return substr($_[0], $_[1]) if @_ == 2;
55             return substr($_[0], $_[1], $_[2]);
56             },
57             'lc' => sub { lc($_[0]); },
58             'lcfirst' => sub { lcfirst($_[0]); },
59             'uc' => sub { uc($_[0]); },
60             'ucfirst' => sub { ucfirst($_[0]); },
61             # 'length' => sub { length($_[0]); },
62             # 'defined' => sub { defined($_[0]); },
63             # 'abs' => sub { abs($_[0]); },
64             # 'hex' => sub { hex($_[0]); },
65             # 'oct' => sub { oct($_[0]); },
66             'rand' => sub { rand($_[0]); },
67             'srand' => sub { srand($_[0]); },
68             );
69              
70             sub new {
71 148     148 0 86504 my $class=shift;
72 148         261 my %param;
73 148         1639 my $options={param_map=>\%param,
74             functions => {},
75             filter => [],
76             # ---- supported -------
77             debug => 0,
78             max_includes => 10,
79             global_vars => 0,
80             no_includes => 0,
81             search_path_on_include => 0,
82             loop_context_vars => 0,
83             path => [],
84             associate => [],
85             case_sensitive => 0,
86             __strict_compatibility => 1,
87             force_untaint => 0,
88             # ---- unsupported distinct -------
89             die_on_bad_params => 0,
90             strict => 0,
91             # ---- unsupported -------
92             # vanguard_compatibility_mode => 0,
93             #=============================================
94             # The following options are harmless caching-specific.
95             # They are ignored silently because there is nothing to cache.
96             #=============================================
97             # stack_debug => 0,
98             # timing => 0,
99             # cache => 0,
100             # blind_cache => 0,
101             # file_cache => 0,
102             # file_cache_dir => '',
103             # file_cache_dir_mode => 0700,
104             # cache_debug => 0,
105             # shared_cache_debug => 0,
106             # memory_debug => 0,
107             # shared_cache => 0,
108             # double_cache => 0,
109             # double_file_cache => 0,
110             # ipc_key => 'TMPL',
111             # ipc_mode => 0666,
112             # ipc_segment_size => 65536,
113             # ipc_max_size => 0,
114             #============================================
115             @_};
116              
117             # make sure taint mode is on if force_untaint flag is set
118 148 50 33     567 if ($options->{force_untaint} && ! ${^TAINT}) {
119 0         0 croak("HTML::Template->new() : 'force_untaint' option set but perl does not run in taint mode!");
120             }
121              
122             # associate should be an array if it's not already
123 148 100       448 if (ref($options->{associate}) ne 'ARRAY') {
124 2         5 $options->{associate} = [ $options->{associate} ];
125             }
126             # path should be an array if it's not already
127 148 100       342 if (ref($options->{path}) ne 'ARRAY') {
128 29         70 $options->{path} = [ $options->{path} ];
129             }
130             # filter should be an array if it's not already
131 148 100       320 if (ref($options->{filter}) ne 'ARRAY') {
132 4         9 $options->{filter} = [ $options->{filter} ];
133             }
134              
135 148         244 my $case_sensitive = $options->{case_sensitive};
136 148         227 my $__strict_compatibility = $options->{__strict_compatibility};
137             # wrap associated objects into tied hash and
138             # make sure objects in associate are support param()
139             $options->{associate} = [
140 2         13 map {HTML::Template::Pro::WrapAssociate->_wrap($_, $case_sensitive, $__strict_compatibility)}
141 148         231 @{$options->{associate}}
  148         399  
142             ];
143              
144             # check for syntax errors:
145 148         254 my $source_count = 0;
146 148 100       322 exists($options->{filename}) and $source_count++;
147 148 100       317 exists($options->{filehandle}) and $source_count++;
148 148 50       310 exists($options->{arrayref}) and $source_count++;
149 148 100       302 exists($options->{scalarref}) and $source_count++;
150 148 50       334 if ($source_count != 1) {
151 0         0 croak("HTML::Template->new called with multiple (or no) template sources specified! A valid call to new() has exactly one filename => 'file' OR exactly one scalarref => \\\$scalar OR exactly one arrayref => \\\@array OR exactly one filehandle => \*FH");
152             }
153 148 50       307 if ($options->{arrayref}) {
154 0 0       0 die "bad value of arrayref" unless UNIVERSAL::isa($_[0], 'ARRAY');
155 0         0 my $template=join('',@{$options->{arrayref}});
  0         0  
156 0         0 $options->{scalarref}=\$template;
157             }
158 148 100       304 if ($options->{filehandle}) {
159 2         10 local $/; # enable "slurp" mode
160 2         41 local *FH=$options->{filehandle};
161 2         49 my $template=;
162 2         17 $options->{scalarref}=\$template;
163             }
164              
165             # merging built_in funcs with user-defined funcs
166 148         512 $options->{expr_func}={%FUNC, %{$options->{functions}}};
  148         658  
167              
168             # hack to be fully compatible with HTML::Template;
169             # caused serious memory leak. it should be done on XS level, if needed.
170             # &safe_circular_reference($options,'options') ???
171             #$options->{options}=$options;
172 148         380 bless $options,$class;
173 148 50 66     447 $options->_call_filters($options->{scalarref}) if $options->{scalarref} and @{$options->{filter}};
  12         51  
174              
175 148         875 return $options; # == $self
176             }
177              
178             # a few shortcuts to new(), of possible use...
179             sub new_file {
180 0     0 0 0 my $pkg = shift; return $pkg->new('filename', @_);
  0         0  
181             }
182             sub new_filehandle {
183 1     1 0 3 my $pkg = shift; return $pkg->new('filehandle', @_);
  1         4  
184             }
185             sub new_array_ref {
186 0     0 0 0 my $pkg = shift; return $pkg->new('arrayref', @_);
  0         0  
187             }
188             sub new_scalar_ref {
189 0     0 0 0 my $pkg = shift; return $pkg->new('scalarref', @_);
  0         0  
190             }
191              
192             sub output {
193 449     449 0 84855 my $self=shift;
194 449         1061 my %oparam=(@_);
195 449         786 my $print_to = $oparam{print_to};
196              
197 449 100 66     1881 if (defined wantarray && ! $print_to) {
198 378         22719 return exec_tmpl_string($self);
199             } else {
200 71         8908 exec_tmpl($self,$print_to);
201             }
202             }
203              
204             sub clear_params {
205 0     0 0 0 my $self = shift;
206 0         0 %{$self->{param_map}}=();
  0         0  
207             }
208              
209             sub param {
210 199     199 0 3688 my $self = shift;
211             #my $options = $self->{options};
212 199         319 my $param_map = $self->{param_map};
213             # compatibility with HTML::Template
214             # the one-parameter case - could be a parameter value request or a
215             # hash-ref.
216 199 100       614 if (scalar @_==0) {
    100          
217 3         10 return keys (%$param_map);
218             } elsif (scalar @_==1) {
219 9 100 66     31 if (ref($_[0]) and UNIVERSAL::isa($_[0], 'HASH')) {
220             # ref to hash of params --- simply dereference it
221 1         2 return $self->param(%{$_[0]});
  1         6  
222             } else {
223 8 100       23 my $key=$self->{case_sensitive} ? $_[0] : lc($_[0]);
224 8   33     38 return $param_map->{$key} || $param_map->{$_[0]};
225             }
226             }
227             # loop below is obvious but wrong for perl
228             # while (@_) {$param_map->{shift(@_)}=shift(@_);}
229 187 100       387 if ($self->{case_sensitive}) {
230 40         93 while (@_) {
231 222         304 my $key=shift;
232 222         280 my $val=shift;
233 222         524 $param_map->{$key}=$val;
234             }
235             } else {
236 147         322 while (@_) {
237 298         779 my $key=shift;
238 298         405 my $val=shift;
239 298 100       532 if (ref($val)) {
240 54 100       148 if (UNIVERSAL::isa($val, 'ARRAY')) {
241 48         111 $param_map->{lc($key)}=[map {_lowercase_keys($_)} @$val];
  100         186  
242             } else {
243 6         32 $param_map->{lc($key)}=$val;
244             }
245             } else {
246 244         734 $param_map->{lc($key)}=$val;
247             }
248             }
249             }
250             }
251              
252             sub register_function {
253 21     21 0 1764 my($self, $name, $sub) = @_;
254 21 100       55 if ( ref($sub) eq 'CODE' ) {
    50          
255 20 100       34 if (ref $self) {
256             # per object call
257 12         29 $self->{expr_func}->{$name} = $sub;
258 12         33 $self->{expr_func_user_list}->{$name} = 1;
259             } else {
260             # per class call
261 8         21 $FUNC{$name} = $sub;
262             }
263             } elsif ( defined $sub ) {
264 1         228 croak("HTML::Template::Pro : last arg of register_function must be subroutine reference\n")
265             } else {
266 0 0       0 if (ref $self) {
267 0 0       0 if ( defined $name ) {
268 0         0 return $self->{expr_func}->{$name};
269             } else {
270 0         0 return keys %{ $self->{expr_func_user_list} };
  0         0  
271             }
272             } else {
273 0         0 return keys %FUNC;
274             }
275             }
276             }
277              
278             sub _lowercase_keys {
279 121     121   165 my $orighash=shift;
280 121         183 my $newhash={};
281 121         181 my ($key,$val);
282 121 50       287 unless (UNIVERSAL::isa($orighash, 'HASH')) {
283 0         0 Carp::carp "HTML::Template::Pro:_lowercase_keys:in param_tree: found strange parameter $orighash while hash was expected";
284 0         0 return;
285             }
286 121         372 while (($key,$val)=each %$orighash) {
287 209 100       370 if (ref($val)) {
288 8 50       27 if (UNIVERSAL::isa($val, 'ARRAY')) {
289 8         16 $newhash->{lc($key)}=[map {_lowercase_keys($_)} @$val];
  21         41  
290             } else {
291 0         0 $newhash->{lc($key)}=$val;
292             }
293             } else {
294 201         562 $newhash->{lc($key)}=$val;
295             }
296             }
297 121         383 return $newhash;
298             }
299              
300             # sub _load_file {
301             # my $filepath=shift;
302             # open my $fh, $filepath or die $!;
303             # local $/; # enable localized slurp mode
304             # my $content = <$fh>;
305             # close $fh;
306             # return $content;
307             # }
308              
309             ## HTML::Template based
310              
311             #### callback function called from C library ##############
312             # Note that this _get_filepath perl code is deprecated; ##
313             # by default built-in find_file implementation is used. ##
314             # use magic option __use_perl_find_file => 1 to re-enable it.
315             ###########################################################
316             sub _get_filepath {
317 0     0   0 my ($self, $filename, $last_visited_file) = @_;
318             # look for the included file...
319 0         0 my $filepath;
320 0 0 0     0 if ((not defined $last_visited_file) or $self->{search_path_on_include}) {
321 0         0 $filepath = $self->_find_file($filename);
322             } else {
323 0         0 $filepath = $self->_find_file($filename,
324             [File::Spec->splitdir($last_visited_file)]
325             );
326             }
327 0 0       0 carp "HTML::Template::Pro (using callback): template $filename not found!" unless $filepath;
328 0         0 return $filepath;
329             }
330              
331             sub _find_file {
332 0     0   0 my ($options, $filename, $extra_path) = @_;
333 0         0 my $filepath;
334              
335             # first check for a full path
336 0 0 0     0 return File::Spec->canonpath($filename)
337             if (File::Spec->file_name_is_absolute($filename) and (-e $filename));
338              
339             # try the extra_path if one was specified
340 0 0       0 if (defined($extra_path)) {
341 0         0 $extra_path->[$#{$extra_path}] = $filename;
  0         0  
342 0         0 $filepath = File::Spec->canonpath(File::Spec->catfile(@$extra_path));
343 0 0       0 return File::Spec->canonpath($filepath) if -e $filepath;
344             }
345              
346             # try pre-prending HTML_Template_Root
347 0 0       0 if (defined($ENV{HTML_TEMPLATE_ROOT})) {
348 0         0 $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $filename);
349 0 0       0 return File::Spec->canonpath($filepath) if -e $filepath;
350             }
351              
352             # try "path" option list..
353 0         0 foreach my $path (@{$options->{path}}) {
  0         0  
354 0         0 $filepath = File::Spec->catfile($path, $filename);
355 0 0       0 return File::Spec->canonpath($filepath) if -e $filepath;
356             }
357              
358             # try even a relative path from the current directory...
359 0 0       0 return File::Spec->canonpath($filename) if -e $filename;
360              
361             # try "path" option list with HTML_TEMPLATE_ROOT prepended...
362 0 0       0 if (defined($ENV{HTML_TEMPLATE_ROOT})) {
363 0         0 foreach my $path (@{$options->{path}}) {
  0         0  
364 0         0 $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $path, $filename);
365 0 0       0 return File::Spec->canonpath($filepath) if -e $filepath;
366             }
367             }
368            
369 0         0 return undef;
370             }
371              
372             sub _load_template {
373 9     9   30 my $self = shift;
374 9         18 my $filepath=shift;
375 9         17 my $template = "";
376 9 50       270 confess("HTML::Template->new() : Cannot open file $filepath : $!")
377             unless defined(open(TEMPLATE, $filepath));
378             # read into scalar
379 9         339 while (read(TEMPLATE, $template, 10240, length($template))) {}
380 9         88 close(TEMPLATE);
381 9 50       21 $self->_call_filters(\$template) if @{$self->{filter}};
  9         59  
382 9         243 return \$template;
383             }
384              
385             # handle calling user defined filters
386             sub _call_filters {
387 9     9   19 my $self = shift;
388 9         12 my $template_ref = shift;
389 9         15 my $options = $self;#->{options};
390              
391 9         14 my ($format, $sub);
392 9         16 foreach my $filter (@{$options->{filter}}) {
  9         20  
393 11 50       27 croak("HTML::Template->new() : bad value set for filter parameter - must be a code ref or a hash ref.")
394             unless ref $filter;
395              
396             # translate into CODE->HASH
397 11 100       32 $filter = { 'format' => 'scalar', 'sub' => $filter }
398             if (ref $filter eq 'CODE');
399              
400 11 50       26 if (ref $filter eq 'HASH') {
401 11         19 $format = $filter->{'format'};
402 11         19 $sub = $filter->{'sub'};
403              
404             # check types and values
405 11 50 33     43 croak("HTML::Template->new() : bad value set for filter parameter - hash must contain \"format\" key and \"sub\" key.")
406             unless defined $format and defined $sub;
407 11 50 66     41 croak("HTML::Template->new() : bad value set for filter parameter - \"format\" must be either 'array' or 'scalar'")
408             unless $format eq 'array' or $format eq 'scalar';
409 11 50 33     40 croak("HTML::Template->new() : bad value set for filter parameter - \"sub\" must be a code ref")
410             unless ref $sub and ref $sub eq 'CODE';
411              
412             # catch errors
413 11         23 eval {
414 11 100       21 if ($format eq 'scalar') {
415             # call
416 8         23 $sub->($template_ref);
417             } else {
418             # modulate
419 3         15 my @array = map { $_."\n" } split("\n", $$template_ref);
  15         37  
420             # call
421 3         23 $sub->(\@array);
422             # demodulate
423 3         69 $$template_ref = join("", @array);
424             }
425             };
426 11 50       66 croak("HTML::Template->new() : fatal error occured during filter call: $@") if $@;
427             } else {
428 0         0 croak("HTML::Template->new() : bad value set for filter parameter - must be code ref or hash ref");
429             }
430             }
431             # all done
432 9         19 return $template_ref;
433             }
434              
435             1;
436             __END__