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   728957 use 5.005;
  14         162  
4 14     14   80 use strict;
  14         26  
  14         401  
5 14     14   7409 use integer; # no floating point math so far!
  14         216  
  14         80  
6 14     14   6597 use HTML::Template::Pro::WrapAssociate;
  14         37  
  14         433  
7 14     14   102 use File::Spec; # generate paths that work on all platforms
  14         31  
  14         356  
8 14     14   77 use Scalar::Util qw(tainted);
  14         25  
  14         1611  
9 14     14   88 use Carp;
  14         28  
  14         850  
10             require DynaLoader;
11             require Exporter;
12 14     14   86 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
  14         30  
  14         1865  
13             @ISA = qw(DynaLoader Exporter);
14              
15             $VERSION = '0.9523';
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         2167 ASK_NAME_DEFAULT => 0,
23             ASK_NAME_AS_IS => 1,
24             ASK_NAME_LOWERCASE => 2,
25             ASK_NAME_UPPERCASE => 4,
26 14     14   113 };
  14         28  
27 14     14   133 use constant ASK_NAME_MASK => ASK_NAME_AS_IS | ASK_NAME_LOWERCASE | ASK_NAME_UPPERCASE;
  14         53  
  14         1678  
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   104 use vars qw(%FUNC);
  14         30  
  14         32442  
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 92750 my $class=shift;
72 148         271 my %param;
73 148         1671 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     558 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       443 if (ref($options->{associate}) ne 'ARRAY') {
124 2         6 $options->{associate} = [ $options->{associate} ];
125             }
126             # path should be an array if it's not already
127 148 100       340 if (ref($options->{path}) ne 'ARRAY') {
128 29         69 $options->{path} = [ $options->{path} ];
129             }
130             # filter should be an array if it's not already
131 148 100       335 if (ref($options->{filter}) ne 'ARRAY') {
132 4         11 $options->{filter} = [ $options->{filter} ];
133             }
134              
135 148         230 my $case_sensitive = $options->{case_sensitive};
136 148         223 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         18 map {HTML::Template::Pro::WrapAssociate->_wrap($_, $case_sensitive, $__strict_compatibility)}
141 148         224 @{$options->{associate}}
  148         361  
142             ];
143              
144             # check for syntax errors:
145 148         264 my $source_count = 0;
146 148 100       325 exists($options->{filename}) and $source_count++;
147 148 100       353 exists($options->{filehandle}) and $source_count++;
148 148 50       310 exists($options->{arrayref}) and $source_count++;
149 148 100       299 exists($options->{scalarref}) and $source_count++;
150 148 50       341 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       310 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       294 if ($options->{filehandle}) {
159 2         10 local $/; # enable "slurp" mode
160 2         39 local *FH=$options->{filehandle};
161 2         51 my $template=;
162 2         15 $options->{scalarref}=\$template;
163             }
164              
165             # merging built_in funcs with user-defined funcs
166 148         522 $options->{expr_func}={%FUNC, %{$options->{functions}}};
  148         679  
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         390 bless $options,$class;
173 148 50 66     460 $options->_call_filters($options->{scalarref}) if $options->{scalarref} and @{$options->{filter}};
  12         57  
174              
175 148         856 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 4 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 85870 my $self=shift;
194 449         1089 my %oparam=(@_);
195 449         785 my $print_to = $oparam{print_to};
196              
197 449 100 66     2211 if (defined wantarray && ! $print_to) {
198 378         22851 return exec_tmpl_string($self);
199             } else {
200 71         8820 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 8022 my $self = shift;
211             #my $options = $self->{options};
212 199         316 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       612 if (scalar @_==0) {
    100          
217 3         11 return keys (%$param_map);
218             } elsif (scalar @_==1) {
219 9 100 66     29 if (ref($_[0]) and UNIVERSAL::isa($_[0], 'HASH')) {
220             # ref to hash of params --- simply dereference it
221 1         3 return $self->param(%{$_[0]});
  1         5  
222             } else {
223 8 100       21 my $key=$self->{case_sensitive} ? $_[0] : lc($_[0]);
224 8   33     36 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       376 if ($self->{case_sensitive}) {
230 40         92 while (@_) {
231 222         305 my $key=shift;
232 222         289 my $val=shift;
233 222         527 $param_map->{$key}=$val;
234             }
235             } else {
236 147         326 while (@_) {
237 298         454 my $key=shift;
238 298         402 my $val=shift;
239 298 100       512 if (ref($val)) {
240 54 100       155 if (UNIVERSAL::isa($val, 'ARRAY')) {
241 48         106 $param_map->{lc($key)}=[map {_lowercase_keys($_)} @$val];
  100         172  
242             } else {
243 6         35 $param_map->{lc($key)}=$val;
244             }
245             } else {
246 244         747 $param_map->{lc($key)}=$val;
247             }
248             }
249             }
250             }
251              
252             sub register_function {
253 21     21 0 1831 my($self, $name, $sub) = @_;
254 21 100       54 if ( ref($sub) eq 'CODE' ) {
    50          
255 20 100       38 if (ref $self) {
256             # per object call
257 12         27 $self->{expr_func}->{$name} = $sub;
258 12         32 $self->{expr_func_user_list}->{$name} = 1;
259             } else {
260             # per class call
261 8         27 $FUNC{$name} = $sub;
262             }
263             } elsif ( defined $sub ) {
264 1         223 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   169 my $orighash=shift;
280 121         174 my $newhash={};
281 121         195 my ($key,$val);
282 121 50       267 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         349 while (($key,$val)=each %$orighash) {
287 209 100       410 if (ref($val)) {
288 8 50       24 if (UNIVERSAL::isa($val, 'ARRAY')) {
289 8         18 $newhash->{lc($key)}=[map {_lowercase_keys($_)} @$val];
  21         42  
290             } else {
291 0         0 $newhash->{lc($key)}=$val;
292             }
293             } else {
294 201         560 $newhash->{lc($key)}=$val;
295             }
296             }
297 121         376 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   31 my $self = shift;
374 9         17 my $filepath=shift;
375 9         15 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         344 while (read(TEMPLATE, $template, 10240, length($template))) {}
380 9         90 close(TEMPLATE);
381 9 50       21 $self->_call_filters(\$template) if @{$self->{filter}};
  9         61  
382 9         209 return \$template;
383             }
384              
385             # handle calling user defined filters
386             sub _call_filters {
387 9     9   18 my $self = shift;
388 9         13 my $template_ref = shift;
389 9         13 my $options = $self;#->{options};
390              
391 9         16 my ($format, $sub);
392 9         13 foreach my $filter (@{$options->{filter}}) {
  9         22  
393 11 50       28 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       28 $filter = { 'format' => 'scalar', 'sub' => $filter }
398             if (ref $filter eq 'CODE');
399              
400 11 50       24 if (ref $filter eq 'HASH') {
401 11         18 $format = $filter->{'format'};
402 11         18 $sub = $filter->{'sub'};
403              
404             # check types and values
405 11 50 33     40 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     37 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     38 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         21 eval {
414 11 100       23 if ($format eq 'scalar') {
415             # call
416 8         20 $sub->($template_ref);
417             } else {
418             # modulate
419 3         15 my @array = map { $_."\n" } split("\n", $$template_ref);
  15         33  
420             # call
421 3         14 $sub->(\@array);
422             # demodulate
423 3         78 $$template_ref = join("", @array);
424             }
425             };
426 11 50       64 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         17 return $template_ref;
433             }
434              
435             1;
436             __END__