File Coverage

blib/lib/HTML/Template.pm
Criterion Covered Total %
statement 1044 1259 82.9
branch 541 834 64.8
condition 178 295 60.3
subroutine 76 81 93.8
pod 5 13 38.4
total 1844 2482 74.2


line stmt bran cond sub pod time code
1             package HTML::Template;
2              
3             $HTML::Template::VERSION = '2.9_01';
4              
5             =head1 NAME
6              
7             HTML::Template - Perl module to use HTML Templates from CGI scripts
8              
9             =head1 SYNOPSIS
10              
11             First you make a template - this is just a normal HTML file with a few
12             extra tags, the simplest being
13              
14             For example, test.tmpl:
15              
16            
17             Test Template
18            
19             My Home Directory is
20            

21             My Path is set to
22            
23            
24              
25             Now create a small CGI program:
26              
27             #!/usr/bin/perl -w
28             use HTML::Template;
29              
30             # open the html template
31             my $template = HTML::Template->new(filename => 'test.tmpl');
32              
33             # fill in some parameters
34             $template->param(HOME => $ENV{HOME});
35             $template->param(PATH => $ENV{PATH});
36              
37             # send the obligatory Content-Type and print the template output
38             print "Content-Type: text/html\n\n", $template->output;
39              
40             If all is well in the universe this should show something like this in
41             your browser when visiting the CGI:
42              
43             My Home Directory is /home/some/directory
44             My Path is set to /bin;/usr/bin
45              
46             =head1 DESCRIPTION
47              
48             This module attempts to make using HTML templates simple and natural.
49             It extends standard HTML with a few new HTML-esque tags - ,
50             , , , , ,
51             and . It even allows you to sub-class
52             HTML::Template (or HTML::Template::Expr) so that you can then create
53             your own application specific tags, eg. , ,
54             .
55              
56             The file written with HTML and these new tags is called a template.
57             It is usually saved separate from your script - possibly even created
58             by someone else! Using this module you fill in the values for the
59             variables, loops and branches declared in the template. This allows
60             you to separate design - the HTML - from the data, which you generate
61             in the Perl script.
62              
63             This module is licensed under the GPL. See the LICENSE section
64             below for more details.
65              
66             =head1 TUTORIAL
67              
68             If you're new to HTML::Template, I suggest you start with the
69             introductory article available on the HTML::Template website:
70              
71             http://html-template.sourceforge.net
72              
73             =head1 MOTIVATION
74              
75             It is true that there are a number of packages out there to do HTML
76             templates. On the one hand you have things like HTML::Embperl which
77             allows you freely mix Perl with HTML. On the other hand lie
78             home-grown variable substitution solutions. Hopefully the module can
79             find a place between the two.
80              
81             One advantage of this module over a full HTML::Embperl-esque solution
82             is that it enforces an important divide - design and programming. By
83             limiting the programmer to just using simple variables and loops in
84             the HTML, the template remains accessible to designers and other
85             non-perl people. The use of HTML-esque syntax goes further to make
86             the format understandable to others. In the future this similarity
87             could be used to extend existing HTML editors/analyzers to support
88             HTML::Template.
89              
90             An advantage of this module over home-grown tag-replacement schemes is
91             the support for loops. In my work I am often called on to produce
92             tables of data in html. Producing them using simplistic HTML
93             templates results in CGIs containing lots of HTML since the HTML
94             itself cannot represent loops. The introduction of loop statements in
95             the HTML simplifies this situation considerably. The designer can
96             layout a single row and the programmer can fill it in as many times as
97             necessary - all they must agree on is the parameter names.
98              
99             For all that, I think the best thing about this module is that it does
100             just one thing and it does it quickly and carefully. It doesn't try
101             to replace Perl and HTML, it just augments them to interact a little
102             better. And it's pretty fast.
103              
104             =head1 THE TAGS
105              
106             =head2 TMPL_VAR
107              
108            
109              
110             The tag is very simple. For each tag in the
111             template you call $template->param(PARAMETER_NAME => "VALUE"). When
112             the template is output the is replaced with the VALUE text
113             you specified. If you don't set a parameter it just gets skipped in
114             the output.
115              
116             You can assign a default value to a variable with the DEFAULT attribute,
117             should the value of a template variable not have been set. For example,
118             this will output "the devil gave me a taco" if the "who" variable is
119             not set.
120              
121             The gave me a taco.
122              
123             You can use the "ESCAPE=xxx" option in the tag to indicate that you
124             want the value to be escaped before being returned from output.
125             Example:
126              
127             ">
128              
129             If the value within PARAM contained sam"my, you will get into trouble
130             with HTML's idea of double-quoting. To overcome this you can use the
131             form:
132              
133             ">
134              
135             which tells HTML::Template that you would like it to transform any
136             characters that HTML renderers would consider bad-form, into their
137             corresponding HTML equivalent-character entities.
138              
139             =over 4
140              
141             =item eg:
142              
143             & becomes &
144             " becomes "
145             ' becomes '
146             < becomes <
147             > becomes >
148              
149             =back
150              
151             Other variations of escaping are available, see L
152             for more information.
153              
154             =head2 TMPL_LOOP
155              
156             ...
157              
158             The tag is a bit more complicated than . The
159             tag allows you to delimit a section of text and give it a
160             name. Inside this named loop you place s. Now you pass to
161             C a list (an array ref) of parameter assignments (hash refs) for
162             this loop. The loop iterates over the list and produces output from
163             the text block for each pass. Unset parameters cause HTML::Template to
164             die (or are skipped). Here's an example:
165              
166             In the template:
167              
168            
169             Name:
170             Job:

171            
172              
173              
174             In the script:
175              
176             $template->param(EMPLOYEE_INFO => [
177             { name => 'Sam', job => 'programmer' },
178             { name => 'Steve', job => 'soda jerk' },
179             ]
180             );
181             print $template->output();
182              
183              
184             The output in a browser:
185              
186             Name: Sam
187             Job: programmer
188              
189             Name: Steve
190             Job: soda jerk
191              
192             As you can see above the takes a list of variable
193             assignments and then iterates over the loop body producing output.
194              
195             Often you'll want to generate a 's contents
196             programmatically. Here's an example of how this can be done (many
197             other ways are possible!):
198              
199             # a couple of arrays of data to put in a loop:
200             my @words = qw(I Am Cool);
201             my @numbers = qw(1 2 3);
202              
203             my @loop_data = (); # initialize an array to hold your loop
204              
205             while (@words and @numbers) {
206             my %row_data; # get a fresh hash for the row data
207              
208             # fill in this row
209             $row_data{WORD} = shift @words;
210             $row_data{NUMBER} = shift @numbers;
211              
212             # the crucial step - push a reference to this row into the loop!
213             push(@loop_data, \%row_data);
214             }
215              
216             # finally, assign the loop data to the loop param, again with a
217             # reference:
218             $template->param(THIS_LOOP => \@loop_data);
219              
220             The above example would work with a template like:
221              
222            
223             Word:
224             Number:

225            
226              
227             It would produce output like:
228              
229             Word: I
230             Number: 1
231              
232             Word: Am
233             Number: 2
234              
235             Word: Cool
236             Number: 3
237              
238             s within s are fine and work as you would
239             expect. If the syntax for the C call has you stumped, here's an
240             example of a param call with one nested loop:
241              
242             $template->param(LOOP => [
243             { name => 'Bobby',
244             nicknames => [
245             { name => 'the big bad wolf' },
246             { name => 'He-Man' },
247             ],
248             },
249             ],
250             );
251              
252             Basically, each gets an array reference. Inside the array
253             are any number of hash references. These hashes contain the
254             name=>value pairs for a single pass over the loop template.
255              
256             Inside a , the only variables that are usable are the ones
257             from the . The variables in the outer blocks are not
258             visible within a template loop. For the computer-science geeks among
259             you, a introduces a new scope much like a perl subroutine
260             call. If you want your variables to be global you can use
261             'global_vars' option to new() described below.
262              
263             =head2 TMPL_INCLUDE
264              
265            
266              
267             This tag includes a template directly into the current template at the
268             point where the tag is found. The included template contents are used
269             exactly as if its contents were physically included in the master
270             template.
271              
272             The file specified can be an absolute path (beginning with a '/' under
273             Unix, for example). If it isn't absolute, the path to the enclosing
274             file is tried first. After that the path in the environment variable
275             HTML_TEMPLATE_ROOT is tried, if it exists. Next, the "path" option is
276             consulted, first as-is and then with HTML_TEMPLATE_ROOT prepended if
277             available. As a final attempt, the filename is passed to open()
278             directly. See below for more information on HTML_TEMPLATE_ROOT and
279             the "path" option to new().
280              
281             As a protection against infinitly recursive includes, an arbitary
282             limit of 10 levels deep is imposed. You can alter this limit with the
283             "max_includes" option. See the entry for the "max_includes" option
284             below for more details.
285              
286             =head2 TMPL_REQUIRE
287              
288            
289              
290             Like , this tag imports another template into the current
291             scope. It differs in that it only does this once.
292              
293             =head2 TMPL_IF
294              
295             ...
296              
297             The tag allows you to include or not include a block of the
298             template based on the value of a given parameter name. If the
299             parameter is given a value that is true for Perl - like '1' - then the
300             block is included in the output. If it is not defined, or given a
301             false value - like '0' - then it is skipped. The parameters are
302             specified the same way as with TMPL_VAR.
303              
304             Example Template:
305              
306            
307             Some text that only gets displayed if BOOL is true!
308            
309              
310             Now if you call $template->param(BOOL => 1) then the above block will
311             be included by output.
312              
313             blocks can include any valid HTML::Template
314             construct - VARs and LOOPs and other IF/ELSE blocks. Note, however,
315             that intersecting a and a is invalid.
316              
317             Not going to work:
318            
319            
320            
321            
322              
323             If the name of a TMPL_LOOP is used in a TMPL_IF, the IF block will
324             output if the loop has at least one row. Example:
325              
326            
327             This will output if the loop is not empty.
328            
329              
330            
331             ....
332            
333              
334             WARNING: Much of the benefit of HTML::Template is in decoupling your
335             Perl and HTML. If you introduce numerous cases where you have
336             TMPL_IFs and matching Perl if()s, you will create a maintenance
337             problem in keeping the two synchronized. I suggest you adopt the
338             practice of only using TMPL_IF if you can do so without requiring a
339             matching if() in your Perl code.
340              
341             =head2 TMPL_ELSE
342              
343             ... ...
344              
345             You can include an alternate block in your TMPL_IF block by using
346             TMPL_ELSE. NOTE: You still end the block with , not
347             !
348              
349             Example:
350              
351            
352             Some text that is included only if BOOL is true
353            
354             Some text that is included only if BOOL is false
355            
356              
357             =head2 TMPL_ELSIF
358              
359            
360             ...
361            
362             ...
363            
364             ...
365            
366              
367             Allows inclusion of alternative test cases, within your IF block.
368              
369             Example:
370              
371            
372             Some text that is included only if BOOL is true
373            
374             Some text that is included if BOOL is FALSE
375             and SOME_VAR is true
376            
377             Some other text if SOME_OTHER_VAR is true
378            
379             Some text that is included if only all the
380             previous values were false
381            
382              
383             Note: note this has the same performance impact as nesting multiple
384             blocks.
385              
386             =head2 TMPL_UNLESS
387              
388             ...
389              
390             This tag is the opposite of . The block is output if the
391             CONTROL_PARAMETER is set false or not defined. You can use
392             with just as you can with .
393              
394             Example:
395              
396            
397             Some text that is output only if BOOL is FALSE.
398            
399             Some text that is output only if BOOL is TRUE.
400            
401              
402             If the name of a TMPL_LOOP is used in a TMPL_UNLESS, the UNLESS block
403             output if the loop has zero rows.
404              
405            
406             This will output if the loop is empty.
407            
408              
409            
410             ....
411            
412              
413             =cut
414              
415             =head2 NOTES
416              
417             HTML::Template's tags are meant to mimic normal HTML tags. However,
418             they are allowed to "break the rules". Something like:
419              
420            
421              
422             is not really valid HTML, but it is a perfectly valid use and will
423             work as planned.
424              
425             The "NAME=" in the tag is optional, although for extensibility's sake I
426             recommend using it. Example - "" is acceptable.
427              
428             If you're a fanatic about valid HTML and would like your templates
429             to conform to valid HTML syntax, you may optionally type template tags
430             in the form of HTML comments. This may be of use to HTML authors who
431             would like to validate their templates' HTML syntax prior to
432             HTML::Template processing, or who use DTD-savvy editing tools.
433              
434            
435              
436             In order to realize a dramatic savings in bandwidth, the standard
437             (non-comment) tags will be used throughout this documentation.
438              
439             =cut
440              
441             =head1 CUSTOM TAGS
442              
443             HTML::Template can be sub-classed so that you can create custom tags.
444             There are various reasons for wanting the ability to do this.
445              
446             For example, your application may need to be displayed in multiple
447             languages. Normal HTML would require you to localise each template.
448             By sub-classing HTML::Template you can create a TMPL_CATGETS tag and thus
449             dynamically lookup the localised version of the remaining part of the tag,
450             as in:
451              
452             in the English locale would translate to
453             'Number one', while in the Italian locale it could translate to
454             'Numero uno'.
455              
456             Another example, implementing a 'switch' statement; you would sub-class
457             HTML::Template (or HTML::Template::Expr for that matter), and implement
458             the tags in a manner something like:
459              
460            
461            
462            
463            
464            
465              
466             See L for more information.
467              
468             =cut
469              
470             =head1 METHODS
471              
472             =head2 new()
473              
474             Call new() to create a new Template object:
475              
476             my $template = HTML::Template->new( filename => 'file.tmpl',
477             option => 'value'
478             );
479              
480             You must call new() with at least one name => value pair specifying how
481             to access the template text. You can use C<< filename => 'file.tmpl' >>
482             to specify a filename to be opened as the template. Alternately you can
483             use:
484              
485             my $t = HTML::Template->new( scalarref => $ref_to_template_text,
486             option => 'value'
487             );
488              
489             and
490              
491             my $t = HTML::Template->new( arrayref => $ref_to_array_of_lines ,
492             option => 'value'
493             );
494              
495              
496             These initialize the template from in-memory resources. In almost
497             every case you'll want to use the filename parameter. If you're
498             worried about all the disk access from reading a template file just
499             use mod_perl and the cache option detailed below.
500              
501             You can also read the template from an already opened filehandle,
502             either traditionally as a glob or as a FileHandle:
503              
504             my $t = HTML::Template->new( filehandle => *FH, option => 'value');
505              
506             The four new() calling methods can also be accessed as below, if you
507             prefer.
508              
509             my $t = HTML::Template->new_file('file.tmpl', option => 'value');
510              
511             my $t = HTML::Template->new_scalar_ref($ref_to_template_text,
512             option => 'value');
513              
514             my $t = HTML::Template->new_array_ref($ref_to_array_of_lines,
515             option => 'value');
516              
517             my $t = HTML::Template->new_filehandle($fh,
518             option => 'value');
519              
520             And as a final option, for those that might prefer it, you can call new as:
521              
522             my $t = HTML::Template->new(type => 'filename',
523             source => 'file.tmpl');
524              
525             Which works for all three of the source types.
526              
527             If the environment variable HTML_TEMPLATE_ROOT is set and your
528             filename doesn't begin with /, then the path will be relative to the
529             value of $HTML_TEMPLATE_ROOT. Example - if the environment variable
530             HTML_TEMPLATE_ROOT is set to "/home/sam" and I call
531             HTML::Template->new() with filename set to "sam.tmpl", the
532             HTML::Template will try to open "/home/sam/sam.tmpl" to access the
533             template file. You can also affect the search path for files with the
534             "path" option to new() - see below for more information.
535              
536             You can modify the Template object's behavior with new(). The options
537             are available:
538              
539             =over 4
540              
541             =item Error Detection Options
542              
543             =over 4
544              
545             =item *
546              
547             die_on_bad_params - if set to 0 the module will let you call
548             $template->param(param_name => 'value') even if 'param_name' doesn't
549             exist in the template body. Defaults to 1.
550              
551             =item *
552              
553             die_on_unset_params - if set to 1 the module will allow you to not set
554             a value for 'param_name' when the template contains something like
555             . The default (C)
556             behaviour is that HTML::Template wont die when output() is called for
557             cases where you haven't called Cparam(param_name => 'value')>.
558              
559             If you set C, HTML::Template will defer the
560             die until it has completed generating the output, then die with a list
561             of unset params.
562              
563             =item *
564              
565             force_untaint - if set to 1 the module will not allow you to set
566             unescaped parameters with tainted values. If set to 2 you will have
567             to untaint all parameters, including ones with the escape attribute.
568             This option makes sure you untaint everything so you don't accidentally
569             introduce e.g. cross-site-scripting (CSS) vulnerabilities. Requires
570             taint mode. Defaults to 0.
571              
572             =item *
573              
574             strict - if set to 0 the module will allow things that look like they
575             might be TMPL_* tags to get by without dieing. Example:
576              
577            
578              
579             Would normally cause an error, but if you call new with strict => 0,
580             HTML::Template will ignore it. Defaults to 1.
581              
582             =item *
583              
584             vanguard_compatibility_mode - removed (use a filter to enable this
585             option).
586              
587              
588             =back
589              
590             =item Caching Options
591              
592             =over 4
593              
594             =item *
595              
596             cache - if set to 1 the module will cache in memory the parsed
597             templates based on the filename parameter and modification date of the
598             file. This only applies to templates opened with the filename
599             parameter specified, not scalarref or arrayref templates. Caching
600             also looks at the modification times of any files included using
601             tags, but again, only if the template is opened with
602             filename parameter.
603              
604             This is mainly of use in a persistent environment like
605             Apache/mod_perl. It has absolutely no benefit in a normal CGI
606             environment since the script is unloaded from memory after every
607             request. For a cache that does work for normal CGIs see the
608             'shared_cache' option below.
609              
610             Note that different new() parameter settings do not cause a cache
611             refresh, only a change in the modification time of the template will
612             trigger a cache refresh. For most usages this is fine. My simplistic
613             testing shows that using cache yields a 90% performance increase under
614             mod_perl. Cache defaults to 0.
615              
616             =item *
617              
618             shared_cache - if set to 1 the module will store its cache in shared
619             memory using the IPC::SharedCache module (available from CPAN). The
620             effect of this will be to maintain a single shared copy of each parsed
621             template for all instances of HTML::Template to use. This can be a
622             significant reduction in memory usage in a multiple server
623             environment. As an example, on one of our systems we use 4MB of
624             template cache and maintain 25 httpd processes - shared_cache results
625             in saving almost 100MB! Of course, some reduction in speed versus
626             normal caching is to be expected. Another difference between normal
627             caching and shared_cache is that shared_cache will work in a CGI
628             environment - normal caching is only useful in a persistent
629             environment like Apache/mod_perl.
630              
631             By default HTML::Template uses the IPC key 'TMPL' as a shared root
632             segment (0x4c504d54 in hex), but this can be changed by setting the
633             'ipc_key' new() parameter to another 4-character or integer key.
634             Other options can be used to affect the shared memory cache correspond
635             to IPC::SharedCache options - ipc_mode, ipc_segment_size and
636             ipc_max_size. See L for a description of how these
637             work - in most cases you shouldn't need to change them from the
638             defaults.
639              
640             For more information about the shared memory cache system used by
641             HTML::Template see L.
642              
643             =item *
644              
645             double_cache - if set to 1 the module will use a combination of
646             shared_cache and normal cache mode for the best possible caching. Of
647             course, it also uses the most memory of all the cache modes. All the
648             same ipc_* options that work with shared_cache apply to double_cache
649             as well. By default double_cache is off.
650              
651             =item *
652              
653             blind_cache - if set to 1 the module behaves exactly as with normal
654             caching but does not check to see if the file has changed on each
655             request. This option should be used with caution, but could be of use
656             on high-load servers. My tests show blind_cache performing only 1 to
657             2 percent faster than cache under mod_perl.
658              
659             NOTE: Combining this option with shared_cache can result in stale
660             templates stuck permanently in shared memory!
661              
662             =item *
663              
664             file_cache - if set to 1 the module will store its cache in a file
665             using the Storable module. It uses no additional memory, and my
666             simplistic testing shows that it yields a 50% performance advantage.
667             Like shared_cache, it will work in a CGI environment. Default is 0.
668              
669             If you set this option you must set the "file_cache_dir" option. See
670             below for details.
671              
672             NOTE: Storable using flock() to ensure safe access to cache files.
673             Using file_cache on a system or filesystem (NFS) without flock()
674             support is dangerous.
675              
676              
677             =item *
678              
679             file_cache_dir - sets the directory where the module will store the
680             cache files if file_cache is enabled. Your script will need write
681             permissions to this directory. You'll also need to make sure the
682             sufficient space is available to store the cache files.
683              
684             =item *
685              
686             file_cache_dir_mode - sets the file mode for newly created file_cache
687             directories and subdirectories. Defaults to 0700 for security but
688             this may be inconvenient if you do not have access to the account
689             running the webserver.
690              
691             =item *
692              
693             double_file_cache - if set to 1 the module will use a combination of
694             file_cache and normal cache mode for the best possible caching. The
695             file_cache_* options that work with file_cache apply to double_file_cache
696             as well. By default double_file_cache is 0.
697              
698             =back
699              
700             =item Filesystem Options
701              
702             =over 4
703              
704             =item *
705              
706             path - you can set this variable with a list of paths to search for
707             files specified with the "filename" option to new() and for files
708             included with the tag. This list is only consulted
709             when the filename is relative. The HTML_TEMPLATE_ROOT environment
710             variable is always tried first if it exists. Also, if
711             HTML_TEMPLATE_ROOT is set then an attempt will be made to prepend
712             HTML_TEMPLATE_ROOT onto paths in the path array. In the case of a
713             file, the path to the including file is also tried
714             before path is consulted.
715              
716             Example:
717              
718             my $template = HTML::Template->new( filename => 'file.tmpl',
719             path => [ '/path/to/templates',
720             '/alternate/path'
721             ]
722             );
723              
724             NOTE: the paths in the path list must be expressed as UNIX paths,
725             separated by the forward-slash character ('/').
726              
727             =item *
728              
729             search_path_on_include - if set to a true value the module will search
730             from the top of the array of paths specified by the path option on
731             every and use the first matching template found. The
732             normal behavior is to look only in the current directory for a
733             template to include. Defaults to 0.
734              
735             =back
736              
737             =item Debugging Options
738              
739             =over 4
740              
741             =item *
742              
743             debug - if set to 1 the module will write random debugging information
744             to STDERR. Defaults to 0.
745              
746             =item *
747              
748             stack_debug - if set to 1 the module will use Data::Dumper to print
749             out the contents of the parse_stack to STDERR. Defaults to 0.
750              
751             =item *
752              
753             cache_debug - if set to 1 the module will send information on cache
754             loads, hits and misses to STDERR. Defaults to 0.
755              
756             =item *
757              
758             shared_cache_debug - if set to 1 the module will turn on the debug
759             option in IPC::SharedCache - see L for
760             details. Defaults to 0.
761              
762             =item *
763              
764             memory_debug - if set to 1 the module will send information on cache
765             memory usage to STDERR. Requires the GTop module. Defaults to 0.
766              
767             =item *
768              
769             includes_debug - if set to 1 the module will print TMPL_INCLUDEed
770             file-stack information, to STDERR. Defaults to 0.
771              
772             =item *
773              
774             param_debug - if set to 1 the module will list the params and values
775             as various stages of processing. Default to 0.
776              
777             =back
778              
779             =item Profiling Options
780              
781             =over 4
782              
783             =item *
784              
785             profile - if set to 1 the module will write timing information
786             to STDERR. Defaults to 0.
787              
788             =back
789              
790             =item Miscellaneous Options
791              
792             =over 4
793              
794             =item *
795              
796             associate - this option allows you to inherit the parameter values
797             from other objects. The only requirement for the other object is that
798             it have a C method that works like HTML::Template's C. A
799             good candidate would be a CGI.pm query object. Example:
800              
801             my $query = new CGI;
802             my $template = HTML::Template->new(filename => 'template.tmpl',
803             associate => $query);
804              
805             Now, C<< $template->output() >> will act as though
806              
807             $template->param('FormField', $cgi->param('FormField'));
808              
809             had been specified for each key/value pair that would be provided by
810             the C<< $cgi->param() >> method. Parameters you set directly take
811             precedence over associated parameters.
812              
813             You can specify multiple objects to associate by passing an anonymous
814             array to the associate option. They are searched for parameters in
815             the order they appear:
816              
817             my $template = HTML::Template->new(filename => 'template.tmpl',
818             associate => [$query, $other_obj]);
819              
820             The old associateCGI() call is still supported, but should be
821             considered obsolete.
822              
823             NOTE: The parameter names are matched in a case-insensitve manner. If
824             you have two parameters in a CGI object like 'NAME' and 'Name' one
825             will be chosen randomly by associate. This behavior can be changed by
826             the following option.
827              
828             =item *
829              
830             case_sensitive - setting this option to true causes HTML::Template to
831             treat template variable names case-sensitively. The following example
832             would only set one parameter without the "case_sensitive" option:
833              
834             my $template = HTML::Template->new(filename => 'template.tmpl',
835             case_sensitive => 1);
836             $template->param(
837             FieldA => 'foo',
838             fIELDa => 'bar',
839             );
840              
841             This option defaults to off.
842              
843             NOTE: with case_sensitive and loop_context_vars the special loop
844             variables are available in lower-case only.
845              
846             =item *
847              
848             loop_context_vars - when this parameter is set to true (it is false by
849             default) four loop context variables are made available inside a loop:
850             __first__, __last__, __outer__,__inner__, __odd__, __even__. They can
851             be used with , , and to
852             control how a loop is output.
853              
854             In addition to the above, a __counter__ var is also made available
855             when loop context variables are turned on.
856              
857             Example:
858              
859            
860            
861             This only outputs on the first pass.
862            
863              
864            
865             This outputs every other pass, on the odd passes.
866            
867              
868            
869             This outputs every other pass, on the even passes.
870            
871              
872            
873             This outputs every other pass, on the even passes.
874            
875              
876            
877             This outputs every other pass, on the odd passes.
878            
879              
880            
881             This outputs on passes that are both first or last.
882            
883              
884            
885             This outputs on passes that are neither first nor last.
886            
887              
888             This is pass number .
889              
890            
891             This only outputs on the last pass.
892            
893            
894              
895             One use of this feature is to provide a "separator" similar in effect
896             to the perl function join(). Example:
897              
898            
899             and
900             , .
901            
902              
903             Would output (in a browser) something like:
904              
905             Apples, Oranges, Brains, Toes, and Kiwi.
906              
907             Given an appropriate C call, of course. NOTE: A loop with only
908             a single pass will get __outer__, __first__ and __last__ set to true, but
909             not __inner__.
910              
911             =item *
912              
913             scalar_loops - when enabled, simply Perl arrays can be used in TMPL_LOOP's
914             such that the attibute name is '__value__'.
915              
916             =item *
917              
918             intrinsic_vars - Enable this to automatically generate template intrinsic
919             variables; current variables:
920              
921             __type__ will be one of 'file','scalarref','arrayref','filehandle'
922             __filename__ the filename you specified, if any
923             __filepath__ as above but using a fully qualified path
924              
925             =item *
926              
927             no_includes - set this option to 1 to disallow the tag
928             in the template file. This can be used to make opening untrusted
929             templates B less dangerous. Defaults to 0.
930              
931             =item *
932              
933             max_includes - set this variable to determine the maximum depth that
934             includes can reach. Set to 10 by default. Including files to a depth
935             greater than this value causes an error message to be displayed. Set
936             to 0 to disable this protection.
937              
938             =item *
939              
940             global_vars - normally variables declared outside a loop are not
941             available inside a loop. This option makes s like global
942             variables in Perl - they have unlimited scope. This option also
943             affects and .
944              
945             Example:
946              
947             This is a normal variable: .

948              
949            
950             Here it is inside the loop:

951            
952              
953             Normally this wouldn't work as expected, since 's
954             value outside the loop is not available inside the loop.
955              
956             The global_vars option also allows you to access the values of an
957             enclosing loop within an inner loop. For example, in this loop the
958             inner loop will have access to the value of OUTER_VAR in the correct
959             iteration:
960              
961            
962             OUTER:
963            
964             INNER:
965             INSIDE OUT:
966            
967            
968              
969             One side-effect of global-vars is that variables you set with param()
970             that might otherwise be ignored when die_on_bad_params is off will
971             stick around. This is necessary to allow inner loops to access values
972             set for outer loops that don't directly use the value.
973              
974             B: C is not C (which does not exist).
975             That means that loops you declare at one scope are not available
976             inside other loops even when C is on.
977              
978             =item *
979              
980             filter - this option allows you to specify a filter for your template
981             files. A filter is a subroutine that will be called after
982             HTML::Template reads your template file but before it starts parsing
983             template tags.
984              
985             In the most simple usage, you simply assign a code reference to the
986             filter parameter. This subroutine will recieve as the first argument,
987             a reference to a string containing the template file text. The second
988             argument is a reference to the HTML::Template instance, which you can
989             use to query its current state.
990              
991             Here is an example that accepts templates with tags that look like
992             "!!!ZAP_VAR FOO!!!" and transforms them into HTML::Template tags:
993              
994             my $filter = sub {
995             my $text_ref = shift;
996             $$text_ref =~ s/!!!ZAP_(.*?)!!!//g;
997             };
998              
999             # open zap.tmpl using the above filter
1000             my $template = HTML::Template->new(filename => 'zap.tmpl',
1001             filter => $filter);
1002              
1003             More complicated usages are possible. You can request that your
1004             filter receieve the template text as an array of lines rather than as
1005             a single scalar. To do that you need to specify your filter using a
1006             hash-ref. In this form you specify the filter using the C key and
1007             the desired argument format using the C key. The available
1008             formats are C and C. Using the C format will incur
1009             a performance penalty but may be more convenient in some situations.
1010              
1011             my $template = HTML::Template->new(filename => 'zap.tmpl',
1012             filter => { sub => $filter,
1013             format => 'array' });
1014              
1015             You may also have multiple filters. This allows simple filters to be
1016             combined for more elaborate functionality. To do this you specify an
1017             array of filters. The filters are applied in the order they are
1018             specified.
1019              
1020             my $template = HTML::Template->new(filename => 'zap.tmpl',
1021             filter => [
1022             { sub => \&decompress,
1023             format => 'scalar' },
1024             { sub => \&remove_spaces,
1025             format => 'array' }
1026             ]);
1027              
1028             The specified filters will be called for any TMPL_INCLUDEed files just
1029             as they are for the main template file.
1030              
1031             A set of pre-made filters are available from the L
1032             module.
1033              
1034             =item *
1035              
1036             default_escape - Set this parameter with the name of one of the
1037             L modules. HTML::Template will apply
1038             the specified escaping to all variables unless they declare a
1039             different escape in the template.
1040              
1041             =item *
1042              
1043             structure_vars - Set this variable to make HTML::Template support a
1044             variable syntax similar to C-style structures. We use dot notation as
1045             the delimiter between template variables. This is easiest explained
1046             by example, say setting the properties of a 'user' object.
1047              
1048             Say we have a user's first name, last name, their address and the address
1049             of the company they work for - the template variable that you would define
1050             would be:
1051              
1052             user.name.first => 'Fred',
1053             user.name.last => 'Flinstone',
1054             user.address => 'Bedrock',
1055             user.company.name => 'Slate Construction',
1056              
1057             Ordinarily, HTML::Template would treat these as simple (unique) variable
1058             names. With 'structure_vars' set, HTML::Template automatically sets:
1059              
1060             user => 1
1061             user.name => 1
1062             user.company => 1
1063              
1064             unless the programmer has already set those variables; at any time they
1065             can be overridden with specific values.
1066              
1067             The reason for this functionality is to simplify template handling of
1068             object-like data. For example, in the template you could now write:
1069              
1070            
1071            
1072            
1073            
1074            
1075            
1076            
1077              
1078             Note that the auto-vivified template variables, cannot be use in TMPL_LOOP
1079             context, ie. they can be use in TMPL_IF/TMPL_VAR context.
1080              
1081             =item *
1082              
1083             extended_syntax - Set this variable is to make HTML::Template defer handling
1084             of unknown tags, to the sub-class. Note that this option is only useful
1085             when used as part of a sub-class, since if HTML::Template is not sub-classed,
1086             the option has no effect.
1087              
1088             See L for more information.
1089              
1090             =item *
1091              
1092             recursive_templates - set this variable to a non-zero value to allow
1093             template syntax to be embedded within other template syntax. Set it
1094             to a value > 0 to try recursing up to 'at most' that value. A value of
1095             -1 results in maximum depth recursion (which is limited to, at most, 10
1096             recursions). This feature can be abused in so many ways...
1097              
1098             This feature comes at a performance penalty, since memory caching is not
1099             applied due the variabliliy in the number of template instantiations.
1100             However, file_cache is still supported.
1101              
1102             Thus this option allows the syntax:
1103              
1104             >
1105             or
1106             >>
1107             etc.
1108              
1109             Note that use of the 'print_to' output-option, cannot currently be used
1110             in conjunction with this option.
1111              
1112             =back
1113              
1114             =back 4
1115              
1116             =cut
1117              
1118              
1119 46     46   779217 use integer; # no floating point math so far!
  46         517  
  46         396  
1120 46     46   1456 use strict; # and no funny business, either.
  46         139  
  46         2179  
1121 46     46   259 use warnings FATAL => 'all';
  46         97  
  46         2182  
1122 46     46   54028 use utf8;
  46         362  
  46         376  
1123              
1124 46     46   1526 use Carp; # generate better errors with more context
  46         86  
  46         4855  
1125 46     46   269 use File::Spec; # generate paths that work on all platforms
  46         105  
  46         2158  
1126 46     46   259 use Digest::MD5 qw(md5_hex); # generate cache keys
  46         127  
  46         2827  
1127 46     46   265 use Scalar::Util qw(tainted);
  46         90  
  46         6028  
1128 46     46   48492 use Time::HiRes qw(gettimeofday tv_interval); # generates sub-second timing info
  46         106335  
  46         238  
1129              
1130             # define accessor constants used to improve readability of array
1131             # accesses into "objects". I used to use 'use constant' but that
1132             # seems to cause occasional irritating warnings in older Perls.
1133             package HTML::Template::LOOP;
1134             sub TEMPLATE_HASH () { 0 };
1135             sub PARAM_SET () { 1 };
1136              
1137             package HTML::Template::COND;
1138             sub VARIABLE () { 0 };
1139             sub VARIABLE_TYPE () { 1 };
1140             sub VARIABLE_TYPE_VAR () { 0 };
1141             sub VARIABLE_TYPE_LOOP () { 1 };
1142             sub JUMP_IF_TRUE () { 2 };
1143             sub JUMP_ADDRESS () { 3 };
1144             sub WHICH () { 4 };
1145             sub UNCONDITIONAL_JUMP () { 5 };
1146             sub IS_ELSE () { 6 };
1147             sub WHICH_IF () { 0 };
1148             sub WHICH_UNLESS () { 1 };
1149              
1150             # back to the main package scope.
1151             package HTML::Template;
1152              
1153             # Want to use Scalar::Util::reftype as a replacement for ref(), but the interface differs... WTF?
1154             # So reproduced here....
1155             sub reftype ($) {
1156 2113     2113 0 11750 local($@, $SIG{__DIE__}, $SIG{__WARN__});
1157 2113         3364 my $r = shift;
1158 2113         3794 my $t = ref($r);
1159              
1160 2113 100       9413 length($t = ref($r)) or return '';
1161              
1162             # This eval will fail if the reference is not blessed
1163 1071         10387 $t = eval { $r->a_sub_not_likely_to_be_here; 1 }
  0         0  
1164 1071 50       1868 ? do {
1165             $t = eval {
1166             # we have a GLOB or an IO. Stringify a GLOB gives it's name
1167 0         0 my $q = *$r;
1168 0 0       0 $q =~ /^\*/ ? "GLOB" : "IO";
1169             }
1170 0 0       0 or do {
1171             # OK, if we don't have a GLOB what parts of
1172             # a glob will it populate.
1173             # NOTE: A glob always has a SCALAR
1174 0         0 local *glob = $r;
1175 0         0 defined *glob{ARRAY} && "ARRAY"
1176             or defined *glob{HASH} && "HASH"
1177             or defined *glob{CODE} && "CODE"
1178 0 0 0     0 or length(ref(${$r})) ? "REF" : "SCALAR";
    0 0        
      0        
      0        
      0        
1179             }
1180             }
1181             : $t;
1182 1071 50       3775 $t = '' unless $t;
1183 1071         7429 $t;
1184             }
1185              
1186             # open a new template and return an object handle
1187             sub new {
1188 240     240 1 1242371 my $pkg = shift;
1189 240         386 my $self; { my %hash; $self = bless(\%hash, $pkg); }
  240         7042  
  240         354  
  240         1208  
1190              
1191             # the options hash
1192 240         559 my $options = {};
1193 240         759 $self->{options} = $options;
1194              
1195             # set default parameters in options hash
1196 240         6991 %$options = (
1197             debug => 0,
1198             stack_debug => 0,
1199             param_debug => 0,
1200             profile => 0,
1201             search_path_on_include => 0,
1202             cache => 0,
1203             blind_cache => 0,
1204             file_cache => 0,
1205             file_cache_dir => '',
1206             file_cache_dir_mode => 0700,
1207             force_untaint => 0,
1208             cache_debug => 0,
1209             shared_cache_debug => 0,
1210             memory_debug => 0,
1211             includes_debug => 0,
1212             die_on_bad_params => 1,
1213             die_on_unset_params => 0,
1214             associate => [],
1215             path => [],
1216             strict => 1,
1217             loop_context_vars => 0,
1218             scalar_loops => 0,
1219             intrinsic_vars => 0,
1220             max_includes => 10,
1221             shared_cache => 0,
1222             double_cache => 0,
1223             double_file_cache => 0,
1224             ipc_key => 'TMPL',
1225             ipc_mode => 0666,
1226             ipc_segment_size => 65536,
1227             ipc_max_size => 0,
1228             global_vars => 0,
1229             no_includes => 0,
1230             case_sensitive => 0,
1231             filter => [],
1232             structure_vars => 0,
1233             extended_syntax => 0,
1234             recursive_templates => 0,
1235             default_escape => undef,
1236             );
1237              
1238             # load in options supplied to new()
1239 240         2036 $options = _load_supplied_options( [@_], $options);
1240              
1241             # blind_cache = 1 implies cache = 1
1242 236 100       1835 $options->{blind_cache} and $options->{cache} = 1;
1243              
1244             # shared_cache = 1 implies cache = 1
1245 236 50       657 $options->{shared_cache} and $options->{cache} = 1;
1246              
1247             # file_cache = 1 implies cache = 1
1248 236 100       577 $options->{file_cache} and $options->{cache} = 1;
1249              
1250             # double_cache is a combination of shared_cache and cache.
1251 236 100       782 $options->{double_cache} and $options->{cache} = 1;
1252 236 100       734 $options->{double_cache} and $options->{shared_cache} = 1;
1253              
1254             # double_file_cache is a combination of file_cache and cache.
1255 236 100       576 $options->{double_file_cache} and $options->{cache} = 1;
1256 236 100       19621 $options->{double_file_cache} and $options->{file_cache} = 1;
1257              
1258             # handle the "type", "source" parameter format (does anyone use it?)
1259 236 100       813 if (exists($options->{type})) {
1260 10 100       127 exists($options->{source}) or croak("HTML::Template->new() called with 'type' parameter set, but no 'source'!");
1261 9 100 100     188 ($options->{type} eq 'filename' or $options->{type} eq 'scalarref' or
      100        
      100        
1262             $options->{type} eq 'arrayref' or $options->{type} eq 'filehandle') or
1263             croak("HTML::Template->new() : type parameter must be set to 'filename', 'arrayref', 'scalarref' or 'filehandle'!");
1264              
1265 8         21 $options->{$options->{type}} = $options->{source};
1266 8         15 delete $options->{type};
1267 8         14 delete $options->{source};
1268             }
1269              
1270             # make sure taint mode is on if force_untaint flag is set
1271 234 100 100     832 if ($options->{force_untaint} && ! ${^TAINT}) {
1272 1         295 croak("HTML::Template->new() : 'force_untaint' option set but perl does not run in taint mode!");
1273             }
1274              
1275             # associate should be an array of one element if it's not
1276             # already an array.
1277 233 100       2044 if (reftype($options->{associate}) ne 'ARRAY') {
1278 3         10 $options->{associate} = [ $options->{associate} ];
1279             }
1280              
1281             # path should be an array if it's not already
1282 233 100       692 if (reftype($options->{path}) ne 'ARRAY') {
1283 39         140 $options->{path} = [ $options->{path} ];
1284             }
1285              
1286             # filter should be an array if it's not already
1287 233 100       637 if (reftype($options->{filter}) ne 'ARRAY') {
1288 6         19 $options->{filter} = [ $options->{filter} ];
1289             }
1290              
1291             # make sure objects in associate area support param()
1292 233         470 foreach my $object (@{$options->{associate}}) {
  233         950  
1293 4 100       179 defined($object->can('param')) or
1294             croak("HTML::Template->new called with associate option, containing object of type " . ref($object) . " which lacks a param() method!");
1295             }
1296              
1297             # make sure we limit the number of recursions to an upper limit
1298 232 50       1261 if ($options->{recursive_templates} < 0) {
    50          
1299 0         0 $options->{recursive_templates} = 10;
1300             } elsif ($options->{recursive_templates} > 100) {
1301 0         0 $options->{recursive_templates} = 100;
1302             }
1303 232 100       993 if ($options->{recursive_templates}) {
1304 1         4 $options->{strict} = 0;
1305 1         2 $self->{recursive_template_params} = {};
1306             }
1307              
1308             # structure-vars requires the use of a temporary param cache
1309 232 100       593 if ($options->{structure_vars}){
1310 1         3 $self->{structure_vars} = {};
1311             }
1312              
1313             # check for syntax errors:
1314 232         337 my $source_count = 0;
1315 232 100       826 exists($options->{filename}) and $source_count++;
1316 232 100       610 exists($options->{filehandle}) and $source_count++;
1317 232 100       901 exists($options->{arrayref}) and $source_count++;
1318 232 100       625 exists($options->{scalarref}) and $source_count++;
1319 232 100       1229 if ($source_count != 1) {
1320 1         189 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");
1321             }
1322              
1323             # check that cache options are not used with non-cacheable templates
1324 693         2947 croak "Cannot have caching when template source is not file"
1325 864         11022 if grep { exists($options->{$_}) } qw( filehandle arrayref scalarref)
1326             and
1327 231 100 100     430 grep {$options->{$_}} qw( cache blind_cache file_cache shared_cache
1328             double_cache double_file_cache );
1329              
1330             # check that filenames aren't empty
1331 228 100       699 if (exists($options->{filename})) {
1332 87 100 66     1032 croak("HTML::Template->new called with empty filename parameter!")
1333             unless defined $options->{filename} and length $options->{filename};
1334             }
1335              
1336             # do some memory debugging - this is best started as early as possible
1337 227 50       726 if ($options->{memory_debug}) {
1338             # memory_debug needs GTop
1339 0         0 eval { require GTop; };
  0         0  
1340 0 0       0 croak("Could not load GTop. You must have GTop installed to use HTML::Template in memory_debug mode. The error was: $@")
1341             if ($@);
1342 0         0 $self->{gtop} = GTop->new();
1343 0         0 $self->{proc_mem} = $self->{gtop}->proc_mem($$);
1344 0         0 print STDERR "\n### HTML::Template Memory Debug ### START ", $self->{proc_mem}->size(), "\n";
1345             }
1346              
1347 227 100       643 if ($options->{file_cache}) {
1348             # make sure we have a file_cache_dir option
1349 11 100 66     394 croak("You must specify the file_cache_dir option if you want to use file_cache.")
1350             unless defined $options->{file_cache_dir} and length $options->{file_cache_dir};
1351              
1352              
1353             # file_cache needs some extra modules loaded
1354 10         19 eval { require Storable; };
  10         5484  
1355 10 50       24385 croak("Could not load Storable. You must have Storable installed to use HTML::Template in file_cache mode. The error was: $@")
1356             if ($@);
1357             }
1358              
1359 226 50       785 if ($options->{shared_cache}) {
1360             # shared_cache needs some extra modules loaded
1361 0         0 eval { require IPC::SharedCache; };
  0         0  
1362 0 0       0 croak("Could not load IPC::SharedCache. You must have IPC::SharedCache installed to use HTML::Template in shared_cache mode. The error was: $@")
1363             if ($@);
1364              
1365             # initialize the shared cache
1366 0         0 my %cache;
1367 0         0 tie %cache, 'IPC::SharedCache',
1368             ipc_key => $options->{ipc_key},
1369             load_callback => [\&_load_shared_cache, $self],
1370             validate_callback => [\&_validate_shared_cache, $self],
1371             debug => $options->{shared_cache_debug},
1372             ipc_mode => $options->{ipc_mode},
1373             max_size => $options->{ipc_max_size},
1374             ipc_segment_size => $options->{ipc_segment_size};
1375 0         0 $self->{cache} = \%cache;
1376             }
1377              
1378 226 100       678 if ($options->{default_escape}) {
1379 102         246 $options->{default_escape} = uc $options->{default_escape};
1380 102         139 eval { $self->_load_escape_type($options->{default_escape}); };
  102         331  
1381 102 100       566 croak("HTML::Template->new(): Invalid setting for default_escape - '$options->{default_escape}'.\n$@") if $@;
1382             }
1383              
1384 225 50       582 print STDERR "### HTML::Template Memory Debug ### POST CACHE INIT ", $self->{proc_mem}->size(), "\n"
1385             if $options->{memory_debug};
1386              
1387             # initialize data structures
1388 225         841 $self->_init;
1389              
1390 217 50       757 print STDERR "### HTML::Template Memory Debug ### POST _INIT CALL ", $self->{proc_mem}->size(), "\n"
1391             if $options->{memory_debug};
1392              
1393             # drop the shared cache - leaving out this step results in the
1394             # template object evading garbage collection since the callbacks in
1395             # the shared cache tie hold references to $self! This was not easy
1396             # to find, by the way.
1397 217 50       620 delete $self->{cache} if $options->{shared_cache};
1398              
1399 217         518 $self->{included_templates} = {};
1400 217         778 return $self;
1401             }
1402              
1403             sub _load_supplied_options {
1404 279     279   499 my $argsref = shift;
1405 279         383 my $options = shift;
1406 279         509 for (my $x = 0; $x < @{$argsref}; $x += 2) {
  1404         3910  
1407 4         620 defined(${$argsref}[($x + 1)]) or croak(
  1129         2840  
1408 1129 100       1259 "HTML::Template->new() called with odd number of option parameters - should be of the form option => value, you supplied option = ".lc(${$argsref}[$x]));
1409 1125         1200 $options->{lc(${$argsref}[$x])} = ${$argsref}[($x + 1)];
  1125         3258  
  1125         1570  
1410             }
1411 275         788 return $options;
1412             }
1413              
1414             # an internally used new that receives its parse_stack and param_map as input
1415             sub _new_from_loop {
1416 39     39   59 my $pkg = shift;
1417 39         53 my $self; { my %hash; $self = bless(\%hash, $pkg); }
  39         46  
  39         43  
  39         121  
1418              
1419             # the options hash
1420 39         73 my $options = {};
1421 39         98 $self->{options} = $options;
1422              
1423             # set default parameters in options hash - a subset of the options
1424             # valid in a normal new(). Since _new_from_loop never calls _init,
1425             # many options have no relevance.
1426 39         328 %$options = (
1427             debug => 0,
1428             stack_debug => 0,
1429             profile => 0,
1430             die_on_bad_params => 1,
1431             die_on_unset_params => 0,
1432             associate => [],
1433             case_sensitive => 0,
1434             loop_context_vars => 0,
1435             scalar_loops => 0,
1436             intrinsic_vars => 0,
1437             global_vars => 0, #FIXME: should this be parent_global_vars ?
1438             extended_syntax => 0,
1439             );
1440              
1441             # load in options supplied to new()
1442 39         234 $options = _load_supplied_options( [@_], $options);
1443              
1444 39         170 $self->{param_map} = $options->{param_map};
1445 39         78 $self->{parse_stack} = $options->{parse_stack};
1446 39         88 delete($options->{param_map});
1447 39         67 delete($options->{parse_stack});
1448              
1449 39         286 return $self;
1450             }
1451              
1452             # a few shortcuts to new(), of possible use...
1453             sub new_file {
1454 1     1 0 7 my $pkg = shift; return $pkg->new('filename', @_);
  1         5  
1455             }
1456             sub new_filehandle {
1457 2     2 0 9 my $pkg = shift; return $pkg->new('filehandle', @_);
  2         7  
1458             }
1459             sub new_array_ref {
1460 1     1 0 7 my $pkg = shift; return $pkg->new('arrayref', @_);
  1         4  
1461             }
1462             sub new_scalar_ref {
1463 5     5 0 1681 my $pkg = shift; return $pkg->new('scalarref', @_);
  5         23  
1464             }
1465              
1466             # initializes all the object data structures, either from cache or by
1467             # calling the appropriate routines.
1468             sub _init {
1469 225     225   900 my $self = shift;
1470 225         9670 my $options = $self->{options};
1471              
1472 225 50       1998 if ($options->{double_cache}) {
    100          
    50          
    100          
    100          
1473             # try the normal cache, return if we have it.
1474 0         0 $self->_fetch_from_cache();
1475 0 0 0     0 return if (defined $self->{param_map} and defined $self->{parse_stack});
1476              
1477             # try the shared cache
1478 0         0 $self->_fetch_from_shared_cache();
1479              
1480             # put it in the local cache if we got it.
1481 0 0 0     0 $self->_commit_to_cache()
1482             if (defined $self->{param_map} and defined $self->{parse_stack});
1483             } elsif ($options->{double_file_cache}) {
1484             # try the normal cache, return if we have it.
1485 3         13 $self->_fetch_from_cache();
1486 3 100 66     18 return if (defined $self->{param_map} and defined $self->{parse_stack});
1487              
1488             # try the file cache
1489 1         6 $self->_fetch_from_file_cache();
1490              
1491             # put it in the local cache if we got it.
1492 1 50 33     8 $self->_commit_to_cache()
1493             if (defined $self->{param_map} and defined $self->{parse_stack});
1494             } elsif ($options->{shared_cache}) {
1495             # try the shared cache
1496 0         0 $self->_fetch_from_shared_cache();
1497             } elsif ($options->{file_cache}) {
1498             # try the file cache
1499 7         27 $self->_fetch_from_file_cache();
1500             } elsif ($options->{cache}) {
1501             # try the normal cache
1502 11         38 $self->_fetch_from_cache();
1503             }
1504              
1505             # if we got a cache hit, return
1506 223 100 66     1110 return if (defined $self->{param_map} and defined $self->{parse_stack});
1507              
1508             # if we're here, then we didn't get a cached copy, so do a full
1509             # init.
1510 211         843 $self->_init_template();
1511 209         839 $self->_parse();
1512              
1513             # now that we have a full init, cache the structures if cacheing is
1514             # on. shared cache is already cool.
1515 203 100       566 if($options->{file_cache}){
1516 1         5 $self->_commit_to_file_cache();
1517             }
1518 203 100 66     2407 $self->_commit_to_cache() if (
      100        
      66        
      100        
1519             ($options->{cache}
1520             and not $options->{shared_cache}
1521             and not $options->{file_cache}
1522             )
1523             or ($options->{double_cache})
1524             or ($options->{double_file_cache})
1525             );
1526             }
1527              
1528             # Caching subroutines - they handle getting and validating cache
1529             # records from either the in-memory or shared caches.
1530              
1531             # handles the normal in memory cache
1532 46     46   154457 use vars qw( %CACHE );
  46         126  
  46         253754  
1533             sub _fetch_from_cache {
1534 14     14   24 my $self = shift;
1535 14         23 my $options = $self->{options};
1536 14 50       42 return unless exists($options->{filename});
1537              
1538             # return if there's no file here
1539 14         51 my $filepath = $self->_find_file($options->{filename});
1540 14 50       544 return unless (defined($filepath));
1541 14         34 $options->{filepath} = $filepath;
1542              
1543             # return if there's no cache entry for this key
1544 14         61 my $key = $self->_cache_key();
1545 14 100       413 return unless exists($CACHE{$key});
1546              
1547             # validate the cache
1548 7         27 my $mtime = $self->_mtime($filepath);
1549 7 100       31 if (defined $mtime) {
1550             # return if the mtime doesn't match the cache
1551 6 50 33     49 if (defined($CACHE{$key}{mtime}) and
1552             ($mtime != $CACHE{$key}{mtime})) {
1553 0 0       0 $options->{cache_debug} and
1554             print STDERR "CACHE MISS : $filepath : $mtime\n";
1555 0         0 return;
1556             }
1557              
1558             # if the template has includes, check each included file's mtime
1559             # and return if different
1560 6 100       31 if (exists($CACHE{$key}{included_mtimes})) {
1561 4         6 foreach my $filename (keys %{$CACHE{$key}{included_mtimes}}) {
  4         17  
1562             next unless
1563 2 50       9 defined($CACHE{$key}{included_mtimes}{$filename});
1564              
1565 2         33 my $included_mtime = (stat($filename))[9];
1566 2 50       12 if ($included_mtime != $CACHE{$key}{included_mtimes}{$filename}) {
1567 0 0       0 $options->{cache_debug} and
1568             print STDERR "### HTML::Template Cache Debug ### CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n";
1569              
1570 0         0 return;
1571             }
1572             }
1573             }
1574             }
1575              
1576             # got a cache hit!
1577              
1578 7 100       33 $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath => $key\n";
1579              
1580 7         26 $self->{param_map} = $CACHE{$key}{param_map};
1581 7         24 $self->{parse_stack} = $CACHE{$key}{parse_stack};
1582 7 100       31 exists($CACHE{$key}{included_mtimes}) and
1583             $self->{included_mtimes} = $CACHE{$key}{included_mtimes};
1584              
1585             # clear out values from param_map from last run
1586 7         54 $self->_normalize_options();
1587 7         28 $self->clear_params();
1588             }
1589              
1590             sub _commit_to_cache {
1591 7     7   17 my $self = shift;
1592 7         19 my $options = $self->{options};
1593 7         20 my $key = $self->_cache_key();
1594 7         18 my $filepath = $options->{filepath};
1595              
1596 7 100       39 $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE LOAD : $filepath => $key\n";
1597              
1598 7 100       47 $options->{blind_cache} or
1599             $CACHE{$key}{mtime} = $self->_mtime($filepath);
1600 7         27 $CACHE{$key}{param_map} = $self->{param_map};
1601 7         20 $CACHE{$key}{parse_stack} = $self->{parse_stack};
1602 7 100       39 exists($self->{included_mtimes}) and
1603             $CACHE{$key}{included_mtimes} = $self->{included_mtimes};
1604             }
1605              
1606             # create a cache key from a template object. The cache key includes
1607             # the full path to the template and options which affect template
1608             # loading. Has the side-effect of loading $self->{options}{filepath}
1609             sub _cache_key {
1610 30     30   52 my $self = shift;
1611 30         49 my $options = $self->{options};
1612              
1613             # assemble pieces of the key
1614 30         195 my @key = ($options->{filepath});
1615 30         39 push(@key, @{$options->{path}});
  30         69  
1616 30   100     149 push(@key, $options->{search_path_on_include} || 0);
1617 30   50     137 push(@key, $options->{loop_context_vars} || 0);
1618 30   50     131 push(@key, $options->{scalar_loops} || 0);
1619 30   50     129 push(@key, $options->{intrinsic_vars} || 0);
1620 30   100     121 push(@key, $options->{global_vars} || 0);
1621              
1622             # compute the md5 and return it
1623 30         273 return md5_hex(@key);
1624             }
1625              
1626             # generates MD5 from filepath to determine filename for cache file
1627             sub _get_cache_filename {
1628 9     9   20 my ($self, $filepath) = @_;
1629              
1630             # get a cache key
1631 9         27 $self->{options}{filepath} = $filepath;
1632 9         50 my $hash = $self->_cache_key();
1633              
1634             # ... and build a path out of it. Using the first two charcters
1635             # gives us 255 buckets. This means you can have 255,000 templates
1636             # in the cache before any one directory gets over a few thousand
1637             # files in it. That's probably pretty good for this planet. If not
1638             # then it should be configurable.
1639 9 100       29 if (wantarray) {
1640 1         4 return (substr($hash,0,2), substr($hash,2))
1641             } else {
1642 8         159 return File::Spec->join($self->{options}{file_cache_dir},
1643             substr($hash,0,2), substr($hash,2));
1644             }
1645             }
1646              
1647             # handles the file cache
1648             sub _fetch_from_file_cache {
1649 8     8   16 my $self = shift;
1650 8         17 my $options = $self->{options};
1651 8 50       37 return unless exists($options->{filename});
1652              
1653             # return if there's no cache entry for this filename
1654 8         42 my $filepath = $self->_find_file($options->{filename});
1655 8 50       27 return unless defined $filepath;
1656 8         32 my $cache_filename = $self->_get_cache_filename($filepath);
1657 8 50       248 return unless -e $cache_filename;
1658              
1659 8         17 eval {
1660 8         31 $self->{record} = Storable::lock_retrieve($cache_filename);
1661             };
1662 8 50       17410 croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $@")
1663             if $@;
1664 8 50       29 croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $!")
1665             unless defined $self->{record};
1666              
1667 8         48 ($self->{mtime},
1668             $self->{included_mtimes},
1669             $self->{param_map},
1670 8         15 $self->{parse_stack}) = @{$self->{record}};
1671              
1672 8         23 $options->{filepath} = $filepath;
1673              
1674             # validate the cache
1675 8         33 my $mtime = $self->_mtime($filepath);
1676 8 50       32 if (defined $mtime) {
1677             # return if the mtime doesn't match the cache
1678 8 100 66     66 if (defined($self->{mtime}) and
1679             ($mtime != $self->{mtime})) {
1680 1 50       6 $options->{cache_debug} and
1681             print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : $mtime\n";
1682 1         4 ($self->{mtime},
1683             $self->{included_mtimes},
1684             $self->{param_map},
1685             $self->{parse_stack}) = (undef, undef, undef, undef);
1686 1         723 return;
1687             }
1688              
1689             # if the template has includes, check each included file's mtime
1690             # and return if different
1691 7 50       24 if (exists($self->{included_mtimes})) {
1692 7         10 foreach my $filename (keys %{$self->{included_mtimes}}) {
  7         35  
1693             next unless
1694 2 50       8 defined($self->{included_mtimes}{$filename});
1695              
1696 2         32 my $included_mtime = (stat($filename))[9];
1697 2 50       12 if ($included_mtime != $self->{included_mtimes}{$filename}) {
1698 0 0       0 $options->{cache_debug} and
1699             print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n";
1700 0         0 ($self->{mtime},
1701             $self->{included_mtimes},
1702             $self->{param_map},
1703             $self->{parse_stack}) = (undef, undef, undef, undef);
1704 0         0 return;
1705             }
1706             }
1707             }
1708             }
1709              
1710             # got a cache hit!
1711 7 100       43 $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE HIT : $filepath\n";
1712              
1713             # clear out values from param_map from last run
1714 7         34 $self->_normalize_options();
1715 7         24 $self->clear_params();
1716             }
1717              
1718             sub _commit_to_file_cache {
1719 1     1   2 my $self = shift;
1720 1         3 my $options = $self->{options};
1721              
1722 1         2 my $filepath = $options->{filepath};
1723 1 50       4 if (not defined $filepath) {
1724 0         0 $filepath = $self->_find_file($options->{filename});
1725 0 0       0 confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.")
1726             unless defined($filepath);
1727 0         0 $options->{filepath} = $filepath;
1728             }
1729              
1730 1         4 my ($cache_dir, $cache_file) = $self->_get_cache_filename($filepath);
1731 1         22 $cache_dir = File::Spec->join($options->{file_cache_dir}, $cache_dir);
1732 1 50       23 if (not -d $cache_dir) {
1733 0 0       0 if (not -d $options->{file_cache_dir}) {
1734 0 0       0 mkdir($options->{file_cache_dir},$options->{file_cache_dir_mode})
1735             or croak("HTML::Template->new() : can't mkdir $options->{file_cache_dir} (file_cache => 1): $!");
1736             }
1737 0 0       0 mkdir($cache_dir,$options->{file_cache_dir_mode})
1738             or croak("HTML::Template->new() : can't mkdir $cache_dir (file_cache => 1): $!");
1739             }
1740              
1741 1 50       6 $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE LOAD : $options->{filepath}\n";
1742              
1743 1         1 my $result;
1744 1         2 eval {
1745 1         17 $result = Storable::lock_store([ $self->{mtime},
1746             $self->{included_mtimes},
1747             $self->{param_map},
1748             $self->{parse_stack} ],
1749             scalar File::Spec->join($cache_dir, $cache_file)
1750             );
1751             };
1752 1 50       552 croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $@")
1753             if $@;
1754 1 50       6 croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $!")
1755             unless defined $result;
1756             }
1757              
1758             # Shared cache routines.
1759             sub _fetch_from_shared_cache {
1760 0     0   0 my $self = shift;
1761 0         0 my $options = $self->{options};
1762 0 0       0 return unless exists($options->{filename});
1763              
1764 0         0 my $filepath = $self->_find_file($options->{filename});
1765 0 0       0 return unless defined $filepath;
1766              
1767             # fetch from the shared cache.
1768 0         0 $self->{record} = $self->{cache}{$filepath};
1769              
1770 0         0 ($self->{mtime},
1771             $self->{included_mtimes},
1772             $self->{param_map},
1773 0 0       0 $self->{parse_stack}) = @{$self->{record}}
1774             if defined($self->{record});
1775              
1776 0 0 0     0 $options->{cache_debug} and defined($self->{record}) and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath\n";
1777             # clear out values from param_map from last run
1778 0 0       0 $self->_normalize_options(), $self->clear_params()
1779             if (defined($self->{record}));
1780 0         0 delete($self->{record});
1781              
1782 0         0 return $self;
1783             }
1784              
1785             sub _validate_shared_cache {
1786 0     0   0 my ($self, $filename, $record) = @_;
1787 0         0 my $options = $self->{options};
1788              
1789 0 0       0 $options->{shared_cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE VALIDATE : $filename\n";
1790              
1791 0 0       0 return 1 if $options->{blind_cache};
1792              
1793 0         0 my ($c_mtime, $included_mtimes, $param_map, $parse_stack) = @$record;
1794              
1795             # if the modification time has changed return false
1796 0         0 my $mtime = $self->_mtime($filename);
1797 0 0 0     0 if (defined $mtime and defined $c_mtime
      0        
1798             and $mtime != $c_mtime) {
1799 0 0       0 $options->{cache_debug} and
1800             print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : $mtime\n";
1801 0         0 return 0;
1802             }
1803              
1804             # if the template has includes, check each included file's mtime
1805             # and return false if different
1806 0 0 0     0 if (defined $mtime and defined $included_mtimes) {
1807 0         0 foreach my $fname (keys %$included_mtimes) {
1808 0 0       0 next unless defined($included_mtimes->{$fname});
1809 0 0       0 if ($included_mtimes->{$fname} != (stat($fname))[9]) {
1810 0 0       0 $options->{cache_debug} and
1811             print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : INCLUDE $fname\n";
1812 0         0 return 0;
1813             }
1814             }
1815             }
1816              
1817             # all done - return true
1818 0         0 return 1;
1819             }
1820              
1821             sub _load_shared_cache {
1822 0     0   0 my ($self, $filename) = @_;
1823 0         0 my $options = $self->{options};
1824 0         0 my $cache = $self->{cache};
1825              
1826 0         0 $self->_init_template();
1827 0         0 $self->_parse();
1828              
1829 0 0       0 $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE LOAD : $options->{filepath}\n";
1830              
1831 0 0       0 print STDERR "### HTML::Template Memory Debug ### END CACHE LOAD ", $self->{proc_mem}->size(), "\n"
1832             if $options->{memory_debug};
1833              
1834 0         0 return [ $self->{mtime},
1835             $self->{included_mtimes},
1836             $self->{param_map},
1837             $self->{parse_stack} ];
1838             }
1839              
1840             # utility function - given a filename performs documented search and
1841             # returns a full path or undef if the file cannot be found.
1842             sub _find_file {
1843 123     123   442 my ($self, $filename, $extra_path) = @_;
1844 123         261 my $options = $self->{options};
1845 123         138 my $filepath;
1846              
1847             # first check for a full path
1848 123 50 33     1181 return File::Spec->canonpath($filename)
1849             if (File::Spec->file_name_is_absolute($filename) and (-e $filename));
1850              
1851             # try the extra_path if one was specified
1852 123 100       396 if (defined($extra_path)) {
1853 34         55 $extra_path->[$#{$extra_path}] = $filename;
  34         88  
1854 34         473 $filepath = File::Spec->canonpath(File::Spec->catfile(@$extra_path));
1855 34 100       906 return File::Spec->canonpath($filepath) if -e $filepath;
1856             }
1857              
1858             # try pre-prending HTML_Template_Root
1859 96 100       510 if (defined($ENV{HTML_TEMPLATE_ROOT})) {
1860 4         54 $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $filename);
1861 4 100       87 return File::Spec->canonpath($filepath) if -e $filepath;
1862             }
1863              
1864             # try "path" option list..
1865 95         148 foreach my $path (@{$options->{path}}) {
  95         260  
1866 81         1156 $filepath = File::Spec->catfile($path, $filename);
1867 81 100       2764 return File::Spec->canonpath($filepath) if -e $filepath;
1868             }
1869              
1870             # try even a relative path from the current directory...
1871 20 100       555 return File::Spec->canonpath($filename) if -e $filename;
1872              
1873             # try "path" option list with HTML_TEMPLATE_ROOT prepended...
1874 3 50       12 if (defined($ENV{HTML_TEMPLATE_ROOT})) {
1875 3         5 foreach my $path (@{$options->{path}}) {
  3         8  
1876 2         25 $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $path, $filename);
1877 2 100       41 return File::Spec->canonpath($filepath) if -e $filepath;
1878             }
1879             }
1880              
1881 2         6 return undef;
1882             }
1883              
1884             # utility function - computes the mtime for $filename
1885             sub _mtime {
1886 89     89   153 my ($self, $filepath) = @_;
1887 89         163 my $options = $self->{options};
1888              
1889 89 100       254 return(undef) if ($options->{blind_cache});
1890              
1891             # make sure it still exists in the filesystem
1892 87 50       1507 (-r $filepath) or Carp::confess("HTML::Template : template file $filepath does not exist or is unreadable.");
1893              
1894             # get the modification time
1895 87         478 return (stat(_))[9];
1896             }
1897              
1898             # utility function - enforces new() options across LOOPs that have
1899             # come from a cache. Otherwise they would have stale options hashes.
1900             sub _normalize_options {
1901 14     14   99 my $self = shift;
1902 14         38 my $options = $self->{options};
1903              
1904 14         40 my @pstacks = ($self->{parse_stack});
1905 14         52 while(@pstacks) {
1906 15         28 my $pstack = pop(@pstacks);
1907 15         35 foreach my $item (@$pstack) {
1908 39 100       183 next unless (ref($item) eq 'HTML::Template::LOOP');
1909 1         2 foreach my $template (values %{$item->[HTML::Template::LOOP::TEMPLATE_HASH]}) {
  1         5  
1910             # must be the same list as the call to _new_from_loop...
1911 1         3 $template->{options}{debug} = $options->{debug};
1912 1         4 $template->{options}{stack_debug} = $options->{stack_debug};
1913 1         3 $template->{options}{profile} = $options->{profile};
1914 1         3 $template->{options}{die_on_bad_params} = $options->{die_on_bad_params};
1915 1         4 $template->{options}{die_on_unset_params} = $options->{die_on_unset_params};
1916 1         6 $template->{options}{case_sensitive} = $options->{case_sensitive};
1917 1         3 $template->{options}{loop_context_vars} = $options->{loop_context_vars};
1918 1         2 $template->{options}{scalar_loops} = $options->{scalar_loops};
1919 1         4 $template->{options}{force_untaint} = $options->{force_untaint};
1920 1   50     9 $template->{options}{parent_global_vars} = $options->{parent_global_vars} || 0; #FIXME: should this include a check for global_vars ?
1921 1         4 $template->{options}{extended_syntax} = $options->{extended_syntax};
1922 1 50       5 $template->{options}{expr} = $options->{expr} if (exists $options->{expr});
1923 1 50       6 $template->{options}{expr_func} = $options->{expr_func} if (exists $options->{expr_func});
1924 1         4 push(@pstacks, $template->{parse_stack});
1925             }
1926             }
1927             }
1928             }
1929              
1930             # initialize the template buffer
1931             sub _init_template {
1932 211     211   336 my $self = shift;
1933 211         467 my $options = $self->{options};
1934              
1935 211 50       819 print STDERR "### HTML::Template Memory Debug ### START INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n"
1936             if $options->{memory_debug};
1937              
1938 211 100       1446 if (exists($options->{filename})) {
    100          
    100          
    50          
1939 70         161 $self->{type} = "filename";
1940 70         142 my $filepath = $options->{filepath};
1941 70 100       189 if (not defined $filepath) {
1942 63         519 $filepath = $self->_find_file($options->{filename});
1943 63 100       564 confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.")
1944             unless defined($filepath);
1945             # we'll need this for future reference - to call stat() for example.
1946 61         157 $options->{filepath} = $filepath;
1947             }
1948              
1949 68 50       2839 confess("HTML::Template->new() : Cannot open included file $options->{filename} : $!")
1950             unless defined(open(TEMPLATE, $filepath));
1951 68         283 $self->{mtime} = $self->_mtime($filepath);
1952              
1953             # read into scalar, note the mtime for the record
1954 68         210 $self->{template} = "";
1955 68         2721 while (read(TEMPLATE, $self->{template}, 10240, length($self->{template}))) {}
1956 68         10553 close(TEMPLATE);
1957              
1958             } elsif (exists($options->{scalarref})) {
1959 135         324 $self->{type} = "scalarref";
1960             # copy in the template text
1961 135         176 $self->{template} = ${$options->{scalarref}};
  135         492  
1962 135         306 delete($options->{scalarref});
1963              
1964             } elsif (exists($options->{arrayref})) {
1965 2         5 $self->{type} = "arrayref";
1966             # if we have an array ref, join and store the template text
1967 2         6 $self->{template} = join("", @{$options->{arrayref}});
  2         9  
1968 2         5 delete($options->{arrayref});
1969              
1970             } elsif (exists($options->{filehandle})) {
1971 4         11 $self->{type} = "filehandle";
1972             # just read everything in in one go
1973 4         18 local $/ = undef;
1974 4         147 $self->{template} = readline($options->{filehandle});
1975 4         20 delete($options->{filehandle});
1976              
1977             } else {
1978 0         0 confess("HTML::Template : Need to call new with filename, filehandle, scalarref or arrayref parameter specified.");
1979             }
1980              
1981 209 50       1790 print STDERR "### HTML::Template Memory Debug ### END INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n"
1982             if $options->{memory_debug};
1983              
1984             # handle filters if necessary
1985 209 100       327 $self->_call_filters(\$self->{template}) if @{$options->{filter}};
  209         764  
1986              
1987 209         444 return $self;
1988             }
1989              
1990             # handle calling user defined filters
1991             sub _call_filters {
1992 12     12   21 my $self = shift;
1993 12         18 my $template_ref = shift;
1994 12         20 my $options = $self->{options};
1995              
1996 12         14 my ($format, $sub);
1997 12         15 foreach my $filter (@{$options->{filter}}) {
  12         30  
1998 14 50       31 croak("HTML::Template->new() : bad value set for filter parameter - must be a code ref or a hash ref.")
1999             unless reftype($filter);
2000              
2001             # translate into CODE->HASH
2002 14 100       31 $filter = { 'format' => 'scalar', 'sub' => $filter }
2003             if (reftype($filter) eq 'CODE');
2004              
2005 14 50       36 if (reftype($filter) eq 'HASH') {
2006 14         24 $format = $filter->{'format'};
2007 14         23 $sub = $filter->{'sub'};
2008              
2009             # check types and values
2010 14 50 33     68 croak("HTML::Template->new() : bad value set for filter parameter - hash must contain \"format\" key and \"sub\" key.")
2011             unless defined $format and defined $sub;
2012 14 50 66     66 croak("HTML::Template->new() : bad value set for filter parameter - \"format\" must be either 'array' or 'scalar'")
2013             unless $format eq 'array' or $format eq 'scalar';
2014 14 50 33     48 croak("HTML::Template->new() : bad value set for filter parameter - \"sub\" must be a code ref")
2015             unless ref $sub and reftype($sub) eq 'CODE';
2016              
2017             # catch errors
2018 14         22 eval {
2019 14 100       31 if ($format eq 'scalar') {
2020             # call
2021 12         37 $sub->($template_ref,$self);
2022             } else {
2023             # modulate
2024 2         8 my @array = map { $_."\n" } split("\n", $$template_ref);
  3         11  
2025             # call
2026 2         9 $sub->(\@array,$self);
2027             # demodulate
2028 2         26 $$template_ref = join("", @array);
2029             }
2030             };
2031 14 50       107 croak("HTML::Template->new() : fatal error occured during filter call: $@") if $@;
2032             } else {
2033 0         0 croak("HTML::Template->new() : bad value set for filter parameter - must be code ref or hash ref");
2034             }
2035             }
2036             # all done
2037 12         30 return $template_ref;
2038             }
2039              
2040             # _parse sifts through a template building up the param_map and
2041             # parse_stack structures.
2042             #
2043             # The end result is a Template object that is fully ready for
2044             # output().
2045             sub _parse {
2046 209     209   280 my $self = shift;
2047 209         392 my $options = $self->{options};
2048              
2049 209 50       1051 $options->{debug} and print STDERR "### HTML::Template Debug ### In _parse:\n";
2050              
2051             # display profiling information
2052 209 50       519 if ($options->{profile}) {
2053 46     46   505 use vars qw($profile_time_start);
  46         97  
  46         13200  
2054 0         0 $profile_time_start = [gettimeofday];
2055 0         0 printf STDERR "### HTML::Template Profile ## begin _parse : %.6f\n", join('.',@$profile_time_start);
2056             }
2057              
2058             # setup the stacks and maps - they're accessed by typeglobs that
2059             # reference the top of the stack. They are masked so that a loop
2060             # can transparently have its own versions.
2061 46     46   269 use vars qw(@pstack %pmap @ifstack @elsifstack @ucstack %top_pmap);
  46         254  
  46         18161  
2062 209         1366 local (*pstack, *ifstack, *elsifstack, *pmap, *ucstack, *top_pmap);
2063              
2064             # the pstack is the array of scalar refs (plain text from the
2065             # template file), VARs, LOOPs, IFs and ELSEs that output() works on
2066             # to produce output. Looking at output() should make it clear what
2067             # _parse is trying to accomplish.
2068 209         562 my @pstacks = ([]);
2069 209         388 *pstack = $pstacks[0];
2070 209         580 $self->{parse_stack} = $pstacks[0];
2071              
2072             # the pmap binds names to VARs, LOOPs and IFs. It allows param() to
2073             # access the right variable. NOTE: output() does not look at the
2074             # pmap at all!
2075 209         689 my @pmaps = ({});
2076 209         341 *pmap = $pmaps[0];
2077 209         298 *top_pmap = $pmaps[0];
2078 209         402 $self->{param_map} = $pmaps[0];
2079              
2080             # enable the intrinsic vars
2081 209 100       655 if ($options->{intrinsic_vars}) {
2082 3         14 $pmap{__type__} = HTML::Template::VAR->new();
2083 3         10 $pmap{__filename__} = HTML::Template::VAR->new();
2084 3         8 $pmap{__filepath__} = HTML::Template::VAR->new();
2085 3         6 ${$pmap{__type__}} = $self->{type};
  3         11  
2086 3   100     12 ${$pmap{__filename__}} = $options->{filename} || '';
  3         6  
2087 3 50       10 ${$pmap{__filepath__}} = defined $options->{filepath} ? $options->{filepath} :
  3 100       5  
2088             $options->{filename} ? $self->_find_file($options->{filename}) :
2089             '';
2090             }
2091              
2092             # the ifstack is a temporary stack containing pending ifs and elses
2093             # waiting for a /if.
2094 209         519 my @ifstacks = ([]);
2095 209         480 *ifstack = $ifstacks[0];
2096              
2097             # the elsifstack is a temporary stack for containing the elsif,
2098             # which in reality expands/unrolls to become IF-ELSE-/IF.
2099 209         408 my @elsifstacks = ([]);
2100 209         313 *elsifstack = $elsifstacks[0];
2101              
2102             # the ucstack is a temporary stack containing conditions that need
2103             # to be bound to param_map entries when their block is finished.
2104             # This happens when a conditional is encountered before any other
2105             # reference to its NAME. Since a conditional can reference VARs and
2106             # LOOPs it isn't possible to make the link right away.
2107 209         382 my @ucstacks = ([]);
2108 209         291 *ucstack = $ucstacks[0];
2109              
2110             # the loopstack is another temp stack for closing loops. unlike
2111             # those above it doesn't get scoped inside loops, therefore it
2112             # doesn't need the typeglob magic.
2113 209         326 my @loopstack = ();
2114              
2115             # the fstack is a stack of filenames and counters that keeps track
2116             # of which file we're in and where we are in it. This allows
2117             # accurate error messages even inside included files!
2118             # fcounter, fmax and fname are aliases for the current file's info
2119 46     46   295 use vars qw($fcounter $fname $fmax);
  46         134  
  46         331625  
2120 209         877 local (*fcounter, *fname, *fmax);
2121              
2122 209         2844 my @fstack = ([$options->{filepath} || "/fake/path/for/non/file/template",
2123             1,
2124 209   100     3164 scalar @{[$self->{template} =~ m/(\n)/g]} + 1
2125             ]);
2126 209         1220 (*fname, *fcounter, *fmax) = \ ( @{$fstack[0]} );
  209         693  
2127              
2128 209         902 my $NOOP = HTML::Template::NOOP->new();
2129              
2130             # all the tags that need NAMEs:
2131 209         413 my %need_names = map { $_ => 1 }
  1463         3877  
2132             qw(TMPL_VAR TMPL_LOOP TMPL_IF TMPL_ELSIF TMPL_UNLESS TMPL_INCLUDE TMPL_REQUIRE);
2133              
2134             # variables used below that don't need to be my'd in the loop
2135 209         466 my ($name, $which, $escape, $default);
2136              
2137             # now split up template on '
2138 209         2814 my @chunks = split(m!(?=<(?:\!--\s*)?/?[Tt][Mm][Pp][Ll]_)!, $self->{template});
2139              
2140             # all done with template
2141 209         466 delete $self->{template};
2142              
2143             # loop through chunks, filling up pstack
2144 209         378 my $last_chunk = $#chunks;
2145 209         919 CHUNK: for (my $chunk_number = 0;
2146             $chunk_number <= $last_chunk;
2147             $chunk_number++) {
2148 614 50       4781 next unless defined $chunks[$chunk_number];
2149 614         2729 my $chunk = $chunks[$chunk_number];
2150              
2151             # a general regex to match any and all TMPL_* tags
2152 614 100 33     10136 if ($chunk =~ /^<
    50          
2153             (?:!--\s*)?
2154             (
2155             \/?[Tt][Mm][Pp][Ll]_
2156             (?:
2157             (?:[Vv][Aa][Rr])
2158             |
2159             (?:[Ll][Oo][Oo][Pp])
2160             |
2161             (?:[Ii][Ff])
2162             |
2163             (?:[Ee][Ll][Ss][Ee])
2164             |
2165             (?:[Ee][Ll][Ss][Ii][Ff])
2166             |
2167             (?:[Uu][Nn][Ll][Ee][Ss][Ss])
2168             |
2169             (?:[Ii][Nn][Cc][Ll][Uu][Dd][Ee])
2170             |
2171             (?:[Rr][Ee][Qq][Uu][Ii][Rr][Ee])
2172             )
2173             ) # $1 => $which - start of the tag
2174              
2175             \s*
2176              
2177             # DEFAULT attribute
2178             (?:
2179             [Dd][Ee][Ff][Aa][Uu][Ll][Tt]
2180             \s*=\s*
2181             (?:
2182             "([^">]*)" # $2 => double-quoted DEFAULT value "
2183             |
2184             '([^'>]*)' # $3 => single-quoted DEFAULT value
2185             |
2186             ([^\s=>]*) # $4 => unquoted DEFAULT value
2187             )
2188             )?
2189              
2190             \s*
2191              
2192             # ESCAPE attribute
2193             (?:
2194             [Ee][Ss][Cc][Aa][Pp][Ee]
2195             \s*=\s*
2196             (
2197             (?:"[^"]*")
2198             |
2199             (?:'[^']*')
2200             |
2201             (?:[^\s=>]*) # $5 => ESCAPE
2202             )
2203             )* # allow multiple ESCAPEs
2204              
2205             \s*
2206              
2207             # DEFAULT attribute
2208             (?:
2209             [Dd][Ee][Ff][Aa][Uu][Ll][Tt]
2210             \s*=\s*
2211             (?:
2212             "([^">]*)" # $6 => double-quoted DEFAULT value "
2213             |
2214             '([^'>]*)' # $7 => single-quoted DEFAULT value
2215             |
2216             ([^\s=>]*) # $8 => unquoted DEFAULT value
2217             )
2218             )?
2219              
2220             \s*
2221              
2222             # NAME attribute
2223             (?:
2224             (?:
2225             [Nn][Aa][Mm][Ee]
2226             \s*=\s*
2227             )?
2228             (?:
2229             "([^">]*)" # $9 => double-quoted NAME value "
2230             |
2231             '([^'>]*)' # $10 => single-quoted NAME value
2232             |
2233             ([^\s=>]*) # $11 => unquoted NAME value
2234             )
2235             )?
2236              
2237             \s*
2238              
2239             # DEFAULT attribute
2240             (?:
2241             [Dd][Ee][Ff][Aa][Uu][Ll][Tt]
2242             \s*=\s*
2243             (?:
2244             "([^">]*)" # $12 => double-quoted DEFAULT value "
2245             |
2246             '([^'>]*)' # $13 => single-quoted DEFAULT value
2247             |
2248             ([^\s=>]*) # $14 => unquoted DEFAULT value
2249             )
2250             )?
2251              
2252             \s*
2253              
2254             # ESCAPE attribute
2255             (?:
2256             [Ee][Ss][Cc][Aa][Pp][Ee]
2257             \s*=\s*
2258             (
2259             (?:"[^"]*")
2260             |
2261             (?:'[^']*')
2262             |
2263             (?:[^\s=>]*) # $15 => ESCAPE
2264             )
2265             )* # allow multiple ESCAPEs
2266              
2267             \s*
2268              
2269             # DEFAULT attribute
2270             (?:
2271             [Dd][Ee][Ff][Aa][Uu][Ll][Tt]
2272             \s*=\s*
2273             (?:
2274             "([^">]*)" # $16 => double-quoted DEFAULT value "
2275             |
2276             '([^'>]*)' # $17 => single-quoted DEFAULT value
2277             |
2278             ([^\s=>]*) # $18 => unquoted DEFAULT value
2279             )
2280             )?
2281              
2282             \s*
2283              
2284             (?:
2285             (?:--)
2286             |
2287             (?:\/)
2288             )?>
2289             (.*) # $19 => $post - text that comes after the tag
2290             $/sx) {
2291              
2292 490         1423 $which = uc($1); # which tag is it
2293              
2294 490 100 100     3550 $escape = defined $5 ? $5 : defined $15 ? $15
    100          
    100          
2295             : (defined $options->{default_escape} && $which eq 'TMPL_VAR') ? $options->{default_escape} : 0; # escape set?
2296              
2297             # what name for the tag? undef for a /tag at most, one of the
2298             # following three will be defined
2299 490 50       2310 $name = defined $9 ? $9 : defined $10 ? $10 : defined $11 ? $11 : undef;
    100          
    100          
2300              
2301             # is there a default?
2302 490 100       7001 $default = defined $2 ? $2 : defined $3 ? $3 : defined $4 ? $4 :
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
2303             defined $6 ? $6 : defined $7 ? $7 : defined $8 ? $8 :
2304             defined $12 ? $12 : defined $13 ? $13 : defined $14 ? $14 :
2305             defined $16 ? $16 : defined $17 ? $17 : defined $18 ? $18 :
2306             undef;
2307              
2308 490         1271 my $post = $19; # what comes after on the line
2309              
2310             # allow mixed case in filenames, otherwise flatten
2311 490 100 66     5527 $name = lc($name) unless (not defined $name or $which eq 'TMPL_INCLUDE' or $which eq 'TMPL_REQUIRE' or $options->{case_sensitive});
      100        
      100        
2312              
2313             # die if we need a name and didn't get one
2314 490 100 66     3297 die "HTML::Template->new() : No NAME given to a $which tag at $fname : line $fcounter."
      100        
2315             if ($need_names{$which} and (not defined $name or not length $name));
2316              
2317             # die if we got an escape but can't use one
2318 489 100 100     1635 die "HTML::Template->new() : ESCAPE option invalid in a $which tag at $fname : line $fcounter." if ( $escape and ($which ne 'TMPL_VAR'));
2319              
2320             # die if we got a default but can't use one
2321 488 100 100     1276 die "HTML::Template->new() : DEFAULT option invalid in a $which tag at $fname : line $fcounter." if ( defined $default and ($which ne 'TMPL_VAR'));
2322              
2323             # take actions depending on which tag found
2324 487 100 100     2570 if ($which eq 'TMPL_VAR') {
    100 100        
    100 66        
    100          
    100          
    100          
    100          
    50          
2325 285 50       685 $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : parsed VAR $name\n";
2326              
2327             # if we already have this var, then simply link to the existing
2328             # HTML::Template::VAR, else create a new one.
2329 285         298 my $var;
2330 285 100       918 if (exists $pmap{$name}) {
2331 28         47 $var = $pmap{$name};
2332 28 50       86 (ref($var) eq 'HTML::Template::VAR') or
2333             die "HTML::Template->new() : Already used param name $name as a TMPL_LOOP, found in a TMPL_VAR at $fname : line $fcounter.";
2334             } else {
2335 257         912 $var = HTML::Template::VAR->new();
2336 257         703 $pmap{$name} = $var;
2337 257 100 100     2093 $top_pmap{$name} = HTML::Template::VAR->new()
2338             if $options->{global_vars} and not exists $top_pmap{$name}; #FIXME: should this also check for parent_global_vars
2339             }
2340              
2341             # if a DEFAULT was provided, push a DEFAULT object on the
2342             # stack before the variable.
2343 285 100       658 if (defined $default) {
2344 25         78 push(@pstack, HTML::Template::DEFAULT->new($default));
2345             }
2346              
2347             # if ESCAPE was set, push an ESCAPE op on the stack before
2348             # the variable. output will handle the actual work.
2349             # unless of course, they have set escape=0 or escape=none
2350 285 100       864 if ($escape) {
2351 132         15275 $escape = $self->_load_escape_type($escape);
2352 132 100       9961 push(@pstack, $escape) if $escape;
2353             }
2354              
2355 285         593 push(@pstack, $var);
2356              
2357             } elsif ($which eq 'TMPL_LOOP') {
2358             # we've got a loop start
2359 39 50       113 $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP $name start\n";
2360              
2361             # if we already have this loop, then simply link to the existing
2362             # HTML::Template::LOOP, else create a new one.
2363 39         46 my $loop;
2364 39 100       180 if (exists $pmap{$name}) {
2365 4         10 $loop = $pmap{$name};
2366 4 50       15 (ref($loop) eq 'HTML::Template::LOOP') or
2367             die "HTML::Template->new() : Already used param name $name as a TMPL_VAR, TMPL_IF or TMPL_UNLESS, found in a TMPL_LOOP at $fname : line $fcounter!";
2368              
2369             } else {
2370             # store the results in a LOOP object - actually just a
2371             # thin wrapper around another HTML::Template object.
2372 35         157 $loop = HTML::Template::LOOP->new();
2373 35         283 $pmap{$name} = $loop;
2374             }
2375              
2376             # get it on the loopstack, pstack of the enclosing block
2377 39         66 push(@pstack, $loop);
2378 39         174 push(@loopstack, [$loop, $#pstack]);
2379              
2380             # magic time - push on a fresh pmap and pstack, adjust the typeglobs.
2381             # this gives the loop a separate namespace (i.e. pmap and pstack).
2382 39         69 push(@pstacks, []);
2383 39         79 *pstack = $pstacks[$#pstacks];
2384 39         65 push(@pmaps, {});
2385 39         65 *pmap = $pmaps[$#pmaps];
2386 39         56 push(@ifstacks, []);
2387 39         97 *ifstack = $ifstacks[$#ifstacks];
2388 39         65 push(@elsifstacks, []);
2389 39         70 *elsifstack = $elsifstacks[$#elsifstacks];
2390 39         65 push(@ucstacks, []);
2391 39         73 *ucstack = $ucstacks[$#ucstacks];
2392              
2393             # auto-vivify __FIRST__, __LAST__, __OUTER__ and __INNER__ if
2394             # loop_context_vars is set. Otherwise, with
2395             # die_on_bad_params set output() will might cause errors
2396             # when it tries to set them.
2397 39 100       122 if ($options->{loop_context_vars}) {
2398 6         22 $pmap{__first__} = HTML::Template::VAR->new();
2399 6         19 $pmap{__inner__} = HTML::Template::VAR->new();
2400 6         18 $pmap{__outer__} = HTML::Template::VAR->new();
2401 6         18 $pmap{__last__} = HTML::Template::VAR->new();
2402 6         16 $pmap{__odd__} = HTML::Template::VAR->new();
2403 6         72 $pmap{__even__} = HTML::Template::VAR->new();
2404 6         14 $pmap{__counter__} = HTML::Template::VAR->new();
2405             }
2406              
2407             } elsif ($which eq '/TMPL_LOOP') {
2408 39 50       105 $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP end\n";
2409              
2410 39         67 my $loopdata = pop(@loopstack);
2411 39 50       138 die "HTML::Template->new() : found with no matching at $fname : line $fcounter!" unless defined $loopdata;
2412              
2413 39         83 my ($loop, $starts_at) = @$loopdata;
2414              
2415             # resolve pending conditionals
2416 39         98 foreach my $uc (@ucstack) {
2417 3         9 my $var = $uc->[HTML::Template::COND::VARIABLE];
2418 3 100       9 if (exists($pmap{$var})) {
2419 2         5 $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var};
2420             } else {
2421 1         6 $pmap{$var} = HTML::Template::VAR->new();
2422 1 50 33     15 $top_pmap{$var} = HTML::Template::VAR->new()
2423             if $options->{global_vars} and not exists $top_pmap{$var}; #FIXME: should this also check for parent_global_vars ?
2424 1         4 $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var};
2425             }
2426 3 50       13 if (ref($pmap{$var}) eq 'HTML::Template::VAR') {
2427 3         10 $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR;
2428             } else {
2429 0         0 $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP;
2430             }
2431             }
2432              
2433             # get pmap and pstack for the loop, adjust the typeglobs to
2434             # the enclosing block.
2435 39         86 my $param_map = pop(@pmaps);
2436 39         80 *pmap = $pmaps[$#pmaps];
2437 39         63 my $parse_stack = pop(@pstacks);
2438 39         58 *pstack = $pstacks[$#pstacks];
2439              
2440 39 50       102 scalar(@ifstack) and die "HTML::Template->new() : Dangling or in loop ending at $fname : line $fcounter.";
2441 39         49 pop(@ifstacks);
2442 39         71 *ifstack = $ifstacks[$#ifstacks];
2443 39         45 pop(@elsifstacks);
2444 39         60 *elsifstack = $elsifstacks[$#elsifstacks];
2445 39         49 pop(@ucstacks);
2446 39         63 *ucstack = $ucstacks[$#ucstacks];
2447              
2448             # instantiate the sub-Template, feeding it parse_stack and
2449             # param_map. This means that only the enclosing template
2450             # does _parse() - sub-templates get their parse_stack and
2451             # param_map fed to them already filled in.
2452 39   100     627 my %opts = (
2453             debug => $options->{debug},
2454             stack_debug => $options->{stack_debug},
2455             profile => $options->{profile},
2456             die_on_bad_params => $options->{die_on_bad_params},
2457             die_on_unset_params => $options->{die_on_unset_params},
2458             case_sensitive => $options->{case_sensitive},
2459             loop_context_vars => $options->{loop_context_vars},
2460             scalar_loops => $options->{scalar_loops},
2461             intrinsic_vars => $options->{intrinsic_vars},
2462             parent_global_vars => ($options->{global_vars} || $options->{parent_global_vars} || 0),
2463             extended_syntax => $options->{extended_syntax},
2464             force_untaint => $options->{force_untaint},
2465             parse_stack => $parse_stack,
2466             param_map => $param_map,
2467             );
2468 39 50       100 exists $options->{expr} and $opts{expr} = $options->{expr};
2469 39 50       106 exists $options->{expr_func} and $opts{expr_func} = $options->{expr_func};
2470 39         332 $loop->[HTML::Template::LOOP::TEMPLATE_HASH]{$starts_at} = ref($self)->_new_from_loop(%opts);
2471              
2472             } elsif ($which eq 'TMPL_IF' or $which eq 'TMPL_UNLESS') {
2473 32 50       92 $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : $which $name start\n";
2474              
2475             # if we already have this var, then simply link to the existing
2476             # HTML::Template::VAR/LOOP, else defer the mapping
2477 32         34 my $var;
2478 32 100       91 if (exists $pmap{$name}) {
2479 7         15 $var = $pmap{$name};
2480             } else {
2481 25         57 $var = $name;
2482             }
2483              
2484             # connect the var to a conditional
2485 32         156 my $cond = HTML::Template::COND->new($var);
2486 32 100       77 if ($which eq 'TMPL_IF') {
2487 25         84 $cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_IF;
2488 25         47 $cond->[HTML::Template::COND::JUMP_IF_TRUE] = 0;
2489             } else {
2490 7         15 $cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_UNLESS;
2491 7         13 $cond->[HTML::Template::COND::JUMP_IF_TRUE] = 1;
2492             }
2493              
2494             # push unconnected conditionals onto the ucstack for
2495             # resolution later. Otherwise, save type information now.
2496 32 100       78 if ($var eq $name) {
2497 25         55 push(@ucstack, $cond);
2498             } else {
2499 7 50       22 if (ref($var) eq 'HTML::Template::VAR') {
2500 7         16 $cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR;
2501             } else {
2502 0         0 $cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP;
2503             }
2504             }
2505              
2506             # push what we've got onto the stacks
2507 32         61 push(@pstack, $cond);
2508 32         48 push(@ifstack, $cond);
2509 32         62 push(@elsifstack, 0);
2510              
2511             } elsif ($which eq 'TMPL_ELSIF') {
2512 3 50       8 $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : ELSIF\n";
2513              
2514 3         7 my $cond = pop(@ifstack);
2515 3 50       8 die "HTML::Template->new() : found with no matching at $fname : line $fcounter."
2516             unless defined $cond;
2517 3 50       8 die "HTML::Template->new() : found incorrectly terminating or at $fname : line $fcounter."
2518             unless ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_IF);
2519             # die "HTML::Template->new() : found tag for at $fname : line $fcounter." if $cond->[HTML::Template::COND::IS_ELSE];
2520              
2521             # $else is masquerading as an TMPL_IF
2522 3         9 my $else = HTML::Template::COND->new($cond->[HTML::Template::COND::VARIABLE]);
2523 3         7 $else->[HTML::Template::COND::WHICH] = $cond->[HTML::Template::COND::WHICH];
2524 3         11 $else->[HTML::Template::COND::JUMP_IF_TRUE] = 0;
2525              
2526             # need end-block resolution?
2527 3 50       7 if (defined($cond->[HTML::Template::COND::VARIABLE_TYPE])) {
2528 0         0 $else->[HTML::Template::COND::VARIABLE_TYPE] = $cond->[HTML::Template::COND::VARIABLE_TYPE];
2529             } else {
2530 3         5 push(@ucstack, $else);
2531             }
2532              
2533 3         4 push(@pstack, $else);
2534 3         5 push(@ifstack, $else);
2535              
2536             # connect the matching to this "address" - thus the IF,
2537             # failing jumps to the ELSE address. The else then gets
2538             # elaborated, and of course succeeds. On the other hand, if
2539             # the IF fails and falls though, output will reach the else
2540             # and jump to the /IF address.
2541 3         6 $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack;
2542              
2543             # if we already have this var, then simply link to the existing
2544             # HTML::Template::VAR/LOOP, else defer the mapping
2545 3         5 my $var;
2546 3 50       7 if (exists $pmap{$name}) {
2547 0         0 $var = $pmap{$name};
2548             } else {
2549 3         4 $var = $name;
2550             }
2551              
2552             # treat elsif as an if, for the jump condition
2553 3         13 my $cond_if = HTML::Template::COND->new($var);
2554 3         5 $cond_if->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_IF;
2555 3         6 $cond_if->[HTML::Template::COND::JUMP_IF_TRUE] = 0;
2556              
2557             # push unconnected conditionals onto the ucstack for
2558             # resolution later. Otherwise, save type information now.
2559 3 50       7 if ($var eq $name) {
2560 3         4 push(@ucstack, $cond_if);
2561             } else {
2562 0 0       0 if (ref($var) eq 'HTML::Template::VAR') {
2563 0         0 $cond_if->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR;
2564             } else {
2565 0         0 $cond_if->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP;
2566             }
2567             }
2568              
2569             # push what we've got onto the stacks
2570 3         5 push(@pstack, $cond_if);
2571 3         5 push(@ifstack, $cond_if);
2572 3         6 $elsifstack[$#elsifstack]++;
2573              
2574             } elsif ($which eq 'TMPL_ELSE') {
2575 19 50       56 $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : ELSE\n";
2576              
2577 19         37 my $cond = pop(@ifstack);
2578 19 50       52 die "HTML::Template->new() : found with no matching or at $fname : line $fcounter." unless defined $cond;
2579 19 100       164 die "HTML::Template->new() : found second tag for or at $fname : line $fcounter." if $cond->[HTML::Template::COND::IS_ELSE];
2580              
2581 18         58 my $else = HTML::Template::COND->new($cond->[HTML::Template::COND::VARIABLE]);
2582 18         40 $else->[HTML::Template::COND::WHICH] = $cond->[HTML::Template::COND::WHICH];
2583 18         33 $else->[HTML::Template::COND::UNCONDITIONAL_JUMP] = 1;
2584 18         43 $else->[HTML::Template::COND::IS_ELSE] = 1;
2585              
2586             # need end-block resolution?
2587 18 100       52 if (defined($cond->[HTML::Template::COND::VARIABLE_TYPE])) {
2588 2         6 $else->[HTML::Template::COND::VARIABLE_TYPE] = $cond->[HTML::Template::COND::VARIABLE_TYPE];
2589             } else {
2590 16         29 push(@ucstack, $else);
2591             }
2592              
2593 18         30 push(@pstack, $else);
2594 18         27 push(@ifstack, $else);
2595              
2596             # connect the matching to this "address" - thus the IF,
2597             # failing jumps to the ELSE address. The else then gets
2598             # elaborated, and of course succeeds. On the other hand, if
2599             # the IF fails and falls though, output will reach the else
2600             # and jump to the /IF address.
2601 18         35 $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack;
2602              
2603             } elsif ($which eq '/TMPL_IF' or $which eq '/TMPL_UNLESS') {
2604 31 50       82 $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : $which end\n";
2605              
2606 31         51 my $elsif_count = pop @elsifstack;
2607 34         54 UNROLL: {
2608 34         37 my $cond = pop(@ifstack);
2609 34 100       84 if ($which eq '/TMPL_IF') {
2610 27 50       61 die "HTML::Template->new() : found with no matching at $fname : line $fcounter." unless defined $cond;
2611 27 50       74 die "HTML::Template->new() : found incorrectly terminating a (use ) at $fname : line $fcounter.\n"
2612             if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_UNLESS);
2613             } else {
2614 7 50       17 die "HTML::Template->new() : found with no matching at $fname : line $fcounter." unless defined $cond;
2615 7 50       20 die "HTML::Template->new() : found incorrectly terminating a (use ) at $fname : line $fcounter.\n"
2616             if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_IF);
2617             }
2618              
2619             # connect the matching to this "address" - place a NOOP to
2620             # hold the spot. This allows output() to treat an IF in the
2621             # assembler-esque "Conditional Jump" mode.
2622 34         58 push(@pstack, $NOOP);
2623 34         61 $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack;
2624             }
2625              
2626             # unroll the ELSIF stack
2627 34 100       293 $elsif_count--, goto UNROLL if $elsif_count;
2628              
2629             } elsif ($which eq 'TMPL_INCLUDE' or $which eq 'TMPL_REQUIRE') {
2630             # handle TMPL_INCLUDEs and TMPL_REQUIRES
2631 39         98 my $w = "".$which;
2632 39         163 $w =~ s/^TMPL_//;
2633 39 50       124 $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : $w $name \n";
2634              
2635             # no includes here, bub
2636 39 100       344 $options->{no_includes} and croak("HTML::Template : Illegal attempt to use TMPL_$w in template file : (no_includes => 1)");
2637              
2638             # display profiling information
2639 38 50       97 $options->{profile} and printf STDERR "### HTML::Template Profile ## template include: %.6f\n", Time::HiRes::time;
2640              
2641 38         65 my $filename = $name;
2642              
2643             # look for the included file...
2644 38         51 my $filepath;
2645 38 100       105 if ($options->{search_path_on_include}) {
2646 4         15 $filepath = $self->_find_file($filename);
2647             } else {
2648 34         372 $filepath = $self->_find_file($filename,
2649             [File::Spec->splitdir($fstack[-1][0])]
2650             );
2651             }
2652              
2653 38 50       153 die "HTML::Template->new() : Cannot open included file $filename : file not found."
2654             unless defined($filepath);
2655              
2656             # if we haven't seen it before or we TMPL_INCLUDE, then load it up.
2657 38 100 100     135 if ($which eq 'TMPL_INCLUDE' or !exists $self->{included_templates}{$filepath}){
2658 37         136 $self->{included_templates}->{$filepath} ++;
2659              
2660 37 50       1401 die "HTML::Template->new() : Cannot open included file $filename : $!"
2661             unless defined(open(TEMPLATE, $filepath));
2662              
2663             # read into the array
2664 37         80 my $included_template = "";
2665 37         1160 while(read(TEMPLATE, $included_template, 10240, length($included_template))) {}
2666 37         391 close(TEMPLATE);
2667              
2668             # call filters if necessary
2669 37 100       57 $self->_call_filters(\$included_template) if @{$options->{filter}};
  37         236  
2670              
2671 37 50       91 if ($included_template) { # not empty
2672              
2673             # collect mtimes for included files
2674 37 100 66     129 if ($options->{cache} and !$options->{blind_cache}) {
2675 4         245 $self->{included_mtimes}{$filepath} = (stat($filepath))[9];
2676             }
2677              
2678             # adjust the fstack to point to the included file info
2679 37         336 push(@fstack, [$filepath, 1,
2680 37         56 scalar @{[$included_template =~ m/(\n)/g]} + 1]);
2681 37         95 (*fname, *fcounter, *fmax) = \ ( @{$fstack[$#fstack]} );
  37         134  
2682              
2683             # make sure we aren't infinitely recursing
2684 37 50       112 if ($options->{includes_debug}) {
2685 0         0 require Data::Dumper;
2686 0         0 print STDERR "TMPL_INCLUDE/TMPL_REQUIRE stack: ", Data::Dumper::Dumper(\@fstack);
2687             }
2688 37 100 66     238 die "HTML::Template->new() : likely recursive includes - parsed $options->{max_includes} files deep and giving up (set max_includes higher to allow deeper recursion)." if ($options->{max_includes} and (scalar(@fstack) > $options->{max_includes}));
2689              
2690             # stick the remains of this chunk onto the bottom of the
2691             # included text.
2692 36         91 $included_template .= $post;
2693 36         53 $post = undef;
2694              
2695             # move the new chunks into place, splitting at '
2696 36         275 splice(@chunks, $chunk_number, 1,
2697             split(m/(?=<(?:\!--\s*)?\/?[Tt][Mm][Pp][Ll]_)/, $included_template));
2698              
2699             # recalculate stopping point
2700 36         70 $last_chunk = $#chunks;
2701              
2702             # start in on the first line of the included text - nothing
2703             # else to do on this line.
2704 36         55 $chunk = $chunks[$chunk_number];
2705              
2706 36         104 redo CHUNK;
2707             }
2708             }
2709             } else {
2710             # zuh!?
2711 0         0 die "HTML::Template->new() : Unknown or unmatched TMPL construct at $fname : line $fcounter.";
2712             }
2713             # push the rest after the tag
2714 448 50       1012 if (defined($post)) {
2715 448 100       1447 if (ref($pstack[$#pstack]) eq 'SCALAR') {
2716 1         3 ${$pstack[$#pstack]} .= $post;
  1         3  
2717             } else {
2718 447         905 push(@pstack, \$post);
2719             }
2720             }
2721              
2722             # custom markup construct
2723             } elsif ($options->{extended_syntax} and
2724             $chunk =~ /^<(?:!--\s*)?
2725             (\/?) # $1 => $slash - start or end of tag marker
2726              
2727             [Tt][Mm][Pp][Ll]_([a-zA-Z0-9_]+) # $2 => $which - custom tag definition
2728              
2729             \s*
2730              
2731             ([^>]*) # $3 => $part - remaining part of custom tag
2732              
2733             >
2734             (.*) # $4 => $post - text that comes after the tag
2735             $/sx) {
2736 0         0 my $objs;
2737 0         0 my $slash = $1;
2738 0         0 my $which = uc($2);
2739 0 0       0 my $part = $3 if length $3;
2740 0 0       0 my $post = $4 if length $4;
2741 0 0       0 $slash = "" unless (defined $slash);
2742 0 0       0 die "Huh? What is the custom tag definition" unless $which;
2743 0 0       0 if (defined $part) {
2744 0         0 $part =~ s/\s*(?:(?:--)|(?:\/))$//;
2745             } else {
2746 0         0 $part = "";
2747             }
2748 0 0       0 $post = "" unless (defined $post);
2749              
2750             # The sub-class is responsible for handling custom constructs
2751 0 0 0     0 ($objs,$post) = $self->handle_tmpl_construct($slash,$which,$part,$post,\%pmap,($options->{parent_global_vars} || $options->{global_vars}) ? \%top_pmap : undef);
2752             # If subclass returned any objects, then we want to keep them on the pstack.
2753 0 0       0 if (defined $objs) {
2754 0 0       0 if (reftype($objs) eq 'ARRAY') {
2755 0         0 push @pstack, @$objs;
2756             } else {
2757 0         0 push @pstack, $objs;
2758             }
2759             }
2760              
2761             # if there is anything after the tag, that is not gobbled up by the sub-class,
2762             # display it in the output.
2763 0 0 0     0 if (defined($post) and length($post)) {
2764 0 0       0 if (ref($pstack[$#pstack]) eq 'SCALAR') {
2765 0         0 ${$pstack[$#pstack]} .= $post;
  0         0  
2766             } else {
2767 0         0 push(@pstack, \$post);
2768             }
2769             }
2770              
2771             } else { # just your ordinary markup
2772             # make sure we didn't reject something TMPL_* but badly formed
2773 124 100       410 if ($options->{strict}) {
2774 120 50       352 die "HTML::Template->new() : Syntax error in tag at $fname : $fcounter." if ($chunk =~ /<(?:!--\s*)?\/?[Tt][Mm][Pp][Ll]_/);
2775             }
2776              
2777             # push the rest and get next chunk
2778 124 50       315 if (defined($chunk)) {
2779 124 100       467 if (ref($pstack[$#pstack]) eq 'SCALAR') {
2780 36         55 ${$pstack[$#pstack]} .= $chunk;
  36         98  
2781             } else {
2782 88         225 push(@pstack, \$chunk);
2783             }
2784             }
2785             }
2786             # count newlines in chunk and advance line count
2787 572         787 $fcounter += scalar(@{[$chunk =~ m/(\n)/g]});
  572         3847  
2788             # if we just crossed the end of an included file
2789             # pop off the record and re-alias to the enclosing file's info
2790 572         2924 while ($fcounter > $fmax) {
2791 26         47 my $counter_offset = $fcounter - $fmax;
2792 26         191 pop(@fstack), (*fname, *fcounter, *fmax) = \ ( @{$fstack[$#fstack]} );
  26         77  
2793 26         122 $fcounter += $counter_offset;
2794             }
2795              
2796             } # next CHUNK
2797              
2798             # make sure we don't have dangling IF or LOOP blocks
2799 203 50       529 scalar(@ifstack) and die "HTML::Template->new() : At least one or not terminated at end of file!";
2800 203 50       6211 scalar(@loopstack) and die "HTML::Template->new() : At least one not terminated at end of file!";
2801              
2802             # resolve pending conditionals
2803 203         488 foreach my $uc (@ucstack) {
2804 42         70 my $var = $uc->[HTML::Template::COND::VARIABLE];
2805 42 100       92 if (exists($pmap{$var})) {
2806 23         46 $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var};
2807             } else {
2808 19         72 $pmap{$var} = HTML::Template::VAR->new();
2809 19 50 33     79 $top_pmap{$var} = HTML::Template::VAR->new()
2810             if $options->{global_vars} and not exists $top_pmap{$var}; #FIXME: should this also check for parent_global_vars ?
2811 19         41 $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var};
2812             }
2813 42 100       131 if (ref($pmap{$var}) eq 'HTML::Template::VAR') {
2814 38         83 $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR;
2815             } else {
2816 4         10 $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP;
2817             }
2818             }
2819              
2820             # want a stack dump?
2821 203 50       681 if ($options->{stack_debug}) {
2822 0         0 require Data::Dumper;
2823 0         0 print STDERR "### HTML::Template _param Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n";
2824             }
2825              
2826             # get rid of filters - they cause runtime errors if Storable tries
2827             # to store them. This can happen under global_vars.
2828 203         470 delete $options->{filter};
2829              
2830             # display profiling information
2831 203 50       561 if ($options->{profile}) {
2832 46     46   605 use vars qw($profile_time_start $profile_time_end $profile_time_difference);
  46         131  
  46         47302  
2833 0         0 $profile_time_end = [gettimeofday];
2834 0         0 printf STDERR "### HTML::Template Profile ## end _parse : %.6f\n", join('.',@$profile_time_end);
2835 0         0 printf STDERR "### HTML::Template Profile ## _parse timing : %.6f\n", tv_interval($profile_time_start,$profile_time_end);
2836 0         0 $profile_time_start = $profile_time_end = [gettimeofday];
2837 0         0 require Math::BigFloat;
2838 0         0 $profile_time_difference = Math::BigFloat->bzero;
2839             }
2840              
2841             # dump params in template
2842 203 50       3127 if ($options->{param_debug}) {
2843 0         0 print STDERR "### HTML::Template Param Dump ###\n\n";
2844 0         0 my @p = $self->param();
2845 0         0 foreach (@p) {
2846 0         0 print STDERR " '$_' => undef $/";
2847             }
2848             }
2849             }
2850              
2851             # we support arbitrary escape types
2852             sub _load_escape_type {
2853 234     234   367 my $self = shift;
2854 234         325 my $escape = shift;
2855 234 100       969 if ($escape =~ /^(?:
2856             "([^"]*)"
2857             |
2858             '([^']*)'
2859             )$/sx) {
2860 68 0       251 $escape = (defined $1) ? $1 : (defined $2) ? $2 : (defined $escape) ? $escape : '';
    50          
    100          
2861             }
2862 234         365 $escape = uc($escape);
2863 234 100 66     1877 return undef if ($escape eq '' || $escape eq '0' || $escape eq 'NONE');
      100        
2864 196 100 100     973 $escape = "ESCAPE" if ($escape eq '1' || $escape eq 'HTML');
2865 46     46   320 use vars qw(%ESCAPE_MAP);
  46         109  
  46         14332  
2866 196 100       803 return $ESCAPE_MAP{$escape} if $ESCAPE_MAP{$escape};
2867 10         24 my $module = "HTML::Template::ESCAPE";
2868 10 100       40 $module .= "::". $escape unless ($escape eq 'ESCAPE');
2869 10         1033 eval 'require '.$module;
2870 10 100       66 die "Failed to locate escape module: $escape (tried loading: $module)" if $@;
2871 9         21 my $esc_obj;
2872 9         942 eval '$esc_obj = '.$module.'->new()';
2873 9 50       44 die "Failed to create escape module: $escape (tried creating: $module)" if $@;
2874 9 50       72 die "Loaded escape module: $escape, but it is not a sub-class of HTML::Template::ESCAPE"
2875             unless (UNIVERSAL::isa($esc_obj,'HTML::Template::ESCAPE'));
2876 9         28 $ESCAPE_MAP{$escape} = $esc_obj;
2877 9         26 return $esc_obj;
2878             }
2879              
2880             # allow subclass a chance at handling customised TMPL_ syntax
2881             # -> default implementation simply dies
2882             sub handle_tmpl_construct {
2883 0     0 0 0 my $self = shift;
2884 0         0 my $slash = shift;
2885 0         0 my $which = shift;
2886 0         0 my $part = shift;
2887 0         0 my $post = shift;
2888 0         0 my $pmap = shift;
2889 0         0 my $top_pmap = shift;
2890 0         0 my $options = $self->{options};
2891              
2892             # die unless user wants non-strict mode
2893 0 0       0 if ($options->{strict}) {
2894 46     46   473 use vars qw($fcounter $fname $fmax);
  46         103  
  46         133850  
2895 0         0 die "HTML::Template->output() : Unknown or unmatched TMPL construct at $fname : line $fcounter.";
2896             }
2897              
2898 0 0       0 $options->{debug} and print STDERR "### HTML::Template Debug ### In handle_tmpl_construct:\nCustom TMPL_ construct '${slash}TMPL_${which}' with content:\n\n", $part, "\n\n";
2899              
2900 0         0 return undef,$post;
2901             }
2902              
2903             # a recursive sub that associates each loop with the loops above
2904             # (treating the top-level as a loop)
2905             sub _globalize_vars {
2906 17     17   114 my $self = shift;
2907              
2908             # associate with the loop (and top-level templates) above in the tree.
2909 17         25 push(@{$self->{options}{associate}}, @_);
  17         84  
2910              
2911             # recurse down into the template tree, adding ourself to the end of
2912             # list.
2913 17         33 push(@_, $self);
2914 11         62 map { $_->_globalize_vars(@_) }
  11         41  
2915 11         14 map {values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]}}
  70         169  
2916 17         24 grep { ref($_) eq 'HTML::Template::LOOP'} @{$self->{parse_stack}};
  17         32  
2917             }
2918              
2919             # method used to recursively un-hook associate
2920             sub _unglobalize_vars {
2921 17     17   26 my $self = shift;
2922              
2923             # disassociate
2924 17         32 $self->{options}{associate} = undef;
2925              
2926             # recurse down into the template tree disassociating
2927 11         32 map { $_->_unglobalize_vars() }
  11         36  
2928 11         14 map {values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]}}
  70         153  
2929 17         28 grep { ref($_) eq 'HTML::Template::LOOP'} @{$self->{parse_stack}};
  17         38  
2930             }
2931              
2932             =head2 param()
2933              
2934             C can be called in a number of ways
2935              
2936             1) To return a list of parameters in the template :
2937              
2938             my @parameter_names = $self->param();
2939              
2940              
2941             2) To return the value set to a param :
2942              
2943             my $value = $self->param('PARAM');
2944              
2945             3) To set the value of a parameter :
2946              
2947             # For simple TMPL_VARs:
2948             $self->param(PARAM => 'value');
2949              
2950             # with a subroutine reference that gets called to get the value
2951             # of the scalar. The sub will recieve the template object as a
2952             # parameter.
2953             $self->param(PARAM => sub { return 'value' });
2954              
2955             # And TMPL_LOOPs:
2956             $self->param(LOOP_PARAM =>
2957             [
2958             { PARAM => VALUE_FOR_FIRST_PASS, ... },
2959             { PARAM => VALUE_FOR_SECOND_PASS, ... }
2960             ...
2961             ]
2962             );
2963              
2964             4) To set the value of a a number of parameters :
2965              
2966             # For simple TMPL_VARs:
2967             $self->param(PARAM => 'value',
2968             PARAM2 => 'value'
2969             );
2970              
2971             # And with some TMPL_LOOPs:
2972             $self->param(PARAM => 'value',
2973             PARAM2 => 'value',
2974             LOOP_PARAM =>
2975             [
2976             { PARAM => VALUE_FOR_FIRST_PASS, ... },
2977             { PARAM => VALUE_FOR_SECOND_PASS, ... }
2978             ...
2979             ],
2980             ANOTHER_LOOP_PARAM =>
2981             [
2982             { PARAM => VALUE_FOR_FIRST_PASS, ... },
2983             { PARAM => VALUE_FOR_SECOND_PASS, ... }
2984             ...
2985             ]
2986             );
2987              
2988             5) To set the value of a a number of parameters using a hash-ref :
2989              
2990             $self->param(
2991             {
2992             PARAM => 'value',
2993             PARAM2 => 'value',
2994             LOOP_PARAM =>
2995             [
2996             { PARAM => VALUE_FOR_FIRST_PASS, ... },
2997             { PARAM => VALUE_FOR_SECOND_PASS, ... }
2998             ...
2999             ],
3000             ANOTHER_LOOP_PARAM =>
3001             [
3002             { PARAM => VALUE_FOR_FIRST_PASS, ... },
3003             { PARAM => VALUE_FOR_SECOND_PASS, ... }
3004             ...
3005             ]
3006             }
3007             );
3008              
3009             An error occurs if you try to set a value that is tainted if the "force_untaint"
3010             option is set.
3011              
3012             =cut
3013              
3014              
3015             sub param {
3016 366     366 1 17462 my $self = shift;
3017 366         702 my $options = $self->{options};
3018 366         508 my $param_map = $self->{param_map};
3019              
3020             # the no-parameter case - return list of parameters in the template.
3021 366 50       949 return keys(%$param_map) unless scalar(@_);
3022              
3023 366         519 my $first = shift;
3024 366         1021 my $type = reftype($first);
3025              
3026             # the one-parameter case - could be a parameter value request or a
3027             # hash-ref.
3028 366 100 66     1266 if (!scalar(@_) and !length($type)) {
3029 78 100       222 my $param = $options->{case_sensitive} ? $first : lc $first;
3030              
3031             # check for parameter existence
3032 78 100 100     445 $options->{die_on_bad_params} and !exists($param_map->{$param}) and
3033             croak("HTML::Template : Attempt to get nonexistent parameter '$param' - this parameter name doesn't match any declarations in the template file : (die_on_bad_params set => 1)");
3034              
3035 77 100 66     516 return undef unless (exists($param_map->{$param}) and
3036             defined($param_map->{$param}));
3037              
3038 67 100       182 return ${$param_map->{$param}} if
  60         253  
3039             (ref($param_map->{$param}) eq 'HTML::Template::VAR');
3040 7         35 return $param_map->{$param}[HTML::Template::LOOP::PARAM_SET];
3041             }
3042              
3043 288 100       678 if (!scalar(@_)) {
3044 59 100 100     305 croak("HTML::Template->param() : Single reference arg to param() must be a hash-ref! You gave me a $type.")
3045             unless $type eq 'HASH' or UNIVERSAL::isa($first, 'HASH');
3046 58         265 push(@_, %$first);
3047             } else {
3048 229         525 unshift(@_, $first);
3049             }
3050              
3051 287 100       1148 croak("HTML::Template->param() : You gave me an odd number of parameters to param()!")
3052             unless ((@_ % 2) == 0);
3053              
3054             # strangely, changing this to a "while(@_) { shift, shift }" type
3055             # loop causes perl 5.004_04 to die with some nonsense about a
3056             # read-only value.
3057 286         981 for (my $x = 0; $x <= $#_; $x += 2) {
3058 443 100       1725 my $param = $options->{case_sensitive} ? $_[$x] : lc $_[$x];
3059 443         716 my $value = $_[($x + 1)];
3060              
3061             # check that this param exists in the template
3062 443 50 100     3234 $options->{die_on_bad_params} and not $options->{recursive_templates} and !exists($param_map->{$param}) and not reftype($value) eq 'HASH' and
      66        
      33        
3063             croak("HTML::Template : Attempt to set nonexistent parameter '$param' - this parameter name doesn't match any declarations in the template file : (die_on_bad_params => 1)");
3064              
3065             # When using recurisve templates, we keep the unmatched params around
3066             # for subsequent instances.
3067 443 100 100     1134 $options->{recursive_templates} and !exists($param_map->{$param}) and not reftype($value) eq 'HASH' and $self->{recursive_template_params}->{$param} = $value;
      66        
3068              
3069             # if we want structure-esque variables, we had better check here...
3070 443 100 100     1233 if ($options->{structure_vars} and $param =~ /\./) {
3071 1         4 $self->{structure_vars}->{$param} = $value;
3072              
3073             # Break down full-length variable into structure-esque parts. Note
3074             # that we handle the full-length variable in the normal code-path.
3075 1         5 my @structure_vars = split(/\./,$param);
3076 1         3 pop @structure_vars;
3077              
3078             # Build up structure param name and check if not already defined.
3079 1         2 my $structure_param = "";
3080 1         2 foreach my $structure_var (@structure_vars) {
3081 1         4 $structure_param .= $structure_var;
3082              
3083             # Auto-vivify structure-esque variable, but only if:
3084             # - defined in param map,
3085             # - not already set,
3086             # - if used in TMPL_VAR/TMPL_IF context
3087             # Otherwise we simply Skip setting unused structure-esque
3088             # value.
3089 1 50 33     9 if (exists($param_map->{$structure_param}) and !exists($self->{structure_vars}->{$structure_param})) {
3090 1         3 $self->{structure_vars}->{$structure_param} = 1;
3091 1         3 my $structure_param_type = ref($param_map->{$structure_param});
3092 1 50       4 if ($structure_param_type eq 'HTML::Template::VAR') {
    0          
3093 1 50       2 unless (defined ${$param_map->{$structure_param}}) {
  1         5  
3094 1         1 ${$param_map->{$structure_param}} = 1;
  1         2  
3095 1 50       5 $options->{debug} and print STDERR "Auto-vivify TMPL_VAR structure-param: $structure_param\n";
3096             }
3097             } elsif ($structure_param_type eq 'HTML::Template::LOOP') {
3098 0 0       0 unless (defined $param_map->{$structure_param}[HTML::Template::LOOP::PARAM_SET]) {
3099 0         0 $param_map->{$structure_param}[HTML::Template::LOOP::PARAM_SET] = [];
3100 0 0       0 $options->{debug} and print STDERR "Auto-vivify TMPL_LOOP structure-param: $structure_param\n";
3101             }
3102             } else {
3103 0         0 croak("HTML::Template->param() : attempt to set parameter structure param '$structure_param' but template param is '$structure_param_type'");
3104             }
3105             }
3106              
3107 1         3 $structure_param .= '.';
3108             }
3109             }
3110              
3111             # if we're not going to die from bad param names, we need to ignore
3112             # them...
3113 443 100       1088 unless (exists($param_map->{$param})) {
3114 7 100 66     65 next if (not ($options->{parent_global_vars} or $options->{global_vars}));
3115              
3116             # ... unless global_vars is on - in which case we can't be
3117             # sure we won't need it in a lower loop.
3118 2 100       4 if (reftype($value) eq 'ARRAY') {
    50          
3119 1         4 $param_map->{$param} = HTML::Template::LOOP->new();
3120              
3121             } elsif (reftype($value) eq 'HASH') {
3122 0 0       0 my $sep = $options->{structure_vars} ? "." : "_";
3123 0         0 foreach my $key (keys %{$value}) {
  0         0  
3124 0         0 $self->param($param.$sep.$key => $value->{$key});
3125             }
3126              
3127             } else {
3128 1         3 $param_map->{$param} = HTML::Template::VAR->new();
3129             }
3130             }
3131              
3132             # figure out what we've got, taking special care to allow for
3133             # objects that are compatible underneath.
3134 438         1108 my $value_type = reftype($value);
3135              
3136             # handle array/TMPL_LOOP
3137 438 100 66     4410 if (defined($value_type) and length($value_type) and ($value_type eq 'ARRAY' or ((reftype($value) !~ /^(CODE)|(HASH)|(SCALAR)$/) and UNIVERSAL::isa($value,'ARRAY')))) {
    100 66        
      66        
      66        
      100        
      66        
3138 27 50       94 (ref($param_map->{$param}) eq 'HTML::Template::LOOP') or
3139             croak("HTML::Template::param() : attempt to set parameter '$param' with an array ref - parameter is not a TMPL_LOOP!");
3140 27 100 66     111 if (scalar(@$value) > 0 and reftype($value->[0]) ne 'HASH') {
3141 1 50       4 $options->{scalar_loops} or
3142             croak("HTML::Template::param() : attempt to set parameter '$param' with an arrayref - \$$param\->[0] is not a hashmap");
3143 1         2 my $v = [];
3144 1         3 foreach (@$value) {
3145 2         7 push @$v, { __value__ => $_ };
3146             }
3147 1         3 $value = $v;
3148             }
3149 27         52 $param_map->{$param}[HTML::Template::LOOP::PARAM_SET] = [@{$value}];
  27         205  
3150              
3151             # handle expansion hash into sub-TMPL_VAR's and sub-TMPL_LOOP's
3152             } elsif (defined($value_type) and length($value_type) and ($value_type eq 'HASH') and UNIVERSAL::isa($value,'HASH')) {
3153 2 100       7 my $sep = $options->{structure_vars} ? "." : "_";
3154 2         3 foreach my $key (keys %{$value}) {
  2         8  
3155 2         32 $self->param($param.$sep.$key => $value->{$key});
3156             }
3157              
3158             # handle scalar/TMPL_VAR
3159             } else {
3160 409 50       1485 (ref($param_map->{$param}) eq 'HTML::Template::VAR') or
3161             croak("HTML::Template::param() : attempt to set parameter '$param' with a scalar - parameter is not a TMPL_VAR!");
3162 409         478 ${$param_map->{$param}} = $value;
  409         2663  
3163             }
3164             }
3165             }
3166              
3167             =pod
3168              
3169             =head2 clear_params()
3170              
3171             Sets all the parameters to undef. Useful internally, if nowhere else!
3172              
3173             =cut
3174              
3175             sub clear_params {
3176 70     70 1 154 my $self = shift;
3177 70         153 my $type;
3178 70         86 foreach my $name (keys %{$self->{param_map}}) {
  70         437  
3179 238         414 $type = ref($self->{param_map}{$name});
3180 238 100       607 undef(${$self->{param_map}{$name}})
  228         540  
3181             if ($type eq 'HTML::Template::VAR');
3182 238 100       663 undef($self->{param_map}{$name}[HTML::Template::LOOP::PARAM_SET])
3183             if ($type eq 'HTML::Template::LOOP');
3184             }
3185             }
3186              
3187              
3188             # obsolete implementation of associate
3189             sub associateCGI {
3190 2     2 0 6897 my $self = shift;
3191 2         4 my $cgi = shift;
3192 2 100       160 (ref($cgi) eq 'CGI') or
3193             croak("Warning! non-CGI object was passed to HTML::Template::associateCGI()!\n");
3194 1         3 push(@{$self->{options}{associate}}, $cgi);
  1         4  
3195 1         4 return 1;
3196             }
3197              
3198              
3199             =head2 output()
3200              
3201             output() returns the final result of the template. In most situations
3202             you'll want to print this, like:
3203              
3204             print $template->output();
3205              
3206             When output is called each occurrence of is
3207             replaced with the value assigned to "name" via C. If a named
3208             parameter is unset, HTML::Template will die indicating that the template
3209             variable hasn't been set. This behaviour can be altered so that it wont
3210             die, by setting C, in which case it is simply
3211             replaced with ''. are evaluated once per parameter set,
3212             accumlating output on each pass.
3213              
3214             Calling output() is guaranteed not to change the state of the
3215             Template object, in case you were wondering. This property is mostly
3216             important for the internal implementation of loops.
3217              
3218             You may optionally supply a filehandle to print to automatically as
3219             the template is generated. This may improve performance and lower
3220             memory consumption. Example:
3221              
3222             $template->output(print_to => *STDOUT);
3223              
3224             The return value is undefined when using the C option.
3225              
3226             Alternatively, you may optionally return the generated output 'by
3227             reference'. This may improve performance by avoiding the copying of
3228             data from the HTML::Template variable into your application variable.
3229             Example:
3230              
3231             my $output = $template->output(by_reference => 1);
3232             print $$output;
3233              
3234             =cut
3235              
3236             sub output {
3237 460     460 1 127028 my $self = shift;
3238 460         20277 my $options = $self->{options};
3239 460         653 local $_;
3240              
3241 460 50       1272 croak("HTML::Template->output() : You gave me an odd number of parameters to output()!")
3242             unless ((@_ % 2) == 0);
3243 460         843 my %args = @_;
3244              
3245             # dump params in template
3246 460 50       1180 if ($options->{param_debug}) {
3247 0         0 print STDERR "### HTML::Template Param Dump ###\n\n";
3248 0         0 my @p = $self->param();
3249 0         0 foreach (@p) {
3250 0         0 my $v = $self->param($_);
3251 0 0       0 $v = defined $v ? "'$v'" : "undef";
3252 0         0 print STDERR " '$_' => $v $/";
3253             }
3254             }
3255              
3256 460 50       1006 print STDERR "### HTML::Template Memory Debug ### START OUTPUT ", $self->{proc_mem}->size(), "\n"
3257             if $options->{memory_debug};
3258              
3259 460 50       1179 $options->{debug} and print STDERR "### HTML::Template Debug ### In output\n";
3260              
3261             # want a stack dump?
3262 460 50       1545 if ($options->{stack_debug}) {
3263 0         0 require Data::Dumper;
3264 0         0 print STDERR "### HTML::Template output Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n";
3265             }
3266              
3267             # display profiling information
3268 460 50       1030 if ($options->{profile}) {
3269 46     46   474 use vars qw($profile_time_start $profile_time_end $profile_time_difference);
  46         119  
  46         26795  
3270 0         0 $profile_time_start = [gettimeofday];
3271 0         0 $profile_time_difference += tv_interval($profile_time_end,$profile_time_start);
3272 0         0 $profile_time_end = [gettimeofday];
3273 0         0 printf STDERR "### HTML::Template Profile ## begin output : %.6f (%.6f)\n", join('.',@$profile_time_start), $profile_time_difference;
3274             }
3275              
3276             # globalize vars - this happens here to localize the circular
3277             # references created by global_vars.
3278 460 100       1131 $self->_globalize_vars() if $options->{global_vars}; #FIXME: should this also check for parent_global_vars ?
3279              
3280             # support the associate magic, searching for undefined params and
3281             # attempting to fill them from the associated objects.
3282 460 100       509 if (scalar(@{$options->{associate}})) {
  460         1210  
3283 20         34 my @undef_params;
3284 20         53 foreach my $param (keys %{$self->{param_map}}) {
  20         64  
3285 34 100       71 next if (defined $self->param($param));
3286 16         36 push @undef_params, $param;
3287             }
3288 20 100       59 if (scalar(@undef_params)) {
3289 11         11 my $value;
3290             # if case sensitive mode or no CGI objects, we can use the fast path
3291 11 100 66     45 if ($options->{case_sensitive} or (grep { !/^1/ } map { UNIVERSAL::isa($_,'HTML::Template') } @{$options->{associate}}) == 0) {
  19         105  
  19         86  
  11         35  
3292 10         19 foreach my $param (@undef_params) {
3293 15         20 foreach my $associated_object (reverse @{$options->{associate}}) {
  15         29  
3294 23         45 $value = $associated_object->param($param);
3295 23 100       59 next unless (defined $value);
3296 15         33 $self->param($param, scalar $value);
3297 15         47 last;
3298             }
3299             }
3300             } else {
3301 1         4 my %case_map;
3302 1         3 foreach my $associated_object (@{$options->{associate}}) {
  1         4  
3303 1         6 map { $case_map{$associated_object}{lc($_)} = $_ } $associated_object->param();
  1         37  
3304             }
3305 1         3 my $associated_param;
3306 1         3 foreach my $param (@undef_params) {
3307 1         2 foreach my $associated_object (reverse @{$options->{associate}}) {
  1         4  
3308 1         4 $associated_param = $case_map{$associated_object}{$param};
3309 1 50       5 next unless (defined $associated_param);
3310 1         4 $value = $associated_object->param($associated_param);
3311 1 50       28 next unless (defined $value);
3312 1         5 $self->param($param, scalar $value);
3313 1         7 last;
3314             }
3315             }
3316             }
3317             }
3318             }
3319              
3320             # # support the associate magic, searching for undefined params and
3321             # # attempting to fill them from the associated objects.
3322             # if (scalar(@{$options->{associate}})) {
3323             # # prepare case-mapping hashes to do case-insensitive matching
3324             # # against associated objects. This allows CGI.pm to be
3325             # # case-sensitive and still work with asssociate.
3326             # my (%case_map, $lparam);
3327             # foreach my $associated_object (@{$options->{associate}}) {
3328             # # what a hack! This should really be optimized out for case_sensitive.
3329             # if ($options->{case_sensitive}) {
3330             # map {
3331             # $case_map{$associated_object}{$_} = $_
3332             # } $associated_object->param();
3333             # } else {
3334             # map {
3335             # $case_map{$associated_object}{lc($_)} = $_
3336             # } $associated_object->param();
3337             # }
3338             # }
3339             #
3340             # foreach my $param (keys %{$self->{param_map}}) {
3341             # unless (defined($self->param($param))) {
3342             # OBJ: foreach my $associated_object (reverse @{$options->{associate}}) {
3343             # $self->param($param, scalar $associated_object->param($case_map{$associated_object}{$param})), last OBJ
3344             # if (exists($case_map{$associated_object}{$param}));
3345             # }
3346             # }
3347             # }
3348             # }
3349              
3350              
3351 46     46   292 use vars qw($line @parse_stack); local(*line, *parse_stack);
  46         97  
  46         115180  
  460         1661  
3352              
3353             # walk the parse stack, accumulating output in $result
3354             # with unset params stored in @unset_params.
3355 460         819 *parse_stack = $self->{parse_stack};
3356 460         646 my $result = '';
3357 460         491 my @unset_params;
3358              
3359 460 100 66     1305 tie $result, 'HTML::Template::PRINTSCALAR', $args{print_to}
3360             if defined $args{print_to} and not tied $args{print_to};
3361              
3362 460 50 66     1168 die "HTML::Template::output() : Cannot use 'print_to' and 'recursive_templates' together."
3363             if ($options->{recursive_templates} && $args{print_to});
3364              
3365 460         616 my $type;
3366 460         813 my $parse_stack_length = $#parse_stack;
3367 460         1712 for (my $x = 0; $x <= $parse_stack_length; $x++) {
3368 1760         4352 *line = \$parse_stack[$x];
3369 1760         3404 $type = ref($line);
3370              
3371 1760 100 100     6942 if ($type eq 'SCALAR') { #FIXME: do we need to test for the reftype? if so, we should more this case further down.
    100 33        
    100          
    100          
    100          
    100          
    100          
    50          
3372 946         2685 $result .= $$line;
3373             } elsif ($type eq 'HTML::Template::VAR' and reftype($$line) eq 'CODE') {
3374 9 50       38 if ( defined($$line) ) {
    0          
3375 9 100       28 if ($options->{force_untaint}) {
3376 1         5 my $tmp = $$line->($self);
3377 1 50       123 croak("HTML::Template->output() : 'force_untaint' option but coderef returns tainted value")
3378             if tainted($tmp);
3379 0         0 $result .= $tmp;
3380             } else {
3381 8         34 $result .= $$line->($self);
3382             }
3383             } elsif ($options->{die_on_unset_params}) {
3384 0         0 croak("HTML::Template : Unset TMPL_VAR CODE block : (die_on_unset_params => $options->{die_on_unset_params})");
3385             }
3386             } elsif ($type eq 'HTML::Template::VAR') {
3387 189 100       458 if (defined $$line) {
    50          
3388 179 100 66     604 if ($options->{force_untaint} && tainted($$line)) {
3389 1         163 croak("HTML::Template->output() : tainted value with 'force_untaint' option");
3390             }
3391 178 50 33     7821 $result .= $$line unless (ref($line) eq 'HTML::Template::UNDEF' or ref($$line) eq 'HTML::Template::UNDEF');
3392             } elsif ($options->{die_on_unset_params}) {
3393 0         0 keys %{$self->{param_map}};
  0         0  
3394 0         0 while (my ($key,$value) = each %{$self->{param_map}}) {
  0         0  
3395 0 0       0 next if ("$line" ne "$value");
3396 0 0       0 croak("HTML::Template : Unset TMPL_VAR param '$key' - this param doesn't match any set by HTML::Template->param($key => ...) : (die_on_unset_params => 1, case_sensitive => $options->{case_sensitive})")
3397             if ($options->{die_on_unset_params} == 1);
3398 0         0 push @unset_params, [$key,"TMPL_VAR"];
3399             }
3400             }
3401             } elsif ($type eq 'HTML::Template::LOOP') {
3402 33 100       113 if (defined($line->[HTML::Template::LOOP::PARAM_SET])) {
    50          
3403 27         37 eval { $result .= $line->output($x, $options->{loop_context_vars}); };
  27         121  
3404 27 50       110 croak("HTML::Template->output() : fatal error in loop output : $@")
3405             if $@;
3406             } elsif ($options->{die_on_unset_params}) {
3407 0         0 keys %{$self->{param_map}};
  0         0  
3408 0         0 while (my ($key,$value) = each %{$self->{param_map}}) {
  0         0  
3409 0 0       0 next if ("$line" ne "$value");
3410 0 0       0 croak("HTML::Template : Unset TMPL_LOOP param '$key' - this param doesn't match any set by HTML::Template->param($key => ...) : (die_on_unset_params => 1, case_sensitive => $options->{case_sensitive})")
3411             if ($options->{die_on_unset_params} == 1);
3412 0         0 push @unset_params, [$key,"TMPL_LOOP"];
3413             }
3414             }
3415             } elsif ($type eq 'HTML::Template::COND') {
3416 370 100       757 if ($line->[HTML::Template::COND::UNCONDITIONAL_JUMP]) {
3417 124         564 $x = $line->[HTML::Template::COND::JUMP_ADDRESS]
3418             } else {
3419 246 100       458 if ($line->[HTML::Template::COND::JUMP_IF_TRUE]) { # UNLESS path
3420 11 50       29 if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) {
3421 11 100       12 if (defined ${$line->[HTML::Template::COND::VARIABLE]}) {
  11 50       42  
3422 10 100       14 if (reftype(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') {
  10 50       23  
  9         31  
3423 1 50       2 $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]}->($self);
  1         4  
3424             } elsif (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'HTML::Template::UNDEF') {
3425             #$x = $line->[HTML::Template::COND::JUMP_ADDRESS];
3426             } else {
3427 9 100       67 $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]};
  9         49  
3428             }
3429             } elsif ($options->{die_on_unset_params}) {
3430 0         0 keys %{$self->{param_map}};
  0         0  
3431 0         0 while (my ($key,$value) = each %{$self->{param_map}}) {
  0         0  
3432 0 0       0 next if ("".$line->[HTML::Template::COND::VARIABLE] ne "$value");
3433 0 0       0 croak("HTML::Template : Unset TMPL_UNLESS param '$key' - this param doesn't match any set by HTML::Template->param($key => ...) : (die_on_unset_params => 1, case_sensitive => $options->{case_sensitive})")
3434             if ($options->{die_on_unset_params} == 1);
3435 0         0 push @unset_params, [$key,"TMPL_UNLESS"];
3436             }
3437             }
3438             } else {
3439 0         0 $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if
3440             (defined $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] and
3441 0 0 0     0 scalar @{$line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]});
3442             }
3443             } else { # IF path
3444 235 100       434 if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) {
3445 233 100       240 if (defined ${$line->[HTML::Template::COND::VARIABLE]}) {
  233 50       582  
3446 226 100       270 if (reftype(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') {
  226 50       527  
  25         81  
3447 201 100       245 $x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]}->($self);
  201         615  
3448             } elsif (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'HTML::Template::UNDEF') {
3449 0         0 $x = $line->[HTML::Template::COND::JUMP_ADDRESS];
3450             } else {
3451 25 100       29 $x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]};
  25         244  
3452             }
3453             } elsif ($options->{die_on_unset_params}) {
3454 0         0 keys %{$self->{param_map}};
  0         0  
3455 0         0 while (my ($key,$value) = each %{$self->{param_map}}) {
  0         0  
3456 0 0       0 next if ("".$line->[HTML::Template::COND::VARIABLE] ne "$value");
3457 0 0       0 croak("HTML::Template : Unset TMPL_IF param '$key' - this param doesn't match any set by HTML::Template->param($key => ...) : (die_on_unset_params => 1, case_sensitive => $options->{case_sensitive})")
3458             if ($options->{die_on_unset_params} == 1);
3459 0         0 push @unset_params, [$key,"TMPL_IF"];
3460             }
3461             } else {
3462 7         25 $x = $line->[HTML::Template::COND::JUMP_ADDRESS];
3463             }
3464             } else {
3465 1         6 $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if
3466             (not defined $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] or
3467 2 100 66     14 not scalar @{$line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]});
3468             }
3469             }
3470             }
3471             } elsif ($type eq 'HTML::Template::NOOP') {
3472 113         255 next;
3473             } elsif ($type eq 'HTML::Template::DEFAULT') {
3474 25         41 $_ = $x; # remember default place in stack
3475              
3476             # find next VAR, there might be an ESCAPE in the way
3477 25         42 *line = \$parse_stack[++$x];
3478 25 100 66     180 *line = \$parse_stack[++$x] if (ref $line and UNIVERSAL::isa($line,'HTML::Template::ESCAPE'));
3479              
3480             # either output the default or go back
3481 25 100       55 if (defined $$line) {
3482 4         8 $x = $_;
3483             } else {
3484 21         24 $result .= ${$parse_stack[$_]};
  21         45  
3485             }
3486 25         240 next;
3487             } elsif ($type and UNIVERSAL::isa($line,'HTML::Template::ESCAPE')) {
3488 75         111 my $obj = $line;
3489 75         155 *line = \$parse_stack[++$x];
3490 75         227 my $line_type = ref($line);
3491 75 50 66     1177 if ($line_type eq 'SCALAR') {
    100 0        
    50          
    0          
3492 0         0 $_ = $$line;
3493             } elsif ($line_type eq 'HTML::Template::VAR' and reftype($$line) eq 'CODE') {
3494 4 50       7 if ($options->{force_untaint}) {
3495 0         0 my $tmp = $$line->($self);
3496 0 0       0 croak("HTML::Template->output() : 'force_untaint' option but coderef returns tainted value")
3497             if tainted($tmp);
3498 0         0 $_ = $tmp;
3499             } else {
3500 4         10 $_ = $$line->($self);
3501             }
3502             } elsif ($line_type eq 'HTML::Template::VAR') {
3503 71 50       182 if (defined($$line)) {
3504 71 50 33     233 if ($options->{force_untaint} > 1 && tainted($$line)) {
3505 0         0 croak("HTML::Template->output() : tainted value with 'force_untaint' option");
3506             }
3507 71         120 $_ = $$line;
3508             }
3509             } elsif ($line_type and $line->can('output')) {
3510 0         0 my $tmp = $line->output();
3511 0 0 0     0 if ($options->{force_untaint} > 1 && tainted($tmp)) {
3512 0         0 croak("HTML::Template->output() : tainted value with 'force_untaint' option");
3513             }
3514 0         0 $_ = $tmp;
3515             } else {
3516 0         0 die "HTML::Template::output() : unknown construct in param stack: type: $line_type";
3517             }
3518 75         412 my $tmp = $obj->output($_);
3519 75 50 33     256 if ($options->{force_untaint} > 1 && tainted($tmp)) {
3520 0         0 croak("HTML::Template->output() : tainted value with 'force_untaint' option");
3521             }
3522 75         142 $result .= $tmp;
3523 75         237 next;
3524             } else {
3525 0   0     0 my ($output,$jump_address) = $self->handle_parse_stack_construct($x,$type,$line,$options->{force_untaint} || 0);
3526 0 0 0     0 $result .= $output if (defined $output and length $output);
3527 0 0       0 $x = $jump_address if (defined $jump_address);
3528             }
3529             }
3530              
3531             # undo the globalization circular refs
3532 458 100       1138 $self->_unglobalize_vars() if $options->{global_vars}; #FIXME: should this also check for parent_global_vars ?
3533              
3534             # If there are any unset params, then we need to die
3535 458 50       1131 if (@unset_params > 0) {
3536 0         0 my $list = join($/,map { $_->[0] ." => ". $_->[1] } @unset_params);
  0         0  
3537 0         0 croak("HTML::Template : The following TMPL_xxx params are unset - they do not match any set by HTML::Template->param(name => ...) : (die_on_unset_params => 2, case_sensitive => $options->{case_sensitive}):$/$list$/")
3538             }
3539              
3540             # display profiling information
3541 458 50       1133 if ($options->{profile}) {
3542 46     46   382 use vars qw($profile_time_start $profile_time_end $profile_time_difference);
  46         117  
  46         76998  
3543 0         0 $profile_time_end = [gettimeofday];
3544 0         0 $profile_time_difference += tv_interval($profile_time_start,$profile_time_end);
3545 0         0 $profile_time_start = [gettimeofday];
3546 0         0 printf STDERR "### HTML::Template Profile ## end output : %.6f (%.6f)\n", join('.',@$profile_time_end), $profile_time_difference;
3547             }
3548              
3549 458 50       993 print STDERR "### HTML::Template Memory Debug ### END OUTPUT ", $self->{proc_mem}->size(), "\n"
3550             if $options->{memory_debug};
3551              
3552             # we dont (yet) support recursive templates when printing to a specific file handle
3553             # so we exit immediately
3554 458 100       1058 return undef if defined $args{print_to};
3555              
3556             # From here on in, $output is a reference to the result
3557 457         662 my $output = \$result;
3558              
3559             # recurse into template, if user wanted recursion
3560 457 100 66     1456 if ($options->{recursive_templates} and $$output =~ /<(?:\!--\s*)?[Tt][Mm][Pp][Ll]_/) {
3561 1 50       3 $options->{profile} and printf STDERR "### HTML::Template Profile ## recursive template %.6f\n", Time::HiRes::time;
3562              
3563 1         2 my $opts = {};
3564 1         3 my %skip = map { $_ => 1 } qw( filename recursive_templates cache shared_cache blind_cache );
  5         12  
3565 1         17 foreach (keys %$options) {
3566 38 100       69 next if $skip{$_};
3567 34 100       61 next unless defined $options->{$_};
3568 33         51 $opts->{$_} = $options->{$_};
3569             }
3570 1         4 push @{$opts->{associate}}, $self;
  1         3  
3571              
3572             # recurse into the resultant template output, but only if
3573             # - we haven't hit an upper limit
3574             # - there exists some form of '
3575 1         3 my $recursions = $options->{recursive_templates};
3576 1   66     11 for (; $recursions && $$output =~ /<(?:\!--\s*)?[Tt][Mm][Pp][Ll]_/; $recursions--) {
3577 1         2 $opts->{scalarref} = $output;
3578 1         2 eval {
3579 1         20 my $ht = ref($self)->new(%$opts);
3580 1         4 $ht->param(%{$self->{recursive_template_params}});
  1         4  
3581 1         24 $output = $ht->output(by_reference => 1);
3582             };
3583 1 50       10 croak("HTML::Template->output : failure to parse recursive template instance. The error was: $@")
3584             if ($@);
3585             }
3586             }
3587              
3588             # does user want to pass data back by reference, or by value?
3589 457 100       946 if ($args{by_reference}) {
3590 1         18 return $output;
3591             } else {
3592 456         2293 return $$output;
3593             }
3594             }
3595              
3596             sub handle_parse_stack_construct {
3597 0     0 0 0 my $self = shift;
3598 0         0 my $index = shift;
3599 0         0 my $type = shift;
3600 0         0 my $tmpl_obj = shift;
3601 0         0 my $force_untaint = shift;
3602 0         0 confess("HTML::Template::output() : Unknown item in parse_stack : " . $type);
3603             }
3604              
3605             =pod
3606              
3607             =head2 query()
3608              
3609             This method allows you to get information about the template structure.
3610             It can be called in a number of ways. The simplest usage of query is
3611             simply to check whether a parameter name exists in the template, using
3612             the C option:
3613              
3614             if ($template->query(name => 'foo')) {
3615             # do something if a varaible of any type
3616             # named FOO is in the template
3617             }
3618              
3619             This same usage returns the type of the parameter. The type is the
3620             same as the tag minus the leading 'TMPL_'. So, for example, a
3621             TMPL_VAR parameter returns 'VAR' from C.
3622              
3623             if ($template->query(name => 'foo') eq 'VAR') {
3624             # do something if FOO exists and is a TMPL_VAR
3625             }
3626              
3627             Note that the variables associated with TMPL_IFs and TMPL_UNLESSs will
3628             be identified as 'VAR' unless they are also used in a TMPL_LOOP, in
3629             which case they will return 'LOOP'.
3630              
3631             C also allows you to get a list of parameters inside a loop
3632             (and inside loops inside loops). Example loop:
3633              
3634            
3635            
3636            
3637            
3638            
3639            
3640            
3641            
3642              
3643             And some query calls:
3644              
3645             # returns 'LOOP'
3646             $type = $template->query(name => 'EXAMPLE_LOOP');
3647              
3648             # returns ('bop', 'bee', 'example_inner_loop')
3649             @param_names = $template->query(loop => 'EXAMPLE_LOOP');
3650              
3651             # both return 'VAR'
3652             $type = $template->query(name => ['EXAMPLE_LOOP', 'BEE']);
3653             $type = $template->query(name => ['EXAMPLE_LOOP', 'BOP']);
3654              
3655             # and this one returns 'LOOP'
3656             $type = $template->query(name => ['EXAMPLE_LOOP',
3657             'EXAMPLE_INNER_LOOP']);
3658              
3659             # and finally, this returns ('inner_bee', 'inner_bop')
3660             @inner_param_names = $template->query(loop => ['EXAMPLE_LOOP',
3661             'EXAMPLE_INNER_LOOP']);
3662              
3663             # for non existent parameter names you get undef
3664             # this returns undef.
3665             $type = $template->query(name => 'DWEAZLE_ZAPPA');
3666              
3667             # calling loop on a non-loop parameter name will cause an error.
3668             # this dies:
3669             $type = $template->query(loop => 'DWEAZLE_ZAPPA');
3670              
3671             As you can see above the C option returns a list of parameter
3672             names and both C and C take array refs in order to refer
3673             to parameters inside loops. It is an error to use C with a
3674             parameter that is not a loop.
3675              
3676             Note that all the names are returned in lowercase and the types are
3677             uppercase.
3678              
3679             Just like C, C with no arguments returns all the
3680             parameter names in the template at the top level.
3681              
3682             =cut
3683              
3684             sub query {
3685 6     6 1 221 my $self = shift;
3686 6 50       24 $self->{options}{debug} and print STDERR "### HTML::Template Debug ### query(", join(', ', @_), ")\n";
3687              
3688             # the no-parameter case - return $self->param()
3689 6 50       16 return $self->param() unless scalar(@_);
3690              
3691 6 50       16 croak("HTML::Template::query() : Odd number of parameters passed to query!")
3692             if (scalar(@_) % 2);
3693 6 50       17 croak("HTML::Template::query() : Wrong number of parameters passed to query - should be 2.")
3694             if (scalar(@_) != 2);
3695              
3696 6         16 my ($opt, $path) = (lc shift, shift);
3697 6 50 66     26 croak("HTML::Template::query() : invalid parameter ($opt)")
3698             unless ($opt eq 'name' or $opt eq 'loop');
3699              
3700             # make path an array unless it already is
3701 6 100       20 $path = [$path] unless (ref $path);
3702              
3703             # find the param in question.
3704 6         20 my @objs = $self->_find_param(@$path);
3705 6 50       23 return undef unless scalar(@objs);
3706 6         11 my ($obj, $type);
3707              
3708             # do what the user asked with the object
3709 6 100       30 if ($opt eq 'name') {
    50          
3710             # we only look at the first one. new() should make sure they're
3711             # all the same.
3712 3         7 ($obj, $type) = (shift(@objs), shift(@objs));
3713 3 50       11 return undef unless defined $obj;
3714 3 100       12 return 'VAR' if $type eq 'HTML::Template::VAR';
3715 2 50       16 return 'LOOP' if $type eq 'HTML::Template::LOOP';
3716 0         0 croak("HTML::Template::query() : unknown object ($type) in param_map!");
3717              
3718             } elsif ($opt eq 'loop') {
3719 3         6 my %results;
3720 3         11 while(@objs) {
3721 4         9 ($obj, $type) = (shift(@objs), shift(@objs));
3722 4 100 66     342 croak("HTML::Template::query() : Search path [", join(', ', @$path), "] doesn't end in a TMPL_LOOP - it is an error to use the 'loop' option on a non-loop parameter. To avoid this problem you can use the 'name' option to query() to check the type first.")
3723             unless ((defined $obj) and ($type eq 'HTML::Template::LOOP'));
3724              
3725             # SHAZAM! This bit extracts all the parameter names from all the
3726             # loop objects for this name.
3727 8         21 map {$results{$_} = 1} map { keys(%{$_->{'param_map'}}) }
  5         6  
  5         20  
  3         8  
3728 3         5 values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]});
3729             }
3730             # this is our loop list, return it.
3731 2         12 return keys(%results);
3732             }
3733             }
3734              
3735             # a function that returns the object(s) corresponding to a given path and
3736             # its (their) ref()(s). Used by query() in the obvious way.
3737             sub _find_param {
3738 14     14   19 my $self = shift;
3739 14 50       45 my $spot = $self->{options}{case_sensitive} ? shift : lc shift;
3740              
3741             # get the obj and type for this spot
3742 14         26 my $obj = $self->{'param_map'}{$spot};
3743 14 100       36 return unless defined $obj;
3744 11         16 my $type = ref $obj;
3745              
3746             # return if we're here or if we're not but this isn't a loop
3747 11 100       44 return ($obj, $type) unless @_;
3748 3 50       11 return unless ($type eq 'HTML::Template::LOOP');
3749              
3750             # recurse. this is a depth first seach on the template tree, for
3751             # the algorithm geeks in the audience.
3752 8         23 return map { $_->_find_param(@_) }
  3         9  
3753 3         5 values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]});
3754             }
3755              
3756             # HTML::Template::VAR, LOOP, etc are *light* objects - their internal
3757             # spec is used above. No encapsulation or information hiding is to be
3758             # assumed.
3759              
3760             package HTML::Template::VAR;
3761 46     46   392 use strict;
  46         450  
  46         2621  
3762 46     46   269 use warnings FATAL => 'all';
  46         98  
  46         2730  
3763 46     46   255 use utf8;
  46         108  
  46         501  
3764              
3765             sub new {
3766 334     334   468 my $value;
3767 334         1717 return bless(\$value, $_[0]);
3768             }
3769              
3770             package HTML::Template::DEFAULT;
3771 46     46   3725 use strict;
  46         89  
  46         1599  
3772 46     46   226 use warnings FATAL => 'all';
  46         106  
  46         1795  
3773 46     46   254 use utf8;
  46         105  
  46         228  
3774              
3775             sub new {
3776 25     25   43 my $value = $_[1];
3777 25         84 return bless(\$value, $_[0]);
3778             }
3779              
3780             package HTML::Template::LOOP;
3781 46     46   3860 use strict;
  46         91  
  46         1496  
3782 46     46   388 use warnings FATAL => 'all';
  46         95  
  46         1668  
3783 46     46   234 use utf8;
  46         85  
  46         234  
3784              
3785             sub new {
3786 36     36   137 return bless([], $_[0]);
3787             }
3788              
3789             sub output {
3790 27     27   42 my $self = shift;
3791 27         44 my $index = shift;
3792 27         33 my $loop_context_vars = shift;
3793 27         60 my $template = $self->[TEMPLATE_HASH]{$index};
3794 27         40 my $value_sets_array = $self->[PARAM_SET];
3795 27         48 my $result = '';
3796 27 50       57 return $result unless defined($value_sets_array);
3797              
3798 27 100       66 if ($loop_context_vars) {
3799 7         10 my $count = 0;
3800 7         9 my $odd = 0;
3801 7         16 foreach my $value_set (@$value_sets_array) {
3802 23 100       53 if ($count == 0) {
  16 100       39  
3803 7         11 @{$value_set}{qw(__first__ __outer__ __inner__ __last__)} = (1,1,0,$#{$value_sets_array} == 0);
  7         32  
  7         15  
3804             } elsif ($count == $#{$value_sets_array}) {
3805 6         11 @{$value_set}{qw(__first__ __outer__ __inner__ __last__)} = (0,1,0,1);
  6         19  
3806             } else {
3807 10         18 @{$value_set}{qw(__first__ __outer__ __inner__ __last__)} = (0,0,1,0);
  10         34  
3808             }
3809 23         139 $odd = $value_set->{__odd__} = not $odd;
3810 23         43 $value_set->{__even__} = $odd;
3811 23         58 $value_set->{__counter__} = $count + 1;
3812 23         56 $template->param($value_set);
3813 23         67 $result .= $template->output();
3814 23         58 $template->clear_params;
3815 23         56 @{$value_set}{qw(__first__ __last__ __outer__ __inner__ __odd__ __even__ __counter__)} = (0,0,0,0,0,0);
  23         71  
3816 23         50 $count++;
3817             }
3818             } else {
3819 20         49 foreach my $value_set (@$value_sets_array) {
3820 33         73 $template->param($value_set);
3821 33         234 $result .= $template->output();
3822 33         114 $template->clear_params;
3823             }
3824             }
3825              
3826 27         95 return $result;
3827             }
3828              
3829             package HTML::Template::COND;
3830 46     46   20379 use strict;
  46         88  
  46         1974  
3831 46     46   242 use warnings FATAL => 'all';
  46         107  
  46         1591  
3832 46     46   243 use utf8;
  46         536  
  46         250  
3833              
3834             sub new {
3835 56     56   84 my $pkg = shift;
3836 56         74 my $var = shift;
3837 56         97 my $self = [];
3838 56         125 $self->[VARIABLE] = $var;
3839              
3840 56         138 bless($self, $pkg);
3841 56         125 return $self;
3842             }
3843              
3844             package HTML::Template::NOOP;
3845 46     46   4408 use strict;
  46         78  
  46         1665  
3846 46     46   236 use warnings FATAL => 'all';
  46         129  
  46         1620  
3847 46     46   233 use utf8;
  46         99  
  46         172  
3848              
3849             sub new {
3850 209     209   319 my $unused;
3851 209         306 my $self = \$unused;
3852 209         671 bless($self, $_[0]);
3853 209         425 return $self;
3854             }
3855              
3856             # scalar-tying package for output(print_to => *HANDLE) implementation
3857             package HTML::Template::PRINTSCALAR;
3858 46     46   3773 use strict;
  46         85  
  46         1625  
3859 46     46   243 use warnings FATAL => 'all';
  46         96  
  46         1713  
3860 46     46   208 use utf8;
  46         88  
  46         203  
3861              
3862 1     1   6 sub TIESCALAR { bless \$_[1], $_[0]; }
3863 1     1   7 sub FETCH { }
3864             sub STORE {
3865 1     1   2 my $self = shift;
3866 1         12 local *FH = $$self;
3867 1         10 print FH @_;
3868             }
3869             1;
3870             __END__