File Coverage

blib/lib/HTML/Template/Ex.pm
Criterion Covered Total %
statement 21 143 14.6
branch 0 66 0.0
condition 0 33 0.0
subroutine 7 23 30.4
pod 4 4 100.0
total 32 269 11.9


line stmt bran cond sub pod time code
1             package HTML::Template::Ex;
2             #
3             # Copyright (C) 2007 Bee Flag, Corp, All Rights Reserved.
4             # Masatoshi Mizuno E<lt>mizunoE<64>bomcity.comE<gt>
5             #
6             # $Id: Ex.pm 297 2007-03-25 14:34:59Z lushe $
7             #
8 2     2   34688 use strict;
  2         6  
  2         115  
9 2     2   10 use warnings;
  2         6  
  2         60  
10 2     2   11 use base qw/HTML::Template/;
  2         6  
  2         3405  
11 2     2   31468 use Carp qw/croak/;
  2         6  
  2         174  
12 2     2   10 use Digest::MD5 qw/md5_hex/;
  2         5  
  2         1314  
13              
14             our $VERSION = '0.08';
15              
16             my $ErrstrStyle= <<END_OF_STYLE;
17             padding : 5px;
18             background : #004858;
19             color : #FFF;
20             font-size : 13px;
21             END_OF_STYLE
22              
23 0     0 1   sub initStyle { $ErrstrStyle= $_[1] }
24              
25             my $GetCharSetRegix=
26             qr{<meta.+?content=[\'\"]text/html\s*\;\s*charset=([A-Za-z0-9\-_]+)[\'\"].*?/?\s*>};
27              
28             sub new {
29 0     0 1   my $class= shift;
30 0   0       my $base = shift || HTML::Template::Ex::DummyObject->new;
31 0 0         my %opt = $_[0] ? ($_[1] ? @_: %{$_[0]})
  0 0          
32             : croak __PACKAGE__.'::new: I want argument.';
33              
34 0           for (
35             [qw{ strict 0 }],
36             [qw{ file_cache 0 }],
37             [qw{ global_vars 1 }],
38             [qw{ shared_cache 0 }],
39             [qw{ die_on_bad_params 0 }],
40             ) {
41 0 0         $opt{$_->[0]}= $_->[1] if exists($opt{$_->[0]});
42             }
43              
44 0           my(%param, %mark, %order, %temp);
45 0           $opt{_ex_base_object}= $base;
46 0           $opt{_ex_params} = \%param;
47 0           $opt{_ex_orders} = \%order;
48 0           $opt{_ex_mark} = \%mark;
49 0 0         if (exists($opt{filter})) {
50 0 0         if (ref($opt{filter}) eq 'CODE') {
    0          
    0          
51 0           $opt{filter}= [{ format=> 'scalar', sub=> $opt{filter} }];
52             } elsif (ref($opt{filter}) eq 'HASH') {
53 0           $opt{filter}= [$opt{filter}];
54             } elsif (ref($opt{filter}) ne 'ARRAY') {
55 0           croak __PACKAGE__.q{::new: Bad format for 'filter'};
56             }
57             }
58 0 0         if ($opt{setup_env}) {
59 0 0   0     $param{"env_$_"}= sub { $ENV{$_} || "" } for keys %ENV;
  0            
60             }
61             my $filter= $opt{exec_off}
62 0     0     ? sub { &_offFilter(\%param, @_) }
63 0 0   0     : sub { &_exFilter($base, \%opt, \%temp, @_) };
  0            
64 0           push @{$opt{filter}}, { format=> 'scalar', sub=> $filter };
  0            
65 0           my $self= HTML::Template::new($class, %opt);
66 0 0 0       $opt{cache} and $self->{_ex_charset}= pop @{$self->{parse_stack}} || "";
67 0           $self;
68             }
69             sub output {
70 0     0 1   my($self)= @_;
71 0           my $parse_stack= $self->{parse_stack};
72 0           my $options = $self->{options};
73 0           my($ex_mark, $ex_param, $ex_order);
74 0 0         if ($options->{cache}) {
75 0           $ex_mark = pop @$parse_stack;
76 0           $ex_param= pop @$parse_stack;
77 0           $ex_order= pop @$parse_stack;
78             } else {
79 0   0       $ex_mark = $options->{_ex_mark} || {};
80 0   0       $ex_param= $options->{_ex_params} || {};
81 0   0       $ex_order= $options->{_ex_orders} || {};
82             }
83 0           HTML::Template::param($self, $ex_mark);
84 0           my $base = $options->{_ex_base_object};
85 0           my %param= %$ex_param;
86              
87 2 0   2   12 $options->{no_strict_exec} and do { no strict }; ## no critic
  2         4  
  2         2934  
  0            
88 0           my $cnt;
89 0           for my $v (@$parse_stack) {
90 0 0 0       next if (ref($v) ne 'HTML::Template::VAR' || ! $$v);
91 0   0       my $hash= $ex_order->{$$v} || next;
92 0           ++$cnt;
93 0           my $result;
94 0           eval{ $result= $hash->{function}->($base, \%param) };
  0            
95 0 0         if (my $err= $@) {
96 0           require HTML::Entities;
97 0           require Devel::StackTrace;
98 0           my $st= Devel::StackTrace->new( no_refs=> 1 );
99 0           my $error;
100             $error.= $_->filename. ': '
101 0           . $_->line. "\n" for $st->frames;
102 0           $error = HTML::Entities::encode_entities(
103             "<TMPL_EX( $cnt )> - error:\n $err \n stack trace:\n $error",
104             q{\\\<>&\"\'},
105             );
106 0           $error=~s{\r?\n} [<br />\n]sg;
107 0           $param{$$v}= qq{<div style="$ErrstrStyle">$error</div>};
108             } else {
109 0 0 0       $param{$$v}= ref($result) eq 'ARRAY' ? ""
    0          
110             : $hash->{hidden} ? "": ($result || "");
111 0 0         $param{$hash->{key_name}}= $result if $hash->{key_name};
112             }
113             }
114              
115 0           HTML::Template::param($self, \%param);
116 0           my $result= HTML::Template::output(@_);
117 0 0         if ($options->{cache}) {
118 0           push @$parse_stack, $ex_order;
119 0           push @$parse_stack, $ex_param;
120 0           push @$parse_stack, $ex_mark;
121 0   0       push @$parse_stack, ($self->{_ex_charset} || "");
122             }
123 0           $result;
124             }
125 0 0   0 1   sub charset { $_[0]->{_ex_charset} || "" }
126              
127             sub _call_filters {
128 0     0     my($self, $html)= @_;
129 0 0         $self->{_ex_charset}= $1 if $$html=~m{$GetCharSetRegix}i;
130 0 0         if ($self->{options}{auto_encoder}) {
    0          
131 0 0         $self->{options}{auto_encoder}->($html) if $self->{_ex_charset};
132             } elsif ($self->{options}{encoder}) {
133 0           $self->{options}{encoder}->($html);
134             }
135 0           HTML::Template::_call_filters(@_);
136             }
137             sub _exFilter {
138 0     0     my($base, $opt, $temp, $text)= @_;
139 0           $$text=~s{<tmpl_ex(\s+[^>]+\s*)?>(.+?)</tmpl_ex[^>]*>}
140 0           [ &_replaceEx($1, $2, $base, $opt, $temp) ]isge;
141 0 0         $$text=~m{(?:<tmpl_ex[^>]*>|</tmpl_ex[^>]*>)}
142             and croak q{At least one <TMPL_EX> not terminated at end of file!};
143 0           $$text=~s{<tmpl_set([^>]+)>} [ &_replaceSet($1, $opt->{_ex_params}) ]isge;
  0            
144             }
145             sub _offFilter {
146 0     0     my($param, $text)= @_;
147 0           $$text=~s{<tmpl_ex\s+[^>]+\s*?>.+?</tmpl_ex[^>]*>} []isg;
148 0           $$text=~s{(?:<tmpl_ex[^>]*>|</tmpl_ex[^>]*>)} []isg;
149 0           $$text=~s{<tmpl_set([^>]+)>} [ &_replaceSet($1, $param) ]isge;
  0            
150             }
151             sub _replaceSet {
152 0   0 0     my $opt = shift || return "[ tmpl_set Error!! ]";
153 0   0       my $param= shift || return "[ tmpl_set Error!! ]";
154 0   0       my $name = ($opt=~/name=\s*[\'\"]?([^\s\'\"]+)/)[0]
155             || return "[ tmpl_set Error!! ]";
156 0   0       my $value= ($opt=~/value=\s*[\'\"](.+?)[\'\"]/)[0]
157             || ($opt=~/value=\s*([^\s]+)/)[0]
158             || return "[ tmpl_set Error!! ('$name') ]";
159 0 0         $param->{$name}= $value if $value;
160 0           "";
161             }
162             sub _replaceEx {
163 0     0     my($tag, $code, $base, $opt, $temp)= @_;
164 0           my $escape= my $default= "";
165 0           my($exec, %attr);
166 0 0         if ($tag) {
167 0 0         $attr{key_name}= lc($1) if $tag=~/name=[\"\']?([^\s\"\']+)/;
168 0 0         $attr{hidden}= 1 if $tag=~/hidden=[\"\']?([^\s\"\']+)/;
169 0 0         $escape = qq{ escape="$1"} if $tag=~/escape=[\"\']?([^\s\"\']+)/;
170 0 0         $default= qq{ default="$1"} if $tag=~/default=[\"\']?([^\s\"\']+)/;
171             }
172 0           my $ident= '__$ex_'. &_get_ident_id($opt) .'$'. (++$temp->{count}). '$__';
173 0 0         $code= "no strict;\n". $code if $opt->{no_strict_exec};
174 0           eval"\$exec= sub { $code }"; ## no critic
175 0 0   0     $attr{function}= sub { $exec->(@_) || "" };
  0            
176 0           $opt->{_ex_orders}{$ident}= \%attr;
177 0           $opt->{_ex_mark}{$ident} = $ident;
178 0           qq{<tmpl_var name="$ident"$escape$default>};
179             }
180             sub _commit_to_cache {
181 0     0     my($self)= @_;
182 0           push @{$self->{parse_stack}}, $self->{options}{_ex_orders};
  0            
183 0           push @{$self->{parse_stack}}, $self->{options}{_ex_params};
  0            
184 0           push @{$self->{parse_stack}}, $self->{options}{_ex_mark};
  0            
185 0   0       push @{$self->{parse_stack}}, ($self->{_ex_charset} || "");
  0            
186 0           HTML::Template::_commit_to_cache(@_);
187             }
188             sub _get_ident_id {
189 0   0 0     $_[0]->{___ident_id} ||= substr(md5_hex(time(). {}. rand()), 0, 32);
190             }
191              
192             package HTML::Template::Ex::DummyObject;
193 2     2   12 use strict;
  2         5  
  2         128  
194 0     0     sub new { bless {}, shift }
195              
196             1;
197              
198             __END__
199              
200             =head1 NAME
201              
202             HTML::Template::Ex - The Perl code is operated in the template for HTML::Template.
203              
204             =head1 SYNOPSIS
205              
206             package MyProject;
207             use CGI;
208             use Jcode;
209             use HTML::Template::Ex;
210            
211             my $cgi = CGI->new;
212             my $self= bless { cgi=> cgi }, __PACKAGE__;
213            
214             my $template= <<END_OF_TEMPLATE;
215             <html>
216             <head><title><tmpl_var name="title"></title></head>
217             <body>
218             <tmpl_set name="title" value="HTML::Template::Ex">
219            
220             <h1><tmpl_var name="page_title"></h1>
221             <h2><tmpl_var name="title"></h2>
222            
223             <div style="margin:10; background:#DDD;">
224             <tmpl_ex>
225             my($self, $param)= @_;
226             $param->{page_title}= 'My Page Title';
227             return $self->{cgi}->param('name') || 'It doesn't receive it.';
228             </tmpl_ex>
229             </div>
230            
231             <div style="margin:10; background:#DDD;">
232             <tmpl_loop name="users">
233             <div>
234             <tmpl_var name="u_name" escape="html">
235             : <tmpl_var name="email" escape="html">
236             </div>
237             </tmpl_loop>
238             </div>
239            
240             <tmpl_ex name="users">
241             return [
242             { u_name=> 'foo', email=> 'foo@mydomain' },
243             { u_name=> 'boo', email=> 'boo@localdomain' },
244             ];
245             </tmpl_ex>
246            
247             <tmpl_var name="env_remote_addr">
248            
249             <body></html>
250             END_OF_TEMPLATE
251            
252             my $tmpl= HTML::Template::Ex->new($self, {
253             setup_env=> 1,
254             scalarref=> \$template,
255             encoder => sub { Jcode->new($_[0])->euc },
256             # ... other 'HTML::Template' options.
257             });
258            
259             print STDOUT $cgi->header, $tmpl->output;
260              
261             =head1 DESCRIPTION
262              
263             This module offers the function to evaluate the Perl code to the template that
264             HTML::Template uses.
265              
266             The character string enclosed with '<TMPL_EX> ... </TMPL_EX>' is evaluated as
267             Perl code.
268              
269             <tmpl_ex>
270             my($self, $param)= @_;
271             my $hoge= $self->to_method;
272             $param->{hoge}= $hoge;
273             return "";
274             </tmpl_ex>
275              
276             The object passed to the constructor is passed to the first argument to the
277             tmpl_ex tag.
278              
279             The second argument is HASH reference for the parameter that HTML::Template uses.
280              
281             When the ending value of each tmpl_ex block is returned, the value is buried
282             under the position.
283             Therefore, it is necessary to return the dead blank character to bury anything.
284              
285             When HTML::Template::Ex evaluates a little code, there is a little habit when a
286             complex thing is done though it is convenient.
287              
288             One is the priority level when two or more tmpl_ex blocks are described.
289              
290             There is no problem for one template.
291             It is sequentially evaluated on.
292             And, please pay attention to the point done earlier than HTML::Template evaluates
293             tag about this evaluation.
294              
295             The problem reads other templates from the template.
296             It is time when it exists also in the read template the tmpl_ex block.
297             HTML::Template::Ex is not intervened for the include of the template.
298             Therefore, after HTML::Template evaluates tag, the tmpl_ex block include ahead
299             will be evaluated. This sometimes causes confusion.
300              
301             <tmpl_include name="first.tmpl"> ... [3]
302             <tmpl_ex>
303             .... [ 1 ]
304             </tmpl_ex>
305             <tmpl_include name="middle.tmpl"> ... [4]
306             <tmpl_ex>
307             .... [ 2 ]
308             </tmpl_ex>
309             <tmpl_include name="end.tmpl"> ... [5]
310              
311             And, the error message is a very difficult secondarily thing.
312              
313             As for each tmpl_ex block, the code is individually evaluated with eval.
314             Therefore, it is not a translation processed while looking about the entire
315             template. Therefore, only the error where eval originates is obtained.
316             As for this, specific in the error generation part becomes very difficult.
317              
318             The thing of this problem solved only by HTML::Template::Ex is difficult.
319             Therefore, the improvement is not scheduled in the future.
320              
321             Using HTML::Template::Ex on the assumption of the thing to write a complex
322             code doesn't come recommended though it is regrettable.
323             Intuition is compelled every time the error occurs and debugging is compelled
324             to reliance. Perhaps, this will be annoyed by the stress.
325              
326             Still, I think that it can do the template that works more high-speed than
327             HTML::Mason and Template ToolKit if the code can be completed.
328             Please try and look at interesting one.
329              
330             Therefore, HTML::Template::Ex selects it by the rental server etc. of the
331             template driver. We will recommend the usage not to expect many of the template
332             driver in the situation in which the leg is limited.
333              
334              
335             And, '<TMPL_IF >' doesn't have the meaning because it is evaluated earlier than
336             HTML::Template though it is a thing misunderstood easily at the end.
337              
338             <tmpl_if name="hoge">
339             <tmpl_ex>
340             ....
341             </tmpl_ex>
342             <tmpl_exse>
343             <tmpl_ex>
344             ....
345             </tmpl_ex>
346             </tmpl_if>
347              
348             This is smoothly evaluated to diverge to both of the tmpl_ex block.
349             Please solve 'IF' related to tmpl_ex block in tmpl_ex block.
350              
351             <tmpl_ex>
352             my($self, $param)= @_;
353             if ($apram->{hoge}) {
354             ...
355             } else {
356             ...
357             }
358             "";
359             </tmpl_ex>
360              
361              
362             =head1 TAGS
363              
364             It is enhancing tag that introduces here added by using HTML::Template::Ex.
365             Please see the document of HTML::Template about standard tag of L<HTML::Template>.
366              
367             =head2 <TMPL_EX ... > [PERL_CODE] </TMPL_EX>
368              
369             The Perl code is evaluated in the template.
370              
371             Please see DESCRIPTION for details concerning basic operation.
372              
373             When the NAME attribute is given, the value that the tmpl_ex block returned to
374             the parameter of the name is substituted.
375             Please give the HIDDEN attribute at the same time to prevent the value being
376             buried under the position of the tmpl_ex block.
377              
378             <h1><tmpl_var name="hoge"></h1>
379            
380             <tmpl_ex name="hoge" hidden="1">
381             my($self)= @_;
382             ..... ban, bo, bon.
383             return $self->request->param('Fooo');
384             </tmpl_ex>
385              
386             The ESCAPE attribute can be used.
387              
388             <tmpl_ex escape="html">
389             ..... ban, bo, bon.
390             return "<font>Zooooo</font>";
391             </tmpl_ex>
392              
393             * After it is escaped of html, this is buried.
394              
395             =head2 <TMPL_SET NAME='...' VALUE='...'>
396              
397             The value is set in the parameter in the template.
398              
399             =head2 <tmpl_var name='env_*[ Environment variable name. ]'>
400              
401             When the setup_env option is given to the constructor, the environment variable
402             is set up.
403             It can be referred to by '<TMPL_VAR NAME=...>'. Please specify the environment
404             variable name putting up 'env_' to the head of the name.
405              
406             <tmpl_var name="env_remote_addr">
407             <tmpl_var name="env_path_info">
408              
409             =head1 METHODS
410              
411             =head2 new ([OBJECT], [OPTION])
412              
413             It is a constructor.
414              
415             An arbitrary object is given to the first argument.
416             The given object is passed as the first argument of each tmpl_ex block.
417              
418             [OPTION] is an option to pass to HTML::Template.
419             Please include the option of HTML::Template::Ex here.
420              
421             Options.
422              
423             =over 4
424              
425             =item * setup_env
426              
427             It is set up to refer to the environment variable.
428              
429             =item * exec_off
430              
431             All the tag that HTML::Template::Ex evaluates is invalidated and it puts it out.
432              
433             =item * no_strict_exec
434              
435             This is turned off though the code of the tmpl_ex block is evaluated under the strict
436             environment usually. For person who is not accustomed to making strict code.
437              
438             =item * encoder
439              
440             The CODE reference to process the character-code can be defined.
441              
442             =item * auto_encoder
443              
444             When charset was able to be acquired from the template, encoder is processed.
445              
446             =back
447              
448             =head2 charset
449              
450             When charset was able to be acquired from the template, the value is returned.
451              
452             =head2 initStyle ([STYLE])
453              
454             The output style etc. when the error occurs are defined.
455              
456             =head2 output
457              
458             Contents are output.
459              
460             =head2 other
461              
462             Please refer to the document of L<HTML::Template> for other methods.
463              
464             =head1 NOTES
465              
466             There is causing the defective operation according to the kind of the cash used
467             by HTML::Template option.
468              
469             * If it is 'cache' option to specify at mod_perl, it operates normally usually.
470              
471             =head1 SEE ALSO
472              
473             L<Egg::Release>,
474              
475             =head1 AUTHOR
476              
477             Masatoshi Mizuno E<lt>mizunoE<64>bomcity.comE<gt>
478              
479             =head1 COPYRIGHT
480              
481             Copyright (C) 2007 by Bee Flag, Corp. E<lt>L<http://egg.bomcity.com/>E<gt>, All Rights Reserved.
482              
483             This library is free software; you can redistribute it and/or modify
484             it under the same terms as Perl itself, either Perl version 5.8.6 or,
485             at your option, any later version of Perl 5 you may have available.
486              
487             =cut