diff options
| author | Andreas Mair <amair.sob@googlemail.com> | 2005-03-06 08:11:12 +0100 |
|---|---|---|
| committer | Andreas Mair <amair.sob@googlemail.com> | 2005-03-06 08:11:12 +0100 |
| commit | 7525bed2d315a25ac2caf95ff0bf44c905d58a7e (patch) | |
| tree | 64f68331dd109cf5c92182d10bb53c614db4a73b /lib | |
| download | vdradmin-am-7525bed2d315a25ac2caf95ff0bf44c905d58a7e.tar.gz vdradmin-am-7525bed2d315a25ac2caf95ff0bf44c905d58a7e.tar.bz2 | |
2005-03-06: 0.97-am1 "initial release"v0.97-am1
This is mainly the lastest vdradmin (v0.97) with different patches applied:
- vdradmin-0.97 has been taken from linvdr-0.7.
- xpix's BigPatch_0.9pre5 (ported from vdradmin-0.95 to vdradmin-0.97 (see HISTORY.bigpatch).
- included changes from vdradmin-0.95-ct-10 (see HISTORY.ct).
- included vdradmin-0.95_0.9_pre5_fb1.diff (see HISTORY.macfly).
- included vdradmin-0.96-rename.diff which also needs an applied "vdr-aio21_svdrprename.patch" patch (don't know the author right now).
My own changes:
- included missing "Was läuft heute?" template (found at www.vdr-portal.de).
- fixed some rendering problems with "New Timer" and "New Autotimer" on KDE's Konqueror.
- Beautified recordings listing (at least in my eyes ;-)
- Added "Size" selectbox to TV template.
Diffstat (limited to 'lib')
28 files changed, 31842 insertions, 0 deletions
diff --git a/lib/HTML/Template.pm b/lib/HTML/Template.pm new file mode 100644 index 0000000..8a2b53f --- /dev/null +++ b/lib/HTML/Template.pm @@ -0,0 +1,3265 @@ +package HTML::Template; + +$HTML::Template::VERSION = '2.6'; + +=head1 NAME + +HTML::Template - Perl module to use HTML Templates from CGI scripts + +=head1 SYNOPSIS + +First you make a template - this is just a normal HTML file with a few +extra tags, the simplest being <TMPL_VAR> + +For example, test.tmpl: + + <html> + <head><title>Test Template</title> + <body> + My Home Directory is <TMPL_VAR NAME=HOME> + <p> + My Path is set to <TMPL_VAR NAME=PATH> + </body> + </html> + +Now create a small CGI program: + + #!/usr/bin/perl -w + use HTML::Template; + + # open the html template + my $template = HTML::Template->new(filename => 'test.tmpl'); + + # fill in some parameters + $template->param(HOME => $ENV{HOME}); + $template->param(PATH => $ENV{PATH}); + + # send the obligatory Content-Type and print the template output + print "Content-Type: text/html\n\n", $template->output; + +If all is well in the universe this should show something like this in +your browser when visiting the CGI: + + My Home Directory is /home/some/directory + My Path is set to /bin;/usr/bin + +=head1 DESCRIPTION + +This module attempts to make using HTML templates simple and natural. +It extends standard HTML with a few new HTML-esque tags - <TMPL_VAR>, +<TMPL_LOOP>, <TMPL_INCLUDE>, <TMPL_IF>, <TMPL_ELSE> and <TMPL_UNLESS>. +The file written with HTML and these new tags is called a template. +It is usually saved separate from your script - possibly even created +by someone else! Using this module you fill in the values for the +variables, loops and branches declared in the template. This allows +you to separate design - the HTML - from the data, which you generate +in the Perl script. + +This module is licensed under the GPL. See the LICENSE section +below for more details. + +=head1 TUTORIAL + +If you're new to HTML::Template, I suggest you start with the +introductory article available on the HTML::Template website: + + http://html-template.sourceforge.net + +=head1 MOTIVATION + +It is true that there are a number of packages out there to do HTML +templates. On the one hand you have things like HTML::Embperl which +allows you freely mix Perl with HTML. On the other hand lie +home-grown variable substitution solutions. Hopefully the module can +find a place between the two. + +One advantage of this module over a full HTML::Embperl-esque solution +is that it enforces an important divide - design and programming. By +limiting the programmer to just using simple variables and loops in +the HTML, the template remains accessible to designers and other +non-perl people. The use of HTML-esque syntax goes further to make +the format understandable to others. In the future this similarity +could be used to extend existing HTML editors/analyzers to support +HTML::Template. + +An advantage of this module over home-grown tag-replacement schemes is +the support for loops. In my work I am often called on to produce +tables of data in html. Producing them using simplistic HTML +templates results in CGIs containing lots of HTML since the HTML +itself cannot represent loops. The introduction of loop statements in +the HTML simplifies this situation considerably. The designer can +layout a single row and the programmer can fill it in as many times as +necessary - all they must agree on is the parameter names. + +For all that, I think the best thing about this module is that it does +just one thing and it does it quickly and carefully. It doesn't try +to replace Perl and HTML, it just augments them to interact a little +better. And it's pretty fast. + +=head1 THE TAGS + +=head2 TMPL_VAR + + <TMPL_VAR NAME="PARAMETER_NAME"> + +The <TMPL_VAR> tag is very simple. For each <TMPL_VAR> tag in the +template you call $template->param(PARAMETER_NAME => "VALUE"). When +the template is output the <TMPL_VAR> is replaced with the VALUE text +you specified. If you don't set a parameter it just gets skipped in +the output. + +Optionally you can use the "ESCAPE=HTML" option in the tag to indicate +that you want the value to be HTML-escaped before being returned from +output (the old ESCAPE=1 syntax is still supported). This means that +the ", <, >, and & characters get translated into ", <, > +and & respectively. This is useful when you want to use a +TMPL_VAR in a context where those characters would cause trouble. +Example: + + <input name=param type=text value="<TMPL_VAR NAME="PARAM">"> + +If you called param() with a value like sam"my you'll get in trouble +with HTML's idea of a double-quote. On the other hand, if you use +ESCAPE=HTML, like this: + + <input name=param type=text value="<TMPL_VAR ESCAPE=HTML NAME="PARAM">"> + +You'll get what you wanted no matter what value happens to be passed in for +param. You can also write ESCAPE="HTML", ESCAPE='HTML' and ESCAPE='1'. +Substitute a 0 for the HTML and you turn off escaping, which is the default +anyway. + +There is also the "ESCAPE=URL" option which may be used for VARs that +populate a URL. It will do URL escaping, like replacing ' ' with '+' +and '/' with '%2F'. + +You can assign a default value to a variable with the DEFAULT +attribute. For example, this will output "the devil gave me a taco" +if the "who" variable is not set. + + The <TMPL_VAR NAME=WHO DEFAULT=devil> gave me a taco. + +=head2 TMPL_LOOP + + <TMPL_LOOP NAME="LOOP_NAME"> ... </TMPL_LOOP> + +The <TMPL_LOOP> tag is a bit more complicated than <TMPL_VAR>. The +<TMPL_LOOP> tag allows you to delimit a section of text and give it a +name. Inside this named loop you place <TMPL_VAR>s. Now you pass to +param() a list (an array ref) of parameter assignments (hash refs) for +this loop. The loop iterates over the list and produces output from +the text block for each pass. Unset parameters are skipped. Here's +an example: + + In the template: + + <TMPL_LOOP NAME=EMPLOYEE_INFO> + Name: <TMPL_VAR NAME=NAME> <br> + Job: <TMPL_VAR NAME=JOB> <p> + </TMPL_LOOP> + + + In the script: + + $template->param(EMPLOYEE_INFO => [ + { name => 'Sam', job => 'programmer' }, + { name => 'Steve', job => 'soda jerk' }, + ] + ); + print $template->output(); + + + The output in a browser: + + Name: Sam + Job: programmer + + Name: Steve + Job: soda jerk + +As you can see above the <TMPL_LOOP> takes a list of variable +assignments and then iterates over the loop body producing output. + +Often you'll want to generate a <TMPL_LOOP>'s contents +programmatically. Here's an example of how this can be done (many +other ways are possible!): + + # a couple of arrays of data to put in a loop: + my @words = qw(I Am Cool); + my @numbers = qw(1 2 3); + + my @loop_data = (); # initialize an array to hold your loop + + while (@words and @numbers) { + my %row_data; # get a fresh hash for the row data + + # fill in this row + $row_data{WORD} = shift @words; + $row_data{NUMBER} = shift @numbers; + + # the crucial step - push a reference to this row into the loop! + push(@loop_data, \%row_data); + } + + # finally, assign the loop data to the loop param, again with a + # reference: + $template->param(THIS_LOOP => \@loop_data); + +The above example would work with a template like: + + <TMPL_LOOP NAME="THIS_LOOP"> + Word: <TMPL_VAR NAME="WORD"> <br> + Number: <TMPL_VAR NAME="NUMBER"> <p> + </TMPL_LOOP> + +It would produce output like: + + Word: I + Number: 1 + + Word: Am + Number: 2 + + Word: Cool + Number: 3 + +<TMPL_LOOP>s within <TMPL_LOOP>s are fine and work as you would +expect. If the syntax for the param() call has you stumped, here's an +example of a param call with one nested loop: + + $template->param(LOOP => [ + { name => 'Bobby', + nicknames => [ + { name => 'the big bad wolf' }, + { name => 'He-Man' }, + ], + }, + ], + ); + +Basically, each <TMPL_LOOP> gets an array reference. Inside the array +are any number of hash references. These hashes contain the +name=>value pairs for a single pass over the loop template. + +Inside a <TMPL_LOOP>, the only variables that are usable are the ones +from the <TMPL_LOOP>. The variables in the outer blocks are not +visible within a template loop. For the computer-science geeks among +you, a <TMPL_LOOP> introduces a new scope much like a perl subroutine +call. If you want your variables to be global you can use +'global_vars' option to new() described below. + +=head2 TMPL_INCLUDE + + <TMPL_INCLUDE NAME="filename.tmpl"> + +This tag includes a template directly into the current template at the +point where the tag is found. The included template contents are used +exactly as if its contents were physically included in the master +template. + +The file specified can be an absolute path (beginning with a '/' under +Unix, for example). If it isn't absolute, the path to the enclosing +file is tried first. After that the path in the environment variable +HTML_TEMPLATE_ROOT is tried, if it exists. Next, the "path" option is +consulted, first as-is and then with HTML_TEMPLATE_ROOT prepended if +available. As a final attempt, the filename is passed to open() +directly. See below for more information on HTML_TEMPLATE_ROOT and +the "path" option to new(). + +As a protection against infinitly recursive includes, an arbitary +limit of 10 levels deep is imposed. You can alter this limit with the +"max_includes" option. See the entry for the "max_includes" option +below for more details. + +=head2 TMPL_IF + + <TMPL_IF NAME="PARAMETER_NAME"> ... </TMPL_IF> + +The <TMPL_IF> tag allows you to include or not include a block of the +template based on the value of a given parameter name. If the +parameter is given a value that is true for Perl - like '1' - then the +block is included in the output. If it is not defined, or given a +false value - like '0' - then it is skipped. The parameters are +specified the same way as with TMPL_VAR. + +Example Template: + + <TMPL_IF NAME="BOOL"> + Some text that only gets displayed if BOOL is true! + </TMPL_IF> + +Now if you call $template->param(BOOL => 1) then the above block will +be included by output. + +<TMPL_IF> </TMPL_IF> blocks can include any valid HTML::Template +construct - VARs and LOOPs and other IF/ELSE blocks. Note, however, +that intersecting a <TMPL_IF> and a <TMPL_LOOP> is invalid. + + Not going to work: + <TMPL_IF BOOL> + <TMPL_LOOP SOME_LOOP> + </TMPL_IF> + </TMPL_LOOP> + +If the name of a TMPL_LOOP is used in a TMPL_IF, the IF block will +output if the loop has at least one row. Example: + + <TMPL_IF LOOP_ONE> + This will output if the loop is not empty. + </TMPL_IF> + + <TMPL_LOOP LOOP_ONE> + .... + </TMPL_LOOP> + +WARNING: Much of the benefit of HTML::Template is in decoupling your +Perl and HTML. If you introduce numerous cases where you have +TMPL_IFs and matching Perl if()s, you will create a maintenance +problem in keeping the two synchronized. I suggest you adopt the +practice of only using TMPL_IF if you can do so without requiring a +matching if() in your Perl code. + +=head2 TMPL_ELSE + + <TMPL_IF NAME="PARAMETER_NAME"> ... <TMPL_ELSE> ... </TMPL_IF> + +You can include an alternate block in your TMPL_IF block by using +TMPL_ELSE. NOTE: You still end the block with </TMPL_IF>, not +</TMPL_ELSE>! + + Example: + + <TMPL_IF BOOL> + Some text that is included only if BOOL is true + <TMPL_ELSE> + Some text that is included only if BOOL is false + </TMPL_IF> + +=head2 TMPL_UNLESS + + <TMPL_UNLESS NAME="PARAMETER_NAME"> ... </TMPL_UNLESS> + +This tag is the opposite of <TMPL_IF>. The block is output if the +CONTROL_PARAMETER is set false or not defined. You can use +<TMPL_ELSE> with <TMPL_UNLESS> just as you can with <TMPL_IF>. + + Example: + + <TMPL_UNLESS BOOL> + Some text that is output only if BOOL is FALSE. + <TMPL_ELSE> + Some text that is output only if BOOL is TRUE. + </TMPL_UNLESS> + +If the name of a TMPL_LOOP is used in a TMPL_UNLESS, the UNLESS block +output if the loop has zero rows. + + <TMPL_UNLESS LOOP_ONE> + This will output if the loop is empty. + </TMPL_UNLESS> + + <TMPL_LOOP LOOP_ONE> + .... + </TMPL_LOOP> + +=cut + +=head2 NOTES + +HTML::Template's tags are meant to mimic normal HTML tags. However, +they are allowed to "break the rules". Something like: + + <img src="<TMPL_VAR IMAGE_SRC>"> + +is not really valid HTML, but it is a perfectly valid use and will +work as planned. + +The "NAME=" in the tag is optional, although for extensibility's sake I +recommend using it. Example - "<TMPL_LOOP LOOP_NAME>" is acceptable. + +If you're a fanatic about valid HTML and would like your templates +to conform to valid HTML syntax, you may optionally type template tags +in the form of HTML comments. This may be of use to HTML authors who +would like to validate their templates' HTML syntax prior to +HTML::Template processing, or who use DTD-savvy editing tools. + + <!-- TMPL_VAR NAME=PARAM1 --> + +In order to realize a dramatic savings in bandwidth, the standard +(non-comment) tags will be used throughout this documentation. + +=head1 METHODS + +=head2 new() + +Call new() to create a new Template object: + + my $template = HTML::Template->new( filename => 'file.tmpl', + option => 'value' + ); + +You must call new() with at least one name => value pair specifying how +to access the template text. You can use "filename => 'file.tmpl'" to +specify a filename to be opened as the template. Alternately you can +use: + + my $t = HTML::Template->new( scalarref => $ref_to_template_text, + option => 'value' + ); + +and + + my $t = HTML::Template->new( arrayref => $ref_to_array_of_lines , + option => 'value' + ); + + +These initialize the template from in-memory resources. In almost +every case you'll want to use the filename parameter. If you're +worried about all the disk access from reading a template file just +use mod_perl and the cache option detailed below. + +You can also read the template from an already opened filehandle, +either traditionally as a glob or as a FileHandle: + + my $t = HTML::Template->new( filehandle => *FH, option => 'value'); + +The four new() calling methods can also be accessed as below, if you +prefer. + + my $t = HTML::Template->new_file('file.tmpl', option => 'value'); + + my $t = HTML::Template->new_scalar_ref($ref_to_template_text, + option => 'value'); + + my $t = HTML::Template->new_array_ref($ref_to_array_of_lines, + option => 'value'); + + my $t = HTML::Template->new_filehandle($fh, + option => 'value'); + +And as a final option, for those that might prefer it, you can call new as: + + my $t = HTML::Template->new(type => 'filename', + source => 'file.tmpl'); + +Which works for all three of the source types. + +If the environment variable HTML_TEMPLATE_ROOT is set and your +filename doesn't begin with /, then the path will be relative to the +value of $HTML_TEMPLATE_ROOT. Example - if the environment variable +HTML_TEMPLATE_ROOT is set to "/home/sam" and I call +HTML::Template->new() with filename set to "sam.tmpl", the +HTML::Template will try to open "/home/sam/sam.tmpl" to access the +template file. You can also affect the search path for files with the +"path" option to new() - see below for more information. + +You can modify the Template object's behavior with new. These options +are available: + +=over 4 + +=item Error Detection Options + +=over 4 + +=item * + +die_on_bad_params - if set to 0 the module will let you call +$template->param(param_name => 'value') even if 'param_name' doesn't +exist in the template body. Defaults to 1. + +=item * + +strict - if set to 0 the module will allow things that look like they +might be TMPL_* tags to get by without dieing. Example: + + <TMPL_HUH NAME=ZUH> + +Would normally cause an error, but if you call new with strict => 0, +HTML::Template will ignore it. Defaults to 1. + +=item * + +vanguard_compatibility_mode - if set to 1 the module will expect to +see <TMPL_VAR>s that look like %NAME% in addition to the standard +syntax. Also sets die_on_bad_params => 0. If you're not at Vanguard +Media trying to use an old format template don't worry about this one. +Defaults to 0. + +=back + +=item Caching Options + +=over 4 + +=item * + +cache - if set to 1 the module will cache in memory the parsed +templates based on the filename parameter and modification date of the +file. This only applies to templates opened with the filename +parameter specified, not scalarref or arrayref templates. Caching +also looks at the modification times of any files included using +<TMPL_INCLUDE> tags, but again, only if the template is opened with +filename parameter. + +This is mainly of use in a persistent environment like +Apache/mod_perl. It has absolutely no benefit in a normal CGI +environment since the script is unloaded from memory after every +request. For a cache that does work for normal CGIs see the +'shared_cache' option below. + +Note that different new() parameter settings do not cause a cache +refresh, only a change in the modification time of the template will +trigger a cache refresh. For most usages this is fine. My simplistic +testing shows that using cache yields a 90% performance increase under +mod_perl. Cache defaults to 0. + +=item * + +shared_cache - if set to 1 the module will store its cache in shared +memory using the IPC::SharedCache module (available from CPAN). The +effect of this will be to maintain a single shared copy of each parsed +template for all instances of HTML::Template to use. This can be a +significant reduction in memory usage in a multiple server +environment. As an example, on one of our systems we use 4MB of +template cache and maintain 25 httpd processes - shared_cache results +in saving almost 100MB! Of course, some reduction in speed versus +normal caching is to be expected. Another difference between normal +caching and shared_cache is that shared_cache will work in a CGI +environment - normal caching is only useful in a persistent +environment like Apache/mod_perl. + +By default HTML::Template uses the IPC key 'TMPL' as a shared root +segment (0x4c504d54 in hex), but this can be changed by setting the +'ipc_key' new() parameter to another 4-character or integer key. +Other options can be used to affect the shared memory cache correspond +to IPC::SharedCache options - ipc_mode, ipc_segment_size and +ipc_max_size. See L<IPC::SharedCache> for a description of how these +work - in most cases you shouldn't need to change them from the +defaults. + +For more information about the shared memory cache system used by +HTML::Template see L<IPC::SharedCache>. + +=item * + +double_cache - if set to 1 the module will use a combination of +shared_cache and normal cache mode for the best possible caching. Of +course, it also uses the most memory of all the cache modes. All the +same ipc_* options that work with shared_cache apply to double_cache +as well. By default double_cache is off. + +=item * + +blind_cache - if set to 1 the module behaves exactly as with normal +caching but does not check to see if the file has changed on each +request. This option should be used with caution, but could be of use +on high-load servers. My tests show blind_cache performing only 1 to +2 percent faster than cache under mod_perl. + +NOTE: Combining this option with shared_cache can result in stale +templates stuck permanently in shared memory! + +=item * + +file_cache - if set to 1 the module will store its cache in a file +using the Storable module. It uses no additional memory, and my +simplistic testing shows that it yields a 50% performance advantage. +Like shared_cache, it will work in a CGI environment. Default is 0. + +If you set this option you must set the "file_cache_dir" option. See +below for details. + +NOTE: Storable using flock() to ensure safe access to cache files. +Using file_cache on a system or filesystem (NFS) without flock() +support is dangerous. + + +=item * + +file_cache_dir - sets the directory where the module will store the +cache files if file_cache is enabled. Your script will need write +permissions to this directory. You'll also need to make sure the +sufficient space is available to store the cache files. + +=item * + +file_cache_dir_mode - sets the file mode for newly created file_cache +directories and subdirectories. Defaults to 0700 for security but +this may be inconvenient if you do not have access to the account +running the webserver. + +=item * + +double_file_cache - if set to 1 the module will use a combination of +file_cache and normal cache mode for the best possible caching. The +file_cache_* options that work with file_cache apply to double_file_cache +as well. By default double_file_cache is 0. + +=back + +=item Filesystem Options + +=over 4 + +=item * + +path - you can set this variable with a list of paths to search for +files specified with the "filename" option to new() and for files +included with the <TMPL_INCLUDE> tag. This list is only consulted +when the filename is relative. The HTML_TEMPLATE_ROOT environment +variable is always tried first if it exists. Also, if +HTML_TEMPLATE_ROOT is set then an attempt will be made to prepend +HTML_TEMPLATE_ROOT onto paths in the path array. In the case of a +<TMPL_INCLUDE> file, the path to the including file is also tried +before path is consulted. + +Example: + + my $template = HTML::Template->new( filename => 'file.tmpl', + path => [ '/path/to/templates', + '/alternate/path' + ] + ); + +NOTE: the paths in the path list must be expressed as UNIX paths, +separated by the forward-slash character ('/'). + +=item * + +search_path_on_include - if set to a true value the module will search +from the top of the array of paths specified by the path option on +every <TMPL_INCLUDE> and use the first matching template found. The +normal behavior is to look only in the current directory for a +template to include. Defaults to 0. + +=back + +=item Debugging Options + +=over 4 + +=item * + +debug - if set to 1 the module will write random debugging information +to STDERR. Defaults to 0. + +=item * + +stack_debug - if set to 1 the module will use Data::Dumper to print +out the contents of the parse_stack to STDERR. Defaults to 0. + +=item * + +cache_debug - if set to 1 the module will send information on cache +loads, hits and misses to STDERR. Defaults to 0. + +=item * + +shared_cache_debug - if set to 1 the module will turn on the debug +option in IPC::SharedCache - see L<IPC::SharedCache> for +details. Defaults to 0. + +=item * + +memory_debug - if set to 1 the module will send information on cache +memory usage to STDERR. Requires the GTop module. Defaults to 0. + +=back + +=item Miscellaneous Options + +=over 4 + +=item * + +associate - this option allows you to inherit the parameter values +from other objects. The only requirement for the other object is that +it have a param() method that works like HTML::Template's param(). A +good candidate would be a CGI.pm query object. Example: + + my $query = new CGI; + my $template = HTML::Template->new(filename => 'template.tmpl', + associate => $query); + +Now, $template->output() will act as though + + $template->param('FormField', $cgi->param('FormField')); + +had been specified for each key/value pair that would be provided by +the $cgi->param() method. Parameters you set directly take precedence +over associated parameters. + +You can specify multiple objects to associate by passing an anonymous +array to the associate option. They are searched for parameters in +the order they appear: + + my $template = HTML::Template->new(filename => 'template.tmpl', + associate => [$query, $other_obj]); + +The old associateCGI() call is still supported, but should be +considered obsolete. + +NOTE: The parameter names are matched in a case-insensitve manner. If +you have two parameters in a CGI object like 'NAME' and 'Name' one +will be chosen randomly by associate. This behavior can be changed by +the following option. + +=item * + +case_sensitive - setting this option to true causes HTML::Template to +treat template variable names case-sensitively. The following example +would only set one parameter without the "case_sensitive" option: + + my $template = HTML::Template->new(filename => 'template.tmpl', + case_sensitive => 1); + $template->param( + FieldA => 'foo', + fIELDa => 'bar', + ); + +This option defaults to off. + +NOTE: with case_sensitive and loop_context_vars the special loop +variables are available in lower-case only. + +=item * + +loop_context_vars - when this parameter is set to true (it is false by +default) four loop context variables are made available inside a loop: +__first__, __last__, __inner__, __odd__. They can be used with +<TMPL_IF>, <TMPL_UNLESS> and <TMPL_ELSE> to control how a loop is +output. + +In addition to the above, a __counter__ var is also made available +when loop context variables are turned on. + +Example: + + <TMPL_LOOP NAME="FOO"> + <TMPL_IF NAME="__first__"> + This only outputs on the first pass. + </TMPL_IF> + + <TMPL_IF NAME="__odd__"> + This outputs every other pass, on the odd passes. + </TMPL_IF> + + <TMPL_UNLESS NAME="__odd__"> + This outputs every other pass, on the even passes. + </TMPL_IF> + + <TMPL_IF NAME="__inner__"> + This outputs on passes that are neither first nor last. + </TMPL_IF> + + This is pass number <TMPL_VAR NAME="__counter__">. + + <TMPL_IF NAME="__last__"> + This only outputs on the last pass. + <TMPL_IF> + </TMPL_LOOP> + +One use of this feature is to provide a "separator" similar in effect +to the perl function join(). Example: + + <TMPL_LOOP FRUIT> + <TMPL_IF __last__> and </TMPL_IF> + <TMPL_VAR KIND><TMPL_UNLESS __last__>, <TMPL_ELSE>.</TMPL_UNLESS> + </TMPL_LOOP> + +Would output (in a browser) something like: + + Apples, Oranges, Brains, Toes, and Kiwi. + +Given an appropriate param() call, of course. NOTE: A loop with only +a single pass will get both __first__ and __last__ set to true, but +not __inner__. + +=item * + +no_includes - set this option to 1 to disallow the <TMPL_INCLUDE> tag +in the template file. This can be used to make opening untrusted +templates B<slightly> less dangerous. Defaults to 0. + +=item * + +max_includes - set this variable to determine the maximum depth that +includes can reach. Set to 10 by default. Including files to a depth +greater than this value causes an error message to be displayed. Set +to 0 to disable this protection. + +=item * + +global_vars - normally variables declared outside a loop are not +available inside a loop. This option makes <TMPL_VAR>s like global +variables in Perl - they have unlimited scope. This option also +affects <TMPL_IF> and <TMPL_UNLESS>. + +Example: + + This is a normal variable: <TMPL_VAR NORMAL>.<P> + + <TMPL_LOOP NAME=FROOT_LOOP> + Here it is inside the loop: <TMPL_VAR NORMAL><P> + </TMPL_LOOP> + +Normally this wouldn't work as expected, since <TMPL_VAR NORMAL>'s +value outside the loop is not available inside the loop. + +The global_vars option also allows you to access the values of an +enclosing loop within an inner loop. For example, in this loop the +inner loop will have access to the value of OUTER_VAR in the correct +iteration: + + <TMPL_LOOP OUTER_LOOP> + OUTER: <TMPL_VAR OUTER_VAR> + <TMPL_LOOP INNER_LOOP> + INNER: <TMPL_VAR INNER_VAR> + INSIDE OUT: <TMPL_VAR OUTER_VAR> + </TMPL_LOOP> + </TMPL_LOOP> + +=item * + +filter - this option allows you to specify a filter for your template +files. A filter is a subroutine that will be called after +HTML::Template reads your template file but before it starts parsing +template tags. + +In the most simple usage, you simply assign a code reference to the +filter parameter. This subroutine will recieve a single arguement - a +reference to a string containing the template file text. Here is an +example that accepts templates with tags that look like "!!!ZAP_VAR +FOO!!!" and transforms them into HTML::Template tags: + + my $filter = sub { + my $text_ref = shift; + $$text_ref =~ s/!!!ZAP_(.*?)!!!/<TMPL_$1>/g; + }; + + # open zap.tmpl using the above filter + my $template = HTML::Template->new(filename => 'zap.tmpl', + filter => $filter); + +More complicated usages are possible. You can request that your +filter receieve the template text as an array of lines rather than as +a single scalar. To do that you need to specify your filter using a +hash-ref. In this form you specify the filter using the "sub" key and +the desired argument format using the "format" key. The available +formats are "scalar" and "array". Using the "array" format will incur +a performance penalty but may be more convenient in some situations. + + my $template = HTML::Template->new(filename => 'zap.tmpl', + filter => { sub => $filter, + format => 'array' }); + +You may also have multiple filters. This allows simple filters to be +combined for more elaborate functionality. To do this you specify an +array of filters. The filters are applied in the order they are +specified. + + my $template = HTML::Template->new(filename => 'zap.tmpl', + filter => [ + { sub => \&decompress, + format => 'scalar' }, + { sub => \&remove_spaces, + format => 'array' } + ]); + +The specified filters will be called for any TMPL_INCLUDEed files just +as they are for the main template file. + +=back + +=back 4 + +=cut + + +use integer; # no floating point math so far! +use strict; # and no funny business, either. + +use Carp; # generate better errors with more context +use File::Spec; # generate paths that work on all platforms + +# define accessor constants used to improve readability of array +# accesses into "objects". I used to use 'use constant' but that +# seems to cause occasional irritating warnings in older Perls. +package HTML::Template::LOOP; +sub TEMPLATE_HASH () { 0; } +sub PARAM_SET () { 1 }; + +package HTML::Template::COND; +sub VARIABLE () { 0 }; +sub VARIABLE_TYPE () { 1 }; +sub VARIABLE_TYPE_VAR () { 0 }; +sub VARIABLE_TYPE_LOOP () { 1 }; +sub JUMP_IF_TRUE () { 2 }; +sub JUMP_ADDRESS () { 3 }; +sub WHICH () { 4 }; +sub WHICH_IF () { 0 }; +sub WHICH_UNLESS () { 1 }; + +# back to the main package scope. +package HTML::Template; + +# open a new template and return an object handle +sub new { + my $pkg = shift; + my $self; { my %hash; $self = bless(\%hash, $pkg); } + + # the options hash + my $options = {}; + $self->{options} = $options; + + # set default parameters in options hash + %$options = ( + debug => 0, + stack_debug => 0, + timing => 0, + search_path_on_include => 0, + cache => 0, + blind_cache => 0, + file_cache => 0, + file_cache_dir => '', + file_cache_dir_mode => 0700, + cache_debug => 0, + shared_cache_debug => 0, + memory_debug => 0, + die_on_bad_params => 1, + vanguard_compatibility_mode => 0, + associate => [], + path => [], + strict => 1, + loop_context_vars => 0, + max_includes => 10, + shared_cache => 0, + double_cache => 0, + double_file_cache => 0, + ipc_key => 'TMPL', + ipc_mode => 0666, + ipc_segment_size => 65536, + ipc_max_size => 0, + global_vars => 0, + no_includes => 0, + case_sensitive => 0, + filter => [], + ); + + # load in options supplied to new() + for (my $x = 0; $x <= $#_; $x += 2) { + defined($_[($x + 1)]) or croak("HTML::Template->new() called with odd number of option parameters - should be of the form option => value"); + $options->{lc($_[$x])} = $_[($x + 1)]; + } + + # blind_cache = 1 implies cache = 1 + $options->{blind_cache} and $options->{cache} = 1; + + # shared_cache = 1 implies cache = 1 + $options->{shared_cache} and $options->{cache} = 1; + + # file_cache = 1 implies cache = 1 + $options->{file_cache} and $options->{cache} = 1; + + # double_cache is a combination of shared_cache and cache. + $options->{double_cache} and $options->{cache} = 1; + $options->{double_cache} and $options->{shared_cache} = 1; + + # double_file_cache is a combination of file_cache and cache. + $options->{double_file_cache} and $options->{cache} = 1; + $options->{double_file_cache} and $options->{file_cache} = 1; + + # vanguard_compatibility_mode implies die_on_bad_params = 0 + $options->{vanguard_compatibility_mode} and + $options->{die_on_bad_params} = 0; + + # handle the "type", "source" parameter format (does anyone use it?) + if (exists($options->{type})) { + exists($options->{source}) or croak("HTML::Template->new() called with 'type' parameter set, but no 'source'!"); + ($options->{type} eq 'filename' or $options->{type} eq 'scalarref' or + $options->{type} eq 'arrayref' or $options->{type} eq 'filehandle') or + croak("HTML::Template->new() : type parameter must be set to 'filename', 'arrayref', 'scalarref' or 'filehandle'!"); + + $options->{$options->{type}} = $options->{source}; + delete $options->{type}; + delete $options->{source}; + } + + # associate should be an array of one element if it's not + # already an array. + if (ref($options->{associate}) ne 'ARRAY') { + $options->{associate} = [ $options->{associate} ]; + } + + # path should be an array if it's not already + if (ref($options->{path}) ne 'ARRAY') { + $options->{path} = [ $options->{path} ]; + } + + # filter should be an array if it's not already + if (ref($options->{filter}) ne 'ARRAY') { + $options->{filter} = [ $options->{filter} ]; + } + + # make sure objects in associate area support param() + foreach my $object (@{$options->{associate}}) { + defined($object->can('param')) or + croak("HTML::Template->new called with associate option, containing object of type " . ref($object) . " which lacks a param() method!"); + } + + # check for syntax errors: + my $source_count = 0; + exists($options->{filename}) and $source_count++; + exists($options->{filehandle}) and $source_count++; + exists($options->{arrayref}) and $source_count++; + exists($options->{scalarref}) and $source_count++; + if ($source_count != 1) { + 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"); + } + + # do some memory debugging - this is best started as early as possible + if ($options->{memory_debug}) { + # memory_debug needs GTop + eval { require GTop; }; + croak("Could not load GTop. You must have GTop installed to use HTML::Template in memory_debug mode. The error was: $@") + if ($@); + $self->{gtop} = GTop->new(); + $self->{proc_mem} = $self->{gtop}->proc_mem($$); + print STDERR "\n### HTML::Template Memory Debug ### START ", $self->{proc_mem}->size(), "\n"; + } + + if ($options->{file_cache}) { + # make sure we have a file_cache_dir option + croak("You must specify the file_cache_dir option if you want to use file_cache.") + unless defined $options->{file_cache_dir} and + length $options->{file_cache_dir}; + + # file_cache needs some extra modules loaded + eval { require Storable; }; + croak("Could not load Storable. You must have Storable installed to use HTML::Template in file_cache mode. The error was: $@") + if ($@); + eval { require Digest::MD5; }; + croak("Could not load Digest::MD5. You must have Digest::MD5 installed to use HTML::Template in file_cache mode. The error was: $@") + if ($@); + } + + if ($options->{shared_cache}) { + # shared_cache needs some extra modules loaded + eval { require IPC::SharedCache; }; + croak("Could not load IPC::SharedCache. You must have IPC::SharedCache installed to use HTML::Template in shared_cache mode. The error was: $@") + if ($@); + + # initialize the shared cache + my %cache; + tie %cache, 'IPC::SharedCache', + ipc_key => $options->{ipc_key}, + load_callback => [\&_load_shared_cache, $self], + validate_callback => [\&_validate_shared_cache, $self], + debug => $options->{shared_cache_debug}, + ipc_mode => $options->{ipc_mode}, + max_size => $options->{ipc_max_size}, + ipc_segment_size => $options->{ipc_segment_size}; + $self->{cache} = \%cache; + } + + print STDERR "### HTML::Template Memory Debug ### POST CACHE INIT ", $self->{proc_mem}->size(), "\n" + if $options->{memory_debug}; + + # initialize data structures + $self->_init; + + print STDERR "### HTML::Template Memory Debug ### POST _INIT CALL ", $self->{proc_mem}->size(), "\n" + if $options->{memory_debug}; + + # drop the shared cache - leaving out this step results in the + # template object evading garbage collection since the callbacks in + # the shared cache tie hold references to $self! This was not easy + # to find, by the way. + delete $self->{cache} if $options->{shared_cache}; + + return $self; +} + +# an internally used new that receives its parse_stack and param_map as input +sub _new_from_loop { + my $pkg = shift; + my $self; { my %hash; $self = bless(\%hash, $pkg); } + + # the options hash + my $options = {}; + $self->{options} = $options; + + # set default parameters in options hash - a subset of the options + # valid in a normal new(). Since _new_from_loop never calls _init, + # many options have no relevance. + %$options = ( + debug => 0, + stack_debug => 0, + die_on_bad_params => 1, + associate => [], + loop_context_vars => 0, + ); + + # load in options supplied to new() + for (my $x = 0; $x <= $#_; $x += 2) { + defined($_[($x + 1)]) or croak("HTML::Template->new() called with odd number of option parameters - should be of the form option => value"); + $options->{lc($_[$x])} = $_[($x + 1)]; + } + + $self->{param_map} = $options->{param_map}; + $self->{parse_stack} = $options->{parse_stack}; + delete($options->{param_map}); + delete($options->{parse_stack}); + + return $self; +} + +# a few shortcuts to new(), of possible use... +sub new_file { + my $pkg = shift; return $pkg->new('filename', @_); +} +sub new_filehandle { + my $pkg = shift; return $pkg->new('filehandle', @_); +} +sub new_array_ref { + my $pkg = shift; return $pkg->new('arrayref', @_); +} +sub new_scalar_ref { + my $pkg = shift; return $pkg->new('scalarref', @_); +} + +# initializes all the object data structures, either from cache or by +# calling the appropriate routines. +sub _init { + my $self = shift; + my $options = $self->{options}; + + if ($options->{double_cache}) { + # try the normal cache, return if we have it. + $self->_fetch_from_cache(); + return if (defined $self->{param_map} and defined $self->{parse_stack}); + + # try the shared cache + $self->_fetch_from_shared_cache(); + + # put it in the local cache if we got it. + $self->_commit_to_cache() + if (defined $self->{param_map} and defined $self->{parse_stack}); + } elsif ($options->{double_file_cache}) { + # try the normal cache, return if we have it. + $self->_fetch_from_cache(); + return if (defined $self->{param_map} and defined $self->{parse_stack}); + + # try the file cache + $self->_fetch_from_file_cache(); + + # put it in the local cache if we got it. + $self->_commit_to_cache() + if (defined $self->{param_map} and defined $self->{parse_stack}); + } elsif ($options->{shared_cache}) { + # try the shared cache + $self->_fetch_from_shared_cache(); + } elsif ($options->{file_cache}) { + # try the file cache + $self->_fetch_from_file_cache(); + } elsif ($options->{cache}) { + # try the normal cache + $self->_fetch_from_cache(); + } + + # if we got a cache hit, return + return if (defined $self->{param_map} and defined $self->{parse_stack}); + + # if we're here, then we didn't get a cached copy, so do a full + # init. + $self->_init_template(); + $self->_parse(); + + # now that we have a full init, cache the structures if cacheing is + # on. shared cache is already cool. + if($options->{file_cache}){ + $self->_commit_to_file_cache(); + } + $self->_commit_to_cache() if (($options->{cache} + and not $options->{shared_cache} + and not $options->{file_cache}) or + ($options->{double_cache}) or + ($options->{double_file_cache})); +} + +# Caching subroutines - they handle getting and validating cache +# records from either the in-memory or shared caches. + +# handles the normal in memory cache +use vars qw( %CACHE ); +sub _fetch_from_cache { + my $self = shift; + my $options = $self->{options}; + + # return if there's no cache entry for this filename + return unless exists($options->{filename}); + my $filepath = $self->_find_file($options->{filename}); + return unless (defined($filepath) and + exists $CACHE{$filepath}); + + $options->{filepath} = $filepath; + + # validate the cache + my $mtime = $self->_mtime($filepath); + if (defined $mtime) { + # return if the mtime doesn't match the cache + if (defined($CACHE{$filepath}{mtime}) and + ($mtime != $CACHE{$filepath}{mtime})) { + $options->{cache_debug} and + print STDERR "CACHE MISS : $filepath : $mtime\n"; + return; + } + + # if the template has includes, check each included file's mtime + # and return if different + if (exists($CACHE{$filepath}{included_mtimes})) { + foreach my $filename (keys %{$CACHE{$filepath}{included_mtimes}}) { + next unless + defined($CACHE{$filepath}{included_mtimes}{$filename}); + + my $included_mtime = (stat($filename))[9]; + if ($included_mtime != $CACHE{$filepath}{included_mtimes}{$filename}) { + $options->{cache_debug} and + print STDERR "### HTML::Template Cache Debug ### CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n"; + + return; + } + } + } + } + + # got a cache hit! + + $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath\n"; + + $self->{param_map} = $CACHE{$filepath}{param_map}; + $self->{parse_stack} = $CACHE{$filepath}{parse_stack}; + exists($CACHE{$filepath}{included_mtimes}) and + $self->{included_mtimes} = $CACHE{$filepath}{included_mtimes}; + + # clear out values from param_map from last run + $self->_normalize_options(); + $self->clear_params(); +} + +sub _commit_to_cache { + my $self = shift; + my $options = $self->{options}; + + my $filepath = $options->{filepath}; + if (not defined $filepath) { + $filepath = $self->_find_file($options->{filename}); + confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.") + unless defined($filepath); + $options->{filepath} = $filepath; + } + + $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### CACHE LOAD : $filepath\n"; + + $options->{blind_cache} or + $CACHE{$filepath}{mtime} = $self->_mtime($filepath); + $CACHE{$filepath}{param_map} = $self->{param_map}; + $CACHE{$filepath}{parse_stack} = $self->{parse_stack}; + exists($self->{included_mtimes}) and + $CACHE{$filepath}{included_mtimes} = $self->{included_mtimes}; +} + +# generates MD5 from filepath to determine filename for cache file +sub _get_cache_filename { + my ($self, $filepath) = @_; + + # hash the filename ... + my $hash = Digest::MD5::md5_hex($filepath); + + # ... and build a path out of it. Using the first two charcters + # gives us 255 buckets. This means you can have 255,000 templates + # in the cache before any one directory gets over a few thousand + # files in it. That's probably pretty good for this planet. If not + # then it should be configurable. + if (wantarray) { + return (substr($hash,0,2), substr($hash,2)) + } else { + return File::Spec->join($self->{options}{file_cache_dir}, + substr($hash,0,2), substr($hash,2)); + } +} + +# handles the file cache +sub _fetch_from_file_cache { + my $self = shift; + my $options = $self->{options}; + return unless exists($options->{filename}); + + # return if there's no cache entry for this filename + my $filepath = $self->_find_file($options->{filename}); + return unless defined $filepath; + my $cache_filename = $self->_get_cache_filename($filepath); + return unless -e $cache_filename; + + eval { + $self->{record} = Storable::lock_retrieve($cache_filename); + }; + croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $@") + if $@; + croak("HTML::Template::new() - Problem reading cache file $cache_filename (file_cache => 1) : $!") + unless defined $self->{record}; + + ($self->{mtime}, + $self->{included_mtimes}, + $self->{param_map}, + $self->{parse_stack}) = @{$self->{record}}; + + $options->{filepath} = $filepath; + + # validate the cache + my $mtime = $self->_mtime($filepath); + if (defined $mtime) { + # return if the mtime doesn't match the cache + if (defined($self->{mtime}) and + ($mtime != $self->{mtime})) { + $options->{cache_debug} and + print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : $mtime\n"; + ($self->{mtime}, + $self->{included_mtimes}, + $self->{param_map}, + $self->{parse_stack}) = (undef, undef, undef, undef); + return; + } + + # if the template has includes, check each included file's mtime + # and return if different + if (exists($self->{included_mtimes})) { + foreach my $filename (keys %{$self->{included_mtimes}}) { + next unless + defined($self->{included_mtimes}{$filename}); + + my $included_mtime = (stat($filename))[9]; + if ($included_mtime != $self->{included_mtimes}{$filename}) { + $options->{cache_debug} and + print STDERR "### HTML::Template Cache Debug ### FILE CACHE MISS : $filepath : INCLUDE $filename : $included_mtime\n"; + ($self->{mtime}, + $self->{included_mtimes}, + $self->{param_map}, + $self->{parse_stack}) = (undef, undef, undef, undef); + return; + } + } + } + } + + # got a cache hit! + $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE HIT : $filepath\n"; + + # clear out values from param_map from last run + $self->_normalize_options(); + $self->clear_params(); +} + +sub _commit_to_file_cache { + my $self = shift; + my $options = $self->{options}; + + my $filepath = $options->{filepath}; + if (not defined $filepath) { + $filepath = $self->_find_file($options->{filename}); + confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.") + unless defined($filepath); + $options->{filepath} = $filepath; + } + + my ($cache_dir, $cache_file) = $self->_get_cache_filename($filepath); + $cache_dir = File::Spec->join($options->{file_cache_dir}, $cache_dir); + if (not -d $cache_dir) { + if (not -d $options->{file_cache_dir}) { + mkdir($options->{file_cache_dir},$options->{file_cache_dir_mode}) + or croak("HTML::Template->new() : can't mkdir $options->{file_cache_dir} (file_cache => 1): $!"); + } + mkdir($cache_dir,$options->{file_cache_dir_mode}) + or croak("HTML::Template->new() : can't mkdir $cache_dir (file_cache => 1): $!"); + } + + $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### FILE CACHE LOAD : $options->{filepath}\n"; + + my $result; + eval { + $result = Storable::lock_store([ $self->{mtime}, + $self->{included_mtimes}, + $self->{param_map}, + $self->{parse_stack} ], + scalar File::Spec->join($cache_dir, $cache_file) + ); + }; + croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $@") + if $@; + croak("HTML::Template::new() - Problem writing cache file $cache_dir/$cache_file (file_cache => 1) : $!") + unless defined $result; +} + +# Shared cache routines. +sub _fetch_from_shared_cache { + my $self = shift; + my $options = $self->{options}; + + my $filepath = $self->_find_file($options->{filename}); + return unless defined $filepath; + + # fetch from the shared cache. + $self->{record} = $self->{cache}{$filepath}; + + ($self->{mtime}, + $self->{included_mtimes}, + $self->{param_map}, + $self->{parse_stack}) = @{$self->{record}} + if defined($self->{record}); + + $options->{cache_debug} and defined($self->{record}) and print STDERR "### HTML::Template Cache Debug ### CACHE HIT : $filepath\n"; + # clear out values from param_map from last run + $self->_normalize_options(), $self->clear_params() + if (defined($self->{record})); + delete($self->{record}); + + return $self; +} + +sub _validate_shared_cache { + my ($self, $filename, $record) = @_; + my $options = $self->{options}; + + $options->{shared_cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE VALIDATE : $filename\n"; + + return 1 if $options->{blind_cache}; + + my ($c_mtime, $included_mtimes, $param_map, $parse_stack) = @$record; + + # if the modification time has changed return false + my $mtime = $self->_mtime($filename); + if (defined $mtime and defined $c_mtime + and $mtime != $c_mtime) { + $options->{cache_debug} and + print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : $mtime\n"; + return 0; + } + + # if the template has includes, check each included file's mtime + # and return false if different + if (defined $mtime and defined $included_mtimes) { + foreach my $fname (keys %$included_mtimes) { + next unless defined($included_mtimes->{$fname}); + if ($included_mtimes->{$fname} != (stat($fname))[9]) { + $options->{cache_debug} and + print STDERR "### HTML::Template Cache Debug ### SHARED CACHE MISS : $filename : INCLUDE $fname\n"; + return 0; + } + } + } + + # all done - return true + return 1; +} + +sub _load_shared_cache { + my ($self, $filename) = @_; + my $options = $self->{options}; + my $cache = $self->{cache}; + + $self->_init_template(); + $self->_parse(); + + $options->{cache_debug} and print STDERR "### HTML::Template Cache Debug ### SHARED CACHE LOAD : $options->{filepath}\n"; + + print STDERR "### HTML::Template Memory Debug ### END CACHE LOAD ", $self->{proc_mem}->size(), "\n" + if $options->{memory_debug}; + + return [ $self->{mtime}, + $self->{included_mtimes}, + $self->{param_map}, + $self->{parse_stack} ]; +} + +# utility function - given a filename performs documented search and +# returns a full path of undef if the file cannot be found. +sub _find_file { + my ($self, $filename, $extra_path) = @_; + my $options = $self->{options}; + my $filepath; + + # first check for a full path + return File::Spec->canonpath($filename) + if (File::Spec->file_name_is_absolute($filename) and (-e $filename)); + + # try the extra_path if one was specified + if (defined($extra_path)) { + $extra_path->[$#{$extra_path}] = $filename; + $filepath = File::Spec->canonpath(File::Spec->catfile(@$extra_path)); + return File::Spec->canonpath($filepath) if -e $filepath; + } + + # try pre-prending HTML_Template_Root + if (exists($ENV{HTML_TEMPLATE_ROOT})) { + $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $filename); + return File::Spec->canonpath($filepath) if -e $filepath; + } + + # try "path" option list.. + foreach my $path (@{$options->{path}}) { + $filepath = File::Spec->catfile($path, $filename); + return File::Spec->canonpath($filepath) if -e $filepath; + } + + # try even a relative path from the current directory... + return File::Spec->canonpath($filename) if -e $filename; + + # try "path" option list with HTML_TEMPLATE_ROOT prepended... + if (exists($ENV{HTML_TEMPLATE_ROOT})) { + foreach my $path (@{$options->{path}}) { + $filepath = File::Spec->catfile($ENV{HTML_TEMPLATE_ROOT}, $path, $filename); + return File::Spec->canonpath($filepath) if -e $filepath; + } + } + + return undef; +} + +# utility function - computes the mtime for $filename +sub _mtime { + my ($self, $filepath) = @_; + my $options = $self->{options}; + + return(undef) if ($options->{blind_cache}); + + # make sure it still exists in the filesystem + (-r $filepath) or Carp::confess("HTML::Template : template file $filepath does not exist or is unreadable."); + + # get the modification time + return (stat(_))[9]; +} + +# utility function - enforces new() options across LOOPs that have +# come from a cache. Otherwise they would have stale options hashes. +sub _normalize_options { + my $self = shift; + my $options = $self->{options}; + + my @pstacks = ($self->{parse_stack}); + while(@pstacks) { + my $pstack = pop(@pstacks); + foreach my $item (@$pstack) { + next unless (ref($item) eq 'HTML::Template::LOOP'); + foreach my $template (values %{$item->[HTML::Template::LOOP::TEMPLATE_HASH]}) { + # must be the same list as the call to _new_from_loop... + $template->{options}{debug} = $options->{debug}; + $template->{options}{stack_debug} = $options->{stack_debug}; + $template->{options}{die_on_bad_params} = $options->{die_on_bad_params}; + $template->{options}{case_sensitive} = $options->{case_sensitive}; + + push(@pstacks, $template->{parse_stack}); + } + } + } +} + +# initialize the template buffer +sub _init_template { + my $self = shift; + my $options = $self->{options}; + + print STDERR "### HTML::Template Memory Debug ### START INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n" + if $options->{memory_debug}; + + if (exists($options->{filename})) { + my $filepath = $options->{filepath}; + if (not defined $filepath) { + $filepath = $self->_find_file($options->{filename}); + confess("HTML::Template->new() : Cannot open included file $options->{filename} : file not found.") + unless defined($filepath); + # we'll need this for future reference - to call stat() for example. + $options->{filepath} = $filepath; + } + + confess("HTML::Template->new() : Cannot open included file $options->{filename} : $!") + unless defined(open(TEMPLATE, $filepath)); + $self->{mtime} = $self->_mtime($filepath); + + # read into scalar, note the mtime for the record + $self->{template} = ""; + while (read(TEMPLATE, $self->{template}, 10240, length($self->{template}))) {} + close(TEMPLATE); + + } elsif (exists($options->{scalarref})) { + # copy in the template text + $self->{template} = ${$options->{scalarref}}; + + delete($options->{scalarref}); + } elsif (exists($options->{arrayref})) { + # if we have an array ref, join and store the template text + $self->{template} = join("", @{$options->{arrayref}}); + + delete($options->{arrayref}); + } elsif (exists($options->{filehandle})) { + # just read everything in in one go + local $/ = undef; + $self->{template} = readline($options->{filehandle}); + + delete($options->{filehandle}); + } else { + confess("HTML::Template : Need to call new with filename, filehandle, scalarref or arrayref parameter specified."); + } + + print STDERR "### HTML::Template Memory Debug ### END INIT_TEMPLATE ", $self->{proc_mem}->size(), "\n" + if $options->{memory_debug}; + + # handle filters if necessary + $self->_call_filters(\$self->{template}) if @{$options->{filter}}; + + return $self; +} + +# handle calling user defined filters +sub _call_filters { + my $self = shift; + my $template_ref = shift; + my $options = $self->{options}; + + my ($format, $sub); + foreach my $filter (@{$options->{filter}}) { + croak("HTML::Template->new() : bad value set for filter parameter - must be a code ref or a hash ref.") + unless ref $filter; + + # translate into CODE->HASH + $filter = { 'format' => 'scalar', 'sub' => $filter } + if (ref $filter eq 'CODE'); + + if (ref $filter eq 'HASH') { + $format = $filter->{'format'}; + $sub = $filter->{'sub'}; + + # check types and values + croak("HTML::Template->new() : bad value set for filter parameter - hash must contain \"format\" key and \"sub\" key.") + unless defined $format and defined $sub; + croak("HTML::Template->new() : bad value set for filter parameter - \"format\" must be either 'array' or 'scalar'") + unless $format eq 'array' or $format eq 'scalar'; + croak("HTML::Template->new() : bad value set for filter parameter - \"sub\" must be a code ref") + unless ref $sub and ref $sub eq 'CODE'; + + # catch errors + eval { + if ($format eq 'scalar') { + # call + $sub->($template_ref); + } else { + # modulate + my @array = map { $_."\n" } split("\n", $$template_ref); + # call + $sub->(\@array); + # demodulate + $$template_ref = join("", @array); + } + }; + croak("HTML::Template->new() : fatal error occured during filter call: $@") if $@; + } else { + croak("HTML::Template->new() : bad value set for filter parameter - must be code ref or hash ref"); + } + } + # all done + return $template_ref; +} + +# _parse sifts through a template building up the param_map and +# parse_stack structures. +# +# The end result is a Template object that is fully ready for +# output(). +sub _parse { + my $self = shift; + my $options = $self->{options}; + + $options->{debug} and print STDERR "### HTML::Template Debug ### In _parse:\n"; + + # setup the stacks and maps - they're accessed by typeglobs that + # reference the top of the stack. They are masked so that a loop + # can transparently have its own versions. + use vars qw(@pstack %pmap @ifstack @ucstack %top_pmap); + local (*pstack, *ifstack, *pmap, *ucstack, *top_pmap); + + # the pstack is the array of scalar refs (plain text from the + # template file), VARs, LOOPs, IFs and ELSEs that output() works on + # to produce output. Looking at output() should make it clear what + # _parse is trying to accomplish. + my @pstacks = ([]); + *pstack = $pstacks[0]; + $self->{parse_stack} = $pstacks[0]; + + # the pmap binds names to VARs, LOOPs and IFs. It allows param() to + # access the right variable. NOTE: output() does not look at the + # pmap at all! + my @pmaps = ({}); + *pmap = $pmaps[0]; + *top_pmap = $pmaps[0]; + $self->{param_map} = $pmaps[0]; + + # the ifstack is a temporary stack containing pending ifs and elses + # waiting for a /if. + my @ifstacks = ([]); + *ifstack = $ifstacks[0]; + + # the ucstack is a temporary stack containing conditions that need + # to be bound to param_map entries when their block is finished. + # This happens when a conditional is encountered before any other + # reference to its NAME. Since a conditional can reference VARs and + # LOOPs it isn't possible to make the link right away. + my @ucstacks = ([]); + *ucstack = $ucstacks[0]; + + # the loopstack is another temp stack for closing loops. unlike + # those above it doesn't get scoped inside loops, therefore it + # doesn't need the typeglob magic. + my @loopstack = (); + + # the fstack is a stack of filenames and counters that keeps track + # of which file we're in and where we are in it. This allows + # accurate error messages even inside included files! + # fcounter, fmax and fname are aliases for the current file's info + use vars qw($fcounter $fname $fmax); + local (*fcounter, *fname, *fmax); + + my @fstack = ([$options->{filepath} || "/fake/path/for/non/file/template", + 1, + scalar @{[$self->{template} =~ m/(\n)/g]} + 1 + ]); + (*fname, *fcounter, *fmax) = \ ( @{$fstack[0]} ); + + my $NOOP = HTML::Template::NOOP->new(); + my $ESCAPE = HTML::Template::ESCAPE->new(); + my $URLESCAPE = HTML::Template::URLESCAPE->new(); + + # all the tags that need NAMEs: + my %need_names = map { $_ => 1 } + qw(TMPL_VAR TMPL_LOOP TMPL_IF TMPL_UNLESS TMPL_INCLUDE); + + # variables used below that don't need to be my'd in the loop + my ($name, $which, $escape, $default); + + # handle the old vanguard format + $options->{vanguard_compatibility_mode} and + $self->{template} =~ s/%([-\w\/\.+]+)%/<TMPL_VAR NAME=$1>/g; + + # now split up template on '<', leaving them in + my @chunks = split(m/(?=<)/, $self->{template}); + + # all done with template + delete $self->{template}; + + # loop through chunks, filling up pstack + my $last_chunk = $#chunks; + CHUNK: for (my $chunk_number = 0; + $chunk_number <= $last_chunk; + $chunk_number++) { + next unless defined $chunks[$chunk_number]; + my $chunk = $chunks[$chunk_number]; + + # a general regex to match any and all TMPL_* tags + if ($chunk =~ /^< + (?:!--\s*)? + ( + \/?[Tt][Mm][Pp][Ll]_ + (?: + (?:[Vv][Aa][Rr]) + | + (?:[Ll][Oo][Oo][Pp]) + | + (?:[Ii][Ff]) + | + (?:[Ee][Ll][Ss][Ee]) + | + (?:[Uu][Nn][Ll][Ee][Ss][Ss]) + | + (?:[Ii][Nn][Cc][Ll][Uu][Dd][Ee]) + ) + ) # $1 => $which - start of the tag + + \s* + + # DEFAULT attribute + (?: + [Dd][Ee][Ff][Aa][Uu][Ll][Tt] + \s*=\s* + (?: + "([^">]*)" # $2 => double-quoted DEFAULT value " + | + '([^'>]*)' # $3 => single-quoted DEFAULT value + | + ([^\s=>]*) # $4 => unquoted DEFAULT value + ) + )? + + \s* + + # ESCAPE attribute + (?: + [Ee][Ss][Cc][Aa][Pp][Ee] + \s*=\s* + (?: + (?: 0 | (?:"0") | (?:'0') ) + | + ( 1 | (?:"1") | (?:'1') | + (?:[Hh][Tt][Mm][Ll]) | + (?:"[Hh][Tt][Mm][Ll]") | + (?:'[Hh][Tt][Mm][Ll]') | + (?:[Uu][Rr][Ll]) | + (?:"[Uu][Rr][Ll]") | + (?:'[Uu][Rr][Ll]') | + ) # $5 => ESCAPE on + ) + )* # allow multiple ESCAPEs + + \s* + + # DEFAULT attribute + (?: + [Dd][Ee][Ff][Aa][Uu][Ll][Tt] + \s*=\s* + (?: + "([^">]*)" # $6 => double-quoted DEFAULT value " + | + '([^'>]*)' # $7 => single-quoted DEFAULT value + | + ([^\s=>]*) # $8 => unquoted DEFAULT value + ) + )? + + \s* + + # NAME attribute + (?: + (?: + [Nn][Aa][Mm][Ee] + \s*=\s* + )? + (?: + "([^">]*)" # $9 => double-quoted NAME value " + | + '([^'>]*)' # $10 => single-quoted NAME value + | + ([^\s=>]*) # $11 => unquoted NAME value + ) + )? + + \s* + + # DEFAULT attribute + (?: + [Dd][Ee][Ff][Aa][Uu][Ll][Tt] + \s*=\s* + (?: + "([^">]*)" # $12 => double-quoted DEFAULT value " + | + '([^'>]*)' # $13 => single-quoted DEFAULT value + | + ([^\s=>]*) # $14 => unquoted DEFAULT value + ) + )? + + \s* + + # ESCAPE attribute + (?: + [Ee][Ss][Cc][Aa][Pp][Ee] + \s*=\s* + (?: + (?: 0 | (?:"0") | (?:'0') ) + | + ( 1 | (?:"1") | (?:'1') | + (?:[Hh][Tt][Mm][Ll]) | + (?:"[Hh][Tt][Mm][Ll]") | + (?:'[Hh][Tt][Mm][Ll]') | + (?:[Uu][Rr][Ll]) | + (?:"[Uu][Rr][Ll]") | + (?:'[Uu][Rr][Ll]') | + ) # $15 => ESCAPE on + ) + )* # allow multiple ESCAPEs + + \s* + + # DEFAULT attribute + (?: + [Dd][Ee][Ff][Aa][Uu][Ll][Tt] + \s*=\s* + (?: + "([^">]*)" # $16 => double-quoted DEFAULT value " + | + '([^'>]*)' # $17 => single-quoted DEFAULT value + | + ([^\s=>]*) # $18 => unquoted DEFAULT value + ) + )? + + \s* + + (?:--)?> + (.*) # $19 => $post - text that comes after the tag + $/sx) { + + $which = uc($1); # which tag is it + + $escape = defined $5 ? $5 : defined $15 ? $15 : 0; # escape set? + + # what name for the tag? undef for a /tag at most, one of the + # following three will be defined + $name = defined $9 ? $9 : defined $10 ? $10 : defined $11 ? $11 : undef; + + # is there a default? + $default = defined $2 ? $2 : defined $3 ? $3 : defined $4 ? $4 : + defined $6 ? $6 : defined $7 ? $7 : defined $8 ? $8 : + defined $12 ? $12 : defined $13 ? $13 : defined $14 ? $14 : + defined $16 ? $16 : defined $17 ? $17 : defined $18 ? $18 : + undef; + + my $post = $19; # what comes after on the line + + # allow mixed case in filenames, otherwise flatten + $name = lc($name) unless (not defined $name or $which eq 'TMPL_INCLUDE' or $options->{case_sensitive}); + + # die if we need a name and didn't get one + die "HTML::Template->new() : No NAME given to a $which tag at $fname : line $fcounter." + if ($need_names{$which} and (not defined $name or not length $name)); + + # die if we got an escape but can't use one + die "HTML::Template->new() : ESCAPE option invalid in a $which tag at $fname : line $fcounter." if ( $escape and ($which ne 'TMPL_VAR')); + + # die if we got a default but can't use one + die "HTML::Template->new() : DEFAULT option invalid in a $which tag at $fname : line $fcounter." if ( defined $default and ($which ne 'TMPL_VAR')); + + # take actions depending on which tag found + if ($which eq 'TMPL_VAR') { + $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : parsed VAR $name\n"; + + # if we already have this var, then simply link to the existing + # HTML::Template::VAR, else create a new one. + my $var; + if (exists $pmap{$name}) { + $var = $pmap{$name}; + (ref($var) eq 'HTML::Template::VAR') or + die "HTML::Template->new() : Already used param name $name as a TMPL_LOOP, found in a TMPL_VAR at $fname : line $fcounter."; + } else { + $var = HTML::Template::VAR->new(); + $pmap{$name} = $var; + $top_pmap{$name} = HTML::Template::VAR->new() + if $options->{global_vars} and not exists $top_pmap{$name}; + } + + # if a DEFAULT was provided, push a DEFAULT object on the + # stack before the variable. + if (defined $default) { + push(@pstack, HTML::Template::DEFAULT->new($default)); + } + + # if ESCAPE was set, push an ESCAPE op on the stack before + # the variable. output will handle the actual work. + if ($escape) { + if ($escape =~ /^"?[Uu][Rr][Ll]"?$/) { + push(@pstack, $URLESCAPE); + } else { + push(@pstack, $ESCAPE); + } + } + + push(@pstack, $var); + + } elsif ($which eq 'TMPL_LOOP') { + # we've got a loop start + $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP $name start\n"; + + # if we already have this loop, then simply link to the existing + # HTML::Template::LOOP, else create a new one. + my $loop; + if (exists $pmap{$name}) { + $loop = $pmap{$name}; + (ref($loop) eq 'HTML::Template::LOOP') or + die "HTML::Template->new() : Already used param name $name as a TMPL_VAR, TMPL_IF or TMPL_UNLESS, found in a TMP_LOOP at $fname : line $fcounter!"; + + } else { + # store the results in a LOOP object - actually just a + # thin wrapper around another HTML::Template object. + $loop = HTML::Template::LOOP->new(); + $pmap{$name} = $loop; + } + + # get it on the loopstack, pstack of the enclosing block + push(@pstack, $loop); + push(@loopstack, [$loop, $#pstack]); + + # magic time - push on a fresh pmap and pstack, adjust the typeglobs. + # this gives the loop a separate namespace (i.e. pmap and pstack). + push(@pstacks, []); + *pstack = $pstacks[$#pstacks]; + push(@pmaps, {}); + *pmap = $pmaps[$#pmaps]; + push(@ifstacks, []); + *ifstack = $ifstacks[$#ifstacks]; + push(@ucstacks, []); + *ucstack = $ucstacks[$#ucstacks]; + + # auto-vivify __FIRST__, __LAST__ and __INNER__ if + # loop_context_vars is set. Otherwise, with + # die_on_bad_params set output() will might cause errors + # when it tries to set them. + if ($options->{loop_context_vars}) { + $pmap{__first__} = HTML::Template::VAR->new(); + $pmap{__inner__} = HTML::Template::VAR->new(); + $pmap{__last__} = HTML::Template::VAR->new(); + $pmap{__odd__} = HTML::Template::VAR->new(); + $pmap{__counter__} = HTML::Template::VAR->new(); + } + + } elsif ($which eq '/TMPL_LOOP') { + $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : LOOP end\n"; + + my $loopdata = pop(@loopstack); + die "HTML::Template->new() : found </TMPL_LOOP> with no matching <TMPL_LOOP> at $fname : line $fcounter!" unless defined $loopdata; + + my ($loop, $starts_at) = @$loopdata; + + # resolve pending conditionals + foreach my $uc (@ucstack) { + my $var = $uc->[HTML::Template::COND::VARIABLE]; + if (exists($pmap{$var})) { + $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; + } else { + $pmap{$var} = HTML::Template::VAR->new(); + $top_pmap{$var} = HTML::Template::VAR->new() + if $options->{global_vars} and not exists $top_pmap{$var}; + $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; + } + if (ref($pmap{$var}) eq 'HTML::Template::VAR') { + $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; + } else { + $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; + } + } + + # get pmap and pstack for the loop, adjust the typeglobs to + # the enclosing block. + my $param_map = pop(@pmaps); + *pmap = $pmaps[$#pmaps]; + my $parse_stack = pop(@pstacks); + *pstack = $pstacks[$#pstacks]; + + scalar(@ifstack) and die "HTML::Template->new() : Dangling <TMPL_IF> or <TMPL_UNLESS> in loop ending at $fname : line $fcounter."; + pop(@ifstacks); + *ifstack = $ifstacks[$#ifstacks]; + pop(@ucstacks); + *ucstack = $ucstacks[$#ucstacks]; + + # instantiate the sub-Template, feeding it parse_stack and + # param_map. This means that only the enclosing template + # does _parse() - sub-templates get their parse_stack and + # param_map fed to them already filled in. + $loop->[HTML::Template::LOOP::TEMPLATE_HASH]{$starts_at} + = HTML::Template->_new_from_loop( + parse_stack => $parse_stack, + param_map => $param_map, + debug => $options->{debug}, + die_on_bad_params => $options->{die_on_bad_params}, + loop_context_vars => $options->{loop_context_vars}, + case_sensitive => $options->{case_sensitive}, + ); + + } elsif ($which eq 'TMPL_IF' or $which eq 'TMPL_UNLESS' ) { + $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : $which $name start\n"; + + # if we already have this var, then simply link to the existing + # HTML::Template::VAR/LOOP, else defer the mapping + my $var; + if (exists $pmap{$name}) { + $var = $pmap{$name}; + } else { + $var = $name; + } + + # connect the var to a conditional + my $cond = HTML::Template::COND->new($var); + if ($which eq 'TMPL_IF') { + $cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_IF; + $cond->[HTML::Template::COND::JUMP_IF_TRUE] = 0; + } else { + $cond->[HTML::Template::COND::WHICH] = HTML::Template::COND::WHICH_UNLESS; + $cond->[HTML::Template::COND::JUMP_IF_TRUE] = 1; + } + + # push unconnected conditionals onto the ucstack for + # resolution later. Otherwise, save type information now. + if ($var eq $name) { + push(@ucstack, $cond); + } else { + if (ref($var) eq 'HTML::Template::VAR') { + $cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; + } else { + $cond->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; + } + } + + # push what we've got onto the stacks + push(@pstack, $cond); + push(@ifstack, $cond); + + } elsif ($which eq '/TMPL_IF' or $which eq '/TMPL_UNLESS') { + $options->{debug} and print STDERR "### HTML::Template Debug ###$fname : line $fcounter : $which end\n"; + + my $cond = pop(@ifstack); + die "HTML::Template->new() : found </${which}> with no matching <TMPL_IF> at $fname : line $fcounter." unless defined $cond; + if ($which eq '/TMPL_IF') { + die "HTML::Template->new() : found </TMPL_IF> incorrectly terminating a <TMPL_UNLESS> (use </TMPL_UNLESS>) at $fname : line $fcounter.\n" + if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_UNLESS); + } else { + die "HTML::Template->new() : found </TMPL_UNLESS> incorrectly terminating a <TMPL_IF> (use </TMPL_IF>) at $fname : line $fcounter.\n" + if ($cond->[HTML::Template::COND::WHICH] == HTML::Template::COND::WHICH_IF); + } + + # connect the matching to this "address" - place a NOOP to + # hold the spot. This allows output() to treat an IF in the + # assembler-esque "Conditional Jump" mode. + push(@pstack, $NOOP); + $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack; + + } elsif ($which eq 'TMPL_ELSE') { + $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : ELSE\n"; + + my $cond = pop(@ifstack); + die "HTML::Template->new() : found <TMPL_ELSE> with no matching <TMPL_IF> or <TMPL_UNLESS> at $fname : line $fcounter." unless defined $cond; + + + my $else = HTML::Template::COND->new($cond->[HTML::Template::COND::VARIABLE]); + $else->[HTML::Template::COND::WHICH] = $cond->[HTML::Template::COND::WHICH]; + $else->[HTML::Template::COND::JUMP_IF_TRUE] = not $cond->[HTML::Template::COND::JUMP_IF_TRUE]; + + # need end-block resolution? + if (defined($cond->[HTML::Template::COND::VARIABLE_TYPE])) { + $else->[HTML::Template::COND::VARIABLE_TYPE] = $cond->[HTML::Template::COND::VARIABLE_TYPE]; + } else { + push(@ucstack, $else); + } + + push(@pstack, $else); + push(@ifstack, $else); + + # connect the matching to this "address" - thus the if, + # failing jumps to the ELSE address. The else then gets + # elaborated, and of course succeeds. On the other hand, if + # the IF fails and falls though, output will reach the else + # and jump to the /if address. + $cond->[HTML::Template::COND::JUMP_ADDRESS] = $#pstack; + + } elsif ($which eq 'TMPL_INCLUDE') { + # handle TMPL_INCLUDEs + $options->{debug} and print STDERR "### HTML::Template Debug ### $fname : line $fcounter : INCLUDE $name \n"; + + # no includes here, bub + $options->{no_includes} and croak("HTML::Template : Illegal attempt to use TMPL_INCLUDE in template file : (no_includes => 1)"); + + my $filename = $name; + + # look for the included file... + my $filepath; + if ($options->{search_path_on_include}) { + $filepath = $self->_find_file($filename); + } else { + $filepath = $self->_find_file($filename, + [File::Spec->splitdir($fstack[-1][0])] + ); + } + die "HTML::Template->new() : Cannot open included file $filename : file not found." + unless defined($filepath); + die "HTML::Template->new() : Cannot open included file $filename : $!" + unless defined(open(TEMPLATE, $filepath)); + + # read into the array + my $included_template = ""; + while(read(TEMPLATE, $included_template, 10240, length($included_template))) {} + close(TEMPLATE); + + # call filters if necessary + $self->_call_filters(\$included_template) if @{$options->{filter}}; + + if ($included_template) { # not empty + # handle the old vanguard format - this needs to happen here + # since we're not about to do a next CHUNKS. + $options->{vanguard_compatibility_mode} and + $included_template =~ s/%([-\w\/\.+]+)%/<TMPL_VAR NAME=$1>/g; + + # collect mtimes for included files + if ($options->{cache} and !$options->{blind_cache}) { + $self->{included_mtimes}{$filepath} = (stat($filepath))[9]; + } + + # adjust the fstack to point to the included file info + push(@fstack, [$filepath, 1, + scalar @{[$included_template =~ m/(\n)/g]} + 1]); + (*fname, *fcounter, *fmax) = \ ( @{$fstack[$#fstack]} ); + + # make sure we aren't infinitely recursing + 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})); + + # stick the remains of this chunk onto the bottom of the + # included text. + $included_template .= $post; + $post = undef; + + # move the new chunks into place. + splice(@chunks, $chunk_number, 1, + split(m/(?=<)/, $included_template)); + + # recalculate stopping point + $last_chunk = $#chunks; + + # start in on the first line of the included text - nothing + # else to do on this line. + $chunk = $chunks[$chunk_number]; + + redo CHUNK; + } + } else { + # zuh!? + die "HTML::Template->new() : Unknown or unmatched TMPL construct at $fname : line $fcounter."; + } + # push the rest after the tag + if (defined($post)) { + if (ref($pstack[$#pstack]) eq 'SCALAR') { + ${$pstack[$#pstack]} .= $post; + } else { + push(@pstack, \$post); + } + } + } else { # just your ordinary markup + # make sure we didn't reject something TMPL_* but badly formed + if ($options->{strict}) { + die "HTML::Template->new() : Syntax error in <TMPL_*> tag at $fname : $fcounter." if ($chunk =~ /<(?:!--\s*)?\/?[Tt][Mm][Pp][Ll]_/); + } + + # push the rest and get next chunk + if (defined($chunk)) { + if (ref($pstack[$#pstack]) eq 'SCALAR') { + ${$pstack[$#pstack]} .= $chunk; + } else { + push(@pstack, \$chunk); + } + } + } + # count newlines in chunk and advance line count + $fcounter += scalar(@{[$chunk =~ m/(\n)/g]}); + # if we just crossed the end of an included file + # pop off the record and re-alias to the enclosing file's info + pop(@fstack), (*fname, *fcounter, *fmax) = \ ( @{$fstack[$#fstack]} ) + if ($fcounter > $fmax); + + } # next CHUNK + + # make sure we don't have dangling IF or LOOP blocks + scalar(@ifstack) and die "HTML::Template->new() : At least one <TMPL_IF> or <TMPL_UNLESS> not terminated at end of file!"; + scalar(@loopstack) and die "HTML::Template->new() : At least one <TMPL_LOOP> not terminated at end of file!"; + + # resolve pending conditionals + foreach my $uc (@ucstack) { + my $var = $uc->[HTML::Template::COND::VARIABLE]; + if (exists($pmap{$var})) { + $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; + } else { + $pmap{$var} = HTML::Template::VAR->new(); + $top_pmap{$var} = HTML::Template::VAR->new() + if $options->{global_vars} and not exists $top_pmap{$var}; + $uc->[HTML::Template::COND::VARIABLE] = $pmap{$var}; + } + if (ref($pmap{$var}) eq 'HTML::Template::VAR') { + $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_VAR; + } else { + $uc->[HTML::Template::COND::VARIABLE_TYPE] = HTML::Template::COND::VARIABLE_TYPE_LOOP; + } + } + + # want a stack dump? + if ($options->{stack_debug}) { + require 'Data/Dumper.pm'; + print STDERR "### HTML::Template _param Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n"; + } + + # get rid of filters - they cause runtime errors if Storable tries + # to store them. This can happen under global_vars. + delete $options->{filter}; +} + +# a recursive sub that associates each loop with the loops above +# (treating the top-level as a loop) +sub _globalize_vars { + my $self = shift; + + # associate with the loop (and top-level templates) above in the tree. + push(@{$self->{options}{associate}}, @_); + + # recurse down into the template tree, adding ourself to the end of + # list. + push(@_, $self); + map { $_->_globalize_vars(@_) } + map {values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]}} + grep { ref($_) eq 'HTML::Template::LOOP'} @{$self->{parse_stack}}; +} + +# method used to recursively un-hook associate +sub _unglobalize_vars { + my $self = shift; + + # disassociate + $self->{options}{associate} = undef; + + # recurse down into the template tree disassociating + map { $_->_unglobalize_vars() } + map {values %{$_->[HTML::Template::LOOP::TEMPLATE_HASH]}} + grep { ref($_) eq 'HTML::Template::LOOP'} @{$self->{parse_stack}}; +} + +=head2 param() + +param() can be called in a number of ways + +1) To return a list of parameters in the template : + + my @parameter_names = $self->param(); + + +2) To return the value set to a param : + + my $value = $self->param('PARAM'); + +3) To set the value of a parameter : + + # For simple TMPL_VARs: + $self->param(PARAM => 'value'); + + # with a subroutine reference that gets called to get the value + # of the scalar. The sub will recieve the template object as a + # parameter. + $self->param(PARAM => sub { return 'value' }); + + # And TMPL_LOOPs: + $self->param(LOOP_PARAM => + [ + { PARAM => VALUE_FOR_FIRST_PASS, ... }, + { PARAM => VALUE_FOR_SECOND_PASS, ... } + ... + ] + ); + +4) To set the value of a a number of parameters : + + # For simple TMPL_VARs: + $self->param(PARAM => 'value', + PARAM2 => 'value' + ); + + # And with some TMPL_LOOPs: + $self->param(PARAM => 'value', + PARAM2 => 'value', + LOOP_PARAM => + [ + { PARAM => VALUE_FOR_FIRST_PASS, ... }, + { PARAM => VALUE_FOR_SECOND_PASS, ... } + ... + ], + ANOTHER_LOOP_PARAM => + [ + { PARAM => VALUE_FOR_FIRST_PASS, ... }, + { PARAM => VALUE_FOR_SECOND_PASS, ... } + ... + ] + ); + +5) To set the value of a a number of parameters using a hash-ref : + + $self->param( + { + PARAM => 'value', + PARAM2 => 'value', + LOOP_PARAM => + [ + { PARAM => VALUE_FOR_FIRST_PASS, ... }, + { PARAM => VALUE_FOR_SECOND_PASS, ... } + ... + ], + ANOTHER_LOOP_PARAM => + [ + { PARAM => VALUE_FOR_FIRST_PASS, ... }, + { PARAM => VALUE_FOR_SECOND_PASS, ... } + ... + ] + } + ); + +=cut + + +sub param { + my $self = shift; + my $options = $self->{options}; + my $param_map = $self->{param_map}; + + # the no-parameter case - return list of parameters in the template. + return keys(%$param_map) unless scalar(@_); + + my $first = shift; + my $type = ref $first; + + # the one-parameter case - could be a parameter value request or a + # hash-ref. + if (!scalar(@_) and !length($type)) { + my $param = $options->{case_sensitive} ? $first : lc $first; + + # check for parameter existence + $options->{die_on_bad_params} and !exists($param_map->{$param}) and + 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)"); + + return undef unless (exists($param_map->{$param}) and + defined($param_map->{$param})); + + return ${$param_map->{$param}} if + (ref($param_map->{$param}) eq 'HTML::Template::VAR'); + return $param_map->{$param}[HTML::Template::LOOP::PARAM_SET]; + } + + if (!scalar(@_)) { + croak("HTML::Template->param() : Single reference arg to param() must be a hash-ref! You gave me a $type.") + unless $type eq 'HASH' or + (ref($first) and UNIVERSAL::isa($first, 'HASH')); + push(@_, %$first); + } else { + unshift(@_, $first); + } + + croak("HTML::Template->param() : You gave me an odd number of parameters to param()!") + unless ((@_ % 2) == 0); + + # strangely, changing this to a "while(@_) { shift, shift }" type + # loop causes perl 5.004_04 to die with some nonsense about a + # read-only value. + for (my $x = 0; $x <= $#_; $x += 2) { + my $param = $options->{case_sensitive} ? $_[$x] : lc $_[$x]; + my $value = $_[($x + 1)]; + + # check that this param exists in the template + $options->{die_on_bad_params} and !exists($param_map->{$param}) and + 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)"); + + # if we're not going to die from bad param names, we need to ignore + # them... + next unless (exists($param_map->{$param})); + + # figure out what we've got, taking special care to allow for + # objects that are compatible underneath. + my $value_type = ref($value); + if (defined($value_type) and length($value_type) and ($value_type eq 'ARRAY' or ((ref($value) !~ /^(CODE)|(HASH)|(SCALAR)$/) and $value->isa('ARRAY')))) { + (ref($param_map->{$param}) eq 'HTML::Template::LOOP') or + croak("HTML::Template::param() : attempt to set parameter '$param' with an array ref - parameter is not a TMPL_LOOP!"); + $param_map->{$param}[HTML::Template::LOOP::PARAM_SET] = [@{$value}]; + } else { + (ref($param_map->{$param}) eq 'HTML::Template::VAR') or + croak("HTML::Template::param() : attempt to set parameter '$param' with a scalar - parameter is not a TMPL_VAR!"); + ${$param_map->{$param}} = $value; + } + } +} + +=pod + +=head2 clear_params() + +Sets all the parameters to undef. Useful internally, if nowhere else! + +=cut + +sub clear_params { + my $self = shift; + my $type; + foreach my $name (keys %{$self->{param_map}}) { + $type = ref($self->{param_map}{$name}); + undef(${$self->{param_map}{$name}}) + if ($type eq 'HTML::Template::VAR'); + undef($self->{param_map}{$name}[HTML::Template::LOOP::PARAM_SET]) + if ($type eq 'HTML::Template::LOOP'); + } +} + + +# obsolete implementation of associate +sub associateCGI { + my $self = shift; + my $cgi = shift; + (ref($cgi) eq 'CGI') or + croak("Warning! non-CGI object was passed to HTML::Template::associateCGI()!\n"); + push(@{$self->{options}{associate}}, $cgi); + return 1; +} + + +=head2 output() + +output() returns the final result of the template. In most situations +you'll want to print this, like: + + print $template->output(); + +When output is called each occurrence of <TMPL_VAR NAME=name> is +replaced with the value assigned to "name" via param(). If a named +parameter is unset it is simply replaced with ''. <TMPL_LOOPS> are +evaluated once per parameter set, accumlating output on each pass. + +Calling output() is guaranteed not to change the state of the +Template object, in case you were wondering. This property is mostly +important for the internal implementation of loops. + +You may optionally supply a filehandle to print to automatically as +the template is generated. This may improve performance and lower +memory consumption. Example: + + $template->output(print_to => *STDOUT); + +The return value is undefined when using the "print_to" option. + +=cut + +use vars qw(%URLESCAPE_MAP); +sub output { + my $self = shift; + my $options = $self->{options}; + local $_; + + croak("HTML::Template->output() : You gave me an odd number of parameters to output()!") + unless ((@_ % 2) == 0); + my %args = @_; + + print STDERR "### HTML::Template Memory Debug ### START OUTPUT ", $self->{proc_mem}->size(), "\n" + if $options->{memory_debug}; + + $options->{debug} and print STDERR "### HTML::Template Debug ### In output\n"; + + # want a stack dump? + if ($options->{stack_debug}) { + require 'Data/Dumper.pm'; + print STDERR "### HTML::Template output Stack Dump ###\n\n", Data::Dumper::Dumper($self->{parse_stack}), "\n"; + } + + # globalize vars - this happens here to localize the circular + # references created by global_vars. + $self->_globalize_vars() if ($options->{global_vars}); + + # support the associate magic, searching for undefined params and + # attempting to fill them from the associated objects. + if (scalar(@{$options->{associate}})) { + # prepare case-mapping hashes to do case-insensitive matching + # against associated objects. This allows CGI.pm to be + # case-sensitive and still work with asssociate. + my (%case_map, $lparam); + foreach my $associated_object (@{$options->{associate}}) { + # what a hack! This should really be optimized out for case_sensitive. + if ($options->{case_sensitive}) { + map { + $case_map{$associated_object}{$_} = $_ + } $associated_object->param(); + } else { + map { + $case_map{$associated_object}{lc($_)} = $_ + } $associated_object->param(); + } + } + + foreach my $param (keys %{$self->{param_map}}) { + unless (defined($self->param($param))) { + OBJ: foreach my $associated_object (reverse @{$options->{associate}}) { + $self->param($param, scalar $associated_object->param($case_map{$associated_object}{$param})), last OBJ + if (exists($case_map{$associated_object}{$param})); + } + } + } + } + + use vars qw($line @parse_stack); local(*line, *parse_stack); + + # walk the parse stack, accumulating output in $result + *parse_stack = $self->{parse_stack}; + my $result = ''; + + tie $result, 'HTML::Template::PRINTSCALAR', $args{print_to} + if defined $args{print_to} and not tied $args{print_to}; + + my $type; + my $parse_stack_length = $#parse_stack; + for (my $x = 0; $x <= $parse_stack_length; $x++) { + *line = \$parse_stack[$x]; + $type = ref($line); + + if ($type eq 'SCALAR') { + $result .= $$line; + } elsif ($type eq 'HTML::Template::VAR' and ref($$line) eq 'CODE') { + defined($$line) and $result .= $$line->($self); + } elsif ($type eq 'HTML::Template::VAR') { + defined($$line) and $result .= $$line; + } elsif ($type eq 'HTML::Template::LOOP') { + if (defined($line->[HTML::Template::LOOP::PARAM_SET])) { + eval { $result .= $line->output($x, $options->{loop_context_vars}); }; + croak("HTML::Template->output() : fatal error in loop output : $@") + if $@; + } + } elsif ($type eq 'HTML::Template::COND') { + if ($line->[HTML::Template::COND::JUMP_IF_TRUE]) { + if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) { + if (defined ${$line->[HTML::Template::COND::VARIABLE]}) { + if (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') { + $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]}->($self); + } else { + $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if ${$line->[HTML::Template::COND::VARIABLE]}; + } + } + } else { + $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if + (defined $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] and + scalar @{$line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]}); + } + } else { + if ($line->[HTML::Template::COND::VARIABLE_TYPE] == HTML::Template::COND::VARIABLE_TYPE_VAR) { + if (defined ${$line->[HTML::Template::COND::VARIABLE]}) { + if (ref(${$line->[HTML::Template::COND::VARIABLE]}) eq 'CODE') { + $x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]}->($self); + } else { + $x = $line->[HTML::Template::COND::JUMP_ADDRESS] unless ${$line->[HTML::Template::COND::VARIABLE]}; + } + } else { + $x = $line->[HTML::Template::COND::JUMP_ADDRESS]; + } + } else { + $x = $line->[HTML::Template::COND::JUMP_ADDRESS] if + (not defined $line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET] or + not scalar @{$line->[HTML::Template::COND::VARIABLE][HTML::Template::LOOP::PARAM_SET]}); + } + } + } elsif ($type eq 'HTML::Template::NOOP') { + next; + } elsif ($type eq 'HTML::Template::DEFAULT') { + $_ = $x; # remember default place in stack + + # find next VAR, there might be an ESCAPE in the way + *line = \$parse_stack[++$x]; + *line = \$parse_stack[++$x] if ref $line eq 'HTML::Template::ESCAPE'; + + # either output the default or go back + if (defined $$line) { + $x = $_; + } else { + $result .= ${$parse_stack[$_]}; + } + next; + } elsif ($type eq 'HTML::Template::ESCAPE') { + *line = \$parse_stack[++$x]; + if (defined($$line)) { + $_ = $$line; + + # straight from the CGI.pm bible. + s/&/&/g; + s/\"/"/g; #" + s/>/>/g; + s/</</g; + s/'/'/g; #' + + $result .= $_; + } + next; + } elsif ($type eq 'HTML::Template::URLESCAPE') { + $x++; + *line = \$parse_stack[$x]; + if (defined($$line)) { + $_ = $$line; + # Build a char->hex map if one isn't already available + unless (exists($URLESCAPE_MAP{chr(1)})) { + for (0..255) { $URLESCAPE_MAP{chr($_)} = sprintf('%%%02X', $_); } + } + # do the translation (RFC 2396 ^uric) + s!([^a-zA-Z0-9_.\-])!$URLESCAPE_MAP{$1}!g; + $result .= $_; + } + } else { + confess("HTML::Template::output() : Unknown item in parse_stack : " . $type); + } + } + + # undo the globalization circular refs + $self->_unglobalize_vars() if ($options->{global_vars}); + + print STDERR "### HTML::Template Memory Debug ### END OUTPUT ", $self->{proc_mem}->size(), "\n" + if $options->{memory_debug}; + + return undef if defined $args{print_to}; + return $result; +} + +=pod + +=head2 query() + +This method allow you to get information about the template structure. +It can be called in a number of ways. The simplest usage of query is +simply to check whether a parameter name exists in the template, using +the C<name> option: + + if ($template->query(name => 'foo')) { + # do something if a varaible of any type + # named FOO is in the template + } + +This same usage returns the type of the parameter. The type is the +same as the tag minus the leading 'TMPL_'. So, for example, a +TMPL_VAR parameter returns 'VAR' from query(). + + if ($template->query(name => 'foo') eq 'VAR') { + # do something if FOO exists and is a TMPL_VAR + } + +Note that the variables associated with TMPL_IFs and TMPL_UNLESSs will +be identified as 'VAR' unless they are also used in a TMPL_LOOP, in +which case they will return 'LOOP'. + +C<query()> also allows you to get a list of parameters inside a loop +(and inside loops inside loops). Example loop: + + <TMPL_LOOP NAME="EXAMPLE_LOOP"> + <TMPL_VAR NAME="BEE"> + <TMPL_VAR NAME="BOP"> + <TMPL_LOOP NAME="EXAMPLE_INNER_LOOP"> + <TMPL_VAR NAME="INNER_BEE"> + <TMPL_VAR NAME="INNER_BOP"> + </TMPL_LOOP> + </TMPL_LOOP> + +And some query calls: + + # returns 'LOOP' + $type = $template->query(name => 'EXAMPLE_LOOP'); + + # returns ('bop', 'bee', 'example_inner_loop') + @param_names = $template->query(loop => 'EXAMPLE_LOOP'); + + # both return 'VAR' + $type = $template->query(name => ['EXAMPLE_LOOP', 'BEE']); + $type = $template->query(name => ['EXAMPLE_LOOP', 'BOP']); + + # and this one returns 'LOOP' + $type = $template->query(name => ['EXAMPLE_LOOP', + 'EXAMPLE_INNER_LOOP']); + + # and finally, this returns ('inner_bee', 'inner_bop') + @inner_param_names = $template->query(loop => ['EXAMPLE_LOOP', + 'EXAMPLE_INNER_LOOP']); + + # for non existent parameter names you get undef + # this returns undef. + $type = $template->query(name => 'DWEAZLE_ZAPPA'); + + # calling loop on a non-loop parameter name will cause an error. + # this dies: + $type = $template->query(loop => 'DWEAZLE_ZAPPA'); + +As you can see above the C<loop> option returns a list of parameter +names and both C<name> and C<loop> take array refs in order to refer +to parameters inside loops. It is an error to use C<loop> with a +parameter that is not a loop. + +Note that all the names are returned in lowercase and the types are +uppercase. + +Just like C<param()>, C<query()> with no arguements returns all the +parameter names in the template at the top level. + +=cut + +sub query { + my $self = shift; + $self->{options}{debug} and print STDERR "### HTML::Template Debug ### query(", join(', ', @_), ")\n"; + + # the no-parameter case - return $self->param() + return $self->param() unless scalar(@_); + + croak("HTML::Template::query() : Odd number of parameters passed to query!") + if (scalar(@_) % 2); + croak("HTML::Template::query() : Wrong number of parameters passed to query - should be 2.") + if (scalar(@_) != 2); + + my ($opt, $path) = (lc shift, shift); + croak("HTML::Template::query() : invalid parameter ($opt)") + unless ($opt eq 'name' or $opt eq 'loop'); + + # make path an array unless it already is + $path = [$path] unless (ref $path); + + # find the param in question. + my @objs = $self->_find_param(@$path); + return undef unless scalar(@objs); + my ($obj, $type); + + # do what the user asked with the object + if ($opt eq 'name') { + # we only look at the first one. new() should make sure they're + # all the same. + ($obj, $type) = (shift(@objs), shift(@objs)); + return undef unless defined $obj; + return 'VAR' if $type eq 'HTML::Template::VAR'; + return 'LOOP' if $type eq 'HTML::Template::LOOP'; + croak("HTML::Template::query() : unknown object ($type) in param_map!"); + + } elsif ($opt eq 'loop') { + my %results; + while(@objs) { + ($obj, $type) = (shift(@objs), shift(@objs)); + 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.") + unless ((defined $obj) and ($type eq 'HTML::Template::LOOP')); + + # SHAZAM! This bit extracts all the parameter names from all the + # loop objects for this name. + map {$results{$_} = 1} map { keys(%{$_->{'param_map'}}) } + values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]}); + } + # this is our loop list, return it. + return keys(%results); + } +} + +# a function that returns the object(s) corresponding to a given path and +# its (their) ref()(s). Used by query() in the obvious way. +sub _find_param { + my $self = shift; + my $spot = $self->{options}{case_sensitive} ? shift : lc shift; + + # get the obj and type for this spot + my $obj = $self->{'param_map'}{$spot}; + return unless defined $obj; + my $type = ref $obj; + + # return if we're here or if we're not but this isn't a loop + return ($obj, $type) unless @_; + return unless ($type eq 'HTML::Template::LOOP'); + + # recurse. this is a depth first seach on the template tree, for + # the algorithm geeks in the audience. + return map { $_->_find_param(@_) } + values(%{$obj->[HTML::Template::LOOP::TEMPLATE_HASH]}); +} + +# HTML::Template::VAR, LOOP, etc are *light* objects - their internal +# spec is used above. No encapsulation or information hiding is to be +# assumed. + +package HTML::Template::VAR; + +sub new { + my $value; + return bless(\$value, $_[0]); +} + +package HTML::Template::DEFAULT; + +sub new { + my $value = $_[1]; + return bless(\$value, $_[0]); +} + +package HTML::Template::LOOP; + +sub new { + return bless([], $_[0]); +} + +sub output { + my $self = shift; + my $index = shift; + my $loop_context_vars = shift; + my $template = $self->[TEMPLATE_HASH]{$index}; + my $value_sets_array = $self->[PARAM_SET]; + return unless defined($value_sets_array); + + my $result = ''; + my $count = 0; + my $odd = 0; + foreach my $value_set (@$value_sets_array) { + if ($loop_context_vars) { + if ($count == 0) { + @{$value_set}{qw(__first__ __inner__ __last__)} = (1,0,$#{$value_sets_array} == 0); + } elsif ($count == $#{$value_sets_array}) { + @{$value_set}{qw(__first__ __inner__ __last__)} = (0,0,1); + } else { + @{$value_set}{qw(__first__ __inner__ __last__)} = (0,1,0); + } + $odd = $value_set->{__odd__} = not $odd; + $value_set->{__counter__} = $count + 1; + } + $template->param($value_set); + $result .= $template->output; + $template->clear_params; + @{$value_set}{qw(__first__ __last__ __inner__ __odd__ __counter__)} = + (0,0,0,0) + if ($loop_context_vars); + $count++; + } + + return $result; +} + +package HTML::Template::COND; + +sub new { + my $pkg = shift; + my $var = shift; + my $self = []; + $self->[VARIABLE] = $var; + + bless($self, $pkg); + return $self; +} + +package HTML::Template::NOOP; +sub new { + my $unused; + my $self = \$unused; + bless($self, $_[0]); + return $self; +} + +package HTML::Template::ESCAPE; +sub new { + my $unused; + my $self = \$unused; + bless($self, $_[0]); + return $self; +} + +package HTML::Template::URLESCAPE; +sub new { + my $unused; + my $self = \$unused; + bless($self, $_[0]); + return $self; +} + +# scalar-tying package for output(print_to => *HANDLE) implementation +package HTML::Template::PRINTSCALAR; +use strict; + +sub TIESCALAR { bless \$_[1], $_[0]; } +sub FETCH { } +sub STORE { + my $self = shift; + local *FH = $$self; + print FH @_; +} +1; +__END__ + +=head1 FREQUENTLY ASKED QUESTIONS + +In the interest of greater understanding I've started a FAQ section of +the perldocs. Please look in here before you send me email. + +=over 4 + +=item 1 + +Q: Is there a place to go to discuss HTML::Template and/or get help? + +A: There's a mailing-list for discussing HTML::Template at +html-template-users@lists.sourceforge.net. To join: + + http://lists.sourceforge.net/lists/listinfo/html-template-users + +If you just want to get email when new releases are available you can +join the announcements mailing-list here: + + http://lists.sourceforge.net/lists/listinfo/html-template-announce + +=item 2 + +Q: Is there a searchable archive for the mailing-list? + +A: Yes, you can find an archive of the SourceForge list here: + + http://www.geocrawler.com/lists/3/SourceForge/23294/0/ + +For an archive of the old vm.com list, setup by Sean P. Scanlon, see: + + http://bluedot.net/mail/archive/ + +=item 3 + +Q: I want support for <TMPL_XXX>! How about it? + +A: Maybe. I definitely encourage people to discuss their ideas for +HTML::Template on the mailing list. Please be ready to explain to me +how the new tag fits in with HTML::Template's mission to provide a +fast, lightweight system for using HTML templates. + +NOTE: Offering to program said addition and provide it in the form of +a patch to the most recent version of HTML::Template will definitely +have a softening effect on potential opponents! + +=item 4 + +Q: I found a bug, can you fix it? + +A: That depends. Did you send me the VERSION of HTML::Template, a test +script and a test template? If so, then almost certainly. + +If you're feeling really adventurous, HTML::Template has a publically +available CVS server. See below for more information in the PUBLIC +CVS SERVER section. + +=item 5 + +Q: <TMPL_VAR>s from the main template aren't working inside a +<TMPL_LOOP>! Why? + +A: This is the intended behavior. <TMPL_LOOP> introduces a separate +scope for <TMPL_VAR>s much like a subroutine call in Perl introduces a +separate scope for "my" variables. + +If you want your <TMPL_VAR>s to be global you can set the +'global_vars' option when you call new(). See above for documentation +of the 'global_vars' new() option. + +=item 6 + +Q: Why do you use /[Tt]/ instead of /t/i? It's so ugly! + +A: Simple - the case-insensitive match switch is very inefficient. +According to _Mastering_Regular_Expressions_ from O'Reilly Press, +/[Tt]/ is faster and more space efficient than /t/i - by as much as +double against long strings. //i essentially does a lc() on the +string and keeps a temporary copy in memory. + +When this changes, and it is in the 5.6 development series, I will +gladly use //i. Believe me, I realize [Tt] is hideously ugly. + +=item 7 + +Q: How can I pre-load my templates using cache-mode and mod_perl? + +A: Add something like this to your startup.pl: + + use HTML::Template; + use File::Find; + + print STDERR "Pre-loading HTML Templates...\n"; + find( + sub { + return unless /\.tmpl$/; + HTML::Template->new( + filename => "$File::Find::dir/$_", + cache => 1, + ); + }, + '/path/to/templates', + '/another/path/to/templates/' + ); + +Note that you'll need to modify the "return unless" line to specify +the extension you use for your template files - I use .tmpl, as you +can see. You'll also need to specify the path to your template files. + +One potential problem: the "/path/to/templates/" must be EXACTLY the +same path you use when you call HTML::Template->new(). Otherwise the +cache won't know they're the same file and will load a new copy - +instead getting a speed increase, you'll double your memory usage. To +find out if this is happening set cache_debug => 1 in your application +code and look for "CACHE MISS" messages in the logs. + +=item 8 + +Q: What characters are allowed in TMPL_* NAMEs? + +A: Numbers, letters, '.', '/', '+', '-' and '_'. + +=item 9 + +Q: How can I execute a program from inside my template? + +A: Short answer: you can't. Longer answer: you shouldn't since this +violates the fundamental concept behind HTML::Template - that design +and code should be seperate. + +But, inevitably some people still want to do it. If that describes +you then you should take a look at +L<HTML::Template::Expr|HTML::Template::Expr>. Using +HTML::Template::Expr it should be easy to write a run_program() +function. Then you can do awful stuff like: + + <tmpl_var expr="run_program('foo.pl')"> + +Just, please, don't tell me about it. I'm feeling guilty enough just +for writing HTML::Template::Expr in the first place. + +=item 10 + +Q: Can I get a copy of these docs in Japanese? + +A: Yes you can. See Kawai Takanori's translation at: + + http://member.nifty.ne.jp/hippo2000/perltips/html/template.htm + +=item 11 + +Q: What's the best way to create a <select> form element using +HTML::Template? + +A: There is much disagreement on this issue. My personal preference +is to use CGI.pm's excellent popup_menu() and scrolling_list() +functions to fill in a single <tmpl_var select_foo> variable. + +To some people this smacks of mixing HTML and code in a way that they +hoped HTML::Template would help them avoid. To them I'd say that HTML +is a violation of the principle of separating design from programming. +There's no clear separation between the programmatic elements of the +<form> tags and the layout of the <form> tags. You'll have to draw +the line somewhere - clearly the designer can't be entirely in charge +of form creation. + +It's a balancing act and you have to weigh the pros and cons on each side. +It is certainly possible to produce a <select> element entirely inside the +template. What you end up with is a rat's nest of loops and conditionals. +Alternately you can give up a certain amount of flexibility in return for +vastly simplifying your templates. I generally choose the latter. + +Another option is to investigate HTML::FillInForm which some have +reported success using to solve this problem. + +=back + +=head1 BUGS + +I am aware of no bugs - if you find one, join the mailing list and +tell us about it. You can join the HTML::Template mailing-list by +visiting: + + http://lists.sourceforge.net/lists/listinfo/html-template-users + +Of course, you can still email me directly (sam@tregar.com) with bugs, +but I reserve the right to forward bug reports to the mailing list. + +When submitting bug reports, be sure to include full details, +including the VERSION of the module, a test script and a test template +demonstrating the problem! + +If you're feeling really adventurous, HTML::Template has a publically +available CVS server. See below for more information in the PUBLIC +CVS SERVER section. + +=head1 CREDITS + +This module was the brain child of my boss, Jesse Erlbaum +( jesse@vm.com ) at Vanguard Media ( http://vm.com ) . The most original +idea in this module - the <TMPL_LOOP> - was entirely his. + +Fixes, Bug Reports, Optimizations and Ideas have been generously +provided by: + + Richard Chen + Mike Blazer + Adriano Nagelschmidt Rodrigues + Andrej Mikus + Ilya Obshadko + Kevin Puetz + Steve Reppucci + Richard Dice + Tom Hukins + Eric Zylberstejn + David Glasser + Peter Marelas + James William Carlson + Frank D. Cringle + Winfried Koenig + Matthew Wickline + Doug Steinwand + Drew Taylor + Tobias Brox + Michael Lloyd + Simran Gambhir + Chris Houser <chouser@bluweb.com> + Larry Moore + Todd Larason + Jody Biggs + T.J. Mather + Martin Schroth + Dave Wolfe + uchum + Kawai Takanori + Peter Guelich + Chris Nokleberg + Ralph Corderoy + William Ward + Ade Olonoh + Mark Stosberg + Lance Thomas + Roland Giersig + Jere Julian + Peter Leonard + Kenny Smith + Sean P. Scanlon + Martin Pfeffer + David Ferrance + Gyepi Sam + Darren Chamberlain + +Thanks! + +=head1 WEBSITE + +You can find information about HTML::Template and other related modules at: + + http://html-template.sourceforge.net + +=head1 PUBLIC CVS SERVER + +HTML::Template now has a publicly accessible CVS server provided by +SourceForge (www.sourceforge.net). You can access it by going to +http://sourceforge.net/cvs/?group_id=1075. Give it a try! + +=head1 AUTHOR + +Sam Tregar, sam@tregar.com + +=head1 LICENSE + + HTML::Template : A module for using HTML Templates with Perl + Copyright (C) 2000-2002 Sam Tregar (sam@tregar.com) + + This module is free software; you can redistribute it and/or modify it + under the terms of either: + + a) the GNU General Public License as published by the Free Software + Foundation; either version 1, or (at your option) any later version, + + or + + b) the "Artistic License" which comes with this module. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either + the GNU General Public License or the Artistic License for more details. + + You should have received a copy of the Artistic License with this + module, in the file ARTISTIC. If not, I'll be glad to provide one. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 + USA + +=cut diff --git a/lib/HTML/Template/Expr.pm b/lib/HTML/Template/Expr.pm new file mode 100644 index 0000000..e6c9dd9 --- /dev/null +++ b/lib/HTML/Template/Expr.pm @@ -0,0 +1,688 @@ +package HTML::Template::Expr; + +use strict; +use vars qw($VERSION); + +$VERSION = '0.04'; + +use HTML::Template 2.4; +use Carp qw(croak confess carp); +use Parse::RecDescent; + +use base 'HTML::Template'; + +# constants used in the expression tree +use constant BIN_OP => 1; +use constant FUNCTION_CALL => 2; + +use vars qw($GRAMMAR); +$GRAMMAR = <<END; +expression : subexpression /^\$/ { \$return = \$item[1]; } + +subexpression : binary_op { \$item[1] } + | function_call { \$item[1] } + | var { \$item[1] } + | literal { \$item[1] } + | '(' subexpression ')' { \$item[2] } + | <error> + +binary_op : '(' subexpression op subexpression ')' + { [ \$item[3][0], \$item[3][1], \$item[2], \$item[4] ] } + +op : />=?|<=?|!=|==/ { [ ${\BIN_OP}, \$item[1] ] } + | /le|ge|eq|ne|lt|gt/ { [ ${\BIN_OP}, \$item[1] ] } + | /\\|\\||or|&&|and/ { [ ${\BIN_OP}, \$item[1] ] } + | /[-+*\\/\%]/ { [ ${\BIN_OP}, \$item[1] ] } + +function_call : function_name '(' args ')' + { [ ${\FUNCTION_CALL}, \$item[1], \$item[3] ] } + | function_name ...'(' subexpression + { [ ${\FUNCTION_CALL}, \$item[1], [ \$item[3] ] ] } + | function_name '(' ')' + { [ ${\FUNCTION_CALL}, \$item[1] ] } + +function_name : /[A-Za-z_][A-Za-z0-9_]*/ + { \$item[1] } + +args : <leftop: subexpression ',' subexpression> + +var : /[A-Za-z_][A-Za-z0-9_]*/ { \\\$item[1] } + +literal : /-?\\d*\\.\\d+/ { \$item[1] } + | /-?\\d+/ { \$item[1] } + | <perl_quotelike> { \$item[1][2] } + +END + + +# create global parser +use vars qw($PARSER); +$PARSER = Parse::RecDescent->new($GRAMMAR); + +# initialize preset function table +use vars qw(%FUNC); +%FUNC = + ( + 'sprintf' => sub { sprintf(shift, @_); }, + 'substr' => sub { + return substr($_[0], $_[1]) if @_ == 2; + return substr($_[0], $_[1], $_[2]); + }, + 'lc' => sub { lc($_[0]); }, + 'lcfirst' => sub { lcfirst($_[0]); }, + 'uc' => sub { uc($_[0]); }, + 'ucfirst' => sub { ucfirst($_[0]); }, + 'length' => sub { length($_[0]); }, + 'defined' => sub { defined($_[0]); }, + 'abs' => sub { abs($_[0]); }, + 'atan2' => sub { atan2($_[0], $_[1]); }, + 'cos' => sub { cos($_[0]); }, + 'exp' => sub { exp($_[0]); }, + 'hex' => sub { hex($_[0]); }, + 'int' => sub { int($_[0]); }, + 'log' => sub { log($_[0]); }, + 'oct' => sub { oct($_[0]); }, + 'rand' => sub { rand($_[0]); }, + 'sin' => sub { sin($_[0]); }, + 'sqrt' => sub { sqrt($_[0]); }, + 'srand' => sub { srand($_[0]); }, + ); + +sub new { + my $pkg = shift; + my $self; + + # check hashworthyness + croak("HTML::Template::Expr->new() called with odd number of option parameters - should be of the form option => value") + if (@_ % 2); + my %options = @_; + + # check for unsupported options file_cache and shared_cache + croak("HTML::Template::Expr->new() : sorry, this module won't work with file_cache or shared_cache modes. This will hopefully be fixed in an upcoming version.") + if ($options{file_cache} or $options{shared_cache}); + + # push on our filter, one way or another. Why did I allow so many + # different ways to say the same thing? Was I smoking crack? + my @expr; + if (exists $options{filter}) { + # CODE => ARRAY + $options{filter} = [ { 'sub' => $options{filter}, + 'format' => 'scalar' } ] + if ref($options{filter}) eq 'CODE'; + + # HASH => ARRAY + $options{filter} = [ $options{filter} ] + if ref($options{filter}) eq 'HASH'; + + # push onto ARRAY + if (ref($options{filter}) eq 'ARRAY') { + push(@{$options{filter}}, { 'sub' => sub { _expr_filter(\@expr, @_); }, + 'format' => 'scalar' }); + } else { + # unrecognized + croak("HTML::Template::Expr->new() : bad format for filter argument. Please check the HTML::Template docs for the allowed forms."); + } + } else { + # new filter + $options{filter} = [ { 'sub' => sub { _expr_filter(\@expr, @_) }, + 'format' => 'scalar' + } ]; + } + + # force global_vars on + $options{global_vars} = 1; + + # create an HTML::Template object, catch the results to keep error + # message line-numbers helpful. + eval { + $self = $pkg->SUPER::new(%options, + expr => \@expr, + expr_func => $options{functions} || {}); + }; + croak("HTML::Template::Expr->new() : Error creating HTML::Template object : $@") if $@; + + return $self; +} + +sub _expr_filter { + my $expr = shift; + my $text = shift; + + # find expressions and create parse trees + my ($ref, $tree, $expr_text, $vars, $which, $out); + $$text =~ s/<(?:!--\s*)?[Tt][Mm][Pp][Ll]_([Ii][Ff]|[Uu][Nn][Ll][Ee][Ss][Ss]|[Vv][Aa][Rr])\s+[Ee][Xx][Pp][Rr]="(.*?)"\s*(?:--)?> + / + $which = $1; + $expr_text = $2; + + # add enclosing parens to keep grammar simple + $expr_text = "($expr_text)"; + + # parse the expression + eval { + $tree = $PARSER->expression($expr_text); + }; + croak("HTML::Template::Expr : Unable to parse expression: $expr_text") + if $@ or not $tree; + + # stub out variables needed by the expression + $out = "<tmpl_if __expr_unused__>"; + foreach my $var (_expr_vars($tree)) { + next unless defined $var; + $out .= "<tmpl_var name=\"$var\">"; + } + + # save parse tree for later + push(@$expr, $tree); + + # add the expression placeholder and replace + $out . "<\/tmpl_if><tmpl_$which __expr_" . $#{$expr} . "__>"; + /xeg; + # stupid emacs - / + + return; +} + +# find all variables in a parse tree +sub _expr_vars { + my %vars; + + while(@_) { + my $node = shift; + if (ref($node)) { + if (ref $node eq 'SCALAR') { + # found a variable + $vars{$$node} = 1; + } elsif ($node->[0] == FUNCTION_CALL) { + # function calls + push(@_, @{$node->[2]}) if defined $node->[2]; + } else { + # binary ops + push(@_, $node->[2], $node->[3]); + } + } + } + + return keys %vars; +} + + +sub output { + my $self = shift; + my $parse_stack = $self->{parse_stack}; + my $options = $self->{options}; + my ($expr, $expr_func); + + # pull expr and expr_func out of the parse_stack for cache mode. + if ($options->{cache}) { + $expr = pop @$parse_stack; + $expr_func = pop @$parse_stack; + } else { + $expr = $options->{expr}; + $expr_func = $options->{expr_func}; + } + + # setup expression evaluators + my %param; + for (my $x = 0; $x < @$expr; $x++) { + my $node = $expr->[$x]; + $param{"__expr_" . $x . "__"} = sub { _expr_evaluate($node, @_) }; + } + $self->param(\%param); + + # setup %FUNC + local %FUNC = (%FUNC, %$expr_func); + + my $result = HTML::Template::output($self, @_); + + # restore cached values to their hideout in the parse_stack + if ($options->{cache}) { + push @$parse_stack, $expr_func; + push @$parse_stack, $expr; + } + + return $result; +} + +sub _expr_evaluate { + my ($tree, $template) = @_; + my ($op, $lhs, $rhs); + + # return literals up + return $tree unless ref $tree; + + # lookup vars + return $template->param($$tree) + if ref $tree eq 'SCALAR'; + + my $type = $tree->[0]; + + # handle binary expressions + if ($type == BIN_OP) { + ($op, $lhs, $rhs) = ($tree->[1], $tree->[2], $tree->[3]); + + # recurse and resolve subexpressions + $lhs = _expr_evaluate($lhs, $template) if ref($lhs); + $rhs = _expr_evaluate($rhs, $template) if ref($rhs); + + # do the op + $op eq '==' and return $lhs == $rhs; + $op eq 'eq' and return $lhs eq $rhs; + $op eq '>' and return $lhs > $rhs; + $op eq '<' and return $lhs < $rhs; + + $op eq '!=' and return $lhs != $rhs; + $op eq 'ne' and return $lhs ne $rhs; + $op eq '>=' and return $lhs >= $rhs; + $op eq '<=' and return $lhs <= $rhs; + + $op eq '+' and return $lhs + $rhs; + $op eq '-' and return $lhs - $rhs; + $op eq '/' and return $lhs / $rhs; + $op eq '*' and return $lhs * $rhs; + $op eq '%' and return $lhs % $rhs; + + if ($op eq 'or' or $op eq '||') { + # short circuit or + $lhs = _expr_evaluate($lhs, $template) if ref $lhs; + return 1 if $lhs; + $rhs = _expr_evaluate($rhs, $template) if ref $rhs; + return 1 if $rhs; + return 0; + } else { + # short circuit and + $lhs = _expr_evaluate($lhs, $template) if ref $lhs; + return 0 unless $lhs; + $rhs = _expr_evaluate($rhs, $template) if ref $rhs; + return 0 unless $rhs; + return 1; + } + + $op eq 'le' and return $lhs le $rhs; + $op eq 'ge' and return $lhs ge $rhs; + $op eq 'lt' and return $lhs lt $rhs; + $op eq 'gt' and return $lhs gt $rhs; + + confess("HTML::Template::Expr : unknown op: $op"); + } + + if ($type == FUNCTION_CALL) { + croak("HTML::Template::Expr : found unknown subroutine call : $tree->[1]\n") unless exists($FUNC{$tree->[1]}); + + if (defined $tree->[2]) { + return $FUNC{$tree->[1]}->( + map { _expr_evaluate($_, $template) } @{$tree->[2]} + ); + } else { + return $FUNC{$tree->[1]}->(); + } + } + + croak("HTML::Template::Expr : fell off the edge of _expr_evaluate()! This is a bug - please report it to the author."); +} + +sub register_function { + my($class, $name, $sub) = @_; + + croak("HTML::Template::Expr : args 3 of register_function must be subroutine reference\n") + unless ref($sub) eq 'CODE'; + + $FUNC{$name} = $sub; +} + + +# Make caching work right by hiding our vars in the parse_stack +# between cache store and load. This is such a hack. +sub _commit_to_cache { + my $self = shift; + my $parse_stack = $self->{parse_stack}; + + push @$parse_stack, $self->{options}{expr_func}; + push @$parse_stack, $self->{options}{expr}; + + my $result = HTML::Template::_commit_to_cache($self, @_); +} + +1; +__END__ +=pod + +=head1 NAME + +HTML::Template::Expr - HTML::Template extension adding expression support + +=head1 SYNOPSIS + + use HTML::Template::Expr; + + my $template = HTML::Template::Expr->new(filename => 'foo.tmpl'); + $template->param(banana_count => 10); + print $template->output(); + +=head1 DESCRIPTION + +This module provides an extension to HTML::Template which allows +expressions in the template syntax. This is purely an addition - all +the normal HTML::Template options, syntax and behaviors will still +work. See L<HTML::Template> for details. + +Expression support includes comparisons, math operations, string +operations and a mechanism to allow you add your own functions at +runtime. The basic syntax is: + + <TMPL_IF EXPR="banana_count > 10"> + I've got a lot of bananas. + </TMPL_IF> + +This will output "I've got a lot of bananas" if you call: + + $template->param(banana_count => 100); + +In your script. <TMPL_VAR>s also work with expressions: + + I'd like to have <TMPL_VAR EXPR="banana_count * 2"> bananas. + +This will output "I'd like to have 200 bananas." with the same param() +call as above. + +=head1 MOTIVATION + +Some of you may wonder if I've been replaced by a pod person. Just +for the record, I still think this sort of thing should be avoided. +However, I realize that there are some situations where allowing the +template author some programatic leeway can be invaluable. + +If you don't like it, don't use this module. Keep using plain ol' +HTML::Template - I know I will! However, if you find yourself needing +a little programming in your template, for whatever reason, then this +module may just save you from HTML::Mason. + +=head1 BASIC SYNTAX + +Variables are unquoted alphanumeric strings with the same restrictions +as variable names in HTML::Template. Their values are set through +param(), just like normal HTML::Template variables. For example, +these two lines are equivalent: + + <TMPL_VAR EXPR="foo"> + + <TMPL_VAR NAME="foo"> + +Numbers are unquoted strings of numbers and may have a single "." to +indicate a floating point number. For example: + + <TMPL_VAR EXPR="10 + 20.5"> + +String constants must be enclosed in quotes, single or double. For example: + + <TMPL_VAR EXPR="sprintf('%d', foo)"> + +The parser is currently rather simple, so all compound expressions +must be parenthesized. Examples: + + <TMPL_VAR EXPR="(10 + foo) / bar"> + + <TMPL_IF EXPR="(foo % 10) > (bar + 1)"> + +If you don't like this rule please feel free to contribute a patch +to improve the parser's grammar. + +=head1 COMPARISON + +Here's a list of supported comparison operators: + +=over 4 + +=item * Numeric Comparisons + +=over 4 + +=item * E<lt> + +=item * E<gt> + +=item * == + +=item * != + +=item * E<gt>= + +=item * E<lt>= + +=item * E<lt>=E<gt> + +=back 4 + +=item * String Comparisons + +=over 4 + +=item * gt + +=item * lt + +=item * eq + +=item * ne + +=item * ge + +=item * le + +=item * cmp + +=back 4 + +=back 4 + +=head1 MATHEMATICS + +The basic operators are supported: + +=over 4 + +=item * + + +=item * - + +=item * * + +=item * / + +=item * % + +=back 4 + +There are also some mathy functions. See the FUNCTIONS section below. + +=head1 LOGIC + +Boolean logic is available: + +=over 4 + +=item * && (synonym: and) + +=item * || (synonym: or) + +=back 4 + +=head1 FUNCTIONS + +The following functions are available to be used in expressions. See +perldoc perlfunc for details. + +=over 4 + +=item * sprintf + +=item * substr (2 and 3 arg versions only) + +=item * lc + +=item * lcfirst + +=item * uc + +=item * ucfirst + +=item * length + +=item * defined + +=item * abs + +=item * atan2 + +=item * cos + +=item * exp + +=item * hex + +=item * int + +=item * log + +=item * oct + +=item * rand + +=item * sin + +=item * sqrt + +=item * srand + +=back 4 + +All functions must be called using full parenthesis. For example, +this is a syntax error: + + <TMPL_IF expr="defined foo"> + +But this is good: + + <TMPL_IF expr="defined(foo)"> + +=head1 DEFINING NEW FUNCTIONS + +To define a new function, pass a C<functions> option to new: + + $t = HTML::Template::Expr->new(filename => 'foo.tmpl', + functions => + { func_name => \&func_handler }); + +Or, you can use C<register_function> class method to register +the function globally: + + HTML::Template::Expr->register_function(func_name => \&func_handler); + +You provide a subroutine reference that will be called during output. +It will recieve as arguments the parameters specified in the template. +For example, here's a function that checks if a directory exists: + + sub directory_exists { + my $dir_name = shift; + return 1 if -d $dir_name; + return 0; + } + +If you call HTML::Template::Expr->new() with a C<functions> arg: + + $t = HTML::Template::Expr->new(filename => 'foo.tmpl', + functions => { + directory_exists => \&directory_exists + }); + +Then you can use it in your template: + + <tmpl_if expr="directory_exists('/home/sam')"> + +This can be abused in ways that make my teeth hurt. + +=head1 MOD_PERL TIP + +C<register_function> class method can be called in mod_perl's +startup.pl to define widely used common functions to +HTML::Template::Expr. Add something like this to your startup.pl: + + use HTML::Template::Expr; + + HTML::Template::Expr->register_function(foozicate => sub { ... }); + HTML::Template::Expr->register_function(barify => sub { ... }); + HTML::Template::Expr->register_function(baznate => sub { ... }); + +You might also want to pre-compile some commonly used templates and +cache them. See L<HTML::Template>'s FAQ for instructions. + +=head1 CAVEATS + +Currently the module forces the HTML::Template global_vars option to +be set. This will hopefully go away in a future version, so if you +need global_vars in your templates then you should set it explicitely. + +The module won't work with HTML::Template's file_cache or shared_cache +modes, but normal memory caching should work. I hope to address this +is a future version. + +The module is inefficient, both in parsing and evaluation. I'll be +working on this for future versions and patches are always welcome. + +=head1 BUGS + +I am aware of no bugs - if you find one, join the mailing list and +tell us about it. You can join the HTML::Template mailing-list by +visiting: + + http://lists.sourceforge.net/lists/listinfo/html-template-users + +Of course, you can still email me directly (sam@tregar.com) with bugs, +but I reserve the right to forward bug reports to the mailing list. + +When submitting bug reports, be sure to include full details, +including the VERSION of the module, a test script and a test template +demonstrating the problem! + +=head1 CREDITS + +The following people have generously submitted bug reports, patches +and ideas: + + Peter Leonard + Tatsuhiko Miyagawa + +Thanks! + +=head1 AUTHOR + +Sam Tregar <sam@tregar.com> + +=head1 LICENSE + +HTML::Template::Expr : HTML::Template extension adding expression support + +Copyright (C) 2001 Sam Tregar (sam@tregar.com) + +This module is free software; you can redistribute it and/or modify it +under the terms of either: + +a) the GNU General Public License as published by the Free Software +Foundation; either version 1, or (at your option) any later version, +or + +b) the "Artistic License" which comes with this module. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either +the GNU General Public License or the Artistic License for more details. + +You should have received a copy of the Artistic License with this +module, in the file ARTISTIC. If not, I'll be glad to provide one. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 +USA + diff --git a/lib/MIME/Base64.pm b/lib/MIME/Base64.pm new file mode 100644 index 0000000..f29c889 --- /dev/null +++ b/lib/MIME/Base64.pm @@ -0,0 +1,202 @@ +# +# $Id: Base64.pm,v 2.16 2001/02/24 06:28:10 gisle Exp $ + +package MIME::Base64; + +=head1 NAME + +MIME::Base64 - Encoding and decoding of base64 strings + +=head1 SYNOPSIS + + use MIME::Base64; + + $encoded = encode_base64('Aladdin:open sesame'); + $decoded = decode_base64($encoded); + +=head1 DESCRIPTION + +This module provides functions to encode and decode strings into the +Base64 encoding specified in RFC 2045 - I<MIME (Multipurpose Internet +Mail Extensions)>. The Base64 encoding is designed to represent +arbitrary sequences of octets in a form that need not be humanly +readable. A 65-character subset ([A-Za-z0-9+/=]) of US-ASCII is used, +enabling 6 bits to be represented per printable character. + +The following functions are provided: + +=over 4 + +=item encode_base64($str, [$eol]) + +Encode data by calling the encode_base64() function. The first +argument is the string to encode. The second argument is the line +ending sequence to use (it is optional and defaults to C<"\n">). The +returned encoded string is broken into lines of no more than 76 +characters each and it will end with $eol unless it is empty. Pass an +empty string as second argument if you do not want the encoded string +broken into lines. + +=item decode_base64($str) + +Decode a base64 string by calling the decode_base64() function. This +function takes a single argument which is the string to decode and +returns the decoded data. + +Any character not part of the 65-character base64 subset set is +silently ignored. Characters occuring after a '=' padding character +are never decoded. + +If the length of the string to decode (after ignoring +non-base64 chars) is not a multiple of 4 or padding occurs too ealy, +then a warning is generated if perl is running under C<-w>. + +=back + +If you prefer not to import these routines into your namespace you can +call them as: + + use MIME::Base64 (); + $encoded = MIME::Base64::encode($decoded); + $decoded = MIME::Base64::decode($encoded); + +=head1 DIAGNOSTICS + +The following warnings might be generated if perl is invoked with the +C<-w> switch: + +=over 4 + +=item Premature end of base64 data + +The number of characters to decode is not a multiple of 4. Legal +base64 data should be padded with one or two "=" characters to make +its length a multiple of 4. The decoded result will anyway be as if +the padding was there. + +=item Premature padding of base64 data + +The '=' padding character occurs as the first or second character +in a base64 quartet. + +=back + +=head1 EXAMPLES + +If you want to encode a large file, you should encode it in chunks +that are a multiple of 57 bytes. This ensures that the base64 lines +line up and that you do not end up with padding in the middle. 57 +bytes of data fills one complete base64 line (76 == 57*4/3): + + use MIME::Base64 qw(encode_base64); + + open(FILE, "/var/log/wtmp") or die "$!"; + while (read(FILE, $buf, 60*57)) { + print encode_base64($buf); + } + +or if you know you have enough memory + + use MIME::Base64 qw(encode_base64); + local($/) = undef; # slurp + print encode_base64(<STDIN>); + +The same approach as a command line: + + perl -MMIME::Base64 -0777 -ne 'print encode_base64($_)' <file + +Decoding does not need slurp mode if all the lines contains a multiple +of 4 base64 chars: + + perl -MMIME::Base64 -ne 'print decode_base64($_)' <file + +=head1 COPYRIGHT + +Copyright 1995-1999, 2001 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +Distantly based on LWP::Base64 written by Martijn Koster +<m.koster@nexor.co.uk> and Joerg Reichelt <j.reichelt@nexor.co.uk> and +code posted to comp.lang.perl <3pd2lp$6gf@wsinti07.win.tue.nl> by Hans +Mulder <hansm@wsinti07.win.tue.nl> + +The XS implementation use code from metamail. Copyright 1991 Bell +Communications Research, Inc. (Bellcore) + +=cut + +use strict; +use vars qw(@ISA @EXPORT $VERSION $OLD_CODE); + +require Exporter; +require DynaLoader; +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw(encode_base64 decode_base64); + +$VERSION = '2.12'; + +eval { bootstrap MIME::Base64 $VERSION; }; +if ($@) { + # can't bootstrap XS implementation, use perl implementation + *encode_base64 = \&old_encode_base64; + *decode_base64 = \&old_decode_base64; + + $OLD_CODE = $@; + #warn $@ if $^W; +} + +# Historically this module has been implemented as pure perl code. +# The XS implementation runs about 20 times faster, but the Perl +# code might be more portable, so it is still here. + +use integer; + +sub old_encode_base64 ($;$) +{ + my $res = ""; + my $eol = $_[1]; + $eol = "\n" unless defined $eol; + pos($_[0]) = 0; # ensure start at the beginning + + $res = join '', map( pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs)); + + $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs + # fix padding at the end + my $padding = (3 - length($_[0]) % 3) % 3; + $res =~ s/.{$padding}$/'=' x $padding/e if $padding; + # break encoded string into lines of no more than 76 characters each + if (length $eol) { + $res =~ s/(.{1,76})/$1$eol/g; + } + return $res; +} + + +sub old_decode_base64 ($) +{ + local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123] + + my $str = shift; + $str =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars + if (length($str) % 4) { + require Carp; + Carp::carp("Length of base64 data not a multiple of 4") + } + $str =~ s/=+$//; # remove padding + $str =~ tr|A-Za-z0-9+/| -_|; # convert to uuencoded format + + return join'', map( unpack("u", chr(32 + length($_)*3/4) . $_), + $str =~ /(.{1,60})/gs); +} + +# Set up aliases so that these functions also can be called as +# +# MIME::Base64::encode(); +# MIME::Base64::decode(); + +*encode = \&encode_base64; +*decode = \&decode_base64; + +1; diff --git a/lib/Parse/RecDescent.pm b/lib/Parse/RecDescent.pm new file mode 100644 index 0000000..35b9e9d --- /dev/null +++ b/lib/Parse/RecDescent.pm @@ -0,0 +1,3045 @@ +# GENERATE RECURSIVE DESCENT PARSER OBJECTS FROM A GRAMMARC +# SEE RecDescent.pod FOR FULL DETAILS + +use 5.005; +use strict; + +package Parse::RecDescent; + +use Text::Balanced qw ( extract_codeblock extract_bracketed extract_quotelike extract_delimited ); + +use vars qw ( $skip ); + + *defskip = \ '\s*'; # DEFAULT SEPARATOR IS OPTIONAL WHITESPACE + $skip = '\s*'; # UNIVERSAL SEPARATOR IS OPTIONAL WHITESPACE +my $MAXREP = 100_000_000; # REPETITIONS MATCH AT MOST 100,000,000 TIMES + + +sub import # IMPLEMENT PRECOMPILER BEHAVIOUR UNDER: + # perl -MParse::RecDescent - <grammarfile> <classname> +{ + local *_die = sub { print @_, "\n"; exit }; + + my ($package, $file, $line) = caller; + if (substr($file,0,1) eq '-' && $line == 0) + { + _die("Usage: perl -MLocalTest - <grammarfile> <classname>") + unless @ARGV == 2; + + my ($sourcefile, $class) = @ARGV; + + local *IN; + open IN, $sourcefile + or _die("Can't open grammar file '$sourcefile'"); + + my $grammar = join '', <IN>; + + Parse::RecDescent->Precompile($grammar, $class, $sourcefile); + exit; + } +} + +sub Save +{ + my ($self, $class) = @_; + $self->{saving} = 1; + $self->Precompile(undef,$class); + $self->{saving} = 0; +} + +sub Precompile +{ + my ($self, $grammar, $class, $sourcefile) = @_; + + $class =~ /^(\w+::)*\w+$/ or croak("Bad class name: $class"); + + my $modulefile = $class; + $modulefile =~ s/.*:://; + $modulefile .= ".pm"; + + open OUT, ">$modulefile" + or croak("Can't write to new module file '$modulefile'"); + + print STDERR "precompiling grammar from file '$sourcefile'\n", + "to class $class in module file '$modulefile'\n" + if $grammar && $sourcefile; + + # local $::RD_HINT = 1; + $self = Parse::RecDescent->new($grammar,1,$class) + || croak("Can't compile bad grammar") + if $grammar; + + foreach ( keys %{$self->{rules}} ) + { $self->{rules}{$_}{changed} = 1 } + + print OUT "package $class;\nuse Parse::RecDescent;\n\n"; + + print OUT "{ my \$ERRORS;\n\n"; + + print OUT $self->_code(); + + print OUT "}\npackage $class; sub new { "; + print OUT "my "; + + require Data::Dumper; + print OUT Data::Dumper->Dump([$self], [qw(self)]); + + print OUT "}"; + + close OUT + or croak("Can't write to new module file '$modulefile'"); +} + + +package Parse::RecDescent::LineCounter; + + +sub TIESCALAR # ($classname, \$text, $thisparser, $prevflag) +{ + bless { + text => $_[1], + parser => $_[2], + prev => $_[3]?1:0, + }, $_[0]; +} + +my %counter_cache; + +sub FETCH +{ + my $parser = $_[0]->{parser}; + my $from = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev} +; + + unless (exists $counter_cache{$from}) { + $parser->{lastlinenum} = $parser->{offsetlinenum} + - Parse::RecDescent::_linecount(substr($parser->{fulltext},$from)) + + 1; + $counter_cache{$from} = $parser->{lastlinenum}; + } + return $counter_cache{$from}; +} + +sub STORE +{ + my $parser = $_[0]->{parser}; + $parser->{offsetlinenum} -= $parser->{lastlinenum} - $_[1]; + return undef; +} + +sub resync # ($linecounter) +{ + my $self = tied($_[0]); + die "Tried to alter something other than a LineCounter\n" + unless $self =~ /Parse::RecDescent::LineCounter/; + + my $parser = $self->{parser}; + my $apparently = $parser->{offsetlinenum} + - Parse::RecDescent::_linecount(${$self->{text}}) + + 1; + + $parser->{offsetlinenum} += $parser->{lastlinenum} - $apparently; + return 1; +} + +package Parse::RecDescent::ColCounter; + +sub TIESCALAR # ($classname, \$text, $thisparser, $prevflag) +{ + bless { + text => $_[1], + parser => $_[2], + prev => $_[3]?1:0, + }, $_[0]; +} + +sub FETCH +{ + my $parser = $_[0]->{parser}; + my $missing = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}+1; + substr($parser->{fulltext},0,$missing) =~ m/^(.*)\Z/m; + return length($1); +} + +sub STORE +{ + die "Can't set column number via \$thiscolumn\n"; +} + + +package Parse::RecDescent::OffsetCounter; + +sub TIESCALAR # ($classname, \$text, $thisparser, $prev) +{ + bless { + text => $_[1], + parser => $_[2], + prev => $_[3]?-1:0, + }, $_[0]; +} + +sub FETCH +{ + my $parser = $_[0]->{parser}; + return $parser->{fulltextlen}-length(${$_[0]->{text}})+$_[0]->{prev}; +} + +sub STORE +{ + die "Can't set current offset via \$thisoffset or \$prevoffset\n"; +} + + + +package Parse::RecDescent::Rule; + +sub new ($$$$$) +{ + my $class = ref($_[0]) || $_[0]; + my $name = $_[1]; + my $owner = $_[2]; + my $line = $_[3]; + my $replace = $_[4]; + + if (defined $owner->{"rules"}{$name}) + { + my $self = $owner->{"rules"}{$name}; + if ($replace && !$self->{"changed"}) + { + $self->reset; + } + return $self; + } + else + { + return $owner->{"rules"}{$name} = + bless + { + "name" => $name, + "prods" => [], + "calls" => [], + "changed" => 0, + "line" => $line, + "impcount" => 0, + "opcount" => 0, + "vars" => "", + }, $class; + } +} + +sub reset($) +{ + @{$_[0]->{"prods"}} = (); + @{$_[0]->{"calls"}} = (); + $_[0]->{"changed"} = 0; + $_[0]->{"impcount"} = 0; + $_[0]->{"opcount"} = 0; + $_[0]->{"vars"} = ""; +} + +sub DESTROY {} + +sub hasleftmost($$) +{ + my ($self, $ref) = @_; + + my $prod; + foreach $prod ( @{$self->{"prods"}} ) + { + return 1 if $prod->hasleftmost($ref); + } + + return 0; +} + +sub leftmostsubrules($) +{ + my $self = shift; + my @subrules = (); + + my $prod; + foreach $prod ( @{$self->{"prods"}} ) + { + push @subrules, $prod->leftmostsubrule(); + } + + return @subrules; +} + +sub expected($) +{ + my $self = shift; + my @expected = (); + + my $prod; + foreach $prod ( @{$self->{"prods"}} ) + { + my $next = $prod->expected(); + unless (! $next or _contains($next,@expected) ) + { + push @expected, $next; + } + } + + return join ', or ', @expected; +} + +sub _contains($@) +{ + my $target = shift; + my $item; + foreach $item ( @_ ) { return 1 if $target eq $item; } + return 0; +} + +sub addcall($$) +{ + my ( $self, $subrule ) = @_; + unless ( _contains($subrule, @{$self->{"calls"}}) ) + { + push @{$self->{"calls"}}, $subrule; + } +} + +sub addprod($$) +{ + my ( $self, $prod ) = @_; + push @{$self->{"prods"}}, $prod; + $self->{"changed"} = 1; + $self->{"impcount"} = 0; + $self->{"opcount"} = 0; + $prod->{"number"} = $#{$self->{"prods"}}; + return $prod; +} + +sub addvar +{ + my ( $self, $var, $parser ) = @_; + if ($var =~ /\A\s*local\s+([%@\$]\w+)/) + { + $parser->{localvars} .= " $1"; + $self->{"vars"} .= "$var;\n" } + else + { $self->{"vars"} .= "my $var;\n" } + $self->{"changed"} = 1; + return 1; +} + +sub addautoscore +{ + my ( $self, $code ) = @_; + $self->{"autoscore"} = $code; + $self->{"changed"} = 1; + return 1; +} + +sub nextoperator($) +{ + my $self = shift; + my $prodcount = scalar @{$self->{"prods"}}; + my $opcount = ++$self->{"opcount"}; + return "_operator_${opcount}_of_production_${prodcount}_of_rule_$self->{name}"; +} + +sub nextimplicit($) +{ + my $self = shift; + my $prodcount = scalar @{$self->{"prods"}}; + my $impcount = ++$self->{"impcount"}; + return "_alternation_${impcount}_of_production_${prodcount}_of_rule_$self->{name}"; +} + + +sub code +{ + my ($self, $namespace, $parser) = @_; + +eval 'undef &' . $namespace . '::' . $self->{"name"} unless $parser->{saving}; + + my $code = +' +# ARGS ARE: ($parser, $text; $repeating, $_noactions, \@args) +sub ' . $namespace . '::' . $self->{"name"} . ' +{ + my $thisparser = $_[0]; + use vars q{$tracelevel}; + local $tracelevel = ($tracelevel||0)+1; + $ERRORS = 0; + my $thisrule = $thisparser->{"rules"}{"' . $self->{"name"} . '"}; + + Parse::RecDescent::_trace(q{Trying rule: [' . $self->{"name"} . ']}, + Parse::RecDescent::_tracefirst($_[1]), + q{' . $self->{"name"} . '}, + $tracelevel) + if defined $::RD_TRACE; + + ' . ($parser->{deferrable} + ? 'my $def_at = @{$thisparser->{deferred}};' + : '') . + ' + my $err_at = @{$thisparser->{errors}}; + + my $score; + my $score_return; + my $_tok; + my $return = undef; + my $_matched=0; + my $commit=0; + my @item = (); + my %item = (); + my $repeating = defined($_[2]) && $_[2]; + my $_noactions = defined($_[3]) && $_[3]; + my @arg = defined $_[4] ? @{ &{$_[4]} } : (); + my %arg = ($#arg & 01) ? @arg : (@arg, undef); + my $text; + my $lastsep=""; + my $expectation = new Parse::RecDescent::Expectation($thisrule->expected()); + $expectation->at($_[1]); + '. ($parser->{_check}{thisoffset}?' + my $thisoffset; + tie $thisoffset, q{Parse::RecDescent::OffsetCounter}, \$text, $thisparser; + ':'') . ($parser->{_check}{prevoffset}?' + my $prevoffset; + tie $prevoffset, q{Parse::RecDescent::OffsetCounter}, \$text, $thisparser, 1; + ':'') . ($parser->{_check}{thiscolumn}?' + my $thiscolumn; + tie $thiscolumn, q{Parse::RecDescent::ColCounter}, \$text, $thisparser; + ':'') . ($parser->{_check}{prevcolumn}?' + my $prevcolumn; + tie $prevcolumn, q{Parse::RecDescent::ColCounter}, \$text, $thisparser, 1; + ':'') . ($parser->{_check}{prevline}?' + my $prevline; + tie $prevline, q{Parse::RecDescent::LineCounter}, \$text, $thisparser, 1; + ':'') . ' + my $thisline; + tie $thisline, q{Parse::RecDescent::LineCounter}, \$text, $thisparser; + + '. $self->{vars} .' +'; + + my $prod; + foreach $prod ( @{$self->{"prods"}} ) + { + $prod->addscore($self->{autoscore},0,0) if $self->{autoscore}; + next unless $prod->checkleftmost(); + $code .= $prod->code($namespace,$self,$parser); + + $code .= $parser->{deferrable} + ? ' splice + @{$thisparser->{deferred}}, $def_at unless $_matched; + ' + : ''; + } + + $code .= +' + unless ( $_matched || defined($return) || defined($score) ) + { + ' .($parser->{deferrable} + ? ' splice @{$thisparser->{deferred}}, $def_at; + ' + : '') . ' + + $_[1] = $text; # NOT SURE THIS IS NEEDED + Parse::RecDescent::_trace(q{<<Didn\'t match rule>>}, + Parse::RecDescent::_tracefirst($_[1]), + q{' . $self->{"name"} .'}, + $tracelevel) + if defined $::RD_TRACE; + return undef; + } + if (!defined($return) && defined($score)) + { + Parse::RecDescent::_trace(q{>>Accepted scored production<<}, "", + q{' . $self->{"name"} .'}, + $tracelevel) + if defined $::RD_TRACE; + $return = $score_return; + } + splice @{$thisparser->{errors}}, $err_at; + $return = $item[$#item] unless defined $return; + if (defined $::RD_TRACE) + { + Parse::RecDescent::_trace(q{>>Matched rule<< (return value: [} . + $return . q{])}, "", + q{' . $self->{"name"} .'}, + $tracelevel); + Parse::RecDescent::_trace(q{(consumed: [} . + Parse::RecDescent::_tracemax(substr($_[1],0,-length($text))) . q{])}, + Parse::RecDescent::_tracefirst($text), + , q{' . $self->{"name"} .'}, + $tracelevel) + } + $_[1] = $text; + return $return; +} +'; + + return $code; +} + +my @left; +sub isleftrec($$) +{ + my ($self, $rules) = @_; + my $root = $self->{"name"}; + @left = $self->leftmostsubrules(); + my $next; + foreach $next ( @left ) + { + next unless defined $rules->{$next}; # SKIP NON-EXISTENT RULES + return 1 if $next eq $root; + my $child; + foreach $child ( $rules->{$next}->leftmostsubrules() ) + { + push(@left, $child) + if ! _contains($child, @left) ; + } + } + return 0; +} + +package Parse::RecDescent::Production; + +sub describe ($;$) +{ + return join ' ', map { $_->describe($_[1]) or () } @{$_[0]->{items}}; +} + +sub new ($$;$$) +{ + my ($self, $line, $uncommit, $error) = @_; + my $class = ref($self) || $self; + + bless + { + "items" => [], + "uncommit" => $uncommit, + "error" => $error, + "line" => $line, + strcount => 0, + patcount => 0, + dircount => 0, + actcount => 0, + }, $class; +} + +sub expected ($) +{ + my $itemcount = scalar @{$_[0]->{"items"}}; + return ($itemcount) ? $_[0]->{"items"}[0]->describe(1) : ''; +} + +sub hasleftmost ($$) +{ + my ($self, $ref) = @_; + return ${$self->{"items"}}[0] eq $ref if scalar @{$self->{"items"}}; + return 0; +} + +sub leftmostsubrule($) +{ + my $self = shift; + + if ( $#{$self->{"items"}} >= 0 ) + { + my $subrule = $self->{"items"}[0]->issubrule(); + return $subrule if defined $subrule; + } + + return (); +} + +sub checkleftmost($) +{ + my @items = @{$_[0]->{"items"}}; + if (@items==1 && ref($items[0]) =~ /\AParse::RecDescent::Error/ + && $items[0]->{commitonly} ) + { + Parse::RecDescent::_warn(2,"Lone <error?> in production treated + as <error?> <reject>"); + Parse::RecDescent::_hint("A production consisting of a single + conditional <error?> directive would + normally succeed (with the value zero) if the + rule is not 'commited' when it is + tried. Since you almost certainly wanted + '<error?> <reject>' Parse::RecDescent + supplied it for you."); + push @{$_[0]->{items}}, + Parse::RecDescent::UncondReject->new(0,0,'<reject>'); + } + elsif (@items==1 && ($items[0]->describe||"") =~ /<rulevar|<autoscore/) + { + # Do nothing + } + elsif (@items && + ( ref($items[0]) =~ /\AParse::RecDescent::UncondReject/ + || ($items[0]->describe||"") =~ /<autoscore/ + )) + { + Parse::RecDescent::_warn(1,"Optimizing away production: [". $_[0]->describe ."]"); + my $what = $items[0]->describe =~ /<rulevar/ + ? "a <rulevar> (which acts like an unconditional <reject> during parsing)" + : $items[0]->describe =~ /<autoscore/ + ? "an <autoscore> (which acts like an unconditional <reject> during parsing)" + : "an unconditional <reject>"; + my $caveat = $items[0]->describe =~ /<rulevar/ + ? " after the specified variable was set up" + : ""; + my $advice = @items > 1 + ? "However, there were also other (useless) items after the leading " + . $items[0]->describe + . ", so you may have been expecting some other behaviour." + : "You can safely ignore this message."; + Parse::RecDescent::_hint("The production starts with $what. That means that the + production can never successfully match, so it was + optimized out of the final parser$caveat. $advice"); + return 0; + } + return 1; +} + +sub changesskip($) +{ + my $item; + foreach $item (@{$_[0]->{"items"}}) + { + if (ref($item) =~ /Parse::RecDescent::(Action|Directive)/) + { + return 1 if $item->{code} =~ /\$skip/; + } + } + return 0; +} + +sub adddirective +{ + my ( $self, $whichop, $line, $name ) = @_; + push @{$self->{op}}, + { type=>$whichop, line=>$line, name=>$name, + offset=> scalar(@{$self->{items}}) }; +} + +sub addscore +{ + my ( $self, $code, $lookahead, $line ) = @_; + $self->additem(Parse::RecDescent::Directive->new( + "local \$^W; + my \$thisscore = do { $code } + 0; + if (!defined(\$score) || \$thisscore>\$score) + { \$score=\$thisscore; \$score_return=\$item[-1]; } + undef;", $lookahead, $line,"<score: $code>") ) + unless $self->{items}[-1]->describe =~ /<score/; + return 1; +} + +sub check_pending +{ + my ( $self, $line ) = @_; + if ($self->{op}) + { + while (my $next = pop @{$self->{op}}) + { + Parse::RecDescent::_error("Incomplete <$next->{type}op:...>.", $line); + Parse::RecDescent::_hint( + "The current production ended without completing the + <$next->{type}op:...> directive that started near line + $next->{line}. Did you forget the closing '>'?"); + } + } + return 1; +} + +sub enddirective +{ + my ( $self, $line, $minrep, $maxrep ) = @_; + unless ($self->{op}) + { + Parse::RecDescent::_error("Unmatched > found.", $line); + Parse::RecDescent::_hint( + "A '>' angle bracket was encountered, which typically + indicates the end of a directive. However no suitable + preceding directive was encountered. Typically this + indicates either a extra '>' in the grammar, or a + problem inside the previous directive."); + return; + } + my $op = pop @{$self->{op}}; + my $span = @{$self->{items}} - $op->{offset}; + if ($op->{type} =~ /left|right/) + { + if ($span != 3) + { + Parse::RecDescent::_error( + "Incorrect <$op->{type}op:...> specification: + expected 3 args, but found $span instead", $line); + Parse::RecDescent::_hint( + "The <$op->{type}op:...> directive requires a + sequence of exactly three elements. For example: + <$op->{type}op:leftarg /op/ rightarg>"); + } + else + { + push @{$self->{items}}, + Parse::RecDescent::Operator->new( + $op->{type}, $minrep, $maxrep, splice(@{$self->{"items"}}, -3)); + $self->{items}[-1]->sethashname($self); + $self->{items}[-1]{name} = $op->{name}; + } + } +} + +sub prevwasreturn +{ + my ( $self, $line ) = @_; + unless (@{$self->{items}}) + { + Parse::RecDescent::_error( + "Incorrect <return:...> specification: + expected item missing", $line); + Parse::RecDescent::_hint( + "The <return:...> directive requires a + sequence of at least one item. For example: + <return: list>"); + return; + } + push @{$self->{items}}, + Parse::RecDescent::Result->new(); +} + +sub additem +{ + my ( $self, $item ) = @_; + $item->sethashname($self); + push @{$self->{"items"}}, $item; + return $item; +} + + +sub preitempos +{ + return q + { + push @itempos, {'offset' => {'from'=>$thisoffset, 'to'=>undef}, + 'line' => {'from'=>$thisline, 'to'=>undef}, + 'column' => {'from'=>$thiscolumn, 'to'=>undef} }; + } +} + +sub incitempos +{ + return q + { + $itempos[$#itempos]{'offset'}{'from'} += length($1); + $itempos[$#itempos]{'line'}{'from'} = $thisline; + $itempos[$#itempos]{'column'}{'from'} = $thiscolumn; + } +} + +sub postitempos +{ + return q + { + $itempos[$#itempos]{'offset'}{'to'} = $prevoffset; + $itempos[$#itempos]{'line'}{'to'} = $prevline; + $itempos[$#itempos]{'column'}{'to'} = $prevcolumn; + } +} + +sub code($$$$) +{ + my ($self,$namespace,$rule,$parser) = @_; + my $code = +' + while (!$_matched' + . (defined $self->{"uncommit"} ? '' : ' && !$commit') + . ') + { + ' . + ($self->changesskip() + ? 'local $skip = defined($skip) ? $skip : $Parse::RecDescent::skip;' + : '') .' + Parse::RecDescent::_trace(q{Trying production: [' + . $self->describe . ']}, + Parse::RecDescent::_tracefirst($_[1]), + q{' . $rule ->{name}. '}, + $tracelevel) + if defined $::RD_TRACE; + my $thisprod = $thisrule->{"prods"}[' . $self->{"number"} . ']; + ' . (defined $self->{"error"} ? '' : '$text = $_[1];' ) . ' + my $_savetext; + @item = (q{' . $rule->{"name"} . '}); + %item = (__RULE__ => q{' . $rule->{"name"} . '}); + my $repcount = 0; + +'; + $code .= +' my @itempos = ({}); +' if $parser->{_check}{itempos}; + + my $item; + my $i; + + for ($i = 0; $i < @{$self->{"items"}}; $i++) + { + $item = ${$self->{items}}[$i]; + + $code .= preitempos() if $parser->{_check}{itempos}; + + $code .= $item->code($namespace,$rule,$parser->{_check}); + + $code .= postitempos() if $parser->{_check}{itempos}; + + } + + if ($parser->{_AUTOACTION} && defined($item) && !$item->isa("Parse::RecDescent::Action")) + { + $code .= $parser->{_AUTOACTION}->code($namespace,$rule); + Parse::RecDescent::_warn(1,"Autogenerating action in rule + \"$rule->{name}\": + $parser->{_AUTOACTION}{code}") + and + Parse::RecDescent::_hint("The \$::RD_AUTOACTION was defined, + so any production not ending in an + explicit action has the specified + \"auto-action\" automatically + appended."); + } + elsif ($parser->{_AUTOTREE} && defined($item) && !$item->isa("Parse::RecDescent::Action")) + { + if ($i==1 && $item->isterminal) + { + $code .= $parser->{_AUTOTREE}{TERMINAL}->code($namespace,$rule); + } + else + { + $code .= $parser->{_AUTOTREE}{NODE}->code($namespace,$rule); + } + Parse::RecDescent::_warn(1,"Autogenerating tree-building action in rule + \"$rule->{name}\"") + and + Parse::RecDescent::_hint("The directive <autotree> was specified, + so any production not ending + in an explicit action has + some parse-tree building code + automatically appended."); + } + + $code .= +' + + Parse::RecDescent::_trace(q{>>Matched production: [' + . $self->describe . ']<<}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{name} . '}, + $tracelevel) + if defined $::RD_TRACE; + $_matched = 1; + last; + } + +'; + return $code; +} + +1; + +package Parse::RecDescent::Action; + +sub describe { undef } + +sub sethashname { $_[0]->{hashname} = '__ACTION' . ++$_[1]->{actcount} .'__'; } + +sub new +{ + my $class = ref($_[0]) || $_[0]; + bless + { + "code" => $_[1], + "lookahead" => $_[2], + "line" => $_[3], + }, $class; +} + +sub issubrule { undef } +sub isterminal { 0 } + +sub code($$$$) +{ + my ($self, $namespace, $rule) = @_; + +' + Parse::RecDescent::_trace(q{Trying action}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{name} . '}, + $tracelevel) + if defined $::RD_TRACE; + ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .' + + $_tok = ($_noactions) ? 0 : do ' . $self->{"code"} . '; + ' . ($self->{"lookahead"}<0?'if':'unless') . ' (defined $_tok) + { + Parse::RecDescent::_trace(q{<<Didn\'t match action>> (return value: [undef])}) + if defined $::RD_TRACE; + last; + } + Parse::RecDescent::_trace(q{>>Matched action<< (return value: [} + . $_tok . q{])}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + push @item, $_tok; + ' . ($self->{line}>=0 ? '$item{'. $self->{hashname} .'}=$_tok;' : '' ) .' + ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .' +' +} + + +1; + +package Parse::RecDescent::Directive; + +sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; } + +sub issubrule { undef } +sub isterminal { 0 } +sub describe { $_[1] ? '' : $_[0]->{name} } + +sub new ($$$$$) +{ + my $class = ref($_[0]) || $_[0]; + bless + { + "code" => $_[1], + "lookahead" => $_[2], + "line" => $_[3], + "name" => $_[4], + }, $class; +} + +sub code($$$$) +{ + my ($self, $namespace, $rule) = @_; + +' + ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .' + + Parse::RecDescent::_trace(q{Trying directive: [' + . $self->describe . ']}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{name} . '}, + $tracelevel) + if defined $::RD_TRACE; ' .' + $_tok = do { ' . $self->{"code"} . ' }; + if (defined($_tok)) + { + Parse::RecDescent::_trace(q{>>Matched directive<< (return value: [} + . $_tok . q{])}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + } + else + { + Parse::RecDescent::_trace(q{<<Didn\'t match directive>>}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + } + ' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .' + last ' + . ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok; + push @item, $item{'.$self->{hashname}.'}=$_tok; + ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .' +' +} + +1; + +package Parse::RecDescent::UncondReject; + +sub issubrule { undef } +sub isterminal { 0 } +sub describe { $_[1] ? '' : $_[0]->{name} } +sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; } + +sub new ($$$;$) +{ + my $class = ref($_[0]) || $_[0]; + bless + { + "lookahead" => $_[1], + "line" => $_[2], + "name" => $_[3], + }, $class; +} + +# MARK, YOU MAY WANT TO OPTIMIZE THIS. + + +sub code($$$$) +{ + my ($self, $namespace, $rule) = @_; + +' + Parse::RecDescent::_trace(q{>>Rejecting production<< (found ' + . $self->describe . ')}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{name} . '}, + $tracelevel) + if defined $::RD_TRACE; + undef $return; + ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .' + + $_tok = undef; + ' . ($self->{"lookahead"} ? '$text = $_savetext and ' : '' ) .' + last ' + . ($self->{"lookahead"}<0?'if':'unless') . ' defined $_tok; +' +} + +1; + +package Parse::RecDescent::Error; + +sub issubrule { undef } +sub isterminal { 0 } +sub describe { $_[1] ? '' : $_[0]->{commitonly} ? '<error?:...>' : '<error...>' } +sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; } + +sub new ($$$$$) +{ + my $class = ref($_[0]) || $_[0]; + bless + { + "msg" => $_[1], + "lookahead" => $_[2], + "commitonly" => $_[3], + "line" => $_[4], + }, $class; +} + +sub code($$$$) +{ + my ($self, $namespace, $rule) = @_; + + my $action = ''; + + if ($self->{"msg"}) # ERROR MESSAGE SUPPLIED + { + #WAS: $action .= "Parse::RecDescent::_error(qq{$self->{msg}}" . ',$thisline);'; + $action .= 'push @{$thisparser->{errors}}, [qq{'.$self->{msg}.'},$thisline];'; + + } + else # GENERATE ERROR MESSAGE DURING PARSE + { + $action .= ' + my $rule = $item[0]; + $rule =~ s/_/ /g; + #WAS: Parse::RecDescent::_error("Invalid $rule: " . $expectation->message() ,$thisline); + push @{$thisparser->{errors}}, ["Invalid $rule: " . $expectation->message() ,$thisline]; + '; + } + + my $dir = + new Parse::RecDescent::Directive('if (' . + ($self->{"commitonly"} ? '$commit' : '1') . + ") { do {$action} unless ".' $_noactions; undef } else {0}', + $self->{"lookahead"},0,$self->describe); + $dir->{hashname} = $self->{hashname}; + return $dir->code($namespace, $rule, 0); +} + +1; + +package Parse::RecDescent::Token; + +sub sethashname { $_[0]->{hashname} = '__PATTERN' . ++$_[1]->{patcount} . '__'; } + +sub issubrule { undef } +sub isterminal { 1 } +sub describe ($) { shift->{'description'}} + + +# ARGS ARE: $self, $pattern, $left_delim, $modifiers, $lookahead, $linenum +sub new ($$$$$$) +{ + my $class = ref($_[0]) || $_[0]; + my $pattern = $_[1]; + my $pat = $_[1]; + my $ldel = $_[2]; + my $rdel = $ldel; + $rdel =~ tr/{[(</}])>/; + + my $mod = $_[3]; + + my $desc; + + if ($ldel eq '/') { $desc = "$ldel$pattern$rdel$mod" } + else { $desc = "m$ldel$pattern$rdel$mod" } + $desc =~ s/\\/\\\\/g; + $desc =~ s/\$$/\\\$/g; + $desc =~ s/}/\\}/g; + $desc =~ s/{/\\{/g; + + if (!eval "no strict; + local \$SIG{__WARN__} = sub {0}; + '' =~ m$ldel$pattern$rdel" and $@) + { + Parse::RecDescent::_warn(3, "Token pattern \"m$ldel$pattern$rdel\" + may not be a valid regular expression", + $_[5]); + $@ =~ s/ at \(eval.*/./; + Parse::RecDescent::_hint($@); + } + + # QUIETLY PREVENT (WELL-INTENTIONED) CALAMITY + $mod =~ s/[gc]//g; + $pattern =~ s/(\A|[^\\])\\G/$1/g; + + bless + { + "pattern" => $pattern, + "ldelim" => $ldel, + "rdelim" => $rdel, + "mod" => $mod, + "lookahead" => $_[4], + "line" => $_[5], + "description" => $desc, + }, $class; +} + + +sub code($$$$) +{ + my ($self, $namespace, $rule, $check) = @_; + my $ldel = $self->{"ldelim"}; + my $rdel = $self->{"rdelim"}; + my $sdel = $ldel; + my $mod = $self->{"mod"}; + + $sdel =~ s/[[{(<]/{}/; + +my $code = ' + Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe + . ']}, Parse::RecDescent::_tracefirst($text), + q{' . $rule->{name} . '}, + $tracelevel) + if defined $::RD_TRACE; + $lastsep = ""; + $expectation->is(q{' . ($rule->hasleftmost($self) ? '' + : $self->describe ) . '})->at($text); + ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . ' + + ' . ($self->{"lookahead"}<0?'if':'unless') + . ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and ' + . ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '') + . ' $text =~ s' . $ldel . '\A(?:' . $self->{"pattern"} . ')' + . $rdel . $sdel . $mod . ') + { + '.($self->{"lookahead"} ? '$text = $_savetext;' : '').' + $expectation->failed(); + Parse::RecDescent::_trace(q{<<Didn\'t match terminal>>}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + + last; + } + Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [} + . $& . q{])}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + push @item, $item{'.$self->{hashname}.'}=$&; + ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .' +'; + + return $code; +} + +1; + +package Parse::RecDescent::Literal; + +sub sethashname { $_[0]->{hashname} = '__STRING' . ++$_[1]->{strcount} . '__'; } + +sub issubrule { undef } +sub isterminal { 1 } +sub describe ($) { shift->{'description'} } + +sub new ($$$$) +{ + my $class = ref($_[0]) || $_[0]; + + my $pattern = $_[1]; + + my $desc = $pattern; + $desc=~s/\\/\\\\/g; + $desc=~s/}/\\}/g; + $desc=~s/{/\\{/g; + + bless + { + "pattern" => $pattern, + "lookahead" => $_[2], + "line" => $_[3], + "description" => "'$desc'", + }, $class; +} + + +sub code($$$$) +{ + my ($self, $namespace, $rule, $check) = @_; + +my $code = ' + Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe + . ']}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{name} . '}, + $tracelevel) + if defined $::RD_TRACE; + $lastsep = ""; + $expectation->is(q{' . ($rule->hasleftmost($self) ? '' + : $self->describe ) . '})->at($text); + ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . ' + + ' . ($self->{"lookahead"}<0?'if':'unless') + . ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and ' + . ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '') + . ' $text =~ s/\A' . quotemeta($self->{"pattern"}) . '//) + { + '.($self->{"lookahead"} ? '$text = $_savetext;' : '').' + $expectation->failed(); + Parse::RecDescent::_trace(qq{<<Didn\'t match terminal>>}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + last; + } + Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [} + . $& . q{])}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + push @item, $item{'.$self->{hashname}.'}=$&; + ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .' +'; + + return $code; +} + +1; + +package Parse::RecDescent::InterpLit; + +sub sethashname { $_[0]->{hashname} = '__STRING' . ++$_[1]->{strcount} . '__'; } + +sub issubrule { undef } +sub isterminal { 1 } +sub describe ($) { shift->{'description'} } + +sub new ($$$$) +{ + my $class = ref($_[0]) || $_[0]; + + my $pattern = $_[1]; + $pattern =~ s#/#\\/#g; + + my $desc = $pattern; + $desc=~s/\\/\\\\/g; + $desc=~s/}/\\}/g; + $desc=~s/{/\\{/g; + + bless + { + "pattern" => $pattern, + "lookahead" => $_[2], + "line" => $_[3], + "description" => "'$desc'", + }, $class; +} + +sub code($$$$) +{ + my ($self, $namespace, $rule, $check) = @_; + +my $code = ' + Parse::RecDescent::_trace(q{Trying terminal: [' . $self->describe + . ']}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{name} . '}, + $tracelevel) + if defined $::RD_TRACE; + $lastsep = ""; + $expectation->is(q{' . ($rule->hasleftmost($self) ? '' + : $self->describe ) . '})->at($text); + ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) . ' + + ' . ($self->{"lookahead"}<0?'if':'unless') + . ' ($text =~ s/\A($skip)/$lastsep=$1 and ""/e and ' + . ($check->{itempos}? 'do {'.Parse::RecDescent::Production::incitempos().' 1} and ' : '') + . ' do { $_tok = "' . $self->{"pattern"} . '"; 1 } and + substr($text,0,length($_tok)) eq $_tok and + do { substr($text,0,length($_tok)) = ""; 1; } + ) + { + '.($self->{"lookahead"} ? '$text = $_savetext;' : '').' + $expectation->failed(); + Parse::RecDescent::_trace(q{<<Didn\'t match terminal>>}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + last; + } + Parse::RecDescent::_trace(q{>>Matched terminal<< (return value: [} + . $_tok . q{])}, + Parse::RecDescent::_tracefirst($text)) + if defined $::RD_TRACE; + push @item, $item{'.$self->{hashname}.'}=$_tok; + ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .' +'; + + return $code; +} + +1; + +package Parse::RecDescent::Subrule; + +sub issubrule ($) { return $_[0]->{"subrule"} } +sub isterminal { 0 } +sub sethashname {} + +sub describe ($) +{ + my $desc = $_[0]->{"implicit"} || $_[0]->{"subrule"}; + $desc = "<matchrule:$desc>" if $_[0]->{"matchrule"}; + return $desc; +} + +sub callsyntax($$) +{ + if ($_[0]->{"matchrule"}) + { + return "&{'$_[1]'.qq{$_[0]->{subrule}}}"; + } + else + { + return $_[1].$_[0]->{"subrule"}; + } +} + +sub new ($$$$;$$$) +{ + my $class = ref($_[0]) || $_[0]; + bless + { + "subrule" => $_[1], + "lookahead" => $_[2], + "line" => $_[3], + "implicit" => $_[4] || undef, + "matchrule" => $_[5], + "argcode" => $_[6] || undef, + }, $class; +} + + +sub code($$$$) +{ + my ($self, $namespace, $rule) = @_; + +' + Parse::RecDescent::_trace(q{Trying subrule: [' . $self->{"subrule"} . ']}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} . '}, + $tracelevel) + if defined $::RD_TRACE; + if (1) { no strict qw{refs}; + $expectation->is(' . ($rule->hasleftmost($self) ? 'q{}' + # WAS : 'qq{'.$self->describe.'}' ) . ')->at($text); + : 'q{'.$self->describe.'}' ) . ')->at($text); + ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) + . ($self->{"lookahead"}<0?'if':'unless') + . ' (defined ($_tok = ' + . $self->callsyntax($namespace.'::') + . '($thisparser,$text,$repeating,' + . ($self->{"lookahead"}?'1':'$_noactions') + . ($self->{argcode} ? ",sub { return $self->{argcode} }" + : ',sub { \\@arg }') + . '))) + { + '.($self->{"lookahead"} ? '$text = $_savetext;' : '').' + Parse::RecDescent::_trace(q{<<Didn\'t match subrule: [' + . $self->{subrule} . ']>>}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} .'}, + $tracelevel) + if defined $::RD_TRACE; + $expectation->failed(); + last; + } + Parse::RecDescent::_trace(q{>>Matched subrule: [' + . $self->{subrule} . ']<< (return value: [} + . $_tok . q{]}, + + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} .'}, + $tracelevel) + if defined $::RD_TRACE; + $item{q{' . $self->{subrule} . '}} = $_tok; + push @item, $_tok; + ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .' + } +' +} + +package Parse::RecDescent::Repetition; + +sub issubrule ($) { return $_[0]->{"subrule"} } +sub isterminal { 0 } +sub sethashname { } + +sub describe ($) +{ + my $desc = $_[0]->{"expected"} || $_[0]->{"subrule"}; + $desc = "<matchrule:$desc>" if $_[0]->{"matchrule"}; + return $desc; +} + +sub callsyntax($$) +{ + if ($_[0]->{matchrule}) + { return "sub { goto &{''.qq{$_[1]$_[0]->{subrule}}} }"; } + else + { return "\\&$_[1]$_[0]->{subrule}"; } +} + +sub new ($$$$$$$$$$) +{ + my ($self, $subrule, $repspec, $min, $max, $lookahead, $line, $parser, $matchrule, $argcode) = @_; + my $class = ref($self) || $self; + ($max, $min) = ( $min, $max) if ($max<$min); + + my $desc; + if ($subrule=~/\A_alternation_\d+_of_production_\d+_of_rule/) + { $desc = $parser->{"rules"}{$subrule}->expected } + + if ($lookahead) + { + if ($min>0) + { + return new Parse::RecDescent::Subrule($subrule,$lookahead,$line,$desc,$matchrule,$argcode); + } + else + { + Parse::RecDescent::_error("Not symbol (\"!\") before + \"$subrule\" doesn't make + sense.",$line); + Parse::RecDescent::_hint("Lookahead for negated optional + repetitions (such as + \"!$subrule($repspec)\" can never + succeed, since optional items always + match (zero times at worst). + Did you mean a single \"!$subrule\", + instead?"); + } + } + bless + { + "subrule" => $subrule, + "repspec" => $repspec, + "min" => $min, + "max" => $max, + "lookahead" => $lookahead, + "line" => $line, + "expected" => $desc, + "argcode" => $argcode || undef, + "matchrule" => $matchrule, + }, $class; +} + +sub code($$$$) +{ + my ($self, $namespace, $rule) = @_; + + my ($subrule, $repspec, $min, $max, $lookahead) = + @{$self}{ qw{subrule repspec min max lookahead} }; + +' + Parse::RecDescent::_trace(q{Trying repeated subrule: [' . $self->describe . ']}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} . '}, + $tracelevel) + if defined $::RD_TRACE; + $expectation->is(' . ($rule->hasleftmost($self) ? 'q{}' + # WAS : 'qq{'.$self->describe.'}' ) . ')->at($text); + : 'q{'.$self->describe.'}' ) . ')->at($text); + ' . ($self->{"lookahead"} ? '$_savetext = $text;' : '' ) .' + unless (defined ($_tok = $thisparser->_parserepeat($text, ' + . $self->callsyntax($namespace.'::') + . ', ' . $min . ', ' . $max . ', ' + . ($self->{"lookahead"}?'1':'$_noactions') + . ',$expectation,' + . ($self->{argcode} ? "sub { return $self->{argcode} }" + : 'undef') + . '))) + { + Parse::RecDescent::_trace(q{<<Didn\'t match repeated subrule: [' + . $self->describe . ']>>}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} .'}, + $tracelevel) + if defined $::RD_TRACE; + last; + } + Parse::RecDescent::_trace(q{>>Matched repeated subrule: [' + . $self->{subrule} . ']<< (} + . @$_tok . q{ times)}, + + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} .'}, + $tracelevel) + if defined $::RD_TRACE; + $item{q{' . "$self->{subrule}($self->{repspec})" . '}} = $_tok; + push @item, $_tok; + ' . ($self->{"lookahead"} ? '$text = $_savetext;' : '' ) .' + +' +} + +package Parse::RecDescent::Result; + +sub issubrule { 0 } +sub isterminal { 0 } +sub describe { '' } + +sub new +{ + my ($class, $pos) = @_; + + bless {}, $class; +} + +sub code($$$$) +{ + my ($self, $namespace, $rule) = @_; + + ' + $return = $item[-1]; + '; +} + +package Parse::RecDescent::Operator; + +my @opertype = ( " non-optional", "n optional" ); + +sub issubrule { 0 } +sub isterminal { 0 } + +sub describe { $_[0]->{"expected"} } +sub sethashname { $_[0]->{hashname} = '__DIRECTIVE' . ++$_[1]->{dircount} . '__'; } + + +sub new +{ + my ($class, $type, $minrep, $maxrep, $leftarg, $op, $rightarg) = @_; + + bless + { + "type" => "${type}op", + "leftarg" => $leftarg, + "op" => $op, + "min" => $minrep, + "max" => $maxrep, + "rightarg" => $rightarg, + "expected" => "<${type}op: ".$leftarg->describe." ".$op->describe." ".$rightarg->describe.">", + }, $class; +} + +sub code($$$$) +{ + my ($self, $namespace, $rule) = @_; + + my ($leftarg, $op, $rightarg) = + @{$self}{ qw{leftarg op rightarg} }; + + my $code = ' + Parse::RecDescent::_trace(q{Trying operator: [' . $self->describe . ']}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} . '}, + $tracelevel) + if defined $::RD_TRACE; + $expectation->is(' . ($rule->hasleftmost($self) ? 'q{}' + # WAS : 'qq{'.$self->describe.'}' ) . ')->at($text); + : 'q{'.$self->describe.'}' ) . ')->at($text); + + $_tok = undef; + OPLOOP: while (1) + { + $repcount = 0; + my @item; + '; + + if ($self->{type} eq "leftop" ) + { + $code .= ' + # MATCH LEFTARG + ' . $leftarg->code(@_[1..2]) . ' + + $repcount++; + + my $savetext = $text; + my $backtrack; + + # MATCH (OP RIGHTARG)(s) + while ($repcount < ' . $self->{max} . ') + { + $backtrack = 0; + ' . $op->code(@_[1..2]) . ' + ' . ($op->isterminal() ? 'pop @item;' : '$backtrack=1;' ) . ' + ' . (ref($op) eq 'Parse::RecDescent::Token' + ? 'if (defined $1) {push @item, $item{'.($self->{name}||$self->{hashname}).'}=$1; $backtrack=1;}' + : "" ) . ' + ' . $rightarg->code(@_[1..2]) . ' + $savetext = $text; + $repcount++; + } + $text = $savetext; + pop @item if $backtrack; + + '; + } + else + { + $code .= ' + my $savetext = $text; + my $backtrack; + # MATCH (LEFTARG OP)(s) + while ($repcount < ' . $self->{max} . ') + { + $backtrack = 0; + ' . $leftarg->code(@_[1..2]) . ' + $repcount++; + $backtrack = 1; + ' . $op->code(@_[1..2]) . ' + $savetext = $text; + ' . ($op->isterminal() ? 'pop @item;' : "" ) . ' + ' . (ref($op) eq 'Parse::RecDescent::Token' ? 'do { push @item, $item{'.($self->{name}||$self->{hashname}).'}=$1; } if defined $1;' : "" ) . ' + } + $text = $savetext; + pop @item if $backtrack; + + # MATCH RIGHTARG + ' . $rightarg->code(@_[1..2]) . ' + $repcount++; + '; + } + + $code .= 'unless (@item) { undef $_tok; last }' unless $self->{min}==0; + + $code .= ' + $_tok = [ @item ]; + last; + } + + unless ($repcount>='.$self->{min}.') + { + Parse::RecDescent::_trace(q{<<Didn\'t match operator: [' + . $self->describe + . ']>>}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} .'}, + $tracelevel) + if defined $::RD_TRACE; + $expectation->failed(); + last; + } + Parse::RecDescent::_trace(q{>>Matched operator: [' + . $self->describe + . ']<< (return value: [} + . qq{@{$_tok||[]}} . q{]}, + Parse::RecDescent::_tracefirst($text), + q{' . $rule->{"name"} .'}, + $tracelevel) + if defined $::RD_TRACE; + + push @item, $item{'.($self->{name}||$self->{hashname}).'}=$_tok||[]; + +'; + return $code; +} + + +package Parse::RecDescent::Expectation; + +sub new ($) +{ + bless { + "failed" => 0, + "expected" => "", + "unexpected" => "", + "lastexpected" => "", + "lastunexpected" => "", + "defexpected" => $_[1], + }; +} + +sub is ($$) +{ + $_[0]->{lastexpected} = $_[1]; return $_[0]; +} + +sub at ($$) +{ + $_[0]->{lastunexpected} = $_[1]; return $_[0]; +} + +sub failed ($) +{ + return unless $_[0]->{lastexpected}; + $_[0]->{expected} = $_[0]->{lastexpected} unless $_[0]->{failed}; + $_[0]->{unexpected} = $_[0]->{lastunexpected} unless $_[0]->{failed}; + $_[0]->{failed} = 1; +} + +sub message ($) +{ + my ($self) = @_; + $self->{expected} = $self->{defexpected} unless $self->{expected}; + $self->{expected} =~ s/_/ /g; + if (!$self->{unexpected} || $self->{unexpected} =~ /\A\s*\Z/s) + { + return "Was expecting $self->{expected}"; + } + else + { + $self->{unexpected} =~ /\s*(.*)/; + return "Was expecting $self->{expected} but found \"$1\" instead"; + } +} + +1; + +package Parse::RecDescent; + +use Carp; +use vars qw ( $AUTOLOAD $VERSION ); + +my $ERRORS = 0; + +$VERSION = '1.94'; + +# BUILDING A PARSER + +my $nextnamespace = "namespace000001"; + +sub _nextnamespace() +{ + return "Parse::RecDescent::" . $nextnamespace++; +} + +sub new ($$$) +{ + my $class = ref($_[0]) || $_[0]; + local $Parse::RecDescent::compiling = $_[2]; + my $name_space_name = defined $_[3] + ? "Parse::RecDescent::".$_[3] + : _nextnamespace(); + my $self = + { + "rules" => {}, + "namespace" => $name_space_name, + "startcode" => '', + "localvars" => '', + "_AUTOACTION" => undef, + "_AUTOTREE" => undef, + }; + if ($::RD_AUTOACTION) + { + my $sourcecode = $::RD_AUTOACTION; + $sourcecode = "{ $sourcecode }" + unless $sourcecode =~ /\A\s*\{.*\}\s*\Z/; + $self->{_check}{itempos} = + $sourcecode =~ /\@itempos\b|\$itempos\s*\[/; + $self->{_AUTOACTION} + = new Parse::RecDescent::Action($sourcecode,0,-1) + } + + bless $self, $class; + shift; + return $self->Replace(@_) +} + +sub Compile($$$$) { + + die "Compilation of Parse::RecDescent grammars not yet implemented\n"; +} + +sub DESTROY {} # SO AUTOLOADER IGNORES IT + +# BUILDING A GRAMMAR.... + +sub Replace ($$) +{ + splice(@_, 2, 0, 1); + return _generate(@_); +} + +sub Extend ($$) +{ + splice(@_, 2, 0, 0); + return _generate(@_); +} + +sub _no_rule ($$;$) +{ + _error("Ruleless $_[0] at start of grammar.",$_[1]); + my $desc = $_[2] ? "\"$_[2]\"" : ""; + _hint("You need to define a rule for the $_[0] $desc + to be part of."); +} + +my $NEGLOOKAHEAD = '\G(\s*\.\.\.\!)'; +my $POSLOOKAHEAD = '\G(\s*\.\.\.)'; +my $RULE = '\G\s*(\w+)[ \t]*:'; +my $PROD = '\G\s*([|])'; +my $TOKEN = q{\G\s*/((\\\\/|[^/])*)/([cgimsox]*)}; +my $MTOKEN = q{\G\s*(m\s*[^\w\s])}; +my $LITERAL = q{\G\s*'((\\\\['\\\\]|[^'])*)'}; +my $INTERPLIT = q{\G\s*"((\\\\["\\\\]|[^"])*)"}; +my $SUBRULE = '\G\s*(\w+)'; +my $MATCHRULE = '\G(\s*<matchrule:)'; +my $SIMPLEPAT = '((\\s+/[^/\\\\]*(?:\\\\.[^/\\\\]*)*/)?)'; +my $OPTIONAL = '\G\((\?)'.$SIMPLEPAT.'\)'; +my $ANY = '\G\((s\?)'.$SIMPLEPAT.'\)'; +my $MANY = '\G\((s|\.\.)'.$SIMPLEPAT.'\)'; +my $EXACTLY = '\G\(([1-9]\d*)'.$SIMPLEPAT.'\)'; +my $BETWEEN = '\G\((\d+)\.\.([1-9]\d*)'.$SIMPLEPAT.'\)'; +my $ATLEAST = '\G\((\d+)\.\.'.$SIMPLEPAT.'\)'; +my $ATMOST = '\G\(\.\.([1-9]\d*)'.$SIMPLEPAT.'\)'; +my $BADREP = '\G\((-?\d+)?\.\.(-?\d+)?'.$SIMPLEPAT.'\)'; +my $ACTION = '\G\s*\{'; +my $IMPLICITSUBRULE = '\G\s*\('; +my $COMMENT = '\G\s*(#.*)'; +my $COMMITMK = '\G\s*<commit>'; +my $UNCOMMITMK = '\G\s*<uncommit>'; +my $QUOTELIKEMK = '\G\s*<perl_quotelike>'; +my $CODEBLOCKMK = '\G\s*<perl_codeblock(?:\s+([][()<>{}]+))?>'; +my $VARIABLEMK = '\G\s*<perl_variable>'; +my $NOCHECKMK = '\G\s*<nocheck>'; +my $AUTOTREEMK = '\G\s*<autotree>'; +my $AUTOSTUBMK = '\G\s*<autostub>'; +my $AUTORULEMK = '\G\s*<autorule:(.*?)>'; +my $REJECTMK = '\G\s*<reject>'; +my $CONDREJECTMK = '\G\s*<reject:'; +my $SCOREMK = '\G\s*<score:'; +my $AUTOSCOREMK = '\G\s*<autoscore:'; +my $SKIPMK = '\G\s*<skip:'; +my $OPMK = '\G\s*<(left|right)op(?:=(\'.*?\'))?:'; +my $ENDDIRECTIVEMK = '\G\s*>'; +my $RESYNCMK = '\G\s*<resync>'; +my $RESYNCPATMK = '\G\s*<resync:'; +my $RULEVARPATMK = '\G\s*<rulevar:'; +my $DEFERPATMK = '\G\s*<defer:'; +my $TOKENPATMK = '\G\s*<token:'; +my $AUTOERRORMK = '\G\s*<error(\??)>'; +my $MSGERRORMK = '\G\s*<error(\??):'; +my $UNCOMMITPROD = $PROD.'\s*<uncommit'; +my $ERRORPROD = $PROD.'\s*<error'; +my $LONECOLON = '\G\s*:'; +my $OTHER = '\G\s*([^\s]+)'; + +my $lines = 0; + +sub _generate($$$;$$) +{ + my ($self, $grammar, $replace, $isimplicit, $isleftop) = (@_, 0); + + my $aftererror = 0; + my $lookahead = 0; + my $lookaheadspec = ""; + $lines = _linecount($grammar) unless $lines; + $self->{_check}{itempos} = ($grammar =~ /\@itempos\b|\$itempos\s*\[/) + unless $self->{_check}{itempos}; + for (qw(thisoffset thiscolumn prevline prevoffset prevcolumn)) + { + $self->{_check}{$_} = + ($grammar =~ /\$$_/) || $self->{_check}{itempos} + unless $self->{_check}{$_}; + } + my $line; + + my $rule = undef; + my $prod = undef; + my $item = undef; + my $lastgreedy = ''; + pos $grammar = 0; + study $grammar; + + while (pos $grammar < length $grammar) + { + $line = $lines - _linecount($grammar) + 1; + my $commitonly; + my $code = ""; + my @components = (); + if ($grammar =~ m/$COMMENT/gco) + { + _parse("a comment",0,$line); + next; + } + elsif ($grammar =~ m/$NEGLOOKAHEAD/gco) + { + _parse("a negative lookahead",$aftererror,$line); + $lookahead = $lookahead ? -$lookahead : -1; + $lookaheadspec .= $1; + next; # SKIP LOOKAHEAD RESET AT END OF while LOOP + } + elsif ($grammar =~ m/$POSLOOKAHEAD/gco) + { + _parse("a positive lookahead",$aftererror,$line); + $lookahead = $lookahead ? $lookahead : 1; + $lookaheadspec .= $1; + next; # SKIP LOOKAHEAD RESET AT END OF while LOOP + } + elsif ($grammar =~ m/(?=$ACTION)/gco + and do { ($code) = extract_codeblock($grammar); $code }) + { + _parse("an action", $aftererror, $line, $code); + $item = new Parse::RecDescent::Action($code,$lookahead,$line); + $prod and $prod->additem($item) + or $self->_addstartcode($code); + } + elsif ($grammar =~ m/(?=$IMPLICITSUBRULE)/gco + and do { ($code) = extract_codeblock($grammar,'{([',undef,'(',1); + $code }) + { + $code =~ s/\A\s*\(|\)\Z//g; + _parse("an implicit subrule", $aftererror, $line, + "( $code )"); + my $implicit = $rule->nextimplicit; + $self->_generate("$implicit : $code",$replace,1); + my $pos = pos $grammar; + substr($grammar,$pos,0,$implicit); + pos $grammar = $pos;; + } + elsif ($grammar =~ m/$ENDDIRECTIVEMK/gco) + { + + # EXTRACT TRAILING REPETITION SPECIFIER (IF ANY) + + my ($minrep,$maxrep) = (1,$MAXREP); + if ($grammar =~ m/\G[(]/gc) + { + pos($grammar)--; + + if ($grammar =~ m/$OPTIONAL/gco) + { ($minrep, $maxrep) = (0,1) } + elsif ($grammar =~ m/$ANY/gco) + { $minrep = 0 } + elsif ($grammar =~ m/$EXACTLY/gco) + { ($minrep, $maxrep) = ($1,$1) } + elsif ($grammar =~ m/$BETWEEN/gco) + { ($minrep, $maxrep) = ($1,$2) } + elsif ($grammar =~ m/$ATLEAST/gco) + { $minrep = $1 } + elsif ($grammar =~ m/$ATMOST/gco) + { $maxrep = $1 } + elsif ($grammar =~ m/$MANY/gco) + { } + elsif ($grammar =~ m/$BADREP/gco) + { + _parse("an invalid repetition specifier", 0,$line); + _error("Incorrect specification of a repeated directive", + $line); + _hint("Repeated directives cannot have + a maximum repetition of zero, nor can they have + negative components in their ranges."); + } + } + + $prod && $prod->enddirective($line,$minrep,$maxrep); + } + elsif ($grammar =~ m/\G\s*<[^m]/gc) + { + pos($grammar)-=2; + + if ($grammar =~ m/$OPMK/gco) + { + # $DB::single=1; + _parse("a $1-associative operator directive", $aftererror, $line, "<$1op:...>"); + $prod->adddirective($1, $line,$2||''); + } + elsif ($grammar =~ m/$UNCOMMITMK/gco) + { + _parse("an uncommit marker", $aftererror,$line); + $item = new Parse::RecDescent::Directive('$commit=0;1', + $lookahead,$line,"<uncommit>"); + $prod and $prod->additem($item) + or _no_rule("<uncommit>",$line); + } + elsif ($grammar =~ m/$QUOTELIKEMK/gco) + { + _parse("an perl quotelike marker", $aftererror,$line); + $item = new Parse::RecDescent::Directive( + 'my ($match,@res); + ($match,$text,undef,@res) = + Text::Balanced::extract_quotelike($text,$skip); + $match ? \@res : undef; + ', $lookahead,$line,"<perl_quotelike>"); + $prod and $prod->additem($item) + or _no_rule("<perl_quotelike>",$line); + } + elsif ($grammar =~ m/$CODEBLOCKMK/gco) + { + my $outer = $1||"{}"; + _parse("an perl codeblock marker", $aftererror,$line); + $item = new Parse::RecDescent::Directive( + 'Text::Balanced::extract_codeblock($text,undef,$skip,\''.$outer.'\'); + ', $lookahead,$line,"<perl_codeblock>"); + $prod and $prod->additem($item) + or _no_rule("<perl_codeblock>",$line); + } + elsif ($grammar =~ m/$VARIABLEMK/gco) + { + _parse("an perl variable marker", $aftererror,$line); + $item = new Parse::RecDescent::Directive( + 'Text::Balanced::extract_variable($text,$skip); + ', $lookahead,$line,"<perl_variable>"); + $prod and $prod->additem($item) + or _no_rule("<perl_variable>",$line); + } + elsif ($grammar =~ m/$NOCHECKMK/gco) + { + _parse("a disable checking marker", $aftererror,$line); + if ($rule) + { + _error("<nocheck> directive not at start of grammar", $line); + _hint("The <nocheck> directive can only + be specified at the start of a + grammar (before the first rule + is defined."); + } + else + { + local $::RD_CHECK = 1; + } + } + elsif ($grammar =~ m/$AUTOSTUBMK/gco) + { + _parse("an autostub marker", $aftererror,$line); + $::RD_AUTOSTUB = ""; + } + elsif ($grammar =~ m/$AUTORULEMK/gco) + { + _parse("an autorule marker", $aftererror,$line); + $::RD_AUTOSTUB = $1; + } + elsif ($grammar =~ m/$AUTOTREEMK/gco) + { + _parse("an autotree marker", $aftererror,$line); + if ($rule) + { + _error("<autotree> directive not at start of grammar", $line); + _hint("The <autotree> directive can only + be specified at the start of a + grammar (before the first rule + is defined."); + } + else + { + undef $self->{_AUTOACTION}; + $self->{_AUTOTREE}{NODE} + = new Parse::RecDescent::Action(q{{bless \%item, $item[0]}},0,-1); + $self->{_AUTOTREE}{TERMINAL} + = new Parse::RecDescent::Action(q{{bless {__VALUE__=>$item[1]}, $item[0]}},0,-1); + } + } + + elsif ($grammar =~ m/$REJECTMK/gco) + { + _parse("an reject marker", $aftererror,$line); + $item = new Parse::RecDescent::UncondReject($lookahead,$line,"<reject>"); + $prod and $prod->additem($item) + or _no_rule("<reject>",$line); + } + elsif ($grammar =~ m/(?=$CONDREJECTMK)/gco + and do { ($code) = extract_codeblock($grammar,'{',undef,'<'); + $code }) + { + _parse("a (conditional) reject marker", $aftererror,$line); + $code =~ /\A\s*<reject:(.*)>\Z/s; + $item = new Parse::RecDescent::Directive( + "($1) ? undef : 1", $lookahead,$line,"<reject:$code>"); + $prod and $prod->additem($item) + or _no_rule("<reject:$code>",$line); + } + elsif ($grammar =~ m/(?=$SCOREMK)/gco + and do { ($code) = extract_codeblock($grammar,'{',undef,'<'); + $code }) + { + _parse("a score marker", $aftererror,$line); + $code =~ /\A\s*<score:(.*)>\Z/s; + $prod and $prod->addscore($1, $lookahead, $line) + or _no_rule($code,$line); + } + elsif ($grammar =~ m/(?=$AUTOSCOREMK)/gco + and do { ($code) = extract_codeblock($grammar,'{',undef,'<'); + $code; + } ) + { + _parse("an autoscore specifier", $aftererror,$line,$code); + $code =~ /\A\s*<autoscore:(.*)>\Z/s; + + $rule and $rule->addautoscore($1,$self) + or _no_rule($code,$line); + + $item = new Parse::RecDescent::UncondReject($lookahead,$line,$code); + $prod and $prod->additem($item) + or _no_rule($code,$line); + } + elsif ($grammar =~ m/$RESYNCMK/gco) + { + _parse("a resync to newline marker", $aftererror,$line); + $item = new Parse::RecDescent::Directive( + 'if ($text =~ s/\A[^\n]*\n//) { $return = 0; $& } else { undef }', + $lookahead,$line,"<resync>"); + $prod and $prod->additem($item) + or _no_rule("<resync>",$line); + } + elsif ($grammar =~ m/(?=$RESYNCPATMK)/gco + and do { ($code) = extract_bracketed($grammar,'<'); + $code }) + { + _parse("a resync with pattern marker", $aftererror,$line); + $code =~ /\A\s*<resync:(.*)>\Z/s; + $item = new Parse::RecDescent::Directive( + 'if ($text =~ s/\A'.$1.'//) { $return = 0; $& } else { undef }', + $lookahead,$line,$code); + $prod and $prod->additem($item) + or _no_rule($code,$line); + } + elsif ($grammar =~ m/(?=$SKIPMK)/gco + and do { ($code) = extract_codeblock($grammar,'<'); + $code }) + { + _parse("a skip marker", $aftererror,$line); + $code =~ /\A\s*<skip:(.*)>\Z/s; + $item = new Parse::RecDescent::Directive( + 'my $oldskip = $skip; $skip='.$1.'; $oldskip', + $lookahead,$line,$code); + $prod and $prod->additem($item) + or _no_rule($code,$line); + } + elsif ($grammar =~ m/(?=$RULEVARPATMK)/gco + and do { ($code) = extract_codeblock($grammar,'{',undef,'<'); + $code; + } ) + { + _parse("a rule variable specifier", $aftererror,$line,$code); + $code =~ /\A\s*<rulevar:(.*)>\Z/s; + + $rule and $rule->addvar($1,$self) + or _no_rule($code,$line); + + $item = new Parse::RecDescent::UncondReject($lookahead,$line,$code); + $prod and $prod->additem($item) + or _no_rule($code,$line); + } + elsif ($grammar =~ m/(?=$DEFERPATMK)/gco + and do { ($code) = extract_codeblock($grammar,'{',undef,'<'); + $code; + } ) + { + _parse("a deferred action specifier", $aftererror,$line,$code); + $code =~ s/\A\s*<defer:(.*)>\Z/$1/s; + if ($code =~ /\A\s*[^{]|[^}]\s*\Z/) + { + $code = "{ $code }" + } + + $item = new Parse::RecDescent::Directive( + "push \@{\$thisparser->{deferred}}, sub $code;", + $lookahead,$line,"<defer:$code>"); + $prod and $prod->additem($item) + or _no_rule("<defer:$code>",$line); + + $self->{deferrable} = 1; + } + elsif ($grammar =~ m/(?=$TOKENPATMK)/gco + and do { ($code) = extract_codeblock($grammar,'{',undef,'<'); + $code; + } ) + { + _parse("a token constructor", $aftererror,$line,$code); + $code =~ s/\A\s*<token:(.*)>\Z/$1/s; + + my $types = eval 'no strict; local $SIG{__WARN__} = sub {0}; my @arr=('.$code.'); @arr' || (); + if (!$types) + { + _error("Incorrect token specification: \"$@\"", $line); + _hint("The <token:...> directive requires a list + of one or more strings representing possible + types of the specified token. For example: + <token:NOUN,VERB>"); + } + else + { + $item = new Parse::RecDescent::Directive( + 'no strict; + $return = { text => $item[-1] }; + @{$return->{type}}{'.$code.'} = (1..'.$types.');', + $lookahead,$line,"<token:$code>"); + $prod and $prod->additem($item) + or _no_rule("<token:$code>",$line); + } + } + elsif ($grammar =~ m/$COMMITMK/gco) + { + _parse("an commit marker", $aftererror,$line); + $item = new Parse::RecDescent::Directive('$commit = 1', + $lookahead,$line,"<commit>"); + $prod and $prod->additem($item) + or _no_rule("<commit>",$line); + } + elsif ($grammar =~ m/$AUTOERRORMK/gco) + { + $commitonly = $1; + _parse("an error marker", $aftererror,$line); + $item = new Parse::RecDescent::Error('',$lookahead,$1,$line); + $prod and $prod->additem($item) + or _no_rule("<error>",$line); + $aftererror = !$commitonly; + } + elsif ($grammar =~ m/(?=$MSGERRORMK)/gco + and do { $commitonly = $1; + ($code) = extract_bracketed($grammar,'<'); + $code }) + { + _parse("an error marker", $aftererror,$line,$code); + $code =~ /\A\s*<error\??:(.*)>\Z/s; + $item = new Parse::RecDescent::Error($1,$lookahead,$commitonly,$line); + $prod and $prod->additem($item) + or _no_rule("$code",$line); + $aftererror = !$commitonly; + } + elsif (do { $commitonly = $1; + ($code) = extract_bracketed($grammar,'<'); + $code }) + { + if ($code =~ /^<[A-Z_]+>$/) + { + _error("Token items are not yet + supported: \"$code\"", + $line); + _hint("Items like $code that consist of angle + brackets enclosing a sequence of + uppercase characters will eventually + be used to specify pre-lexed tokens + in a grammar. That functionality is not + yet implemented. Or did you misspell + \"$code\"?"); + } + else + { + _error("Untranslatable item encountered: \"$code\"", + $line); + _hint("Did you misspell \"$code\" + or forget to comment it out?"); + } + } + } + elsif ($grammar =~ m/$RULE/gco) + { + _parseunneg("a rule declaration", 0, + $lookahead,$line) or next; + my $rulename = $1; + if ($rulename =~ /Replace|Extend|Precompile|Save/ ) + { + _warn(2,"Rule \"$rulename\" hidden by method + Parse::RecDescent::$rulename",$line) + and + _hint("The rule named \"$rulename\" cannot be directly + called through the Parse::RecDescent object + for this grammar (although it may still + be used as a subrule of other rules). + It can't be directly called because + Parse::RecDescent::$rulename is already defined (it + is the standard method of all + parsers)."); + } + $rule = new Parse::RecDescent::Rule($rulename,$self,$line,$replace); + $prod->check_pending($line) if $prod; + $prod = $rule->addprod( new Parse::RecDescent::Production ); + $aftererror = 0; + } + elsif ($grammar =~ m/$UNCOMMITPROD/gco) + { + pos($grammar)-=9; + _parseunneg("a new (uncommitted) production", + 0, $lookahead, $line) or next; + + $prod->check_pending($line) if $prod; + $prod = new Parse::RecDescent::Production($line,1); + $rule and $rule->addprod($prod) + or _no_rule("<uncommit>",$line); + $aftererror = 0; + } + elsif ($grammar =~ m/$ERRORPROD/gco) + { + pos($grammar)-=6; + _parseunneg("a new (error) production", $aftererror, + $lookahead,$line) or next; + $prod->check_pending($line) if $prod; + $prod = new Parse::RecDescent::Production($line,0,1); + $rule and $rule->addprod($prod) + or _no_rule("<error>",$line); + $aftererror = 0; + } + elsif ($grammar =~ m/$PROD/gco) + { + _parseunneg("a new production", 0, + $lookahead,$line) or next; + $rule + and (!$prod || $prod->check_pending($line)) + and $prod = $rule->addprod(new Parse::RecDescent::Production($line)) + or _no_rule("production",$line); + $aftererror = 0; + } + elsif ($grammar =~ m/$LITERAL/gco) + { + ($code = $1) =~ s/\\\\/\\/g; + _parse("a literal terminal", $aftererror,$line,$1); + $item = new Parse::RecDescent::Literal($code,$lookahead,$line); + $prod and $prod->additem($item) + or _no_rule("literal terminal",$line,"'$1'"); + } + elsif ($grammar =~ m/$INTERPLIT/gco) + { + _parse("an interpolated literal terminal", $aftererror,$line); + $item = new Parse::RecDescent::InterpLit($1,$lookahead,$line); + $prod and $prod->additem($item) + or _no_rule("interpolated literal terminal",$line,"'$1'"); + } + elsif ($grammar =~ m/$TOKEN/gco) + { + _parse("a /../ pattern terminal", $aftererror,$line); + $item = new Parse::RecDescent::Token($1,'/',$3?$3:'',$lookahead,$line); + $prod and $prod->additem($item) + or _no_rule("pattern terminal",$line,"/$1/"); + } + elsif ($grammar =~ m/(?=$MTOKEN)/gco + and do { ($code, undef, @components) + = extract_quotelike($grammar); + $code } + ) + + { + _parse("an m/../ pattern terminal", $aftererror,$line,$code); + $item = new Parse::RecDescent::Token(@components[3,2,8], + $lookahead,$line); + $prod and $prod->additem($item) + or _no_rule("pattern terminal",$line,$code); + } + elsif ($grammar =~ m/(?=$MATCHRULE)/gco + and do { ($code) = extract_bracketed($grammar,'<'); + $code + } + or $grammar =~ m/$SUBRULE/gco + and $code = $1) + { + my $name = $code; + my $matchrule = 0; + if (substr($name,0,1) eq '<') + { + $name =~ s/$MATCHRULE\s*//; + $name =~ s/\s*>\Z//; + $matchrule = 1; + } + + # EXTRACT TRAILING ARG LIST (IF ANY) + + my ($argcode) = extract_codeblock($grammar, "[]",'') || ''; + + # EXTRACT TRAILING REPETITION SPECIFIER (IF ANY) + + if ($grammar =~ m/\G[(]/gc) + { + pos($grammar)--; + + if ($grammar =~ m/$OPTIONAL/gco) + { + _parse("an zero-or-one subrule match", $aftererror,$line,"$code$argcode($1)"); + $item = new Parse::RecDescent::Repetition($name,$1,0,1, + $lookahead,$line, + $self, + $matchrule, + $argcode); + $prod and $prod->additem($item) + or _no_rule("repetition",$line,"$code$argcode($1)"); + + !$matchrule and $rule and $rule->addcall($name); + } + elsif ($grammar =~ m/$ANY/gco) + { + _parse("a zero-or-more subrule match", $aftererror,$line,"$code$argcode($1)"); + if ($2) + { + my $pos = pos $grammar; + substr($grammar,$pos,0, + "<leftop='$name(s?)': $name $2 $name>(s?) "); + + pos $grammar = $pos; + } + else + { + $item = new Parse::RecDescent::Repetition($name,$1,0,$MAXREP, + $lookahead,$line, + $self, + $matchrule, + $argcode); + $prod and $prod->additem($item) + or _no_rule("repetition",$line,"$code$argcode($1)"); + + !$matchrule and $rule and $rule->addcall($name); + + _check_insatiable($name,$1,$grammar,$line) if $::RD_CHECK; + } + } + elsif ($grammar =~ m/$MANY/gco) + { + _parse("a one-or-more subrule match", $aftererror,$line,"$code$argcode($1)"); + if ($2) + { + # $DB::single=1; + my $pos = pos $grammar; + substr($grammar,$pos,0, + "<leftop='$name(s)': $name $2 $name> "); + + pos $grammar = $pos; + } + else + { + $item = new Parse::RecDescent::Repetition($name,$1,1,$MAXREP, + $lookahead,$line, + $self, + $matchrule, + $argcode); + + $prod and $prod->additem($item) + or _no_rule("repetition",$line,"$code$argcode($1)"); + + !$matchrule and $rule and $rule->addcall($name); + + _check_insatiable($name,$1,$grammar,$line) if $::RD_CHECK; + } + } + elsif ($grammar =~ m/$EXACTLY/gco) + { + _parse("an exactly-$1-times subrule match", $aftererror,$line,"$code$argcode($1)"); + if ($2) + { + my $pos = pos $grammar; + substr($grammar,$pos,0, + "<leftop='$name($1)': $name $2 $name>($1) "); + + pos $grammar = $pos; + } + else + { + $item = new Parse::RecDescent::Repetition($name,$1,$1,$1, + $lookahead,$line, + $self, + $matchrule, + $argcode); + $prod and $prod->additem($item) + or _no_rule("repetition",$line,"$code$argcode($1)"); + + !$matchrule and $rule and $rule->addcall($name); + } + } + elsif ($grammar =~ m/$BETWEEN/gco) + { + _parse("a $1-to-$2 subrule match", $aftererror,$line,"$code$argcode($1..$2)"); + if ($3) + { + my $pos = pos $grammar; + substr($grammar,$pos,0, + "<leftop='$name($1..$2)': $name $3 $name>($1..$2) "); + + pos $grammar = $pos; + } + else + { + $item = new Parse::RecDescent::Repetition($name,"$1..$2",$1,$2, + $lookahead,$line, + $self, + $matchrule, + $argcode); + $prod and $prod->additem($item) + or _no_rule("repetition",$line,"$code$argcode($1..$2)"); + + !$matchrule and $rule and $rule->addcall($name); + } + } + elsif ($grammar =~ m/$ATLEAST/gco) + { + _parse("a $1-or-more subrule match", $aftererror,$line,"$code$argcode($1..)"); + if ($2) + { + my $pos = pos $grammar; + substr($grammar,$pos,0, + "<leftop='$name($1..)': $name $2 $name>($1..) "); + + pos $grammar = $pos; + } + else + { + $item = new Parse::RecDescent::Repetition($name,"$1..",$1,$MAXREP, + $lookahead,$line, + $self, + $matchrule, + $argcode); + $prod and $prod->additem($item) + or _no_rule("repetition",$line,"$code$argcode($1..)"); + + !$matchrule and $rule and $rule->addcall($name); + _check_insatiable($name,"$1..",$grammar,$line) if $::RD_CHECK; + } + } + elsif ($grammar =~ m/$ATMOST/gco) + { + _parse("a one-to-$1 subrule match", $aftererror,$line,"$code$argcode(..$1)"); + if ($2) + { + my $pos = pos $grammar; + substr($grammar,$pos,0, + "<leftop='$name(..$1)': $name $2 $name>(..$1) "); + + pos $grammar = $pos; + } + else + { + $item = new Parse::RecDescent::Repetition($name,"..$1",1,$1, + $lookahead,$line, + $self, + $matchrule, + $argcode); + $prod and $prod->additem($item) + or _no_rule("repetition",$line,"$code$argcode(..$1)"); + + !$matchrule and $rule and $rule->addcall($name); + } + } + elsif ($grammar =~ m/$BADREP/gco) + { + _parse("an subrule match with invalid repetition specifier", 0,$line); + _error("Incorrect specification of a repeated subrule", + $line); + _hint("Repeated subrules like \"$code$argcode$&\" cannot have + a maximum repetition of zero, nor can they have + negative components in their ranges."); + } + } + else + { + _parse("a subrule match", $aftererror,$line,$code); + my $desc; + if ($name=~/\A_alternation_\d+_of_production_\d+_of_rule/) + { $desc = $self->{"rules"}{$name}->expected } + $item = new Parse::RecDescent::Subrule($name, + $lookahead, + $line, + $desc, + $matchrule, + $argcode); + + $prod and $prod->additem($item) + or _no_rule("(sub)rule",$line,$name); + + !$matchrule and $rule and $rule->addcall($name); + } + } + elsif ($grammar =~ m/$LONECOLON/gco ) + { + _error("Unexpected colon encountered", $line); + _hint("Did you mean \"|\" (to start a new production)? + Or perhaps you forgot that the colon + in a rule definition must be + on the same line as the rule name?"); + } + elsif ($grammar =~ m/$ACTION/gco ) # BAD ACTION, ALREADY FAILED + { + _error("Malformed action encountered", + $line); + _hint("Did you forget the closing curly bracket + or is there a syntax error in the action?"); + } + elsif ($grammar =~ m/$OTHER/gco ) + { + _error("Untranslatable item encountered: \"$1\"", + $line); + _hint("Did you misspell \"$1\" + or forget to comment it out?"); + } + + if ($lookaheadspec =~ tr /././ > 3) + { + $lookaheadspec =~ s/\A\s+//; + $lookahead = $lookahead<0 + ? 'a negative lookahead ("...!")' + : 'a positive lookahead ("...")' ; + _warn(1,"Found two or more lookahead specifiers in a + row.",$line) + and + _hint("Multiple positive and/or negative lookaheads + are simply multiplied together to produce a + single positive or negative lookahead + specification. In this case the sequence + \"$lookaheadspec\" was reduced to $lookahead. + Was this your intention?"); + } + $lookahead = 0; + $lookaheadspec = ""; + + $grammar =~ m/\G\s+/gc; + } + + unless ($ERRORS or $isimplicit or !$::RD_CHECK) + { + $self->_check_grammar(); + } + + unless ($ERRORS or $isimplicit or $Parse::RecDescent::compiling) + { + my $code = $self->_code(); + if (defined $::RD_TRACE) + { + print STDERR "printing code (", length($code),") to RD_TRACE\n"; + local *TRACE_FILE; + open TRACE_FILE, ">RD_TRACE" + and print TRACE_FILE "my \$ERRORS;\n$code" + and close TRACE_FILE; + } + + unless ( eval "$code 1" ) + { + _error("Internal error in generated parser code!"); + $@ =~ s/at grammar/in grammar at/; + _hint($@); + } + } + + if ($ERRORS and !_verbosity("HINT")) + { + local $::RD_HINT = 1; + _hint('Set $::RD_HINT (or -RD_HINT if you\'re using "perl -s") + for hints on fixing these problems.'); + } + if ($ERRORS) { $ERRORS=0; return } + return $self; +} + + +sub _addstartcode($$) +{ + my ($self, $code) = @_; + $code =~ s/\A\s*\{(.*)\}\Z/$1/s; + + $self->{"startcode"} .= "$code;\n"; +} + +# CHECK FOR GRAMMAR PROBLEMS.... + +sub _check_insatiable($$$$) +{ + my ($subrule,$repspec,$grammar,$line) = @_; + pos($grammar)=pos($_[2]); + return if $grammar =~ m/$OPTIONAL/gco || $grammar =~ m/$ANY/gco; + my $min = 1; + if ( $grammar =~ m/$MANY/gco + || $grammar =~ m/$EXACTLY/gco + || $grammar =~ m/$ATMOST/gco + || $grammar =~ m/$BETWEEN/gco && do { $min=$2; 1 } + || $grammar =~ m/$ATLEAST/gco && do { $min=$2; 1 } + || $grammar =~ m/$SUBRULE(?!\s*:)/gco + ) + { + return unless $1 eq $subrule && $min > 0; + _warn(3,"Subrule sequence \"$subrule($repspec) $&\" will + (almost certainly) fail.",$line) + and + _hint("Unless subrule \"$subrule\" performs some cunning + lookahead, the repetition \"$subrule($repspec)\" will + insatiably consume as many matches of \"$subrule\" as it + can, leaving none to match the \"$&\" that follows."); + } +} + +sub _check_grammar ($) +{ + my $self = shift; + my $rules = $self->{"rules"}; + my $rule; + foreach $rule ( values %$rules ) + { + next if ! $rule->{"changed"}; + + # CHECK FOR UNDEFINED RULES + + my $call; + foreach $call ( @{$rule->{"calls"}} ) + { + if (!defined ${$rules}{$call} + &&!defined &{"Parse::RecDescent::$call"}) + { + if (!defined $::RD_AUTOSTUB) + { + _warn(3,"Undefined (sub)rule \"$call\" + used in a production.") + and + _hint("Will you be providing this rule + later, or did you perhaps + misspell \"$call\"? Otherwise + it will be treated as an + immediate <reject>."); + eval "sub $self->{namespace}::$call {undef}"; + } + else # EXPERIMENTAL + { + my $rule = $::RD_AUTOSTUB || qq{'$call'}; + _warn(1,"Autogenerating rule: $call") + and + _hint("A call was made to a subrule + named \"$call\", but no such + rule was specified. However, + since \$::RD_AUTOSTUB + was defined, a rule stub + ($call : $rule) was + automatically created."); + + $self->_generate("$call : $rule",0,1); + } + } + } + + # CHECK FOR LEFT RECURSION + + if ($rule->isleftrec($rules)) + { + _error("Rule \"$rule->{name}\" is left-recursive."); + _hint("Redesign the grammar so it's not left-recursive. + That will probably mean you need to re-implement + repetitions using the '(s)' notation. + For example: \"$rule->{name}(s)\"."); + next; + } + } +} + +# GENERATE ACTUAL PARSER CODE + +sub _code($) +{ + my $self = shift; + my $code = qq{ +package $self->{namespace}; +use strict; +use vars qw(\$skip \$AUTOLOAD $self->{localvars} ); +\$skip = '$skip'; +$self->{startcode} + +{ +local \$SIG{__WARN__} = sub {0}; +# PRETEND TO BE IN Parse::RecDescent NAMESPACE +*$self->{namespace}::AUTOLOAD = sub +{ + no strict 'refs'; + \$AUTOLOAD =~ s/^$self->{namespace}/Parse::RecDescent/; + goto &{\$AUTOLOAD}; +} +} + +}; + $code .= "push \@$self->{namespace}\::ISA, 'Parse::RecDescent';"; + $self->{"startcode"} = ''; + + my $rule; + foreach $rule ( values %{$self->{"rules"}} ) + { + if ($rule->{"changed"}) + { + $code .= $rule->code($self->{"namespace"},$self); + $rule->{"changed"} = 0; + } + } + + return $code; +} + + +# EXECUTING A PARSE.... + +sub AUTOLOAD # ($parser, $text; $linenum, @args) +{ + croak "Could not find method: $AUTOLOAD\n" unless ref $_[0]; + my $class = ref($_[0]) || $_[0]; + my $text = ref($_[1]) ? ${$_[1]} : $_[1]; + $_[0]->{lastlinenum} = $_[2]||_linecount($_[1]); + $_[0]->{lastlinenum} = _linecount($_[1]); + $_[0]->{lastlinenum} += $_[2] if @_ > 2; + $_[0]->{offsetlinenum} = $_[0]->{lastlinenum}; + $_[0]->{fulltext} = $text; + $_[0]->{fulltextlen} = length $text; + $_[0]->{deferred} = []; + $_[0]->{errors} = []; + my @args = @_[3..$#_]; + my $args = sub { [ @args ] }; + + $AUTOLOAD =~ s/$class/$_[0]->{namespace}/; + no strict "refs"; + + croak "Unknown starting rule ($AUTOLOAD) called\n" + unless defined &$AUTOLOAD; + my $retval = &{$AUTOLOAD}($_[0],$text,undef,undef,$args); + + if (defined $retval) + { + foreach ( @{$_[0]->{deferred}} ) { &$_; } + } + else + { + foreach ( @{$_[0]->{errors}} ) { _error(@$_); } + } + + if (ref $_[1]) { ${$_[1]} = $text } + + $ERRORS = 0; + return $retval; +} + +sub _parserepeat($$$$$$$$$$) # RETURNS A REF TO AN ARRAY OF MATCHES +{ + my ($parser, $text, $prod, $min, $max, $_noactions, $expectation, $argcode) = @_; + my @tokens = (); + + my $reps; + for ($reps=0; $reps<$max;) + { + $_[6]->at($text); # $_[6] IS $expectation FROM CALLER + my $_savetext = $text; + my $prevtextlen = length $text; + my $_tok; + if (! defined ($_tok = &$prod($parser,$text,1,$_noactions,$argcode))) + { + $text = $_savetext; + last; + } + push @tokens, $_tok if defined $_tok; + last if ++$reps >= $min and $prevtextlen == length $text; + } + + do { $_[6]->failed(); return undef} if $reps<$min; + + $_[1] = $text; + return [@tokens]; +} + + +# ERROR REPORTING.... + +my $errortext; +my $errorprefix; + +open (ERROR, ">&STDERR"); +format ERROR = +@>>>>>>>>>>>>>>>>>>>>: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +$errorprefix, $errortext +~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $errortext +. + +select ERROR; +$| = 1; + +# TRACING + +my $tracemsg; +my $tracecontext; +my $tracerulename; +use vars '$tracelevel'; + +open (TRACE, ">&STDERR"); +format TRACE = +@>|@|||||||||@^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<| +$tracelevel, $tracerulename, '|', $tracemsg + | ~~ |^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<| + $tracemsg +. + +select TRACE; +$| = 1; + +open (TRACECONTEXT, ">&STDERR"); +format TRACECONTEXT = +@>|@|||||||||@ |^<<<<<<<<<<<<<<<<<<<<<<<<<<< +$tracelevel, $tracerulename, '|', $tracecontext + | ~~ | |^<<<<<<<<<<<<<<<<<<<<<<<<<<< + $tracecontext +. + + +select TRACECONTEXT; +$| = 1; + +select STDOUT; + +sub _verbosity($) +{ + defined $::RD_TRACE + or defined $::RD_HINT and $_[0] =~ /ERRORS|WARN|HINT/ + or defined $::RD_WARN and $_[0] =~ /ERRORS|WARN/ + or defined $::RD_ERRORS and $_[0] =~ /ERRORS/ +} + +sub _error($;$) +{ + $ERRORS++; + return 0 if ! _verbosity("ERRORS"); + $errortext = $_[0]; + $errorprefix = "ERROR" . ($_[1] ? " (line $_[1])" : ""); + $errortext =~ s/\s+/ /g; + print ERROR "\n" if _verbosity("WARN"); + write ERROR; + return 1; +} + +sub _warn($$;$) +{ + return 0 unless _verbosity("WARN") && ($::RD_HINT || $_[0] >= ($::RD_WARN||1)); + $errortext = $_[1]; + $errorprefix = "Warning" . ($_[2] ? " (line $_[2])" : ""); + print ERROR "\n"; + $errortext =~ s/\s+/ /g; + write ERROR; + return 1; +} + +sub _hint($) +{ + return 0 unless defined $::RD_HINT; + $errortext = "$_[0])"; + $errorprefix = "(Hint"; + $errortext =~ s/\s+/ /g; + write ERROR; + return 1; +} + +sub _tracemax($) +{ + if (defined $::RD_TRACE + && $::RD_TRACE =~ /\d+/ + && $::RD_TRACE>1 + && $::RD_TRACE+10<length($_[0])) + { + my $count = length($_[0]) - $::RD_TRACE; + return substr($_[0],0,$::RD_TRACE/2) + . "...<$count>..." + . substr($_[0],-$::RD_TRACE/2); + } + else + { + return $_[0]; + } +} + +sub _tracefirst($) +{ + if (defined $::RD_TRACE + && $::RD_TRACE =~ /\d+/ + && $::RD_TRACE>1 + && $::RD_TRACE+10<length($_[0])) + { + my $count = length($_[0]) - $::RD_TRACE; + return substr($_[0],0,$::RD_TRACE) . "...<+$count>"; + } + else + { + return $_[0]; + } +} + +my $lastcontext = ''; +my $lastrulename = ''; +my $lastlevel = ''; + +sub _trace($;$$$) +{ + $tracemsg = $_[0]; + $tracecontext = $_[1]||$lastcontext; + $tracerulename = $_[2]||$lastrulename; + $tracelevel = $_[3]||$lastlevel; + if ($tracerulename) { $lastrulename = $tracerulename } + if ($tracelevel) { $lastlevel = $tracelevel } + + $tracecontext =~ s/\n/\\n/g; + $tracecontext =~ s/\s+/ /g; + $tracerulename = qq{$tracerulename}; + write TRACE; + if ($tracecontext ne $lastcontext) + { + if ($tracecontext) + { + $lastcontext = _tracefirst($tracecontext); + $tracecontext = qq{"$tracecontext"}; + } + else + { + $tracecontext = qq{<NO TEXT LEFT>}; + } + write TRACECONTEXT; + } +} + +sub _parseunneg($$$$) +{ + _parse($_[0],$_[1],$_[3]); + if ($_[2]<0) + { + _error("Can't negate \"$&\".",$_[3]); + _hint("You can't negate $_[0]. Remove the \"...!\" before + \"$&\"."); + return 0; + } + return 1; +} + +sub _parse($$$;$) +{ + my $what = $_[3] || $&; + $what =~ s/^\s+//; + if ($_[1]) + { + _warn(3,"Found $_[0] ($what) after an unconditional <error>",$_[2]) + and + _hint("An unconditional <error> always causes the + production containing it to immediately fail. + \u$_[0] that follows an <error> + will never be reached. Did you mean to use + <error?> instead?"); + } + + return if ! _verbosity("TRACE"); + $errortext = "Treating \"$what\" as $_[0]"; + $errorprefix = "Parse::RecDescent"; + $errortext =~ s/\s+/ /g; + write ERROR; +} + +sub _linecount($) { + scalar substr($_[0], pos $_[0]||0) =~ tr/\n// +} + + +package main; + +use vars qw ( $RD_ERRORS $RD_WARN $RD_HINT $RD_TRACE $RD_CHECK ); +$::RD_CHECK = 1; +$::RD_ERRORS = 1; +$::RD_WARN = 3; + +1; + diff --git a/lib/Template.pm b/lib/Template.pm new file mode 100644 index 0000000..18e1ec4 --- /dev/null +++ b/lib/Template.pm @@ -0,0 +1,950 @@ +#============================================================= -*-perl-*- +# +# Template +# +# DESCRIPTION +# Module implementing a simple, user-oriented front-end to the Template +# Toolkit. +# +# AUTHOR +# Andy Wardley <abw@andywardley.com> +# +# COPYRIGHT +# Copyright (C) 1996-2002 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# REVISION +# $Id: Template.pm,v 2.68 2003/04/29 12:38:58 abw Exp $ +# +#======================================================================== + +package Template; +use base qw( Template::Base ); + +require 5.005; + +use strict; +use vars qw( $VERSION $AUTOLOAD $ERROR $DEBUG $BINMODE ); +use Template::Base; +use Template::Config; +use Template::Constants; +use Template::Provider; +use Template::Service; +use File::Basename; +use File::Path; + +## This is the main version number for the Template Toolkit. +## It is extracted by ExtUtils::MakeMaker and inserted in various places. +$VERSION = '2.10'; +$ERROR = ''; +$DEBUG = 0; + +# we used to default to binary mode for all win32 files but that make +# line endings strange, so we're turning it off and letting users set +# it explicitly as an argument to process() +# $BINMODE = ($^O eq 'MSWin32') ? 1 : 0; +$BINMODE = 0 unless defined $BINMODE; + +# preload all modules if we're running under mod_perl +Template::Config->preload() if $ENV{ MOD_PERL }; + + +#------------------------------------------------------------------------ +# process($input, \%replace, $output) +# +# Main entry point for the Template Toolkit. The Template module +# delegates most of the processing effort to the underlying SERVICE +# object, an instance of the Template::Service class. +#------------------------------------------------------------------------ + +sub process { + my ($self, $template, $vars, $outstream, @opts) = @_; + my ($output, $error); + my $options = (@opts == 1) && UNIVERSAL::isa($opts[0], 'HASH') + ? shift(@opts) : { @opts }; + + $options->{ binmode } = $BINMODE + unless defined $options->{ binmode }; + + # we're using this for testing in t/output.t and t/filter.t so + # don't remove it if you don't want tests to fail... + $self->DEBUG("set binmode\n") if $DEBUG && $options->{ binmode }; + + $output = $self->{ SERVICE }->process($template, $vars); + + if (defined $output) { + $outstream ||= $self->{ OUTPUT }; + unless (ref $outstream) { + my $outpath = $self->{ OUTPUT_PATH }; + $outstream = "$outpath/$outstream" if $outpath; + } + + # send processed template to output stream, checking for error + return ($self->error($error)) + if ($error = &_output($outstream, \$output, $options)); + + return 1; + } + else { + return $self->error($self->{ SERVICE }->error); + } +} + + +#------------------------------------------------------------------------ +# service() +# +# Returns a reference to the the internal SERVICE object which handles +# all requests for this Template object +#------------------------------------------------------------------------ + +sub service { + my $self = shift; + return $self->{ SERVICE }; +} + + +#------------------------------------------------------------------------ +# context() +# +# Returns a reference to the the CONTEXT object withint the SERVICE +# object. +#------------------------------------------------------------------------ + +sub context { + my $self = shift; + return $self->{ SERVICE }->{ CONTEXT }; +} + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init(\%config) +#------------------------------------------------------------------------ +sub _init { + my ($self, $config) = @_; + + # convert any textual DEBUG args to numerical form + my $debug = $config->{ DEBUG }; + $config->{ DEBUG } = Template::Constants::debug_flags($self, $debug) + || return if defined $debug && $debug !~ /^\d+$/; + + # prepare a namespace handler for any CONSTANTS definition + if (my $constants = $config->{ CONSTANTS }) { + my $ns = $config->{ NAMESPACE } ||= { }; + my $cns = $config->{ CONSTANTS_NAMESPACE } || 'constants'; + $constants = Template::Config->constants($constants) + || return $self->error(Template::Config->error); + $ns->{ $cns } = $constants; + } + + $self->{ SERVICE } = $config->{ SERVICE } + || Template::Config->service($config) + || return $self->error(Template::Config->error); + + $self->{ OUTPUT } = $config->{ OUTPUT } || \*STDOUT; + $self->{ OUTPUT_PATH } = $config->{ OUTPUT_PATH }; + + return $self; +} + + +#------------------------------------------------------------------------ +# _output($where, $text) +#------------------------------------------------------------------------ + +sub _output { + my ($where, $textref, $options) = @_; + my $reftype; + my $error = 0; + + # call a CODE reference + if (($reftype = ref($where)) eq 'CODE') { + &$where($$textref); + } + # print to a glob (such as \*STDOUT) + elsif ($reftype eq 'GLOB') { + print $where $$textref; + } + # append output to a SCALAR ref + elsif ($reftype eq 'SCALAR') { + $$where .= $$textref; + } + # push onto ARRAY ref + elsif ($reftype eq 'ARRAY') { + push @$where, $$textref; + } + # call the print() method on an object that implements the method + # (e.g. IO::Handle, Apache::Request, etc) + elsif (UNIVERSAL::can($where, 'print')) { + $where->print($$textref); + } + # a simple string is taken as a filename + elsif (! $reftype) { + local *FP; + # make destination directory if it doesn't exist + my $dir = dirname($where); + eval { mkpath($dir) unless -d $dir; }; + if ($@) { + # strip file name and line number from error raised by die() + ($error = $@) =~ s/ at \S+ line \d+\n?$//; + } + elsif (open(FP, ">$where")) { + binmode FP if $options->{ binmode }; + print FP $$textref; + close FP; + } + else { + $error = "$where: $!"; + } + } + # give up, we've done our best + else { + $error = "output_handler() cannot determine target type ($where)\n"; + } + + return $error; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template - Front-end module to the Template Toolkit + +=head1 SYNOPSIS + + use Template; + + # some useful options (see below for full list) + my $config = { + INCLUDE_PATH => '/search/path', # or list ref + INTERPOLATE => 1, # expand "$var" in plain text + POST_CHOMP => 1, # cleanup whitespace + PRE_PROCESS => 'header', # prefix each template + EVAL_PERL => 1, # evaluate Perl code blocks + }; + + # create Template object + my $template = Template->new($config); + + # define template variables for replacement + my $vars = { + var1 => $value, + var2 => \%hash, + var3 => \@list, + var4 => \&code, + var5 => $object, + }; + + # specify input filename, or file handle, text reference, etc. + my $input = 'myfile.html'; + + # process input template, substituting variables + $template->process($input, $vars) + || die $template->error(); + +=head1 DESCRIPTION + +This documentation describes the Template module which is the direct +Perl interface into the Template Toolkit. It covers the use of the +module and gives a brief summary of configuration options and template +directives. Please see L<Template::Manual> for the complete reference +manual which goes into much greater depth about the features and use +of the Template Toolkit. The L<Template::Tutorial> is also available +as an introductory guide to using the Template Toolkit. + +=head1 METHODS + +=head2 new(\%config) + +The new() constructor method (implemented by the Template::Base base +class) instantiates a new Template object. A reference to a hash +array of configuration items may be passed as a parameter. + + my $tt = Template->new({ + INCLUDE_PATH => '/usr/local/templates', + EVAL_PERL => 1, + }) || die $Template::ERROR, "\n"; + +A reference to a new Template object is returned, or undef on error. +In the latter case, the error message can be retrieved by calling +error() as a class method (e.g. C<Template-E<gt>error()>) or by +examining the $ERROR package variable directly +(e.g. C<$Template::ERROR>). + + my $tt = Template->new(\%config) + || die Template->error(), "\n"; + + my $tt = Template->new(\%config) + || die $Template::ERROR, "\n"; + +For convenience, configuration items may also be specified as a list +of items instead of a hash array reference. These are automatically +folded into a hash array by the constructor. + + my $tt = Template->new(INCLUDE_PATH => '/tmp', POST_CHOMP => 1) + || die $Template::ERROR, "\n"; + +=head2 process($template, \%vars, $output, %options) + +The process() method is called to process a template. The first +parameter indicates the input template as one of: a filename relative +to INCLUDE_PATH, if defined; a reference to a text string containing +the template text; or a file handle reference (e.g. IO::Handle or +sub-class) or GLOB (e.g. \*STDIN), from which the template can be +read. A reference to a hash array may be passed as the second +parameter, containing definitions of template variables. + + $text = "[% INCLUDE header %]\nHello world!\n[% INCLUDE footer %]"; + + # filename + $tt->process('welcome.tt2') + || die $tt->error(), "\n"; + + # text reference + $tt->process(\$text) + || die $tt->error(), "\n"; + + # GLOB + $tt->process(\*DATA) + || die $tt->error(), "\n"; + + __END__ + [% INCLUDE header %] + This is a template defined in the __END__ section which is + accessible via the DATA "file handle". + [% INCLUDE footer %] + +By default, the processed template output is printed to STDOUT. The +process() method then returns 1 to indicate success. A third +parameter may be passed to the process() method to specify a different +output location. This value may be one of: a plain string indicating +a filename which will be opened (relative to OUTPUT_PATH, if defined) +and the output written to; a file GLOB opened ready for output; a +reference to a scalar (e.g. a text string) to which output/error is +appended; a reference to a subroutine which is called, passing the +output as a parameter; or any object reference which implements a +'print' method (e.g. IO::Handle, Apache::Request, etc.) which will +be called, passing the generated output as a parameter. + +Examples: + + # output filename + $tt->process('welcome.tt2', $vars, 'welcome.html') + || die $tt->error(), "\n"; + + # reference to output subroutine + sub myout { + my $output = shift; + ... + } + $tt->process('welcome.tt2', $vars, \&myout) + || die $tt->error(), "\n"; + + # reference to output text string + my $output = ''; + $tt->process('welcome.tt2', $vars, \$output) + || die $tt->error(), "\n"; + + print "output: $output\n"; + +In an Apache/mod_perl handler: + + sub handler { + my $req = shift; + + ... + + # direct output to Apache::Request via $req->print($output) + $tt->process($file, $vars, $req) || do { + $req->log_reason($tt->error()); + return SERVER_ERROR; + }; + + return OK; + } + +After the optional third output argument can come an optional +reference to a hash or a list of (name, value) pairs providing further +options for the output. The only option currently supported is +"binmode" which, when set to any true value will ensure that files +created (but not any existing file handles passed) will be set to +binary mode. + + # either: hash reference of options + $tt->process($infile, $vars, $outfile, { binmode => 1 }) + || die $tt->error(), "\n"; + + # or: list of name, value pairs + $tt->process($infile, $vars, $outfile, binmode => 1) + || die $tt->error(), "\n"; + +The OUTPUT configuration item can be used to specify a default output +location other than \*STDOUT. The OUTPUT_PATH specifies a directory +which should be prefixed to all output locations specified as filenames. + + my $tt = Template->new({ + OUTPUT => sub { ... }, # default + OUTPUT_PATH => '/tmp', + ... + }) || die Template->error(), "\n"; + + # use default OUTPUT (sub is called) + $tt->process('welcome.tt2', $vars) + || die $tt->error(), "\n"; + + # write file to '/tmp/welcome.html' + $tt->process('welcome.tt2', $vars, 'welcome.html') + || die $tt->error(), "\n"; + +The process() method returns 1 on success or undef on error. The error +message generated in the latter case can be retrieved by calling the +error() method. See also L<CONFIGURATION SUMMARY> which describes how +error handling may be further customised. + +=head2 error() + +When called as a class method, it returns the value of the $ERROR package +variable. Thus, the following are equivalent. + + my $tt = Template->new() + || die Template->error(), "\n"; + + my $tt = Template->new() + || die $Template::ERROR, "\n"; + +When called as an object method, it returns the value of the internal +_ERROR variable, as set by an error condition in a previous call to +process(). + + $tt->process('welcome.tt2') + || die $tt->error(), "\n"; + +Errors are represented in the Template Toolkit by objects of the +Template::Exception class. If the process() method returns a false +value then the error() method can be called to return an object of +this class. The type() and info() methods can called on the object to +retrieve the error type and information string, respectively. The +as_string() method can be called to return a string of the form "$type +- $info". This method is also overloaded onto the stringification +operator allowing the object reference itself to be printed to return +the formatted error string. + + $tt->process('somefile') || do { + my $error = $tt->error(); + print "error type: ", $error->type(), "\n"; + print "error info: ", $error->info(), "\n"; + print $error, "\n"; + }; + +=head2 service() + +The Template module delegates most of the effort of processing templates +to an underlying Template::Service object. This method returns a reference +to that object. + +=head2 context() + +The Template::Service module uses a core Template::Context object for +runtime processing of templates. This method returns a reference to +that object and is equivalent to $template-E<gt>service-E<gt>context(); + +=head1 CONFIGURATION SUMMARY + +The following list gives a short summary of each Template Toolkit +configuration option. See L<Template::Manual::Config> for full details. + +=head2 Template Style and Parsing Options + +=over 4 + +=item START_TAG, END_TAG + +Define tokens that indicate start and end of directives (default: '[%' and +'%]'). + +=item TAG_STYLE + +Set START_TAG and END_TAG according to a pre-defined style (default: +'template', as above). + +=item PRE_CHOMP, POST_CHOMP + +Remove whitespace before/after directives (default: 0/0). + +=item TRIM + +Remove leading and trailing whitespace from template output (default: 0). + +=item INTERPOLATE + +Interpolate variables embedded like $this or ${this} (default: 0). + +=item ANYCASE + +Allow directive keywords in lower case (default: 0 - UPPER only). + +=back + +=head2 Template Files and Blocks + +=over 4 + +=item INCLUDE_PATH + +One or more directories to search for templates. + +=item DELIMITER + +Delimiter for separating paths in INCLUDE_PATH (default: ':'). + +=item ABSOLUTE + +Allow absolute file names, e.g. /foo/bar.html (default: 0). + +=item RELATIVE + +Allow relative filenames, e.g. ../foo/bar.html (default: 0). + +=item DEFAULT + +Default template to use when another not found. + +=item BLOCKS + +Hash array pre-defining template blocks. + +=item AUTO_RESET + +Enabled by default causing BLOCK definitions to be reset each time a +template is processed. Disable to allow BLOCK definitions to persist. + +=item RECURSION + +Flag to permit recursion into templates (default: 0). + +=back + +=head2 Template Variables + +=over 4 + +=item VARIABLES, PRE_DEFINE + +Hash array of variables and values to pre-define in the stash. + +=back + +=head2 Runtime Processing Options + +=over 4 + +=item EVAL_PERL + +Flag to indicate if PERL/RAWPERL blocks should be processed (default: 0). + +=item PRE_PROCESS, POST_PROCESS + +Name of template(s) to process before/after main template. + +=item PROCESS + +Name of template(s) to process instead of main template. + +=item ERROR + +Name of error template or reference to hash array mapping error types to +templates. + +=item OUTPUT + +Default output location or handler. + +=item OUTPUT_PATH + +Directory into which output files can be written. + +=item DEBUG + +Enable debugging messages. + +=back + +=head2 Caching and Compiling Options + +=over 4 + +=item CACHE_SIZE + +Maximum number of compiled templates to cache in memory (default: +undef - cache all) + +=item COMPILE_EXT + +Filename extension for compiled template files (default: undef - don't +compile). + +=item COMPILE_DIR + +Root of directory in which compiled template files should be written +(default: undef - don't compile). + +=back + +=head2 Plugins and Filters + +=over 4 + +=item PLUGINS + +Reference to a hash array mapping plugin names to Perl packages. + +=item PLUGIN_BASE + +One or more base classes under which plugins may be found. + +=item LOAD_PERL + +Flag to indicate regular Perl modules should be loaded if a named plugin +can't be found (default: 0). + +=item FILTERS + +Hash array mapping filter names to filter subroutines or factories. + +=back + +=head2 Compatibility, Customisation and Extension + +=over 4 + +=item V1DOLLAR + +Backwards compatibility flag enabling version 1.* handling (i.e. ignore it) +of leading '$' on variables (default: 0 - '$' indicates interpolation). + +=item LOAD_TEMPLATES + +List of template providers. + +=item LOAD_PLUGINS + +List of plugin providers. + +=item LOAD_FILTERS + +List of filter providers. + +=item TOLERANT + +Set providers to tolerate errors as declinations (default: 0). + +=item SERVICE + +Reference to a custom service object (default: Template::Service). + +=item CONTEXT + +Reference to a custom context object (default: Template::Context). + +=item STASH + +Reference to a custom stash object (default: Template::Stash). + +=item PARSER + +Reference to a custom parser object (default: Template::Parser). + +=item GRAMMAR + +Reference to a custom grammar object (default: Template::Grammar). + +=back + +=head1 DIRECTIVE SUMMARY + +The following list gives a short summary of each Template Toolkit directive. +See L<Template::Manual::Directives> for full details. + +=over 4 + +=item GET + +Evaluate and print a variable or value. + + [% GET variable %] # 'GET' keyword is optional + + [% variable %] + [% hash.key %] + [% list.n %] + [% code(args) %] + [% obj.meth(args) %] + [% "value: $var" %] + +=item CALL + +As per GET but without printing result (e.g. call code) + + [% CALL variable %] + +=item SET + +Assign a values to variables. + + [% SET variable = value %] # 'SET' also optional + + [% variable = other_variable + variable = 'literal text @ $100' + variable = "interpolated text: $var" + list = [ val, val, val, val, ... ] + list = [ val..val ] + hash = { var => val, var => val, ... } + %] + +=item DEFAULT + +Like SET above, but variables are only set if currently unset (i.e. have no +true value). + + [% DEFAULT variable = value %] + +=item INSERT + +Insert a file without any processing performed on the contents. + + [% INSERT legalese.txt %] + +=item INCLUDE + +Process another template file or block and include the output. Variables +are localised. + + [% INCLUDE template %] + [% INCLUDE template var = val, ... %] + +=item PROCESS + +As INCLUDE above, but without localising variables. + + [% PROCESS template %] + [% PROCESS template var = val, ... %] + +=item WRAPPER + +Process the enclosed block WRAPPER ... END block then INCLUDE the +named template, passing the block output in the 'content' variable. + + [% WRAPPER template %] + content... + [% END %] + +=item BLOCK + +Define a named template block for subsequent INCLUDE, PROCESS, etc., + + [% BLOCK template %] + content + [% END %] + +=item FOREACH + +Repeat the enclosed FOREACH ... END block for each value in the list. + + [% FOREACH variable = [ val, val, val ] %] # either + [% FOREACH variable = list %] # or + [% FOREACH list %] # or + content... + [% variable %] + [% END %] + +=item WHILE + +Enclosed WHILE ... END block is processed while condition is true. + + [% WHILE condition %] + content + [% END %] + +=item IF / UNLESS / ELSIF / ELSE + +Enclosed block is processed if the condition is true / false. + + [% IF condition %] + content + [% ELSIF condition %] + content + [% ELSE %] + content + [% END %] + + [% UNLESS condition %] + content + [% # ELSIF/ELSE as per IF, above %] + content + [% END %] + +=item SWITCH / CASE + +Multi-way switch/case statement. + + [% SWITCH variable %] + [% CASE val1 %] + content + [% CASE [ val2, val3 ] %] + content + [% CASE %] # or [% CASE DEFAULT %] + content + [% END %] + +=item MACRO + +Define a named macro. + + [% MACRO name <directive> %] + [% MACRO name(arg1, arg2) <directive> %] + ... + [% name %] + [% name(val1, val2) %] + +=item FILTER + +Process enclosed FILTER ... END block then pipe through a filter. + + [% FILTER name %] # either + [% FILTER name( params ) %] # or + [% FILTER alias = name( params ) %] # or + content + [% END %] + +=item USE + +Load a "plugin" module, or any regular Perl module if LOAD_PERL option is +set. + + [% USE name %] # either + [% USE name( params ) %] # or + [% USE var = name( params ) %] # or + ... + [% name.method %] + [% var.method %] + +=item PERL / RAWPERL + +Evaluate enclosed blocks as Perl code (requires EVAL_PERL option to be set). + + [% PERL %] + # perl code goes here + $stash->set('foo', 10); + print "set 'foo' to ", $stash->get('foo'), "\n"; + print $context->include('footer', { var => $val }); + [% END %] + + [% RAWPERL %] + # raw perl code goes here, no magic but fast. + $output .= 'some output'; + [% END %] + +=item TRY / THROW / CATCH / FINAL + +Exception handling. + + [% TRY %] + content + [% THROW type info %] + [% CATCH type %] + catch content + [% error.type %] [% error.info %] + [% CATCH %] # or [% CATCH DEFAULT %] + content + [% FINAL %] + this block is always processed + [% END %] + +=item NEXT + +Jump straight to the next item in a FOREACH/WHILE loop. + + [% NEXT %] + +=item LAST + +Break out of FOREACH/WHILE loop. + + [% LAST %] + +=item RETURN + +Stop processing current template and return to including templates. + + [% RETURN %] + +=item STOP + +Stop processing all templates and return to caller. + + [% STOP %] + +=item TAGS + +Define new tag style or characters (default: [% %]). + + [% TAGS html %] + [% TAGS <!-- --> %] + +=item COMMENTS + +Ignored and deleted. + + [% # this is a comment to the end of line + foo = 'bar' + %] + + [%# placing the '#' immediately inside the directive + tag comments out the entire directive + %] + +=back + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/lib/Template/Base.pm b/lib/Template/Base.pm new file mode 100644 index 0000000..b66d9c8 --- /dev/null +++ b/lib/Template/Base.pm @@ -0,0 +1,290 @@ +#============================================================= -*-perl-*- +# +# Template::Base +# +# DESCRIPTION +# Base class module implementing common functionality for various other +# Template Toolkit modules. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#------------------------------------------------------------------------ +# +# $Id: Base.pm,v 2.62 2003/04/24 09:14:38 abw Exp $ +# +#======================================================================== + +package Template::Base; + +require 5.004; + +use strict; +use vars qw( $VERSION ); +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); + + +#------------------------------------------------------------------------ +# new(\%params) +# +# General purpose constructor method which expects a hash reference of +# configuration parameters, or a list of name => value pairs which are +# folded into a hash. Blesses a hash into an object and calls its +# _init() method, passing the parameter hash reference. Returns a new +# object derived from Template::Base, or undef on error. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my ($argnames, @args, $arg, $cfg); +# $class->error(''); # always clear package $ERROR var? + + { no strict qw( refs ); + $argnames = \@{"$class\::BASEARGS"} || [ ]; + } + + # shift off all mandatory args, returning error if undefined or null + foreach $arg (@$argnames) { + return $class->error("no $arg specified") + unless ($cfg = shift); + push(@args, $cfg); + } + + # fold all remaining args into a hash, or use provided hash ref +# local $" = ', '; +# print STDERR "args: [@_]\n"; + $cfg = defined $_[0] && UNIVERSAL::isa($_[0], 'HASH') ? shift : { @_ }; + + my $self = bless { + map { ($_ => shift @args) } @$argnames, + _ERROR => '', + DEBUG => 0, + }, $class; + + return $self->_init($cfg) ? $self : $class->error($self->error); +} + + +#------------------------------------------------------------------------ +# error() +# error($msg, ...) +# +# May be called as a class or object method to set or retrieve the +# package variable $ERROR (class method) or internal member +# $self->{ _ERROR } (object method). The presence of parameters indicates +# that the error value should be set. Undef is then returned. In the +# abscence of parameters, the current error value is returned. +#------------------------------------------------------------------------ + +sub error { + my $self = shift; + my $errvar; + + { + no strict qw( refs ); + $errvar = ref $self ? \$self->{ _ERROR } : \${"$self\::ERROR"}; + } + if (@_) { + $$errvar = ref($_[0]) ? shift : join('', @_); + return undef; + } + else { + return $$errvar; + } +} + + +#------------------------------------------------------------------------ +# _init() +# +# Initialisation method called by the new() constructor and passing a +# reference to a hash array containing any configuration items specified +# as constructor arguments. Should return $self on success or undef on +# error, via a call to the error() method to set the error message. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $config) = @_; + return $self; +} + + +sub DEBUG { + my $self = shift; + print STDERR "DEBUG: ", @_; +} + +sub debug { + my $self = shift; + my $msg = join('', @_); + my ($pkg, $file, $line) = caller(); + + unless ($msg =~ /\n$/) { + $msg .= ($self->{ DEBUG } & Template::Constants::DEBUG_CALLER) + ? " at $file line $line\n" + : "\n"; + } + + print STDERR "[$pkg] $msg"; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Base - Base class module implementing common functionality + +=head1 SYNOPSIS + + package My::Module; + use base qw( Template::Base ); + + sub _init { + my ($self, $config) = @_; + $self->{ doodah } = $config->{ doodah } + || return $self->error("No 'doodah' specified"); + return $self; + } + + package main; + + my $object = My::Module->new({ doodah => 'foobar' }) + || die My::Module->error(); + +=head1 DESCRIPTION + +Base class module which implements a constructor and error reporting +functionality for various Template Toolkit modules. + +=head1 PUBLIC METHODS + +=head2 new(\%config) + +Constructor method which accepts a reference to a hash array or a list +of C<name =E<gt> value> parameters which are folded into a hash. The +_init() method is then called, passing the configuration hash and should +return true/false to indicate success or failure. A new object reference +is returned, or undef on error. Any error message raised can be examined +via the error() class method or directly via the package variable ERROR +in the derived class. + + my $module = My::Module->new({ ... }) + || die My::Module->error(), "\n"; + + my $module = My::Module->new({ ... }) + || die "constructor error: $My::Module::ERROR\n"; + +=head2 error($msg, ...) + +May be called as an object method to get/set the internal _ERROR member +or as a class method to get/set the $ERROR variable in the derived class's +package. + + my $module = My::Module->new({ ... }) + || die My::Module->error(), "\n"; + + $module->do_something() + || die $module->error(), "\n"; + +When called with parameters (multiple params are concatenated), this +method will set the relevant variable and return undef. This is most +often used within object methods to report errors to the caller. + + package My::Module; + + sub foobar { + my $self = shift; + + # some other code... + + return $self->error('some kind of error...') + if $some_condition; + } + +=head2 debug($msg, ...) + +Generates a debugging message by concatenating all arguments +passed into a string and printing it to STDERR. A prefix is +added to indicate the module of the caller. + + package My::Module; + + sub foobar { + my $self = shift; + + $self->debug('called foobar()'); + + # some other code... + } + +When the foobar() method is called, the following message +is sent to STDERR: + + [My::Module] called foobar() + +Objects can set an internal DEBUG value which the debug() +method will examine. If this value sets the relevant bits +to indicate DEBUG_CALLER then the file and line number of +the caller will be appened to the message. + + use Template::Constants qw( :debug ); + + my $module = My::Module->new({ + DEBUG => DEBUG_SERVICE | DEBUG_CONTEXT | DEBUG_CALLER, + }); + + $module->foobar(); + +This generates an error message such as: + + [My::Module] called foobar() at My/Module.pm line 6 + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.62, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template> diff --git a/lib/Template/Config.pm b/lib/Template/Config.pm new file mode 100644 index 0000000..dbe3a53 --- /dev/null +++ b/lib/Template/Config.pm @@ -0,0 +1,457 @@ +#============================================================= -*-perl-*- +# +# Template::Config +# +# DESCRIPTION +# Template Toolkit configuration module. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#------------------------------------------------------------------------ +# +# $Id: Config.pm,v 2.62 2003/04/24 09:14:38 abw Exp $ +# +#======================================================================== + +package Template::Config; + +require 5.004; + +use strict; +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG $ERROR $INSTDIR + $PARSER $PROVIDER $PLUGINS $FILTERS $ITERATOR + $LATEX_PATH $PDFLATEX_PATH $DVIPS_PATH + $STASH $SERVICE $CONTEXT $CONSTANTS @PRELOAD ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; +$ERROR = ''; +$CONTEXT = 'Template::Context'; +$FILTERS = 'Template::Filters'; +$ITERATOR = 'Template::Iterator'; +$PARSER = 'Template::Parser'; +$PLUGINS = 'Template::Plugins'; +$PROVIDER = 'Template::Provider'; +$SERVICE = 'Template::Service'; +$STASH = 'Template::Stash'; +$CONSTANTS = 'Template::Namespace::Constants'; + +@PRELOAD = ( $CONTEXT, $FILTERS, $ITERATOR, $PARSER, + $PLUGINS, $PROVIDER, $SERVICE, $STASH ); + +# the following is set at installation time by the Makefile.PL +$INSTDIR = ''; + +# LaTeX executable paths set at installation time by the Makefile.PL +# Empty strings cause the latex(pdf|dvi|ps) filters to throw an error. +$LATEX_PATH = ''; +$PDFLATEX_PATH = ''; +$DVIPS_PATH = ''; + +#======================================================================== +# --- CLASS METHODS --- +#======================================================================== + +#------------------------------------------------------------------------ +# preload($module, $module, ...) +# +# Preloads all the standard TT modules that are likely to be used, along +# with any other passed as arguments. +#------------------------------------------------------------------------ + +sub preload { + my $class = shift; + + foreach my $module (@PRELOAD, @_) { + $class->load($module) || return; + }; + return 1; +} + + +#------------------------------------------------------------------------ +# load($module) +# +# Load a module via require(). Any occurences of '::' in the module name +# are be converted to '/' and '.pm' is appended. Returns 1 on success +# or undef on error. Use $class->error() to examine the error string. +#------------------------------------------------------------------------ + +sub load { + my ($class, $module) = @_; + $module =~ s[::][/]g; + $module .= '.pm'; +# print STDERR "loading $module\n" +# if $DEBUG; + eval { + require $module; + }; + return $@ ? $class->error("failed to load $module: $@") : 1; +} + + +#------------------------------------------------------------------------ +# parser(\%params) +# +# Instantiate a new parser object of the class whose name is denoted by +# the package variable $PARSER (default: Template::Parser). Returns +# a reference to a newly instantiated parser object or undef on error. +# The class error() method can be called without arguments to examine +# the error message generated by this failure. +#------------------------------------------------------------------------ + +sub parser { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($PARSER); + return $PARSER->new($params) + || $class->error("failed to create parser: ", $PARSER->error); +} + + +#------------------------------------------------------------------------ +# provider(\%params) +# +# Instantiate a new template provider object (default: Template::Provider). +# Returns an object reference or undef on error, as above. +#------------------------------------------------------------------------ + +sub provider { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($PROVIDER); + return $PROVIDER->new($params) + || $class->error("failed to create template provider: ", + $PROVIDER->error); +} + + +#------------------------------------------------------------------------ +# plugins(\%params) +# +# Instantiate a new plugins provider object (default: Template::Plugins). +# Returns an object reference or undef on error, as above. +#------------------------------------------------------------------------ + +sub plugins { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($PLUGINS); + return $PLUGINS->new($params) + || $class->error("failed to create plugin provider: ", + $PLUGINS->error); +} + + +#------------------------------------------------------------------------ +# filters(\%params) +# +# Instantiate a new filters provider object (default: Template::Filters). +# Returns an object reference or undef on error, as above. +#------------------------------------------------------------------------ + +sub filters { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($FILTERS); + return $FILTERS->new($params) + || $class->error("failed to create filter provider: ", + $FILTERS->error); +} + + +#------------------------------------------------------------------------ +# iterator(\@list) +# +# Instantiate a new Template::Iterator object (default: Template::Iterator). +# Returns an object reference or undef on error, as above. +#------------------------------------------------------------------------ + +sub iterator { + my $class = shift; + my $list = shift; + + return undef unless $class->load($ITERATOR); + return $ITERATOR->new($list, @_) + || $class->error("failed to create iterator: ", $ITERATOR->error); +} + + +#------------------------------------------------------------------------ +# stash(\%vars) +# +# Instantiate a new template variable stash object (default: +# Template::Stash). Returns object or undef, as above. +#------------------------------------------------------------------------ + +sub stash { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($STASH); + return $STASH->new($params) + || $class->error("failed to create stash: ", $STASH->error); +} + + +#------------------------------------------------------------------------ +# context(\%params) +# +# Instantiate a new template context object (default: Template::Context). +# Returns object or undef, as above. +#------------------------------------------------------------------------ + +sub context { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($CONTEXT); + return $CONTEXT->new($params) + || $class->error("failed to create context: ", $CONTEXT->error); +} + + +#------------------------------------------------------------------------ +# service(\%params) +# +# Instantiate a new template context object (default: Template::Service). +# Returns object or undef, as above. +#------------------------------------------------------------------------ + +sub service { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($SERVICE); + return $SERVICE->new($params) + || $class->error("failed to create context: ", $SERVICE->error); +} + + +#------------------------------------------------------------------------ +# constants(\%params) +# +# Instantiate a new namespace handler for compile time constant folding +# (default: Template::Namespace::Constants). +# Returns object or undef, as above. +#------------------------------------------------------------------------ + +sub constants { + my $class = shift; + my $params = defined($_[0]) && UNIVERSAL::isa($_[0], 'HASH') + ? shift : { @_ }; + + return undef unless $class->load($CONSTANTS); + return $CONSTANTS->new($params) + || $class->error("failed to create constants namespace: ", + $CONSTANTS->error); +} + + +#------------------------------------------------------------------------ +# instdir($dir) +# +# Returns the root installation directory appended with any local +# component directory passed as an argument. +#------------------------------------------------------------------------ + +sub instdir { + my ($class, $dir) = @_; + my $inst = $INSTDIR + || return $class->error("no installation directory"); + $inst =~ s[/$][]g; + $inst .= "/$dir" if $dir; + return $inst; +} + +#------------------------------------------------------------------------ +# latexpaths() +# +# Returns a reference to a three element array: +# [latex_path, pdf2latex_path, dvips_path] +# These values are determined by Makefile.PL at installation time +# and are used by the latex(pdf|dvi|ps) filters. +#------------------------------------------------------------------------ + +sub latexpaths { + return [$LATEX_PATH, $PDFLATEX_PATH, $DVIPS_PATH]; +} + +#======================================================================== +# This should probably be moved somewhere else in the long term, but for +# now it ensures that Template::TieString is available even if the +# Template::Directive module hasn't been loaded, as is the case when +# using compiled templates and Template::Parser hasn't yet been loaded +# on demand. +#======================================================================== + +#------------------------------------------------------------------------ +# simple package for tying $output variable to STDOUT, used by perl() +#------------------------------------------------------------------------ + +package Template::TieString; + +sub TIEHANDLE { + my ($class, $textref) = @_; + bless $textref, $class; +} +sub PRINT { + my $self = shift; + $$self .= join('', @_); +} + + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Config - Factory module for instantiating other TT2 modules + +=head1 SYNOPSIS + + use Template::Config; + +=head1 DESCRIPTION + +This module implements various methods for loading and instantiating +other modules that comprise the Template Toolkit. It provides a consistent +way to create toolkit components and allows custom modules to be used in +place of the regular ones. + +Package variables such as $STASH, $SERVICE, $CONTEXT, etc., contain +the default module/package name for each component (Template::Stash, +Template::Service and Template::Context, respectively) and are used by +the various factory methods (stash(), service() and context()) to load +the appropriate module. Changing these package variables will cause +subsequent calls to the relevant factory method to load and instantiate +an object from the new class. + +=head1 PUBLIC METHODS + +=head2 load($module) + +Load a module via require(). Any occurences of '::' in the module name +are be converted to '/' and '.pm' is appended. Returns 1 on success +or undef on error. Use $class-E<gt>error() to examine the error string. + +=head2 preload() + +This method preloads all the other Template::* modules that are likely +to be used. It is called by the Template module when running under +mod_perl ($ENV{MOD_PERL} is set). + +=head2 parser(\%config) + +Instantiate a new parser object of the class whose name is denoted by +the package variable $PARSER (default: Template::Parser). Returns +a reference to a newly instantiated parser object or undef on error. + +=head2 provider(\%config) + +Instantiate a new template provider object (default: Template::Provider). +Returns an object reference or undef on error, as above. + +=head2 plugins(\%config) + +Instantiate a new plugins provider object (default: Template::Plugins). +Returns an object reference or undef on error, as above. + +=head2 filters(\%config) + +Instantiate a new filter provider object (default: Template::Filters). +Returns an object reference or undef on error, as above. + +=head2 stash(\%vars) + +Instantiate a new stash object (Template::Stash or Template::Stash::XS +depending on the default set at installation time) using the contents +of the optional hash array passed by parameter as initial variable +definitions. Returns an object reference or undef on error, as above. + +=head2 context(\%config) + +Instantiate a new template context object (default: Template::Context). +Returns an object reference or undef on error, as above. + +=head2 service(\%config) + +Instantiate a new template service object (default: Template::Service). +Returns an object reference or undef on error, as above. + +=head2 instdir($dir) + +Returns the root directory of the Template Toolkit installation under +which optional components are installed. Any relative directory specified +as an argument will be appended to the returned directory. + + # e.g. returns '/usr/local/tt2' + my $ttroot = Template::Config->instdir() + || die "$Template::Config::ERROR\n"; + + # e.g. returns '/usr/local/tt2/templates' + my $template = Template::Config->instdir('templates') + || die "$Template::Config::ERROR\n"; + +Returns undef and sets $Template::Config::ERROR appropriately if the +optional components of the Template Toolkit have not been installed. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.62, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template> diff --git a/lib/Template/Constants.pm b/lib/Template/Constants.pm new file mode 100644 index 0000000..60af6bb --- /dev/null +++ b/lib/Template/Constants.pm @@ -0,0 +1,277 @@ +#============================================================= -*-Perl-*- +# +# Template::Constants.pm +# +# DESCRIPTION +# Definition of constants for the Template Toolkit. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Constants.pm,v 2.62 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Constants; + +require 5.004; +require Exporter; + +use strict; +use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ); +use vars qw( $DEBUG_OPTIONS @STATUS @ERROR @CHOMP @DEBUG); + +@ISA = qw( Exporter ); +$VERSION = sprintf("%d.%02d", q$Revision: 2.62 $ =~ /(\d+)\.(\d+)/); + + +#======================================================================== +# ----- EXPORTER ----- +#======================================================================== + +# STATUS constants returned by directives +use constant STATUS_OK => 0; # ok +use constant STATUS_RETURN => 1; # ok, block ended by RETURN +use constant STATUS_STOP => 2; # ok, stoppped by STOP +use constant STATUS_DONE => 3; # ok, iterator done +use constant STATUS_DECLINED => 4; # ok, declined to service request +use constant STATUS_ERROR => 255; # error condition + +# ERROR constants for indicating exception types +use constant ERROR_RETURN => 'return'; # return a status code +use constant ERROR_FILE => 'file'; # file error: I/O, parse, recursion +use constant ERROR_VIEW => 'view'; # view error +use constant ERROR_UNDEF => 'undef'; # undefined variable value used +use constant ERROR_PERL => 'perl'; # error in [% PERL %] block +use constant ERROR_FILTER => 'filter'; # filter error +use constant ERROR_PLUGIN => 'plugin'; # plugin error + +# CHOMP constants for PRE_CHOMP and POST_CHOMP +use constant CHOMP_NONE => 0; # do not remove whitespace +use constant CHOMP_ALL => 1; # remove whitespace +use constant CHOMP_COLLAPSE => 2; # collapse whitespace to a single space + +# DEBUG constants to enable various debugging options +use constant DEBUG_OFF => 0; # do nothing +use constant DEBUG_ON => 1; # basic debugging flag +use constant DEBUG_UNDEF => 2; # throw undef on undefined variables +use constant DEBUG_VARS => 4; # general variable debugging +use constant DEBUG_DIRS => 8; # directive debugging +use constant DEBUG_STASH => 16; # general stash debugging +use constant DEBUG_CONTEXT => 32; # context debugging +use constant DEBUG_PARSER => 64; # parser debugging +use constant DEBUG_PROVIDER => 128; # provider debugging +use constant DEBUG_PLUGINS => 256; # plugins debugging +use constant DEBUG_FILTERS => 512; # filters debugging +use constant DEBUG_SERVICE => 1024; # context debugging +use constant DEBUG_ALL => 2047; # everything + +# extra debugging flags +use constant DEBUG_CALLER => 4096; # add caller file/line +use constant DEBUG_FLAGS => 4096; # bitmask to extraxt flags + +$DEBUG_OPTIONS = { + &DEBUG_OFF => off => off => &DEBUG_OFF, + &DEBUG_ON => on => on => &DEBUG_ON, + &DEBUG_UNDEF => undef => undef => &DEBUG_UNDEF, + &DEBUG_VARS => vars => vars => &DEBUG_VARS, + &DEBUG_DIRS => dirs => dirs => &DEBUG_DIRS, + &DEBUG_STASH => stash => stash => &DEBUG_STASH, + &DEBUG_CONTEXT => context => context => &DEBUG_CONTEXT, + &DEBUG_PARSER => parser => parser => &DEBUG_PARSER, + &DEBUG_PROVIDER => provider => provider => &DEBUG_PROVIDER, + &DEBUG_PLUGINS => plugins => plugins => &DEBUG_PLUGINS, + &DEBUG_FILTERS => filters => filters => &DEBUG_FILTERS, + &DEBUG_SERVICE => service => service => &DEBUG_SERVICE, + &DEBUG_ALL => all => all => &DEBUG_ALL, + &DEBUG_CALLER => caller => caller => &DEBUG_CALLER, +}; + +@STATUS = qw( STATUS_OK STATUS_RETURN STATUS_STOP STATUS_DONE + STATUS_DECLINED STATUS_ERROR ); +@ERROR = qw( ERROR_FILE ERROR_VIEW ERROR_UNDEF ERROR_PERL + ERROR_RETURN ERROR_FILTER ERROR_PLUGIN ); +@CHOMP = qw( CHOMP_NONE CHOMP_ALL CHOMP_COLLAPSE ); +@DEBUG = qw( DEBUG_OFF DEBUG_ON DEBUG_UNDEF DEBUG_VARS + DEBUG_DIRS DEBUG_STASH DEBUG_CONTEXT DEBUG_PARSER + DEBUG_PROVIDER DEBUG_PLUGINS DEBUG_FILTERS DEBUG_SERVICE + DEBUG_ALL DEBUG_CALLER DEBUG_FLAGS ); + +@EXPORT_OK = ( @STATUS, @ERROR, @CHOMP, @DEBUG ); +%EXPORT_TAGS = ( + 'all' => [ @EXPORT_OK ], + 'status' => [ @STATUS ], + 'error' => [ @ERROR ], + 'chomp' => [ @CHOMP ], + 'debug' => [ @DEBUG ], +); + + +sub debug_flags { + my ($self, $debug) = @_; + my (@flags, $flag, $value); + $debug = $self unless defined($debug) || ref($self); + + if ($debug =~ /^\d+$/) { + foreach $flag (@DEBUG) { + next if $flag =~ /^DEBUG_(OFF|ALL|FLAGS)$/; + + # don't trash the original + my $copy = $flag; + $flag =~ s/^DEBUG_//; + $flag = lc $flag; + return $self->error("no value for flag: $flag") + unless defined($value = $DEBUG_OPTIONS->{ $flag }); + $flag = $value; + + if ($debug & $flag) { + $value = $DEBUG_OPTIONS->{ $flag }; + return $self->error("no value for flag: $flag") unless defined $value; + push(@flags, $value); + } + } + return wantarray ? @flags : join(', ', @flags); + } + else { + @flags = split(/\W+/, $debug); + $debug = 0; + foreach $flag (@flags) { + $value = $DEBUG_OPTIONS->{ $flag }; + return $self->error("unknown debug flag: $flag") unless defined $value; + $debug |= $value; + } + return $debug; + } +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Constants - Defines constants for the Template Toolkit + +=head1 SYNOPSIS + + use Template::Constants qw( :status :error :all ); + +=head1 DESCRIPTION + +The Template::Constants modules defines, and optionally exports into the +caller's namespace, a number of constants used by the Template package. + +Constants may be used by specifying the Template::Constants package +explicitly: + + use Template::Constants; + + print Template::Constants::STATUS_DECLINED; + +Constants may be imported into the caller's namespace by naming them as +options to the C<use Template::Constants> statement: + + use Template::Constants qw( STATUS_DECLINED ); + + print STATUS_DECLINED; + +Alternatively, one of the following tagset identifiers may be specified +to import sets of constants; :status, :error, :all. + + use Template::Constants qw( :status ); + + print STATUS_DECLINED; + +See L<Exporter> for more information on exporting variables. + +=head1 EXPORTABLE TAG SETS + +The following tag sets and associated constants are defined: + + :status + STATUS_OK # no problem, continue + STATUS_RETURN # ended current block then continue (ok) + STATUS_STOP # controlled stop (ok) + STATUS_DONE # iterator is all done (ok) + STATUS_DECLINED # provider declined to service request (ok) + STATUS_ERROR # general error condition (not ok) + + :error + ERROR_RETURN # return a status code (e.g. 'stop') + ERROR_FILE # file error: I/O, parse, recursion + ERROR_UNDEF # undefined variable value used + ERROR_PERL # error in [% PERL %] block + ERROR_FILTER # filter error + ERROR_PLUGIN # plugin error + + :chomp # for PRE_CHOMP and POST_CHOMP + CHOMP_NONE # do not remove whitespace + CHOMP_ALL # remove whitespace + CHOMP_COLLAPSE # collapse whitespace to a single space + + :debug + DEBUG_OFF # do nothing + DEBUG_ON # basic debugging flag + DEBUG_UNDEF # throw undef on undefined variables + DEBUG_VARS # general variable debugging + DEBUG_DIRS # directive debugging + DEBUG_STASH # general stash debugging + DEBUG_CONTEXT # context debugging + DEBUG_PARSER # parser debugging + DEBUG_PROVIDER # provider debugging + DEBUG_PLUGINS # plugins debugging + DEBUG_FILTERS # filters debugging + DEBUG_SERVICE # context debugging + DEBUG_ALL # everything + DEBUG_CALLER # add caller file/line info + DEBUG_FLAGS # bitmap used internally + + :all All the above constants. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.62, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Exporter|Exporter> diff --git a/lib/Template/Context.pm b/lib/Template/Context.pm new file mode 100644 index 0000000..6fb29ca --- /dev/null +++ b/lib/Template/Context.pm @@ -0,0 +1,1549 @@ +#============================================================= -*-Perl-*- +# +# Template::Context +# +# DESCRIPTION +# Module defining a context in which a template document is processed. +# This is the runtime processing interface through which templates +# can access the functionality of the Template Toolkit. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# REVISION +# $Id: Context.pm,v 2.81 2003/07/24 11:32:35 abw Exp $ +# +#============================================================================ + +package Template::Context; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $AUTOLOAD $DEBUG_FORMAT ); +use base qw( Template::Base ); + +use Template::Base; +use Template::Config; +use Template::Constants; +use Template::Exception; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.81 $ =~ /(\d+)\.(\d+)/); +$DEBUG_FORMAT = "\n## \$file line \$line : [% \$text %] ##\n"; + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# template($name) +# +# General purpose method to fetch a template and return it in compiled +# form. In the usual case, the $name parameter will be a simple string +# containing the name of a template (e.g. 'header'). It may also be +# a reference to Template::Document object (or sub-class) or a Perl +# sub-routine. These are considered to be compiled templates and are +# returned intact. Finally, it may be a reference to any other kind +# of valid input source accepted by Template::Provider (e.g. scalar +# ref, glob, IO handle, etc). +# +# Templates may be cached at one of 3 different levels. The internal +# BLOCKS member is a local cache which holds references to all +# template blocks used or imported via PROCESS since the context's +# reset() method was last called. This is checked first and if the +# template is not found, the method then walks down the BLOCKSTACK +# list. This contains references to the block definition tables in +# any enclosing Template::Documents that we're visiting (e.g. we've +# been called via an INCLUDE and we want to access a BLOCK defined in +# the template that INCLUDE'd us). If nothing is defined, then we +# iterate through the LOAD_TEMPLATES providers list as a 'chain of +# responsibility' (see Design Patterns) asking each object to fetch() +# the template if it can. +# +# Returns the compiled template. On error, undef is returned and +# the internal ERROR value (read via error()) is set to contain an +# error message of the form "$name: $error". +#------------------------------------------------------------------------ + +sub template { + my ($self, $name) = @_; + my ($prefix, $blocks, $defblocks, $provider, $template, $error); + my ($shortname, $blockname, $providers); + + $self->debug("template($name)") if $self->{ DEBUG }; + + # references to Template::Document (or sub-class) objects objects, or + # CODE references are assumed to be pre-compiled templates and are + # returned intact + return $name + if UNIVERSAL::isa($name, 'Template::Document') + || ref($name) eq 'CODE'; + + $shortname = $name; + + unless (ref $name) { + + $self->debug("looking for block [$name]") if $self->{ DEBUG }; + + # we first look in the BLOCKS hash for a BLOCK that may have + # been imported from a template (via PROCESS) + return $template + if ($template = $self->{ BLOCKS }->{ $name }); + + # then we iterate through the BLKSTACK list to see if any of the + # Template::Documents we're visiting define this BLOCK + foreach $blocks (@{ $self->{ BLKSTACK } }) { + return $template + if $blocks && ($template = $blocks->{ $name }); + } + + # now it's time to ask the providers, so we look to see if any + # prefix is specified to indicate the desired provider set. + if ($^O eq 'MSWin32') { + # let C:/foo through + $prefix = $1 if $shortname =~ s/^(\w{2,})://o; + } + else { + $prefix = $1 if $shortname =~ s/^(\w+)://; + } + + if (defined $prefix) { + $providers = $self->{ PREFIX_MAP }->{ $prefix } + || return $self->throw(Template::Constants::ERROR_FILE, + "no providers for template prefix '$prefix'"); + } + } + $providers = $self->{ PREFIX_MAP }->{ default } + || $self->{ LOAD_TEMPLATES } + unless $providers; + + + # Finally we try the regular template providers which will + # handle references to files, text, etc., as well as templates + # reference by name. If + + $blockname = ''; + while ($shortname) { + $self->debug("asking providers for [$shortname] [$blockname]") + if $self->{ DEBUG }; + + foreach my $provider (@$providers) { + ($template, $error) = $provider->fetch($shortname, $prefix); + if ($error) { + if ($error == Template::Constants::STATUS_ERROR) { + # $template contains exception object + if (UNIVERSAL::isa($template, 'Template::Exception') + && $template->type() eq Template::Constants::ERROR_FILE) { + $self->throw($template); + } + else { + $self->throw( Template::Constants::ERROR_FILE, $template ); + } + } + # DECLINE is ok, carry on + } + elsif (length $blockname) { + return $template + if $template = $template->blocks->{ $blockname }; + } + else { + return $template; + } + } + + last if ref $shortname || ! $self->{ EXPOSE_BLOCKS }; + $shortname =~ s{/([^/]+)$}{} || last; + $blockname = length $blockname ? "$1/$blockname" : $1; + } + + $self->throw(Template::Constants::ERROR_FILE, "$name: not found"); +} + + +#------------------------------------------------------------------------ +# plugin($name, \@args) +# +# Calls on each of the LOAD_PLUGINS providers in turn to fetch() (i.e. load +# and instantiate) a plugin of the specified name. Additional parameters +# passed are propagated to the new() constructor for the plugin. +# Returns a reference to a new plugin object or other reference. On +# error, undef is returned and the appropriate error message is set for +# subsequent retrieval via error(). +#------------------------------------------------------------------------ + +sub plugin { + my ($self, $name, $args) = @_; + my ($provider, $plugin, $error); + + $self->debug("plugin($name, ", defined $args ? @$args : '[ ]', ')') + if $self->{ DEBUG }; + + # request the named plugin from each of the LOAD_PLUGINS providers in turn + foreach my $provider (@{ $self->{ LOAD_PLUGINS } }) { + ($plugin, $error) = $provider->fetch($name, $args, $self); + return $plugin unless $error; + if ($error == Template::Constants::STATUS_ERROR) { + $self->throw($plugin) if ref $plugin; + $self->throw(Template::Constants::ERROR_PLUGIN, $plugin); + } + } + + $self->throw(Template::Constants::ERROR_PLUGIN, "$name: plugin not found"); +} + + +#------------------------------------------------------------------------ +# filter($name, \@args, $alias) +# +# Similar to plugin() above, but querying the LOAD_FILTERS providers to +# return filter instances. An alias may be provided which is used to +# save the returned filter in a local cache. +#------------------------------------------------------------------------ + +sub filter { + my ($self, $name, $args, $alias) = @_; + my ($provider, $filter, $error); + + $self->debug("filter($name, ", + defined $args ? @$args : '[ ]', + defined $alias ? $alias : '<no alias>', ')') + if $self->{ DEBUG }; + + # use any cached version of the filter if no params provided + return $filter + if ! $args && ! ref $name + && ($filter = $self->{ FILTER_CACHE }->{ $name }); + + # request the named filter from each of the FILTERS providers in turn + foreach my $provider (@{ $self->{ LOAD_FILTERS } }) { + ($filter, $error) = $provider->fetch($name, $args, $self); + last unless $error; + if ($error == Template::Constants::STATUS_ERROR) { + $self->throw($filter) if ref $filter; + $self->throw(Template::Constants::ERROR_FILTER, $filter); + } + # return $self->error($filter) + # if $error == &Template::Constants::STATUS_ERROR; + } + + return $self->error("$name: filter not found") + unless $filter; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # commented out by abw on 19 Nov 2001 to fix problem with xmlstyle + # plugin which may re-define a filter by calling define_filter() + # multiple times. With the automatic aliasing/caching below, any + # new filter definition isn't seen. Don't think this will cause + # any problems as filters explicitly supplied with aliases will + # still work as expected. + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # alias defaults to name if undefined + # $alias = $name + # unless defined($alias) or ref($name) or $args; + + # cache FILTER if alias is valid + $self->{ FILTER_CACHE }->{ $alias } = $filter + if $alias; + + return $filter; +} + + +#------------------------------------------------------------------------ +# view(\%config) +# +# Create a new Template::View bound to this context. +#------------------------------------------------------------------------ + +sub view { + my $self = shift; + require Template::View; + return Template::View->new($self, @_) + || $self->throw(&Template::Constants::ERROR_VIEW, + $Template::View::ERROR); +} + + +#------------------------------------------------------------------------ +# process($template, \%params) [% PROCESS template var=val ... %] +# process($template, \%params, $local) [% INCLUDE template var=val ... %] +# +# Processes the template named or referenced by the first parameter. +# The optional second parameter may reference a hash array of variable +# definitions. These are set before the template is processed by +# calling update() on the stash. Note that, unless the third parameter +# is true, the context is not localised and these, and any other +# variables set in the template will retain their new values after this +# method returns. The third parameter is in place so that this method +# can handle INCLUDE calls: the stash will be localized. +# +# Returns the output of processing the template. Errors are thrown +# as Template::Exception objects via die(). +#------------------------------------------------------------------------ + +sub process { + my ($self, $template, $params, $localize) = @_; + my ($trim, $blocks) = @$self{ qw( TRIM BLOCKS ) }; + my (@compiled, $name, $compiled); + my ($stash, $tblocks, $error, $tmpout); + my $output = ''; + + $template = [ $template ] unless ref $template eq 'ARRAY'; + + $self->debug("process([ ", join(', '), @$template, ' ], ', + defined $params ? $params : '<no params>', ', ', + $localize ? '<localized>' : '<unlocalized>', ')') + if $self->{ DEBUG }; + + # fetch compiled template for each name specified + foreach $name (@$template) { + push(@compiled, $self->template($name)); + } + + if ($localize) { + # localise the variable stash with any parameters passed + $stash = $self->{ STASH } = $self->{ STASH }->clone($params); + } else { + # update stash with any new parameters passed + $self->{ STASH }->update($params); + $stash = $self->{ STASH }; + } + + eval { + foreach $name (@$template) { + $compiled = shift @compiled; + my $element = ref $compiled eq 'CODE' + ? { (name => (ref $name ? '' : $name), modtime => time()) } + : $compiled; + $stash->set('component', $element); + + unless ($localize) { + # merge any local blocks defined in the Template::Document + # into our local BLOCKS cache + @$blocks{ keys %$tblocks } = values %$tblocks + if UNIVERSAL::isa($compiled, 'Template::Document') + && ($tblocks = $compiled->blocks()); + } + + if (ref $compiled eq 'CODE') { + $tmpout = &$compiled($self); + } + elsif (ref $compiled) { + $tmpout = $compiled->process($self); + } + else { + $self->throw('file', + "invalid template reference: $compiled"); + } + + if ($trim) { + for ($tmpout) { + s/^\s+//; + s/\s+$//; + } + } + $output .= $tmpout; + } + }; + $error = $@; + + if ($localize) { + # ensure stash is delocalised before dying + $self->{ STASH } = $self->{ STASH }->declone(); + } + + $self->throw(ref $error + ? $error : (Template::Constants::ERROR_FILE, $error)) + if $error; + + return $output; +} + + +#------------------------------------------------------------------------ +# include($template, \%params) [% INCLUDE template var = val, ... %] +# +# Similar to process() above but processing the template in a local +# context. Any variables passed by reference to a hash as the second +# parameter will be set before the template is processed and then +# revert to their original values before the method returns. Similarly, +# any changes made to non-global variables within the template will +# persist only until the template is processed. +# +# Returns the output of processing the template. Errors are thrown +# as Template::Exception objects via die(). +#------------------------------------------------------------------------ + +sub include { + my ($self, $template, $params) = @_; + return $self->process($template, $params, 'localize me!'); +} + +#------------------------------------------------------------------------ +# insert($file) +# +# Insert the contents of a file without parsing. +#------------------------------------------------------------------------ + +sub insert { + my ($self, $file) = @_; + my ($prefix, $providers, $text, $error); + my $output = ''; + + my $files = ref $file eq 'ARRAY' ? $file : [ $file ]; + + $self->debug("insert([ ", join(', '), @$files, " ])") + if $self->{ DEBUG }; + + + FILE: foreach $file (@$files) { + my $name = $file; + + if ($^O eq 'MSWin32') { + # let C:/foo through + $prefix = $1 if $name =~ s/^(\w{2,})://o; + } + else { + $prefix = $1 if $name =~ s/^(\w+)://; + } + + if (defined $prefix) { + $providers = $self->{ PREFIX_MAP }->{ $prefix } + || return $self->throw(Template::Constants::ERROR_FILE, + "no providers for file prefix '$prefix'"); + } + else { + $providers = $self->{ PREFIX_MAP }->{ default } + || $self->{ LOAD_TEMPLATES }; + } + + foreach my $provider (@$providers) { + ($text, $error) = $provider->load($name, $prefix); + next FILE unless $error; + if ($error == Template::Constants::STATUS_ERROR) { + $self->throw($text) if ref $text; + $self->throw(Template::Constants::ERROR_FILE, $text); + } + } + $self->throw(Template::Constants::ERROR_FILE, "$file: not found"); + } + continue { + $output .= $text; + } + return $output; +} + + +#------------------------------------------------------------------------ +# throw($type, $info, \$output) [% THROW errtype "Error info" %] +# +# Throws a Template::Exception object by calling die(). This method +# may be passed a reference to an existing Template::Exception object; +# a single value containing an error message which is used to +# instantiate a Template::Exception of type 'undef'; or a pair of +# values representing the exception type and info from which a +# Template::Exception object is instantiated. e.g. +# +# $context->throw($exception); +# $context->throw("I'm sorry Dave, I can't do that"); +# $context->throw('denied', "I'm sorry Dave, I can't do that"); +# +# An optional third parameter can be supplied in the last case which +# is a reference to the current output buffer containing the results +# of processing the template up to the point at which the exception +# was thrown. The RETURN and STOP directives, for example, use this +# to propagate output back to the user, but it can safely be ignored +# in most cases. +# +# This method rides on a one-way ticket to die() oblivion. It does not +# return in any real sense of the word, but should get caught by a +# surrounding eval { } block (e.g. a BLOCK or TRY) and handled +# accordingly, or returned to the caller as an uncaught exception. +#------------------------------------------------------------------------ + +sub throw { + my ($self, $error, $info, $output) = @_; + local $" = ', '; + + # die! die! die! + if (UNIVERSAL::isa($error, 'Template::Exception')) { + die $error; + } + elsif (defined $info) { + die (Template::Exception->new($error, $info, $output)); + } + else { + $error ||= ''; + die (Template::Exception->new('undef', $error, $output)); + } + + # not reached +} + + +#------------------------------------------------------------------------ +# catch($error, \$output) +# +# Called by various directives after catching an error thrown via die() +# from within an eval { } block. The first parameter contains the errror +# which may be a sanitized reference to a Template::Exception object +# (such as that raised by the throw() method above, a plugin object, +# and so on) or an error message thrown via die from somewhere in user +# code. The latter are coerced into 'undef' Template::Exception objects. +# Like throw() above, a reference to a scalar may be passed as an +# additional parameter to represent the current output buffer +# localised within the eval block. As exceptions are thrown upwards +# and outwards from nested blocks, the catch() method reconstructs the +# correct output buffer from these fragments, storing it in the +# exception object for passing further onwards and upwards. +# +# Returns a reference to a Template::Exception object.. +#------------------------------------------------------------------------ + +sub catch { + my ($self, $error, $output) = @_; + + if (UNIVERSAL::isa($error, 'Template::Exception')) { + $error->text($output) if $output; + return $error; + } + else { + return Template::Exception->new('undef', $error, $output); + } +} + + +#------------------------------------------------------------------------ +# localise(\%params) +# delocalise() +# +# The localise() method creates a local copy of the current stash, +# allowing the existing state of variables to be saved and later +# restored via delocalise(). +# +# A reference to a hash array may be passed containing local variable +# definitions which should be added to the cloned namespace. These +# values persist until delocalisation. +#------------------------------------------------------------------------ + +sub localise { + my $self = shift; + $self->{ STASH } = $self->{ STASH }->clone(@_); +} + +sub delocalise { + my $self = shift; + $self->{ STASH } = $self->{ STASH }->declone(); +} + + +#------------------------------------------------------------------------ +# visit($blocks) +# +# Each Template::Document calls the visit() method on the context +# before processing itself. It passes a reference to the hash array +# of named BLOCKs defined within the document, allowing them to be +# added to the internal BLKSTACK list which is subsequently used by +# template() to resolve templates. +# from a provider. +#------------------------------------------------------------------------ + +sub visit { + my ($self, $blocks) = @_; + unshift(@{ $self->{ BLKSTACK } }, $blocks) +} + + +#------------------------------------------------------------------------ +# leave() +# +# The leave() method is called when the document has finished +# processing itself. This removes the entry from the BLKSTACK list +# that was added visit() above. For persistance of BLOCK definitions, +# the process() method (i.e. the PROCESS directive) does some extra +# magic to copy BLOCKs into a shared hash. +#------------------------------------------------------------------------ + +sub leave { + my $self = shift; + shift(@{ $self->{ BLKSTACK } }); +} + + +#------------------------------------------------------------------------ +# define_block($name, $block) +# +# Adds a new BLOCK definition to the local BLOCKS cache. $block may +# be specified as a reference to a sub-routine or Template::Document +# object or as text which is compiled into a template. Returns a true +# value (the $block reference or compiled block reference) if +# succesful or undef on failure. Call error() to retrieve the +# relevent error message (i.e. compilation failure). +#------------------------------------------------------------------------ + +sub define_block { + my ($self, $name, $block) = @_; + $block = $self->template(\$block) + || return undef + unless ref $block; + $self->{ BLOCKS }->{ $name } = $block; +} + + +#------------------------------------------------------------------------ +# define_filter($name, $filter, $is_dynamic) +# +# Adds a new FILTER definition to the local FILTER_CACHE. +#------------------------------------------------------------------------ + +sub define_filter { + my ($self, $name, $filter, $is_dynamic) = @_; + my ($result, $error); + $filter = [ $filter, 1 ] if $is_dynamic; + + foreach my $provider (@{ $self->{ LOAD_FILTERS } }) { + ($result, $error) = $provider->store($name, $filter); + return 1 unless $error; + $self->throw(&Template::Constants::ERROR_FILTER, $result) + if $error == &Template::Constants::STATUS_ERROR; + } + $self->throw(&Template::Constants::ERROR_FILTER, + "FILTER providers declined to store filter $name"); +} + + +#------------------------------------------------------------------------ +# reset() +# +# Reset the state of the internal BLOCKS hash to clear any BLOCK +# definitions imported via the PROCESS directive. Any original +# BLOCKS definitions passed to the constructor will be restored. +#------------------------------------------------------------------------ + +sub reset { + my ($self, $blocks) = @_; + $self->{ BLKSTACK } = [ ]; + $self->{ BLOCKS } = { %{ $self->{ INIT_BLOCKS } } }; +} + + +#------------------------------------------------------------------------ +# stash() +# +# Simple accessor methods to return the STASH values. This is likely +# to be called quite often so we provide a direct method rather than +# relying on the slower AUTOLOAD. +#------------------------------------------------------------------------ + +sub stash { + return $_[0]->{ STASH }; +} + + +#------------------------------------------------------------------------ +# define_vmethod($type, $name, \&sub) +# +# Passes $type, $name, and &sub on to stash->define_vmethod(). +#------------------------------------------------------------------------ +sub define_vmethod { + my $self = shift; + $self->stash->define_vmethod(@_); +} + + +#------------------------------------------------------------------------ +# debugging($command, @args, \%params) +# +# Method for controlling the debugging status of the context. The first +# argument can be 'on' or 'off' to enable/disable debugging, 'format' +# to define the format of the debug message, or 'msg' to generate a +# debugging message reporting the file, line, message text, etc., +# according to the current debug format. +#------------------------------------------------------------------------ + +sub debugging { + my $self = shift; + my $hash = ref $_[-1] eq 'HASH' ? pop : { }; + my @args = @_; + +# print "*** debug(@args)\n"; + if (@args) { + if ($args[0] =~ /^on|1$/i) { + $self->{ DEBUG_DIRS } = 1; + shift(@args); + } + elsif ($args[0] =~ /^off|0$/i) { + $self->{ DEBUG_DIRS } = 0; + shift(@args); + } + } + + if (@args) { + if ($args[0] =~ /^msg$/i) { + return unless $self->{ DEBUG_DIRS }; + my $format = $self->{ DEBUG_FORMAT }; + $format = $DEBUG_FORMAT unless defined $format; + $format =~ s/\$(\w+)/$hash->{ $1 }/ge; + return $format; + } + elsif ($args[0] =~ /^format$/i) { + $self->{ DEBUG_FORMAT } = $args[1]; + } + # else ignore + } + + return ''; +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# Provides pseudo-methods for read-only access to various internal +# members. For example, templates(), plugins(), filters(), +# eval_perl(), load_perl(), etc. These aren't called very often, or +# may never be called at all. +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + my $result; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + + warn "no such context method/member: $method\n" + unless defined ($result = $self->{ uc $method }); + + return $result; +} + + +#------------------------------------------------------------------------ +# DESTROY +# +# Stash may contain references back to the Context via macro closures, +# etc. This breaks the circular references. +#------------------------------------------------------------------------ + +sub DESTROY { + my $self = shift; + undef $self->{ STASH }; +} + + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init(\%config) +# +# Initialisation method called by Template::Base::new() +#------------------------------------------------------------------------ + +sub _init { + my ($self, $config) = @_; + my ($name, $item, $method, $block, $blocks); + my @itemlut = ( + LOAD_TEMPLATES => 'provider', + LOAD_PLUGINS => 'plugins', + LOAD_FILTERS => 'filters' + ); + + # LOAD_TEMPLATE, LOAD_PLUGINS, LOAD_FILTERS - lists of providers + while (($name, $method) = splice(@itemlut, 0, 2)) { + $item = $config->{ $name } + || Template::Config->$method($config) + || return $self->error($Template::Config::ERROR); + $self->{ $name } = ref $item eq 'ARRAY' ? $item : [ $item ]; + } + + my $providers = $self->{ LOAD_TEMPLATES }; + my $prefix_map = $self->{ PREFIX_MAP } = $config->{ PREFIX_MAP } || { }; + while (my ($key, $val) = each %$prefix_map) { + $prefix_map->{ $key } = [ ref $val ? $val : + map { $providers->[$_] } + split(/\D+/, $val) ] + unless ref $val eq 'ARRAY'; +# print(STDERR "prefix $key => $val => [", +# join(', ', @{ $prefix_map->{ $key } }), "]\n"); + } + + # STASH + $self->{ STASH } = $config->{ STASH } || do { + my $predefs = $config->{ VARIABLES } + || $config->{ PRE_DEFINE } + || { }; + + # hack to get stash to know about debug mode + $predefs->{ _DEBUG } = ( ($config->{ DEBUG } || 0) + & &Template::Constants::DEBUG_UNDEF ) ? 1 : 0 + unless defined $predefs->{ _DEBUG }; + + Template::Config->stash($predefs) + || return $self->error($Template::Config::ERROR); + }; + + # compile any template BLOCKS specified as text + $blocks = $config->{ BLOCKS } || { }; + $self->{ INIT_BLOCKS } = $self->{ BLOCKS } = { + map { + $block = $blocks->{ $_ }; + $block = $self->template(\$block) + || return undef + unless ref $block; + ($_ => $block); + } + keys %$blocks + }; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # RECURSION - flag indicating is recursion into templates is supported + # EVAL_PERL - flag indicating if PERL blocks should be processed + # TRIM - flag to remove leading and trailing whitespace from output + # BLKSTACK - list of hashes of BLOCKs defined in current template(s) + # CONFIG - original configuration hash + # EXPOSE_BLOCKS - make blocks visible as pseudo-files + # DEBUG_FORMAT - format for generating template runtime debugging messages + # DEBUG - format for generating template runtime debugging messages + + $self->{ RECURSION } = $config->{ RECURSION } || 0; + $self->{ EVAL_PERL } = $config->{ EVAL_PERL } || 0; + $self->{ TRIM } = $config->{ TRIM } || 0; + $self->{ BLKSTACK } = [ ]; + $self->{ CONFIG } = $config; + $self->{ EXPOSE_BLOCKS } = defined $config->{ EXPOSE_BLOCKS } + ? $config->{ EXPOSE_BLOCKS } + : 0; + + $self->{ DEBUG_FORMAT } = $config->{ DEBUG_FORMAT }; + $self->{ DEBUG_DIRS } = ($config->{ DEBUG } || 0) + & Template::Constants::DEBUG_DIRS; + $self->{ DEBUG } = defined $config->{ DEBUG } + ? $config->{ DEBUG } & ( Template::Constants::DEBUG_CONTEXT + | Template::Constants::DEBUG_FLAGS ) + : $DEBUG; + + return $self; +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the context object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $output = "[Template::Context] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + foreach $key (qw( RECURSION EVAL_PERL TRIM )) { + $output .= sprintf($format, $key, $self->{ $key }); + } + foreach my $pname (qw( LOAD_TEMPLATES LOAD_PLUGINS LOAD_FILTERS )) { + my $provtext = "[\n"; + foreach my $prov (@{ $self->{ $pname } }) { + $provtext .= $prov->_dump(); +# $provtext .= ",\n"; + } + $provtext =~ s/\n/\n /g; + $provtext =~ s/\s+$//; + $provtext .= ",\n ]"; + $output .= sprintf($format, $pname, $provtext); + } + $output .= sprintf($format, STASH => $self->{ STASH }->_dump()); + $output .= '}'; + return $output; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Context - Runtime context in which templates are processed + +=head1 SYNOPSIS + + use Template::Context; + + # constructor + $context = Template::Context->new(\%config) + || die $Template::Context::ERROR; + + # fetch (load and compile) a template + $template = $context->template($template_name); + + # fetch (load and instantiate) a plugin object + $plugin = $context->plugin($name, \@args); + + # fetch (return or create) a filter subroutine + $filter = $context->filter($name, \@args, $alias); + + # process/include a template, errors are thrown via die() + $output = $context->process($template, \%vars); + $output = $context->include($template, \%vars); + + # raise an exception via die() + $context->throw($error_type, $error_message, \$output_buffer); + + # catch an exception, clean it up and fix output buffer + $exception = $context->catch($exception, \$output_buffer); + + # save/restore the stash to effect variable localisation + $new_stash = $context->localise(\%vars); + $old_stash = $context->delocalise(); + + # add new BLOCK or FILTER definitions + $context->define_block($name, $block); + $context->define_filter($name, \&filtersub, $is_dynamic); + + # reset context, clearing any imported BLOCK definitions + $context->reset(); + + # methods for accessing internal items + $stash = $context->stash(); + $tflag = $context->trim(); + $epflag = $context->eval_perl(); + $providers = $context->templates(); + $providers = $context->plugins(); + $providers = $context->filters(); + ... + +=head1 DESCRIPTION + +The Template::Context module defines an object class for representing +a runtime context in which templates are processed. It provides an +interface to the fundamental operations of the Template Toolkit +processing engine through which compiled templates (i.e. Perl code +constructed from the template source) can process templates, load +plugins and filters, raise exceptions and so on. + +A default Template::Context object is created by the Template module. +Any Template::Context options may be passed to the Template new() +constructor method and will be forwarded to the Template::Context +constructor. + + use Template; + + my $template = Template->new({ + TRIM => 1, + EVAL_PERL => 1, + BLOCKS => { + header => 'This is the header', + footer => 'This is the footer', + }, + }); + +Similarly, the Template::Context constructor will forward all configuration +parameters onto other default objects (e.g. Template::Provider, Template::Plugins, +Template::Filters, etc.) that it may need to instantiate. + + $context = Template::Context->new({ + INCLUDE_PATH => '/home/abw/templates', # provider option + TAG_STYLE => 'html', # parser option + }); + +A Template::Context object (or subclass/derivative) can be explicitly +instantiated and passed to the Template new() constructor method as +the CONTEXT item. + + use Template; + use Template::Context; + + my $context = Template::Context->new({ TRIM => 1 }); + my $template = Template->new({ CONTEXT => $context }); + +The Template module uses the Template::Config context() factory method +to create a default context object when required. The +$Template::Config::CONTEXT package variable may be set to specify an +alternate context module. This will be loaded automatically and its +new() constructor method called by the context() factory method when +a default context object is required. + + use Template; + + $Template::Config::CONTEXT = 'MyOrg::Template::Context'; + + my $template = Template->new({ + EVAL_PERL => 1, + EXTRA_MAGIC => 'red hot', # your extra config items + ... + }); + +=head1 METHODS + +=head2 new(\%params) + +The new() constructor method is called to instantiate a Template::Context +object. Configuration parameters may be specified as a HASH reference or +as a list of (name =E<gt> value) pairs. + + my $context = Template::Context->new({ + INCLUDE_PATH => 'header', + POST_PROCESS => 'footer', + }); + + my $context = Template::Context->new( EVAL_PERL => 1 ); + +The new() method returns a Template::Context object (or sub-class) or +undef on error. In the latter case, a relevant error message can be +retrieved by the error() class method or directly from the +$Template::Context::ERROR package variable. + + my $context = Template::Context->new(\%config) + || die Template::Context->error(); + + my $context = Template::Context->new(\%config) + || die $Template::Context::ERROR; + +The following configuration items may be specified. + +=over 4 + + +=item VARIABLES, PRE_DEFINE + +The VARIABLES option (or PRE_DEFINE - they're equivalent) can be used +to specify a hash array of template variables that should be used to +pre-initialise the stash when it is created. These items are ignored +if the STASH item is defined. + + my $context = Template::Context->new({ + VARIABLES => { + title => 'A Demo Page', + author => 'Joe Random Hacker', + version => 3.14, + }, + }; + +or + + my $context = Template::Context->new({ + PRE_DEFINE => { + title => 'A Demo Page', + author => 'Joe Random Hacker', + version => 3.14, + }, + }; + + + + + +=item BLOCKS + +The BLOCKS option can be used to pre-define a default set of template +blocks. These should be specified as a reference to a hash array +mapping template names to template text, subroutines or Template::Document +objects. + + my $context = Template::Context->new({ + BLOCKS => { + header => 'The Header. [% title %]', + footer => sub { return $some_output_text }, + another => Template::Document->new({ ... }), + }, + }); + + + + + +=item TRIM + +The TRIM option can be set to have any leading and trailing whitespace +automatically removed from the output of all template files and BLOCKs. + +By example, the following BLOCK definition + + [% BLOCK foo %] + Line 1 of foo + [% END %] + +will be processed is as "\nLine 1 of foo\n". When INCLUDEd, the surrounding +newlines will also be introduced. + + before + [% INCLUDE foo %] + after + +output: + before + + Line 1 of foo + + after + +With the TRIM option set to any true value, the leading and trailing +newlines (which count as whitespace) will be removed from the output +of the BLOCK. + + before + Line 1 of foo + after + +The TRIM option is disabled (0) by default. + + + + + + +=item EVAL_PERL + +This flag is used to indicate if PERL and/or RAWPERL blocks should be +evaluated. By default, it is disabled and any PERL or RAWPERL blocks +encountered will raise exceptions of type 'perl' with the message +'EVAL_PERL not set'. Note however that any RAWPERL blocks should +always contain valid Perl code, regardless of the EVAL_PERL flag. The +parser will fail to compile templates that contain invalid Perl code +in RAWPERL blocks and will throw a 'file' exception. + +When using compiled templates (see +L<COMPILE_EXT|Template::Manual::Config/Caching_and_Compiling_Options> and +L<COMPILE_DIR|Template::Manual::Config/Caching_and_Compiling_Options>), +the EVAL_PERL has an affect when the template is compiled, and again +when the templates is subsequently processed, possibly in a different +context to the one that compiled it. + +If the EVAL_PERL is set when a template is compiled, then all PERL and +RAWPERL blocks will be included in the compiled template. If the +EVAL_PERL option isn't set, then Perl code will be generated which +B<always> throws a 'perl' exception with the message 'EVAL_PERL not +set' B<whenever> the compiled template code is run. + +Thus, you must have EVAL_PERL set if you want your compiled templates +to include PERL and RAWPERL blocks. + +At some point in the future, using a different invocation of the +Template Toolkit, you may come to process such a pre-compiled +template. Assuming the EVAL_PERL option was set at the time the +template was compiled, then the output of any RAWPERL blocks will be +included in the compiled template and will get executed when the +template is processed. This will happen regardless of the runtime +EVAL_PERL status. + +Regular PERL blocks are a little more cautious, however. If the +EVAL_PERL flag isn't set for the I<current> context, that is, the +one which is trying to process it, then it will throw the familiar 'perl' +exception with the message, 'EVAL_PERL not set'. + +Thus you can compile templates to include PERL blocks, but optionally +disable them when you process them later. Note however that it is +possible for a PERL block to contain a Perl "BEGIN { # some code }" +block which will always get run regardless of the runtime EVAL_PERL +status. Thus, if you set EVAL_PERL when compiling templates, it is +assumed that you trust the templates to Do The Right Thing. Otherwise +you must accept the fact that there's no bulletproof way to prevent +any included code from trampling around in the living room of the +runtime environment, making a real nuisance of itself if it really +wants to. If you don't like the idea of such uninvited guests causing +a bother, then you can accept the default and keep EVAL_PERL disabled. + + + + + + + +=item RECURSION + +The template processor will raise a file exception if it detects +direct or indirect recursion into a template. Setting this option to +any true value will allow templates to include each other recursively. + + + +=item LOAD_TEMPLATES + +The LOAD_TEMPLATE option can be used to provide a reference to a list +of Template::Provider objects or sub-classes thereof which will take +responsibility for loading and compiling templates. + + my $context = Template::Context->new({ + LOAD_TEMPLATES => [ + MyOrg::Template::Provider->new({ ... }), + Template::Provider->new({ ... }), + ], + }); + +When a PROCESS, INCLUDE or WRAPPER directive is encountered, the named +template may refer to a locally defined BLOCK or a file relative to +the INCLUDE_PATH (or an absolute or relative path if the appropriate +ABSOLUTE or RELATIVE options are set). If a BLOCK definition can't be +found (see the Template::Context template() method for a discussion of +BLOCK locality) then each of the LOAD_TEMPLATES provider objects is +queried in turn via the fetch() method to see if it can supply the +required template. Each provider can return a compiled template, an +error, or decline to service the request in which case the +responsibility is passed to the next provider. If none of the +providers can service the request then a 'not found' error is +returned. The same basic provider mechanism is also used for the +INSERT directive but it bypasses any BLOCK definitions and doesn't +attempt is to parse or process the contents of the template file. + +This is an implementation of the 'Chain of Responsibility' +design pattern as described in +"Design Patterns", Erich Gamma, Richard Helm, Ralph Johnson, John +Vlissides), Addision-Wesley, ISBN 0-201-63361-2, page 223 +. + +If LOAD_TEMPLATES is undefined, a single default provider will be +instantiated using the current configuration parameters. For example, +the Template::Provider INCLUDE_PATH option can be specified in the Template::Context configuration and will be correctly passed to the provider's +constructor method. + + my $context = Template::Context->new({ + INCLUDE_PATH => '/here:/there', + }); + + + + + +=item LOAD_PLUGINS + +The LOAD_PLUGINS options can be used to specify a list of provider +objects (i.e. they implement the fetch() method) which are responsible +for loading and instantiating template plugin objects. The +Template::Content plugin() method queries each provider in turn in a +"Chain of Responsibility" as per the template() and filter() methods. + + my $context = Template::Context->new({ + LOAD_PLUGINS => [ + MyOrg::Template::Plugins->new({ ... }), + Template::Plugins->new({ ... }), + ], + }); + +By default, a single Template::Plugins object is created using the +current configuration hash. Configuration items destined for the +Template::Plugins constructor may be added to the Template::Context +constructor. + + my $context = Template::Context->new({ + PLUGIN_BASE => 'MyOrg::Template::Plugins', + LOAD_PERL => 1, + }); + + + + + +=item LOAD_FILTERS + +The LOAD_FILTERS option can be used to specify a list of provider +objects (i.e. they implement the fetch() method) which are responsible +for returning and/or creating filter subroutines. The +Template::Context filter() method queries each provider in turn in a +"Chain of Responsibility" as per the template() and plugin() methods. + + my $context = Template::Context->new({ + LOAD_FILTERS => [ + MyTemplate::Filters->new(), + Template::Filters->new(), + ], + }); + +By default, a single Template::Filters object is created for the +LOAD_FILTERS list. + + + +=item STASH + +A reference to a Template::Stash object or sub-class which will take +responsibility for managing template variables. + + my $stash = MyOrg::Template::Stash->new({ ... }); + my $context = Template::Context->new({ + STASH => $stash, + }); + +If unspecified, a default stash object is created using the VARIABLES +configuration item to initialise the stash variables. These may also +be specified as the PRE_DEFINE option for backwards compatibility with +version 1. + + my $context = Template::Context->new({ + VARIABLES => { + id => 'abw', + name => 'Andy Wardley', + }, + }; + + + +=item DEBUG + +The DEBUG option can be used to enable various debugging features +of the Template::Context module. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_CONTEXT | DEBUG_DIRS, + }); + +The DEBUG value can include any of the following. Multiple values +should be combined using the logical OR operator, '|'. + +=over 4 + +=item DEBUG_CONTEXT + +Enables general debugging messages for the +L<Template::Context|Template::Context> module. + +=item DEBUG_DIRS + +This option causes the Template Toolkit to generate comments +indicating the source file, line and original text of each directive +in the template. These comments are embedded in the template output +using the format defined in the DEBUG_FORMAT configuration item, or a +simple default format if unspecified. + +For example, the following template fragment: + + + Hello World + +would generate this output: + + ## input text line 1 : ## + Hello + ## input text line 2 : World ## + World + + +=back + + + + + +=back + +=head2 template($name) + +Returns a compiled template by querying each of the LOAD_TEMPLATES providers +(instances of Template::Provider, or sub-class) in turn. + + $template = $context->template('header'); + +On error, a Template::Exception object of type 'file' is thrown via +die(). This can be caught by enclosing the call to template() in an +eval block and examining $@. + + eval { + $template = $context->template('header'); + }; + if ($@) { + print "failed to fetch template: $@\n"; + } + +=head2 plugin($name, \@args) + +Instantiates a plugin object by querying each of the LOAD_PLUGINS +providers. The default LOAD_PLUGINS provider is a Template::Plugins +object which attempts to load plugin modules, according the various +configuration items such as PLUGIN_BASE, LOAD_PERL, etc., and then +instantiate an object via new(). A reference to a list of constructor +arguments may be passed as the second parameter. These are forwarded +to the plugin constructor. + +Returns a reference to a plugin (which is generally an object, but +doesn't have to be). Errors are thrown as Template::Exception objects +of type 'plugin'. + + $plugin = $context->plugin('DBI', 'dbi:msql:mydbname'); + +=head2 filter($name, \@args, $alias) + +Instantiates a filter subroutine by querying the LOAD_FILTERS providers. +The default LOAD_FILTERS providers is a Template::Filters object. +Additional arguments may be passed by list reference along with an +optional alias under which the filter will be cached for subsequent +use. The filter is cached under its own $name if $alias is undefined. +Subsequent calls to filter($name) will return the cached entry, if +defined. Specifying arguments bypasses the caching mechanism and +always creates a new filter. Errors are thrown as Template::Exception +objects of typre 'filter'. + + # static filter (no args) + $filter = $context->filter('html'); + + # dynamic filter (args) aliased to 'padright' + $filter = $context->filter('format', '%60s', 'padright'); + + # retrieve previous filter via 'padright' alias + $filter = $context->filter('padright'); + +=head2 process($template, \%vars) + +Processes a template named or referenced by the first parameter and returns +the output generated. An optional reference to a hash array may be passed +as the second parameter, containing variable definitions which will be set +before the template is processed. The template is processed in the current +context, with no localisation of variables performed. Errors are thrown +as Template::Exception objects via die(). + + $output = $context->process('header', { title => 'Hello World' }); + +=head2 include($template, \%vars) + +Similar to process() above, but using localised variables. Changes made to +any variables will only persist until the include() method completes. + + $output = $context->include('header', { title => 'Hello World' }); + +=head2 throw($error_type, $error_message, \$output) + +Raises an exception in the form of a Template::Exception object by +calling die(). This method may be passed a reference to an existing +Template::Exception object; a single value containing an error message +which is used to instantiate a Template::Exception of type 'undef'; or +a pair of values representing the exception type and info from which a +Template::Exception object is instantiated. e.g. + + $context->throw($exception); + $context->throw("I'm sorry Dave, I can't do that"); + $context->throw('denied', "I'm sorry Dave, I can't do that"); + +The optional third parameter may be a reference to the current output +buffer. This is then stored in the exception object when created, +allowing the catcher to examine and use the output up to the point at +which the exception was raised. + + $output .= 'blah blah blah'; + $output .= 'more rhubarb'; + $context->throw('yack', 'Too much yacking', \$output); + +=head2 catch($exception, \$output) + +Catches an exception thrown, either as a reference to a +Template::Exception object or some other value. In the latter case, +the error string is promoted to a Template::Exception object of +'undef' type. This method also accepts a reference to the current +output buffer which is passed to the Template::Exception constructor, +or is appended to the output buffer stored in an existing +Template::Exception object, if unique (i.e. not the same reference). +By this process, the correct state of the output buffer can be +reconstructed for simple or nested throws. + +=head2 define_block($name, $block) + +Adds a new block definition to the internal BLOCKS cache. The first +argument should contain the name of the block and the second a reference +to a Template::Document object or template sub-routine, or template text +which is automatically compiled into a template sub-routine. Returns +a true value (the sub-routine or Template::Document reference) on +success or undef on failure. The relevant error message can be +retrieved by calling the error() method. + +=head2 define_filter($name, \&filter, $is_dynamic) + +Adds a new filter definition by calling the store() method on each of +the LOAD_FILTERS providers until accepted (in the usual case, this is +accepted straight away by the one and only Template::Filters +provider). The first argument should contain the name of the filter +and the second a reference to a filter subroutine. The optional +third argument can be set to any true value to indicate that the +subroutine is a dynamic filter factory. Returns a true value or +throws a 'filter' exception on error. + +=head2 localise(\%vars) + +Clones the stash to create a context with localised variables. Returns a +reference to the newly cloned stash object which is also stored +internally. + + $stash = $context->localise(); + +=head2 delocalise() + +Restore the stash to its state prior to localisation. + + $stash = $context->delocalise(); + +=head2 visit(\%blocks) + +This method is called by Template::Document objects immediately before +they process their content. It is called to register any local BLOCK +definitions with the context object so that they may be subsequently +delivered on request. + +=head2 leave() + +Compliment to visit(), above. Called by Template::Document objects +immediately after they process their content. + +=head2 reset() + +Clears the local BLOCKS cache of any BLOCK definitions. Any initial set of +BLOCKS specified as a configuration item to the constructor will be reinstated. + +=head2 AUTOLOAD + +An AUTOLOAD method provides access to context configuration items. + + $stash = $context->stash(); + $tflag = $context->trim(); + $epflag = $context->eval_perl(); + ... + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.81, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Document|Template::Document>, L<Template::Exception|Template::Exception>, L<Template::Filters|Template::Filters>, L<Template::Plugins|Template::Plugins>, L<Template::Provider|Template::Provider>, L<Template::Service|Template::Service>, L<Template::Stash|Template::Stash> diff --git a/lib/Template/Directive.pm b/lib/Template/Directive.pm new file mode 100644 index 0000000..67982d3 --- /dev/null +++ b/lib/Template/Directive.pm @@ -0,0 +1,1004 @@ +#================================================================= -*-Perl-*- +# +# Template::Directive +# +# DESCRIPTION +# Factory module for constructing templates from Perl code. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# WARNING +# Much of this module is hairy, even furry in places. It needs +# a lot of tidying up and may even be moved into a different place +# altogether. The generator code is often inefficient, particulary in +# being very anal about pretty-printing the Perl code all neatly, but +# at the moment, that's still high priority for the sake of easier +# debugging. +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Directive.pm,v 2.17 2002/08/08 11:59:15 abw Exp $ +# +#============================================================================ + +package Template::Directive; + +require 5.004; + +use strict; +use Template::Base; +use Template::Constants; +use Template::Exception; + +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG $PRETTY $WHILE_MAX ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.17 $ =~ /(\d+)\.(\d+)/); + +$WHILE_MAX = 1000 unless defined $WHILE_MAX; +$PRETTY = 0 unless defined $PRETTY; +my $OUTPUT = '$output .= '; + + +sub _init { + my ($self, $config) = @_; + $self->{ NAMESPACE } = $config->{ NAMESPACE }; + return $self; +} + + +sub pad { + my ($text, $pad) = @_; + $pad = ' ' x ($pad * 4); + $text =~ s/^(?!#line)/$pad/gm; + $text; +} + +#======================================================================== +# FACTORY METHODS +# +# These methods are called by the parser to construct directive instances. +#======================================================================== + +#------------------------------------------------------------------------ +# template($block) +#------------------------------------------------------------------------ + +sub template { + my ($class, $block) = @_; + $block = pad($block, 2) if $PRETTY; + + return "sub { return '' }" unless $block =~ /\S/; + + return <<EOF; +sub { + my \$context = shift || die "template sub called without context\\n"; + my \$stash = \$context->stash; + my \$output = ''; + my \$error; + + eval { BLOCK: { +$block + } }; + if (\$@) { + \$error = \$context->catch(\$@, \\\$output); + die \$error unless \$error->type eq 'return'; + } + + return \$output; +} +EOF +} + + +#------------------------------------------------------------------------ +# anon_block($block) [% BLOCK %] ... [% END %] +#------------------------------------------------------------------------ + +sub anon_block { + my ($class, $block) = @_; + $block = pad($block, 2) if $PRETTY; + + return <<EOF; + +# BLOCK +$OUTPUT do { + my \$output = ''; + my \$error; + + eval { BLOCK: { +$block + } }; + if (\$@) { + \$error = \$context->catch(\$@, \\\$output); + die \$error unless \$error->type eq 'return'; + } + + \$output; +}; +EOF +} + + +#------------------------------------------------------------------------ +# block($blocktext) +#------------------------------------------------------------------------ + +sub block { + my ($class, $block) = @_; + return join("\n", @{ $block || [] }); +} + + +#------------------------------------------------------------------------ +# textblock($text) +#------------------------------------------------------------------------ + +sub textblock { + my ($class, $text) = @_; + return "$OUTPUT " . &text($class, $text) . ';'; +} + + +#------------------------------------------------------------------------ +# text($text) +#------------------------------------------------------------------------ + +sub text { + my ($class, $text) = @_; + for ($text) { + s/(["\$\@\\])/\\$1/g; + s/\n/\\n/g; + } + return '"' . $text . '"'; +} + + +#------------------------------------------------------------------------ +# quoted(\@items) "foo$bar" +#------------------------------------------------------------------------ + +sub quoted { + my ($class, $items) = @_; + return '' unless @$items; + return ("('' . " . $items->[0] . ')') if scalar @$items == 1; + return '(' . join(' . ', @$items) . ')'; +# my $r = '(' . join(' . ', @$items) . ' . "")'; +# print STDERR "[$r]\n"; +# return $r; +} + + +#------------------------------------------------------------------------ +# ident(\@ident) foo.bar(baz) +#------------------------------------------------------------------------ + +sub ident { + my ($class, $ident) = @_; + return "''" unless @$ident; + my $ns; + + # does the first element of the identifier have a NAMESPACE + # handler defined? + if (ref $class && @$ident > 2 && ($ns = $class->{ NAMESPACE })) { + my $key = $ident->[0]; + $key =~ s/^'(.+)'$/$1/s; + if ($ns = $ns->{ $key }) { + return $ns->ident($ident); + } + } + + if (scalar @$ident <= 2 && ! $ident->[1]) { + $ident = $ident->[0]; + } + else { + $ident = '[' . join(', ', @$ident) . ']'; + } + return "\$stash->get($ident)"; +} + +#------------------------------------------------------------------------ +# identref(\@ident) \foo.bar(baz) +#------------------------------------------------------------------------ + +sub identref { + my ($class, $ident) = @_; + return "''" unless @$ident; + if (scalar @$ident <= 2 && ! $ident->[1]) { + $ident = $ident->[0]; + } + else { + $ident = '[' . join(', ', @$ident) . ']'; + } + return "\$stash->getref($ident)"; +} + + +#------------------------------------------------------------------------ +# assign(\@ident, $value, $default) foo = bar +#------------------------------------------------------------------------ + +sub assign { + my ($class, $var, $val, $default) = @_; + + if (ref $var) { + if (scalar @$var == 2 && ! $var->[1]) { + $var = $var->[0]; + } + else { + $var = '[' . join(', ', @$var) . ']'; + } + } + $val .= ', 1' if $default; + return "\$stash->set($var, $val)"; +} + + +#------------------------------------------------------------------------ +# args(\@args) foo, bar, baz = qux +#------------------------------------------------------------------------ + +sub args { + my ($class, $args) = @_; + my $hash = shift @$args; + push(@$args, '{ ' . join(', ', @$hash) . ' }') + if @$hash; + + return '0' unless @$args; + return '[ ' . join(', ', @$args) . ' ]'; +} + +#------------------------------------------------------------------------ +# filenames(\@names) +#------------------------------------------------------------------------ + +sub filenames { + my ($class, $names) = @_; + if (@$names > 1) { + $names = '[ ' . join(', ', @$names) . ' ]'; + } + else { + $names = shift @$names; + } + return $names; +} + + +#------------------------------------------------------------------------ +# get($expr) [% foo %] +#------------------------------------------------------------------------ + +sub get { + my ($class, $expr) = @_; + return "$OUTPUT $expr;"; +} + + +#------------------------------------------------------------------------ +# call($expr) [% CALL bar %] +#------------------------------------------------------------------------ + +sub call { + my ($class, $expr) = @_; + $expr .= ';'; + return $expr; +} + + +#------------------------------------------------------------------------ +# set(\@setlist) [% foo = bar, baz = qux %] +#------------------------------------------------------------------------ + +sub set { + my ($class, $setlist) = @_; + my $output; + while (my ($var, $val) = splice(@$setlist, 0, 2)) { + $output .= &assign($class, $var, $val) . ";\n"; + } + chomp $output; + return $output; +} + + +#------------------------------------------------------------------------ +# default(\@setlist) [% DEFAULT foo = bar, baz = qux %] +#------------------------------------------------------------------------ + +sub default { + my ($class, $setlist) = @_; + my $output; + while (my ($var, $val) = splice(@$setlist, 0, 2)) { + $output .= &assign($class, $var, $val, 1) . ";\n"; + } + chomp $output; + return $output; +} + + +#------------------------------------------------------------------------ +# insert(\@nameargs) [% INSERT file %] +# # => [ [ $file, ... ], \@args ] +#------------------------------------------------------------------------ + +sub insert { + my ($class, $nameargs) = @_; + my ($file, $args) = @$nameargs; + $file = $class->filenames($file); + return "$OUTPUT \$context->insert($file);"; +} + + +#------------------------------------------------------------------------ +# include(\@nameargs) [% INCLUDE template foo = bar %] +# # => [ [ $file, ... ], \@args ] +#------------------------------------------------------------------------ + +sub include { + my ($class, $nameargs) = @_; + my ($file, $args) = @$nameargs; + my $hash = shift @$args; + $file = $class->filenames($file); + $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + return "$OUTPUT \$context->include($file);"; +} + + +#------------------------------------------------------------------------ +# process(\@nameargs) [% PROCESS template foo = bar %] +# # => [ [ $file, ... ], \@args ] +#------------------------------------------------------------------------ + +sub process { + my ($class, $nameargs) = @_; + my ($file, $args) = @$nameargs; + my $hash = shift @$args; + $file = $class->filenames($file); + $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + return "$OUTPUT \$context->process($file);"; +} + + +#------------------------------------------------------------------------ +# if($expr, $block, $else) [% IF foo < bar %] +# ... +# [% ELSE %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub if { + my ($class, $expr, $block, $else) = @_; + my @else = $else ? @$else : (); + $else = pop @else; + $block = pad($block, 1) if $PRETTY; + + my $output = "if ($expr) {\n$block\n}\n"; + + foreach my $elsif (@else) { + ($expr, $block) = @$elsif; + $block = pad($block, 1) if $PRETTY; + $output .= "elsif ($expr) {\n$block\n}\n"; + } + if (defined $else) { + $else = pad($else, 1) if $PRETTY; + $output .= "else {\n$else\n}\n"; + } + + return $output; +} + + +#------------------------------------------------------------------------ +# foreach($target, $list, $args, $block) [% FOREACH x = [ foo bar ] %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub foreach { + my ($class, $target, $list, $args, $block) = @_; + $args = shift @$args; + $args = @$args ? ', { ' . join(', ', @$args) . ' }' : ''; + + my ($loop_save, $loop_set, $loop_restore, $setiter); + if ($target) { + $loop_save = 'eval { $oldloop = ' . &ident($class, ["'loop'"]) . ' }'; + $loop_set = "\$stash->{'$target'} = \$value"; + $loop_restore = "\$stash->set('loop', \$oldloop)"; + } + else { + $loop_save = '$stash = $context->localise()'; +# $loop_set = "\$stash->set('import', \$value) " +# . "if ref \$value eq 'HASH'"; + $loop_set = "\$stash->get(['import', [\$value]]) " + . "if ref \$value eq 'HASH'"; + $loop_restore = '$stash = $context->delocalise()'; + } + $block = pad($block, 3) if $PRETTY; + + return <<EOF; + +# FOREACH +do { + my (\$value, \$error, \$oldloop); + my \$list = $list; + + unless (UNIVERSAL::isa(\$list, 'Template::Iterator')) { + \$list = Template::Config->iterator(\$list) + || die \$Template::Config::ERROR, "\\n"; + } + + (\$value, \$error) = \$list->get_first(); + $loop_save; + \$stash->set('loop', \$list); + eval { +LOOP: while (! \$error) { + $loop_set; +$block; + (\$value, \$error) = \$list->get_next(); + } + }; + $loop_restore; + die \$@ if \$@; + \$error = 0 if \$error && \$error eq Template::Constants::STATUS_DONE; + die \$error if \$error; +}; +EOF +} + +#------------------------------------------------------------------------ +# next() [% NEXT %] +# +# Next iteration of a FOREACH loop (experimental) +#------------------------------------------------------------------------ + +sub next { + return <<EOF; +(\$value, \$error) = \$list->get_next(); +next LOOP; +EOF +} + + +#------------------------------------------------------------------------ +# wrapper(\@nameargs, $block) [% WRAPPER template foo = bar %] +# # => [ [$file,...], \@args ] +#------------------------------------------------------------------------ + +sub wrapper { + my ($class, $nameargs, $block) = @_; + my ($file, $args) = @$nameargs; + my $hash = shift @$args; + + local $" = ', '; +# print STDERR "wrapper([@$file], { @$hash })\n"; + + return $class->multi_wrapper($file, $hash, $block) + if @$file > 1; + $file = shift @$file; + + $block = pad($block, 1) if $PRETTY; + push(@$hash, "'content'", '$output'); + $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + + return <<EOF; + +# WRAPPER +$OUTPUT do { + my \$output = ''; +$block + \$context->include($file); +}; +EOF +} + + +sub multi_wrapper { + my ($class, $file, $hash, $block) = @_; + $block = pad($block, 1) if $PRETTY; + + push(@$hash, "'content'", '$output'); + $hash = @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + + $file = join(', ', reverse @$file); +# print STDERR "multi wrapper: $file\n"; + + return <<EOF; + +# WRAPPER +$OUTPUT do { + my \$output = ''; +$block + foreach ($file) { + \$output = \$context->include(\$_$hash); + } + \$output; +}; +EOF +} + + +#------------------------------------------------------------------------ +# while($expr, $block) [% WHILE x < 10 %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub while { + my ($class, $expr, $block) = @_; + $block = pad($block, 2) if $PRETTY; + + return <<EOF; + +# WHILE +do { + my \$failsafe = $WHILE_MAX; +LOOP: + while (--\$failsafe && ($expr)) { +$block + } + die "WHILE loop terminated (> $WHILE_MAX iterations)\\n" + unless \$failsafe; +}; +EOF +} + + +#------------------------------------------------------------------------ +# switch($expr, \@case) [% SWITCH %] +# [% CASE foo %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub switch { + my ($class, $expr, $case) = @_; + my @case = @$case; + my ($match, $block, $default); + my $caseblock = ''; + + $default = pop @case; + + foreach $case (@case) { + $match = $case->[0]; + $block = $case->[1]; + $block = pad($block, 1) if $PRETTY; + $caseblock .= <<EOF; +\$match = $match; +\$match = [ \$match ] unless ref \$match eq 'ARRAY'; +if (grep(/^\$result\$/, \@\$match)) { +$block + last SWITCH; +} +EOF + } + + $caseblock .= $default + if defined $default; + $caseblock = pad($caseblock, 2) if $PRETTY; + +return <<EOF; + +# SWITCH +do { + my \$result = $expr; + my \$match; + SWITCH: { +$caseblock + } +}; +EOF +} + + +#------------------------------------------------------------------------ +# try($block, \@catch) [% TRY %] +# ... +# [% CATCH %] +# ... +# [% END %] +#------------------------------------------------------------------------ + +sub try { + my ($class, $block, $catch) = @_; + my @catch = @$catch; + my ($match, $mblock, $default, $final, $n); + my $catchblock = ''; + my $handlers = []; + + $block = pad($block, 2) if $PRETTY; + $final = pop @catch; + $final = "# FINAL\n" . ($final ? "$final\n" : '') + . 'die $error if $error;' . "\n" . '$output;'; + $final = pad($final, 1) if $PRETTY; + + $n = 0; + foreach $catch (@catch) { + $match = $catch->[0] || do { + $default ||= $catch->[1]; + next; + }; + $mblock = $catch->[1]; + $mblock = pad($mblock, 1) if $PRETTY; + push(@$handlers, "'$match'"); + $catchblock .= $n++ + ? "elsif (\$handler eq '$match') {\n$mblock\n}\n" + : "if (\$handler eq '$match') {\n$mblock\n}\n"; + } + $catchblock .= "\$error = 0;"; + $catchblock = pad($catchblock, 3) if $PRETTY; + if ($default) { + $default = pad($default, 1) if $PRETTY; + $default = "else {\n # DEFAULT\n$default\n \$error = '';\n}"; + } + else { + $default = '# NO DEFAULT'; + } + $default = pad($default, 2) if $PRETTY; + + $handlers = join(', ', @$handlers); +return <<EOF; + +# TRY +$OUTPUT do { + my \$output = ''; + my (\$error, \$handler); + eval { +$block + }; + if (\$@) { + \$error = \$context->catch(\$@, \\\$output); + die \$error if \$error->type =~ /^return|stop\$/; + \$stash->set('error', \$error); + \$stash->set('e', \$error); + if (defined (\$handler = \$error->select_handler($handlers))) { +$catchblock + } +$default + } +$final +}; +EOF +} + + +#------------------------------------------------------------------------ +# throw(\@nameargs) [% THROW foo "bar error" %] +# # => [ [$type], \@args ] +#------------------------------------------------------------------------ + +sub throw { + my ($class, $nameargs) = @_; + my ($type, $args) = @$nameargs; + my $hash = shift(@$args); + my $info = shift(@$args); + $type = shift @$type; # uses same parser production as INCLUDE + # etc., which allow multiple names + # e.g. INCLUDE foo+bar+baz + + if (! $info) { + $args = "$type, undef"; + } + elsif (@$hash || @$args) { + local $" = ', '; + my $i = 0; + $args = "$type, { args => [ " + . join(', ', $info, @$args) + . ' ], ' + . join(', ', + (map { "'" . $i++ . "' => $_" } ($info, @$args)), + @$hash) + . ' }'; + } + else { + $args = "$type, $info"; + } + + return "\$context->throw($args, \\\$output);"; +} + + +#------------------------------------------------------------------------ +# clear() [% CLEAR %] +# +# NOTE: this is redundant, being hard-coded (for now) into Parser.yp +#------------------------------------------------------------------------ + +sub clear { + return "\$output = '';"; +} + +#------------------------------------------------------------------------ +# break() [% BREAK %] +# +# NOTE: this is redundant, being hard-coded (for now) into Parser.yp +#------------------------------------------------------------------------ + +sub break { + return 'last LOOP;'; +} + +#------------------------------------------------------------------------ +# return() [% RETURN %] +#------------------------------------------------------------------------ + +sub return { + return "\$context->throw('return', '', \\\$output);"; +} + +#------------------------------------------------------------------------ +# stop() [% STOP %] +#------------------------------------------------------------------------ + +sub stop { + return "\$context->throw('stop', '', \\\$output);"; +} + + +#------------------------------------------------------------------------ +# use(\@lnameargs) [% USE alias = plugin(args) %] +# # => [ [$file, ...], \@args, $alias ] +#------------------------------------------------------------------------ + +sub use { + my ($class, $lnameargs) = @_; + my ($file, $args, $alias) = @$lnameargs; + $file = shift @$file; # same production rule as INCLUDE + $alias ||= $file; + $args = &args($class, $args); + $file .= ", $args" if $args; +# my $set = &assign($class, $alias, '$plugin'); + return "# USE\n" + . "\$stash->set($alias,\n" + . " \$context->plugin($file));"; +} + +#------------------------------------------------------------------------ +# view(\@nameargs, $block) [% VIEW name args %] +# # => [ [$file, ... ], \@args ] +#------------------------------------------------------------------------ + +sub view { + my ($class, $nameargs, $block, $defblocks) = @_; + my ($name, $args) = @$nameargs; + my $hash = shift @$args; + $name = shift @$name; # same production rule as INCLUDE + $block = pad($block, 1) if $PRETTY; + + if (%$defblocks) { + $defblocks = join(",\n", map { "'$_' => $defblocks->{ $_ }" } + keys %$defblocks); + $defblocks = pad($defblocks, 1) if $PRETTY; + $defblocks = "{\n$defblocks\n}"; + push(@$hash, "'blocks'", $defblocks); + } + $hash = @$hash ? '{ ' . join(', ', @$hash) . ' }' : ''; + + return <<EOF; +# VIEW +do { + my \$output = ''; + my \$oldv = \$stash->get('view'); + my \$view = \$context->view($hash); + \$stash->set($name, \$view); + \$stash->set('view', \$view); + +$block + + \$stash->set('view', \$oldv); + \$view->seal(); + \$output; +}; +EOF +} + + +#------------------------------------------------------------------------ +# perl($block) +#------------------------------------------------------------------------ + +sub perl { + my ($class, $block) = @_; + $block = pad($block, 1) if $PRETTY; + + return <<EOF; + +# PERL +\$context->throw('perl', 'EVAL_PERL not set') + unless \$context->eval_perl(); + +$OUTPUT do { + my \$output = "package Template::Perl;\\n"; + +$block + + local(\$Template::Perl::context) = \$context; + local(\$Template::Perl::stash) = \$stash; + + my \$result = ''; + tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$result; + my \$save_stdout = select *Template::Perl::PERLOUT; + + eval \$output; + select \$save_stdout; + \$context->throw(\$@) if \$@; + \$result; +}; +EOF +} + + +#------------------------------------------------------------------------ +# no_perl() +#------------------------------------------------------------------------ + +sub no_perl { + my $class = shift; + return "\$context->throw('perl', 'EVAL_PERL not set');"; +} + + +#------------------------------------------------------------------------ +# rawperl($block) +# +# NOTE: perhaps test context EVAL_PERL switch at compile time rather than +# runtime? +#------------------------------------------------------------------------ + +sub rawperl { + my ($class, $block, $line) = @_; + for ($block) { + s/^\n+//; + s/\n+$//; + } + $block = pad($block, 1) if $PRETTY; + $line = $line ? " (starting line $line)" : ''; + + return <<EOF; +# RAWPERL +#line 1 "RAWPERL block$line" +$block +EOF +} + + + +#------------------------------------------------------------------------ +# filter() +#------------------------------------------------------------------------ + +sub filter { + my ($class, $lnameargs, $block) = @_; + my ($name, $args, $alias) = @$lnameargs; + $name = shift @$name; + $args = &args($class, $args); + $args = $args ? "$args, $alias" : ", undef, $alias" + if $alias; + $name .= ", $args" if $args; + $block = pad($block, 1) if $PRETTY; + + return <<EOF; + +# FILTER +$OUTPUT do { + my \$output = ''; + my \$filter = \$context->filter($name) + || \$context->throw(\$context->error); + +$block + + &\$filter(\$output); +}; +EOF +} + + +#------------------------------------------------------------------------ +# capture($name, $block) +#------------------------------------------------------------------------ + +sub capture { + my ($class, $name, $block) = @_; + + if (ref $name) { + if (scalar @$name == 2 && ! $name->[1]) { + $name = $name->[0]; + } + else { + $name = '[' . join(', ', @$name) . ']'; + } + } + $block = pad($block, 1) if $PRETTY; + + return <<EOF; + +# CAPTURE +\$stash->set($name, do { + my \$output = ''; +$block + \$output; +}); +EOF + +} + + +#------------------------------------------------------------------------ +# macro($name, $block, \@args) +#------------------------------------------------------------------------ + +sub macro { + my ($class, $ident, $block, $args) = @_; + $block = pad($block, 2) if $PRETTY; + + if ($args) { + my $nargs = scalar @$args; + $args = join(', ', map { "'$_'" } @$args); + $args = $nargs > 1 + ? "\@args{ $args } = splice(\@_, 0, $nargs)" + : "\$args{ $args } = shift"; + + return <<EOF; + +# MACRO +\$stash->set('$ident', sub { + my \$output = ''; + my (%args, \$params); + $args; + \$params = shift; + \$params = { } unless ref(\$params) eq 'HASH'; + \$params = { \%args, %\$params }; + + my \$stash = \$context->localise(\$params); + eval { +$block + }; + \$stash = \$context->delocalise(); + die \$@ if \$@; + return \$output; +}); +EOF + + } + else { + return <<EOF; + +# MACRO +\$stash->set('$ident', sub { + my \$params = \$_[0] if ref(\$_[0]) eq 'HASH'; + my \$output = ''; + + my \$stash = \$context->localise(\$params); + eval { +$block + }; + \$stash = \$context->delocalise(); + die \$@ if \$@; + return \$output; +}); +EOF + } +} + + +sub debug { + my ($class, $nameargs) = @_; + my ($file, $args) = @$nameargs; + my $hash = shift @$args; + $args = join(', ', @$file, @$args); + $args .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; + return "$OUTPUT \$context->debugging($args); ## DEBUG ##"; +} + + +1; + +__END__ + diff --git a/lib/Template/Document.pm b/lib/Template/Document.pm new file mode 100644 index 0000000..9e01548 --- /dev/null +++ b/lib/Template/Document.pm @@ -0,0 +1,482 @@ +##============================================================= -*-Perl-*- +# +# Template::Document +# +# DESCRIPTION +# Module defining a class of objects which encapsulate compiled +# templates, storing additional block definitions and metadata +# as well as the compiled Perl sub-routine representing the main +# template content. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Document.pm,v 2.65 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Document; + +require 5.004; + +use strict; +use vars qw( $VERSION $ERROR $COMPERR $DEBUG $AUTOLOAD ); +use base qw( Template::Base ); +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.65 $ =~ /(\d+)\.(\d+)/); + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%document) +# +# Creates a new self-contained Template::Document object which +# encapsulates a compiled Perl sub-routine, $block, any additional +# BLOCKs defined within the document ($defblocks, also Perl sub-routines) +# and additional $metadata about the document. +#------------------------------------------------------------------------ + +sub new { + my ($class, $doc) = @_; + my ($block, $defblocks, $metadata) = @$doc{ qw( BLOCK DEFBLOCKS METADATA ) }; + $defblocks ||= { }; + $metadata ||= { }; + + # evaluate Perl code in $block to create sub-routine reference if necessary + unless (ref $block) { + local $SIG{__WARN__} = \&catch_warnings; + $COMPERR = ''; + + # DON'T LOOK NOW! - blindly untainting can make you go blind! + $block =~ /(.*)/s; + $block = $1; + + $block = eval $block; +# $COMPERR .= "[$@]" if $@; +# return $class->error($COMPERR) + return $class->error($@) + unless defined $block; + } + + # same for any additional BLOCK definitions + @$defblocks{ keys %$defblocks } = + # MORE BLIND UNTAINTING - turn away if you're squeamish + map { + ref($_) + ? $_ + : ( /(.*)/s && eval($1) or return $class->error($@) ) + } values %$defblocks; + + bless { + %$metadata, + _BLOCK => $block, + _DEFBLOCKS => $defblocks, + _HOT => 0, + }, $class; +} + + +#------------------------------------------------------------------------ +# block() +# +# Returns a reference to the internal sub-routine reference, _BLOCK, +# that constitutes the main document template. +#------------------------------------------------------------------------ + +sub block { + return $_[0]->{ _BLOCK }; +} + + +#------------------------------------------------------------------------ +# blocks() +# +# Returns a reference to a hash array containing any BLOCK definitions +# from the template. The hash keys are the BLOCK nameand the values +# are references to Template::Document objects. Returns 0 (# an empty hash) +# if no blocks are defined. +#------------------------------------------------------------------------ + +sub blocks { + return $_[0]->{ _DEFBLOCKS }; +} + + +#------------------------------------------------------------------------ +# process($context) +# +# Process the document in a particular context. Checks for recursion, +# registers the document with the context via visit(), processes itself, +# and then unwinds with a large gin and tonic. +#------------------------------------------------------------------------ + +sub process { + my ($self, $context) = @_; + my $defblocks = $self->{ _DEFBLOCKS }; + my $output; + + + # check we're not already visiting this template + return $context->throw(Template::Constants::ERROR_FILE, + "recursion into '$self->{ name }'") + if $self->{ _HOT } && ! $context->{ RECURSION }; ## RETURN ## + + $context->visit($defblocks); + $self->{ _HOT } = 1; + eval { + my $block = $self->{ _BLOCK }; + $output = &$block($context); + }; + $self->{ _HOT } = 0; + $context->leave(); + + die $context->catch($@) + if $@; + + return $output; +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# Provides pseudo-methods for read-only access to various internal +# members. +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; +# my ($pkg, $file, $line) = caller(); +# print STDERR "called $self->AUTOLOAD($method) from $file line $line\n"; + return $self->{ $method }; +} + + +#======================================================================== +# ----- PRIVATE METHODS ----- +#======================================================================== + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $dblks; + my $output = "$self : $self->{ name }\n"; + + $output .= "BLOCK: $self->{ _BLOCK }\nDEFBLOCKS:\n"; + + if ($dblks = $self->{ _DEFBLOCKS }) { + foreach my $b (keys %$dblks) { + $output .= " $b: $dblks->{ $b }\n"; + } + } + + return $output; +} + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# as_perl($content) +# +# This method expects a reference to a hash passed as the first argument +# containing 3 items: +# METADATA # a hash of template metadata +# BLOCK # string containing Perl sub definition for main block +# DEFBLOCKS # hash containing further subs for addional BLOCK defs +# It returns a string containing Perl code which, when evaluated and +# executed, will instantiate a new Template::Document object with the +# above data. On error, it returns undef with an appropriate error +# message set in $ERROR. +#------------------------------------------------------------------------ + +sub as_perl { + my ($class, $content) = @_; + my ($block, $defblocks, $metadata) = @$content{ qw( BLOCK DEFBLOCKS METADATA ) }; + + $block =~ s/\n/\n /g; + $block =~ s/\s+$//; + + $defblocks = join('', map { + my $code = $defblocks->{ $_ }; + $code =~ s/\n/\n /g; + $code =~ s/\s*$//; + " '$_' => $code,\n"; + } keys %$defblocks); + $defblocks =~ s/\s+$//; + + $metadata = join('', map { + my $x = $metadata->{ $_ }; + $x =~ s/(['\\])/\\$1/g; + " '$_' => '$x',\n"; + } keys %$metadata); + $metadata =~ s/\s+$//; + + return <<EOF +#------------------------------------------------------------------------ +# Compiled template generated by the Template Toolkit version $Template::VERSION +#------------------------------------------------------------------------ + +$class->new({ + METADATA => { +$metadata + }, + BLOCK => $block, + DEFBLOCKS => { +$defblocks + }, +}); +EOF +} + + +#------------------------------------------------------------------------ +# write_perl_file($filename, \%content) +# +# This method calls as_perl() to generate the Perl code to represent a +# compiled template with the content passed as the second argument. +# It then writes this to the file denoted by the first argument. +# +# Returns 1 on success. On error, sets the $ERROR package variable +# to contain an error message and returns undef. +#------------------------------------------------------------------------ + +sub write_perl_file { + my ($class, $file, $content) = @_; + my ($fh, $tmpfile); + + return $class->error("invalid filename: $file") + unless $file =~ /^(.+)$/s; + + eval { + require File::Temp; + require File::Basename; + ($fh, $tmpfile) = File::Temp::tempfile( + DIR => File::Basename::dirname($file) + ); + print $fh $class->as_perl($content) || die $!; + close($fh); + }; + return $class->error($@) if $@; + return rename($tmpfile, $file) + || $class->error($!); +} + + +#------------------------------------------------------------------------ +# catch_warnings($msg) +# +# Installed as +#------------------------------------------------------------------------ + +sub catch_warnings { + $COMPERR .= join('', @_); +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Document - Compiled template document object + +=head1 SYNOPSIS + + use Template::Document; + + $doc = Template::Document->new({ + BLOCK => sub { # some perl code; return $some_text }, + DEFBLOCKS => { + header => sub { # more perl code; return $some_text }, + footer => sub { # blah blah blah; return $some_text }, + }, + METADATA => { + author => 'Andy Wardley', + version => 3.14, + } + }) || die $Template::Document::ERROR; + + print $doc->process($context); + +=head1 DESCRIPTION + +This module defines an object class whose instances represent compiled +template documents. The Template::Parser module creates a +Template::Document instance to encapsulate a template as it is compiled +into Perl code. + +The constructor method, new(), expects a reference to a hash array +containing the BLOCK, DEFBLOCKS and METADATA items. The BLOCK item +should contain a reference to a Perl subroutine or a textual +representation of Perl code, as generated by the Template::Parser +module, which is then evaluated into a subroutine reference using +eval(). The DEFLOCKS item should reference a hash array containing +further named BLOCKs which may be defined in the template. The keys +represent BLOCK names and the values should be subroutine references +or text strings of Perl code as per the main BLOCK item. The METADATA +item should reference a hash array of metadata items relevant to the +document. + +The process() method can then be called on the instantiated +Template::Document object, passing a reference to a Template::Content +object as the first parameter. This will install any locally defined +blocks (DEFBLOCKS) in the the contexts() BLOCKS cache (via a call to +visit()) so that they may be subsequently resolved by the context. The +main BLOCK subroutine is then executed, passing the context reference +on as a parameter. The text returned from the template subroutine is +then returned by the process() method, after calling the context leave() +method to permit cleanup and de-registration of named BLOCKS previously +installed. + +An AUTOLOAD method provides access to the METADATA items for the document. +The Template::Service module installs a reference to the main +Template::Document object in the stash as the 'template' variable. +This allows metadata items to be accessed from within templates, +including PRE_PROCESS templates. + +header: + + <html> + <head> + <title>[% template.title %] + </head> + ... + +Template::Document objects are usually created by the Template::Parser +but can be manually instantiated or sub-classed to provide custom +template components. + +=head1 METHODS + +=head2 new(\%config) + +Constructor method which accept a reference to a hash array containing the +structure as shown in this example: + + $doc = Template::Document->new({ + BLOCK => sub { # some perl code; return $some_text }, + DEFBLOCKS => { + header => sub { # more perl code; return $some_text }, + footer => sub { # blah blah blah; return $some_text }, + }, + METADATA => { + author => 'Andy Wardley', + version => 3.14, + } + }) || die $Template::Document::ERROR; + +BLOCK and DEFBLOCKS items may be expressed as references to Perl subroutines +or as text strings containing Perl subroutine definitions, as is generated +by the Template::Parser module. These are evaluated into subroutine references +using eval(). + +Returns a new Template::Document object or undef on error. The error() class +method can be called, or the $ERROR package variable inspected to retrieve +the relevant error message. + +=head2 process($context) + +Main processing routine for the compiled template document. A reference to +a Template::Context object should be passed as the first parameter. The +method installs any locally defined blocks via a call to the context +visit() method, processes it's own template, passing the context reference +by parameter and then calls leave() in the context to allow cleanup. + + print $doc->process($context); + +Returns a text string representing the generated output for the template. +Errors are thrown via die(). + +=head2 block() + +Returns a reference to the main BLOCK subroutine. + +=head2 blocks() + +Returns a reference to the hash array of named DEFBLOCKS subroutines. + +=head2 AUTOLOAD + +An autoload method returns METADATA items. + + print $doc->author(); + +=head1 PACKAGE SUB-ROUTINES + +=head2 write_perl_file(\%config) + +This package subroutine is provided to effect persistance of compiled +templates. If the COMPILE_EXT option (to indicate a file extension +for saving compiled templates) then the Template::Parser module calls +this subroutine before calling the new() constructor. At this stage, +the parser has a representation of the template as text strings +containing Perl code. We can write that to a file, enclosed in a +small wrapper which will allow us to susequently require() the file +and have Perl parse and compile it into a Template::Document. Thus we +have persistance of compiled templates. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.65, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Parser|Template::Parser> diff --git a/lib/Template/Exception.pm b/lib/Template/Exception.pm new file mode 100644 index 0000000..cf60cb3 --- /dev/null +++ b/lib/Template/Exception.pm @@ -0,0 +1,244 @@ +#============================================================= -*-Perl-*- +# +# Template::Exception +# +# DESCRIPTION +# Module implementing a generic exception class used for error handling +# in the Template Toolkit. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#------------------------------------------------------------------------ +# +# $Id: Exception.pm,v 2.59 2003/04/24 09:14:38 abw Exp $ +# +#======================================================================== + + +package Template::Exception; + +require 5.005; + +use strict; +use vars qw( $VERSION ); + +use constant TYPE => 0; +use constant INFO => 1; +use constant TEXT => 2; +use overload q|""| => "as_string", fallback => 1; + + +$VERSION = sprintf("%d.%02d", q$Revision: 2.59 $ =~ /(\d+)\.(\d+)/); + + +#------------------------------------------------------------------------ +# new($type, $info, \$text) +# +# Constructor method used to instantiate a new Template::Exception +# object. The first parameter should contain the exception type. This +# can be any arbitrary string of the caller's choice to represent a +# specific exception. The second parameter should contain any +# information (i.e. error message or data reference) relevant to the +# specific exception event. The third optional parameter may be a +# reference to a scalar containing output text from the template +# block up to the point where the exception was thrown. +#------------------------------------------------------------------------ + +sub new { + my ($class, $type, $info, $textref) = @_; + bless [ $type, $info, $textref ], $class; +} + + +#------------------------------------------------------------------------ +# type() +# info() +# type_info() +# +# Accessor methods to return the internal TYPE and INFO fields. +#------------------------------------------------------------------------ + +sub type { + $_[0]->[ TYPE ]; +} + +sub info { + $_[0]->[ INFO ]; +} + +sub type_info { + my $self = shift; + @$self[ TYPE, INFO ]; +} + +#------------------------------------------------------------------------ +# text() +# text(\$pretext) +# +# Method to return the text referenced by the TEXT member. A text +# reference may be passed as a parameter to supercede the existing +# member. The existing text is added to the *end* of the new text +# before being stored. This facility is provided for template blocks +# to gracefully de-nest when an exception occurs and allows them to +# reconstruct their output in the correct order. +#------------------------------------------------------------------------ + +sub text { + my ($self, $newtextref) = @_; + my $textref = $self->[ TEXT ]; + + if ($newtextref) { + $$newtextref .= $$textref if $textref && $textref ne $newtextref; + $self->[ TEXT ] = $newtextref; + return ''; + + } + elsif ($textref) { + return $$textref; + } + else { + return ''; + } +} + + +#------------------------------------------------------------------------ +# as_string() +# +# Accessor method to return a string indicating the exception type and +# information. +#------------------------------------------------------------------------ + +sub as_string { + my $self = shift; + return $self->[ TYPE ] . ' error - ' . $self->[ INFO ]; +} + + +#------------------------------------------------------------------------ +# select_handler(@types) +# +# Selects the most appropriate handler for the exception TYPE, from +# the list of types passed in as parameters. The method returns the +# item which is an exact match for TYPE or the closest, more +# generic handler (e.g. foo being more generic than foo.bar, etc.) +#------------------------------------------------------------------------ + +sub select_handler { + my ($self, @options) = @_; + my $type = $self->[ TYPE ]; + my %hlut; + @hlut{ @options } = (1) x @options; + + while ($type) { + return $type if $hlut{ $type }; + + # strip .element from the end of the exception type to find a + # more generic handler + $type =~ s/\.?[^\.]*$//; + } + return undef; +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Exception - Exception handling class module + +=head1 SYNOPSIS + + use Template::Exception; + + my $exception = Template::Exception->new($type, $info); + $type = $exception->type; + $info = $exception->info; + ($type, $info) = $exception->type_info; + + print $exception->as_string(); + + $handler = $exception->select_handler(\@candidates); + +=head1 DESCRIPTION + +The Template::Exception module defines an object class for +representing exceptions within the template processing life cycle. +Exceptions can be raised by modules within the Template Toolkit, or +can be generated and returned by user code bound to template +variables. + + +Exceptions can be raised in a template using the THROW directive, + + [% THROW user.login 'no user id: please login' %] + +or by calling the throw() method on the current Template::Context object, + + $context->throw('user.passwd', 'Incorrect Password'); + $context->throw('Incorrect Password'); # type 'undef' + +or from Perl code by calling die() with a Template::Exception object, + + die (Template::Exception->new('user.denied', 'Invalid User ID')); + +or by simply calling die() with an error string. This is +automagically caught and converted to an exception of 'undef' +type which can then be handled in the usual way. + + die "I'm sorry Dave, I can't do that"; + + + +Each exception is defined by its type and a information component +(e.g. error message). The type can be any identifying string and may +contain dotted components (e.g. 'foo', 'foo.bar', 'foo.bar.baz'). +Exception types are considered to be hierarchical such that 'foo.bar' +would be a specific type of the more general 'foo' type. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.59, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Context|Template::Context> diff --git a/lib/Template/Filters.pm b/lib/Template/Filters.pm new file mode 100644 index 0000000..8667c6a --- /dev/null +++ b/lib/Template/Filters.pm @@ -0,0 +1,1438 @@ +#============================================================= -*-Perl-*- +# +# Template::Filters +# +# DESCRIPTION +# Defines filter plugins as used by the FILTER directive. +# +# AUTHORS +# Andy Wardley <abw@kfs.org>, with a number of filters contributed +# by Leslie Michael Orchard <deus_x@nijacode.com> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Filters.pm,v 2.72 2003/07/01 12:43:55 darren Exp $ +# +#============================================================================ + +package Template::Filters; + +require 5.004; + +use strict; +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG $FILTERS $URI_ESCAPES $PLUGIN_FILTER ); +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.72 $ =~ /(\d+)\.(\d+)/); + + +#------------------------------------------------------------------------ +# standard filters, defined in one of the following forms: +# name => \&static_filter +# name => [ \&subref, $is_dynamic ] +# If the $is_dynamic flag is set then the sub-routine reference +# is called to create a new filter each time it is requested; if +# not set, then it is a single, static sub-routine which is returned +# for every filter request for that name. +#------------------------------------------------------------------------ + +$FILTERS = { + # static filters + 'html' => \&html_filter, + 'html_para' => \&html_paragraph, + 'html_break' => \&html_para_break, + 'html_para_break' => \&html_para_break, + 'html_line_break' => \&html_line_break, + 'uri' => \&uri_filter, + 'upper' => sub { uc $_[0] }, + 'lower' => sub { lc $_[0] }, + 'ucfirst' => sub { ucfirst $_[0] }, + 'lcfirst' => sub { lcfirst $_[0] }, + 'stderr' => sub { print STDERR @_; return '' }, + 'trim' => sub { for ($_[0]) { s/^\s+//; s/\s+$// }; $_[0] }, + 'null' => sub { return '' }, + 'collapse' => sub { for ($_[0]) { s/^\s+//; s/\s+$//; s/\s+/ /g }; + $_[0] }, + + # dynamic filters + 'html_entity' => [ \&html_entity_filter_factory, 1 ], + 'indent' => [ \&indent_filter_factory, 1 ], + 'format' => [ \&format_filter_factory, 1 ], + 'truncate' => [ \&truncate_filter_factory, 1 ], + 'repeat' => [ \&repeat_filter_factory, 1 ], + 'replace' => [ \&replace_filter_factory, 1 ], + 'remove' => [ \&remove_filter_factory, 1 ], + 'eval' => [ \&eval_filter_factory, 1 ], + 'evaltt' => [ \&eval_filter_factory, 1 ], # alias + 'perl' => [ \&perl_filter_factory, 1 ], + 'evalperl' => [ \&perl_filter_factory, 1 ], # alias + 'redirect' => [ \&redirect_filter_factory, 1 ], + 'file' => [ \&redirect_filter_factory, 1 ], # alias + 'stdout' => [ \&stdout_filter_factory, 1 ], + 'latex' => [ \&latex_filter_factory, 1 ], +}; + +# name of module implementing plugin filters +$PLUGIN_FILTER = 'Template::Plugin::Filter'; + + +#======================================================================== +# -- PUBLIC METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# fetch($name, \@args, $context) +# +# Attempts to instantiate or return a reference to a filter sub-routine +# named by the first parameter, $name, with additional constructor +# arguments passed by reference to a list as the second parameter, +# $args. A reference to the calling Template::Context object is +# passed as the third paramter. +# +# Returns a reference to a filter sub-routine or a pair of values +# (undef, STATUS_DECLINED) or ($error, STATUS_ERROR) to decline to +# deliver the filter or to indicate an error. +#------------------------------------------------------------------------ + +sub fetch { + my ($self, $name, $args, $context) = @_; + my ($factory, $is_dynamic, $filter, $error); + + $self->debug("fetch($name, ", + defined $args ? ('[ ', join(', ', @$args), ' ]') : '<no args>', ', ', + defined $context ? $context : '<no context>', + ')') if $self->{ DEBUG }; + + # allow $name to be specified as a reference to + # a plugin filter object; any other ref is + # assumed to be a coderef and hence already a filter; + # non-refs are assumed to be regular name lookups + + if (ref $name) { + if (UNIVERSAL::isa($name, $PLUGIN_FILTER)) { + $factory = $name->factory() + || return $self->error($name->error()); + } + else { + return $name; + } + } + else { + return (undef, Template::Constants::STATUS_DECLINED) + unless ($factory = $self->{ FILTERS }->{ $name } + || $FILTERS->{ $name }); + } + + # factory can be an [ $code, $dynamic ] or just $code + if (ref $factory eq 'ARRAY') { + ($factory, $is_dynamic) = @$factory; + } + else { + $is_dynamic = 0; + } + + if (ref $factory eq 'CODE') { + if ($is_dynamic) { + # if the dynamic flag is set then the sub-routine is a + # factory which should be called to create the actual + # filter... + eval { + ($filter, $error) = &$factory($context, $args ? @$args : ()); + }; + $error ||= $@; + $error = "invalid FILTER for '$name' (not a CODE ref)" + unless $error || ref($filter) eq 'CODE'; + } + else { + # ...otherwise, it's a static filter sub-routine + $filter = $factory; + } + } + else { + $error = "invalid FILTER entry for '$name' (not a CODE ref)"; + } + + if ($error) { + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR) ; + } + else { + return $filter; + } +} + + +#------------------------------------------------------------------------ +# store($name, \&filter) +# +# Stores a new filter in the internal FILTERS hash. The first parameter +# is the filter name, the second a reference to a subroutine or +# array, as per the standard $FILTERS entries. +#------------------------------------------------------------------------ + +sub store { + my ($self, $name, $filter) = @_; + + $self->debug("store($name, $filter)") if $self->{ DEBUG }; + + $self->{ FILTERS }->{ $name } = $filter; + return 1; +} + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init(\%config) +# +# Private initialisation method. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $params) = @_; + + $self->{ FILTERS } = $params->{ FILTERS } || { }; + $self->{ TOLERANT } = $params->{ TOLERANT } || 0; + $self->{ DEBUG } = ( $params->{ DEBUG } || 0 ) + & Template::Constants::DEBUG_FILTERS; + + + return $self; +} + + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $output = "[Template::Filters] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + foreach $key (qw( TOLERANT )) { + my $val = $self->{ $key }; + $val = '<undef>' unless defined $val; + $output .= sprintf($format, $key, $val); + } + + my $filters = $self->{ FILTERS }; + $filters = join('', map { + sprintf(" $format", $_, $filters->{ $_ }); + } keys %$filters); + $filters = "{\n$filters }"; + + $output .= sprintf($format, 'FILTERS (local)' => $filters); + + $filters = $FILTERS; + $filters = join('', map { + my $f = $filters->{ $_ }; + my ($ref, $dynamic) = ref $f eq 'ARRAY' ? @$f : ($f, 0); + sprintf(" $format", $_, $dynamic ? 'dynamic' : 'static'); + } sort keys %$filters); + $filters = "{\n$filters }"; + + $output .= sprintf($format, 'FILTERS (global)' => $filters); + + $output .= '}'; + return $output; +} + + +#======================================================================== +# -- STATIC FILTER SUBS -- +#======================================================================== + +#------------------------------------------------------------------------ +# uri_filter() [% FILTER uri %] +# +# URI escape a string. This code is borrowed from Gisle Aas' URI::Escape +# module. For something so simple, I can't see any validation in making +# the user install the URI modules just for this, so we cut and paste. +# +# URI::Escape is Copyright 1995-2000 Gisle Aas. +#------------------------------------------------------------------------ + +sub uri_filter { + my $text = shift; + + # construct and cache a lookup table for escapes (faster than + # doing a sprintf() for every character in every string each + # time) + $URI_ESCAPES ||= { + map { ( chr($_), sprintf("%%%02X", $_) ) } (0..255), + }; + + $text =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*'()])/$URI_ESCAPES->{$1}/g; + $text; +} + + +#------------------------------------------------------------------------ +# html_filter() [% FILTER html %] +# +# Convert any '<', '>' or '&' characters to the HTML equivalents, '<', +# '>' and '&', respectively. +#------------------------------------------------------------------------ + +sub html_filter { + my $text = shift; + for ($text) { + s/&/&/g; + s/</</g; + s/>/>/g; + s/"/"/g; + } + return $text; +} + + +#------------------------------------------------------------------------ +# html_paragraph() [% FILTER html_para %] +# +# Wrap each paragraph of text (delimited by two or more newlines) in the +# <p>...</p> HTML tags. +#------------------------------------------------------------------------ + +sub html_paragraph { + my $text = shift; + return "<p>\n" + . join("\n</p>\n\n<p>\n", split(/(?:\r?\n){2,}/, $text)) + . "</p>\n"; +} + + +#------------------------------------------------------------------------ +# html_para_break() [% FILTER html_para_break %] +# +# Join each paragraph of text (delimited by two or more newlines) with +# <br><br> HTML tags. +#------------------------------------------------------------------------ + +sub html_para_break { + my $text = shift; + $text =~ s|(\r?\n){2,}|$1<br />$1<br />$1|g; + return $text; +} + +#------------------------------------------------------------------------ +# html_line_break() [% FILTER html_line_break %] +# +# replaces any newlines with <br> HTML tags. +#------------------------------------------------------------------------ + +sub html_line_break { + my $text = shift; + $text =~ s|(\r?\n)|<br />$1|g; + return $text; +} + +#======================================================================== +# -- DYNAMIC FILTER FACTORIES -- +#======================================================================== + +#------------------------------------------------------------------------ +# html_entity_filter_factory(\%options) [% FILTER html %] +# +# Dynamic version of the static html filter which attempts to locate the +# Apache::Util or HTML::Entities modules to perform full entity encoding +# of the text passed. Returns an exception if one or other of the +# modules can't be located. +#------------------------------------------------------------------------ + +sub html_entity_filter_factory { + my $context = shift; + + # if Apache::Util is installed then we use it + eval { + require Apache::Util; + Apache::Util::escape_html(''); + }; + return \&Apache::Util::escape_html + unless $@; + + # otherwise if HTML::Entities is installed then we use that + eval { + require HTML::Entities; + }; + return \&HTML::Entities::encode_entities + unless $@; + + return (undef, Template::Exception->new( html_entity => + 'cannot locate Apache::Util or HTML::Entities' )); + +} + + +#------------------------------------------------------------------------ +# indent_filter_factory($pad) [% FILTER indent(pad) %] +# +# Create a filter to indent text by a fixed pad string or when $pad is +# numerical, a number of space. +#------------------------------------------------------------------------ + +sub indent_filter_factory { + my ($context, $pad) = @_; + $pad = 4 unless defined $pad; + $pad = ' ' x $pad if $pad =~ /^\d+$/; + + return sub { + my $text = shift; + $text = '' unless defined $text; + $text =~ s/^/$pad/mg; + return $text; + } +} + +#------------------------------------------------------------------------ +# format_filter_factory() [% FILTER format(format) %] +# +# Create a filter to format text according to a printf()-like format +# string. +#------------------------------------------------------------------------ + +sub format_filter_factory { + my ($context, $format) = @_; + $format = '%s' unless defined $format; + + return sub { + my $text = shift; + $text = '' unless defined $text; + return join("\n", map{ sprintf($format, $_) } split(/\n/, $text)); + } +} + + +#------------------------------------------------------------------------ +# repeat_filter_factory($n) [% FILTER repeat(n) %] +# +# Create a filter to repeat text n times. +#------------------------------------------------------------------------ + +sub repeat_filter_factory { + my ($context, $iter) = @_; + $iter = 1 unless defined $iter and length $iter; + + return sub { + my $text = shift; + $text = '' unless defined $text; + return join('\n', $text) x $iter; + } +} + + +#------------------------------------------------------------------------ +# replace_filter_factory($s, $r) [% FILTER replace(search, replace) %] +# +# Create a filter to replace 'search' text with 'replace' +#------------------------------------------------------------------------ + +sub replace_filter_factory { + my ($context, $search, $replace) = @_; + $search = '' unless defined $search; + $replace = '' unless defined $replace; + + return sub { + my $text = shift; + $text = '' unless defined $text; + $text =~ s/$search/$replace/g; + return $text; + } +} + + +#------------------------------------------------------------------------ +# remove_filter_factory($text) [% FILTER remove(text) %] +# +# Create a filter to remove 'search' string from the input text. +#------------------------------------------------------------------------ + +sub remove_filter_factory { + my ($context, $search) = @_; + + return sub { + my $text = shift; + $text = '' unless defined $text; + $text =~ s/$search//g; + return $text; + } +} + + +#------------------------------------------------------------------------ +# truncate_filter_factory($n) [% FILTER truncate(n) %] +# +# Create a filter to truncate text after n characters. +#------------------------------------------------------------------------ + +sub truncate_filter_factory { + my ($context, $len) = @_; + $len = 32 unless defined $len; + + return sub { + my $text = shift; + return $text if length $text < $len; + return substr($text, 0, $len - 3) . "..."; + } +} + + +#------------------------------------------------------------------------ +# eval_filter_factory [% FILTER eval %] +# +# Create a filter to evaluate template text. +#------------------------------------------------------------------------ + +sub eval_filter_factory { + my $context = shift; + + return sub { + my $text = shift; + $context->process(\$text); + } +} + + +#------------------------------------------------------------------------ +# perl_filter_factory [% FILTER perl %] +# +# Create a filter to process Perl text iff the context EVAL_PERL flag +# is set. +#------------------------------------------------------------------------ + +sub perl_filter_factory { + my $context = shift; + my $stash = $context->stash; + + return (undef, Template::Exception->new('perl', 'EVAL_PERL is not set')) + unless $context->eval_perl(); + + return sub { + my $text = shift; + local($Template::Perl::context) = $context; + local($Template::Perl::stash) = $stash; + my $out = eval <<EOF; +package Template::Perl; +\$stash = \$context->stash(); +$text +EOF + $context->throw($@) if $@; + return $out; + } +} + + +#------------------------------------------------------------------------ +# redirect_filter_factory($context, $file) [% FILTER redirect(file) %] +# +# Create a filter to redirect the block text to a file. +#------------------------------------------------------------------------ + +sub redirect_filter_factory { + my ($context, $file, $options) = @_; + my $outpath = $context->config->{ OUTPUT_PATH }; + + return (undef, Template::Exception->new('redirect', + 'OUTPUT_PATH is not set')) + unless $outpath; + + $options = { binmode => $options } unless ref $options; + + sub { + my $text = shift; + my $outpath = $context->config->{ OUTPUT_PATH } + || return ''; + $outpath .= "/$file"; + my $error = Template::_output($outpath, \$text, $options); + die Template::Exception->new('redirect', $error) + if $error; + return ''; + } +} + + +#------------------------------------------------------------------------ +# stdout_filter_factory($context, $binmode) [% FILTER stdout(binmode) %] +# +# Create a filter to print a block to stdout, with an optional binmode. +#------------------------------------------------------------------------ + +sub stdout_filter_factory { + my ($context, $options) = @_; + + $options = { binmode => $options } unless ref $options; + + sub { + my $text = shift; + binmode(STDOUT) if $options->{ binmode }; + print STDOUT $text; + return ''; + } +} + + +#------------------------------------------------------------------------ +# latex_filter_factory($context, $outputType) [% FILTER latex(outputType) %] +# +# Return a filter sub that converts a (hopefully) complete LaTeX source +# file to either "ps", "dvi", or "pdf". Output type should be "ps", "dvi" +# or "pdf" (pdf is default). +# +# Creates a temporary directory below File::Spec->tmpdir() (often /tmp) +# and writes the text into doc.tex. It then runs either pdflatex or +# latex and optionally dvips. Based on the exit status either returns +# the entire doc.(pdf|ps|dvi) output or throws an error with a summary +# of the error messages from doc.log. +# +# Written by Craig Barratt, Apr 28 2001. +# Win32 additions by Richard Tietjen. +#------------------------------------------------------------------------ +use File::Path; +use File::Spec; +use Cwd; + +sub latex_filter_factory +{ + my($context, $output) = @_; + + $output = lc($output); + my $fName = "latex"; + my($LaTeXPath, $PdfLaTeXPath, $DviPSPath) + = @{Template::Config->latexpaths()}; + if ( $output eq "ps" || $output eq "dvi" ) { + $context->throw($fName, + "latex not installed (see Template::Config::LATEX_PATH)") + if ( $LaTeXPath eq "" ); + } else { + $output = "pdf"; + $LaTeXPath = $PdfLaTeXPath; + $context->throw($fName, + "pdflatex not installed (see Template::Config::PDFLATEX_PATH)") + if ( $LaTeXPath eq "" ); + } + if ( $output eq "ps" && $DviPSPath eq "" ) { + $context->throw($fName, + "dvips not installed (see Template::Config::DVIPS_PATH)"); + } + if ( $^O !~ /^(MacOS|os2|VMS)$/i ) { + return sub { + local(*FH); + my $text = shift; + my $tmpRootDir = File::Spec->tmpdir(); + my $cnt = 0; + my($tmpDir, $fileName, $devnull); + my $texDoc = 'doc'; + + do { + $tmpDir = File::Spec->catdir($tmpRootDir, + "tt2latex$$" . "_$cnt"); + $cnt++; + } while ( -e $tmpDir ); + mkpath($tmpDir, 0, 0700); + $context->throw($fName, "can't create temp dir $tmpDir") + if ( !-d $tmpDir ); + $fileName = File::Spec->catfile($tmpDir, "$texDoc.tex"); + $devnull = File::Spec->devnull(); + if ( !open(FH, ">$fileName") ) { + rmtree($tmpDir); + $context->throw($fName, "can't open $fileName for output"); + } + print(FH $text); + close(FH); + + # latex must run in tmpDir directory + my $currDir = cwd(); + if ( !chdir($tmpDir) ) { + rmtree($tmpDir); + $context->throw($fName, "can't chdir $tmpDir"); + } + # + # We don't need to quote the backslashes on windows, but we + # do on other OSs + # + my $LaTeX_arg = "\\nonstopmode\\input{$texDoc}"; + $LaTeX_arg = "'$LaTeX_arg'" if ( $^O ne 'MSWin32' ); + if ( system("$LaTeXPath $LaTeX_arg" + . " 1>$devnull 2>$devnull 0<$devnull") ) { + my $texErrs = ""; + $fileName = File::Spec->catfile($tmpDir, "$texDoc.log"); + if ( open(FH, "<$fileName") ) { + my $state = 0; + # + # Try to extract just the interesting errors from + # the verbose log file + # + while ( <FH> ) { + # + # TeX errors seems to start with a "!" at the + # start of the line, and are followed several + # lines later by a line designator of the + # form "l.nnn" where nnn is the line number. + # We make sure we pick up every /^!/ line, and + # the first /^l.\d/ line after each /^!/ line. + # + if ( /^(!.*)/ ) { + $texErrs .= $1 . "\n"; + $state = 1; + } + if ( $state == 1 && /^(l\.\d.*)/ ) { + $texErrs .= $1 . "\n"; + $state = 0; + } + } + close(FH); + } else { + $texErrs = "Unable to open $fileName\n"; + } + my $ok = chdir($currDir); + rmtree($tmpDir); + $context->throw($fName, "can't chdir $currDir") if ( !$ok ); + $context->throw($fName, "latex exited with errors:\n$texErrs"); + } + if ( $output eq "ps" ) { + $fileName = File::Spec->catfile($tmpDir, "$texDoc.dvi"); + if ( system("$DviPSPath $texDoc -o" + . " 1>$devnull 2>$devnull 0<$devnull") ) { + my $ok = chdir($currDir); + rmtree($tmpDir); + $context->throw($fName, "can't chdir $currDir") if ( !$ok ); + $context->throw($fName, "can't run $DviPSPath $fileName"); + } + } + if ( !chdir($currDir) ) { + rmtree($tmpDir); + $context->throw($fName, "can't chdir $currDir"); + } + + my $retStr; + $fileName = File::Spec->catfile($tmpDir, "$texDoc.$output"); + if ( open(FH, $fileName) ) { + local $/ = undef; # slurp file in one go + binmode(FH); + $retStr = <FH>; + close(FH); + } else { + rmtree($tmpDir); + $context->throw($fName, "Can't open output file $fileName"); + } + rmtree($tmpDir); + return $retStr; + } + } else { + $context->throw("$fName not yet supported on $^O OS." + . " Please contribute code!!"); + } +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Filters - Post-processing filters for template blocks + +=head1 SYNOPSIS + + use Template::Filters; + + $filters = Template::Filters->new(\%config); + + ($filter, $error) = $filters->fetch($name, \@args, $context); + +=head1 DESCRIPTION + +The Template::Filters module implements a provider for creating and/or +returning subroutines that implement the standard filters. Additional +custom filters may be provided via the FILTERS options. + +=head1 METHODS + +=head2 new(\%params) + +Constructor method which instantiates and returns a reference to a +Template::Filters object. A reference to a hash array of configuration +items may be passed as a parameter. These are described below. + + my $filters = Template::Filters->new({ + FILTERS => { ... }, + }); + + my $template = Template->new({ + LOAD_FILTERS => [ $filters ], + }); + +A default Template::Filters module is created by the Template.pm module +if the LOAD_FILTERS option isn't specified. All configuration parameters +are forwarded to the constructor. + + $template = Template->new({ + FILTERS => { ... }, + }); + +=head2 fetch($name, \@args, $context) + +Called to request that a filter of a given name be provided. The name +of the filter should be specified as the first parameter. This should +be one of the standard filters or one specified in the FILTERS +configuration hash. The second argument should be a reference to an +array containing configuration parameters for the filter. This may be +specified as 0, or undef where no parameters are provided. The third +argument should be a reference to the current Template::Context +object. + +The method returns a reference to a filter sub-routine on success. It +may also return (undef, STATUS_DECLINE) to decline the request, to allow +delegation onto other filter providers in the LOAD_FILTERS chain of +responsibility. On error, ($error, STATUS_ERROR) is returned where $error +is an error message or Template::Exception object indicating the error +that occurred. + +When the TOLERANT option is set, errors are automatically downgraded to +a STATUS_DECLINE response. + + +=head1 CONFIGURATION OPTIONS + +The following list details the configuration options that can be provided +to the Template::Filters new() constructor. + +=over 4 + + + + +=item FILTERS + +The FILTERS option can be used to specify custom filters which can +then be used with the FILTER directive like any other. These are +added to the standard filters which are available by default. Filters +specified via this option will mask any standard filters of the same +name. + +The FILTERS option should be specified as a reference to a hash array +in which each key represents the name of a filter. The corresponding +value should contain a reference to an array containing a subroutine +reference and a flag which indicates if the filter is static (0) or +dynamic (1). A filter may also be specified as a solitary subroutine +reference and is assumed to be static. + + $filters = Template::Filters->new({ + FILTERS => { + 'sfilt1' => \&static_filter, # static + 'sfilt2' => [ \&static_filter, 0 ], # same as above + 'dfilt1' => [ \&dyanamic_filter_factory, 1 ], + }, + }); + +Additional filters can be specified at any time by calling the +define_filter() method on the current Template::Context object. +The method accepts a filter name, a reference to a filter +subroutine and an optional flag to indicate if the filter is +dynamic. + + my $context = $template->context(); + $context->define_filter('new_html', \&new_html); + $context->define_filter('new_repeat', \&new_repeat, 1); + +Static filters are those where a single subroutine reference is used +for all invocations of a particular filter. Filters that don't accept +any configuration parameters (e.g. 'html') can be implemented +statically. The subroutine reference is simply returned when that +particular filter is requested. The subroutine is called to filter +the output of a template block which is passed as the only argument. +The subroutine should return the modified text. + + sub static_filter { + my $text = shift; + # do something to modify $text... + return $text; + } + +The following template fragment: + + [% FILTER sfilt1 %] + Blah blah blah. + [% END %] + +is approximately equivalent to: + + &static_filter("\nBlah blah blah.\n"); + +Filters that can accept parameters (e.g. 'truncate') should be +implemented dynamically. In this case, the subroutine is taken to be +a filter 'factory' that is called to create a unique filter subroutine +each time one is requested. A reference to the current +Template::Context object is passed as the first parameter, followed by +any additional parameters specified. The subroutine should return +another subroutine reference (usually a closure) which implements the +filter. + + sub dynamic_filter_factory { + my ($context, @args) = @_; + + return sub { + my $text = shift; + # do something to modify $text... + return $text; + } + } + +The following template fragment: + + [% FILTER dfilt1(123, 456) %] + Blah blah blah + [% END %] + +is approximately equivalent to: + + my $filter = &dynamic_filter_factory($context, 123, 456); + &$filter("\nBlah blah blah.\n"); + +See the FILTER directive for further examples. + + + + +=item TOLERANT + +The TOLERANT flag is used by the various Template Toolkit provider +modules (Template::Provider, Template::Plugins, Template::Filters) to +control their behaviour when errors are encountered. By default, any +errors are reported as such, with the request for the particular +resource (template, plugin, filter) being denied and an exception +raised. When the TOLERANT flag is set to any true values, errors will +be silently ignored and the provider will instead return +STATUS_DECLINED. This allows a subsequent provider to take +responsibility for providing the resource, rather than failing the +request outright. If all providers decline to service the request, +either through tolerated failure or a genuine disinclination to +comply, then a 'E<lt>resourceE<gt> not found' exception is raised. + + + + +=item DEBUG + +The DEBUG option can be used to enable debugging messages from the +Template::Filters module by setting it to include the DEBUG_FILTERS +value. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_FILTERS | DEBUG_PLUGINS, + }); + + + + +=back + +=head1 TEMPLATE TOOLKIT FILTERS + +The following standard filters are distributed with the Template Toolkit. + + + +=head2 format(format) + +The 'format' filter takes a format string as a parameter (as per +printf()) and formats each line of text accordingly. + + [% FILTER format('<!-- %-40s -->') %] + This is a block of text filtered + through the above format. + [% END %] + +output: + + <!-- This is a block of text filtered --> + <!-- through the above format. --> + +=head2 upper + +Folds the input to UPPER CASE. + + [% "hello world" FILTER upper %] + +output: + + HELLO WORLD + +=head2 lower + +Folds the input to lower case. + + [% "Hello World" FILTER lower %] + +output: + + hello world + +=head2 ucfirst + +Folds the first character of the input to UPPER CASE. + + [% "hello" FILTER ucfirst %] + +output: + + Hello + +=head2 lcfirst + +Folds the first character of the input to lower case. + + [% "HELLO" FILTER lcfirst %] + +output: + + hELLO + +=head2 trim + +Trims any leading or trailing whitespace from the input text. Particularly +useful in conjunction with INCLUDE, PROCESS, etc., having the same effect +as the TRIM configuration option. + + [% INCLUDE myfile | trim %] + +=head2 collapse + +Collapse any whitespace sequences in the input text into a single space. +Leading and trailing whitespace (which would be reduced to a single space) +is removed, as per trim. + + [% FILTER collapse %] + + The cat + + sat on + + the mat + + [% END %] + +output: + + The cat sat on the mat + +=head2 html + +Converts the characters 'E<lt>', 'E<gt>' and '&' to '<', '>' and +'&', respectively, protecting them from being interpreted as +representing HTML tags or entities. + + [% FILTER html %] + Binary "<=>" returns -1, 0, or 1 depending on... + [% END %] + +output: + + Binary "<=>" returns -1, 0, or 1 depending on... + +=head2 html_entity + +The html filter is fast and simple but it doesn't encode the full +range of HTML entities that your text may contain. The html_entity +filter uses either the Apache::Util module (which is written in C and +is therefore faster) or the HTML::Entities module (written in Perl but +equally as comprehensive) to perform the encoding. If one or other of +these modules are installed on your system then the text will be +encoded (via the escape_html() or encode_entities() subroutines +respectively) to convert all extended characters into their +appropriate HTML entities (e.g. converting 'é' to 'é'). If +neither module is available on your system then an 'html_entity' exception +will be thrown reporting an appropriate message. + +For further information on HTML entity encoding, see +http://www.w3.org/TR/REC-html40/sgml/entities.html. + +=head2 html_para + +This filter formats a block of text into HTML paragraphs. A sequence of +two or more newlines is used as the delimiter for paragraphs which are +then wrapped in HTML E<lt>pE<gt>...E<lt>/pE<gt> tags. + + [% FILTER html_para %] + The cat sat on the mat. + + Mary had a little lamb. + [% END %] + +output: + + <p> + The cat sat on the mat. + </p> + + <p> + Mary had a little lamb. + </p> + +=head2 html_break / html_para_break + +Similar to the html_para filter described above, but uses the HTML tag +sequence E<lt>brE<gt>E<lt>brE<gt> to join paragraphs. + + [% FILTER html_break %] + The cat sat on the mat. + + Mary had a little lamb. + [% END %] + +output: + + The cat sat on the mat. + <br> + <br> + Mary had a little lamb. + +=head2 html_line_break + +This filter replaces any newlines with E<lt>brE<gt> HTML tags, +thus preserving the line breaks of the original text in the +HTML output. + + [% FILTER html_line_break %] + The cat sat on the mat. + Mary had a little lamb. + [% END %] + +output: + + The cat sat on the mat.<br> + Mary had a little lamb.<br> + +=head2 uri + +This filter URI escapes the input text, converting any characters +outside of the permitted URI character set (as defined by RFC 2396) +into a C<%nn> hex escape. + + [% 'my file.html' | uri %] + +output: + + my%20file.html + +Note that URI escaping isn't always enough when generating hyperlinks in +an HTML document. The C<&> character, for example, is valid in a URI and +will not be escaped by the URI filter. In this case you should also filter +the text through the 'html' filter. + + <a href="[% filename | uri | html %]">click here</a> + +=head2 indent(pad) + +Indents the text block by a fixed pad string or width. The 'pad' argument +can be specified as a string, or as a numerical value to indicate a pad +width (spaces). Defaults to 4 spaces if unspecified. + + [% FILTER indent('ME> ') %] + blah blah blah + cabbages, rhubard, onions + [% END %] + +output: + + ME> blah blah blah + ME> cabbages, rhubard, onions + +=head2 truncate(length) + +Truncates the text block to the length specified, or a default length of +32. Truncated text will be terminated with '...' (i.e. the '...' falls +inside the required length, rather than appending to it). + + [% FILTER truncate(21) %] + I have much to say on this matter that has previously + been said on more than one occasion. + [% END %] + +output: + + I have much to say... + +=head2 repeat(iterations) + +Repeats the text block for as many iterations as are specified (default: 1). + + [% FILTER repeat(3) %] + We want more beer and we want more beer, + [% END %] + We are the more beer wanters! + +output: + + We want more beer and we want more beer, + We want more beer and we want more beer, + We want more beer and we want more beer, + We are the more beer wanters! + +=head2 remove(string) + +Searches the input text for any occurrences of the specified string and +removes them. A Perl regular expression may be specified as the search +string. + + [% "The cat sat on the mat" FILTER remove('\s+') %] + +output: + + Thecatsatonthemat + +=head2 replace(search, replace) + +Similar to the remove filter described above, but taking a second parameter +which is used as a replacement string for instances of the search string. + + [% "The cat sat on the mat" | replace('\s+', '_') %] + +output: + + The_cat_sat_on_the_mat + +=head2 redirect(file, options) + +The 'redirect' filter redirects the output of the block into a separate +file, specified relative to the OUTPUT_PATH configuration item. + + [% FOREACH user = myorg.userlist %] + [% FILTER redirect("users/${user.id}.html") %] + [% INCLUDE userinfo %] + [% END %] + [% END %] + +or more succinctly, using side-effect notation: + + [% INCLUDE userinfo + FILTER redirect("users/${user.id}.html") + FOREACH user = myorg.userlist + %] + +A 'file' exception will be thrown if the OUTPUT_PATH option is undefined. + +An optional 'binmode' argument can follow the filename to explicitly set +the output file to binary mode. + + [% PROCESS my/png/generator + FILTER redirect("images/logo.png", binmode=1) %] + +For backwards compatibility with earlier versions, a single true/false +value can be used to set binary mode. + + [% PROCESS my/png/generator + FILTER redirect("images/logo.png", 1) %] + +For the sake of future compatibility and clarity, if nothing else, we +would strongly recommend you explicitly use the named 'binmode' option +as shown in the first example. + +=head2 eval / evaltt + +The 'eval' filter evaluates the block as template text, processing +any directives embedded within it. This allows template variables to +contain template fragments, or for some method to be provided for +returning template fragments from an external source such as a +database, which can then be processed in the template as required. + + my $vars = { + fragment => "The cat sat on the [% place %]", + }; + $template->process($file, $vars); + +The following example: + + [% fragment | eval %] + +is therefore equivalent to + + The cat sat on the [% place %] + +The 'evaltt' filter is provided as an alias for 'eval'. + +=head2 perl / evalperl + +The 'perl' filter evaluates the block as Perl code. The EVAL_PERL +option must be set to a true value or a 'perl' exception will be +thrown. + + [% my_perl_code | perl %] + +In most cases, the [% PERL %] ... [% END %] block should suffice for +evaluating Perl code, given that template directives are processed +before being evaluate as Perl. Thus, the previous example could have +been written in the more verbose form: + + [% PERL %] + [% my_perl_code %] + [% END %] + +as well as + + [% FILTER perl %] + [% my_perl_code %] + [% END %] + +The 'evalperl' filter is provided as an alias for 'perl' for backwards +compatibility. + +=head2 stdout(options) + +The stdout filter prints the output generated by the enclosing block to +STDOUT. The 'binmode' option can be passed as either a named parameter +or a single argument to set STDOUT to binary mode (see the +binmode perl function). + + [% PROCESS something/cool + FILTER stdout(binmode=1) # recommended %] + + [% PROCESS something/cool + FILTER stdout(1) # alternate %] + +The stdout filter can be used to force binmode on STDOUT, or also inside +redirect, null or stderr blocks to make sure that particular output goes +to stdout. See the null filter below for an example. + +=head2 stderr + +The stderr filter prints the output generated by the enclosing block to +STDERR. + +=head2 null + +The null filter prints nothing. This is useful for plugins whose +methods return values that you don't want to appear in the output. +Rather than assigning every plugin method call to a dummy variable +to silence it, you can wrap the block in a null filter: + + [% FILTER null; + USE im = GD.Image(100,100); + black = im.colorAllocate(0, 0, 0); + red = im.colorAllocate(255,0, 0); + blue = im.colorAllocate(0, 0, 255); + im.arc(50,50,95,75,0,360,blue); + im.fill(50,50,red); + im.png | stdout(1); + END; + -%] + +Notice the use of the stdout filter to ensure that a particular expression +generates output to stdout (in this case in binary mode). + +=head2 latex(outputType) + +Passes the text block to LaTeX and produces either PDF, DVI or +PostScript output. The 'outputType' argument determines the output +format and it should be set to one of the strings: "pdf" (default), +"dvi", or "ps". + +The text block should be a complete LaTeX source file. + + [% FILTER latex("pdf") -%] + \documentclass{article} + + \begin{document} + + \title{A Sample TT2 \LaTeX\ Source File} + \author{Craig Barratt} + \maketitle + + \section{Introduction} + This is some text. + + \end{document} + [% END -%] + +The output will be a PDF file. You should be careful not to prepend or +append any extraneous characters or text outside the FILTER block, +since this text will wrap the (binary) output of the latex filter. +Notice the END directive uses '-%]' for the END_TAG to remove the +trailing new line. + +One example where you might prepend text is in a CGI script where +you might include the Content-Type before the latex output, eg: + + Content-Type: application/pdf + + [% FILTER latex("pdf") -%] + \documentclass{article} + \begin{document} + ... + \end{document} + [% END -%] + +In other cases you might use the redirect filter to put the output +into a file, rather than delivering it to stdout. This might be +suitable for batch scripts: + + [% output = FILTER latex("pdf") -%] + \documentclass{article} + \begin{document} + ... + \end{document} + [% END; output | redirect("document.pdf", 1) -%] + +(Notice the second argument to redirect to force binary mode.) + +Note that the latex filter runs one or two external programs, so it +isn't very fast. But for modest documents the performance is adequate, +even for interactive applications. + +A error of type 'latex' will be thrown if there is an error reported +by latex, pdflatex or dvips. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.72, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Context|Template::Context>, L<Template::Manual::Filters|Template::Manual::Filters> diff --git a/lib/Template/Grammar.pm b/lib/Template/Grammar.pm new file mode 100644 index 0000000..2e1a808 --- /dev/null +++ b/lib/Template/Grammar.pm @@ -0,0 +1,6174 @@ +#============================================================= -*-Perl-*- +# +# Template::Grammar +# +# DESCRIPTION +# Grammar file for the Template Toolkit language containing token +# definitions and parser state/rules tables generated by Parse::Yapp. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#------------------------------------------------------------------------ +# +# NOTE: this module is constructed from the parser/Grammar.pm.skel +# file by running the parser/yc script. You only need to do this if +# you have modified the grammar in the parser/Parser.yp file and need +# to-recompile it. See the README in the 'parser' directory for more +# information (sub-directory of the Template distribution). +# +#------------------------------------------------------------------------ +# +# $Id: Grammar.pm,v 2.19 2003/04/29 12:47:22 abw Exp $ +# +#======================================================================== + +package Template::Grammar; + +require 5.004; + +use strict; +use vars qw( $VERSION ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.19 $ =~ /(\d+)\.(\d+)/); + +my (@RESERVED, %CMPOP, $LEXTABLE, $RULES, $STATES); +my ($factory, $rawstart); + + +#======================================================================== + +# Reserved words, comparison and binary operators +#======================================================================== + +@RESERVED = qw( + GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER BLOCK END + USE PLUGIN FILTER MACRO PERL RAWPERL TO STEP AND OR NOT DIV MOD + IF UNLESS ELSE ELSIF FOR NEXT WHILE SWITCH CASE META IN + TRY THROW CATCH FINAL LAST RETURN STOP CLEAR VIEW DEBUG + ); + +# for historical reasons, != and == are converted to ne and eq to perform +# stringwise comparison (mainly because it doesn't generate "non-numerical +# comparison" warnings which != and == can) but the others (e.g. < > <= >=) +# are not converted to their stringwise equivalents. I added 'gt' et al, +# briefly for v2.04d and then took them out again in 2.04e. + +%CMPOP = qw( + != ne + == eq + < < + > > + >= >= + <= <= +); + + +#======================================================================== +# Lexer Token Table +#======================================================================== + +# lookup table used by lexer is initialised with special-cases +$LEXTABLE = { + 'FOREACH' => 'FOR', + 'BREAK' => 'LAST', + '&&' => 'AND', + '||' => 'OR', + '!' => 'NOT', + '|' => 'FILTER', + '.' => 'DOT', + '_' => 'CAT', + '..' => 'TO', +# ':' => 'MACRO', + '=' => 'ASSIGN', + '=>' => 'ASSIGN', +# '->' => 'ARROW', + ',' => 'COMMA', + '\\' => 'REF', + 'and' => 'AND', # explicitly specified so that qw( and or + 'or' => 'OR', # not ) can always be used in lower case, + 'not' => 'NOT', # regardless of ANYCASE flag + 'mod' => 'MOD', + 'div' => 'DIV', +}; + +# localise the temporary variables needed to complete lexer table +{ +# my @tokens = qw< ( ) [ ] { } ${ $ / ; : ? >; + my @tokens = qw< ( ) [ ] { } ${ $ + / ; : ? >; + my @cmpop = keys %CMPOP; +# my @binop = qw( + - * % ); # '/' above, in @tokens + my @binop = qw( - * % ); # '+' and '/' above, in @tokens + + # fill lexer table, slice by slice, with reserved words and operators + @$LEXTABLE{ @RESERVED, @cmpop, @binop, @tokens } + = ( @RESERVED, ('CMPOP') x @cmpop, ('BINOP') x @binop, @tokens ); +} + + +#======================================================================== +# CLASS METHODS +#======================================================================== + +sub new { + my $class = shift; + bless { + LEXTABLE => $LEXTABLE, + STATES => $STATES, + RULES => $RULES, + }, $class; +} + +# update method to set package-scoped $factory lexical +sub install_factory { + my ($self, $new_factory) = @_; + $factory = $new_factory; +} + + +#======================================================================== +# States +#======================================================================== + +$STATES = [ + {#State 0 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'template' => 52, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'switch' => 34, + 'try' => 35, + 'assign' => 19, + 'block' => 72, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 1 + ACTIONS => { + "\$" => 43, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'setlist' => 76, + 'item' => 39, + 'assign' => 19, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 2 + DEFAULT => -130 + }, + {#State 3 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 79, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 4 + DEFAULT => -23 + }, + {#State 5 + ACTIONS => { + ";" => 80 + } + }, + {#State 6 + DEFAULT => -37 + }, + {#State 7 + DEFAULT => -14 + }, + {#State 8 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 90, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 9 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "]" => 94, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 96, + 'item' => 39, + 'range' => 93, + 'node' => 23, + 'ident' => 77, + 'term' => 95, + 'list' => 92, + 'lterm' => 56 + } + }, + {#State 10 + ACTIONS => { + ";" => 97 + } + }, + {#State 11 + DEFAULT => -5 + }, + {#State 12 + ACTIONS => { + ";" => -20 + }, + DEFAULT => -27 + }, + {#State 13 + DEFAULT => -78, + GOTOS => { + '@5-1' => 98 + } + }, + {#State 14 + ACTIONS => { + 'IDENT' => 99 + }, + DEFAULT => -87, + GOTOS => { + 'blockargs' => 102, + 'metadata' => 101, + 'meta' => 100 + } + }, + {#State 15 + ACTIONS => { + 'IDENT' => 99 + }, + GOTOS => { + 'metadata' => 103, + 'meta' => 100 + } + }, + {#State 16 + ACTIONS => { + 'DOT' => 104, + 'ASSIGN' => 105 + }, + DEFAULT => -109 + }, + {#State 17 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 106, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 18 + ACTIONS => { + 'IDENT' => 107 + } + }, + {#State 19 + DEFAULT => -149 + }, + {#State 20 + DEFAULT => -12 + }, + {#State 21 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 108, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'loopvar' => 110, + 'node' => 23, + 'ident' => 77, + 'term' => 109, + 'lterm' => 56 + } + }, + {#State 22 + DEFAULT => -40 + }, + {#State 23 + DEFAULT => -127 + }, + {#State 24 + DEFAULT => -6 + }, + {#State 25 + ACTIONS => { + "\"" => 117, + "\$" => 114, + 'LITERAL' => 116, + 'FILENAME' => 83, + 'IDENT' => 111, + 'NUMBER' => 84, + "\${" => 37 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 118, + 'filename' => 85, + 'lvalue' => 112, + 'lnameargs' => 115, + 'item' => 113, + 'name' => 82 + } + }, + {#State 26 + DEFAULT => -113 + }, + {#State 27 + ACTIONS => { + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 119 + } + }, + {#State 28 + ACTIONS => { + 'LITERAL' => 124, + 'FILENAME' => 83, + 'IDENT' => 120, + 'NUMBER' => 84 + }, + DEFAULT => -87, + GOTOS => { + 'blockargs' => 123, + 'filepart' => 87, + 'filename' => 122, + 'blockname' => 121, + 'metadata' => 101, + 'meta' => 100 + } + }, + {#State 29 + DEFAULT => -43 + }, + {#State 30 + ACTIONS => { + "\$" => 43, + 'LITERAL' => 129, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -119, + GOTOS => { + 'params' => 128, + 'hash' => 125, + 'item' => 126, + 'param' => 127 + } + }, + {#State 31 + DEFAULT => -25 + }, + {#State 32 + ACTIONS => { + "\"" => 117, + "\$" => 114, + 'LITERAL' => 116, + 'FILENAME' => 83, + 'IDENT' => 111, + 'NUMBER' => 84, + "\${" => 37 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 118, + 'filename' => 85, + 'lvalue' => 112, + 'lnameargs' => 130, + 'item' => 113, + 'name' => 82 + } + }, + {#State 33 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -2, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 131, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 34 + DEFAULT => -22 + }, + {#State 35 + DEFAULT => -24 + }, + {#State 36 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 132, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 37 + ACTIONS => { + "\"" => 60, + "\$" => 43, + 'LITERAL' => 78, + 'IDENT' => 2, + 'REF' => 27, + 'NUMBER' => 26, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 133, + 'item' => 39, + 'node' => 23, + 'ident' => 77 + } + }, + {#State 38 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 134, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 39 + ACTIONS => { + "(" => 135 + }, + DEFAULT => -128 + }, + {#State 40 + ACTIONS => { + ";" => 136 + } + }, + {#State 41 + DEFAULT => -38 + }, + {#State 42 + DEFAULT => -11 + }, + {#State 43 + ACTIONS => { + 'IDENT' => 137 + } + }, + {#State 44 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 138, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 45 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 139, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 46 + DEFAULT => -42 + }, + {#State 47 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 140, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 48 + ACTIONS => { + 'IF' => 144, + 'FILTER' => 143, + 'FOR' => 142, + 'WHILE' => 146, + 'WRAPPER' => 145, + 'UNLESS' => 141 + } + }, + {#State 49 + DEFAULT => -39 + }, + {#State 50 + DEFAULT => -10 + }, + {#State 51 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 147, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 52 + ACTIONS => { + '' => 148 + } + }, + {#State 53 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 57, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 149, + 'term' => 58, + 'expr' => 151, + 'assign' => 150, + 'lterm' => 56 + } + }, + {#State 54 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 152, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 55 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 153, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 56 + DEFAULT => -103 + }, + {#State 57 + ACTIONS => { + 'ASSIGN' => 154 + }, + DEFAULT => -112 + }, + {#State 58 + DEFAULT => -146 + }, + {#State 59 + DEFAULT => -15 + }, + {#State 60 + DEFAULT => -176, + GOTOS => { + 'quoted' => 155 + } + }, + {#State 61 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 156, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 62 + ACTIONS => { + ";" => -16, + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -26 + }, + {#State 63 + DEFAULT => -13 + }, + {#State 64 + DEFAULT => -36 + }, + {#State 65 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 167, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 66 + DEFAULT => -9 + }, + {#State 67 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 168, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 68 + DEFAULT => -104 + }, + {#State 69 + ACTIONS => { + "\$" => 43, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'setlist' => 169, + 'item' => 39, + 'assign' => 19, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 70 + ACTIONS => { + "\$" => 43, + 'COMMA' => 171, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -19, + GOTOS => { + 'item' => 39, + 'assign' => 170, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 71 + DEFAULT => -8 + }, + {#State 72 + DEFAULT => -1 + }, + {#State 73 + DEFAULT => -21 + }, + {#State 74 + ACTIONS => { + 'ASSIGN' => 172, + 'DOT' => 104 + } + }, + {#State 75 + ACTIONS => { + 'ASSIGN' => 154 + } + }, + {#State 76 + ACTIONS => { + "\$" => 43, + 'COMMA' => 171, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -30, + GOTOS => { + 'item' => 39, + 'assign' => 170, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 77 + ACTIONS => { + 'DOT' => 104 + }, + DEFAULT => -109 + }, + {#State 78 + DEFAULT => -112 + }, + {#State 79 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 173, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 80 + DEFAULT => -7 + }, + {#State 81 + DEFAULT => -173 + }, + {#State 82 + DEFAULT => -166 + }, + {#State 83 + DEFAULT => -172 + }, + {#State 84 + DEFAULT => -174 + }, + {#State 85 + ACTIONS => { + 'DOT' => 174 + }, + DEFAULT => -168 + }, + {#State 86 + ACTIONS => { + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 175 + } + }, + {#State 87 + DEFAULT => -171 + }, + {#State 88 + DEFAULT => -169 + }, + {#State 89 + DEFAULT => -176, + GOTOS => { + 'quoted' => 176 + } + }, + {#State 90 + DEFAULT => -35 + }, + {#State 91 + ACTIONS => { + "+" => 177, + "(" => 178 + }, + DEFAULT => -156, + GOTOS => { + 'args' => 179 + } + }, + {#State 92 + ACTIONS => { + "{" => 30, + 'COMMA' => 182, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "]" => 180, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 181, + 'lterm' => 56 + } + }, + {#State 93 + ACTIONS => { + "]" => 183 + } + }, + {#State 94 + DEFAULT => -107 + }, + {#State 95 + DEFAULT => -116 + }, + {#State 96 + ACTIONS => { + 'TO' => 184 + }, + DEFAULT => -104 + }, + {#State 97 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 185, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 98 + ACTIONS => { + ";" => 186 + } + }, + {#State 99 + ACTIONS => { + 'ASSIGN' => 187 + } + }, + {#State 100 + DEFAULT => -99 + }, + {#State 101 + ACTIONS => { + 'COMMA' => 189, + 'IDENT' => 99 + }, + DEFAULT => -86, + GOTOS => { + 'meta' => 188 + } + }, + {#State 102 + ACTIONS => { + ";" => 190 + } + }, + {#State 103 + ACTIONS => { + 'COMMA' => 189, + 'IDENT' => 99 + }, + DEFAULT => -17, + GOTOS => { + 'meta' => 188 + } + }, + {#State 104 + ACTIONS => { + "\$" => 43, + 'IDENT' => 2, + 'NUMBER' => 192, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 191 + } + }, + {#State 105 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'WRAPPER' => 55, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + "\"" => 60, + 'PROCESS' => 61, + 'FILTER' => 25, + 'RETURN' => 64, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 193, + 'DEFAULT' => 69, + "{" => 30, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'term' => 58, + 'loop' => 4, + 'expr' => 195, + 'wrapper' => 46, + 'atomexpr' => 48, + 'atomdir' => 12, + 'mdir' => 194, + 'sterm' => 68, + 'filter' => 29, + 'ident' => 149, + 'perl' => 31, + 'setlist' => 70, + 'switch' => 34, + 'try' => 35, + 'assign' => 19, + 'directive' => 196, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 106 + DEFAULT => -33 + }, + {#State 107 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'INCLUDE' => 17, + "(" => 198, + 'SWITCH' => 54, + 'WRAPPER' => 55, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + "\"" => 60, + 'PROCESS' => 61, + 'FILTER' => 25, + 'RETURN' => 64, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 193, + 'DEFAULT' => 69, + "{" => 30, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'term' => 58, + 'loop' => 4, + 'expr' => 199, + 'wrapper' => 46, + 'atomexpr' => 48, + 'atomdir' => 12, + 'mdir' => 197, + 'sterm' => 68, + 'filter' => 29, + 'ident' => 149, + 'perl' => 31, + 'setlist' => 70, + 'switch' => 34, + 'try' => 35, + 'assign' => 19, + 'directive' => 196, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 108 + ACTIONS => { + 'IN' => 201, + 'ASSIGN' => 200 + }, + DEFAULT => -130 + }, + {#State 109 + DEFAULT => -156, + GOTOS => { + 'args' => 202 + } + }, + {#State 110 + ACTIONS => { + ";" => 203 + } + }, + {#State 111 + ACTIONS => { + 'ASSIGN' => -130 + }, + DEFAULT => -173 + }, + {#State 112 + ACTIONS => { + 'ASSIGN' => 204 + } + }, + {#State 113 + DEFAULT => -159 + }, + {#State 114 + ACTIONS => { + "\$" => 43, + 'IDENT' => 205, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 175 + } + }, + {#State 115 + ACTIONS => { + ";" => 206 + } + }, + {#State 116 + ACTIONS => { + 'ASSIGN' => -161 + }, + DEFAULT => -169 + }, + {#State 117 + DEFAULT => -176, + GOTOS => { + 'quoted' => 207 + } + }, + {#State 118 + DEFAULT => -158 + }, + {#State 119 + ACTIONS => { + 'DOT' => 104 + }, + DEFAULT => -110 + }, + {#State 120 + ACTIONS => { + 'ASSIGN' => 187 + }, + DEFAULT => -173 + }, + {#State 121 + DEFAULT => -83 + }, + {#State 122 + ACTIONS => { + 'DOT' => 174 + }, + DEFAULT => -84 + }, + {#State 123 + ACTIONS => { + ";" => 208 + } + }, + {#State 124 + DEFAULT => -85 + }, + {#State 125 + ACTIONS => { + "}" => 209 + } + }, + {#State 126 + ACTIONS => { + 'ASSIGN' => 210 + } + }, + {#State 127 + DEFAULT => -122 + }, + {#State 128 + ACTIONS => { + "\$" => 43, + 'COMMA' => 212, + 'LITERAL' => 129, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -118, + GOTOS => { + 'item' => 126, + 'param' => 211 + } + }, + {#State 129 + ACTIONS => { + 'ASSIGN' => 213 + } + }, + {#State 130 + DEFAULT => -73 + }, + {#State 131 + DEFAULT => -4 + }, + {#State 132 + ACTIONS => { + ";" => 214 + } + }, + {#State 133 + ACTIONS => { + "}" => 215 + } + }, + {#State 134 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -142 + }, + {#State 135 + DEFAULT => -156, + GOTOS => { + 'args' => 216 + } + }, + {#State 136 + DEFAULT => -76, + GOTOS => { + '@4-2' => 217 + } + }, + {#State 137 + DEFAULT => -132 + }, + {#State 138 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 218, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 139 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -29 + }, + {#State 140 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -28 + }, + {#State 141 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 219, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 142 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 108, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'loopvar' => 220, + 'node' => 23, + 'ident' => 77, + 'term' => 109, + 'lterm' => 56 + } + }, + {#State 143 + ACTIONS => { + "\"" => 117, + "\$" => 114, + 'LITERAL' => 116, + 'FILENAME' => 83, + 'IDENT' => 111, + 'NUMBER' => 84, + "\${" => 37 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 118, + 'filename' => 85, + 'lvalue' => 112, + 'lnameargs' => 221, + 'item' => 113, + 'name' => 82 + } + }, + {#State 144 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 222, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 145 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 223, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 146 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 224, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 147 + DEFAULT => -41 + }, + {#State 148 + DEFAULT => 0 + }, + {#State 149 + ACTIONS => { + 'DOT' => 104, + 'ASSIGN' => 172 + }, + DEFAULT => -109 + }, + {#State 150 + ACTIONS => { + ")" => 225 + } + }, + {#State 151 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + ")" => 226, + 'OR' => 162 + } + }, + {#State 152 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 227, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 153 + ACTIONS => { + ";" => 228 + } + }, + {#State 154 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 229, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 155 + ACTIONS => { + "\"" => 234, + 'TEXT' => 231, + ";" => 233, + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 230, + 'quotable' => 232 + } + }, + {#State 156 + DEFAULT => -34 + }, + {#State 157 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 235, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 158 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 236, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 159 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 237, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 160 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 238, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 161 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 239, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 162 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 240, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 163 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 241, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 164 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 242, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 165 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 243, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 166 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 244, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 167 + DEFAULT => -32 + }, + {#State 168 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 245, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 169 + ACTIONS => { + "\$" => 43, + 'COMMA' => 171, + 'LITERAL' => 75, + 'IDENT' => 2, + "\${" => 37 + }, + DEFAULT => -31, + GOTOS => { + 'item' => 39, + 'assign' => 170, + 'node' => 23, + 'ident' => 74 + } + }, + {#State 170 + DEFAULT => -147 + }, + {#State 171 + DEFAULT => -148 + }, + {#State 172 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 246, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 173 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 247, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 174 + ACTIONS => { + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 248 + } + }, + {#State 175 + ACTIONS => { + 'DOT' => 104 + }, + DEFAULT => -156, + GOTOS => { + 'args' => 249 + } + }, + {#State 176 + ACTIONS => { + "\"" => 250, + 'TEXT' => 231, + ";" => 233, + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 230, + 'quotable' => 232 + } + }, + {#State 177 + ACTIONS => { + "\"" => 89, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'filename' => 85, + 'name' => 251 + } + }, + {#State 178 + DEFAULT => -156, + GOTOS => { + 'args' => 252 + } + }, + {#State 179 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -163, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 180 + DEFAULT => -105 + }, + {#State 181 + DEFAULT => -114 + }, + {#State 182 + DEFAULT => -115 + }, + {#State 183 + DEFAULT => -106 + }, + {#State 184 + ACTIONS => { + "\"" => 60, + "\$" => 43, + 'LITERAL' => 78, + 'IDENT' => 2, + 'REF' => 27, + 'NUMBER' => 26, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 259, + 'item' => 39, + 'node' => 23, + 'ident' => 77 + } + }, + {#State 185 + ACTIONS => { + 'FINAL' => 260, + 'CATCH' => 262 + }, + DEFAULT => -72, + GOTOS => { + 'final' => 261 + } + }, + {#State 186 + ACTIONS => { + 'TEXT' => 263 + } + }, + {#State 187 + ACTIONS => { + "\"" => 266, + 'LITERAL' => 265, + 'NUMBER' => 264 + } + }, + {#State 188 + DEFAULT => -97 + }, + {#State 189 + DEFAULT => -98 + }, + {#State 190 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'template' => 267, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 72, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 191 + DEFAULT => -125 + }, + {#State 192 + DEFAULT => -126 + }, + {#State 193 + ACTIONS => { + ";" => 268 + } + }, + {#State 194 + DEFAULT => -89 + }, + {#State 195 + ACTIONS => { + ";" => -150, + "+" => 157, + 'LITERAL' => -150, + 'IDENT' => -150, + 'CAT' => 163, + "\$" => -150, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + 'COMMA' => -150, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162, + "\${" => -150 + }, + DEFAULT => -26 + }, + {#State 196 + DEFAULT => -92 + }, + {#State 197 + DEFAULT => -91 + }, + {#State 198 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 57, + 'IDENT' => 269, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'margs' => 270, + 'node' => 23, + 'ident' => 149, + 'term' => 58, + 'expr' => 151, + 'assign' => 150, + 'lterm' => 56 + } + }, + {#State 199 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -26 + }, + {#State 200 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 271, + 'lterm' => 56 + } + }, + {#State 201 + ACTIONS => { + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 272, + 'lterm' => 56 + } + }, + {#State 202 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -64, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 203 + DEFAULT => -56, + GOTOS => { + '@1-3' => 273 + } + }, + {#State 204 + ACTIONS => { + "\"" => 89, + "\$" => 86, + 'LITERAL' => 88, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'names' => 91, + 'nameargs' => 274, + 'filename' => 85, + 'name' => 82 + } + }, + {#State 205 + ACTIONS => { + 'ASSIGN' => -132 + }, + DEFAULT => -130 + }, + {#State 206 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 275, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 207 + ACTIONS => { + "\"" => 276, + 'TEXT' => 231, + ";" => 233, + "\$" => 43, + 'IDENT' => 2, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'ident' => 230, + 'quotable' => 232 + } + }, + {#State 208 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 277, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 209 + DEFAULT => -108 + }, + {#State 210 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 278, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 211 + DEFAULT => -120 + }, + {#State 212 + DEFAULT => -121 + }, + {#State 213 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 279, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 214 + DEFAULT => -74, + GOTOS => { + '@3-3' => 280 + } + }, + {#State 215 + DEFAULT => -131 + }, + {#State 216 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + ")" => 281, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 217 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 282, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 218 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 283, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 219 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -47 + }, + {#State 220 + DEFAULT => -58 + }, + {#State 221 + DEFAULT => -81 + }, + {#State 222 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -45 + }, + {#State 223 + DEFAULT => -66 + }, + {#State 224 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -61 + }, + {#State 225 + DEFAULT => -144 + }, + {#State 226 + DEFAULT => -145 + }, + {#State 227 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 284, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 228 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 285, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 229 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -151 + }, + {#State 230 + ACTIONS => { + 'DOT' => 104 + }, + DEFAULT => -177 + }, + {#State 231 + DEFAULT => -178 + }, + {#State 232 + DEFAULT => -175 + }, + {#State 233 + DEFAULT => -179 + }, + {#State 234 + DEFAULT => -111 + }, + {#State 235 + ACTIONS => { + 'DIV' => 159, + 'MOD' => 165, + "/" => 166 + }, + DEFAULT => -135 + }, + {#State 236 + ACTIONS => { + ":" => 286, + 'CMPOP' => 164, + "?" => 158, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 237 + ACTIONS => { + 'MOD' => 165 + }, + DEFAULT => -136 + }, + {#State 238 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -140 + }, + {#State 239 + ACTIONS => { + "+" => 157, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166 + }, + DEFAULT => -133 + }, + {#State 240 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -141 + }, + {#State 241 + ACTIONS => { + "+" => 157, + 'CMPOP' => 164, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -139 + }, + {#State 242 + ACTIONS => { + "+" => 157, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'BINOP' => 161 + }, + DEFAULT => -138 + }, + {#State 243 + DEFAULT => -137 + }, + {#State 244 + ACTIONS => { + 'DIV' => 159, + 'MOD' => 165 + }, + DEFAULT => -134 + }, + {#State 245 + DEFAULT => -59, + GOTOS => { + '@2-3' => 287 + } + }, + {#State 246 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -150 + }, + {#State 247 + ACTIONS => { + 'ELSIF' => 290, + 'ELSE' => 288 + }, + DEFAULT => -50, + GOTOS => { + 'else' => 289 + } + }, + {#State 248 + DEFAULT => -170 + }, + {#State 249 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -162, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 250 + DEFAULT => -167 + }, + {#State 251 + DEFAULT => -165 + }, + {#State 252 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + ")" => 291, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 253 + ACTIONS => { + 'DOT' => 104, + 'ASSIGN' => 292 + }, + DEFAULT => -109 + }, + {#State 254 + ACTIONS => { + "(" => 135, + 'ASSIGN' => 210 + }, + DEFAULT => -128 + }, + {#State 255 + DEFAULT => -153 + }, + {#State 256 + ACTIONS => { + 'ASSIGN' => 213 + }, + DEFAULT => -112 + }, + {#State 257 + DEFAULT => -152 + }, + {#State 258 + DEFAULT => -155 + }, + {#State 259 + DEFAULT => -117 + }, + {#State 260 + ACTIONS => { + ";" => 293 + } + }, + {#State 261 + ACTIONS => { + 'END' => 294 + } + }, + {#State 262 + ACTIONS => { + ";" => 296, + 'DEFAULT' => 297, + 'FILENAME' => 83, + 'IDENT' => 81, + 'NUMBER' => 84 + }, + GOTOS => { + 'filepart' => 87, + 'filename' => 295 + } + }, + {#State 263 + ACTIONS => { + 'END' => 298 + } + }, + {#State 264 + DEFAULT => -102 + }, + {#State 265 + DEFAULT => -100 + }, + {#State 266 + ACTIONS => { + 'TEXT' => 299 + } + }, + {#State 267 + ACTIONS => { + 'END' => 300 + } + }, + {#State 268 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 301, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 269 + ACTIONS => { + 'COMMA' => -96, + 'IDENT' => -96, + ")" => -96 + }, + DEFAULT => -130 + }, + {#State 270 + ACTIONS => { + 'COMMA' => 304, + 'IDENT' => 302, + ")" => 303 + } + }, + {#State 271 + DEFAULT => -156, + GOTOS => { + 'args' => 305 + } + }, + {#State 272 + DEFAULT => -156, + GOTOS => { + 'args' => 306 + } + }, + {#State 273 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 307, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 274 + DEFAULT => -157 + }, + {#State 275 + ACTIONS => { + 'END' => 308 + } + }, + {#State 276 + ACTIONS => { + 'ASSIGN' => -160 + }, + DEFAULT => -167 + }, + {#State 277 + ACTIONS => { + 'END' => 309 + } + }, + {#State 278 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -124 + }, + {#State 279 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -123 + }, + {#State 280 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 310, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 281 + DEFAULT => -129 + }, + {#State 282 + ACTIONS => { + 'END' => 311 + } + }, + {#State 283 + ACTIONS => { + 'ELSIF' => 290, + 'ELSE' => 288 + }, + DEFAULT => -50, + GOTOS => { + 'else' => 312 + } + }, + {#State 284 + ACTIONS => { + 'CASE' => 313 + }, + DEFAULT => -55, + GOTOS => { + 'case' => 314 + } + }, + {#State 285 + ACTIONS => { + 'END' => 315 + } + }, + {#State 286 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 316, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 287 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 317, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 288 + ACTIONS => { + ";" => 318 + } + }, + {#State 289 + ACTIONS => { + 'END' => 319 + } + }, + {#State 290 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 320, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 291 + DEFAULT => -164 + }, + {#State 292 + ACTIONS => { + 'NOT' => 38, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "(" => 53, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'expr' => 321, + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 58, + 'lterm' => 56 + } + }, + {#State 293 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 322, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 294 + DEFAULT => -67 + }, + {#State 295 + ACTIONS => { + 'DOT' => 174, + ";" => 323 + } + }, + {#State 296 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 324, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 297 + ACTIONS => { + ";" => 325 + } + }, + {#State 298 + DEFAULT => -79 + }, + {#State 299 + ACTIONS => { + "\"" => 326 + } + }, + {#State 300 + DEFAULT => -82 + }, + {#State 301 + ACTIONS => { + 'END' => 327 + } + }, + {#State 302 + DEFAULT => -94 + }, + {#State 303 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'WRAPPER' => 55, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + "\"" => 60, + 'PROCESS' => 61, + 'FILTER' => 25, + 'RETURN' => 64, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 193, + 'DEFAULT' => 69, + "{" => 30, + "\${" => 37 + }, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'term' => 58, + 'loop' => 4, + 'expr' => 199, + 'wrapper' => 46, + 'atomexpr' => 48, + 'atomdir' => 12, + 'mdir' => 328, + 'sterm' => 68, + 'filter' => 29, + 'ident' => 149, + 'perl' => 31, + 'setlist' => 70, + 'switch' => 34, + 'try' => 35, + 'assign' => 19, + 'directive' => 196, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 304 + DEFAULT => -95 + }, + {#State 305 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -62, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 306 + ACTIONS => { + "{" => 30, + 'COMMA' => 258, + 'LITERAL' => 256, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + DEFAULT => -63, + GOTOS => { + 'sterm' => 68, + 'item' => 254, + 'param' => 255, + 'node' => 23, + 'ident' => 253, + 'term' => 257, + 'lterm' => 56 + } + }, + {#State 307 + ACTIONS => { + 'END' => 329 + } + }, + {#State 308 + DEFAULT => -80 + }, + {#State 309 + DEFAULT => -88 + }, + {#State 310 + ACTIONS => { + 'END' => 330 + } + }, + {#State 311 + DEFAULT => -77 + }, + {#State 312 + ACTIONS => { + 'END' => 331 + } + }, + {#State 313 + ACTIONS => { + ";" => 332, + 'DEFAULT' => 334, + "{" => 30, + 'LITERAL' => 78, + 'IDENT' => 2, + "\"" => 60, + "\$" => 43, + "[" => 9, + 'NUMBER' => 26, + 'REF' => 27, + "\${" => 37 + }, + GOTOS => { + 'sterm' => 68, + 'item' => 39, + 'node' => 23, + 'ident' => 77, + 'term' => 333, + 'lterm' => 56 + } + }, + {#State 314 + ACTIONS => { + 'END' => 335 + } + }, + {#State 315 + DEFAULT => -65 + }, + {#State 316 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -143 + }, + {#State 317 + ACTIONS => { + 'END' => 336 + } + }, + {#State 318 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 337, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 319 + DEFAULT => -46 + }, + {#State 320 + ACTIONS => { + 'CMPOP' => 164, + "?" => 158, + ";" => 338, + "+" => 157, + 'MOD' => 165, + 'DIV' => 159, + "/" => 166, + 'AND' => 160, + 'CAT' => 163, + 'BINOP' => 161, + 'OR' => 162 + } + }, + {#State 321 + ACTIONS => { + "+" => 157, + 'CAT' => 163, + 'CMPOP' => 164, + "?" => 158, + 'DIV' => 159, + 'MOD' => 165, + "/" => 166, + 'AND' => 160, + 'BINOP' => 161, + 'OR' => 162 + }, + DEFAULT => -154 + }, + {#State 322 + DEFAULT => -71 + }, + {#State 323 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 339, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 324 + ACTIONS => { + 'FINAL' => 260, + 'CATCH' => 262 + }, + DEFAULT => -72, + GOTOS => { + 'final' => 340 + } + }, + {#State 325 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 341, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 326 + DEFAULT => -101 + }, + {#State 327 + DEFAULT => -93 + }, + {#State 328 + DEFAULT => -90 + }, + {#State 329 + DEFAULT => -57 + }, + {#State 330 + DEFAULT => -75 + }, + {#State 331 + DEFAULT => -44 + }, + {#State 332 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 342, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 333 + ACTIONS => { + ";" => 343 + } + }, + {#State 334 + ACTIONS => { + ";" => 344 + } + }, + {#State 335 + DEFAULT => -51 + }, + {#State 336 + DEFAULT => -60 + }, + {#State 337 + DEFAULT => -49 + }, + {#State 338 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 345, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 339 + ACTIONS => { + 'FINAL' => 260, + 'CATCH' => 262 + }, + DEFAULT => -72, + GOTOS => { + 'final' => 346 + } + }, + {#State 340 + DEFAULT => -70 + }, + {#State 341 + ACTIONS => { + 'FINAL' => 260, + 'CATCH' => 262 + }, + DEFAULT => -72, + GOTOS => { + 'final' => 347 + } + }, + {#State 342 + DEFAULT => -54 + }, + {#State 343 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 348, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 344 + ACTIONS => { + 'SET' => 1, + 'PERL' => 40, + 'NOT' => 38, + 'IDENT' => 2, + 'CLEAR' => 41, + 'UNLESS' => 3, + 'IF' => 44, + "\$" => 43, + 'STOP' => 6, + 'CALL' => 45, + 'THROW' => 8, + 'GET' => 47, + "[" => 9, + 'TRY' => 10, + 'LAST' => 49, + 'DEBUG' => 51, + 'RAWPERL' => 13, + 'META' => 15, + 'INCLUDE' => 17, + "(" => 53, + 'SWITCH' => 54, + 'MACRO' => 18, + 'WRAPPER' => 55, + ";" => -18, + 'FOR' => 21, + 'NEXT' => 22, + 'LITERAL' => 57, + 'TEXT' => 24, + "\"" => 60, + 'PROCESS' => 61, + 'RETURN' => 64, + 'FILTER' => 25, + 'INSERT' => 65, + 'NUMBER' => 26, + 'REF' => 27, + 'WHILE' => 67, + 'BLOCK' => 28, + 'DEFAULT' => 69, + "{" => 30, + 'USE' => 32, + 'VIEW' => 36, + "\${" => 37 + }, + DEFAULT => -3, + GOTOS => { + 'item' => 39, + 'node' => 23, + 'rawperl' => 59, + 'term' => 58, + 'loop' => 4, + 'use' => 63, + 'expr' => 62, + 'capture' => 42, + 'statement' => 5, + 'view' => 7, + 'wrapper' => 46, + 'atomexpr' => 48, + 'chunk' => 11, + 'defblock' => 66, + 'atomdir' => 12, + 'anonblock' => 50, + 'sterm' => 68, + 'defblockname' => 14, + 'filter' => 29, + 'ident' => 16, + 'perl' => 31, + 'setlist' => 70, + 'chunks' => 33, + 'try' => 35, + 'switch' => 34, + 'assign' => 19, + 'block' => 349, + 'directive' => 71, + 'macro' => 20, + 'condition' => 73, + 'lterm' => 56 + } + }, + {#State 345 + ACTIONS => { + 'ELSIF' => 290, + 'ELSE' => 288 + }, + DEFAULT => -50, + GOTOS => { + 'else' => 350 + } + }, + {#State 346 + DEFAULT => -68 + }, + {#State 347 + DEFAULT => -69 + }, + {#State 348 + ACTIONS => { + 'CASE' => 313 + }, + DEFAULT => -55, + GOTOS => { + 'case' => 351 + } + }, + {#State 349 + DEFAULT => -53 + }, + {#State 350 + DEFAULT => -48 + }, + {#State 351 + DEFAULT => -52 + } +]; + + +#======================================================================== +# Rules +#======================================================================== + +$RULES = [ + [#Rule 0 + '$start', 2, undef + ], + [#Rule 1 + 'template', 1, +sub +#line 64 "Parser.yp" +{ $factory->template($_[1]) } + ], + [#Rule 2 + 'block', 1, +sub +#line 67 "Parser.yp" +{ $factory->block($_[1]) } + ], + [#Rule 3 + 'block', 0, +sub +#line 68 "Parser.yp" +{ $factory->block() } + ], + [#Rule 4 + 'chunks', 2, +sub +#line 71 "Parser.yp" +{ push(@{$_[1]}, $_[2]) + if defined $_[2]; $_[1] } + ], + [#Rule 5 + 'chunks', 1, +sub +#line 73 "Parser.yp" +{ defined $_[1] ? [ $_[1] ] : [ ] } + ], + [#Rule 6 + 'chunk', 1, +sub +#line 76 "Parser.yp" +{ $factory->textblock($_[1]) } + ], + [#Rule 7 + 'chunk', 2, undef + ], + [#Rule 8 + 'statement', 1, undef + ], + [#Rule 9 + 'statement', 1, undef + ], + [#Rule 10 + 'statement', 1, undef + ], + [#Rule 11 + 'statement', 1, undef + ], + [#Rule 12 + 'statement', 1, undef + ], + [#Rule 13 + 'statement', 1, undef + ], + [#Rule 14 + 'statement', 1, undef + ], + [#Rule 15 + 'statement', 1, undef + ], + [#Rule 16 + 'statement', 1, +sub +#line 89 "Parser.yp" +{ $factory->get($_[1]) } + ], + [#Rule 17 + 'statement', 2, +sub +#line 90 "Parser.yp" +{ $_[0]->add_metadata($_[2]); } + ], + [#Rule 18 + 'statement', 0, undef + ], + [#Rule 19 + 'directive', 1, +sub +#line 94 "Parser.yp" +{ $factory->set($_[1]) } + ], + [#Rule 20 + 'directive', 1, undef + ], + [#Rule 21 + 'directive', 1, undef + ], + [#Rule 22 + 'directive', 1, undef + ], + [#Rule 23 + 'directive', 1, undef + ], + [#Rule 24 + 'directive', 1, undef + ], + [#Rule 25 + 'directive', 1, undef + ], + [#Rule 26 + 'atomexpr', 1, +sub +#line 108 "Parser.yp" +{ $factory->get($_[1]) } + ], + [#Rule 27 + 'atomexpr', 1, undef + ], + [#Rule 28 + 'atomdir', 2, +sub +#line 112 "Parser.yp" +{ $factory->get($_[2]) } + ], + [#Rule 29 + 'atomdir', 2, +sub +#line 113 "Parser.yp" +{ $factory->call($_[2]) } + ], + [#Rule 30 + 'atomdir', 2, +sub +#line 114 "Parser.yp" +{ $factory->set($_[2]) } + ], + [#Rule 31 + 'atomdir', 2, +sub +#line 115 "Parser.yp" +{ $factory->default($_[2]) } + ], + [#Rule 32 + 'atomdir', 2, +sub +#line 116 "Parser.yp" +{ $factory->insert($_[2]) } + ], + [#Rule 33 + 'atomdir', 2, +sub +#line 117 "Parser.yp" +{ $factory->include($_[2]) } + ], + [#Rule 34 + 'atomdir', 2, +sub +#line 118 "Parser.yp" +{ $factory->process($_[2]) } + ], + [#Rule 35 + 'atomdir', 2, +sub +#line 119 "Parser.yp" +{ $factory->throw($_[2]) } + ], + [#Rule 36 + 'atomdir', 1, +sub +#line 120 "Parser.yp" +{ $factory->return() } + ], + [#Rule 37 + 'atomdir', 1, +sub +#line 121 "Parser.yp" +{ $factory->stop() } + ], + [#Rule 38 + 'atomdir', 1, +sub +#line 122 "Parser.yp" +{ "\$output = '';"; } + ], + [#Rule 39 + 'atomdir', 1, +sub +#line 123 "Parser.yp" +{ $_[0]->{ INFOR } || $_[0]->{ INWHILE } + ? 'last LOOP;' + : 'last;' } + ], + [#Rule 40 + 'atomdir', 1, +sub +#line 126 "Parser.yp" +{ $_[0]->{ INFOR } + ? $factory->next() + : ($_[0]->{ INWHILE } + ? 'next LOOP;' + : 'next;') } + ], + [#Rule 41 + 'atomdir', 2, +sub +#line 131 "Parser.yp" +{ if ($_[2]->[0]->[0] =~ /^'(on|off)'$/) { + $_[0]->{ DEBUG_DIRS } = ($1 eq 'on'); + $factory->debug($_[2]); + } + else { + $_[0]->{ DEBUG_DIRS } ? $factory->debug($_[2]) : ''; + } + } + ], + [#Rule 42 + 'atomdir', 1, undef + ], + [#Rule 43 + 'atomdir', 1, undef + ], + [#Rule 44 + 'condition', 6, +sub +#line 144 "Parser.yp" +{ $factory->if(@_[2, 4, 5]) } + ], + [#Rule 45 + 'condition', 3, +sub +#line 145 "Parser.yp" +{ $factory->if(@_[3, 1]) } + ], + [#Rule 46 + 'condition', 6, +sub +#line 147 "Parser.yp" +{ $factory->if("!($_[2])", @_[4, 5]) } + ], + [#Rule 47 + 'condition', 3, +sub +#line 148 "Parser.yp" +{ $factory->if("!($_[3])", $_[1]) } + ], + [#Rule 48 + 'else', 5, +sub +#line 152 "Parser.yp" +{ unshift(@{$_[5]}, [ @_[2, 4] ]); + $_[5]; } + ], + [#Rule 49 + 'else', 3, +sub +#line 154 "Parser.yp" +{ [ $_[3] ] } + ], + [#Rule 50 + 'else', 0, +sub +#line 155 "Parser.yp" +{ [ undef ] } + ], + [#Rule 51 + 'switch', 6, +sub +#line 159 "Parser.yp" +{ $factory->switch(@_[2, 5]) } + ], + [#Rule 52 + 'case', 5, +sub +#line 163 "Parser.yp" +{ unshift(@{$_[5]}, [ @_[2, 4] ]); + $_[5]; } + ], + [#Rule 53 + 'case', 4, +sub +#line 165 "Parser.yp" +{ [ $_[4] ] } + ], + [#Rule 54 + 'case', 3, +sub +#line 166 "Parser.yp" +{ [ $_[3] ] } + ], + [#Rule 55 + 'case', 0, +sub +#line 167 "Parser.yp" +{ [ undef ] } + ], + [#Rule 56 + '@1-3', 0, +sub +#line 170 "Parser.yp" +{ $_[0]->{ INFOR }++ } + ], + [#Rule 57 + 'loop', 6, +sub +#line 171 "Parser.yp" +{ $_[0]->{ INFOR }--; + $factory->foreach(@{$_[2]}, $_[5]) } + ], + [#Rule 58 + 'loop', 3, +sub +#line 175 "Parser.yp" +{ $factory->foreach(@{$_[3]}, $_[1]) } + ], + [#Rule 59 + '@2-3', 0, +sub +#line 176 "Parser.yp" +{ $_[0]->{ INWHILE }++ } + ], + [#Rule 60 + 'loop', 6, +sub +#line 177 "Parser.yp" +{ $_[0]->{ INWHILE }--; + $factory->while(@_[2, 5]) } + ], + [#Rule 61 + 'loop', 3, +sub +#line 179 "Parser.yp" +{ $factory->while(@_[3, 1]) } + ], + [#Rule 62 + 'loopvar', 4, +sub +#line 182 "Parser.yp" +{ [ @_[1, 3, 4] ] } + ], + [#Rule 63 + 'loopvar', 4, +sub +#line 183 "Parser.yp" +{ [ @_[1, 3, 4] ] } + ], + [#Rule 64 + 'loopvar', 2, +sub +#line 184 "Parser.yp" +{ [ 0, @_[1, 2] ] } + ], + [#Rule 65 + 'wrapper', 5, +sub +#line 188 "Parser.yp" +{ $factory->wrapper(@_[2, 4]) } + ], + [#Rule 66 + 'wrapper', 3, +sub +#line 190 "Parser.yp" +{ $factory->wrapper(@_[3, 1]) } + ], + [#Rule 67 + 'try', 5, +sub +#line 194 "Parser.yp" +{ $factory->try(@_[3, 4]) } + ], + [#Rule 68 + 'final', 5, +sub +#line 198 "Parser.yp" +{ unshift(@{$_[5]}, [ @_[2,4] ]); + $_[5]; } + ], + [#Rule 69 + 'final', 5, +sub +#line 201 "Parser.yp" +{ unshift(@{$_[5]}, [ undef, $_[4] ]); + $_[5]; } + ], + [#Rule 70 + 'final', 4, +sub +#line 204 "Parser.yp" +{ unshift(@{$_[4]}, [ undef, $_[3] ]); + $_[4]; } + ], + [#Rule 71 + 'final', 3, +sub +#line 206 "Parser.yp" +{ [ $_[3] ] } + ], + [#Rule 72 + 'final', 0, +sub +#line 207 "Parser.yp" +{ [ 0 ] } + ], + [#Rule 73 + 'use', 2, +sub +#line 210 "Parser.yp" +{ $factory->use($_[2]) } + ], + [#Rule 74 + '@3-3', 0, +sub +#line 213 "Parser.yp" +{ $_[0]->push_defblock(); } + ], + [#Rule 75 + 'view', 6, +sub +#line 214 "Parser.yp" +{ $factory->view(@_[2,5], + $_[0]->pop_defblock) } + ], + [#Rule 76 + '@4-2', 0, +sub +#line 218 "Parser.yp" +{ ${$_[0]->{ INPERL }}++; } + ], + [#Rule 77 + 'perl', 5, +sub +#line 219 "Parser.yp" +{ ${$_[0]->{ INPERL }}--; + $_[0]->{ EVAL_PERL } + ? $factory->perl($_[4]) + : $factory->no_perl(); } + ], + [#Rule 78 + '@5-1', 0, +sub +#line 225 "Parser.yp" +{ ${$_[0]->{ INPERL }}++; + $rawstart = ${$_[0]->{'LINE'}}; } + ], + [#Rule 79 + 'rawperl', 5, +sub +#line 227 "Parser.yp" +{ ${$_[0]->{ INPERL }}--; + $_[0]->{ EVAL_PERL } + ? $factory->rawperl($_[4], $rawstart) + : $factory->no_perl(); } + ], + [#Rule 80 + 'filter', 5, +sub +#line 234 "Parser.yp" +{ $factory->filter(@_[2,4]) } + ], + [#Rule 81 + 'filter', 3, +sub +#line 236 "Parser.yp" +{ $factory->filter(@_[3,1]) } + ], + [#Rule 82 + 'defblock', 5, +sub +#line 241 "Parser.yp" +{ my $name = join('/', @{ $_[0]->{ DEFBLOCKS } }); + pop(@{ $_[0]->{ DEFBLOCKS } }); + $_[0]->define_block($name, $_[4]); + undef + } + ], + [#Rule 83 + 'defblockname', 2, +sub +#line 248 "Parser.yp" +{ push(@{ $_[0]->{ DEFBLOCKS } }, $_[2]); + $_[2]; + } + ], + [#Rule 84 + 'blockname', 1, undef + ], + [#Rule 85 + 'blockname', 1, +sub +#line 254 "Parser.yp" +{ $_[1] =~ s/^'(.*)'$/$1/; $_[1] } + ], + [#Rule 86 + 'blockargs', 1, undef + ], + [#Rule 87 + 'blockargs', 0, undef + ], + [#Rule 88 + 'anonblock', 5, +sub +#line 262 "Parser.yp" +{ local $" = ', '; + print STDERR "experimental block args: [@{ $_[2] }]\n" + if $_[2]; + $factory->anon_block($_[4]) } + ], + [#Rule 89 + 'capture', 3, +sub +#line 268 "Parser.yp" +{ $factory->capture(@_[1, 3]) } + ], + [#Rule 90 + 'macro', 6, +sub +#line 272 "Parser.yp" +{ $factory->macro(@_[2, 6, 4]) } + ], + [#Rule 91 + 'macro', 3, +sub +#line 273 "Parser.yp" +{ $factory->macro(@_[2, 3]) } + ], + [#Rule 92 + 'mdir', 1, undef + ], + [#Rule 93 + 'mdir', 4, +sub +#line 277 "Parser.yp" +{ $_[3] } + ], + [#Rule 94 + 'margs', 2, +sub +#line 280 "Parser.yp" +{ push(@{$_[1]}, $_[2]); $_[1] } + ], + [#Rule 95 + 'margs', 2, +sub +#line 281 "Parser.yp" +{ $_[1] } + ], + [#Rule 96 + 'margs', 1, +sub +#line 282 "Parser.yp" +{ [ $_[1] ] } + ], + [#Rule 97 + 'metadata', 2, +sub +#line 285 "Parser.yp" +{ push(@{$_[1]}, @{$_[2]}); $_[1] } + ], + [#Rule 98 + 'metadata', 2, undef + ], + [#Rule 99 + 'metadata', 1, undef + ], + [#Rule 100 + 'meta', 3, +sub +#line 290 "Parser.yp" +{ for ($_[3]) { s/^'//; s/'$//; + s/\\'/'/g }; + [ @_[1,3] ] } + ], + [#Rule 101 + 'meta', 5, +sub +#line 293 "Parser.yp" +{ [ @_[1,4] ] } + ], + [#Rule 102 + 'meta', 3, +sub +#line 294 "Parser.yp" +{ [ @_[1,3] ] } + ], + [#Rule 103 + 'term', 1, undef + ], + [#Rule 104 + 'term', 1, undef + ], + [#Rule 105 + 'lterm', 3, +sub +#line 306 "Parser.yp" +{ "[ $_[2] ]" } + ], + [#Rule 106 + 'lterm', 3, +sub +#line 307 "Parser.yp" +{ "[ $_[2] ]" } + ], + [#Rule 107 + 'lterm', 2, +sub +#line 308 "Parser.yp" +{ "[ ]" } + ], + [#Rule 108 + 'lterm', 3, +sub +#line 309 "Parser.yp" +{ "{ $_[2] }" } + ], + [#Rule 109 + 'sterm', 1, +sub +#line 312 "Parser.yp" +{ $factory->ident($_[1]) } + ], + [#Rule 110 + 'sterm', 2, +sub +#line 313 "Parser.yp" +{ $factory->identref($_[2]) } + ], + [#Rule 111 + 'sterm', 3, +sub +#line 314 "Parser.yp" +{ $factory->quoted($_[2]) } + ], + [#Rule 112 + 'sterm', 1, undef + ], + [#Rule 113 + 'sterm', 1, undef + ], + [#Rule 114 + 'list', 2, +sub +#line 319 "Parser.yp" +{ "$_[1], $_[2]" } + ], + [#Rule 115 + 'list', 2, undef + ], + [#Rule 116 + 'list', 1, undef + ], + [#Rule 117 + 'range', 3, +sub +#line 324 "Parser.yp" +{ $_[1] . '..' . $_[3] } + ], + [#Rule 118 + 'hash', 1, undef + ], + [#Rule 119 + 'hash', 0, +sub +#line 329 "Parser.yp" +{ "" } + ], + [#Rule 120 + 'params', 2, +sub +#line 332 "Parser.yp" +{ "$_[1], $_[2]" } + ], + [#Rule 121 + 'params', 2, undef + ], + [#Rule 122 + 'params', 1, undef + ], + [#Rule 123 + 'param', 3, +sub +#line 337 "Parser.yp" +{ "$_[1] => $_[3]" } + ], + [#Rule 124 + 'param', 3, +sub +#line 338 "Parser.yp" +{ "$_[1] => $_[3]" } + ], + [#Rule 125 + 'ident', 3, +sub +#line 341 "Parser.yp" +{ push(@{$_[1]}, @{$_[3]}); $_[1] } + ], + [#Rule 126 + 'ident', 3, +sub +#line 342 "Parser.yp" +{ push(@{$_[1]}, + map {($_, 0)} split(/\./, $_[3])); + $_[1]; } + ], + [#Rule 127 + 'ident', 1, undef + ], + [#Rule 128 + 'node', 1, +sub +#line 348 "Parser.yp" +{ [ $_[1], 0 ] } + ], + [#Rule 129 + 'node', 4, +sub +#line 349 "Parser.yp" +{ [ $_[1], $factory->args($_[3]) ] } + ], + [#Rule 130 + 'item', 1, +sub +#line 352 "Parser.yp" +{ "'$_[1]'" } + ], + [#Rule 131 + 'item', 3, +sub +#line 353 "Parser.yp" +{ $_[2] } + ], + [#Rule 132 + 'item', 2, +sub +#line 354 "Parser.yp" +{ $_[0]->{ V1DOLLAR } + ? "'$_[2]'" + : $factory->ident(["'$_[2]'", 0]) } + ], + [#Rule 133 + 'expr', 3, +sub +#line 359 "Parser.yp" +{ "$_[1] $_[2] $_[3]" } + ], + [#Rule 134 + 'expr', 3, +sub +#line 360 "Parser.yp" +{ "$_[1] $_[2] $_[3]" } + ], + [#Rule 135 + 'expr', 3, +sub +#line 361 "Parser.yp" +{ "$_[1] $_[2] $_[3]" } + ], + [#Rule 136 + 'expr', 3, +sub +#line 362 "Parser.yp" +{ "int($_[1] / $_[3])" } + ], + [#Rule 137 + 'expr', 3, +sub +#line 363 "Parser.yp" +{ "$_[1] % $_[3]" } + ], + [#Rule 138 + 'expr', 3, +sub +#line 364 "Parser.yp" +{ "$_[1] $CMPOP{ $_[2] } $_[3]" } + ], + [#Rule 139 + 'expr', 3, +sub +#line 365 "Parser.yp" +{ "$_[1] . $_[3]" } + ], + [#Rule 140 + 'expr', 3, +sub +#line 366 "Parser.yp" +{ "$_[1] && $_[3]" } + ], + [#Rule 141 + 'expr', 3, +sub +#line 367 "Parser.yp" +{ "$_[1] || $_[3]" } + ], + [#Rule 142 + 'expr', 2, +sub +#line 368 "Parser.yp" +{ "! $_[2]" } + ], + [#Rule 143 + 'expr', 5, +sub +#line 369 "Parser.yp" +{ "$_[1] ? $_[3] : $_[5]" } + ], + [#Rule 144 + 'expr', 3, +sub +#line 370 "Parser.yp" +{ $factory->assign(@{$_[2]}) } + ], + [#Rule 145 + 'expr', 3, +sub +#line 371 "Parser.yp" +{ "($_[2])" } + ], + [#Rule 146 + 'expr', 1, undef + ], + [#Rule 147 + 'setlist', 2, +sub +#line 375 "Parser.yp" +{ push(@{$_[1]}, @{$_[2]}); $_[1] } + ], + [#Rule 148 + 'setlist', 2, undef + ], + [#Rule 149 + 'setlist', 1, undef + ], + [#Rule 150 + 'assign', 3, +sub +#line 381 "Parser.yp" +{ [ $_[1], $_[3] ] } + ], + [#Rule 151 + 'assign', 3, +sub +#line 382 "Parser.yp" +{ [ @_[1,3] ] } + ], + [#Rule 152 + 'args', 2, +sub +#line 389 "Parser.yp" +{ push(@{$_[1]}, $_[2]); $_[1] } + ], + [#Rule 153 + 'args', 2, +sub +#line 390 "Parser.yp" +{ push(@{$_[1]->[0]}, $_[2]); $_[1] } + ], + [#Rule 154 + 'args', 4, +sub +#line 391 "Parser.yp" +{ push(@{$_[1]->[0]}, "'', " . + $factory->assign(@_[2,4])); $_[1] } + ], + [#Rule 155 + 'args', 2, +sub +#line 393 "Parser.yp" +{ $_[1] } + ], + [#Rule 156 + 'args', 0, +sub +#line 394 "Parser.yp" +{ [ [ ] ] } + ], + [#Rule 157 + 'lnameargs', 3, +sub +#line 404 "Parser.yp" +{ push(@{$_[3]}, $_[1]); $_[3] } + ], + [#Rule 158 + 'lnameargs', 1, undef + ], + [#Rule 159 + 'lvalue', 1, undef + ], + [#Rule 160 + 'lvalue', 3, +sub +#line 409 "Parser.yp" +{ $factory->quoted($_[2]) } + ], + [#Rule 161 + 'lvalue', 1, undef + ], + [#Rule 162 + 'nameargs', 3, +sub +#line 413 "Parser.yp" +{ [ [$factory->ident($_[2])], $_[3] ] } + ], + [#Rule 163 + 'nameargs', 2, +sub +#line 414 "Parser.yp" +{ [ @_[1,2] ] } + ], + [#Rule 164 + 'nameargs', 4, +sub +#line 415 "Parser.yp" +{ [ @_[1,3] ] } + ], + [#Rule 165 + 'names', 3, +sub +#line 418 "Parser.yp" +{ push(@{$_[1]}, $_[3]); $_[1] } + ], + [#Rule 166 + 'names', 1, +sub +#line 419 "Parser.yp" +{ [ $_[1] ] } + ], + [#Rule 167 + 'name', 3, +sub +#line 422 "Parser.yp" +{ $factory->quoted($_[2]) } + ], + [#Rule 168 + 'name', 1, +sub +#line 423 "Parser.yp" +{ "'$_[1]'" } + ], + [#Rule 169 + 'name', 1, undef + ], + [#Rule 170 + 'filename', 3, +sub +#line 435 "Parser.yp" +{ "$_[1].$_[3]" } + ], + [#Rule 171 + 'filename', 1, undef + ], + [#Rule 172 + 'filepart', 1, undef + ], + [#Rule 173 + 'filepart', 1, undef + ], + [#Rule 174 + 'filepart', 1, undef + ], + [#Rule 175 + 'quoted', 2, +sub +#line 449 "Parser.yp" +{ push(@{$_[1]}, $_[2]) + if defined $_[2]; $_[1] } + ], + [#Rule 176 + 'quoted', 0, +sub +#line 451 "Parser.yp" +{ [ ] } + ], + [#Rule 177 + 'quotable', 1, +sub +#line 454 "Parser.yp" +{ $factory->ident($_[1]) } + ], + [#Rule 178 + 'quotable', 1, +sub +#line 455 "Parser.yp" +{ $factory->text($_[1]) } + ], + [#Rule 179 + 'quotable', 1, +sub +#line 456 "Parser.yp" +{ undef } + ] +]; + + + +1; + + + + + + + + + + + + diff --git a/lib/Template/Iterator.pm b/lib/Template/Iterator.pm new file mode 100644 index 0000000..0063b6e --- /dev/null +++ b/lib/Template/Iterator.pm @@ -0,0 +1,446 @@ +#============================================================= -*-Perl-*- +# +# Template::Iterator +# +# DESCRIPTION +# +# Module defining an iterator class which is used by the FOREACH +# directive for iterating through data sets. This may be +# sub-classed to define more specific iterator types. +# +# An iterator is an object which provides a consistent way to +# navigate through data which may have a complex underlying form. +# This implementation uses the get_first() and get_next() methods to +# iterate through a dataset. The get_first() method is called once +# to perform any data initialisation and return the first value, +# then get_next() is called repeatedly to return successive values. +# Both these methods return a pair of values which are the data item +# itself and a status code. The default implementation handles +# iteration through an array (list) of elements which is passed by +# reference to the constructor. An empty list is used if none is +# passed. The module may be sub-classed to provide custom +# implementations which iterate through any kind of data in any +# manner as long as it can conforms to the get_first()/get_next() +# interface. The object also implements the get_all() method for +# returning all remaining elements as a list reference. +# +# For further information on iterators see "Design Patterns", by the +# "Gang of Four" (Erich Gamma, Richard Helm, Ralph Johnson, John +# Vlissides), Addision-Wesley, ISBN 0-201-63361-2. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Iterator.pm,v 2.59 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Iterator; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $AUTOLOAD ); # AUTO? +use base qw( Template::Base ); +use Template::Constants; +use Template::Exception; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.59 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\@target, \%options) +# +# Constructor method which creates and returns a reference to a new +# Template::Iterator object. A reference to the target data (array +# or hash) may be passed for the object to iterate through. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my $data = shift || [ ]; + my $params = shift || { }; + + if (ref $data eq 'HASH') { + # map a hash into a list of { key => ???, value => ??? } hashes, + # one for each key, sorted by keys + $data = [ map { { key => $_, value => $data->{ $_ } } } + sort keys %$data ]; + } + elsif (UNIVERSAL::can($data, 'as_list')) { + $data = $data->as_list(); + } + elsif (ref $data ne 'ARRAY') { + # coerce any non-list data into an array reference + $data = [ $data ] ; + } + + bless { + _DATA => $data, + _ERROR => '', + }, $class; +} + + +#======================================================================== +# ----- PUBLIC OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# get_first() +# +# Initialises the object for iterating through the target data set. The +# first record is returned, if defined, along with the STATUS_OK value. +# If there is no target data, or the data is an empty set, then undef +# is returned with the STATUS_DONE value. +#------------------------------------------------------------------------ + +sub get_first { + my $self = shift; + my $data = $self->{ _DATA }; + + $self->{ _DATASET } = $self->{ _DATA }; + my $size = scalar @$data; + my $index = 0; + + return (undef, Template::Constants::STATUS_DONE) unless $size; + + # initialise various counters, flags, etc. + @$self{ qw( SIZE MAX INDEX COUNT FIRST LAST ) } + = ( $size, $size - 1, $index, 1, 1, $size > 1 ? 0 : 1, undef ); + @$self{ qw( PREV NEXT ) } = ( undef, $self->{ _DATASET }->[ $index + 1 ]); + + return $self->{ _DATASET }->[ $index ]; +} + + + +#------------------------------------------------------------------------ +# get_next() +# +# Called repeatedly to access successive elements in the data set. +# Should only be called after calling get_first() or a warning will +# be raised and (undef, STATUS_DONE) returned. +#------------------------------------------------------------------------ + +sub get_next { + my $self = shift; + my ($max, $index) = @$self{ qw( MAX INDEX ) }; + my $data = $self->{ _DATASET }; + + # warn about incorrect usage + unless (defined $index) { + my ($pack, $file, $line) = caller(); + warn("iterator get_next() called before get_first() at $file line $line\n"); + return (undef, Template::Constants::STATUS_DONE); ## RETURN ## + } + + # if there's still some data to go... + if ($index < $max) { + # update counters and flags + $index++; + @$self{ qw( INDEX COUNT FIRST LAST ) } + = ( $index, $index + 1, 0, $index == $max ? 1 : 0 ); + @$self{ qw( PREV NEXT ) } = @$data[ $index - 1, $index + 1 ]; + return $data->[ $index ]; ## RETURN ## + } + else { + return (undef, Template::Constants::STATUS_DONE); ## RETURN ## + } +} + + +#------------------------------------------------------------------------ +# get_all() +# +# Method which returns all remaining items in the iterator as a Perl list +# reference. May be called at any time in the life-cycle of the iterator. +# The get_first() method will be called automatically if necessary, and +# then subsequent get_next() calls are made, storing each returned +# result until the list is exhausted. +#------------------------------------------------------------------------ + +sub get_all { + my $self = shift; + my ($max, $index) = @$self{ qw( MAX INDEX ) }; + my @data; + + # if there's still some data to go... + if ($index < $max) { + $index++; + @data = @{ $self->{ _DATASET } } [ $index..$max ]; + + # update counters and flags + @$self{ qw( INDEX COUNT FIRST LAST ) } + = ( $max, $max + 1, 0, 1 ); + + return \@data; ## RETURN ## + } + else { + return (undef, Template::Constants::STATUS_DONE); ## RETURN ## + } +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# Provides access to internal fields (e.g. size, first, last, max, etc) +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $item = $AUTOLOAD; + $item =~ s/.*:://; + return if $item eq 'DESTROY'; + + # alias NUMBER to COUNT for backwards compatability + $item = 'COUNT' if $item =~ /NUMBER/i; + + return $self->{ uc $item }; +} + + +#======================================================================== +# ----- PRIVATE DEBUG METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string detailing the internal state of +# the iterator object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + join('', + " Data: ", $self->{ _DATA }, "\n", + " Index: ", $self->{ INDEX }, "\n", + "Number: ", $self->{ NUMBER }, "\n", + " Max: ", $self->{ MAX }, "\n", + " Size: ", $self->{ SIZE }, "\n", + " First: ", $self->{ FIRST }, "\n", + " Last: ", $self->{ LAST }, "\n", + "\n" + ); +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Iterator - Data iterator used by the FOREACH directive + +=head1 SYNOPSIS + + my $iter = Template::Iterator->new(\@data, \%options); + +=head1 DESCRIPTION + +The Template::Iterator module defines a generic data iterator for use +by the FOREACH directive. + +It may be used as the base class for custom iterators. + +=head1 PUBLIC METHODS + +=head2 new($data) + +Constructor method. A reference to a list of values is passed as the +first parameter. Subsequent calls to get_first() and get_next() calls +will return each element from the list. + + my $iter = Template::Iterator->new([ 'foo', 'bar', 'baz' ]); + +The constructor will also accept a reference to a hash array and will +expand it into a list in which each entry is a hash array containing +a 'key' and 'value' item, sorted according to the hash keys. + + my $iter = Template::Iterator->new({ + foo => 'Foo Item', + bar => 'Bar Item', + }); + +This is equivalent to: + + my $iter = Template::Iterator->new([ + { key => 'bar', value => 'Bar Item' }, + { key => 'foo', value => 'Foo Item' }, + ]); + +When passed a single item which is not an array reference, the constructor +will automatically create a list containing that single item. + + my $iter = Template::Iterator->new('foo'); + +This is equivalent to: + + my $iter = Template::Iterator->new([ 'foo' ]); + +Note that a single item which is an object based on a blessed ARRAY +references will NOT be treated as an array and will be folded into +a list containing that one object reference. + + my $list = bless [ 'foo', 'bar' ], 'MyListClass'; + my $iter = Template::Iterator->new($list); + +equivalent to: + + my $iter = Template::Iterator->new([ $list ]); + +If the object provides an as_list() method then the Template::Iterator +constructor will call that method to return the list of data. For example: + + package MyListObject; + + sub new { + my $class = shift; + bless [ @_ ], $class; + } + + package main; + + my $list = MyListObject->new('foo', 'bar'); + my $iter = Template::Iterator->new($list); + +This is then functionally equivalent to: + + my $iter = Template::Iterator->new([ $list ]); + +The iterator will return only one item, a reference to the MyListObject +object, $list. + +By adding an as_list() method to the MyListObject class, we can force +the Template::Iterator constructor to treat the object as a list and +use the data contained within. + + package MyListObject; + + ... + + sub as_list { + my $self = shift; + return $self; + } + + package main; + + my $list = MyListObject->new('foo', 'bar'); + my $iter = Template::Iterator->new($list); + +The iterator will now return the two item, 'foo' and 'bar', which the +MyObjectList encapsulates. + +=head2 get_first() + +Returns a ($value, $error) pair for the first item in the iterator set. +The $error returned may be zero or undefined to indicate a valid datum +was successfully returned. Returns an error of STATUS_DONE if the list +is empty. + +=head2 get_next() + +Returns a ($value, $error) pair for the next item in the iterator set. +Returns an error of STATUS_DONE if all items in the list have been +visited. + +=head2 get_all() + +Returns a (\@values, $error) pair for all remaining items in the iterator +set. Returns an error of STATUS_DONE if all items in the list have been +visited. + +=head2 size() + +Returns the size of the data set or undef if unknown. + +=head2 max() + +Returns the maximum index number (i.e. the index of the last element) +which is equivalent to size() - 1. + +=head2 index() + +Returns the current index number which is in the range 0 to max(). + +=head2 count() + +Returns the current iteration count in the range 1 to size(). This is +equivalent to index() + 1. Note that number() is supported as an alias +for count() for backwards compatability. + +=head2 first() + +Returns a boolean value to indicate if the iterator is currently on +the first iteration of the set. + +=head2 last() + +Returns a boolean value to indicate if the iterator is currently on +the last iteration of the set. + +=head2 prev() + +Returns the previous item in the data set, or undef if the iterator is +on the first item. + +=head2 next() + +Returns the next item in the data set or undef if the iterator is on the +last item. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.59, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template> diff --git a/lib/Template/Namespace/Constants.pm b/lib/Template/Namespace/Constants.pm new file mode 100644 index 0000000..76e5366 --- /dev/null +++ b/lib/Template/Namespace/Constants.pm @@ -0,0 +1,195 @@ +#================================================================= -*-Perl-*- +# +# Template::Namespace::Constants +# +# DESCRIPTION +# Plugin compiler module for performing constant folding at compile time +# on variables in a particular namespace. +# +# AUTHOR +# Andy Wardley <abw@andywardley.com> +# +# COPYRIGHT +# Copyright (C) 1996-2002 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# REVISION +# $Id: Constants.pm,v 1.17 2003/04/24 09:14:42 abw Exp $ +# +#============================================================================ + +package Template::Namespace::Constants; + +use strict; +use Template::Base; +use Template::Config; +use Template::Directive; +use Template::Exception; + +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG ); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; + + +sub _init { + my ($self, $config) = @_; + $self->{ STASH } = Template::Config->stash($config) + || return $self->error(Template::Config->error()); + return $self; +} + + + +#------------------------------------------------------------------------ +# ident(\@ident) foo.bar(baz) +#------------------------------------------------------------------------ + +sub ident { + my ($self, $ident) = @_; + my @save = @$ident; + + # discard first node indicating constants namespace + splice(@$ident, 0, 2); + + my $nelems = @$ident / 2; + my ($e, $result); + local $" = ', '; + + print STDERR "constant ident [ @$ident ] " if $DEBUG; + + foreach $e (0..$nelems-1) { + # node name must be a constant + unless ($ident->[$e * 2] =~ s/^'(.+)'$/$1/s) { + $self->DEBUG(" * deferred (non-constant item: ", $ident->[$e * 2], ")\n") + if $DEBUG; + return Template::Directive->ident(\@save); + } + + # if args is non-zero then it must be eval'ed + if ($ident->[$e * 2 + 1]) { + my $args = $ident->[$e * 2 + 1]; + my $comp = eval "$args"; + if ($@) { + $self->DEBUG(" * deferred (non-constant args: $args)\n") if $DEBUG; + return Template::Directive->ident(\@save); + } + $self->DEBUG("($args) ") if $comp && $DEBUG; + $ident->[$e * 2 + 1] = $comp; + } + } + + + $result = $self->{ STASH }->get($ident); + + if (! length $result || ref $result) { + my $reason = length $result ? 'reference' : 'no result'; + $self->DEBUG(" * deferred ($reason)\n") if $DEBUG; + return Template::Directive->ident(\@save); + } + + $result =~ s/'/\\'/g; + + $self->DEBUG(" * resolved => '$result'\n") if $DEBUG; + + return "'$result'"; +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Namespace::Constants - Compile time constant folding + +=head1 SYNOPSIS + + # easy way to define constants + use Template; + + my $tt = Template->new({ + CONSTANTS => { + pi => 3.14, + e => 2.718, + }, + }); + + # nitty-gritty, hands-dirty way + use Template::Namespace::Constants; + + my $tt = Template->new({ + NAMESPACE => { + constants => Template::Namespace::Constants->new({ + pi => 3.14, + e => 2.718, + }, + }, + }); + +=head1 DESCRIPTION + +The Template::Namespace::Constants module implements a namespace handler +which is plugged into the Template::Directive compiler module. This then +performs compile time constant folding of variables in a particular namespace. + +=head1 PUBLIC METHODS + +=head2 new(\%constants) + +The new() constructor method creates and returns a reference to a new +Template::Namespace::Constants object. This creates an internal stash +to store the constant variable definitions passed as arguments. + + my $handler = Template::Namespace::Constants->new({ + pi => 3.14, + e => 2.718, + }); + +=head2 ident(\@ident) + +Method called to resolve a variable identifier into a compiled form. In this +case, the method fetches the corresponding constant value from its internal +stash and returns it. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +1.17, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template::Directive|Template::Directive> diff --git a/lib/Template/Parser.pm b/lib/Template/Parser.pm new file mode 100644 index 0000000..34f777d --- /dev/null +++ b/lib/Template/Parser.pm @@ -0,0 +1,1434 @@ +#============================================================= -*-Perl-*- +# +# Template::Parser +# +# DESCRIPTION +# This module implements a LALR(1) parser and assocated support +# methods to parse template documents into the appropriate "compiled" +# format. Much of the parser DFA code (see _parse() method) is based +# on Francois Desarmenien's Parse::Yapp module. Kudos to him. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# The following copyright notice appears in the Parse::Yapp +# documentation. +# +# The Parse::Yapp module and its related modules and shell +# scripts are copyright (c) 1998 Francois Desarmenien, +# France. All rights reserved. +# +# You may use and distribute them under the terms of either +# the GNU General Public License or the Artistic License, as +# specified in the Perl README file. +# +#---------------------------------------------------------------------------- +# +# $Id: Parser.pm,v 2.75 2003/07/01 12:44:56 darren Exp $ +# +#============================================================================ + +package Template::Parser; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $ERROR ); +use base qw( Template::Base ); +use vars qw( $TAG_STYLE $DEFAULT_STYLE $QUOTED_ESCAPES ); + +use Template::Constants qw( :status :chomp ); +use Template::Directive; +use Template::Grammar; + +# parser state constants +use constant CONTINUE => 0; +use constant ACCEPT => 1; +use constant ERROR => 2; +use constant ABORT => 3; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.75 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; +$ERROR = ''; + + +#======================================================================== +# -- COMMON TAG STYLES -- +#======================================================================== + +$TAG_STYLE = { + 'default' => [ '\[%', '%\]' ], + 'template1' => [ '[\[%]%', '%[\]%]' ], + 'metatext' => [ '%%', '%%' ], + 'html' => [ '<!--', '-->' ], + 'mason' => [ '<%', '>' ], + 'asp' => [ '<%', '%>' ], + 'php' => [ '<\?', '\?>' ], + 'star' => [ '\[\*', '\*\]' ], +}; +$TAG_STYLE->{ template } = $TAG_STYLE->{ tt2 } = $TAG_STYLE->{ default }; + + +$DEFAULT_STYLE = { + START_TAG => $TAG_STYLE->{ default }->[0], + END_TAG => $TAG_STYLE->{ default }->[1], +# TAG_STYLE => 'default', + ANYCASE => 0, + INTERPOLATE => 0, + PRE_CHOMP => 0, + POST_CHOMP => 0, + V1DOLLAR => 0, + EVAL_PERL => 0, +}; + +$QUOTED_ESCAPES = { + n => "\n", + r => "\r", + t => "\t", +}; + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%config) +# +# Constructor method. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my $config = $_[0] && UNIVERSAL::isa($_[0], 'HASH') ? shift(@_) : { @_ }; + my ($tagstyle, $debug, $start, $end, $defaults, $grammar, $hash, $key, $udef); + + my $self = bless { + START_TAG => undef, + END_TAG => undef, + TAG_STYLE => 'default', + ANYCASE => 0, + INTERPOLATE => 0, + PRE_CHOMP => 0, + POST_CHOMP => 0, + V1DOLLAR => 0, + EVAL_PERL => 0, + GRAMMAR => undef, + _ERROR => '', + FACTORY => 'Template::Directive', + }, $class; + + # update self with any relevant keys in config + foreach $key (keys %$self) { + $self->{ $key } = $config->{ $key } if defined $config->{ $key }; + } + $self->{ FILEINFO } = [ ]; + + # DEBUG config item can be a bitmask + if (defined ($debug = $config->{ DEBUG })) { + $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PARSER + | Template::Constants::DEBUG_FLAGS ); + $self->{ DEBUG_DIRS } = $debug & Template::Constants::DEBUG_DIRS; + } + # package variable can be set to 1 to support previous behaviour + elsif ($DEBUG == 1) { + $self->{ DEBUG } = Template::Constants::DEBUG_PARSER; + $self->{ DEBUG_DIRS } = 0; + } + # otherwise let $DEBUG be a bitmask + else { + $self->{ DEBUG } = $DEBUG & ( Template::Constants::DEBUG_PARSER + | Template::Constants::DEBUG_FLAGS ); + $self->{ DEBUG_DIRS } = $DEBUG & Template::Constants::DEBUG_DIRS; + } + + $grammar = $self->{ GRAMMAR } ||= do { + require Template::Grammar; + Template::Grammar->new(); + }; + + # build a FACTORY object to include any NAMESPACE definitions, + # but only if FACTORY isn't already an object + if ($config->{ NAMESPACE } && ! ref $self->{ FACTORY }) { + my $fclass = $self->{ FACTORY }; + $self->{ FACTORY } = $fclass->new( NAMESPACE => $config->{ NAMESPACE } ) + || return $class->error($fclass->error()); + } + + +# # determine START_TAG and END_TAG for specified (or default) TAG_STYLE +# $tagstyle = $self->{ TAG_STYLE } || 'default'; +# return $class->error("Invalid tag style: $tagstyle") +# unless defined ($start = $TAG_STYLE->{ $tagstyle }); +# ($start, $end) = @$start; +# +# $self->{ START_TAG } ||= $start; +# $self->{ END_TAG } ||= $end; + + # load grammar rules, states and lex table + @$self{ qw( LEXTABLE STATES RULES ) } + = @$grammar{ qw( LEXTABLE STATES RULES ) }; + + $self->new_style($config) + || return $class->error($self->error()); + + return $self; +} + + +#------------------------------------------------------------------------ +# new_style(\%config) +# +# Install a new (stacked) parser style. This feature is currently +# experimental but should mimic the previous behaviour with regard to +# TAG_STYLE, START_TAG, END_TAG, etc. +#------------------------------------------------------------------------ + +sub new_style { + my ($self, $config) = @_; + my $styles = $self->{ STYLE } ||= [ ]; + my ($tagstyle, $tags, $start, $end, $key); + + # clone new style from previous or default style + my $style = { %{ $styles->[-1] || $DEFAULT_STYLE } }; + + # expand START_TAG and END_TAG from specified TAG_STYLE + if ($tagstyle = $config->{ TAG_STYLE }) { + return $self->error("Invalid tag style: $tagstyle") + unless defined ($tags = $TAG_STYLE->{ $tagstyle }); + ($start, $end) = @$tags; + $config->{ START_TAG } ||= $start; + $config->{ END_TAG } ||= $end; + } + + foreach $key (keys %$DEFAULT_STYLE) { + $style->{ $key } = $config->{ $key } if defined $config->{ $key }; + } + push(@$styles, $style); + return $style; +} + + +#------------------------------------------------------------------------ +# old_style() +# +# Pop the current parser style and revert to the previous one. See +# new_style(). ** experimental ** +#------------------------------------------------------------------------ + +sub old_style { + my $self = shift; + my $styles = $self->{ STYLE }; + return $self->error('only 1 parser style remaining') + unless (@$styles > 1); + pop @$styles; + return $styles->[-1]; +} + + +#------------------------------------------------------------------------ +# parse($text, $data) +# +# Parses the text string, $text and returns a hash array representing +# the compiled template block(s) as Perl code, in the format expected +# by Template::Document. +#------------------------------------------------------------------------ + +sub parse { + my ($self, $text, $info) = @_; + my ($tokens, $block); + + $info->{ DEBUG } = $self->{ DEBUG_DIRS } + unless defined $info->{ DEBUG }; + +# print "info: { ", join(', ', map { "$_ => $info->{ $_ }" } keys %$info), " }\n"; + + # store for blocks defined in the template (see define_block()) + my $defblock = $self->{ DEFBLOCK } = { }; + my $metadata = $self->{ METADATA } = [ ]; + + $self->{ _ERROR } = ''; + + # split file into TEXT/DIRECTIVE chunks + $tokens = $self->split_text($text) + || return undef; ## RETURN ## + + push(@{ $self->{ FILEINFO } }, $info); + + # parse chunks + $block = $self->_parse($tokens, $info); + + pop(@{ $self->{ FILEINFO } }); + + return undef unless $block; ## RETURN ## + + $self->debug("compiled main template document block:\n$block") + if $self->{ DEBUG } & Template::Constants::DEBUG_PARSER; + + return { + BLOCK => $block, + DEFBLOCKS => $defblock, + METADATA => { @$metadata }, + }; +} + + + +#------------------------------------------------------------------------ +# split_text($text) +# +# Split input template text into directives and raw text chunks. +#------------------------------------------------------------------------ + +sub split_text { + my ($self, $text) = @_; + my ($pre, $dir, $prelines, $dirlines, $postlines, $chomp, $tags, @tags); + my $style = $self->{ STYLE }->[-1]; + my ($start, $end, $prechomp, $postchomp, $interp ) = + @$style{ qw( START_TAG END_TAG PRE_CHOMP POST_CHOMP INTERPOLATE ) }; + + my @tokens = (); + my $line = 1; + + return \@tokens ## RETURN ## + unless defined $text && length $text; + + # extract all directives from the text + while ($text =~ s/ + ^(.*?) # $1 - start of line up to directive + (?: + $start # start of tag + (.*?) # $2 - tag contents + $end # end of tag + ) + //sx) { + + ($pre, $dir) = ($1, $2); + $pre = '' unless defined $pre; + $dir = '' unless defined $dir; + + $postlines = 0; # denotes lines chomped + $prelines = ($pre =~ tr/\n//); # NULL - count only + $dirlines = ($dir =~ tr/\n//); # ditto + + # the directive CHOMP options may modify the preceding text + for ($dir) { + # remove leading whitespace and check for a '-' chomp flag + s/^([-+\#])?\s*//s; + if ($1 && $1 eq '#') { + # comment out entire directive except for any chomp flag + $dir = ($dir =~ /([-+])$/) ? $1 : ''; + } + else { + $chomp = ($1 && $1 eq '+') ? 0 : ($1 || $prechomp); +# my $space = $prechomp == &Template::Constants::CHOMP_COLLAPSE + my $space = $prechomp == CHOMP_COLLAPSE + ? ' ' : ''; + + # chomp off whitespace and newline preceding directive + $chomp and $pre =~ s/(\n|^)([ \t]*)\Z/($1||$2) ? $space : ''/me + and $1 eq "\n" + and $prelines++; + } + + # remove trailing whitespace and check for a '-' chomp flag + s/\s*([-+])?\s*$//s; + $chomp = ($1 && $1 eq '+') ? 0 : ($1 || $postchomp); + my $space = $postchomp == &Template::Constants::CHOMP_COLLAPSE + ? ' ' : ''; + + $postlines++ + if $chomp and $text =~ s/ + ^ + ([ \t]*)\n # whitespace to newline + (?:(.|\n)|$) # any char (not EOF) + / + (($1||$2) ? $space : '') . (defined $2 ? $2 : '') + /ex; + } + + # any text preceding the directive can now be added + if (length $pre) { + push(@tokens, $interp + ? [ $pre, $line, 'ITEXT' ] + : ('TEXT', $pre) ); + $line += $prelines; + } + + # and now the directive, along with line number information + if (length $dir) { + # the TAGS directive is a compile-time switch + if ($dir =~ /^TAGS\s+(.*)/i) { + my @tags = split(/\s+/, $1); + if (scalar @tags > 1) { + ($start, $end) = map { quotemeta($_) } @tags; + } + elsif ($tags = $TAG_STYLE->{ $tags[0] }) { + ($start, $end) = @$tags; + } + else { + warn "invalid TAGS style: $tags[0]\n"; + } + } + else { + # DIRECTIVE is pushed as [ $dirtext, $line_no(s), \@tokens ] + push(@tokens, [ $dir, + ($dirlines + ? sprintf("%d-%d", $line, $line + $dirlines) + : $line), + $self->tokenise_directive($dir) ]); + } + } + + # update line counter to include directive lines and any extra + # newline chomped off the start of the following text + $line += $dirlines + $postlines; + } + + # anything remaining in the string is plain text + push(@tokens, $interp + ? [ $text, $line, 'ITEXT' ] + : ( 'TEXT', $text) ) + if length $text; + + return \@tokens; ## RETURN ## +} + + + +#------------------------------------------------------------------------ +# interpolate_text($text, $line) +# +# Examines $text looking for any variable references embedded like +# $this or like ${ this }. +#------------------------------------------------------------------------ + +sub interpolate_text { + my ($self, $text, $line) = @_; + my @tokens = (); + my ($pre, $var, $dir); + + + while ($text =~ + / + ( (?: \\. | [^\$] ){1,3000} ) # escaped or non-'$' character [$1] + | + ( \$ (?: # embedded variable [$2] + (?: \{ ([^\}]*) \} ) # ${ ... } [$3] + | + ([\w\.]+) # $word [$4] + ) + ) + /gx) { + + ($pre, $var, $dir) = ($1, $3 || $4, $2); + + # preceding text + if (defined($pre) && length($pre)) { + $line += $pre =~ tr/\n//; + $pre =~ s/\\\$/\$/g; + push(@tokens, 'TEXT', $pre); + } + # $variable reference + if ($var) { + $line += $dir =~ tr/\n/ /; + push(@tokens, [ $dir, $line, $self->tokenise_directive($var) ]); + } + # other '$' reference - treated as text + elsif ($dir) { + $line += $dir =~ tr/\n//; + push(@tokens, 'TEXT', $dir); + } + } + + return \@tokens; +} + + + +#------------------------------------------------------------------------ +# tokenise_directive($text) +# +# Called by the private _parse() method when it encounters a DIRECTIVE +# token in the list provided by the split_text() or interpolate_text() +# methods. The directive text is passed by parameter. +# +# The method splits the directive into individual tokens as recognised +# by the parser grammar (see Template::Grammar for details). It +# constructs a list of tokens each represented by 2 elements, as per +# split_text() et al. The first element contains the token type, the +# second the token itself. +# +# The method tokenises the string using a complex (but fast) regex. +# For a deeper understanding of the regex magic at work here, see +# Jeffrey Friedl's excellent book "Mastering Regular Expressions", +# from O'Reilly, ISBN 1-56592-257-3 +# +# Returns a reference to the list of chunks (each one being 2 elements) +# identified in the directive text. On error, the internal _ERROR string +# is set and undef is returned. +#------------------------------------------------------------------------ + +sub tokenise_directive { + my ($self, $text, $line) = @_; + my ($token, $uctoken, $type, $lookup); + my $lextable = $self->{ LEXTABLE }; + my $style = $self->{ STYLE }->[-1]; + my ($anycase, $start, $end) = @$style{ qw( ANYCASE START_TAG END_TAG ) }; + my @tokens = ( ); + + while ($text =~ + / + # strip out any comments + (\#[^\n]*) + | + # a quoted phrase matches in $3 + (["']) # $2 - opening quote, ' or " + ( # $3 - quoted text buffer + (?: # repeat group (no backreference) + \\\\ # an escaped backslash \\ + | # ...or... + \\\2 # an escaped quote \" or \' (match $1) + | # ...or... + . # any other character + | \n + )*? # non-greedy repeat + ) # end of $3 + \2 # match opening quote + | + # an unquoted number matches in $4 + (-?\d+(?:\.\d+)?) # numbers + | + # filename matches in $5 + ( \/?\w+(?:(?:\/|::?)\w*)+ | \/\w+) + | + # an identifier matches in $6 + (\w+) # variable identifier + | + # an unquoted word or symbol matches in $7 + ( [(){}\[\]:;,\/\\] # misc parenthesis and symbols +# | \-> # arrow operator (for future?) + | [+\-*] # math operations + | \$\{? # dollar with option left brace + | => # like '=' + | [=!<>]?= | [!<>] # eqality tests + | &&? | \|\|? # boolean ops + | \.\.? # n..n sequence + | \S+ # something unquoted + ) # end of $7 + /gmxo) { + + # ignore comments to EOL + next if $1; + + # quoted string + if (defined ($token = $3)) { + # double-quoted string may include $variable references + if ($2 eq '"') { + if ($token =~ /[\$\\]/) { + $type = 'QUOTED'; + # unescape " and \ but leave \$ escaped so that + # interpolate_text() doesn't incorrectly treat it + # as a variable reference +# $token =~ s/\\([\\"])/$1/g; + for ($token) { + s/\\([^\$nrt])/$1/g; + s/\\([nrt])/$QUOTED_ESCAPES->{ $1 }/ge; + } + push(@tokens, ('"') x 2, + @{ $self->interpolate_text($token) }, + ('"') x 2); + next; + } + else { + $type = 'LITERAL'; + $token =~ s['][\\']g; + $token = "'$token'"; + } + } + else { + $type = 'LITERAL'; + $token = "'$token'"; + } + } + # number + elsif (defined ($token = $4)) { + $type = 'NUMBER'; + } + elsif (defined($token = $5)) { + $type = 'FILENAME'; + } + elsif (defined($token = $6)) { + # reserved words may be in lower case unless case sensitive + $uctoken = $anycase ? uc $token : $token; + if (defined ($type = $lextable->{ $uctoken })) { + $token = $uctoken; + } + else { + $type = 'IDENT'; + } + } + elsif (defined ($token = $7)) { + # reserved words may be in lower case unless case sensitive + $uctoken = $anycase ? uc $token : $token; + unless (defined ($type = $lextable->{ $uctoken })) { + $type = 'UNQUOTED'; + } + } + + push(@tokens, $type, $token); + +# print(STDERR " +[ $type, $token ]\n") +# if $DEBUG; + } + +# print STDERR "tokenise directive() returning:\n [ @tokens ]\n" +# if $DEBUG; + + return \@tokens; ## RETURN ## +} + + +#------------------------------------------------------------------------ +# define_block($name, $block) +# +# Called by the parser 'defblock' rule when a BLOCK definition is +# encountered in the template. The name of the block is passed in the +# first parameter and a reference to the compiled block is passed in +# the second. This method stores the block in the $self->{ DEFBLOCK } +# hash which has been initialised by parse() and will later be used +# by the same method to call the store() method on the calling cache +# to define the block "externally". +#------------------------------------------------------------------------ + +sub define_block { + my ($self, $name, $block) = @_; + my $defblock = $self->{ DEFBLOCK } + || return undef; + + $self->debug("compiled block '$name':\n$block") + if $self->{ DEBUG } & Template::Constants::DEBUG_PARSER; + + $defblock->{ $name } = $block; + + return undef; +} + +sub push_defblock { + my $self = shift; + my $stack = $self->{ DEFBLOCK_STACK } ||= []; + push(@$stack, $self->{ DEFBLOCK } ); + $self->{ DEFBLOCK } = { }; +} + +sub pop_defblock { + my $self = shift; + my $defs = $self->{ DEFBLOCK }; + my $stack = $self->{ DEFBLOCK_STACK } || return $defs; + return $defs unless @$stack; + $self->{ DEFBLOCK } = pop @$stack; + return $defs; +} + + +#------------------------------------------------------------------------ +# add_metadata(\@setlist) +#------------------------------------------------------------------------ + +sub add_metadata { + my ($self, $setlist) = @_; + my $metadata = $self->{ METADATA } + || return undef; + + push(@$metadata, @$setlist); + + return undef; +} + + +#======================================================================== +# ----- PRIVATE METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# _parse(\@tokens, \@info) +# +# Parses the list of input tokens passed by reference and returns a +# Template::Directive::Block object which contains the compiled +# representation of the template. +# +# This is the main parser DFA loop. See embedded comments for +# further details. +# +# On error, undef is returned and the internal _ERROR field is set to +# indicate the error. This can be retrieved by calling the error() +# method. +#------------------------------------------------------------------------ + +sub _parse { + my ($self, $tokens, $info) = @_; + my ($token, $value, $text, $line, $inperl); + my ($state, $stateno, $status, $action, $lookup, $coderet, @codevars); + my ($lhs, $len, $code); # rule contents + my $stack = [ [ 0, undef ] ]; # DFA stack + +# DEBUG +# local $" = ', '; + + # retrieve internal rule and state tables + my ($states, $rules) = @$self{ qw( STATES RULES ) }; + + # call the grammar set_factory method to install emitter factory + $self->{ GRAMMAR }->install_factory($self->{ FACTORY }); + + $line = $inperl = 0; + $self->{ LINE } = \$line; + $self->{ INPERL } = \$inperl; + + $status = CONTINUE; + my $in_string = 0; + + while(1) { + # get state number and state + $stateno = $stack->[-1]->[0]; + $state = $states->[$stateno]; + + # see if any lookaheads exist for the current state + if (exists $state->{'ACTIONS'}) { + + # get next token and expand any directives (i.e. token is an + # array ref) onto the front of the token list + while (! defined $token && @$tokens) { + $token = shift(@$tokens); + if (ref $token) { + ($text, $line, $token) = @$token; + if (ref $token) { + if ($info->{ DEBUG } && ! $in_string) { + # - - - - - - - - - - - - - - - - - - - - - - - - - + # This is gnarly. Look away now if you're easily + # frightened. We're pushing parse tokens onto the + # pending list to simulate a DEBUG directive like so: + # [% DEBUG msg line='20' text='INCLUDE foo' %] + # - - - - - - - - - - - - - - - - - - - - - - - - - + my $dtext = $text; + $dtext =~ s[(['\\])][\\$1]g; + unshift(@$tokens, + DEBUG => 'DEBUG', + IDENT => 'msg', + IDENT => 'line', + ASSIGN => '=', + LITERAL => "'$line'", + IDENT => 'text', + ASSIGN => '=', + LITERAL => "'$dtext'", + IDENT => 'file', + ASSIGN => '=', + LITERAL => "'$info->{ name }'", + (';') x 2, + @$token, + (';') x 2); + } + else { + unshift(@$tokens, @$token, (';') x 2); + } + $token = undef; # force redo + } + elsif ($token eq 'ITEXT') { + if ($inperl) { + # don't perform interpolation in PERL blocks + $token = 'TEXT'; + $value = $text; + } + else { + unshift(@$tokens, + @{ $self->interpolate_text($text, $line) }); + $token = undef; # force redo + } + } + } + else { + # toggle string flag to indicate if we're crossing + # a string boundary + $in_string = ! $in_string if $token eq '"'; + $value = shift(@$tokens); + } + }; + # clear undefined token to avoid 'undefined variable blah blah' + # warnings and let the parser logic pick it up in a minute + $token = '' unless defined $token; + + # get the next state for the current lookahead token + $action = defined ($lookup = $state->{'ACTIONS'}->{ $token }) + ? $lookup + : defined ($lookup = $state->{'DEFAULT'}) + ? $lookup + : undef; + } + else { + # no lookahead actions + $action = $state->{'DEFAULT'}; + } + + # ERROR: no ACTION + last unless defined $action; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # shift (+ive ACTION) + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if ($action > 0) { + push(@$stack, [ $action, $value ]); + $token = $value = undef; + redo; + }; + + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - + # reduce (-ive ACTION) + # - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ($lhs, $len, $code) = @{ $rules->[ -$action ] }; + + # no action imples ACCEPTance + $action + or $status = ACCEPT; + + # use dummy sub if code ref doesn't exist + $code = sub { $_[1] } + unless $code; + + @codevars = $len + ? map { $_->[1] } @$stack[ -$len .. -1 ] + : (); + + eval { + $coderet = &$code( $self, @codevars ); + }; + if ($@) { + my $err = $@; + chomp $err; + return $self->_parse_error($err); + } + + # reduce stack by $len + splice(@$stack, -$len, $len); + + # ACCEPT + return $coderet ## RETURN ## + if $status == ACCEPT; + + # ABORT + return undef ## RETURN ## + if $status == ABORT; + + # ERROR + last + if $status == ERROR; + } + continue { + push(@$stack, [ $states->[ $stack->[-1][0] ]->{'GOTOS'}->{ $lhs }, + $coderet ]), + } + + # ERROR ## RETURN ## + return $self->_parse_error('unexpected end of input') + unless defined $value; + + # munge text of last directive to make it readable +# $text =~ s/\n/\\n/g; + + return $self->_parse_error("unexpected end of directive", $text) + if $value eq ';'; # end of directive SEPARATOR + + return $self->_parse_error("unexpected token ($value)", $text); +} + + + +#------------------------------------------------------------------------ +# _parse_error($msg, $dirtext) +# +# Method used to handle errors encountered during the parse process +# in the _parse() method. +#------------------------------------------------------------------------ + +sub _parse_error { + my ($self, $msg, $text) = @_; + my $line = $self->{ LINE }; + $line = ref($line) ? $$line : $line; + $line = 'unknown' unless $line; + + $msg .= "\n [% $text %]" + if defined $text; + + return $self->error("line $line: $msg"); +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method returns a string representing the internal state of the +# object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $output = "[Template::Parser] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + foreach $key (qw( START_TAG END_TAG TAG_STYLE ANYCASE INTERPOLATE + PRE_CHOMP POST_CHOMP V1DOLLAR )) { + my $val = $self->{ $key }; + $val = '<undef>' unless defined $val; + $output .= sprintf($format, $key, $val); + } + + $output .= '}'; + return $output; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Parser - LALR(1) parser for compiling template documents + +=head1 SYNOPSIS + + use Template::Parser; + + $parser = Template::Parser->new(\%config); + $template = $parser->parse($text) + || die $parser->error(), "\n"; + +=head1 DESCRIPTION + +The Template::Parser module implements a LALR(1) parser and associated methods +for parsing template documents into Perl code. + +=head1 PUBLIC METHODS + +=head2 new(\%params) + +The new() constructor creates and returns a reference to a new +Template::Parser object. A reference to a hash may be supplied as a +parameter to provide configuration values. These may include: + +=over + + + + +=item START_TAG, END_TAG + +The START_TAG and END_TAG options are used to specify character +sequences or regular expressions that mark the start and end of a +template directive. The default values for START_TAG and END_TAG are +'[%' and '%]' respectively, giving us the familiar directive style: + + [% example %] + +Any Perl regex characters can be used and therefore should be escaped +(or use the Perl C<quotemeta> function) if they are intended to +represent literal characters. + + my $parser = Template::Parser->new({ + START_TAG => quotemeta('<+'), + END_TAG => quotemeta('+>'), + }); + +example: + + <+ INCLUDE foobar +> + +The TAGS directive can also be used to set the START_TAG and END_TAG values +on a per-template file basis. + + [% TAGS <+ +> %] + + + + + + +=item TAG_STYLE + +The TAG_STYLE option can be used to set both START_TAG and END_TAG +according to pre-defined tag styles. + + my $parser = Template::Parser->new({ + TAG_STYLE => 'star', + }); + +Available styles are: + + template [% ... %] (default) + template1 [% ... %] or %% ... %% (TT version 1) + metatext %% ... %% (Text::MetaText) + star [* ... *] (TT alternate) + php <? ... ?> (PHP) + asp <% ... %> (ASP) + mason <% ... > (HTML::Mason) + html <!-- ... --> (HTML comments) + +Any values specified for START_TAG and/or END_TAG will over-ride +those defined by a TAG_STYLE. + +The TAGS directive may also be used to set a TAG_STYLE + + [% TAGS html %] + <!-- INCLUDE header --> + + + + + + +=item PRE_CHOMP, POST_CHOMP + +Anything outside a directive tag is considered plain text and is +generally passed through unaltered (but see the INTERPOLATE option). +This includes all whitespace and newlines characters surrounding +directive tags. Directives that don't generate any output will leave +gaps in the output document. + +Example: + + Foo + [% a = 10 %] + Bar + +Output: + + Foo + + Bar + +The PRE_CHOMP and POST_CHOMP options can help to clean up some of this +extraneous whitespace. Both are disabled by default. + + my $parser = Template::Parser->new({ + PRE_CHOMP => 1, + POST_CHOMP => 1, + }); + +With PRE_CHOMP set to 1, the newline and whitespace preceding a directive +at the start of a line will be deleted. This has the effect of +concatenating a line that starts with a directive onto the end of the +previous line. + + Foo <----------. + | + ,---(PRE_CHOMP)----' + | + `-- [% a = 10 %] --. + | + ,---(POST_CHOMP)---' + | + `-> Bar + +With POST_CHOMP set to 1, any whitespace after a directive up to and +including the newline will be deleted. This has the effect of joining +a line that ends with a directive onto the start of the next line. + +If PRE_CHOMP or POST_CHOMP is set to 2, then instead of removing all +the whitespace, the whitespace will be collapsed to a single space. +This is useful for HTML, where (usually) a contiguous block of +whitespace is rendered the same as a single space. + +You may use the CHOMP_NONE, CHOMP_ALL, and CHOMP_COLLAPSE constants +from the Template::Constants module to deactivate chomping, remove +all whitespace, or collapse whitespace to a single space. + +PRE_CHOMP and POST_CHOMP can be activated for individual directives by +placing a '-' immediately at the start and/or end of the directive. + + [% FOREACH user = userlist %] + [%- user -%] + [% END %] + +The '-' characters activate both PRE_CHOMP and POST_CHOMP for the one +directive '[%- name -%]'. Thus, the template will be processed as if +written: + + [% FOREACH user = userlist %][% user %][% END %] + +Note that this is the same as if PRE_CHOMP and POST_CHOMP were set +to CHOMP_ALL; the only way to get the CHOMP_COLLAPSE behavior is +to set PRE_CHOMP or POST_CHOMP accordingly. If PRE_CHOMP or POST_CHOMP +is already set to CHOMP_COLLAPSE, using '-' will give you CHOMP_COLLAPSE +behavior, not CHOMP_ALL behavior. + +Similarly, '+' characters can be used to disable PRE_CHOMP or +POST_CHOMP (i.e. leave the whitespace/newline intact) options on a +per-directive basis. + + [% FOREACH user = userlist %] + User: [% user +%] + [% END %] + +With POST_CHOMP enabled, the above example would be parsed as if written: + + [% FOREACH user = userlist %]User: [% user %] + [% END %] + + + + + +=item INTERPOLATE + +The INTERPOLATE flag, when set to any true value will cause variable +references in plain text (i.e. not surrounded by START_TAG and END_TAG) +to be recognised and interpolated accordingly. + + my $parser = Template::Parser->new({ + INTERPOLATE => 1, + }); + +Variables should be prefixed by a '$' to identify them. Curly braces +can be used in the familiar Perl/shell style to explicitly scope the +variable name where required. + + # INTERPOLATE => 0 + <a href="http://[% server %]/[% help %]"> + <img src="[% images %]/help.gif"></a> + [% myorg.name %] + + # INTERPOLATE => 1 + <a href="http://$server/$help"> + <img src="$images/help.gif"></a> + $myorg.name + + # explicit scoping with { } + <img src="$images/${icon.next}.gif"> + +Note that a limitation in Perl's regex engine restricts the maximum length +of an interpolated template to around 32 kilobytes or possibly less. Files +that exceed this limit in size will typically cause Perl to dump core with +a segmentation fault. If you routinely process templates of this size +then you should disable INTERPOLATE or split the templates in several +smaller files or blocks which can then be joined backed together via +PROCESS or INCLUDE. + + + + + + + +=item ANYCASE + +By default, directive keywords should be expressed in UPPER CASE. The +ANYCASE option can be set to allow directive keywords to be specified +in any case. + + # ANYCASE => 0 (default) + [% INCLUDE foobar %] # OK + [% include foobar %] # ERROR + [% include = 10 %] # OK, 'include' is a variable + + # ANYCASE => 1 + [% INCLUDE foobar %] # OK + [% include foobar %] # OK + [% include = 10 %] # ERROR, 'include' is reserved word + +One side-effect of enabling ANYCASE is that you cannot use a variable +of the same name as a reserved word, regardless of case. The reserved +words are currently: + + GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER + IF UNLESS ELSE ELSIF FOR FOREACH WHILE SWITCH CASE + USE PLUGIN FILTER MACRO PERL RAWPERL BLOCK META + TRY THROW CATCH FINAL NEXT LAST BREAK RETURN STOP + CLEAR TO STEP AND OR NOT MOD DIV END + + +The only lower case reserved words that cannot be used for variables, +regardless of the ANYCASE option, are the operators: + + and or not mod div + + + + + + + + +=item V1DOLLAR + +In version 1 of the Template Toolkit, an optional leading '$' could be placed +on any template variable and would be silently ignored. + + # VERSION 1 + [% $foo %] === [% foo %] + [% $hash.$key %] === [% hash.key %] + +To interpolate a variable value the '${' ... '}' construct was used. +Typically, one would do this to index into a hash array when the key +value was stored in a variable. + +example: + + my $vars = { + users => { + aba => { name => 'Alan Aardvark', ... }, + abw => { name => 'Andy Wardley', ... }, + ... + }, + uid => 'aba', + ... + }; + + $template->process('user/home.html', $vars) + || die $template->error(), "\n"; + +'user/home.html': + + [% user = users.${uid} %] # users.aba + Name: [% user.name %] # Alan Aardvark + +This was inconsistent with double quoted strings and also the +INTERPOLATE mode, where a leading '$' in text was enough to indicate a +variable for interpolation, and the additional curly braces were used +to delimit variable names where necessary. Note that this use is +consistent with UNIX and Perl conventions, among others. + + # double quoted string interpolation + [% name = "$title ${user.name}" %] + + # INTERPOLATE = 1 + <img src="$images/help.gif"></a> + <img src="$images/${icon.next}.gif"> + +For version 2, these inconsistencies have been removed and the syntax +clarified. A leading '$' on a variable is now used exclusively to +indicate that the variable name should be interpolated +(e.g. subsituted for its value) before being used. The earlier example +from version 1: + + # VERSION 1 + [% user = users.${uid} %] + Name: [% user.name %] + +can now be simplified in version 2 as: + + # VERSION 2 + [% user = users.$uid %] + Name: [% user.name %] + +The leading dollar is no longer ignored and has the same effect of +interpolation as '${' ... '}' in version 1. The curly braces may +still be used to explicitly scope the interpolated variable name +where necessary. + +e.g. + + [% user = users.${me.id} %] + Name: [% user.name %] + +The rule applies for all variables, both within directives and in +plain text if processed with the INTERPOLATE option. This means that +you should no longer (if you ever did) add a leading '$' to a variable +inside a directive, unless you explicitly want it to be interpolated. + +One obvious side-effect is that any version 1 templates with variables +using a leading '$' will no longer be processed as expected. Given +the following variable definitions, + + [% foo = 'bar' + bar = 'baz' + %] + +version 1 would interpret the following as: + + # VERSION 1 + [% $foo %] => [% GET foo %] => bar + +whereas version 2 interprets it as: + + # VERSION 2 + [% $foo %] => [% GET $foo %] => [% GET bar %] => baz + +In version 1, the '$' is ignored and the value for the variable 'foo' is +retrieved and printed. In version 2, the variable '$foo' is first interpolated +to give the variable name 'bar' whose value is then retrieved and printed. + +The use of the optional '$' has never been strongly recommended, but +to assist in backwards compatibility with any version 1 templates that +may rely on this "feature", the V1DOLLAR option can be set to 1 +(default: 0) to revert the behaviour and have leading '$' characters +ignored. + + my $parser = Template::Parser->new({ + V1DOLLAR => 1, + }); + + + + + + +=item GRAMMAR + +The GRAMMAR configuration item can be used to specify an alternate +grammar for the parser. This allows a modified or entirely new +template language to be constructed and used by the Template Toolkit. + +Source templates are compiled to Perl code by the Template::Parser +using the Template::Grammar (by default) to define the language +structure and semantics. Compiled templates are thus inherently +"compatible" with each other and there is nothing to prevent any +number of different template languages being compiled and used within +the same Template Toolkit processing environment (other than the usual +time and memory constraints). + +The Template::Grammar file is constructed from a YACC like grammar +(using Parse::YAPP) and a skeleton module template. These files are +provided, along with a small script to rebuild the grammar, in the +'parser' sub-directory of the distribution. You don't have to know or +worry about these unless you want to hack on the template language or +define your own variant. There is a README file in the same directory +which provides some small guidance but it is assumed that you know +what you're doing if you venture herein. If you grok LALR parsers, +then you should find it comfortably familiar. + +By default, an instance of the default Template::Grammar will be +created and used automatically if a GRAMMAR item isn't specified. + + use MyOrg::Template::Grammar; + + my $parser = Template::Parser->new({ + GRAMMAR = MyOrg::Template::Grammar->new(); + }); + + + +=item DEBUG + +The DEBUG option can be used to enable various debugging features +of the Template::Parser module. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_PARSER | DEBUG_DIRS, + }); + +The DEBUG value can include any of the following. Multiple values +should be combined using the logical OR operator, '|'. + +=over 4 + +=item DEBUG_PARSER + +This flag causes the L<Template::Parser|Template::Parser> to generate +debugging messages that show the Perl code generated by parsing and +compiling each template. + +=item DEBUG_DIRS + +This option causes the Template Toolkit to generate comments +indicating the source file, line and original text of each directive +in the template. These comments are embedded in the template output +using the format defined in the DEBUG_FORMAT configuration item, or a +simple default format if unspecified. + +For example, the following template fragment: + + + Hello World + +would generate this output: + + ## input text line 1 : ## + Hello + ## input text line 2 : World ## + World + + +=back + + + + +=back + +=head2 parse($text) + +The parse() method parses the text passed in the first parameter and +returns a reference to a Template::Document object which contains the +compiled representation of the template text. On error, undef is +returned. + +Example: + + $doc = $parser->parse($text) + || die $parser->error(); + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + + + +=head1 VERSION + +2.75, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + + + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + +The original Template::Parser module was derived from a standalone +parser generated by version 0.16 of the Parse::Yapp module. The +following copyright notice appears in the Parse::Yapp documentation. + + The Parse::Yapp module and its related modules and shell + scripts are copyright (c) 1998 Francois Desarmenien, + France. All rights reserved. + + You may use and distribute them under the terms of either + the GNU General Public License or the Artistic License, as + specified in the Perl README file. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Grammar|Template::Grammar>, L<Template::Directive|Template::Directive> + diff --git a/lib/Template/Plugin.pm b/lib/Template/Plugin.pm new file mode 100644 index 0000000..664ac96 --- /dev/null +++ b/lib/Template/Plugin.pm @@ -0,0 +1,399 @@ +#============================================================= -*-Perl-*- +# +# Template::Plugin +# +# DESCRIPTION +# +# Module defining a base class for a plugin object which can be loaded +# and instantiated via the USE directive. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Plugin.pm,v 2.60 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Plugin; + +require 5.004; + +use strict; +use Template::Base; + +use vars qw( $VERSION $DEBUG $ERROR $AUTOLOAD ); +use base qw( Template::Base ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.60 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0; + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# load() +# +# Class method called when the plugin module is first loaded. It +# returns the name of a class (by default, its own class) or a prototype +# object which will be used to instantiate new objects. The new() +# method is then called against the class name (class method) or +# prototype object (object method) to create a new instances of the +# object. +#------------------------------------------------------------------------ + +sub load { + return $_[0]; +} + + +#------------------------------------------------------------------------ +# new($context, $delegate, @params) +# +# Object constructor which is called by the Template::Context to +# instantiate a new Plugin object. This base class constructor is +# used as a general mechanism to load and delegate to other Perl +# modules. The context is passed as the first parameter, followed by +# a reference to a delegate object or the name of the module which +# should be loaded and instantiated. Any additional parameters passed +# to the USE directive are forwarded to the new() constructor. +# +# A plugin object is returned which has an AUTOLOAD method to delegate +# requests to the underlying object. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + bless { + }, $class; +} + +sub old_new { + my ($class, $context, $delclass, @params) = @_; + my ($delegate, $delmod); + + return $class->error("no context passed to $class constructor\n") + unless defined $context; + + if (ref $delclass) { + # $delclass contains a reference to a delegate object + $delegate = $delclass; + } + else { + # delclass is the name of a module to load and instantiate + ($delmod = $delclass) =~ s|::|/|g; + + eval { + require "$delmod.pm"; + $delegate = $delclass->new(@params) + || die "failed to instantiate $delclass object\n"; + }; + return $class->error($@) if $@; + } + + bless { + _CONTEXT => $context, + _DELEGATE => $delegate, + _PARAMS => \@params, + }, $class; +} + + +#------------------------------------------------------------------------ +# fail($error) +# +# Version 1 error reporting function, now replaced by error() inherited +# from Template::Base. Raises a "deprecated function" warning and then +# calls error(). +#------------------------------------------------------------------------ + +sub fail { + my $class = shift; + my ($pkg, $file, $line) = caller(); + warn "Template::Plugin::fail() is deprecated at $file line $line. Please use error()\n"; + $class->error(@_); +} + + +#======================================================================== +# ----- OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# AUTOLOAD +# +# General catch-all method which delegates all calls to the _DELEGATE +# object. +#------------------------------------------------------------------------ + +sub OLD_AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + + if (ref $self eq 'HASH') { + my $delegate = $self->{ _DELEGATE } || return; + return $delegate->$method(@_); + } + my ($pkg, $file, $line) = caller(); +# warn "no such '$method' method called on $self at $file line $line\n"; + return undef; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Plugin - Base class for Template Toolkit plugins + +=head1 SYNOPSIS + + package MyOrg::Template::Plugin::MyPlugin; + use base qw( Template::Plugin ); + use Template::Plugin; + use MyModule; + + sub new { + my $class = shift; + my $context = shift; + bless { + ... + }, $class; + } + +=head1 DESCRIPTION + +A "plugin" for the Template Toolkit is simply a Perl module which +exists in a known package location (e.g. Template::Plugin::*) and +conforms to a regular standard, allowing it to be loaded and used +automatically. + +The Template::Plugin module defines a base class from which other +plugin modules can be derived. A plugin does not have to be derived +from Template::Plugin but should at least conform to its object-oriented +interface. + +It is recommended that you create plugins in your own package namespace +to avoid conflict with toolkit plugins. e.g. + + package MyOrg::Template::Plugin::FooBar; + +Use the PLUGIN_BASE option to specify the namespace that you use. e.g. + + use Template; + my $template = Template->new({ + PLUGIN_BASE => 'MyOrg::Template::Plugin', + }); + +=head1 PLUGIN API + +The following methods form the basic interface between the Template +Toolkit and plugin modules. + +=over 4 + +=item load($context) + +This method is called by the Template Toolkit when the plugin module +is first loaded. It is called as a package method and thus implicitly +receives the package name as the first parameter. A reference to the +Template::Context object loading the plugin is also passed. The +default behaviour for the load() method is to simply return the class +name. The calling context then uses this class name to call the new() +package method. + + package MyPlugin; + + sub load { # called as MyPlugin->load($context) + my ($class, $context) = @_; + return $class; # returns 'MyPlugin' + } + +=item new($context, @params) + +This method is called to instantiate a new plugin object for the USE +directive. It is called as a package method against the class name +returned by load(). A reference to the Template::Context object creating +the plugin is passed, along with any additional parameters specified in +the USE directive. + + sub new { # called as MyPlugin->new($context) + my ($class, $context, @params) = @_; + bless { + _CONTEXT => $context, + }, $class; # returns blessed MyPlugin object + } + +=item error($error) + +This method, inherited from the Template::Base module, is used for +reporting and returning errors. It can be called as a package method +to set/return the $ERROR package variable, or as an object method to +set/return the object _ERROR member. When called with an argument, it +sets the relevant variable and returns undef. When called without an +argument, it returns the value of the variable. + + sub new { + my ($class, $context, $dsn) = @_; + + return $class->error('No data source specified') + unless $dsn; + + bless { + _DSN => $dsn, + }, $class; + } + + ... + + my $something = MyModule->new() + || die MyModule->error(), "\n"; + + $something->do_something() + || die $something->error(), "\n"; + +=back + +=head1 DEEPER MAGIC + +The Template::Context object that handles the loading and use of +plugins calls the new() and error() methods against the package name +returned by the load() method. In pseudo-code terms, it might look +something like this: + + $class = MyPlugin->load($context); # returns 'MyPlugin' + + $object = $class->new($context, @params) # MyPlugin->new(...) + || die $class->error(); # MyPlugin->error() + +The load() method may alterately return a blessed reference to an +object instance. In this case, new() and error() are then called as +I<object> methods against that prototype instance. + + package YourPlugin; + + sub load { + my ($class, $context) = @_; + bless { + _CONTEXT => $context, + }, $class; + } + + sub new { + my ($self, $context, @params) = @_; + return $self; + } + +In this example, we have implemented a 'Singleton' plugin. One object +gets created when load() is called and this simply returns itself for +each call to new(). + +Another implementation might require individual objects to be created +for every call to new(), but with each object sharing a reference to +some other object to maintain cached data, database handles, etc. +This pseudo-code example demonstrates the principle. + + package MyServer; + + sub load { + my ($class, $context) = @_; + bless { + _CONTEXT => $context, + _CACHE => { }, + }, $class; + } + + sub new { + my ($self, $context, @params) = @_; + MyClient->new($self, @params); + } + + sub add_to_cache { ... } + + sub get_from_cache { ... } + + + package MyClient; + + sub new { + my ($class, $server, $blah) = @_; + bless { + _SERVER => $server, + _BLAH => $blah, + }, $class; + } + + sub get { + my $self = shift; + $self->{ _SERVER }->get_from_cache(@_); + } + + sub put { + my $self = shift; + $self->{ _SERVER }->add_to_cache(@_); + } + +When the plugin is loaded, a MyServer instance is created. The new() +method is called against this object which instantiates and returns a +MyClient object, primed to communicate with the creating MyServer. + +=head1 Template::Plugin Delegation + +As of version 2.01, the Template::Plugin module no longer provides an +AUTOLOAD method to delegate to other objects or classes. This was a +badly designed feature that caused more trouble than good. You can +easily add your own AUTOLOAD method to perform delegation if you +require this kind of functionality. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.60, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Plugins|Template::Plugins>, L<Template::Context|Template::Context> diff --git a/lib/Template/Plugin/Date.pm b/lib/Template/Plugin/Date.pm new file mode 100644 index 0000000..1cd0a60 --- /dev/null +++ b/lib/Template/Plugin/Date.pm @@ -0,0 +1,361 @@ +#============================================================= -*-Perl-*- +# +# Template::Plugin::Date +# +# DESCRIPTION +# +# Plugin to generate formatted date strings. +# +# AUTHORS +# Thierry-Michel Barral <kktos@electron-libre.com> +# Andy Wardley <abw@cre.canon.co.uk> +# +# COPYRIGHT +# Copyright (C) 2000 Thierry-Michel Barral, Andy Wardley. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Date.pm,v 2.66 2003/04/24 09:14:43 abw Exp $ +# +#============================================================================ + +package Template::Plugin::Date; + +use strict; +use vars qw( $VERSION $FORMAT @LOCALE_SUFFIX ); +use base qw( Template::Plugin ); +use Template::Plugin; + +use POSIX (); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.66 $ =~ /(\d+)\.(\d+)/); +$FORMAT = '%H:%M:%S %d-%b-%Y'; # default strftime() format +@LOCALE_SUFFIX = qw( .ISO8859-1 .ISO_8859-15 .US-ASCII .UTF-8 ); + +#------------------------------------------------------------------------ +# new(\%options) +#------------------------------------------------------------------------ + +sub new { + my ($class, $context, $params) = @_; + bless { + $params ? %$params : () + }, $class; +} + + +#------------------------------------------------------------------------ +# now() +# +# Call time() to return the current system time in seconds since the epoch. +#------------------------------------------------------------------------ + +sub now { + return time(); +} + + +#------------------------------------------------------------------------ +# format() +# format($time) +# format($time, $format) +# format($time, $format, $locale) +# format($time, $format, $locale, $gmt_flag) +# format(\%named_params); +# +# Returns a formatted time/date string for the specified time, $time, +# (or the current system time if unspecified) using the $format, $locale, +# and $gmt values specified as arguments or internal values set defined +# at construction time). Specifying a Perl-true value for $gmt will +# override the local time zone and force the output to be for GMT. +# Any or all of the arguments may be specified as named parameters which +# get passed as a hash array reference as the final argument. +# ------------------------------------------------------------------------ + +sub format { + my $self = shift; + my $params = ref($_[$#_]) eq 'HASH' ? pop(@_) : { }; + my $time = shift(@_) || $params->{ time } || $self->{ time } + || $self->now(); + my $format = @_ ? shift(@_) + : ($params->{ format } || $self->{ format } || $FORMAT); + my $locale = @_ ? shift(@_) + : ($params->{ locale } || $self->{ locale }); + my $gmt = @_ ? shift(@_) + : ($params->{ gmt } || $self->{ gmt }); + my (@date, $datestr); + + if ($time =~ /^\d+$/) { + # $time is now in seconds since epoch + if ($gmt) { + @date = (gmtime($time))[0..6]; + } + else { + @date = (localtime($time))[0..6]; + } + } + else { + # if $time is numeric, then we assume it's seconds since the epoch + # otherwise, we try to parse it as a 'H:M:S D:M:Y' string + @date = (split(/(?:\/| |:|-)/, $time))[2,1,0,3..5]; + return (undef, Template::Exception->new('date', + "bad time/date string: expects 'h:m:s d:m:y' got: '$time'")) + unless @date >= 6 && defined $date[5]; + $date[4] -= 1; # correct month number 1-12 to range 0-11 + $date[5] -= 1900; # convert absolute year to years since 1900 + $time = &POSIX::mktime(@date); + } + + if ($locale) { + # format the date in a specific locale, saving and subsequently + # restoring the current locale. + my $old_locale = &POSIX::setlocale(&POSIX::LC_ALL); + + # some systems expect locales to have a particular suffix + for my $suffix ('', @LOCALE_SUFFIX) { + my $try_locale = $locale.$suffix; + my $setlocale = &POSIX::setlocale(&POSIX::LC_ALL, $try_locale); + if (defined $setlocale && $try_locale eq $setlocale) { + $locale = $try_locale; + last; + } + } + $datestr = &POSIX::strftime($format, @date); + &POSIX::setlocale(&POSIX::LC_ALL, $old_locale); + } + else { + $datestr = &POSIX::strftime($format, @date); + } + + return $datestr; +} + +sub calc { + my $self = shift; + eval { require "Date/Calc.pm" }; + $self->throw("failed to load Date::Calc: $@") if $@; + return Template::Plugin::Date::Calc->new('no context'); +} + +sub manip { + my $self = shift; + eval { require "Date/Manip.pm" }; + $self->throw("failed to load Date::Manip: $@") if $@; + return Template::Plugin::Date::Manip->new('no context'); +} + + +sub throw { + my $self = shift; + die (Template::Exception->new('date', join(', ', @_))); +} + + +package Template::Plugin::Date::Calc; +use base qw( Template::Plugin ); +use vars qw( $AUTOLOAD ); +*throw = \&Template::Plugin::Date::throw; + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + + my $sub = \&{"Date::Calc::$method"}; + $self->throw("no such Date::Calc method: $method") + unless $sub; + + &$sub(@_); +} + +package Template::Plugin::Date::Manip; +use base qw( Template::Plugin ); +use vars qw( $AUTOLOAD ); +*throw = \&Template::Plugin::Date::throw; + +sub AUTOLOAD { + my $self = shift; + my $method = $AUTOLOAD; + + $method =~ s/.*:://; + return if $method eq 'DESTROY'; + + my $sub = \&{"Date::Manip::$method"}; + $self->throw("no such Date::Manip method: $method") + unless $sub; + + &$sub(@_); +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Plugin::Date - Plugin to generate formatted date strings + +=head1 SYNOPSIS + + [% USE date %] + + # use current time and default format + [% date.format %] + + # specify time as seconds since epoch or 'h:m:s d-m-y' string + [% date.format(960973980) %] + [% date.format('4:20:36 21/12/2000') %] + + # specify format + [% date.format(mytime, '%H:%M:%S') %] + + # specify locale + [% date.format(date.now, '%a %d %b %y', 'en_GB') %] + + # named parameters + [% date.format(mytime, format = '%H:%M:%S') %] + [% date.format(locale = 'en_GB') %] + [% date.format(time = date.now, + format = '%H:%M:%S', + locale = 'en_GB) %] + + # specify default format to plugin + [% USE date(format = '%H:%M:%S', locale = 'de_DE') %] + + [% date.format %] + ... + +=head1 DESCRIPTION + +The Date plugin provides an easy way to generate formatted time and date +strings by delegating to the POSIX strftime() routine. + +The plugin can be loaded via the familiar USE directive. + + [% USE date %] + +This creates a plugin object with the default name of 'date'. An alternate +name can be specified as such: + + [% USE myname = date %] + +The plugin provides the format() method which accepts a time value, a +format string and a locale name. All of these parameters are optional +with the current system time, default format ('%H:%M:%S %d-%b-%Y') and +current locale being used respectively, if undefined. Default values +for the time, format and/or locale may be specified as named parameters +in the USE directive. + + [% USE date(format = '%a %d-%b-%Y', locale = 'fr_FR') %] + +When called without any parameters, the format() method returns a string +representing the current system time, formatted by strftime() according +to the default format and for the default locale (which may not be the +current one, if locale is set in the USE directive). + + [% date.format %] + +The plugin allows a time/date to be specified as seconds since the epoch, +as is returned by time(). + + File last modified: [% date.format(filemod_time) %] + +The time/date can also be specified as a string of the form 'h:m:s d/m/y'. +Any of the characters : / - or space may be used to delimit fields. + + [% USE day = date(format => '%A', locale => 'en_GB') %] + [% day.format('4:20:00 9-13-2000') %] + +Output: + + Tuesday + +A format string can also be passed to the format() method, and a locale +specification may follow that. + + [% date.format(filemod, '%d-%b-%Y') %] + [% date.format(filemod, '%d-%b-%Y', 'en_GB') %] + +A fourth parameter allows you to force output in GMT, in the case of +seconds-since-the-epoch input: + + [% date.format(filemod, '%d-%b-%Y', 'en_GB', 1) %] + +Note that in this case, if the local time is not GMT, then also specifying +'%Z' (time zone) in the format parameter will lead to an extremely +misleading result. + +Any or all of these parameters may be named. Positional parameters +should always be in the order ($time, $format, $locale). + + [% date.format(format => '%H:%M:%S') %] + [% date.format(time => filemod, format => '%H:%M:%S') %] + [% date.format(mytime, format => '%H:%M:%S') %] + [% date.format(mytime, format => '%H:%M:%S', locale => 'fr_FR') %] + [% date.format(mytime, format => '%H:%M:%S', gmt => 1) %] + ...etc... + +The now() method returns the current system time in seconds since the +epoch. + + [% date.format(date.now, '%A') %] + +The calc() method can be used to create an interface to the Date::Calc +module (if installed on your system). + + [% calc = date.calc %] + [% calc.Monday_of_Week(22, 2001).join('/') %] + +The manip() method can be used to create an interface to the Date::Manip +module (if installed on your system). + + [% manip = date.manip %] + [% manip.UnixDate("Noon Yesterday","%Y %b %d %H:%M") %] + +=head1 AUTHORS + +Thierry-Michel Barral E<lt>kktos@electron-libre.comE<gt> wrote the original +plugin. + +Andy Wardley E<lt>abw@cre.canon.co.ukE<gt> provided some minor +fixups/enhancements, a test script and documentation. + +Mark D. Mills E<lt>mark@hostile.orgE<gt> cloned Date::Manip from the +cute Date::Calc sub-plugin. + +=head1 VERSION + +2.66, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + + + +=head1 COPYRIGHT + +Copyright (C) 2000 Thierry-Michel Barral, Andy Wardley. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template::Plugin|Template::Plugin>, L<POSIX|POSIX> + diff --git a/lib/Template/Plugins.pm b/lib/Template/Plugins.pm new file mode 100644 index 0000000..839c85e --- /dev/null +++ b/lib/Template/Plugins.pm @@ -0,0 +1,1031 @@ +#============================================================= -*-Perl-*- +# +# Template::Plugins +# +# DESCRIPTION +# Plugin provider which handles the loading of plugin modules and +# instantiation of plugin objects. +# +# AUTHORS +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Plugins.pm,v 2.65 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Plugins; + +require 5.004; + +use strict; +use base qw( Template::Base ); +use vars qw( $VERSION $DEBUG $STD_PLUGINS ); +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.65 $ =~ /(\d+)\.(\d+)/); + +$STD_PLUGINS = { + 'autoformat' => 'Template::Plugin::Autoformat', + 'cgi' => 'Template::Plugin::CGI', + 'datafile' => 'Template::Plugin::Datafile', + 'date' => 'Template::Plugin::Date', + 'debug' => 'Template::Plugin::Debug', + 'directory' => 'Template::Plugin::Directory', + 'dbi' => 'Template::Plugin::DBI', + 'dumper' => 'Template::Plugin::Dumper', + 'file' => 'Template::Plugin::File', + 'format' => 'Template::Plugin::Format', + 'html' => 'Template::Plugin::HTML', + 'image' => 'Template::Plugin::Image', + 'iterator' => 'Template::Plugin::Iterator', + 'pod' => 'Template::Plugin::Pod', + 'table' => 'Template::Plugin::Table', + 'url' => 'Template::Plugin::URL', + 'view' => 'Template::Plugin::View', + 'wrap' => 'Template::Plugin::Wrap', + 'xmlstyle' => 'Template::Plugin::XML::Style', +}; + + +#======================================================================== +# -- PUBLIC METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# fetch($name, \@args, $context) +# +# General purpose method for requesting instantiation of a plugin +# object. The name of the plugin is passed as the first parameter. +# The internal FACTORY lookup table is consulted to retrieve the +# appropriate factory object or class name. If undefined, the _load() +# method is called to attempt to load the module and return a factory +# class/object which is then cached for subsequent use. A reference +# to the calling context should be passed as the third parameter. +# This is passed to the _load() class method. The new() method is +# then called against the factory class name or prototype object to +# instantiate a new plugin object, passing any arguments specified by +# list reference as the second parameter. e.g. where $factory is the +# class name 'MyClass', the new() method is called as a class method, +# $factory->new(...), equivalent to MyClass->new(...) . Where +# $factory is a prototype object, the new() method is called as an +# object method, $myobject->new(...). This latter approach allows +# plugins to act as Singletons, cache shared data, etc. +# +# Returns a reference to a plugin, (undef, STATUS_DECLINE) to decline +# the request or ($error, STATUS_ERROR) on error. +#------------------------------------------------------------------------ + +sub fetch { + my ($self, $name, $args, $context) = @_; + my ($factory, $plugin, $error); + + $self->debug("fetch($name, ", + defined $args ? ('[ ', join(', ', @$args), ' ]') : '<no args>', ', ', + defined $context ? $context : '<no context>', + ')') if $self->{ DEBUG }; + + # NOTE: + # the $context ref gets passed as the first parameter to all regular + # plugins, but not to those loaded via LOAD_PERL; to hack around + # this until we have a better implementation, we pass the $args + # reference to _load() and let it unshift the first args in the + # LOAD_PERL case + + $args ||= [ ]; + unshift @$args, $context; + + $factory = $self->{ FACTORY }->{ $name } ||= do { + ($factory, $error) = $self->_load($name, $context); + return ($factory, $error) if $error; ## RETURN + $factory; + }; + + # call the new() method on the factory object or class name + eval { + if (ref $factory eq 'CODE') { + defined( $plugin = &$factory(@$args) ) + || die "$name plugin failed\n"; + } + else { + defined( $plugin = $factory->new(@$args) ) + || die "$name plugin failed: ", $factory->error(), "\n"; + } + }; + if ($error = $@) { +# chomp $error; + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR); + } + + return $plugin; +} + + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init(\%config) +# +# Private initialisation method. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $params) = @_; + my ($pbase, $plugins, $factory) = + @$params{ qw( PLUGIN_BASE PLUGINS PLUGIN_FACTORY ) }; + + $plugins ||= { }; + if (ref $pbase ne 'ARRAY') { + $pbase = $pbase ? [ $pbase ] : [ ]; + } + push(@$pbase, 'Template::Plugin'); + + $self->{ PLUGIN_BASE } = $pbase; + $self->{ PLUGINS } = { %$STD_PLUGINS, %$plugins }; + $self->{ TOLERANT } = $params->{ TOLERANT } || 0; + $self->{ LOAD_PERL } = $params->{ LOAD_PERL } || 0; + $self->{ FACTORY } = $factory || { }; + $self->{ DEBUG } = ( $params->{ DEBUG } || 0 ) + & Template::Constants::DEBUG_PLUGINS; + + return $self; +} + + + +#------------------------------------------------------------------------ +# _load($name, $context) +# +# Private method which attempts to load a plugin module and determine the +# correct factory name or object by calling the load() class method in +# the loaded module. +#------------------------------------------------------------------------ + +sub _load { + my ($self, $name, $context) = @_; + my ($factory, $module, $base, $pkg, $file, $ok, $error); + + if ($module = $self->{ PLUGINS }->{ $name }) { + # plugin module name is explicitly stated in PLUGIN_NAME + $pkg = $module; + ($file = $module) =~ s|::|/|g; + $file =~ s|::|/|g; + $self->debug("loading $module.pm (PLUGIN_NAME)") + if $self->{ DEBUG }; + $ok = eval { require "$file.pm" }; + $error = $@; + } + else { + # try each of the PLUGIN_BASE values to build module name + ($module = $name) =~ s/\./::/g; + + foreach $base (@{ $self->{ PLUGIN_BASE } }) { + $pkg = $base . '::' . $module; + ($file = $pkg) =~ s|::|/|g; + + $self->debug("loading $file.pm (PLUGIN_BASE)") + if $self->{ DEBUG }; + + $ok = eval { require "$file.pm" }; + last unless $@; + + $error .= "$@\n" + unless ($@ =~ /^Can\'t locate $file\.pm/); + } + } + + if ($ok) { + $self->debug("calling $pkg->load()") if $self->{ DEBUG }; + + $factory = eval { $pkg->load($context) }; + $error = ''; + if ($@ || ! $factory) { + $error = $@ || 'load() returned a false value'; + } + } + elsif ($self->{ LOAD_PERL }) { + # fallback - is it a regular Perl module? + ($file = $module) =~ s|::|/|g; + eval { require "$file.pm" }; + if ($@) { + $error = $@; + } + else { + # this is a regular Perl module so the new() constructor + # isn't expecting a $context reference as the first argument; + # so we construct a closure which removes it before calling + # $module->new(@_); + $factory = sub { + shift; + $module->new(@_); + }; + $error = ''; + } + } + + if ($factory) { + $self->debug("$name => $factory") if $self->{ DEBUG }; + return $factory; + } + elsif ($error) { + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR); + } + else { + return (undef, Template::Constants::STATUS_DECLINED); + } +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which constructs and returns text representing the current +# state of the object. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $output = "[Template::Plugins] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + foreach $key (qw( TOLERANT LOAD_PERL )) { + $output .= sprintf($format, $key, $self->{ $key }); + } + + local $" = ', '; + my $fkeys = join(", ", keys %{$self->{ FACTORY }}); + my $plugins = $self->{ PLUGINS }; + $plugins = join('', map { + sprintf(" $format", $_, $plugins->{ $_ }); + } keys %$plugins); + $plugins = "{\n$plugins }"; + + $output .= sprintf($format, 'PLUGIN_BASE', "[ @{ $self->{ PLUGIN_BASE } } ]"); + $output .= sprintf($format, 'PLUGINS', $plugins); + $output .= sprintf($format, 'FACTORY', $fkeys); + $output .= '}'; + return $output; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Plugins - Plugin provider module + +=head1 SYNOPSIS + + use Template::Plugins; + + $plugin_provider = Template::Plugins->new(\%options); + + ($plugin, $error) = $plugin_provider->fetch($name, @args); + +=head1 DESCRIPTION + +The Template::Plugins module defines a provider class which can be used +to load and instantiate Template Toolkit plugin modules. + +=head1 METHODS + +=head2 new(\%params) + +Constructor method which instantiates and returns a reference to a +Template::Plugins object. A reference to a hash array of configuration +items may be passed as a parameter. These are described below. + +Note that the Template.pm front-end module creates a Template::Plugins +provider, passing all configuration items. Thus, the examples shown +below in the form: + + $plugprov = Template::Plugins->new({ + PLUGIN_BASE => 'MyTemplate::Plugin', + LOAD_PERL => 1, + ... + }); + +can also be used via the Template module as: + + $ttengine = Template->new({ + PLUGIN_BASE => 'MyTemplate::Plugin', + LOAD_PERL => 1, + ... + }); + +as well as the more explicit form of: + + $plugprov = Template::Plugins->new({ + PLUGIN_BASE => 'MyTemplate::Plugin', + LOAD_PERL => 1, + ... + }); + + $ttengine = Template->new({ + LOAD_PLUGINS => [ $plugprov ], + }); + +=head2 fetch($name, @args) + +Called to request that a plugin of a given name be provided. The relevant +module is first loaded (if necessary) and the load() class method called +to return the factory class name (usually the same package name) or a +factory object (a prototype). The new() method is then called as a +class or object method against the factory, passing all remaining +parameters. + +Returns a reference to a new plugin object or ($error, STATUS_ERROR) +on error. May also return (undef, STATUS_DECLINED) to decline to +serve the request. If TOLERANT is set then all errors will be +returned as declines. + +=head1 CONFIGURATION OPTIONS + +The following list details the configuration options that can be provided +to the Template::Plugins new() constructor. + +=over 4 + + + + +=item PLUGINS + +The PLUGINS options can be used to provide a reference to a hash array +that maps plugin names to Perl module names. A number of standard +plugins are defined (e.g. 'table', 'cgi', 'dbi', etc.) which map to +their corresponding Template::Plugin::* counterparts. These can be +redefined by values in the PLUGINS hash. + + my $plugins = Template::Plugins->new({ + PLUGINS => { + cgi => 'MyOrg::Template::Plugin::CGI', + foo => 'MyOrg::Template::Plugin::Foo', + bar => 'MyOrg::Template::Plugin::Bar', + }, + }); + +The USE directive is used to create plugin objects and does so by +calling the plugin() method on the current Template::Context object. +If the plugin name is defined in the PLUGINS hash then the +corresponding Perl module is loaded via require(). The context then +calls the load() class method which should return the class name +(default and general case) or a prototype object against which the +new() method can be called to instantiate individual plugin objects. + +If the plugin name is not defined in the PLUGINS hash then the PLUGIN_BASE +and/or LOAD_PERL options come into effect. + + + + + +=item PLUGIN_BASE + +If a plugin is not defined in the PLUGINS hash then the PLUGIN_BASE is used +to attempt to construct a correct Perl module name which can be successfully +loaded. + +The PLUGIN_BASE can be specified as a single value or as a reference +to an array of multiple values. The default PLUGIN_BASE value, +'Template::Plugin', is always added the the end of the PLUGIN_BASE +list (a single value is first converted to a list). Each value should +contain a Perl package name to which the requested plugin name is +appended. + +example 1: + + my $plugins = Template::Plugins->new({ + PLUGIN_BASE => 'MyOrg::Template::Plugin', + }); + + [% USE Foo %] # => MyOrg::Template::Plugin::Foo + or Template::Plugin::Foo + +example 2: + + my $plugins = Template::Plugins->new({ + PLUGIN_BASE => [ 'MyOrg::Template::Plugin', + 'YourOrg::Template::Plugin' ], + }); + + [% USE Foo %] # => MyOrg::Template::Plugin::Foo + or YourOrg::Template::Plugin::Foo + or Template::Plugin::Foo + + + + + + +=item LOAD_PERL + +If a plugin cannot be loaded using the PLUGINS or PLUGIN_BASE +approaches then the provider can make a final attempt to load the +module without prepending any prefix to the module path. This allows +regular Perl modules (i.e. those that don't reside in the +Template::Plugin or some other such namespace) to be loaded and used +as plugins. + +By default, the LOAD_PERL option is set to 0 and no attempt will be made +to load any Perl modules that aren't named explicitly in the PLUGINS +hash or reside in a package as named by one of the PLUGIN_BASE +components. + +Plugins loaded using the PLUGINS or PLUGIN_BASE receive a reference to +the current context object as the first argument to the new() +constructor. Modules loaded using LOAD_PERL are assumed to not +conform to the plugin interface. They must provide a new() class +method for instantiating objects but it will not receive a reference +to the context as the first argument. Plugin modules should provide a +load() class method (or inherit the default one from the +Template::Plugin base class) which is called the first time the plugin +is loaded. Regular Perl modules need not. In all other respects, +regular Perl objects and Template Toolkit plugins are identical. + +If a particular Perl module does not conform to the common, but not +unilateral, new() constructor convention then a simple plugin wrapper +can be written to interface to it. + + + + +=item TOLERANT + +The TOLERANT flag is used by the various Template Toolkit provider +modules (Template::Provider, Template::Plugins, Template::Filters) to +control their behaviour when errors are encountered. By default, any +errors are reported as such, with the request for the particular +resource (template, plugin, filter) being denied and an exception +raised. When the TOLERANT flag is set to any true values, errors will +be silently ignored and the provider will instead return +STATUS_DECLINED. This allows a subsequent provider to take +responsibility for providing the resource, rather than failing the +request outright. If all providers decline to service the request, +either through tolerated failure or a genuine disinclination to +comply, then a 'E<lt>resourceE<gt> not found' exception is raised. + + + + +=item DEBUG + +The DEBUG option can be used to enable debugging messages from the +Template::Plugins module by setting it to include the DEBUG_PLUGINS +value. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_FILTERS | DEBUG_PLUGINS, + }); + + + + +=back + + + +=head1 TEMPLATE TOOLKIT PLUGINS + +The following plugin modules are distributed with the Template +Toolkit. Some of the plugins interface to external modules (detailed +below) which should be downloaded from any CPAN site and installed +before using the plugin. + +=head2 Autoformat + +The Autoformat plugin is an interface to Damian Conway's Text::Autoformat +Perl module which provides advanced text wrapping and formatting. See +L<Template::Plugin::Autoformat> and L<Text::Autoformat> for further +details. + + [% USE autoformat(left=10, right=20) %] + [% autoformat(mytext) %] # call autoformat sub + [% mytext FILTER autoformat %] # or use autoformat filter + +The Text::Autoformat module is available from CPAN: + + http://www.cpan.org/modules/by-module/Text/ + +=head2 CGI + +The CGI plugin is a wrapper around Lincoln Stein's +E<lt>lstein@genome.wi.mit.eduE<gt> CGI.pm module. The plugin is +distributed with the Template Toolkit (see L<Template::Plugin::CGI>) +and the CGI module itself is distributed with recent versions Perl, +or is available from CPAN. + + [% USE CGI %] + [% CGI.param('param_name') %] + [% CGI.start_form %] + [% CGI.popup_menu( Name => 'color', + Values => [ 'Green', 'Brown' ] ) %] + [% CGI.end_form %] + +=head2 Datafile + +Provides an interface to data stored in a plain text file in a simple +delimited format. The first line in the file specifies field names +which should be delimiter by any non-word character sequence. +Subsequent lines define data using the same delimiter as int he first +line. Blank lines and comments (lines starting '#') are ignored. See +L<Template::Plugin::Datafile> for further details. + +/tmp/mydata: + + # define names for each field + id : email : name : tel + # here's the data + fred : fred@here.com : Fred Smith : 555-1234 + bill : bill@here.com : Bill White : 555-5678 + +example: + + [% USE userlist = datafile('/tmp/mydata') %] + + [% FOREACH user = userlist %] + [% user.name %] ([% user.id %]) + [% END %] + +=head2 Date + +The Date plugin provides an easy way to generate formatted time and date +strings by delegating to the POSIX strftime() routine. See +L<Template::Plugin::Date> and L<POSIX> for further details. + + [% USE date %] + [% date.format %] # current time/date + + File last modified: [% date.format(template.modtime) %] + +=head2 Directory + +The Directory plugin provides a simple interface to a directory and +the files within it. See L<Template::Plugin::Directory> for further +details. + + [% USE dir = Directory('/tmp') %] + [% FOREACH file = dir.files %] + # all the plain files in the directory + [% END %] + [% FOREACH file = dir.dirs %] + # all the sub-directories + [% END %] + +=head2 DBI + +The DBI plugin, developed by Simon Matthews +E<lt>sam@knowledgepool.comE<gt>, brings the full power of Tim Bunce's +E<lt>Tim.Bunce@ig.co.ukE<gt> database interface module (DBI) to your +templates. See L<Template::Plugin::DBI> and L<DBI> for further details. + + [% USE DBI('dbi:driver:database', 'user', 'pass') %] + + [% FOREACH user = DBI.query( 'SELECT * FROM users' ) %] + [% user.id %] [% user.name %] + [% END %] + +The DBI and relevant DBD modules are available from CPAN: + + http://www.cpan.org/modules/by-module/DBI/ + +=head2 Dumper + +The Dumper plugin provides an interface to the Data::Dumper module. See +L<Template::Plugin::Dumper> and L<Data::Dumper> for futher details. + + [% USE dumper(indent=0, pad="<br>") %] + [% dumper.dump(myvar, yourvar) %] + +=head2 File + +The File plugin provides a general abstraction for files and can be +used to fetch information about specific files within a filesystem. +See L<Template::Plugin::File> for further details. + + [% USE File('/tmp/foo.html') %] + [% File.name %] # foo.html + [% File.dir %] # /tmp + [% File.mtime %] # modification time + +=head2 Filter + +This module implements a base class plugin which can be subclassed +to easily create your own modules that define and install new filters. + + package MyOrg::Template::Plugin::MyFilter; + + use Template::Plugin::Filter; + use base qw( Template::Plugin::Filter ); + + sub filter { + my ($self, $text) = @_; + + # ...mungify $text... + + return $text; + } + + # now load it... + [% USE MyFilter %] + + # ...and use the returned object as a filter + [% FILTER $MyFilter %] + ... + [% END %] + +See L<Template::Plugin::Filter> for further details. + +=head2 Format + +The Format plugin provides a simple way to format text according to a +printf()-like format. See L<Template::Plugin::Format> for further +details. + + [% USE bold = format('<b>%s</b>') %] + [% bold('Hello') %] + +=head2 GD::Image, GD::Polygon, GD::Constants + +These plugins provide access to the GD graphics library via Lincoln +D. Stein's GD.pm interface. These plugins allow PNG, JPEG and other +graphical formats to be generated. + + [% FILTER null; + USE im = GD.Image(100,100); + # allocate some colors + black = im.colorAllocate(0, 0, 0); + red = im.colorAllocate(255,0, 0); + blue = im.colorAllocate(0, 0, 255); + # Draw a blue oval + im.arc(50,50,95,75,0,360,blue); + # And fill it with red + im.fill(50,50,red); + # Output image in PNG format + im.png | stdout(1); + END; + -%] + +See L<Template::Plugin::GD::Image> for further details. + +=head2 GD::Text, GD::Text::Align, GD::Text::Wrap + +These plugins provide access to Martien Verbruggen's GD::Text, +GD::Text::Align and GD::Text::Wrap modules. These plugins allow the +layout, alignment and wrapping of text when drawing text in GD images. + + [% FILTER null; + USE gd = GD.Image(200,400); + USE gdc = GD.Constants; + black = gd.colorAllocate(0, 0, 0); + green = gd.colorAllocate(0, 255, 0); + txt = "This is some long text. " | repeat(10); + USE wrapbox = GD.Text.Wrap(gd, + line_space => 4, + color => green, + text => txt, + ); + wrapbox.set_font(gdc.gdMediumBoldFont); + wrapbox.set(align => 'center', width => 160); + wrapbox.draw(20, 20); + gd.png | stdout(1); + END; + -%] + +See L<Template::Plugin::GD::Text>, L<Template::Plugin::GD::Text::Align> +and L<Template::Plugin::GD::Text::Wrap> for further details. + +=head2 GD::Graph::lines, GD::Graph::bars, GD::Graph::points, GD::Graph::linespoin +ts, GD::Graph::area, GD::Graph::mixed, GD::Graph::pie + +These plugins provide access to Martien Verbruggen's GD::Graph module +that allows graphs, plots and charts to be created. These plugins allow +graphs, plots and charts to be generated in PNG, JPEG and other +graphical formats. + + [% FILTER null; + data = [ + ["1st","2nd","3rd","4th","5th","6th"], + [ 4, 2, 3, 4, 3, 3.5] + ]; + USE my_graph = GD.Graph.pie(250, 200); + my_graph.set( + title => 'A Pie Chart', + label => 'Label', + axislabelclr => 'black', + pie_height => 36, + transparent => 0, + ); + my_graph.plot(data).png | stdout(1); + END; + -%] + +See +L<Template::Plugin::GD::Graph::lines>, +L<Template::Plugin::GD::Graph::bars>, +L<Template::Plugin::GD::Graph::points>, +L<Template::Plugin::GD::Graph::linespoints>, +L<Template::Plugin::GD::Graph::area>, +L<Template::Plugin::GD::Graph::mixed>, +L<Template::Plugin::GD::Graph::pie>, and +L<GD::Graph>, +for more details. + +=head2 GD::Graph::bars3d, GD::Graph::lines3d, GD::Graph::pie3d + +These plugins provide access to Jeremy Wadsack's GD::Graph3d +module. This allows 3D bar charts and 3D lines plots to +be generated. + + [% FILTER null; + data = [ + ["1st","2nd","3rd","4th","5th","6th","7th", "8th", "9th"], + [ 1, 2, 5, 6, 3, 1.5, 1, 3, 4], + ]; + USE my_graph = GD.Graph.bars3d(); + my_graph.set( + x_label => 'X Label', + y_label => 'Y label', + title => 'A 3d Bar Chart', + y_max_value => 8, + y_tick_number => 8, + y_label_skip => 2, + # shadows + bar_spacing => 8, + shadow_depth => 4, + shadowclr => 'dred', + transparent => 0, + my_graph.plot(data).png | stdout(1); + END; + -%] + +See +L<Template::Plugin::GD::Graph::lines3d>, +L<Template::Plugin::GD::Graph::bars3d>, and +L<Template::Plugin::GD::Graph::pie3d> +for more details. + +=head2 HTML + +The HTML plugin is very new and very basic, implementing a few useful +methods for generating HTML. It is likely to be extended in the future +or integrated with a larger project to generate HTML elements in a generic +way (as discussed recently on the mod_perl mailing list). + + [% USE HTML %] + [% HTML.escape("if (a < b && c > d) ..." %] + [% HTML.attributes(border => 1, cellpadding => 2) %] + [% HTML.element(table => { border => 1, cellpadding => 2 }) %] + +See L<Template::Plugin::HTML> for further details. + +=head2 Iterator + +The Iterator plugin provides a way to create a Template::Iterator +object to iterate over a data set. An iterator is created +automatically by the FOREACH directive and is aliased to the 'loop' +variable. This plugin allows an iterator to be explicitly created +with a given name, or the default plugin name, 'iterator'. See +L<Template::Plugin::Iterator> for further details. + + [% USE iterator(list, args) %] + + [% FOREACH item = iterator %] + [% '<ul>' IF iterator.first %] + <li>[% item %] + [% '</ul>' IF iterator.last %] + [% END %] + +=head2 Pod + +This plugin provides an interface to the L<Pod::POM|Pod::POM> module +which parses POD documents into an internal object model which can +then be traversed and presented through the Template Toolkit. + + [% USE Pod(podfile) %] + + [% FOREACH head1 = Pod.head1; + FOREACH head2 = head1/head2; + ... + END; + END + %] + +=head2 String + +The String plugin implements an object-oriented interface for +manipulating strings. See L<Template::Plugin::String> for further +details. + + [% USE String 'Hello' %] + [% String.append(' World') %] + + [% msg = String.new('Another string') %] + [% msg.replace('string', 'text') %] + + The string "[% msg %]" is [% msg.length %] characters long. + +=head2 Table + +The Table plugin allows you to format a list of data items into a +virtual table by specifying a fixed number of rows or columns, with +an optional overlap. See L<Template::Plugin::Table> for further +details. + + [% USE table(list, rows=10, overlap=1) %] + + [% FOREACH item = table.col(3) %] + [% item %] + [% END %] + +=head2 URL + +The URL plugin provides a simple way of contructing URLs from a base +part and a variable set of parameters. See L<Template::Plugin::URL> +for further details. + + [% USE mycgi = url('/cgi-bin/bar.pl', debug=1) %] + + [% mycgi %] + # ==> /cgi/bin/bar.pl?debug=1 + + [% mycgi(mode='submit') %] + # ==> /cgi/bin/bar.pl?mode=submit&debug=1 + +=head2 Wrap + +The Wrap plugin uses the Text::Wrap module by David Muir Sharnoff +E<lt>muir@idiom.comE<gt> (with help from Tim Pierce and many many others) +to provide simple paragraph formatting. See L<Template::Plugin::Wrap> +and L<Text::Wrap> for further details. + + [% USE wrap %] + [% wrap(mytext, 40, '* ', ' ') %] # use wrap sub + [% mytext FILTER wrap(40) -%] # or wrap FILTER + +The Text::Wrap module is available from CPAN: + + http://www.cpan.org/modules/by-module/Text/ + +=head2 XML::DOM + +The XML::DOM plugin gives access to the XML Document Object Module via +Clark Cooper E<lt>cooper@sch.ge.comE<gt> and Enno Derksen's +E<lt>enno@att.comE<gt> XML::DOM module. See L<Template::Plugin::XML::DOM> +and L<XML::DOM> for further details. + + [% USE dom = XML.DOM %] + [% doc = dom.parse(filename) %] + + [% FOREACH node = doc.getElementsByTagName('CODEBASE') %] + * [% node.getAttribute('href') %] + [% END %] + +The plugin requires the XML::DOM module, available from CPAN: + + http://www.cpan.org/modules/by-module/XML/ + +=head2 XML::RSS + +The XML::RSS plugin is a simple interface to Jonathan Eisenzopf's +E<lt>eisen@pobox.comE<gt> XML::RSS module. A RSS (Rich Site Summary) +file is typically used to store short news 'headlines' describing +different links within a site. This plugin allows you to parse RSS +files and format the contents accordingly using templates. +See L<Template::Plugin::XML::RSS> and L<XML::RSS> for further details. + + [% USE news = XML.RSS(filename) %] + + [% FOREACH item = news.items %] + <a href="[% item.link %]">[% item.title %]</a> + [% END %] + +The XML::RSS module is available from CPAN: + + http://www.cpan.org/modules/by-module/XML/ + +=head2 XML::Simple + +This plugin implements an interface to the L<XML::Simple|XML::Simple> +module. + + [% USE xml = XML.Simple(xml_file_or_text) %] + + [% xml.head.title %] + +See L<Template::Plugin::XML::Simple> for further details. + +=head2 XML::Style + +This plugin defines a filter for performing simple stylesheet based +transformations of XML text. + + [% USE xmlstyle + table = { + attributes = { + border = 0 + cellpadding = 4 + cellspacing = 1 + } + } + %] + + [% FILTER xmlstyle %] + <table> + <tr> + <td>Foo</td> <td>Bar</td> <td>Baz</td> + </tr> + </table> + [% END %] + +See L<Template::Plugin::XML::Style> for further details. + +=head2 XML::XPath + +The XML::XPath plugin provides an interface to Matt Sergeant's +E<lt>matt@sergeant.orgE<gt> XML::XPath module. See +L<Template::Plugin::XML::XPath> and L<XML::XPath> for further details. + + [% USE xpath = XML.XPath(xmlfile) %] + [% FOREACH page = xpath.findnodes('/html/body/page') %] + [% page.getAttribute('title') %] + [% END %] + +The plugin requires the XML::XPath module, available from CPAN: + + http://www.cpan.org/modules/by-module/XML/ + + + + +=head1 BUGS / ISSUES + +=over 4 + +=item * + +It might be worthwhile being able to distinguish between absolute +module names and those which should be applied relative to PLUGIN_BASE +directories. For example, use 'MyNamespace::MyModule' to denote +absolute module names (e.g. LOAD_PERL), and 'MyNamespace.MyModule' to +denote relative to PLUGIN_BASE. + +=back + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.65, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Plugin|Template::Plugin>, L<Template::Context|Template::Context> diff --git a/lib/Template/Provider.pm b/lib/Template/Provider.pm new file mode 100644 index 0000000..ee599de --- /dev/null +++ b/lib/Template/Provider.pm @@ -0,0 +1,1433 @@ +#============================================================= -*-Perl-*- +# +# Template::Provider +# +# DESCRIPTION +# This module implements a class which handles the loading, compiling +# and caching of templates. Multiple Template::Provider objects can +# be stacked and queried in turn to effect a Chain-of-Command between +# them. A provider will attempt to return the requested template, +# an error (STATUS_ERROR) or decline to provide the template +# (STATUS_DECLINE), allowing subsequent providers to attempt to +# deliver it. See 'Design Patterns' for further details. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# TODO: +# * optional provider prefix (e.g. 'http:') +# * fold ABSOLUTE and RELATIVE test cases into one regex? +# +#---------------------------------------------------------------------------- +# +# $Id: Provider.pm,v 2.70 2003/04/24 09:14:38 abw Exp $ +# +#============================================================================ + +package Template::Provider; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $ERROR $DOCUMENT $STAT_TTL $MAX_DIRS ); +use base qw( Template::Base ); +use Template::Config; +use Template::Constants; +use Template::Document; +use File::Basename; +use File::Spec; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.70 $ =~ /(\d+)\.(\d+)/); + +# name of document class +$DOCUMENT = 'Template::Document' unless defined $DOCUMENT; + +# maximum time between performing stat() on file to check staleness +$STAT_TTL = 1 unless defined $STAT_TTL; + +# maximum number of directories in an INCLUDE_PATH, to prevent runaways +$MAX_DIRS = 64 unless defined $MAX_DIRS; + +use constant PREV => 0; +use constant NAME => 1; +use constant DATA => 2; +use constant LOAD => 3; +use constant NEXT => 4; +use constant STAT => 5; + +$DEBUG = 0 unless defined $DEBUG; + +#======================================================================== +# -- PUBLIC METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# fetch($name) +# +# Returns a compiled template for the name specified by parameter. +# The template is returned from the internal cache if it exists, or +# loaded and then subsequently cached. The ABSOLUTE and RELATIVE +# configuration flags determine if absolute (e.g. '/something...') +# and/or relative (e.g. './something') paths should be honoured. The +# INCLUDE_PATH is otherwise used to find the named file. $name may +# also be a reference to a text string containing the template text, +# or a file handle from which the content is read. The compiled +# template is not cached in these latter cases given that there is no +# filename to cache under. A subsequent call to store($name, +# $compiled) can be made to cache the compiled template for future +# fetch() calls, if necessary. +# +# Returns a compiled template or (undef, STATUS_DECLINED) if the +# template could not be found. On error (e.g. the file was found +# but couldn't be read or parsed), the pair ($error, STATUS_ERROR) +# is returned. The TOLERANT configuration option can be set to +# downgrade any errors to STATUS_DECLINE. +#------------------------------------------------------------------------ + +sub fetch { + my ($self, $name) = @_; + my ($data, $error); + + if (ref $name) { + # $name can be a reference to a scalar, GLOB or file handle + ($data, $error) = $self->_load($name); + ($data, $error) = $self->_compile($data) + unless $error; + $data = $data->{ data } + unless $error; + } + elsif (File::Spec->file_name_is_absolute($name)) { + # absolute paths (starting '/') allowed if ABSOLUTE set + ($data, $error) = $self->{ ABSOLUTE } + ? $self->_fetch($name) + : $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ("$name: absolute paths are not allowed (set ABSOLUTE option)", + Template::Constants::STATUS_ERROR); + } + elsif ($name =~ m[^\.+/]) { + # anything starting "./" is relative to cwd, allowed if RELATIVE set + ($data, $error) = $self->{ RELATIVE } + ? $self->_fetch($name) + : $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ("$name: relative paths are not allowed (set RELATIVE option)", + Template::Constants::STATUS_ERROR); + } + else { + # otherwise, it's a file name relative to INCLUDE_PATH + ($data, $error) = $self->{ INCLUDE_PATH } + ? $self->_fetch_path($name) + : (undef, Template::Constants::STATUS_DECLINED); + } + +# $self->_dump_cache() +# if $DEBUG > 1; + + return ($data, $error); +} + + +#------------------------------------------------------------------------ +# store($name, $data) +# +# Store a compiled template ($data) in the cached as $name. +#------------------------------------------------------------------------ + +sub store { + my ($self, $name, $data) = @_; + $self->_store($name, { + data => $data, + load => 0, + }); +} + + +#------------------------------------------------------------------------ +# load($name) +# +# Load a template without parsing/compiling it, suitable for use with +# the INSERT directive. There's some duplication with fetch() and at +# some point this could be reworked to integrate them a little closer. +#------------------------------------------------------------------------ + +sub load { + my ($self, $name) = @_; + my ($data, $error); + my $path = $name; + + if (File::Spec->file_name_is_absolute($name)) { + # absolute paths (starting '/') allowed if ABSOLUTE set + $error = "$name: absolute paths are not allowed (set ABSOLUTE option)" + unless $self->{ ABSOLUTE }; + } + elsif ($name =~ m[^\.+/]) { + # anything starting "./" is relative to cwd, allowed if RELATIVE set + $error = "$name: relative paths are not allowed (set RELATIVE option)" + unless $self->{ RELATIVE }; + } + else { + INCPATH: { + # otherwise, it's a file name relative to INCLUDE_PATH + my $paths = $self->paths() + || return ($self->error(), Template::Constants::STATUS_ERROR); + + foreach my $dir (@$paths) { + $path = "$dir/$name"; + last INCPATH + if -f $path; + } + undef $path; # not found + } + } + + if (defined $path && ! $error) { + local $/ = undef; # slurp files in one go + local *FH; + if (open(FH, $path)) { + $data = <FH>; + close(FH); + } + else { + $error = "$name: $!"; + } + } + + if ($error) { + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR); + } + elsif (! defined $path) { + return (undef, Template::Constants::STATUS_DECLINED); + } + else { + return ($data, Template::Constants::STATUS_OK); + } +} + + + +#------------------------------------------------------------------------ +# include_path(\@newpath) +# +# Accessor method for the INCLUDE_PATH setting. If called with an +# argument, this method will replace the existing INCLUDE_PATH with +# the new value. +#------------------------------------------------------------------------ + +sub include_path { + my ($self, $path) = @_; + $self->{ INCLUDE_PATH } = $path if $path; + return $self->{ INCLUDE_PATH }; +} + + +#------------------------------------------------------------------------ +# paths() +# +# Evaluates the INCLUDE_PATH list, ignoring any blank entries, and +# calling and subroutine or object references to return dynamically +# generated path lists. Returns a reference to a new list of paths +# or undef on error. +#------------------------------------------------------------------------ + +sub paths { + my $self = shift; + my @ipaths = @{ $self->{ INCLUDE_PATH } }; + my (@opaths, $dpaths, $dir); + my $count = $MAX_DIRS; + + while (@ipaths && --$count) { + $dir = shift @ipaths || next; + + # $dir can be a sub or object ref which returns a reference + # to a dynamically generated list of search paths. + + if (ref $dir eq 'CODE') { + eval { $dpaths = &$dir() }; + if ($@) { + chomp $@; + return $self->error($@); + } + unshift(@ipaths, @$dpaths); + next; + } + elsif (UNIVERSAL::can($dir, 'paths')) { + $dpaths = $dir->paths() + || return $self->error($dir->error()); + unshift(@ipaths, @$dpaths); + next; + } + else { + push(@opaths, $dir); + } + } + return $self->error("INCLUDE_PATH exceeds $MAX_DIRS directories") + if @ipaths; + + return \@opaths; +} + + +#------------------------------------------------------------------------ +# DESTROY +# +# The provider cache is implemented as a doubly linked list which Perl +# cannot free by itself due to the circular references between NEXT <=> +# PREV items. This cleanup method walks the list deleting all the NEXT/PREV +# references, allowing the proper cleanup to occur and memory to be +# repooled. +#------------------------------------------------------------------------ + +sub DESTROY { + my $self = shift; + my ($slot, $next); + + $slot = $self->{ HEAD }; + while ($slot) { + $next = $slot->[ NEXT ]; + undef $slot->[ PREV ]; + undef $slot->[ NEXT ]; + $slot = $next; + } + undef $self->{ HEAD }; + undef $self->{ TAIL }; +} + + + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init() +# +# Initialise the cache. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $params) = @_; + my $size = $params->{ CACHE_SIZE }; + my $path = $params->{ INCLUDE_PATH } || '.'; + my $cdir = $params->{ COMPILE_DIR } || ''; + my $dlim = $params->{ DELIMITER }; + my $debug; + + # tweak delim to ignore C:/ + unless (defined $dlim) { + $dlim = ($^O eq 'MSWin32') ? ':(?!\\/)' : ':'; + } + + # coerce INCLUDE_PATH to an array ref, if not already so + $path = [ split(/$dlim/, $path) ] + unless ref $path eq 'ARRAY'; + + # don't allow a CACHE_SIZE 1 because it breaks things and the + # additional checking isn't worth it + $size = 2 + if defined $size && ($size == 1 || $size < 0); + + if (defined ($debug = $params->{ DEBUG })) { + $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PROVIDER + | Template::Constants::DEBUG_FLAGS ); + } + else { + $self->{ DEBUG } = $DEBUG; + } + + if ($self->{ DEBUG }) { + local $" = ', '; + $self->debug("creating cache of ", + defined $size ? $size : 'unlimited', + " slots for [ @$path ]"); + } + + # create COMPILE_DIR and sub-directories representing each INCLUDE_PATH + # element in which to store compiled files + if ($cdir) { + +# Stas' hack +# # this is a hack to solve the problem with INCLUDE_PATH using +# # relative dirs +# my $segments = 0; +# for (@$path) { +# my $c = 0; +# $c++ while m|\.\.|g; +# $segments = $c if $c > $segments; +# } +# $cdir .= "/".join "/",('hack') x $segments if $segments; +# + + require File::Path; + foreach my $dir (@$path) { + next if ref $dir; + my $wdir = $dir; + $wdir =~ s[:][]g if $^O eq 'MSWin32'; + $wdir =~ /(.*)/; # untaint + &File::Path::mkpath(File::Spec->catfile($cdir, $1)); + } + } + + $self->{ LOOKUP } = { }; + $self->{ SLOTS } = 0; + $self->{ SIZE } = $size; + $self->{ INCLUDE_PATH } = $path; + $self->{ DELIMITER } = $dlim; + $self->{ COMPILE_DIR } = $cdir; + $self->{ COMPILE_EXT } = $params->{ COMPILE_EXT } || ''; + $self->{ ABSOLUTE } = $params->{ ABSOLUTE } || 0; + $self->{ RELATIVE } = $params->{ RELATIVE } || 0; + $self->{ TOLERANT } = $params->{ TOLERANT } || 0; + $self->{ DOCUMENT } = $params->{ DOCUMENT } || $DOCUMENT; + $self->{ PARSER } = $params->{ PARSER }; + $self->{ DEFAULT } = $params->{ DEFAULT }; +# $self->{ PREFIX } = $params->{ PREFIX }; + $self->{ PARAMS } = $params; + + return $self; +} + + +#------------------------------------------------------------------------ +# _fetch($name) +# +# Fetch a file from cache or disk by specification of an absolute or +# relative filename. No search of the INCLUDE_PATH is made. If the +# file is found and loaded, it is compiled and cached. +#------------------------------------------------------------------------ + +sub _fetch { + my ($self, $name) = @_; + my $size = $self->{ SIZE }; + my ($slot, $data, $error); + + $self->debug("_fetch($name)") if $self->{ DEBUG }; + + my $compiled = $self->_compiled_filename($name); + + if (defined $size && ! $size) { + # caching disabled so load and compile but don't cache + if ($compiled && -f $compiled && (stat($name))[9] <= (stat($compiled))[9]) { + $data = $self->_load_compiled($compiled); + $error = $self->error() unless $data; + } + else { + ($data, $error) = $self->_load($name); + ($data, $error) = $self->_compile($data, $compiled) + unless $error; + $data = $data->{ data } + unless $error; + } + } + elsif ($slot = $self->{ LOOKUP }->{ $name }) { + # cached entry exists, so refresh slot and extract data + ($data, $error) = $self->_refresh($slot); + $data = $slot->[ DATA ] + unless $error; + } + else { + # nothing in cache so try to load, compile and cache + if ($compiled && -f $compiled && (stat($name))[9] <= (stat($compiled))[9]) { + $data = $self->_load_compiled($compiled); + $error = $self->error() unless $data; + $self->store($name, $data) unless $error; + } + else { + ($data, $error) = $self->_load($name); + ($data, $error) = $self->_compile($data, $compiled) + unless $error; + $data = $self->_store($name, $data) + unless $error; + } + + } + + return ($data, $error); +} + + +#------------------------------------------------------------------------ +# _fetch_path($name) +# +# Fetch a file from cache or disk by specification of an absolute cache +# name (e.g. 'header') or filename relative to one of the INCLUDE_PATH +# directories. If the file isn't already cached and can be found and +# loaded, it is compiled and cached under the full filename. +#------------------------------------------------------------------------ + +sub _fetch_path { + my ($self, $name) = @_; + my ($size, $compext, $compdir) = + @$self{ qw( SIZE COMPILE_EXT COMPILE_DIR ) }; + my ($dir, $paths, $path, $compiled, $slot, $data, $error); + local *FH; + + $self->debug("_fetch_path($name)") if $self->{ DEBUG }; + + # caching is enabled if $size is defined and non-zero or undefined + my $caching = (! defined $size || $size); + + INCLUDE: { + + # the template may have been stored using a non-filename name + if ($caching && ($slot = $self->{ LOOKUP }->{ $name })) { + # cached entry exists, so refresh slot and extract data + ($data, $error) = $self->_refresh($slot); + $data = $slot->[ DATA ] + unless $error; + last INCLUDE; + } + + $paths = $self->paths() || do { + $error = Template::Constants::STATUS_ERROR; + $data = $self->error(); + last INCLUDE; + }; + + # search the INCLUDE_PATH for the file, in cache or on disk + foreach $dir (@$paths) { + $path = "$dir/$name"; + + $self->debug("searching path: $path\n") if $self->{ DEBUG }; + + if ($caching && ($slot = $self->{ LOOKUP }->{ $path })) { + # cached entry exists, so refresh slot and extract data + ($data, $error) = $self->_refresh($slot); + $data = $slot->[ DATA ] + unless $error; + last INCLUDE; + } + elsif (-f $path) { + $compiled = $self->_compiled_filename($path) + if $compext || $compdir; + + if ($compiled && -f $compiled && (stat($path))[9] <= (stat($compiled))[9]) { + if ($data = $self->_load_compiled($compiled)) { + # store in cache + $data = $self->store($path, $data); + $error = Template::Constants::STATUS_OK; + last INCLUDE; + } + else { + warn($self->error(), "\n"); + } + } + # $compiled is set if an attempt to write the compiled + # template to disk should be made + + ($data, $error) = $self->_load($path, $name); + ($data, $error) = $self->_compile($data, $compiled) + unless $error; + $data = $self->_store($path, $data) + unless $error || ! $caching; + $data = $data->{ data } if ! $caching; + # all done if $error is OK or ERROR + last INCLUDE if ! $error + || $error == Template::Constants::STATUS_ERROR; + } + } + # template not found, so look for a DEFAULT template + my $default; + if (defined ($default = $self->{ DEFAULT }) && $name ne $default) { + $name = $default; + redo INCLUDE; + } + ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); + } # INCLUDE + + return ($data, $error); +} + + + +sub _compiled_filename { + my ($self, $file) = @_; + my ($compext, $compdir) = @$self{ qw( COMPILE_EXT COMPILE_DIR ) }; + my ($path, $compiled); + + return undef + unless $compext || $compdir; + + $path = $file; + $path =~ /^(.+)$/s or die "invalid filename: $path"; + $path =~ s[:][]g if $^O eq 'MSWin32'; + + $compiled = "$path$compext"; + $compiled = File::Spec->catfile($compdir, $compiled) if length $compdir; + + return $compiled; +} + + +sub _load_compiled { + my ($self, $file) = @_; + my $compiled; + + # load compiled template via require(); we zap any + # %INC entry to ensure it is reloaded (we don't + # want 1 returned by require() to say it's in memory) + delete $INC{ $file }; + eval { $compiled = require $file; }; + return $@ + ? $self->error("compiled template $compiled: $@") + : $compiled; +} + + + +#------------------------------------------------------------------------ +# _load($name, $alias) +# +# Load template text from a string ($name = scalar ref), GLOB or file +# handle ($name = ref), or from an absolute filename ($name = scalar). +# Returns a hash array containing the following items: +# name filename or $alias, if provided, or 'input text', etc. +# text template text +# time modification time of file, or current time for handles/strings +# load time file was loaded (now!) +# +# On error, returns ($error, STATUS_ERROR), or (undef, STATUS_DECLINED) +# if TOLERANT is set. +#------------------------------------------------------------------------ + +sub _load { + my ($self, $name, $alias) = @_; + my ($data, $error); + my $tolerant = $self->{ TOLERANT }; + my $now = time; + local $/ = undef; # slurp files in one go + local *FH; + + $alias = $name unless defined $alias or ref $name; + + $self->debug("_load($name, ", defined $alias ? $alias : '<no alias>', + ')') if $self->{ DEBUG }; + + LOAD: { + if (ref $name eq 'SCALAR') { + # $name can be a SCALAR reference to the input text... + $data = { + name => defined $alias ? $alias : 'input text', + text => $$name, + time => $now, + load => 0, + }; + } + elsif (ref $name) { + # ...or a GLOB or file handle... + my $text = <$name>; + $data = { + name => defined $alias ? $alias : 'input file handle', + text => $text, + time => $now, + load => 0, + }; + } + elsif (-f $name) { + if (open(FH, $name)) { + my $text = <FH>; + $data = { + name => $alias, + text => $text, + time => (stat $name)[9], + load => $now, + }; + } + elsif ($tolerant) { + ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); + } + else { + $data = "$alias: $!"; + $error = Template::Constants::STATUS_ERROR; + } + } + else { + ($data, $error) = (undef, Template::Constants::STATUS_DECLINED); + } + } + + return ($data, $error); +} + + +#------------------------------------------------------------------------ +# _refresh(\@slot) +# +# Private method called to mark a cache slot as most recently used. +# A reference to the slot array should be passed by parameter. The +# slot is relocated to the head of the linked list. If the file from +# which the data was loaded has been upated since it was compiled, then +# it is re-loaded from disk and re-compiled. +#------------------------------------------------------------------------ + +sub _refresh { + my ($self, $slot) = @_; + my ($head, $file, $data, $error); + + + $self->debug("_refresh([ ", + join(', ', map { defined $_ ? $_ : '<undef>' } @$slot), + '])') if $self->{ DEBUG }; + + # if it's more than $STAT_TTL seconds since we last performed a + # stat() on the file then we need to do it again and see if the file + # time has changed + if ( (time - $slot->[ STAT ]) > $STAT_TTL && stat $slot->[ NAME ] ) { + $slot->[ STAT ] = time; + + if ( (stat(_))[9] != $slot->[ LOAD ]) { + + $self->debug("refreshing cache file ", $slot->[ NAME ]) + if $self->{ DEBUG }; + + ($data, $error) = $self->_load($slot->[ NAME ], + $slot->[ DATA ]->{ name }); + ($data, $error) = $self->_compile($data) + unless $error; + + unless ($error) { + $slot->[ DATA ] = $data->{ data }; + $slot->[ LOAD ] = $data->{ time }; + } + } + } + + unless( $self->{ HEAD } == $slot ) { + # remove existing slot from usage chain... + if ($slot->[ PREV ]) { + $slot->[ PREV ]->[ NEXT ] = $slot->[ NEXT ]; + } + else { + $self->{ HEAD } = $slot->[ NEXT ]; + } + if ($slot->[ NEXT ]) { + $slot->[ NEXT ]->[ PREV ] = $slot->[ PREV ]; + } + else { + $self->{ TAIL } = $slot->[ PREV ]; + } + + # ..and add to start of list + $head = $self->{ HEAD }; + $head->[ PREV ] = $slot if $head; + $slot->[ PREV ] = undef; + $slot->[ NEXT ] = $head; + $self->{ HEAD } = $slot; + } + + return ($data, $error); +} + + +#------------------------------------------------------------------------ +# _store($name, $data) +# +# Private method called to add a data item to the cache. If the cache +# size limit has been reached then the oldest entry at the tail of the +# list is removed and its slot relocated to the head of the list and +# reused for the new data item. If the cache is under the size limit, +# or if no size limit is defined, then the item is added to the head +# of the list. +#------------------------------------------------------------------------ + +sub _store { + my ($self, $name, $data, $compfile) = @_; + my $size = $self->{ SIZE }; + my ($slot, $head); + + # extract the load time and compiled template from the data +# my $load = $data->{ load }; + my $load = (stat($name))[9]; + $data = $data->{ data }; + + $self->debug("_store($name, $data)") if $self->{ DEBUG }; + + if (defined $size && $self->{ SLOTS } >= $size) { + # cache has reached size limit, so reuse oldest entry + + $self->debug("reusing oldest cache entry (size limit reached: $size)\nslots: $self->{ SLOTS }") if $self->{ DEBUG }; + + # remove entry from tail of list + $slot = $self->{ TAIL }; + $slot->[ PREV ]->[ NEXT ] = undef; + $self->{ TAIL } = $slot->[ PREV ]; + + # remove name lookup for old node + delete $self->{ LOOKUP }->{ $slot->[ NAME ] }; + + # add modified node to head of list + $head = $self->{ HEAD }; + $head->[ PREV ] = $slot if $head; + @$slot = ( undef, $name, $data, $load, $head, time ); + $self->{ HEAD } = $slot; + + # add name lookup for new node + $self->{ LOOKUP }->{ $name } = $slot; + } + else { + # cache is under size limit, or none is defined + + $self->debug("adding new cache entry") if $self->{ DEBUG }; + + # add new node to head of list + $head = $self->{ HEAD }; + $slot = [ undef, $name, $data, $load, $head, time ]; + $head->[ PREV ] = $slot if $head; + $self->{ HEAD } = $slot; + $self->{ TAIL } = $slot unless $self->{ TAIL }; + + # add lookup from name to slot and increment nslots + $self->{ LOOKUP }->{ $name } = $slot; + $self->{ SLOTS }++; + } + + return $data; +} + + +#------------------------------------------------------------------------ +# _compile($data) +# +# Private method called to parse the template text and compile it into +# a runtime form. Creates and delegates a Template::Parser object to +# handle the compilation, or uses a reference passed in PARSER. On +# success, the compiled template is stored in the 'data' item of the +# $data hash and returned. On error, ($error, STATUS_ERROR) is returned, +# or (undef, STATUS_DECLINED) if the TOLERANT flag is set. +# The optional $compiled parameter may be passed to specify +# the name of a compiled template file to which the generated Perl +# code should be written. Errors are (for now...) silently +# ignored, assuming that failures to open a file for writing are +# intentional (e.g directory write permission). +#------------------------------------------------------------------------ + +sub _compile { + my ($self, $data, $compfile) = @_; + my $text = $data->{ text }; + my ($parsedoc, $error); + + $self->debug("_compile($data, ", + defined $compfile ? $compfile : '<no compfile>', ')') + if $self->{ DEBUG }; + + my $parser = $self->{ PARSER } + ||= Template::Config->parser($self->{ PARAMS }) + || return (Template::Config->error(), Template::Constants::STATUS_ERROR); + + # discard the template text - we don't need it any more + delete $data->{ text }; + + # call parser to compile template into Perl code + if ($parsedoc = $parser->parse($text, $data)) { + + $parsedoc->{ METADATA } = { + 'name' => $data->{ name }, + 'modtime' => $data->{ time }, + %{ $parsedoc->{ METADATA } }, + }; + + # write the Perl code to the file $compfile, if defined + if ($compfile) { + my $basedir = &File::Basename::dirname($compfile); + $basedir =~ /(.*)/; + $basedir = $1; + &File::Path::mkpath($basedir) unless -d $basedir; + + my $docclass = $self->{ DOCUMENT }; + $error = 'cache failed to write ' + . &File::Basename::basename($compfile) + . ': ' . $docclass->error() + unless $docclass->write_perl_file($compfile, $parsedoc); + + # set atime and mtime of newly compiled file, don't bother + # if time is undef + if (!defined($error) && defined $data->{ time }) { + my ($cfile) = $compfile =~ /^(.+)$/s or do { + return("invalid filename: $compfile", + Template::Constants::STATUS_ERROR); + }; + + my ($ctime) = $data->{ time } =~ /^(\d+)$/; + unless ($ctime || $ctime eq 0) { + return("invalid time: $ctime", + Template::Constants::STATUS_ERROR); + } + utime($ctime, $ctime, $cfile); + } + } + + unless ($error) { + return $data ## RETURN ## + if $data->{ data } = Template::Document->new($parsedoc); + $error = $Template::Document::ERROR; + } + } + else { + $error = Template::Exception->new( 'parse', "$data->{ name } " . + $parser->error() ); + } + + # return STATUS_ERROR, or STATUS_DECLINED if we're being tolerant + return $self->{ TOLERANT } + ? (undef, Template::Constants::STATUS_DECLINED) + : ($error, Template::Constants::STATUS_ERROR) +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal object +# state. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $size = $self->{ SIZE }; + my $parser = $self->{ PARSER }; + $parser = $parser ? $parser->_dump() : '<no parser>'; + $parser =~ s/\n/\n /gm; + $size = 'unlimited' unless defined $size; + + my $output = "[Template::Provider] {\n"; + my $format = " %-16s => %s\n"; + my $key; + + $output .= sprintf($format, 'INCLUDE_PATH', + '[ ' . join(', ', @{ $self->{ INCLUDE_PATH } }) . ' ]'); + $output .= sprintf($format, 'CACHE_SIZE', $size); + + foreach $key (qw( ABSOLUTE RELATIVE TOLERANT DELIMITER + COMPILE_EXT COMPILE_DIR )) { + $output .= sprintf($format, $key, $self->{ $key }); + } + $output .= sprintf($format, 'PARSER', $parser); + + + local $" = ', '; + my $lookup = $self->{ LOOKUP }; + $lookup = join('', map { + sprintf(" $format", $_, defined $lookup->{ $_ } + ? ('[ ' . join(', ', map { defined $_ ? $_ : '<undef>' } + @{ $lookup->{ $_ } }) . ' ]') : '<undef>'); + } sort keys %$lookup); + $lookup = "{\n$lookup }"; + + $output .= sprintf($format, LOOKUP => $lookup); + + $output .= '}'; + return $output; +} + + +#------------------------------------------------------------------------ +# _dump_cache() +# +# Debug method which prints the current state of the cache to STDERR. +#------------------------------------------------------------------------ + +sub _dump_cache { + my $self = shift; + my ($node, $lut, $count); + + $count = 0; + if ($node = $self->{ HEAD }) { + while ($node) { + $lut->{ $node } = $count++; + $node = $node->[ NEXT ]; + } + $node = $self->{ HEAD }; + print STDERR "CACHE STATE:\n"; + print STDERR " HEAD: ", $self->{ HEAD }->[ NAME ], "\n"; + print STDERR " TAIL: ", $self->{ TAIL }->[ NAME ], "\n"; + while ($node) { + my ($prev, $name, $data, $load, $next) = @$node; +# $name = '...' . substr($name, -10) if length $name > 10; + $prev = $prev ? "#$lut->{ $prev }<-": '<undef>'; + $next = $next ? "->#$lut->{ $next }": '<undef>'; + print STDERR " #$lut->{ $node } : [ $prev, $name, $data, $load, $next ]\n"; + $node = $node->[ NEXT ]; + } + } +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Provider - Provider module for loading/compiling templates + +=head1 SYNOPSIS + + $provider = Template::Provider->new(\%options); + + ($template, $error) = $provider->fetch($name); + +=head1 DESCRIPTION + +The Template::Provider is used to load, parse, compile and cache template +documents. This object may be sub-classed to provide more specific +facilities for loading, or otherwise providing access to templates. + +The Template::Context objects maintain a list of Template::Provider +objects which are polled in turn (via fetch()) to return a requested +template. Each may return a compiled template, raise an error, or +decline to serve the reqest, giving subsequent providers a chance to +do so. + +This is the "Chain of Responsiblity" pattern. See 'Design Patterns' for +further information. + +This documentation needs work. + +=head1 PUBLIC METHODS + +=head2 new(\%options) + +Constructor method which instantiates and returns a new Template::Provider +object. The optional parameter may be a hash reference containing any of +the following items: + +=over 4 + + + + +=item INCLUDE_PATH + +The INCLUDE_PATH is used to specify one or more directories in which +template files are located. When a template is requested that isn't +defined locally as a BLOCK, each of the INCLUDE_PATH directories is +searched in turn to locate the template file. Multiple directories +can be specified as a reference to a list or as a single string where +each directory is delimited by ':'. + + my $provider = Template::Provider->new({ + INCLUDE_PATH => '/usr/local/templates', + }); + + my $provider = Template::Provider->new({ + INCLUDE_PATH => '/usr/local/templates:/tmp/my/templates', + }); + + my $provider = Template::Provider->new({ + INCLUDE_PATH => [ '/usr/local/templates', + '/tmp/my/templates' ], + }); + +On Win32 systems, a little extra magic is invoked, ignoring delimiters +that have ':' followed by a '/' or '\'. This avoids confusion when using +directory names like 'C:\Blah Blah'. + +When specified as a list, the INCLUDE_PATH path can contain elements +which dynamically generate a list of INCLUDE_PATH directories. These +generator elements can be specified as a reference to a subroutine or +an object which implements a paths() method. + + my $provider = Template::Provider->new({ + INCLUDE_PATH => [ '/usr/local/templates', + \&incpath_generator, + My::IncPath::Generator->new( ... ) ], + }); + +Each time a template is requested and the INCLUDE_PATH examined, the +subroutine or object method will be called. A reference to a list of +directories should be returned. Generator subroutines should report +errors using die(). Generator objects should return undef and make an +error available via its error() method. + +For example: + + sub incpath_generator { + + # ...some code... + + if ($all_is_well) { + return \@list_of_directories; + } + else { + die "cannot generate INCLUDE_PATH...\n"; + } + } + +or: + + package My::IncPath::Generator; + + # Template::Base (or Class::Base) provides error() method + use Template::Base; + use base qw( Template::Base ); + + sub paths { + my $self = shift; + + # ...some code... + + if ($all_is_well) { + return \@list_of_directories; + } + else { + return $self->error("cannot generate INCLUDE_PATH...\n"); + } + } + + 1; + + + + + +=item DELIMITER + +Used to provide an alternative delimiter character sequence for +separating paths specified in the INCLUDE_PATH. The default +value for DELIMITER is ':'. + + # tolerate Silly Billy's file system conventions + my $provider = Template::Provider->new({ + DELIMITER => '; ', + INCLUDE_PATH => 'C:/HERE/NOW; D:/THERE/THEN', + }); + + # better solution: install Linux! :-) + +On Win32 systems, the default delimiter is a little more intelligent, +splitting paths only on ':' characters that aren't followed by a '/'. +This means that the following should work as planned, splitting the +INCLUDE_PATH into 2 separate directories, C:/foo and C:/bar. + + # on Win32 only + my $provider = Template::Provider->new({ + INCLUDE_PATH => 'C:/Foo:C:/Bar' + }); + +However, if you're using Win32 then it's recommended that you +explicitly set the DELIMITER character to something else (e.g. ';') +rather than rely on this subtle magic. + + + + +=item ABSOLUTE + +The ABSOLUTE flag is used to indicate if templates specified with +absolute filenames (e.g. '/foo/bar') should be processed. It is +disabled by default and any attempt to load a template by such a +name will cause a 'file' exception to be raised. + + my $provider = Template::Provider->new({ + ABSOLUTE => 1, + }); + + # this is why it's disabled by default + [% INSERT /etc/passwd %] + +On Win32 systems, the regular expression for matching absolute +pathnames is tweaked slightly to also detect filenames that start +with a driver letter and colon, such as: + + C:/Foo/Bar + + + + + + +=item RELATIVE + +The RELATIVE flag is used to indicate if templates specified with +filenames relative to the current directory (e.g. './foo/bar' or +'../../some/where/else') should be loaded. It is also disabled by +default, and will raise a 'file' error if such template names are +encountered. + + my $provider = Template::Provider->new({ + RELATIVE => 1, + }); + + [% INCLUDE ../logs/error.log %] + + + + + +=item DEFAULT + +The DEFAULT option can be used to specify a default template which should +be used whenever a specified template can't be found in the INCLUDE_PATH. + + my $provider = Template::Provider->new({ + DEFAULT => 'notfound.html', + }); + +If a non-existant template is requested through the Template process() +method, or by an INCLUDE, PROCESS or WRAPPER directive, then the +DEFAULT template will instead be processed, if defined. Note that the +DEFAULT template is not used when templates are specified with +absolute or relative filenames, or as a reference to a input file +handle or text string. + + + + + +=item CACHE_SIZE + +The Template::Provider module caches compiled templates to avoid the need +to re-parse template files or blocks each time they are used. The CACHE_SIZE +option is used to limit the number of compiled templates that the module +should cache. + +By default, the CACHE_SIZE is undefined and all compiled templates are +cached. When set to any positive value, the cache will be limited to +storing no more than that number of compiled templates. When a new +template is loaded and compiled and the cache is full (i.e. the number +of entries == CACHE_SIZE), the least recently used compiled template +is discarded to make room for the new one. + +The CACHE_SIZE can be set to 0 to disable caching altogether. + + my $provider = Template::Provider->new({ + CACHE_SIZE => 64, # only cache 64 compiled templates + }); + + my $provider = Template::Provider->new({ + CACHE_SIZE => 0, # don't cache any compiled templates + }); + + + + + + +=item COMPILE_EXT + +From version 2 onwards, the Template Toolkit has the ability to +compile templates to Perl code and save them to disk for subsequent +use (i.e. cache persistence). The COMPILE_EXT option may be +provided to specify a filename extension for compiled template files. +It is undefined by default and no attempt will be made to read or write +any compiled template files. + + my $provider = Template::Provider->new({ + COMPILE_EXT => '.ttc', + }); + +If COMPILE_EXT is defined (and COMPILE_DIR isn't, see below) then compiled +template files with the COMPILE_EXT extension will be written to the same +directory from which the source template files were loaded. + +Compiling and subsequent reuse of templates happens automatically +whenever the COMPILE_EXT or COMPILE_DIR options are set. The Template +Toolkit will automatically reload and reuse compiled files when it +finds them on disk. If the corresponding source file has been modified +since the compiled version as written, then it will load and re-compile +the source and write a new compiled version to disk. + +This form of cache persistence offers significant benefits in terms of +time and resources required to reload templates. Compiled templates can +be reloaded by a simple call to Perl's require(), leaving Perl to handle +all the parsing and compilation. This is a Good Thing. + +=item COMPILE_DIR + +The COMPILE_DIR option is used to specify an alternate directory root +under which compiled template files should be saved. + + my $provider = Template::Provider->new({ + COMPILE_DIR => '/tmp/ttc', + }); + +The COMPILE_EXT option may also be specified to have a consistent file +extension added to these files. + + my $provider1 = Template::Provider->new({ + COMPILE_DIR => '/tmp/ttc', + COMPILE_EXT => '.ttc1', + }); + + my $provider2 = Template::Provider->new({ + COMPILE_DIR => '/tmp/ttc', + COMPILE_EXT => '.ttc2', + }); + + +When COMPILE_EXT is undefined, the compiled template files have the +same name as the original template files, but reside in a different +directory tree. + +Each directory in the INCLUDE_PATH is replicated in full beneath the +COMPILE_DIR directory. This example: + + my $provider = Template::Provider->new({ + COMPILE_DIR => '/tmp/ttc', + INCLUDE_PATH => '/home/abw/templates:/usr/share/templates', + }); + +would create the following directory structure: + + /tmp/ttc/home/abw/templates/ + /tmp/ttc/usr/share/templates/ + +Files loaded from different INCLUDE_PATH directories will have their +compiled forms save in the relevant COMPILE_DIR directory. + +On Win32 platforms a filename may by prefixed by a drive letter and +colon. e.g. + + C:/My Templates/header + +The colon will be silently stripped from the filename when it is added +to the COMPILE_DIR value(s) to prevent illegal filename being generated. +Any colon in COMPILE_DIR elements will be left intact. For example: + + # Win32 only + my $provider = Template::Provider->new({ + DELIMITER => ';', + COMPILE_DIR => 'C:/TT2/Cache', + INCLUDE_PATH => 'C:/TT2/Templates;D:/My Templates', + }); + +This would create the following cache directories: + + C:/TT2/Cache/C/TT2/Templates + C:/TT2/Cache/D/My Templates + + + + +=item TOLERANT + +The TOLERANT flag is used by the various Template Toolkit provider +modules (Template::Provider, Template::Plugins, Template::Filters) to +control their behaviour when errors are encountered. By default, any +errors are reported as such, with the request for the particular +resource (template, plugin, filter) being denied and an exception +raised. When the TOLERANT flag is set to any true values, errors will +be silently ignored and the provider will instead return +STATUS_DECLINED. This allows a subsequent provider to take +responsibility for providing the resource, rather than failing the +request outright. If all providers decline to service the request, +either through tolerated failure or a genuine disinclination to +comply, then a 'E<lt>resourceE<gt> not found' exception is raised. + + + + + + +=item PARSER + +The Template::Parser module implements a parser object for compiling +templates into Perl code which can then be executed. A default object +of this class is created automatically and then used by the +Template::Provider whenever a template is loaded and requires +compilation. The PARSER option can be used to provide a reference to +an alternate parser object. + + my $provider = Template::Provider->new({ + PARSER => MyOrg::Template::Parser->new({ ... }), + }); + + + +=item DEBUG + +The DEBUG option can be used to enable debugging messages from the +Template::Provider module by setting it to include the DEBUG_PROVIDER +value. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_PROVIDER, + }); + + + +=back + +=head2 fetch($name) + +Returns a compiled template for the name specified. If the template +cannot be found then (undef, STATUS_DECLINED) is returned. If an error +occurs (e.g. read error, parse error) then ($error, STATUS_ERROR) is +returned, where $error is the error message generated. If the TOLERANT +flag is set the the method returns (undef, STATUS_DECLINED) instead of +returning an error. + +=head2 store($name, $template) + +Stores the compiled template, $template, in the cache under the name, +$name. Susbequent calls to fetch($name) will return this template in +preference to any disk-based file. + +=head2 include_path(\@newpath)) + +Accessor method for the INCLUDE_PATH setting. If called with an +argument, this method will replace the existing INCLUDE_PATH with +the new value. + +=head2 paths() + +This method generates a copy of the INCLUDE_PATH list. Any elements in the +list which are dynamic generators (e.g. references to subroutines or objects +implementing a paths() method) will be called and the list of directories +returned merged into the output list. + +It is possible to provide a generator which returns itself, thus sending +this method into an infinite loop. To detect and prevent this from happening, +the C<$MAX_DIRS> package variable, set to 64 by default, limits the maximum +number of paths that can be added to, or generated for the output list. If +this number is exceeded then the method will immediately return an error +reporting as much. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.70, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Parser|Template::Parser>, L<Template::Context|Template::Context> diff --git a/lib/Template/Service.pm b/lib/Template/Service.pm new file mode 100644 index 0000000..e2ac533 --- /dev/null +++ b/lib/Template/Service.pm @@ -0,0 +1,765 @@ +#============================================================= -*-Perl-*- +# +# Template::Service +# +# DESCRIPTION +# Module implementing a template processing service which wraps a +# template within PRE_PROCESS and POST_PROCESS templates and offers +# ERROR recovery. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Service.pm,v 2.70 2003/04/29 12:39:37 abw Exp $ +# +#============================================================================ + +package Template::Service; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $ERROR ); +use base qw( Template::Base ); +use Template::Base; +use Template::Config; +use Template::Exception; +use Template::Constants; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.70 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; + + +#======================================================================== +# ----- PUBLIC METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# process($template, \%params) +# +# Process a template within a service framework. A service may encompass +# PRE_PROCESS and POST_PROCESS templates and an ERROR hash which names +# templates to be substituted for the main template document in case of +# error. Each service invocation begins by resetting the state of the +# context object via a call to reset(). The AUTO_RESET option may be set +# to 0 (default: 1) to bypass this step. +#------------------------------------------------------------------------ + +sub process { + my ($self, $template, $params) = @_; + my $context = $self->{ CONTEXT }; + my ($name, $output, $procout, $error); + $output = ''; + + $self->debug("process($template, ", + defined $params ? $params : '<no params>', + ')') if $self->{ DEBUG }; + + $context->reset() + if $self->{ AUTO_RESET }; + + # pre-request compiled template from context so that we can alias it + # in the stash for pre-processed templates to reference + eval { $template = $context->template($template) }; + return $self->error($@) + if $@; + + # localise the variable stash with any parameters passed + # and set the 'template' variable + $params ||= { }; + $params->{ template } = $template + unless ref $template eq 'CODE'; + $context->localise($params); + + SERVICE: { + # PRE_PROCESS + eval { + foreach $name (@{ $self->{ PRE_PROCESS } }) { + $self->debug("PRE_PROCESS: $name") if $self->{ DEBUG }; + $output .= $context->process($name); + } + }; + last SERVICE if ($error = $@); + + # PROCESS + eval { + foreach $name (@{ $self->{ PROCESS } || [ $template ] }) { + $self->debug("PROCESS: $name") if $self->{ DEBUG }; + $procout .= $context->process($name); + } + }; + if ($error = $@) { + last SERVICE + unless defined ($procout = $self->_recover(\$error)); + } + + if (defined $procout) { + # WRAPPER + eval { + foreach $name (reverse @{ $self->{ WRAPPER } }) { + $self->debug("WRAPPER: $name") if $self->{ DEBUG }; + $procout = $context->process($name, { content => $procout }); + } + }; + last SERVICE if ($error = $@); + $output .= $procout; + } + + # POST_PROCESS + eval { + foreach $name (@{ $self->{ POST_PROCESS } }) { + $self->debug("POST_PROCESS: $name") if $self->{ DEBUG }; + $output .= $context->process($name); + } + }; + last SERVICE if ($error = $@); + } + + $context->delocalise(); + delete $params->{ template }; + + if ($error) { +# $error = $error->as_string if ref $error; + return $self->error($error); + } + + return $output; +} + + +#------------------------------------------------------------------------ +# context() +# +# Returns the internal CONTEXT reference. +#------------------------------------------------------------------------ + +sub context { + return $_[0]->{ CONTEXT }; +} + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +sub _init { + my ($self, $config) = @_; + my ($item, $data, $context, $block, $blocks); + my $delim = $config->{ DELIMITER }; + $delim = ':' unless defined $delim; + + # coerce PRE_PROCESS, PROCESS and POST_PROCESS to arrays if necessary, + # by splitting on non-word characters + foreach $item (qw( PRE_PROCESS PROCESS POST_PROCESS WRAPPER )) { + $data = $config->{ $item }; + $self->{ $item } = [ ], next unless (defined $data); + $data = [ split($delim, $data || '') ] + unless ref $data eq 'ARRAY'; + $self->{ $item } = $data; + } + # unset PROCESS option unless explicitly specified in config + $self->{ PROCESS } = undef + unless defined $config->{ PROCESS }; + + $self->{ ERROR } = $config->{ ERROR } || $config->{ ERRORS }; + $self->{ AUTO_RESET } = defined $config->{ AUTO_RESET } + ? $config->{ AUTO_RESET } : 1; + $self->{ DEBUG } = ( $config->{ DEBUG } || 0 ) + & Template::Constants::DEBUG_SERVICE; + + $context = $self->{ CONTEXT } = $config->{ CONTEXT } + || Template::Config->context($config) + || return $self->error(Template::Config->error); + + return $self; +} + + +#------------------------------------------------------------------------ +# _recover(\$exception) +# +# Examines the internal ERROR hash array to find a handler suitable +# for the exception object passed by reference. Selecting the handler +# is done by delegation to the exception's select_handler() method, +# passing the set of handler keys as arguments. A 'default' handler +# may also be provided. The handler value represents the name of a +# template which should be processed. +#------------------------------------------------------------------------ + +sub _recover { + my ($self, $error) = @_; + my $context = $self->{ CONTEXT }; + my ($hkey, $handler, $output); + + # there shouldn't ever be a non-exception object received at this + # point... unless a module like CGI::Carp messes around with the + # DIE handler. + return undef + unless (ref $$error); + + # a 'stop' exception is thrown by [% STOP %] - we return the output + # buffer stored in the exception object + return $$error->text() + if $$error->type() eq 'stop'; + + my $handlers = $self->{ ERROR } + || return undef; ## RETURN + + if (ref $handlers eq 'HASH') { + if ($hkey = $$error->select_handler(keys %$handlers)) { + $handler = $handlers->{ $hkey }; + $self->debug("using error handler for $hkey") if $self->{ DEBUG }; + } + elsif ($handler = $handlers->{ default }) { + # use default handler + $self->debug("using default error handler") if $self->{ DEBUG }; + } + else { + return undef; ## RETURN + } + } + else { + $handler = $handlers; + $self->debug("using default error handler") if $self->{ DEBUG }; + } + + eval { $handler = $context->template($handler) }; + if ($@) { + $$error = $@; + return undef; ## RETURN + }; + + $context->stash->set('error', $$error); + eval { + $output .= $context->process($handler); + }; + if ($@) { + $$error = $@; + return undef; ## RETURN + } + + return $output; +} + + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which return a string representing the internal object +# state. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $context = $self->{ CONTEXT }->_dump(); + $context =~ s/\n/\n /gm; + + my $error = $self->{ ERROR }; + $error = join('', + "{\n", + (map { " $_ => $error->{ $_ }\n" } + keys %$error), + "}\n") + if ref $error; + + local $" = ', '; + return <<EOF; +$self +PRE_PROCESS => [ @{ $self->{ PRE_PROCESS } } ] +POST_PROCESS => [ @{ $self->{ POST_PROCESS } } ] +ERROR => $error +CONTEXT => $context +EOF +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Service - General purpose template processing service + +=head1 SYNOPSIS + + use Template::Service; + + my $service = Template::Service->new({ + PRE_PROCESS => [ 'config', 'header' ], + POST_PROCESS => 'footer', + ERROR => { + user => 'user/index.html', + dbi => 'error/database', + default => 'error/default', + }, + }); + + my $output = $service->process($template_name, \%replace) + || die $service->error(), "\n"; + +=head1 DESCRIPTION + +The Template::Service module implements an object class for providing +a consistent template processing service. + +Standard header (PRE_PROCESS) and footer (POST_PROCESS) templates may +be specified which are prepended and appended to all templates +processed by the service (but not any other templates or blocks +INCLUDEd or PROCESSed from within). An ERROR hash may be specified +which redirects the service to an alternate template file in the case +of uncaught exceptions being thrown. This allows errors to be +automatically handled by the service and a guaranteed valid response +to be generated regardless of any processing problems encountered. + +A default Template::Service object is created by the Template module. +Any Template::Service options may be passed to the Template new() +constructor method and will be forwarded to the Template::Service +constructor. + + use Template; + + my $template = Template->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + }); + +Similarly, the Template::Service constructor will forward all configuration +parameters onto other default objects (e.g. Template::Context) that it may +need to instantiate. + +A Template::Service object (or subclass/derivative) can be explicitly +instantiated and passed to the Template new() constructor method as +the SERVICE item. + + use Template; + use Template::Service; + + my $service = Template::Service->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + }); + + my $template = Template->new({ + SERVICE => $service, + }); + +The Template::Service module can be sub-classed to create custom service +handlers. + + use Template; + use MyOrg::Template::Service; + + my $service = MyOrg::Template::Service->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + COOL_OPTION => 'enabled in spades', + }); + + my $template = Template->new({ + SERVICE => $service, + }); + +The Template module uses the Template::Config service() factory method +to create a default service object when required. The +$Template::Config::SERVICE package variable may be set to specify an +alternate service module. This will be loaded automatically and its +new() constructor method called by the service() factory method when +a default service object is required. Thus the previous example could +be written as: + + use Template; + + $Template::Config::SERVICE = 'MyOrg::Template::Service'; + + my $template = Template->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + COOL_OPTION => 'enabled in spades', + }); + +=head1 METHODS + +=head2 new(\%config) + +The new() constructor method is called to instantiate a Template::Service +object. Configuration parameters may be specified as a HASH reference or +as a list of (name =E<gt> value) pairs. + + my $service1 = Template::Service->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + }); + + my $service2 = Template::Service->new( ERROR => 'error.html' ); + +The new() method returns a Template::Service object (or sub-class) or +undef on error. In the latter case, a relevant error message can be +retrieved by the error() class method or directly from the +$Template::Service::ERROR package variable. + + my $service = Template::Service->new(\%config) + || die Template::Service->error(); + + my $service = Template::Service->new(\%config) + || die $Template::Service::ERROR; + +The following configuration items may be specified: + +=over 4 + + + + +=item PRE_PROCESS, POST_PROCESS + +These values may be set to contain the name(s) of template files +(relative to INCLUDE_PATH) which should be processed immediately +before and/or after each template. These do not get added to +templates processed into a document via directives such as INCLUDE, +PROCESS, WRAPPER etc. + + my $service = Template::Service->new({ + PRE_PROCESS => 'header', + POST_PROCESS => 'footer', + }; + +Multiple templates may be specified as a reference to a list. Each is +processed in the order defined. + + my $service = Template::Service->new({ + PRE_PROCESS => [ 'config', 'header' ], + POST_PROCESS => 'footer', + }; + +Alternately, multiple template may be specified as a single string, +delimited by ':'. This delimiter string can be changed via the +DELIMITER option. + + my $service = Template::Service->new({ + PRE_PROCESS => 'config:header', + POST_PROCESS => 'footer', + }; + +The PRE_PROCESS and POST_PROCESS templates are evaluated in the same +variable context as the main document and may define or update +variables for subsequent use. + +config: + + [% # set some site-wide variables + bgcolor = '#ffffff' + version = 2.718 + %] + +header: + + [% DEFAULT title = 'My Funky Web Site' %] + <html> + <head> + <title>[% title %]</title> + </head> + <body bgcolor="[% bgcolor %]"> + +footer: + + <hr> + Version [% version %] + </body> + </html> + +The Template::Document object representing the main template being processed +is available within PRE_PROCESS and POST_PROCESS templates as the 'template' +variable. Metadata items defined via the META directive may be accessed +accordingly. + + $service->process('mydoc.html', $vars); + +mydoc.html: + + [% META title = 'My Document Title' %] + blah blah blah + ... + +header: + + <html> + <head> + <title>[% template.title %]</title></head> + <body bgcolor="[% bgcolor %]"> + + + + + + + + + + + + + + +=item PROCESS + +The PROCESS option may be set to contain the name(s) of template files +(relative to INCLUDE_PATH) which should be processed instead of the +main template passed to the Template::Service process() method. This can +be used to apply consistent wrappers around all templates, similar to +the use of PRE_PROCESS and POST_PROCESS templates. + + my $service = Template::Service->new({ + PROCESS => 'content', + }; + + # processes 'content' instead of 'foo.html' + $service->process('foo.html'); + +A reference to the original template is available in the 'template' +variable. Metadata items can be inspected and the template can be +processed by specifying it as a variable reference (i.e. prefixed by +'$') to an INCLUDE, PROCESS or WRAPPER directive. + +content: + + <html> + <head> + <title>[% template.title %]</title> + </head> + + <body> + [% PROCESS $template %] + <hr> + © Copyright [% template.copyright %] + </body> + </html> + +foo.html: + + [% META + title = 'The Foo Page' + author = 'Fred Foo' + copyright = '2000 Fred Foo' + %] + <h1>[% template.title %]</h1> + Welcome to the Foo Page, blah blah blah + +output: + + <html> + <head> + <title>The Foo Page</title> + </head> + + <body> + <h1>The Foo Page</h1> + Welcome to the Foo Page, blah blah blah + <hr> + © Copyright 2000 Fred Foo + </body> + </html> + + + + + + + +=item ERROR + +The ERROR (or ERRORS if you prefer) configuration item can be used to +name a single template or specify a hash array mapping exception types +to templates which should be used for error handling. If an uncaught +exception is raised from within a template then the appropriate error +template will instead be processed. + +If specified as a single value then that template will be processed +for all uncaught exceptions. + + my $service = Template::Service->new({ + ERROR => 'error.html' + }); + +If the ERROR item is a hash reference the keys are assumed to be +exception types and the relevant template for a given exception will +be selected. A 'default' template may be provided for the general +case. Note that 'ERROR' can be pluralised to 'ERRORS' if you find +it more appropriate in this case. + + my $service = Template::Service->new({ + ERRORS => { + user => 'user/index.html', + dbi => 'error/database', + default => 'error/default', + }, + }); + +In this example, any 'user' exceptions thrown will cause the +'user/index.html' template to be processed, 'dbi' errors are handled +by 'error/database' and all others by the 'error/default' template. +Any PRE_PROCESS and/or POST_PROCESS templates will also be applied +to these error templates. + +Note that exception types are hierarchical and a 'foo' handler will +catch all 'foo.*' errors (e.g. foo.bar, foo.bar.baz) if a more +specific handler isn't defined. Be sure to quote any exception types +that contain periods to prevent Perl concatenating them into a single +string (i.e. C<user.passwd> is parsed as 'user'.'passwd'). + + my $service = Template::Service->new({ + ERROR => { + 'user.login' => 'user/login.html', + 'user.passwd' => 'user/badpasswd.html', + 'user' => 'user/index.html', + 'default' => 'error/default', + }, + }); + +In this example, any template processed by the $service object, or +other templates or code called from within, can raise a 'user.login' +exception and have the service redirect to the 'user/login.html' +template. Similarly, a 'user.passwd' exception has a specific +handling template, 'user/badpasswd.html', while all other 'user' or +'user.*' exceptions cause a redirection to the 'user/index.html' page. +All other exception types are handled by 'error/default'. + + +Exceptions can be raised in a template using the THROW directive, + + [% THROW user.login 'no user id: please login' %] + +or by calling the throw() method on the current Template::Context object, + + $context->throw('user.passwd', 'Incorrect Password'); + $context->throw('Incorrect Password'); # type 'undef' + +or from Perl code by calling die() with a Template::Exception object, + + die (Template::Exception->new('user.denied', 'Invalid User ID')); + +or by simply calling die() with an error string. This is +automagically caught and converted to an exception of 'undef' +type which can then be handled in the usual way. + + die "I'm sorry Dave, I can't do that"; + + + + + + + +=item AUTO_RESET + +The AUTO_RESET option is set by default and causes the local BLOCKS +cache for the Template::Context object to be reset on each call to the +Template process() method. This ensures that any BLOCKs defined +within a template will only persist until that template is finished +processing. This prevents BLOCKs defined in one processing request +from interfering with other independent requests subsequently +processed by the same context object. + +The BLOCKS item may be used to specify a default set of block definitions +for the Template::Context object. Subsequent BLOCK definitions in templates +will over-ride these but they will be reinstated on each reset if AUTO_RESET +is enabled (default), or if the Template::Context reset() method is called. + + + + + + + +=item DEBUG + +The DEBUG option can be used to enable debugging messages from the +Template::Service module by setting it to include the DEBUG_SERVICE +value. + + use Template::Constants qw( :debug ); + + my $template = Template->new({ + DEBUG => DEBUG_SERVICE, + }); + + + + +=back + +=head2 process($input, \%replace) + +The process() method is called to process a template specified as the first +parameter, $input. This may be a file name, file handle (e.g. GLOB or IO::Handle) +or a reference to a text string containing the template text. An additional +hash reference may be passed containing template variable definitions. + +The method processes the template, adding any PRE_PROCESS or POST_PROCESS +templates defined, and returns the output text. An uncaught exception thrown +by the template will be handled by a relevant ERROR handler if defined. +Errors that occur in the PRE_PROCESS or POST_PROCESS templates, or those that +occur in the main input template and aren't handled, cause the method to +return undef to indicate failure. The appropriate error message can be +retrieved via the error() method. + + $service->process('myfile.html', { title => 'My Test File' }) + || die $service->error(); + + +=head2 context() + +Returns a reference to the internal context object which is, by default, an +instance of the Template::Context class. + +=head2 error() + +Returns the most recent error message. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.70, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Context|Template::Context> diff --git a/lib/Template/Stash.pm b/lib/Template/Stash.pm new file mode 100644 index 0000000..4f26bca --- /dev/null +++ b/lib/Template/Stash.pm @@ -0,0 +1,1000 @@ +#============================================================= -*-Perl-*- +# +# Template::Stash +# +# DESCRIPTION +# Definition of an object class which stores and manages access to +# variables for the Template Toolkit. +# +# AUTHOR +# Andy Wardley <abw@wardley.org> +# +# COPYRIGHT +# Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Stash.pm,v 2.78 2003/07/24 12:13:32 abw Exp $ +# +#============================================================================ + +package Template::Stash; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.78 $ =~ /(\d+)\.(\d+)/); + + +#======================================================================== +# -- PACKAGE VARIABLES AND SUBS -- +#======================================================================== + +#------------------------------------------------------------------------ +# Definitions of various pseudo-methods. ROOT_OPS are merged into all +# new Template::Stash objects, and are thus default global functions. +# SCALAR_OPS are methods that can be called on a scalar, and ditto +# respectively for LIST_OPS and HASH_OPS +#------------------------------------------------------------------------ + +$ROOT_OPS = { + 'inc' => sub { local $^W = 0; my $item = shift; ++$item }, + 'dec' => sub { local $^W = 0; my $item = shift; --$item }, +# import => \&hash_import, + defined $ROOT_OPS ? %$ROOT_OPS : (), +}; + +$SCALAR_OPS = { + 'item' => sub { $_[0] }, + 'list' => sub { [ $_[0] ] }, + 'hash' => sub { { value => $_[0] } }, + 'length' => sub { length $_[0] }, + 'size' => sub { return 1 }, + 'defined' => sub { return 1 }, + 'repeat' => sub { + my ($str, $count) = @_; + $str = '' unless defined $str; + $count ||= 1; + return $str x $count; + }, + 'search' => sub { + my ($str, $pattern) = @_; + return $str unless defined $str and defined $pattern; + return $str =~ /$pattern/; + }, + 'replace' => sub { + my ($str, $search, $replace) = @_; + $replace = '' unless defined $replace; + return $str unless defined $str and defined $search; + $str =~ s/$search/$replace/g; +# print STDERR "s [ $search ] [ $replace ] g\n"; +# eval "\$str =~ s$search$replaceg"; + return $str; + }, + 'match' => sub { + my ($str, $search) = @_; + return $str unless defined $str and defined $search; + my @matches = ($str =~ /$search/); + return @matches ? \@matches : ''; + }, + 'split' => sub { + my ($str, $split, @args) = @_; + $str = '' unless defined $str; + return [ defined $split ? split($split, $str, @args) + : split(' ', $str, @args) ]; + }, + 'chunk' => sub { + my ($string, $size) = @_; + my @list; + $size ||= 1; + if ($size < 0) { + # sexeger! It's faster to reverse the string, search + # it from the front and then reverse the output than to + # search it from the end, believe it nor not! + $string = reverse $string; + $size = -$size; + unshift(@list, scalar reverse $1) + while ($string =~ /((.{$size})|(.+))/g); + } + else { + push(@list, $1) while ($string =~ /((.{$size})|(.+))/g); + } + return \@list; + }, + + + defined $SCALAR_OPS ? %$SCALAR_OPS : (), +}; + +$HASH_OPS = { + 'item' => sub { my ($hash, $item) = @_; + $item = '' unless defined $item; + $hash->{ $item }; + }, + 'hash' => sub { $_[0] }, + 'size' => sub { scalar keys %{$_[0]} }, + 'keys' => sub { [ keys %{ $_[0] } ] }, + 'values' => sub { [ values %{ $_[0] } ] }, + 'each' => sub { [ %{ $_[0] } ] }, + 'list' => sub { my ($hash, $what) = @_; $what ||= ''; + return ($what eq 'keys') ? [ keys %$hash ] + : ($what eq 'values') ? [ values %$hash ] + : ($what eq 'each') ? [ %$hash ] + : [ map { { key => $_ , value => $hash->{ $_ } } } + keys %$hash ]; + }, + 'exists' => sub { exists $_[0]->{ $_[1] } }, + 'defined' => sub { defined $_[0]->{ $_[1] } }, + 'import' => \&hash_import, + 'sort' => sub { + my ($hash) = @_; + [ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ]; + }, + 'nsort' => sub { + my ($hash) = @_; + [ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ]; + }, + defined $HASH_OPS ? %$HASH_OPS : (), +}; + +$LIST_OPS = { + 'item' => sub { $_[0]->[ $_[1] || 0 ] }, + 'list' => sub { $_[0] }, + 'hash' => sub { my $list = shift; my $n = 0; + return { map { ($n++, $_) } @$list }; }, + 'push' => sub { my $list = shift; push(@$list, shift); return '' }, + 'pop' => sub { my $list = shift; pop(@$list) }, + 'unshift' => sub { my $list = shift; unshift(@$list, shift); return '' }, + 'shift' => sub { my $list = shift; shift(@$list) }, + 'max' => sub { local $^W = 0; my $list = shift; $#$list; }, + 'size' => sub { local $^W = 0; my $list = shift; $#$list + 1; }, + 'first' => sub { + my $list = shift; + return $list->[0] unless @_; + return [ @$list[0..$_[0]-1] ]; + }, + 'last' => sub { + my $list = shift; + return $list->[-1] unless @_; + return [ @$list[-$_[0]..-1] ]; + }, + 'reverse' => sub { my $list = shift; [ reverse @$list ] }, + 'grep' => sub { + my ($list, $pattern) = @_; + $pattern ||= ''; + return [ grep /$pattern/, @$list ]; + }, + 'join' => sub { + my ($list, $joint) = @_; + join(defined $joint ? $joint : ' ', + map { defined $_ ? $_ : '' } @$list) + }, + 'sort' => sub { + $^W = 0; + my ($list, $field) = @_; + return $list unless @$list > 1; # no need to sort 1 item lists + return $field # Schwartzian Transform + ? map { $_->[0] } # for case insensitivity + sort { $a->[1] cmp $b->[1] } + map { [ $_, lc(ref($_) eq 'HASH' + ? $_->{ $field } : + UNIVERSAL::can($_, $field) + ? $_->$field() : $_) ] } + @$list + : map { $_->[0] } + sort { $a->[1] cmp $b->[1] } + map { [ $_, lc $_ ] } + @$list + }, + 'nsort' => sub { + my ($list, $field) = @_; + return $list unless $#$list; # no need to sort 1 item lists + return $field # Schwartzian Transform + ? map { $_->[0] } # for case insensitivity + sort { $a->[1] <=> $b->[1] } + map { [ $_, lc(ref($_) eq 'HASH' + ? $_->{ $field } : + UNIVERSAL::can($_, $field) + ? $_->$field() : $_) ] } + @$list + : map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [ $_, lc $_ ] } + @$list + }, + 'unique' => sub { my %u; [ grep { ++$u{$_} == 1 } @{$_[0]} ] }, + 'merge' => sub { + my $list = shift; + return [ @$list, grep defined, map ref eq 'ARRAY' ? @$_ : undef, @_ ]; + }, + 'slice' => sub { + my ($list, $from, $to) = @_; + $from ||= 0; + $to = $#$list unless defined $to; + return [ @$list[$from..$to] ]; + }, + 'splice' => sub { + my ($list, $offset, $length, @replace) = @_; + + if (@replace) { + # @replace can contain a list of multiple replace items, or + # be a single reference to a list + @replace = @{ $replace[0] } + if @replace == 1 && ref $replace[0] eq 'ARRAY'; + return [ splice @$list, $offset, $length, @replace ]; + } + elsif (defined $length) { + return [ splice @$list, $offset, $length ]; + } + elsif (defined $offset) { + return [ splice @$list, $offset ]; + } + else { + return [ splice(@$list) ]; + } + }, + + defined $LIST_OPS ? %$LIST_OPS : (), +}; + +sub hash_import { + my ($hash, $imp) = @_; + $imp = {} unless ref $imp eq 'HASH'; + @$hash{ keys %$imp } = values %$imp; + return ''; +} + + +#------------------------------------------------------------------------ +# define_vmethod($type, $name, \&sub) +# +# Defines a virtual method of type $type (SCALAR, HASH, or LIST), with +# name $name, that invokes &sub when called. It is expected that &sub +# be able to handle the type that it will be called upon. +#------------------------------------------------------------------------ + +sub define_vmethod { + my ($class, $type, $name, $sub) = @_; + my $op; + $type = lc $type; + + if ($type =~ /^scalar|item$/) { + $op = $SCALAR_OPS; + } + elsif ($type eq 'hash') { + $op = $HASH_OPS; + } + elsif ($type =~ /^list|array$/) { + $op = $LIST_OPS; + } + else { + die "invalid vmethod type: $type\n"; + } + + $op->{ $name } = $sub; + + return 1; +} + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%params) +# +# Constructor method which creates a new Template::Stash object. +# An optional hash reference may be passed containing variable +# definitions that will be used to initialise the stash. +# +# Returns a reference to a newly created Template::Stash. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ }; + + my $self = { + global => { }, + %$params, + %$ROOT_OPS, + '_PARENT' => undef, + }; + + bless $self, $class; +} + + +#======================================================================== +# ----- PUBLIC OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# clone(\%params) +# +# Creates a copy of the current stash object to effect localisation +# of variables. The new stash is blessed into the same class as the +# parent (which may be a derived class) and has a '_PARENT' member added +# which contains a reference to the parent stash that created it +# ($self). This member is used in a successive declone() method call to +# return the reference to the parent. +# +# A parameter may be provided which should reference a hash of +# variable/values which should be defined in the new stash. The +# update() method is called to define these new variables in the cloned +# stash. +# +# Returns a reference to a cloned Template::Stash. +#------------------------------------------------------------------------ + +sub clone { + my ($self, $params) = @_; + $params ||= { }; + + # look out for magical 'import' argument which imports another hash + my $import = $params->{ import }; + if (defined $import && UNIVERSAL::isa($import, 'HASH')) { + delete $params->{ import }; + } + else { + undef $import; + } + + my $clone = bless { + %$self, # copy all parent members + %$params, # copy all new data + '_PARENT' => $self, # link to parent + }, ref $self; + + # perform hash import if defined + &{ $HASH_OPS->{ import }}($clone, $import) + if defined $import; + + return $clone; +} + + +#------------------------------------------------------------------------ +# declone($export) +# +# Returns a reference to the PARENT stash. When called in the following +# manner: +# $stash = $stash->declone(); +# the reference count on the current stash will drop to 0 and be "freed" +# and the caller will be left with a reference to the parent. This +# contains the state of the stash before it was cloned. +#------------------------------------------------------------------------ + +sub declone { + my $self = shift; + $self->{ _PARENT } || $self; +} + + +#------------------------------------------------------------------------ +# get($ident) +# +# Returns the value for an variable stored in the stash. The variable +# may be specified as a simple string, e.g. 'foo', or as an array +# reference representing compound variables. In the latter case, each +# pair of successive elements in the list represent a node in the +# compound variable. The first is the variable name, the second a +# list reference of arguments or 0 if undefined. So, the compound +# variable [% foo.bar('foo').baz %] would be represented as the list +# [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the +# identifier or an empty string if undefined. Errors are thrown via +# die(). +#------------------------------------------------------------------------ + +sub get { + my ($self, $ident, $args) = @_; + my ($root, $result); + $root = $self; + + if (ref $ident eq 'ARRAY' + || ($ident =~ /\./) + && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) { + my $size = $#$ident; + + # if $ident is a list reference, then we evaluate each item in the + # identifier against the previous result, using the root stash + # ($self) as the first implicit 'result'... + + foreach (my $i = 0; $i <= $size; $i += 2) { + $result = $self->_dotop($root, @$ident[$i, $i+1]); + last unless defined $result; + $root = $result; + } + } + else { + $result = $self->_dotop($root, $ident, $args); + } + + return defined $result ? $result : $self->undefined($ident, $args); +} + + +#------------------------------------------------------------------------ +# set($ident, $value, $default) +# +# Updates the value for a variable in the stash. The first parameter +# should be the variable name or array, as per get(). The second +# parameter should be the intended value for the variable. The third, +# optional parameter is a flag which may be set to indicate 'default' +# mode. When set true, the variable will only be updated if it is +# currently undefined or has a false value. The magical 'IMPORT' +# variable identifier may be used to indicate that $value is a hash +# reference whose values should be imported. Returns the value set, +# or an empty string if not set (e.g. default mode). In the case of +# IMPORT, returns the number of items imported from the hash. +#------------------------------------------------------------------------ + +sub set { + my ($self, $ident, $value, $default) = @_; + my ($root, $result, $error); + + $root = $self; + + ELEMENT: { + if (ref $ident eq 'ARRAY' + || ($ident =~ /\./) + && ($ident = [ map { s/\(.*$//; ($_, 0) } + split(/\./, $ident) ])) { + + # a compound identifier may contain multiple elements (e.g. + # foo.bar.baz) and we must first resolve all but the last, + # using _dotop() with the $lvalue flag set which will create + # intermediate hashes if necessary... + my $size = $#$ident; + foreach (my $i = 0; $i < $size - 2; $i += 2) { + $result = $self->_dotop($root, @$ident[$i, $i+1], 1); + last ELEMENT unless defined $result; + $root = $result; + } + + # then we call _assign() to assign the value to the last element + $result = $self->_assign($root, @$ident[$size-1, $size], + $value, $default); + } + else { + $result = $self->_assign($root, $ident, 0, $value, $default); + } + } + + return defined $result ? $result : ''; +} + + +#------------------------------------------------------------------------ +# getref($ident) +# +# Returns a "reference" to a particular item. This is represented as a +# closure which will return the actual stash item when called. +# WARNING: still experimental! +#------------------------------------------------------------------------ + +sub getref { + my ($self, $ident, $args) = @_; + my ($root, $item, $result); + $root = $self; + + if (ref $ident eq 'ARRAY') { + my $size = $#$ident; + + foreach (my $i = 0; $i <= $size; $i += 2) { + ($item, $args) = @$ident[$i, $i + 1]; + last if $i >= $size - 2; # don't evaluate last node + last unless defined + ($root = $self->_dotop($root, $item, $args)); + } + } + else { + $item = $ident; + } + + if (defined $root) { + return sub { my @args = (@{$args||[]}, @_); + $self->_dotop($root, $item, \@args); + } + } + else { + return sub { '' }; + } +} + + + + +#------------------------------------------------------------------------ +# update(\%params) +# +# Update multiple variables en masse. No magic is performed. Simple +# variable names only. +#------------------------------------------------------------------------ + +sub update { + my ($self, $params) = @_; + + # look out for magical 'import' argument to import another hash + my $import = $params->{ import }; + if (defined $import && UNIVERSAL::isa($import, 'HASH')) { + @$self{ keys %$import } = values %$import; + delete $params->{ import }; + } + + @$self{ keys %$params } = values %$params; +} + + +#------------------------------------------------------------------------ +# undefined($ident, $args) +# +# Method called when a get() returns an undefined value. Can be redefined +# in a subclass to implement alternate handling. +#------------------------------------------------------------------------ + +sub undefined { + my ($self, $ident, $args); + return ''; +} + + +#======================================================================== +# ----- PRIVATE OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# _dotop($root, $item, \@args, $lvalue) +# +# This is the core 'dot' operation method which evaluates elements of +# variables against their root. All variables have an implicit root +# which is the stash object itself (a hash). Thus, a non-compound +# variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is +# '(stash.)foo.bar'. The first parameter is a reference to the current +# root, initially the stash itself. The second parameter contains the +# name of the variable element, e.g. 'foo'. The third optional +# parameter is a reference to a list of any parenthesised arguments +# specified for the variable, which are passed to sub-routines, object +# methods, etc. The final parameter is an optional flag to indicate +# if this variable is being evaluated on the left side of an assignment +# (e.g. foo.bar.baz = 10). When set true, intermediated hashes will +# be created (e.g. bar) if necessary. +# +# Returns the result of evaluating the item against the root, having +# performed any variable "magic". The value returned can then be used +# as the root of the next _dotop() in a compound sequence. Returns +# undef if the variable is undefined. +#------------------------------------------------------------------------ + +sub _dotop { + my ($self, $root, $item, $args, $lvalue) = @_; + my $rootref = ref $root; + my $atroot = ($root eq $self); + my ($value, @result); + + $args ||= [ ]; + $lvalue ||= 0; + +# print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n" +# if $DEBUG; + + # return undef without an error if either side of the dot is unviable + # or if an attempt is made to access a private member, starting _ or . + return undef + unless defined($root) and defined($item) and $item !~ /^[\._]/; + + if ($atroot || $rootref eq 'HASH') { + + # if $root is a regular HASH or a Template::Stash kinda HASH (the + # *real* root of everything). We first lookup the named key + # in the hash, or create an empty hash in its place if undefined + # and the $lvalue flag is set. Otherwise, we check the HASH_OPS + # pseudo-methods table, calling the code if found, or return undef. + + if (defined($value = $root->{ $item })) { + return $value unless ref $value eq 'CODE'; ## RETURN + @result = &$value(@$args); ## @result + } + elsif ($lvalue) { + # we create an intermediate hash if this is an lvalue + return $root->{ $item } = { }; ## RETURN + } + # ugly hack: only allow import vmeth to be called on root stash + elsif (($value = $HASH_OPS->{ $item }) + && ! $atroot || $item eq 'import') { + @result = &$value($root, @$args); ## @result + } + elsif ( ref $item eq 'ARRAY' ) { + # hash slice + return [@$root{@$item}]; ## RETURN + } + } + elsif ($rootref eq 'ARRAY') { + + # if root is an ARRAY then we check for a LIST_OPS pseudo-method + # (except for l-values for which it doesn't make any sense) + # or return the numerical index into the array, or undef + + if (($value = $LIST_OPS->{ $item }) && ! $lvalue) { + @result = &$value($root, @$args); ## @result + } + elsif ($item =~ /^-?\d+$/) { + $value = $root->[$item]; + return $value unless ref $value eq 'CODE'; ## RETURN + @result = &$value(@$args); ## @result + } + elsif ( ref $item eq 'ARRAY' ) { + # array slice + return [@$root[@$item]]; ## RETURN + } + } + + # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL') + # doesn't appear to work with CGI, returning true for the first call + # and false for all subsequent calls. + + elsif (ref($root) && UNIVERSAL::can($root, 'can')) { + + # if $root is a blessed reference (i.e. inherits from the + # UNIVERSAL object base class) then we call the item as a method. + # If that fails then we try to fallback on HASH behaviour if + # possible. + eval { @result = $root->$item(@$args); }; + + if ($@) { + # temporary hack - required to propogate errors thrown + # by views; if $@ is a ref (e.g. Template::Exception + # object then we assume it's a real error that needs + # real throwing + + die $@ if ref($@) || ($@ !~ /Can't locate object method/); + + # failed to call object method, so try some fallbacks + if (UNIVERSAL::isa($root, 'HASH') + && defined($value = $root->{ $item })) { + return $value unless ref $value eq 'CODE'; ## RETURN + @result = &$value(@$args); + } + elsif (UNIVERSAL::isa($root, 'ARRAY') + && ($value = $LIST_OPS->{ $item })) { + @result = &$value($root, @$args); + } + elsif ($value = $SCALAR_OPS->{ $item }) { + @result = &$value($root, @$args); + } + elsif ($value = $LIST_OPS->{ $item }) { + @result = &$value([$root], @$args); + } + elsif ($self->{ _DEBUG }) { + @result = (undef, $@); + } + } + } + elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { + # at this point, it doesn't look like we've got a reference to + # anything we know about, so we try the SCALAR_OPS pseudo-methods + # table (but not for l-values) + @result = &$value($root, @$args); ## @result + } + elsif (($value = $LIST_OPS->{ $item }) && ! $lvalue) { + # last-ditch: can we promote a scalar to a one-element + # list and apply a LIST_OPS virtual method? + @result = &$value([$root], @$args); + } + elsif ($self->{ _DEBUG }) { + die "don't know how to access [ $root ].$item\n"; ## DIE + } + else { + @result = (); + } + + # fold multiple return items into a list unless first item is undef + if (defined $result[0]) { + return ## RETURN + scalar @result > 1 ? [ @result ] : $result[0]; + } + elsif (defined $result[1]) { + die $result[1]; ## DIE + } + elsif ($self->{ _DEBUG }) { + die "$item is undefined\n"; ## DIE + } + + return undef; +} + + +#------------------------------------------------------------------------ +# _assign($root, $item, \@args, $value, $default) +# +# Similar to _dotop() above, but assigns a value to the given variable +# instead of simply returning it. The first three parameters are the +# root item, the item and arguments, as per _dotop(), followed by the +# value to which the variable should be set and an optional $default +# flag. If set true, the variable will only be set if currently false +# (undefined/zero) +#------------------------------------------------------------------------ + +sub _assign { + my ($self, $root, $item, $args, $value, $default) = @_; + my $rootref = ref $root; + my $atroot = ($root eq $self); + my $result; + $args ||= [ ]; + $default ||= 0; + +# print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n", +# "value=$value, default=$default)\n") +# if $DEBUG; + + # return undef without an error if either side of the dot is unviable + # or if an attempt is made to update a private member, starting _ or . + return undef ## RETURN + unless $root and defined $item and $item !~ /^[\._]/; + + if ($rootref eq 'HASH' || $atroot) { +# if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) { +# # import hash entries into root hash +# @$root{ keys %$value } = values %$value; +# return ''; ## RETURN +# } + # if the root is a hash we set the named key + return ($root->{ $item } = $value) ## RETURN + unless $default && $root->{ $item }; + } + elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) { + # or set a list item by index number + return ($root->[$item] = $value) ## RETURN + unless $default && $root->{ $item }; + } + elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) { + # try to call the item as a method of an object + + return $root->$item(@$args, $value) ## RETURN + unless $default && $root->$item(); + +# 2 issues: +# - method call should be wrapped in eval { } +# - fallback on hash methods if object method not found +# +# eval { $result = $root->$item(@$args, $value); }; +# +# if ($@) { +# die $@ if ref($@) || ($@ !~ /Can't locate object method/); +# +# # failed to call object method, so try some fallbacks +# if (UNIVERSAL::isa($root, 'HASH') && exists $root->{ $item }) { +# $result = ($root->{ $item } = $value) +# unless $default && $root->{ $item }; +# } +# } +# return $result; ## RETURN + + } + else { + die "don't know how to assign to [$root].[$item]\n"; ## DIE + } + + return undef; +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the object. The method calls itself recursively to dump sub-hashes. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + return "[Template::Stash] " . $self->_dump_frame(2); +} + +sub _dump_frame { + my ($self, $indent) = @_; + $indent ||= 1; + my $buffer = ' '; + my $pad = $buffer x $indent; + my $text = "{\n"; + local $" = ', '; + + my ($key, $value); + + return $text . "...excessive recursion, terminating\n" + if $indent > 32; + + foreach $key (keys %$self) { + $value = $self->{ $key }; + $value = '<undef>' unless defined $value; + next if $key =~ /^\./; + if (ref($value) eq 'ARRAY') { + $value = '[ ' . join(', ', map { defined $_ ? $_ : '<undef>' } + @$value) . ' ]'; + } + elsif (ref $value eq 'HASH') { + $value = _dump_frame($value, $indent + 1); + } + + $text .= sprintf("$pad%-16s => $value\n", $key); + } + $text .= $buffer x ($indent - 1) . '}'; + return $text; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Stash - Magical storage for template variables + +=head1 SYNOPSIS + + use Template::Stash; + + my $stash = Template::Stash->new(\%vars); + + # get variable values + $value = $stash->get($variable); + $value = $stash->get(\@compound); + + # set variable value + $stash->set($variable, $value); + $stash->set(\@compound, $value); + + # default variable value + $stash->set($variable, $value, 1); + $stash->set(\@compound, $value, 1); + + # set variable values en masse + $stash->update(\%new_vars) + + # methods for (de-)localising variables + $stash = $stash->clone(\%new_vars); + $stash = $stash->declone(); + +=head1 DESCRIPTION + +The Template::Stash module defines an object class which is used to store +variable values for the runtime use of the template processor. Variable +values are stored internally in a hash reference (which itself is blessed +to create the object) and are accessible via the get() and set() methods. + +Variables may reference hash arrays, lists, subroutines and objects +as well as simple values. The stash automatically performs the right +magic when dealing with variables, calling code or object methods, +indexing into lists, hashes, etc. + +The stash has clone() and declone() methods which are used by the +template processor to make temporary copies of the stash for +localising changes made to variables. + +=head1 PUBLIC METHODS + +=head2 new(\%params) + +The new() constructor method creates and returns a reference to a new +Template::Stash object. + + my $stash = Template::Stash->new(); + +A hash reference may be passed to provide variables and values which +should be used to initialise the stash. + + my $stash = Template::Stash->new({ var1 => 'value1', + var2 => 'value2' }); + +=head2 get($variable) + +The get() method retrieves the variable named by the first parameter. + + $value = $stash->get('var1'); + +Dotted compound variables can be retrieved by specifying the variable +elements by reference to a list. Each node in the variable occupies +two entries in the list. The first gives the name of the variable +element, the second is a reference to a list of arguments for that +element, or 0 if none. + + [% foo.bar(10).baz(20) %] + + $stash->get([ 'foo', 0, 'bar', [ 10 ], 'baz', [ 20 ] ]); + +=head2 set($variable, $value, $default) + +The set() method sets the variable name in the first parameter to the +value specified in the second. + + $stash->set('var1', 'value1'); + +If the third parameter evaluates to a true value, the variable is +set only if it did not have a true value before. + + $stash->set('var2', 'default_value', 1); + +Dotted compound variables may be specified as per get() above. + + [% foo.bar = 30 %] + + $stash->set([ 'foo', 0, 'bar', 0 ], 30); + +The magical variable 'IMPORT' can be specified whose corresponding +value should be a hash reference. The contents of the hash array are +copied (i.e. imported) into the current namespace. + + # foo.bar = baz, foo.wiz = waz + $stash->set('foo', { 'bar' => 'baz', 'wiz' => 'waz' }); + + # import 'foo' into main namespace: foo = baz, wiz = waz + $stash->set('IMPORT', $stash->get('foo')); + +=head2 clone(\%params) + +The clone() method creates and returns a new Template::Stash object which +represents a localised copy of the parent stash. Variables can be +freely updated in the cloned stash and when declone() is called, the +original stash is returned with all its members intact and in the +same state as they were before clone() was called. + +For convenience, a hash of parameters may be passed into clone() which +is used to update any simple variable (i.e. those that don't contain any +namespace elements like 'foo' and 'bar' but not 'foo.bar') variables while +cloning the stash. For adding and updating complex variables, the set() +method should be used after calling clone(). This will correctly resolve +and/or create any necessary namespace hashes. + +A cloned stash maintains a reference to the stash that it was copied +from in its '_PARENT' member. + +=head2 declone() + +The declone() method returns the '_PARENT' reference and can be used to +restore the state of a stash as described above. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.78, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template>, L<Template::Context|Template::Context> diff --git a/lib/Template/Stash/Context.pm b/lib/Template/Stash/Context.pm new file mode 100644 index 0000000..8f9cfdb --- /dev/null +++ b/lib/Template/Stash/Context.pm @@ -0,0 +1,781 @@ +#============================================================= -*-Perl-*- +# +# Template::Stash::Context +# +# DESCRIPTION +# This is an alternate stash object which includes a patch from +# Craig Barratt to implement various new virtual methods to allow +# dotted template variable to denote if object methods and subroutines +# should be called in scalar or list context. It adds a little overhead +# to each stash call and I'm a little wary of doing that. So for now, +# it's implemented as a separate stash module which will allow us to +# test it out, benchmark it and switch it in or out as we require. +# +# This is what Craig has to say about it: +# +# Here's a better set of features for the core. Attached is a new version +# of Stash.pm (based on TT2.02) that: +# +# - supports the special op "scalar" that forces scalar context on +# function calls, eg: +# +# cgi.param("foo").scalar +# +# calls cgi.param("foo") in scalar context (unlike my wimpy +# scalar op from last night). Array context is the default. +# +# With non-function operands, scalar behaves like the perl +# version (eg: no-op for scalar, size for arrays, etc). +# +# - supports the special op "ref" that behaves like the perl ref. +# If applied to a function the function is not called. Eg: +# +# cgi.param("foo").ref +# +# does *not* call cgi.param and evaluates to "CODE". Similarly, +# HASH.ref, ARRAY.ref return what you expect. +# +# - adds a new scalar and list op called "array" that is a no-op for +# arrays and promotes scalars to one-element arrays. +# +# - allows scalar ops to be applied to arrays and hashes in place, +# eg: ARRAY.repeat(3) repeats each element in place. +# +# - allows list ops to be applied to scalars by promoting the scalars +# to one-element arrays (like an implicit "array"). So you can +# do things like SCALAR.size, SCALAR.join and get a useful result. +# +# This also means you can now use x.0 to safely get the first element +# whether x is an array or scalar. +# +# The new Stash.pm passes the TT2.02 test suite. But I haven't tested the +# new features very much. One nagging implementation problem is that the +# "scalar" and "ref" ops have higher precedence than user variable names. +# +# AUTHORS +# Andy Wardley <abw@kfs.org> +# Craig Barratt <craig@arraycomm.com> +# +# COPYRIGHT +# Copyright (C) 1996-2001 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2001 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Context.pm,v 1.53 2003/04/24 09:14:47 abw Exp $ +# +#============================================================================ + +package Template::Stash::Context; + +require 5.004; + +use strict; +use Template::Stash; +use vars qw( $VERSION $DEBUG $ROOT_OPS $SCALAR_OPS $HASH_OPS $LIST_OPS ); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.53 $ =~ /(\d+)\.(\d+)/); + + +#======================================================================== +# -- PACKAGE VARIABLES AND SUBS -- +#======================================================================== + +#------------------------------------------------------------------------ +# copy virtual methods from those in the regular Template::Stash +#------------------------------------------------------------------------ + +$ROOT_OPS = { + %$Template::Stash::ROOT_OPS, + defined $ROOT_OPS ? %$ROOT_OPS : (), +}; + +$SCALAR_OPS = { + %$Template::Stash::SCALAR_OPS, + 'array' => sub { return [$_[0]] }, + defined $SCALAR_OPS ? %$SCALAR_OPS : (), +}; + +$LIST_OPS = { + %$Template::Stash::LIST_OPS, + 'array' => sub { return $_[0] }, + defined $LIST_OPS ? %$LIST_OPS : (), +}; + +$HASH_OPS = { + %$Template::Stash::HASH_OPS, + defined $HASH_OPS ? %$HASH_OPS : (), +}; + + + +#======================================================================== +# ----- CLASS METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# new(\%params) +# +# Constructor method which creates a new Template::Stash object. +# An optional hash reference may be passed containing variable +# definitions that will be used to initialise the stash. +# +# Returns a reference to a newly created Template::Stash. +#------------------------------------------------------------------------ + +sub new { + my $class = shift; + my $params = ref $_[0] eq 'HASH' ? shift(@_) : { @_ }; + + my $self = { + global => { }, + %$params, + %$ROOT_OPS, + '_PARENT' => undef, + }; + + bless $self, $class; +} + + +#======================================================================== +# ----- PUBLIC OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# clone(\%params) +# +# Creates a copy of the current stash object to effect localisation +# of variables. The new stash is blessed into the same class as the +# parent (which may be a derived class) and has a '_PARENT' member added +# which contains a reference to the parent stash that created it +# ($self). This member is used in a successive declone() method call to +# return the reference to the parent. +# +# A parameter may be provided which should reference a hash of +# variable/values which should be defined in the new stash. The +# update() method is called to define these new variables in the cloned +# stash. +# +# Returns a reference to a cloned Template::Stash. +#------------------------------------------------------------------------ + +sub clone { + my ($self, $params) = @_; + $params ||= { }; + + # look out for magical 'import' argument which imports another hash + my $import = $params->{ import }; + if (defined $import && UNIVERSAL::isa($import, 'HASH')) { + delete $params->{ import }; + } + else { + undef $import; + } + + my $clone = bless { + %$self, # copy all parent members + %$params, # copy all new data + '_PARENT' => $self, # link to parent + }, ref $self; + + # perform hash import if defined + &{ $HASH_OPS->{ import }}($clone, $import) + if defined $import; + + return $clone; +} + + +#------------------------------------------------------------------------ +# declone($export) +# +# Returns a reference to the PARENT stash. When called in the following +# manner: +# $stash = $stash->declone(); +# the reference count on the current stash will drop to 0 and be "freed" +# and the caller will be left with a reference to the parent. This +# contains the state of the stash before it was cloned. +#------------------------------------------------------------------------ + +sub declone { + my $self = shift; + $self->{ _PARENT } || $self; +} + + +#------------------------------------------------------------------------ +# get($ident) +# +# Returns the value for an variable stored in the stash. The variable +# may be specified as a simple string, e.g. 'foo', or as an array +# reference representing compound variables. In the latter case, each +# pair of successive elements in the list represent a node in the +# compound variable. The first is the variable name, the second a +# list reference of arguments or 0 if undefined. So, the compound +# variable [% foo.bar('foo').baz %] would be represented as the list +# [ 'foo', 0, 'bar', ['foo'], 'baz', 0 ]. Returns the value of the +# identifier or an empty string if undefined. Errors are thrown via +# die(). +#------------------------------------------------------------------------ + +sub get { + my ($self, $ident, $args) = @_; + my ($root, $result); + $root = $self; + + if (ref $ident eq 'ARRAY' + || ($ident =~ /\./) + && ($ident = [ map { s/\(.*$//; ($_, 0) } split(/\./, $ident) ])) { + my $size = $#$ident; + + # if $ident is a list reference, then we evaluate each item in the + # identifier against the previous result, using the root stash + # ($self) as the first implicit 'result'... + + foreach (my $i = 0; $i <= $size; $i += 2) { + if ( $i + 2 <= $size && ($ident->[$i+2] eq "scalar" + || $ident->[$i+2] eq "ref") ) { + $result = $self->_dotop($root, @$ident[$i, $i+1], 0, + $ident->[$i+2]); + $i += 2; + } else { + $result = $self->_dotop($root, @$ident[$i, $i+1]); + } + last unless defined $result; + $root = $result; + } + } + else { + $result = $self->_dotop($root, $ident, $args); + } + + return defined $result ? $result : ''; +} + + +#------------------------------------------------------------------------ +# set($ident, $value, $default) +# +# Updates the value for a variable in the stash. The first parameter +# should be the variable name or array, as per get(). The second +# parameter should be the intended value for the variable. The third, +# optional parameter is a flag which may be set to indicate 'default' +# mode. When set true, the variable will only be updated if it is +# currently undefined or has a false value. The magical 'IMPORT' +# variable identifier may be used to indicate that $value is a hash +# reference whose values should be imported. Returns the value set, +# or an empty string if not set (e.g. default mode). In the case of +# IMPORT, returns the number of items imported from the hash. +#------------------------------------------------------------------------ + +sub set { + my ($self, $ident, $value, $default) = @_; + my ($root, $result, $error); + + $root = $self; + + ELEMENT: { + if (ref $ident eq 'ARRAY' + || ($ident =~ /\./) + && ($ident = [ map { s/\(.*$//; ($_, 0) } + split(/\./, $ident) ])) { + + # a compound identifier may contain multiple elements (e.g. + # foo.bar.baz) and we must first resolve all but the last, + # using _dotop() with the $lvalue flag set which will create + # intermediate hashes if necessary... + my $size = $#$ident; + foreach (my $i = 0; $i < $size - 2; $i += 2) { + $result = $self->_dotop($root, @$ident[$i, $i+1], 1); + last ELEMENT unless defined $result; + $root = $result; + } + + # then we call _assign() to assign the value to the last element + $result = $self->_assign($root, @$ident[$size-1, $size], + $value, $default); + } + else { + $result = $self->_assign($root, $ident, 0, $value, $default); + } + } + + return defined $result ? $result : ''; +} + + +#------------------------------------------------------------------------ +# getref($ident) +# +# Returns a "reference" to a particular item. This is represented as a +# closure which will return the actual stash item when called. +# WARNING: still experimental! +#------------------------------------------------------------------------ + +sub getref { + my ($self, $ident, $args) = @_; + my ($root, $item, $result); + $root = $self; + + if (ref $ident eq 'ARRAY') { + my $size = $#$ident; + + foreach (my $i = 0; $i <= $size; $i += 2) { + ($item, $args) = @$ident[$i, $i + 1]; + last if $i >= $size - 2; # don't evaluate last node + last unless defined + ($root = $self->_dotop($root, $item, $args)); + } + } + else { + $item = $ident; + } + + if (defined $root) { + return sub { my @args = (@{$args||[]}, @_); + $self->_dotop($root, $item, \@args); + } + } + else { + return sub { '' }; + } +} + + + + +#------------------------------------------------------------------------ +# update(\%params) +# +# Update multiple variables en masse. No magic is performed. Simple +# variable names only. +#------------------------------------------------------------------------ + +sub update { + my ($self, $params) = @_; + + # look out for magical 'import' argument to import another hash + my $import = $params->{ import }; + if (defined $import && UNIVERSAL::isa($import, 'HASH')) { + @$self{ keys %$import } = values %$import; + delete $params->{ import }; + } + + @$self{ keys %$params } = values %$params; +} + + +#======================================================================== +# ----- PRIVATE OBJECT METHODS ----- +#======================================================================== + +#------------------------------------------------------------------------ +# _dotop($root, $item, \@args, $lvalue, $nextItem) +# +# This is the core 'dot' operation method which evaluates elements of +# variables against their root. All variables have an implicit root +# which is the stash object itself (a hash). Thus, a non-compound +# variable 'foo' is actually '(stash.)foo', the compound 'foo.bar' is +# '(stash.)foo.bar'. The first parameter is a reference to the current +# root, initially the stash itself. The second parameter contains the +# name of the variable element, e.g. 'foo'. The third optional +# parameter is a reference to a list of any parenthesised arguments +# specified for the variable, which are passed to sub-routines, object +# methods, etc. The final parameter is an optional flag to indicate +# if this variable is being evaluated on the left side of an assignment +# (e.g. foo.bar.baz = 10). When set true, intermediated hashes will +# be created (e.g. bar) if necessary. +# +# Returns the result of evaluating the item against the root, having +# performed any variable "magic". The value returned can then be used +# as the root of the next _dotop() in a compound sequence. Returns +# undef if the variable is undefined. +#------------------------------------------------------------------------ + +sub _dotop { + my ($self, $root, $item, $args, $lvalue, $nextItem) = @_; + my $rootref = ref $root; + my ($value, @result, $ret, $retVal); + $nextItem ||= ""; + my $scalarContext = 1 if ( $nextItem eq "scalar" ); + my $returnRef = 1 if ( $nextItem eq "ref" ); + + $args ||= [ ]; + $lvalue ||= 0; + +# print STDERR "_dotop(root=$root, item=$item, args=[@$args])\n" +# if $DEBUG; + + # return undef without an error if either side of the dot is unviable + # or if an attempt is made to access a private member, starting _ or . + return undef + unless defined($root) and defined($item) and $item !~ /^[\._]/; + + if (ref(\$root) eq "SCALAR" && !$lvalue && + (($value = $LIST_OPS->{ $item }) || $item =~ /^-?\d+$/) ) { + # + # Promote scalar to one element list, to be processed below. + # + $rootref = 'ARRAY'; + $root = [$root]; + } + if ($rootref eq __PACKAGE__ || $rootref eq 'HASH') { + + # if $root is a regular HASH or a Template::Stash kinda HASH (the + # *real* root of everything). We first lookup the named key + # in the hash, or create an empty hash in its place if undefined + # and the $lvalue flag is set. Otherwise, we check the HASH_OPS + # pseudo-methods table, calling the code if found, or return undef. + + if (defined($value = $root->{ $item })) { + ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef, + $scalarContext); + return $retVal if ( $ret ); ## RETURN + } + elsif ($lvalue) { + # we create an intermediate hash if this is an lvalue + return $root->{ $item } = { }; ## RETURN + } + elsif ($value = $HASH_OPS->{ $item }) { + @result = &$value($root, @$args); ## @result + } + elsif (ref $item eq 'ARRAY') { + # hash slice + return [@$root{@$item}]; ## RETURN + } + elsif ($value = $SCALAR_OPS->{ $item }) { + # + # Apply scalar ops to every hash element, in place. + # + foreach my $key ( keys %$root ) { + $root->{$key} = &$value($root->{$key}, @$args); + } + } + } + elsif ($rootref eq 'ARRAY') { + + # if root is an ARRAY then we check for a LIST_OPS pseudo-method + # (except for l-values for which it doesn't make any sense) + # or return the numerical index into the array, or undef + + if (($value = $LIST_OPS->{ $item }) && ! $lvalue) { + @result = &$value($root, @$args); ## @result + } + elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { + # + # Apply scalar ops to every array element, in place. + # + for ( my $i = 0 ; $i < @$root ; $i++ ) { + $root->[$i] = &$value($root->[$i], @$args); ## @result + } + } + elsif ($item =~ /^-?\d+$/) { + $value = $root->[$item]; + ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef, + $scalarContext); + return $retVal if ( $ret ); ## RETURN + } + elsif (ref $item eq 'ARRAY' ) { + # array slice + return [@$root[@$item]]; ## RETURN + } + } + + # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL') + # doesn't appear to work with CGI, returning true for the first call + # and false for all subsequent calls. + + elsif (ref($root) && UNIVERSAL::can($root, 'can')) { + + # if $root is a blessed reference (i.e. inherits from the + # UNIVERSAL object base class) then we call the item as a method. + # If that fails then we try to fallback on HASH behaviour if + # possible. + return ref $root->can($item) if ( $returnRef ); ## RETURN + eval { + @result = $scalarContext ? scalar $root->$item(@$args) + : $root->$item(@$args); ## @result + }; + + if ($@) { + # failed to call object method, so try some fallbacks + if (UNIVERSAL::isa($root, 'HASH') + && defined($value = $root->{ $item })) { + ($ret, $retVal, @result) = _dotop_return($value, $args, + $returnRef, $scalarContext); + return $retVal if ( $ret ); ## RETURN + } + elsif (UNIVERSAL::isa($root, 'ARRAY') + && ($value = $LIST_OPS->{ $item })) { + @result = &$value($root, @$args); + } + else { + @result = (undef, $@); + } + } + } + elsif (($value = $SCALAR_OPS->{ $item }) && ! $lvalue) { + + # at this point, it doesn't look like we've got a reference to + # anything we know about, so we try the SCALAR_OPS pseudo-methods + # table (but not for l-values) + + @result = &$value($root, @$args); ## @result + } + elsif ($self->{ _DEBUG }) { + die "don't know how to access [ $root ].$item\n"; ## DIE + } + else { + @result = (); + } + + # fold multiple return items into a list unless first item is undef + if (defined $result[0]) { + return ref(@result > 1 ? [ @result ] : $result[0]) + if ( $returnRef ); ## RETURN + if ( $scalarContext ) { + return scalar @result if ( @result > 1 ); ## RETURN + return scalar(@{$result[0]}) if ( ref $result[0] eq "ARRAY" ); + return scalar(%{$result[0]}) if ( ref $result[0] eq "HASH" ); + return $result[0]; ## RETURN + } else { + return @result > 1 ? [ @result ] : $result[0]; ## RETURN + } + } + elsif (defined $result[1]) { + die $result[1]; ## DIE + } + elsif ($self->{ _DEBUG }) { + die "$item is undefined\n"; ## DIE + } + + return undef; +} + +#------------------------------------------------------------------------ +# ($ret, $retVal, @result) = _dotop_return($value, $args, $returnRef, +# $scalarContext); +# +# Handle the various return processing for _dotop +#------------------------------------------------------------------------ +sub _dotop_return +{ + my($value, $args, $returnRef, $scalarContext) = @_; + my(@result); + + return (1, ref $value) if ( $returnRef ); ## RETURN + if ( $scalarContext ) { + return (1, scalar(@$value)) if ref $value eq 'ARRAY'; ## RETURN + return (1, scalar(%$value)) if ref $value eq 'HASH'; ## RETURN + return (1, scalar($value)) unless ref $value eq 'CODE'; ## RETURN; + @result = scalar &$value(@$args) ## @result; + } else { + return (1, $value) unless ref $value eq 'CODE'; ## RETURN + @result = &$value(@$args); ## @result + } + return (0, undef, @result); +} + + +#------------------------------------------------------------------------ +# _assign($root, $item, \@args, $value, $default) +# +# Similar to _dotop() above, but assigns a value to the given variable +# instead of simply returning it. The first three parameters are the +# root item, the item and arguments, as per _dotop(), followed by the +# value to which the variable should be set and an optional $default +# flag. If set true, the variable will only be set if currently false +# (undefined/zero) +#------------------------------------------------------------------------ + +sub _assign { + my ($self, $root, $item, $args, $value, $default) = @_; + my $rootref = ref $root; + my $result; + $args ||= [ ]; + $default ||= 0; + +# print(STDERR "_assign(root=$root, item=$item, args=[@$args], \n", +# "value=$value, default=$default)\n") +# if $DEBUG; + + # return undef without an error if either side of the dot is unviable + # or if an attempt is made to update a private member, starting _ or . + return undef ## RETURN + unless $root and defined $item and $item !~ /^[\._]/; + + if ($rootref eq 'HASH' || $rootref eq __PACKAGE__) { +# if ($item eq 'IMPORT' && UNIVERSAL::isa($value, 'HASH')) { +# # import hash entries into root hash +# @$root{ keys %$value } = values %$value; +# return ''; ## RETURN +# } + # if the root is a hash we set the named key + return ($root->{ $item } = $value) ## RETURN + unless $default && $root->{ $item }; + } + elsif ($rootref eq 'ARRAY' && $item =~ /^-?\d+$/) { + # or set a list item by index number + return ($root->[$item] = $value) ## RETURN + unless $default && $root->{ $item }; + } + elsif (UNIVERSAL::isa($root, 'UNIVERSAL')) { + # try to call the item as a method of an object + return $root->$item(@$args, $value); ## RETURN + } + else { + die "don't know how to assign to [$root].[$item]\n"; ## DIE + } + + return undef; +} + + +#------------------------------------------------------------------------ +# _dump() +# +# Debug method which returns a string representing the internal state +# of the object. The method calls itself recursively to dump sub-hashes. +#------------------------------------------------------------------------ + +sub _dump { + my $self = shift; + my $indent = shift || 1; + my $buffer = ' '; + my $pad = $buffer x $indent; + my $text = ''; + local $" = ', '; + + my ($key, $value); + + + return $text . "...excessive recursion, terminating\n" + if $indent > 32; + + foreach $key (keys %$self) { + + $value = $self->{ $key }; + $value = '<undef>' unless defined $value; + + if (ref($value) eq 'ARRAY') { + $value = "$value [@$value]"; + } + $text .= sprintf("$pad%-8s => $value\n", $key); + next if $key =~ /^\./; + if (UNIVERSAL::isa($value, 'HASH')) { + $text .= _dump($value, $indent + 1); + } + } + $text; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Stash::Context - Experimetal stash allowing list/scalar context definition + +=head1 SYNOPSIS + + use Template; + use Template::Stash::Context; + + my $stash = Template::Stash::Context->new(\%vars); + my $tt2 = Template->new({ STASH => $stash }); + +=head1 DESCRIPTION + +This is an alternate stash object which includes a patch from +Craig Barratt to implement various new virtual methods to allow +dotted template variable to denote if object methods and subroutines +should be called in scalar or list context. It adds a little overhead +to each stash call and I'm a little wary of applying that to the core +default stash without investigating the effects first. So for now, +it's implemented as a separate stash module which will allow us to +test it out, benchmark it and switch it in or out as we require. + +This is what Craig has to say about it: + +Here's a better set of features for the core. Attached is a new version +of Stash.pm (based on TT2.02) that: + +* supports the special op "scalar" that forces scalar context on +function calls, eg: + + cgi.param("foo").scalar + +calls cgi.param("foo") in scalar context (unlike my wimpy +scalar op from last night). Array context is the default. + +With non-function operands, scalar behaves like the perl +version (eg: no-op for scalar, size for arrays, etc). + +* supports the special op "ref" that behaves like the perl ref. +If applied to a function the function is not called. Eg: + + cgi.param("foo").ref + +does *not* call cgi.param and evaluates to "CODE". Similarly, +HASH.ref, ARRAY.ref return what you expect. + +* adds a new scalar and list op called "array" that is a no-op for +arrays and promotes scalars to one-element arrays. + +* allows scalar ops to be applied to arrays and hashes in place, +eg: ARRAY.repeat(3) repeats each element in place. + +* allows list ops to be applied to scalars by promoting the scalars +to one-element arrays (like an implicit "array"). So you can +do things like SCALAR.size, SCALAR.join and get a useful result. + +This also means you can now use x.0 to safely get the first element +whether x is an array or scalar. + +The new Stash.pm passes the TT2.02 test suite. But I haven't tested the +new features very much. One nagging implementation problem is that the +"scalar" and "ref" ops have higher precedence than user variable names. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +1.53, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template::Stash|Template::Stash> diff --git a/lib/Template/Stash/XS.pm b/lib/Template/Stash/XS.pm new file mode 100644 index 0000000..ca37c08 --- /dev/null +++ b/lib/Template/Stash/XS.pm @@ -0,0 +1,176 @@ +#============================================================= -*-Perl-*- +# +# Template::Stash::XS +# +# DESCRIPTION +# +# Perl bootstrap for XS module. Inherits methods from +# Template::Stash when not implemented in the XS module. +# +#======================================================================== + +package Template::Stash::XS; + +use Template; +use Template::Stash; + +BEGIN { + require DynaLoader; + @Template::Stash::XS::ISA = qw( DynaLoader Template::Stash ); + + eval { + bootstrap Template::Stash::XS $Template::VERSION; + }; + if ($@) { + die "Couldn't load Template::Stash::XS $Template::VERSION:\n\n$@\n"; + } +} + + +sub DESTROY { + # no op + 1; +} + + +# catch missing method calls here so perl doesn't barf +# trying to load *.al files +sub AUTOLOAD { + my ($self, @args) = @_; + my @c = caller(0); + my $auto = $AUTOLOAD; + + $auto =~ s/.*:://; + $self =~ s/=.*//; + + die "Can't locate object method \"$auto\"" . + " via package \"$self\" at $c[1] line $c[2]\n"; +} + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Stash::XS - Experimetal high-speed stash written in XS + +=head1 SYNOPSIS + + use Template; + use Template::Stash::XS; + + my $stash = Template::Stash::XS->new(\%vars); + my $tt2 = Template->new({ STASH => $stash }); + +=head1 DESCRIPTION + +This module loads the XS version of Template::Stash::XS. It should +behave very much like the old one, but run about twice as fast. +See the synopsis above for usage information. + +Only a few methods (such as get and set) have been implemented in XS. +The others are inherited from Template::Stash. + +=head1 NOTE + +To always use the XS version of Stash, modify the Template/Config.pm +module near line 45: + + $STASH = 'Template::Stash::XS'; + +If you make this change, then there is no need to explicitly create +an instance of Template::Stash::XS as seen in the SYNOPSIS above. Just +use Template as normal. + +Alternatively, in your code add this line before creating a Template +object: + + $Template::Config::STASH = 'Template::Stash::XS'; + +To use the original, pure-perl version restore this line in +Template/Config.pm: + + $STASH = 'Template::Stash'; + +Or in your code: + + $Template::Config::STASH = 'Template::Stash'; + +You can elect to have this performed once for you at installation +time by answering 'y' or 'n' to the question that asks if you want +to make the XS Stash the default. + +=head1 BUGS + +Please report bugs to the Template Toolkit mailing list +templates@template-toolkit.org + +As of version 2.05 of the Template Toolkit, use of the XS Stash is +known to have 2 potentially troublesome side effects. The first +problem is that accesses to tied hashes (e.g. Apache::Session) may not +work as expected. This should be fixed in an imminent release. If +you are using tied hashes then it is suggested that you use the +regular Stash by default, or write a thin wrapper around your tied +hashes to enable the XS Stash to access items via regular method +calls. + +The second potential problem is that enabling the XS Stash causes all +the Template Toolkit modules to be installed in an architecture +dependant library, e.g. in + + /usr/lib/perl5/site_perl/5.6.0/i386-linux/Template + +instead of + + /usr/lib/perl5/site_perl/5.6.0/Template + +At the time of writing, we're not sure why this is happening but it's +likely that this is either a bug or intentional feature in the Perl +ExtUtils::MakeMaker module. As far as I know, Perl always checks the +architecture dependant directories before the architecture independant +ones. Therefore, a newer version of the Template Toolkit installed +with the XS Stash enabled should be used by Perl in preference to any +existing version using the regular stash. However, if you install a +future version of the Template Toolkit with the XS Stash disabled, you +may find that Perl continues to use the older version with XS Stash +enabled in preference. + +=head1 AUTHORS + +Andy Wardley E<lt>abw@tt2.orgE<gt> + +Doug Steinwand E<lt>dsteinwand@citysearch.comE<gt> + +=head1 VERSION + +Template Toolkit version 2.10, released on 24 July 2003. + + + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + + + +=head1 SEE ALSO + +L<Template::Stash|Template::Stash> + diff --git a/lib/Template/Test.pm b/lib/Template/Test.pm new file mode 100644 index 0000000..ba5915f --- /dev/null +++ b/lib/Template/Test.pm @@ -0,0 +1,701 @@ +#============================================================= -*-Perl-*- +# +# Template::Test +# +# DESCRIPTION +# Module defining a test harness which processes template input and +# then compares the output against pre-define expected output. +# Generates test output compatible with Test::Harness. This was +# originally the t/texpect.pl script. +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. +# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#---------------------------------------------------------------------------- +# +# $Id: Test.pm,v 2.64 2003/04/29 12:29:49 abw Exp $ +# +#============================================================================ + +package Template::Test; + +require 5.004; + +use strict; +use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS + $VERSION $DEBUG $EXTRA $PRESERVE $REASON $NO_FLUSH + $loaded %callsign); +use Template qw( :template ); +use Exporter; + +$VERSION = sprintf("%d.%02d", q$Revision: 2.64 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0; +@ISA = qw( Exporter ); +@EXPORT = qw( ntests ok is match flush skip_all test_expect callsign banner ); +@EXPORT_OK = ( 'assert' ); +%EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] ); +$| = 1; + +$REASON = 'not applicable on this platform'; +$NO_FLUSH = 0; +$EXTRA = 0; # any extra tests to come after test_expect() +$PRESERVE = 0 # don't mangle newlines in output/expect + unless defined $PRESERVE; + +# always set binmode on Win32 machines so that any output generated +# is true to what we expect +$Template::BINMODE = ($^O eq 'MSWin32') ? 1 : 0; + +my @results = (); +my ($ntests, $ok_count); +*is = \&match; + +END { + # ensure flush() is called to print any cached results + flush(); +} + + +#------------------------------------------------------------------------ +# ntests($n) +# +# Declare how many (more) tests are expected to come. If ok() is called +# before ntests() then the results are cached instead of being printed +# to STDOUT. When ntests() is called, the total number of tests +# (including any cached) is known and the "1..$ntests" line can be +# printed along with the cached results. After that, calls to ok() +# generated printed output immediately. +#------------------------------------------------------------------------ + +sub ntests { + $ntests = shift; + # add any pre-declared extra tests, or pre-stored test @results, to + # the grand total of tests + $ntests += $EXTRA + scalar @results; + $ok_count = 1; + print $ntests ? "1..$ntests\n" : "1..$ntests # skipped: $REASON\n"; + # flush cached results + foreach my $pre_test (@results) { + ok(@$pre_test); + } +} + + +#------------------------------------------------------------------------ +# ok($truth, $msg) +# +# Tests the value passed for truth and generates an "ok $n" or "not ok $n" +# line accordingly. If ntests() hasn't been called then we cached +# results for later, instead. +#------------------------------------------------------------------------ + +sub ok { + my ($ok, $msg) = @_; + + # cache results if ntests() not yet called + unless ($ok_count) { + push(@results, [ $ok, $msg ]); + return $ok; + } + + $msg = defined $msg ? " - $msg" : ''; + if ($ok) { + print "ok ", $ok_count++, "$msg\n"; + } + else { + print STDERR "FAILED $ok_count: $msg\n" if defined $msg; + print "not ok ", $ok_count++, "$msg\n"; + } +} + + + +#------------------------------------------------------------------------ +# assert($truth, $error) +# +# Test value for truth, die if false. +#------------------------------------------------------------------------ + +sub assert { + my ($ok, $err) = @_; + return ok(1) if $ok; + + # failed + my ($pkg, $file, $line) = caller(); + $err ||= "assert failed"; + $err .= " at $file line $line\n"; + ok(0); + die $err; +} + +#------------------------------------------------------------------------ +# match( $result, $expect ) +#------------------------------------------------------------------------ + +sub match { + my ($result, $expect, $msg) = @_; + my $count = $ok_count ? $ok_count : scalar @results + 1; + + # force stringification of $result to avoid 'no eq method' overload errors + $result = "$result" if ref $result; + + if ($result eq $expect) { + return ok(1, $msg); + } + else { + print STDERR "FAILED $count:\n expect: [$expect]\n result: [$result]\n"; + return ok(0, $msg); + } +} + + +#------------------------------------------------------------------------ +# flush() +# +# Flush any tests results. +#------------------------------------------------------------------------ + +sub flush { + ntests(0) + unless $ok_count || $NO_FLUSH; +} + + +#------------------------------------------------------------------------ +# skip_all($reason) +# +# Skip all tests, setting $REASON to contain any message passed. Calls +# exit(0) which triggers flush() which generates a "1..0 # $REASON" +# string to keep to test harness happy. +#------------------------------------------------------------------------ + +sub skip_all { + $REASON = join('', @_); + exit(0); +} + + +#------------------------------------------------------------------------ +# test_expect($input, $template, \%replace) +# +# This is the main testing sub-routine. The $input parameter should be a +# text string or a filehandle reference (e.g. GLOB or IO::Handle) from +# which the input text can be read. The input should contain a number +# of tests which are split up and processed individually, comparing the +# generated output against the expected output. Tests should be defined +# as follows: +# +# -- test -- +# test input +# -- expect -- +# expected output +# +# -- test -- +# etc... +# +# The number of tests is determined and ntests() is called to generate +# the "0..$n" line compatible with Test::Harness. Each test input is +# then processed by the Template object passed as the second parameter, +# $template. This may also be a hash reference containing configuration +# which are used to instantiate a Template object, or may be left +# undefined in which case a default Template object will be instantiated. +# The third parameter, also optional, may be a reference to a hash array +# defining template variables. This is passed to the template process() +# method. +#------------------------------------------------------------------------ + +sub test_expect { + my ($src, $tproc, $params) = @_; + my ($input, @tests); + my ($output, $expect, $match); + my $count = 0; + my $ttprocs; + + # read input text + eval { + local $/ = undef; + $input = ref $src ? <$src> : $src; + }; + if ($@) { + ntests(1); ok(0); + warn "Cannot read input text from $src\n"; + return undef; + } + + # remove any comment lines + $input =~ s/^#.*?\n//gm; + + # remove anything before '-- start --' and/or after '-- stop --' + $input = $' if $input =~ /\s*--\s*start\s*--\s*/; + $input = $` if $input =~ /\s*--\s*stop\s*--\s*/; + + @tests = split(/^\s*--\s*test\s*--\s*\n/im, $input); + + # if the first line of the file was '--test--' (optional) then the + # first test will be empty and can be discarded + shift(@tests) if $tests[0] =~ /^\s*$/; + + ntests(3 + scalar(@tests) * 2); + + # first test is that Template loaded OK, which it did + ok(1, 'running test_expect()'); + + # optional second param may contain a Template reference or a HASH ref + # of constructor options, or may be undefined + if (ref($tproc) eq 'HASH') { + # create Template object using hash of config items + $tproc = Template->new($tproc) + || die Template->error(), "\n"; + } + elsif (ref($tproc) eq 'ARRAY') { + # list of [ name => $tproc, name => $tproc ], use first $tproc + $ttprocs = { @$tproc }; + $tproc = $tproc->[1]; + } + elsif (! ref $tproc) { + $tproc = Template->new() + || die Template->error(), "\n"; + } + # otherwise, we assume it's a Template reference + + # test: template processor created OK + ok($tproc, 'template processor is engaged'); + + # third test is that the input read ok, which it did + ok(1, 'input read and split into ' . scalar @tests . ' tests'); + + # the remaining tests are defined in @tests... + foreach $input (@tests) { + $count++; + my $name = ''; + + if ($input =~ s/^\s*-- name:? (.*?) --\s*\n//im) { + $name = $1; + } + else { + $name = "template text $count"; + } + + # split input by a line like "-- expect --" + ($input, $expect) = + split(/^\s*--\s*expect\s*--\s*\n/im, $input); + $expect = '' + unless defined $expect; + + $output = ''; + + # input text may be prefixed with "-- use name --" to indicate a + # Template object in the $ttproc hash which we should use + if ($input =~ s/^\s*--\s*use\s+(\S+)\s*--\s*\n//im) { + my $ttname = $1; + my $ttlookup; + if ($ttlookup = $ttprocs->{ $ttname }) { + $tproc = $ttlookup; + } + else { + warn "no such template object to use: $ttname\n"; + } + } + + # process input text + $tproc->process(\$input, $params, \$output) || do { + warn "Template process failed: ", $tproc->error(), "\n"; + # report failure and automatically fail the expect match + ok(0, "$name process FAILED: " . subtext($input)); + ok(0, '(obviously did not match expected)'); + next; + }; + + # processed OK + ok(1, "$name processed OK: " . subtext($input)); + + # another hack: if the '-- expect --' section starts with + # '-- process --' then we process the expected output + # before comparing it with the generated output. This is + # slightly twisted but it makes it possible to run tests + # where the expected output isn't static. See t/date.t for + # an example. + + if ($expect =~ s/^\s*--+\s*process\s*--+\s*\n//im) { + my $out; + $tproc->process(\$expect, $params, \$out) || do { + warn("Template process failed (expect): ", + $tproc->error(), "\n"); + # report failure and automatically fail the expect match + ok(0, "failed to process expected output [" + . subtext($expect) . ']'); + next; + }; + $expect = $out; + }; + + # strip any trailing blank lines from expected and real output + foreach ($expect, $output) { + s/\n*\Z//mg; + } + + $match = ($expect eq $output) ? 1 : 0; + if (! $match || $DEBUG) { + print "MATCH FAILED\n" + unless $match; + + my ($copyi, $copye, $copyo) = ($input, $expect, $output); + unless ($PRESERVE) { + foreach ($copyi, $copye, $copyo) { + s/\n/\\n/g; + } + } + printf(" input: [%s]\nexpect: [%s]\noutput: [%s]\n", + $copyi, $copye, $copyo); + } + + ok($match, $match ? "$name matched expected" : "$name did not match expected"); + }; +} + +#------------------------------------------------------------------------ +# callsign() +# +# Returns a hash array mapping lower a..z to their phonetic alphabet +# equivalent. +#------------------------------------------------------------------------ + +sub callsign { + my %callsign; + @callsign{ 'a'..'z' } = qw( + alpha bravo charlie delta echo foxtrot golf hotel india + juliet kilo lima mike november oscar papa quebec romeo + sierra tango umbrella victor whisky x-ray yankee zulu ); + return \%callsign; +} + + +#------------------------------------------------------------------------ +# banner($text) +# +# Prints a banner with the specified text if $DEBUG is set. +#------------------------------------------------------------------------ + +sub banner { + return unless $DEBUG; + my $text = join('', @_); + my $count = $ok_count ? $ok_count - 1 : scalar @results; + print "-" x 72, "\n$text ($count tests completed)\n", "-" x 72, "\n"; +} + + +sub subtext { + my $text = shift; + $text =~ s/\s*$//sg; + $text = substr($text, 0, 32) . '...' if length $text > 32; + $text =~ s/\n/\\n/g; + return $text; +} + + +1; + +__END__ + + +#------------------------------------------------------------------------ +# IMPORTANT NOTE +# This documentation is generated automatically from source +# templates. Any changes you make here may be lost. +# +# The 'docsrc' documentation source bundle is available for download +# from http://www.template-toolkit.org/docs.html and contains all +# the source templates, XML files, scripts, etc., from which the +# documentation for the Template Toolkit is built. +#------------------------------------------------------------------------ + +=head1 NAME + +Template::Test - Module for automating TT2 test scripts + +=head1 SYNOPSIS + + use Template::Test; + + $Template::Test::DEBUG = 0; # set this true to see each test running + $Template::Test::EXTRA = 2; # 2 extra tests follow test_expect()... + + # ok() can be called any number of times before test_expect + ok( $true_or_false ) + + # test_expect() splits $input into individual tests, processes each + # and compares generated output against expected output + test_expect($input, $template, \%replace ); + + # $input is text or filehandle (e.g. DATA section after __END__) + test_expect( $text ); + test_expect( \*DATA ); + + # $template is a Template object or configuration hash + my $template_cfg = { ... }; + test_expect( $input, $template_cfg ); + my $template_obj = Template->new($template_cfg); + test_expect( $input, $template_obj ); + + # $replace is a hash reference of template variables + my $replace = { + a => 'alpha', + b => 'bravo' + }; + test_expect( $input, $template, $replace ); + + # ok() called after test_expect should be declared in $EXTRA (2) + ok( $true_or_false ) + ok( $true_or_false ) + +=head1 DESCRIPTION + +The Template::Test module defines the test_expect() and other related +subroutines which can be used to automate test scripts for the +Template Toolkit. See the numerous tests in the 't' sub-directory of +the distribution for examples of use. + +The test_expect() subroutine splits an input document into a number +of separate tests, processes each one using the Template Toolkit and +then compares the generated output against an expected output, also +specified in the input document. It generates the familiar "ok/not +ok" output compatible with Test::Harness. + +The test input should be specified as a text string or a reference to +a filehandle (e.g. GLOB or IO::Handle) from which it can be read. In +particular, this allows the test input to be placed after the __END__ +marker and read via the DATA filehandle. + + use Template::Test; + + test_expect(\*DATA); + + __END__ + # this is the first test (this is a comment) + -- test -- + blah blah blah [% foo %] + -- expect -- + blah blah blah value_of_foo + + # here's the second test (no surprise, so is this) + -- test -- + more blah blah [% bar %] + -- expect -- + more blah blah value_of_bar + +Blank lines between test sections are generally ignored. Any line starting +with '#' is treated as a comment and is ignored. + +The second and third parameters to test_expect() are optional. The second +may be either a reference to a Template object which should be used to +process the template fragments, or a reference to a hash array containing +configuration values which should be used to instantiate a new Template +object. + + # pass reference to config hash + my $config = { + INCLUDE_PATH => '/here/there:/every/where', + POST_CHOMP => 1, + }; + test_expect(\*DATA, $config); + + # or create Template object explicitly + my $template = Template->new($config); + test_expect(\*DATA, $template); + + +The third parameter may be used to reference a hash array of template +variable which should be defined when processing the tests. This is +passed to the Template process() method. + + my $replace = { + a => 'alpha', + b => 'bravo', + }; + + test_expect(\*DATA, $config, $replace); + +The second parameter may be left undefined to specify a default Template +configuration. + + test_expect(\*DATA, undef, $replace); + +For testing the output of different Template configurations, a +reference to a list of named Template objects also may be passed as +the second parameter. + + my $tt1 = Template->new({ ... }); + my $tt2 = Template->new({ ... }); + my @tts = [ one => $tt1, two => $tt1 ]; + +The first object in the list is used by default. Other objects may be +switched in with the '-- use $name --' marker. This should immediately +follow a '-- test --' line. That object will then be used for the rest +of the test, or until a different object is selected. + + -- test -- + -- use one -- + [% blah %] + -- expect -- + blah, blah + + -- test -- + still using one... + -- expect -- + ... + + -- test -- + -- use two -- + [% blah %] + -- expect -- + blah, blah, more blah + +The test_expect() sub counts the number of tests, and then calls ntests() +to generate the familiar "1..$ntests\n" test harness line. Each +test defined generates two test numbers. The first indicates +that the input was processed without error, and the second that the +output matches that expected. + +Additional test may be run before test_expect() by calling ok(). +These test results are cached until ntests() is called and the final +number of tests can be calculated. Then, the "1..$ntests" line is +output, along with "ok $n" / "not ok $n" lines for each of the cached +test result. Subsequent calls to ok() then generate an output line +immediately. + + my $something = SomeObject->new(); + ok( $something ); + + my $other = AnotherThing->new(); + ok( $other ); + + test_expect(\*DATA); + +If any tests are to follow after test_expect() is called then these +should be pre-declared by setting the $EXTRA package variable. This +value (default: 0) is added to the grand total calculated by ntests(). +The results of the additional tests are also registered by calling ok(). + + $Template::Test::EXTRA = 2; + + # can call ok() any number of times before test_expect() + ok( $did_that_work ); + ok( $make_sure ); + ok( $dead_certain ); + + # <some> number of tests... + test_expect(\*DATA, $config, $replace); + + # here's those $EXTRA tests + ok( defined $some_result && ref $some_result eq 'ARRAY' ); + ok( $some_result->[0] eq 'some expected value' ); + +If you don't want to call test_expect() at all then you can call +ntests($n) to declare the number of tests and generate the test +header line. After that, simply call ok() for each test passing +a true or false values to indicate that the test passed or failed. + + ntests(2); + ok(1); + ok(0); + +If you're really lazy, you can just call ok() and not bother declaring +the number of tests at all. All tests results will be cached until the +end of the script and then printed in one go before the program exits. + + ok( $x ); + ok( $y ); + +You can identify only a specific part of the input file for testing +using the '-- start --' and '-- stop --' markers. Anything before the +first '-- start --' is ignored, along with anything after the next +'-- stop --' marker. + + -- test -- + this is test 1 (not performed) + -- expect -- + this is test 1 (not performed) + + -- start -- + + -- test -- + this is test 2 + -- expect -- + this is test 2 + + -- stop -- + + ... + +For historical reasons and general utility, the module also defines a +'callsign' subroutine which returns a hash mapping a..z to their phonetic +alphabet equivalent (e.g. radio callsigns). This is used by many +of the test scripts as a "known source" of variable values. + + test_expect(\*DATA, $config, callsign()); + +A banner() subroutine is also provided which prints a simple banner +including any text passed as parameters, if $DEBUG is set. + + banner('Testing something-or-other'); + +example output: + + #------------------------------------------------------------ + # Testing something-or-other (27 tests completed) + #------------------------------------------------------------ + +The $DEBUG package variable can be set to enable debugging mode. + +The $PRESERVE package variable can be set to stop the test_expect() +from converting newlines in the output and expected output into +the literal strings '\n'. + +=head1 HISTORY + +This module started its butt-ugly life as the t/texpect.pl script. It +was cleaned up to became the Template::Test module some time around +version 0.29. It underwent further cosmetic surgery for version 2.00 +but still retains some rear-end resemblances. + +=head1 BUGS / KNOWN "FEATURES" + +Imports all methods by default. This is generally a Bad Thing, but +this module is only used in test scripts (i.e. at build time) so a) we +don't really care and b) it saves typing. + +The line splitter may be a bit dumb, especially if it sees lines like +-- this -- that aren't supposed to be special markers. So don't do that. + +=head1 AUTHOR + +Andy Wardley E<lt>abw@andywardley.comE<gt> + +L<http://www.andywardley.com/|http://www.andywardley.com/> + + + + +=head1 VERSION + +2.64, distributed as part of the +Template Toolkit version 2.10, released on 24 July 2003. + +=head1 COPYRIGHT + + Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved. + Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template|Template> diff --git a/lib/Template/View.pm b/lib/Template/View.pm new file mode 100644 index 0000000..312ff45 --- /dev/null +++ b/lib/Template/View.pm @@ -0,0 +1,754 @@ +#============================================================= -*-Perl-*- +# +# Template::View +# +# DESCRIPTION +# A custom view of a template processing context. Can be used to +# implement custom "skins". +# +# AUTHOR +# Andy Wardley <abw@kfs.org> +# +# COPYRIGHT +# Copyright (C) 2000 Andy Wardley. All Rights Reserved. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# TODO +# * allowing print to have a hash ref as final args will cause problems +# if you do this: [% view.print(hash1, hash2, hash3) %]. Current +# work-around is to do [% view.print(hash1); view.print(hash2); +# view.print(hash3) %] or [% view.print(hash1, hash2, hash3, { }) %] +# +# REVISION +# $Id: View.pm,v 2.8 2002/04/15 15:53:37 abw Exp $ +# +#============================================================================ + +package Template::View; + +require 5.004; + +use strict; +use vars qw( $VERSION $DEBUG $AUTOLOAD @BASEARGS $MAP ); +use base qw( Template::Base ); + +$VERSION = sprintf("%d.%02d", q$Revision: 2.8 $ =~ /(\d+)\.(\d+)/); +$DEBUG = 0 unless defined $DEBUG; +@BASEARGS = qw( context ); +$MAP = { + HASH => 'hash', + ARRAY => 'list', + TEXT => 'text', + default => '', +}; + +#$DEBUG = 1; + +#------------------------------------------------------------------------ +# _init(\%config) +# +# Initialisation method called by the Template::Base class new() +# constructor. $self->{ context } has already been set, by virtue of +# being named in @BASEARGS. Remaining config arguments are presented +# as a hash reference. +#------------------------------------------------------------------------ + +sub _init { + my ($self, $config) = @_; + + # move 'context' somewhere more private + $self->{ _CONTEXT } = $self->{ context }; + delete $self->{ context }; + + # generate table mapping object types to templates + my $map = $config->{ map } || { }; + $map->{ default } = $config->{ default } unless defined $map->{ default }; + $self->{ map } = { + %$MAP, + %$map, + }; + + # local BLOCKs definition table + $self->{ _BLOCKS } = $config->{ blocks } || { }; + + # name of presentation method which printed objects might provide + $self->{ method } = defined $config->{ method } + ? $config->{ method } : 'present'; + + # view is sealed by default preventing variable update after + # definition, however we don't actually seal a view until the + # END of the view definition + my $sealed = $config->{ sealed }; + $sealed = 1 unless defined $sealed; + $self->{ sealed } = $sealed ? 1 : 0; + + # copy remaining config items from $config or set defaults + foreach my $arg (qw( base prefix suffix notfound silent )) { + $self->{ $arg } = $config->{ $arg } || ''; + } + + # name of data item used by view() + $self->{ item } = $config->{ item } || 'item'; + + # map methods of form ${include_prefix}_foobar() to include('foobar')? + $self->{ include_prefix } = $config->{ include_prefix } || 'include_'; + # what about mapping foobar() to include('foobar')? + $self->{ include_naked } = defined $config->{ include_naked } + ? $config->{ include_naked } : 1; + + # map methods of form ${view_prefix}_foobar() to include('foobar')? + $self->{ view_prefix } = $config->{ view_prefix } || 'view_'; + # what about mapping foobar() to view('foobar')? + $self->{ view_naked } = $config->{ view_naked } || 0; + + # the view is initially unsealed, allowing directives in the initial + # view template to create data items via the AUTOLOAD; once sealed via + # call to seal(), the AUTOLOAD will not update any internal items. + delete @$config{ qw( base method map default prefix suffix notfound item + include_prefix include_naked silent sealed + view_prefix view_naked blocks ) }; + $config = { %{ $self->{ base }->{ data } }, %$config } + if $self->{ base }; + $self->{ data } = $config; + $self->{ SEALED } = 0; + + return $self; +} + + +#------------------------------------------------------------------------ +# seal() +# unseal() +# +# Seal or unseal the view to allow/prevent new datat items from being +# automatically created by the AUTOLOAD method. +#------------------------------------------------------------------------ + +sub seal { + my $self = shift; + $self->{ SEALED } = $self->{ sealed }; +} + +sub unseal { + my $self = shift; + $self->{ SEALED } = 0; +} + + +#------------------------------------------------------------------------ +# clone(\%config) +# +# Cloning method which takes a copy of $self and then applies to it any +# modifications specified in the $config hash passed as an argument. +# Configuration items may also be specified as a list of "name => $value" +# arguments. Returns a reference to the cloned Template::View object. +# +# NOTE: may need to copy BLOCKS??? +#------------------------------------------------------------------------ + +sub clone { + my $self = shift; + my $clone = bless { %$self }, ref $self; + my $config = ref $_[0] eq 'HASH' ? shift : { @_ }; + + # merge maps + $clone->{ map } = { + %{ $self->{ map } }, + %{ $config->{ map } || { } }, + }; + + # "map => { default=>'xxx' }" can be specified as "default => 'xxx'" + $clone->{ map }->{ default } = $config->{ default } + if defined $config->{ default }; + + # update any remaining config items + my @args = qw( base prefix suffix notfound item method include_prefix + include_naked view_prefix view_naked ); + foreach my $arg (@args) { + $clone->{ $arg } = $config->{ $arg } if defined $config->{ $arg }; + } + push(@args, qw( default map )); + delete @$config{ @args }; + + # anything left is data + my $data = $clone->{ data } = { %{ $self->{ data } } }; + @$data{ keys %$config } = values %$config; + + return $clone; +} + + +#------------------------------------------------------------------------ +# print(@items, ..., \%config) +# +# Prints @items in turn by mapping each to an approriate template using +# the internal 'map' hash. If an entry isn't found and the item is an +# object that implements the method named in the internal 'method' item, +# (default: 'present'), then the method will be called passing a reference +# to $self, against which the presenter method may make callbacks (e.g. +# to view_item()). If the presenter method isn't implemented, then the +# 'default' map entry is consulted and used if defined. The final argument +# may be a reference to a hash array providing local overrides to the internal +# defaults for various items (prefix, suffix, etc). In the presence +# of this parameter, a clone of the current object is first made, applying +# any configuration updates, and control is then delegated to it. +#------------------------------------------------------------------------ + +sub print { + my $self = shift; + + # if final config hash is specified then create a clone and delegate to it + # NOTE: potential problem when called print(\%data_hash1, \%data_hash2); + if ((scalar @_ > 1) && (ref $_[-1] eq 'HASH')) { + my $cfg = pop @_; + my $clone = $self->clone($cfg) + || return; + return $clone->print(@_) + || $self->error($clone->error()); + } + my ($item, $type, $template, $present); + my $method = $self->{ method }; + my $map = $self->{ map }; + my $output = ''; + + # print each argument + foreach $item (@_) { + my $newtype; + + if (! ($type = ref $item)) { + # non-references are TEXT + $type = 'TEXT'; + $template = $map->{ $type }; + } + elsif (! defined ($template = $map->{ $type })) { + # no specific map entry for object, maybe it implements a + # 'present' (or other) method? +# $self->DEBUG("determining if $item can $method\n") if $DEBUG; + if ( $method && UNIVERSAL::can($item, $method) ) { + $self->DEBUG("Calling \$item->$method\n") if $DEBUG; + $present = $item->$method($self); ## call item method + # undef returned indicates error, note that we expect + # $item to have called error() on the view + return unless defined $present; + $output .= $present; + next; ## NEXT + } + elsif ( UNIVERSAL::isa($item, 'HASH' ) + && defined($newtype = $item->{$method}) + && defined($template = $map->{"$method=>$newtype"})) { + } + elsif ( defined($newtype) + && defined($template = $map->{"$method=>*"}) ) { + $template =~ s/\*/$newtype/; + } + elsif (! ($template = $map->{ default }) ) { + # default not defined, so construct template name from type + ($template = $type) =~ s/\W+/_/g; + } + } +# else { +# $self->DEBUG("defined map type for $type: $template\n"); +# } + $self->DEBUG("printing view '", $template || '', "', $item\n") if $DEBUG; + $output .= $self->view($template, $item) + if $template; + } + return $output; +} + + +#------------------------------------------------------------------------ +# view($template, $item, \%vars) +# +# Wrapper around include() which expects a template name, $template, +# followed by a data item, $item, and optionally, a further hash array +# of template variables. The $item is added as an entry to the $vars +# hash (which is created empty if not passed as an argument) under the +# name specified by the internal 'item' member, which is appropriately +# 'item' by default. Thus an external object present() method can +# callback against this object method, simply passing a data item to +# be displayed. The external object doesn't have to know what the +# view expects the item to be called in the $vars hash. +#------------------------------------------------------------------------ + +sub view { + my ($self, $template, $item) = splice(@_, 0, 3); + my $vars = ref $_[0] eq 'HASH' ? shift : { @_ }; + $vars->{ $self->{ item } } = $item if defined $item; + $self->include($template, $vars); +} + + +#------------------------------------------------------------------------ +# include($template, \%vars) +# +# INCLUDE a template, $template, mapped according to the current prefix, +# suffix, default, etc., where $vars is an optional hash reference +# containing template variable definitions. If the template isn't found +# then the method will default to any 'notfound' template, if defined +# as an internal item. +#------------------------------------------------------------------------ + +sub include { + my ($self, $template, $vars) = @_; + my $context = $self->{ _CONTEXT }; + + $template = $self->template($template); + + $vars = { } unless ref $vars eq 'HASH'; + $vars->{ view } ||= $self; + + $context->include( $template, $vars ); + +# DEBUGGING +# my $out = $context->include( $template, $vars ); +# print STDERR "VIEW return [$out]\n"; +# return $out; +} + + +#------------------------------------------------------------------------ +# template($template) +# +# Returns a compiled template for the specified template name, according +# to the current configuration parameters. +#------------------------------------------------------------------------ + +sub template { + my ($self, $name) = @_; + my $context = $self->{ _CONTEXT }; + return $context->throw(Template::Constants::ERROR_VIEW, + "no view template specified") + unless $name; + + my $notfound = $self->{ notfound }; + my $base = $self->{ base }; + my ($template, $block, $error); + + return $block + if ($block = $self->{ _BLOCKS }->{ $name }); + + # try the named template + $template = $self->template_name($name); + $self->DEBUG("looking for $template\n") if $DEBUG; + eval { $template = $context->template($template) }; + + # try asking the base view if not found + if (($error = $@) && $base) { + $self->DEBUG("asking base for $name\n") if $DEBUG; + eval { $template = $base->template($name) }; + } + + # try the 'notfound' template (if defined) if that failed + if (($error = $@) && $notfound) { + unless ($template = $self->{ _BLOCKS }->{ $notfound }) { + $notfound = $self->template_name($notfound); + $self->DEBUG("not found, looking for $notfound\n") if $DEBUG; + eval { $template = $context->template($notfound) }; + + return $context->throw(Template::Constants::ERROR_VIEW, $error) + if $@; # return first error + } + } + elsif ($error) { + $self->DEBUG("no 'notfound'\n") + if $DEBUG; + return $context->throw(Template::Constants::ERROR_VIEW, $error); + } + return $template; +} + + +#------------------------------------------------------------------------ +# template_name($template) +# +# Returns the name of the specified template with any appropriate prefix +# and/or suffix added. +#------------------------------------------------------------------------ + +sub template_name { + my ($self, $template) = @_; + $template = $self->{ prefix } . $template . $self->{ suffix } + if $template; + + $self->DEBUG("template name: $template\n") if $DEBUG; + return $template; +} + + +#------------------------------------------------------------------------ +# default($val) +# +# Special case accessor to retrieve/update 'default' as an alias for +# '$map->{ default }'. +#------------------------------------------------------------------------ + +sub default { + my $self = shift; + return @_ ? ($self->{ map }->{ default } = shift) + : $self->{ map }->{ default }; +} + + +#------------------------------------------------------------------------ +# AUTOLOAD +# + +# Returns/updates public internal data items (i.e. not prefixed '_' or +# '.') or presents a view if the method matches the view_prefix item, +# e.g. view_foo(...) => view('foo', ...). Similarly, the +# include_prefix is used, if defined, to map include_foo(...) to +# include('foo', ...). If that fails then the entire method name will +# be used as the name of a template to include iff the include_named +# parameter is set (default: 1). Last attempt is to match the entire +# method name to a view() call, iff view_naked is set. Otherwise, a +# 'view' exception is raised reporting the error "no such view member: +# $method". +#------------------------------------------------------------------------ + +sub AUTOLOAD { + my $self = shift; + my $item = $AUTOLOAD; + $item =~ s/.*:://; + return if $item eq 'DESTROY'; + + if ($item =~ /^[\._]/) { + return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, + "attempt to view private member: $item"); + } + elsif (exists $self->{ $item }) { + # update existing config item (e.g. 'prefix') if unsealed + return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, + "cannot update config item in sealed view: $item") + if @_ && $self->{ SEALED }; + $self->DEBUG("accessing item: $item\n") if $DEBUG; + return @_ ? ($self->{ $item } = shift) : $self->{ $item }; + } + elsif (exists $self->{ data }->{ $item }) { + # get/update existing data item (must be unsealed to update) + if (@_ && $self->{ SEALED }) { + return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, + "cannot update item in sealed view: $item") + unless $self->{ silent }; + # ignore args if silent + @_ = (); + } + $self->DEBUG(@_ ? "updating data item: $item <= $_[0]\n" + : "returning data item: $item\n") if $DEBUG; + return @_ ? ($self->{ data }->{ $item } = shift) + : $self->{ data }->{ $item }; + } + elsif (@_ && ! $self->{ SEALED }) { + # set data item if unsealed + $self->DEBUG("setting unsealed data: $item => @_\n") if $DEBUG; + $self->{ data }->{ $item } = shift; + } + elsif ($item =~ s/^$self->{ view_prefix }//) { + $self->DEBUG("returning view($item)\n") if $DEBUG; + return $self->view($item, @_); + } + elsif ($item =~ s/^$self->{ include_prefix }//) { + $self->DEBUG("returning include($item)\n") if $DEBUG; + return $self->include($item, @_); + } + elsif ($self->{ include_naked }) { + $self->DEBUG("returning naked include($item)\n") if $DEBUG; + return $self->include($item, @_); + } + elsif ($self->{ view_naked }) { + $self->DEBUG("returning naked view($item)\n") if $DEBUG; + return $self->view($item, @_); + } + else { + return $self->{ _CONTEXT }->throw(Template::Constants::ERROR_VIEW, + "no such view member: $item"); + } +} + + +1; + + +__END__ + +=head1 NAME + +Template::View - customised view of a template processing context + +=head1 SYNOPSIS + + # define a view + [% VIEW view + # some standard args + prefix => 'my_', + suffix => '.tt2', + notfound => 'no_such_file' + ... + + # any other data + title => 'My View title' + other_item => 'Joe Random Data' + ... + %] + # add new data definitions, via 'my' self reference + [% my.author = "$abw.name <$abw.email>" %] + [% my.copy = "© Copyright 2000 $my.author" %] + + # define a local block + [% BLOCK header %] + This is the header block, title: [% title or my.title %] + [% END %] + + [% END %] + + # access data items for view + [% view.title %] + [% view.other_item %] + + # access blocks directly ('include_naked' option, set by default) + [% view.header %] + [% view.header(title => 'New Title') %] + + # non-local templates have prefix/suffix attached + [% view.footer %] # => [% INCLUDE my_footer.tt2 %] + + # more verbose form of block access + [% view.include( 'header', title => 'The Header Title' ) %] + [% view.include_header( title => 'The Header Title' ) %] + + # very short form of above ('include_naked' option, set by default) + [% view.header( title => 'The Header Title' ) %] + + # non-local templates have prefix/suffix attached + [% view.footer %] # => [% INCLUDE my_footer.tt2 %] + + # fallback on the 'notfound' template ('my_no_such_file.tt2') + # if template not found + [% view.include('missing') %] + [% view.include_missing %] + [% view.missing %] + + # print() includes a template relevant to argument type + [% view.print("some text") %] # type=TEXT, template='text' + + [% BLOCK my_text.tt2 %] # 'text' with prefix/suffix + Text: [% item %] + [% END %] + + # now print() a hash ref, mapped to 'hash' template + [% view.print(some_hash_ref) %] # type=HASH, template='hash' + + [% BLOCK my_hash.tt2 %] # 'hash' with prefix/suffix + hash keys: [% item.keys.sort.join(', ') + [% END %] + + # now print() a list ref, mapped to 'list' template + [% view.print(my_list_ref) %] # type=ARRAY, template='list' + + [% BLOCK my_list.tt2 %] # 'list' with prefix/suffix + list: [% item.join(', ') %] + [% END %] + + # print() maps 'My::Object' to 'My_Object' + [% view.print(myobj) %] + + [% BLOCK my_My_Object.tt2 %] + [% item.this %], [% item.that %] + [% END %] + + # update mapping table + [% view.map.ARRAY = 'my_list_template' %] + [% view.map.TEXT = 'my_text_block' %] + + + # change prefix, suffix, item name, etc. + [% view.prefix = 'your_' %] + [% view.default = 'anyobj' %] + ... + +=head1 DESCRIPTION + +TODO + +=head1 METHODS + +=head2 new($context, \%config) + +Creates a new Template::View presenting a custom view of the specified +$context object. + +A reference to a hash array of configuration options may be passed as the +second argument. + +=over 4 + +=item prefix + +Prefix added to all template names. + + [% USE view(prefix => 'my_') %] + [% view.view('foo', a => 20) %] # => my_foo + +=item suffix + +Suffix added to all template names. + + [% USE view(suffix => '.tt2') %] + [% view.view('foo', a => 20) %] # => foo.tt2 + +=item map + +Hash array mapping reference types to template names. The print() +method uses this to determine which template to use to present any +particular item. The TEXT, HASH and ARRAY items default to 'test', +'hash' and 'list' appropriately. + + [% USE view(map => { ARRAY => 'my_list', + HASH => 'your_hash', + My::Foo => 'my_foo', } ) %] + + [% view.print(some_text) %] # => text + [% view.print(a_list) %] # => my_list + [% view.print(a_hash) %] # => your_hash + [% view.print(a_foo) %] # => my_foo + + [% BLOCK text %] + Text: [% item %] + [% END %] + + [% BLOCK my_list %] + list: [% item.join(', ') %] + [% END %] + + [% BLOCK your_hash %] + hash keys: [% item.keys.sort.join(', ') + [% END %] + + [% BLOCK my_foo %] + Foo: [% item.this %], [% item.that %] + [% END %] + +=item method + +Name of a method which objects passed to print() may provide for presenting +themselves to the view. If a specific map entry can't be found for an +object reference and it supports the method (default: 'present') then +the method will be called, passing the view as an argument. The object +can then make callbacks against the view to present itself. + + package Foo; + + sub present { + my ($self, $view) = @_; + return "a regular view of a Foo\n"; + } + + sub debug { + my ($self, $view) = @_; + return "a debug view of a Foo\n"; + } + +In a template: + + [% USE view %] + [% view.print(my_foo_object) %] # a regular view of a Foo + + [% USE view(method => 'debug') %] + [% view.print(my_foo_object) %] # a debug view of a Foo + +=item default + +Default template to use if no specific map entry is found for an item. + + [% USE view(default => 'my_object') %] + + [% view.print(objref) %] # => my_object + +If no map entry or default is provided then the view will attempt to +construct a template name from the object class, substituting any +sequence of non-word characters to single underscores, e.g. + + # 'fubar' is an object of class Foo::Bar + [% view.print(fubar) %] # => Foo_Bar + +Any current prefix and suffix will be added to both the default template +name and any name constructed from the object class. + +=item notfound + +Fallback template to use if any other isn't found. + +=item item + +Name of the template variable to which the print() method assigns the current +item. Defaults to 'item'. + + [% USE view %] + [% BLOCK list %] + [% item.join(', ') %] + [% END %] + [% view.print(a_list) %] + + [% USE view(item => 'thing') %] + [% BLOCK list %] + [% thing.join(', ') %] + [% END %] + [% view.print(a_list) %] + +=item view_prefix + +Prefix of methods which should be mapped to view() by AUTOLOAD. Defaults +to 'view_'. + + [% USE view %] + [% view.view_header() %] # => view('header') + + [% USE view(view_prefix => 'show_me_the_' %] + [% view.show_me_the_header() %] # => view('header') + +=item view_naked + +Flag to indcate if any attempt should be made to map method names to +template names where they don't match the view_prefix. Defaults to 0. + + [% USE view(view_naked => 1) %] + + [% view.header() %] # => view('header') + +=back + +=head2 print( $obj1, $obj2, ... \%config) + +TODO + +=head2 view( $template, \%vars, \%config ); + +TODO + +=head1 AUTHOR + +Andy Wardley E<lt>abw@kfs.orgE<gt> + +=head1 REVISION + +$Revision: 2.8 $ + +=head1 COPYRIGHT + +Copyright (C) 2000 Andy Wardley. All Rights Reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<Template::Plugin|Template::Plugin>, + +=cut + + + + + diff --git a/lib/Text/Balanced.pm b/lib/Text/Balanced.pm new file mode 100644 index 0000000..aa09c3e --- /dev/null +++ b/lib/Text/Balanced.pm @@ -0,0 +1,2301 @@ +# EXTRACT VARIOUSLY DELIMITED TEXT SEQUENCES FROM STRINGS. +# FOR FULL DOCUMENTATION SEE Balanced.pod + +use 5.005; +use strict; + +package Text::Balanced; + +use Exporter; +use SelfLoader; +use vars qw { $VERSION @ISA %EXPORT_TAGS }; + +$VERSION = '1.90'; +@ISA = qw ( Exporter ); + +%EXPORT_TAGS = ( ALL => [ qw( + &extract_delimited + &extract_bracketed + &extract_quotelike + &extract_codeblock + &extract_variable + &extract_tagged + &extract_multiple + + &gen_delimited_pat + &gen_extract_tagged + + &delimited_pat + ) ] ); + +Exporter::export_ok_tags('ALL'); + +# PROTOTYPES + +sub _match_bracketed($$$$$$); +sub _match_variable($$); +sub _match_codeblock($$$$$$$); +sub _match_quotelike($$$$); + +# HANDLE RETURN VALUES IN VARIOUS CONTEXTS + +sub _failmsg { + my ($message, $pos) = @_; + $@ = bless { error=>$message, pos=>$pos }, "Text::Balanced::ErrorMsg"; +} + +sub _fail +{ + my ($wantarray, $textref, $message, $pos) = @_; + _failmsg $message, $pos if $message; + return ("",$$textref,"") if $wantarray; + return undef; +} + +sub _succeed +{ + $@ = undef; + my ($wantarray,$textref) = splice @_, 0, 2; + my ($extrapos, $extralen) = @_>18 ? splice(@_, -2, 2) : (0,0); + my ($startlen) = $_[5]; + my $remainderpos = $_[2]; + if ($wantarray) + { + my @res; + while (my ($from, $len) = splice @_, 0, 2) + { + push @res, substr($$textref,$from,$len); + } + if ($extralen) { # CORRECT FILLET + my $extra = substr($res[0], $extrapos-$startlen, $extralen, "\n"); + $res[1] = "$extra$res[1]"; + eval { substr($$textref,$remainderpos,0) = $extra; + substr($$textref,$extrapos,$extralen,"\n")} ; + #REARRANGE HERE DOC AND FILLET IF POSSIBLE + pos($$textref) = $remainderpos-$extralen+1; # RESET \G + } + else { + pos($$textref) = $remainderpos; # RESET \G + } + return @res; + } + else + { + my $match = substr($$textref,$_[0],$_[1]); + substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen; + my $extra = $extralen + ? substr($$textref, $extrapos, $extralen)."\n" : ""; + eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE + pos($$textref) = $_[4]; # RESET \G + return $match; + } +} + +# BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING + +sub gen_delimited_pat($;$) # ($delimiters;$escapes) +{ + my ($dels, $escs) = @_; + return "" unless $dels =~ /\S/; + $escs = '\\' unless $escs; + $escs .= substr($escs,-1) x (length($dels)-length($escs)); + my @pat = (); + my $i; + for ($i=0; $i<length $dels; $i++) + { + my $del = quotemeta substr($dels,$i,1); + my $esc = quotemeta substr($escs,$i,1); + if ($del eq $esc) + { + push @pat, "$del(?:[^$del]*(?:(?:$del$del)[^$del]*)*)$del"; + } + else + { + push @pat, "$del(?:[^$esc$del]*(?:$esc.[^$esc$del]*)*)$del"; + } + } + my $pat = join '|', @pat; + return "(?:$pat)"; +} + +*delimited_pat = \&gen_delimited_pat; + + +# THE EXTRACTION FUNCTIONS + +sub extract_delimited (;$$$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $del = defined $_[1] ? $_[1] : qq{\'\"\`}; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $esc = defined $_[3] ? $_[3] : qq{\\}; + my $pat = gen_delimited_pat($del, $esc); + my $startpos = pos $$textref || 0; + return _fail($wantarray, $textref, "Not a delimited pattern", 0) + unless $$textref =~ m/\G($pre)($pat)/gc; + my $prelen = length($1); + my $matchpos = $startpos+$prelen; + my $endpos = pos $$textref; + return _succeed $wantarray, $textref, + $matchpos, $endpos-$matchpos, # MATCH + $endpos, length($$textref)-$endpos, # REMAINDER + $startpos, $prelen; # PREFIX +} + +sub extract_bracketed (;$$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + my $ldel = defined $_[1] ? $_[1] : '{([<'; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $wantarray = wantarray; + my $qdel = ""; + my $quotelike; + $ldel =~ s/'//g and $qdel .= q{'}; + $ldel =~ s/"//g and $qdel .= q{"}; + $ldel =~ s/`//g and $qdel .= q{`}; + $ldel =~ s/q//g and $quotelike = 1; + $ldel =~ tr/[](){}<>\0-\377/[[(({{<</ds; + my $rdel = $ldel; + unless ($rdel =~ tr/[({</])}>/) + { + return _fail $wantarray, $textref, + "Did not find a suitable bracket in delimiter: \"$_[1]\"", + 0; + } + my $posbug = pos; + $ldel = join('|', map { quotemeta $_ } split('', $ldel)); + $rdel = join('|', map { quotemeta $_ } split('', $rdel)); + pos = $posbug; + + my $startpos = pos $$textref || 0; + my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel); + + return _fail ($wantarray, $textref) unless @match; + + return _succeed ( $wantarray, $textref, + $match[2], $match[5]+2, # MATCH + @match[8,9], # REMAINDER + @match[0,1], # PREFIX + ); +} + +sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel +{ + my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_; + my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0); + unless ($$textref =~ m/\G$pre/gc) + { + _failmsg "Did not find prefix: /$pre/", $startpos; + return; + } + + $ldelpos = pos $$textref; + + unless ($$textref =~ m/\G($ldel)/gc) + { + _failmsg "Did not find opening bracket after prefix: \"$pre\"", + pos $$textref; + pos $$textref = $startpos; + return; + } + + my @nesting = ( $1 ); + my $textlen = length $$textref; + while (pos $$textref < $textlen) + { + next if $$textref =~ m/\G\\./gcs; + + if ($$textref =~ m/\G($ldel)/gc) + { + push @nesting, $1; + } + elsif ($$textref =~ m/\G($rdel)/gc) + { + my ($found, $brackettype) = ($1, $1); + if ($#nesting < 0) + { + _failmsg "Unmatched closing bracket: \"$found\"", + pos $$textref; + pos $$textref = $startpos; + return; + } + my $expected = pop(@nesting); + $expected =~ tr/({[</)}]>/; + if ($expected ne $brackettype) + { + _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"}, + pos $$textref; + pos $$textref = $startpos; + return; + } + last if $#nesting < 0; + } + elsif ($qdel && $$textref =~ m/\G([$qdel])/gc) + { + $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next; + _failmsg "Unmatched embedded quote ($1)", + pos $$textref; + pos $$textref = $startpos; + return; + } + elsif ($quotelike && _match_quotelike($textref,"",1,0)) + { + next; + } + + else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs } + } + if ($#nesting>=0) + { + _failmsg "Unmatched opening bracket(s): " + . join("..",@nesting)."..", + pos $$textref; + pos $$textref = $startpos; + return; + } + + $endpos = pos $$textref; + + return ( + $startpos, $ldelpos-$startpos, # PREFIX + $ldelpos, 1, # OPENING BRACKET + $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS + $endpos-1, 1, # CLOSING BRACKET + $endpos, length($$textref)-$endpos, # REMAINDER + ); +} + +sub revbracket($) +{ + my $brack = reverse $_[0]; + $brack =~ tr/[({</])}>/; + return $brack; +} + +my $XMLNAME = q{[a-zA-Z_:][a-zA-Z0-9_:.-]*}; + +sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + my $ldel = $_[1]; + my $rdel = $_[2]; + my $pre = defined $_[3] ? $_[3] : '\s*'; + my %options = defined $_[4] ? %{$_[4]} : (); + my $omode = defined $options{fail} ? $options{fail} : ''; + my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) + : defined($options{reject}) ? $options{reject} + : '' + ; + my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) + : defined($options{ignore}) ? $options{ignore} + : '' + ; + + if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + $@ = undef; + + my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); + + return _fail(wantarray, $textref) unless @match; + return _succeed wantarray, $textref, + $match[2], $match[3]+$match[5]+$match[7], # MATCH + @match[8..9,0..1,2..7]; # REM, PRE, BITS +} + +sub _match_tagged # ($$$$$$$) +{ + my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_; + my $rdelspec; + + my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 ); + + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg "Did not find prefix: /$pre/", pos $$textref; + goto failed; + } + + $opentagpos = pos($$textref); + + unless ($$textref =~ m/\G$ldel/gc) + { + _failmsg "Did not find opening tag: /$ldel/", pos $$textref; + goto failed; + } + + $textpos = pos($$textref); + + if (!defined $rdel) + { + $rdelspec = $&; + unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". revbracket($1) /oes) + { + _failmsg "Unable to construct closing tag to match: $rdel", + pos $$textref; + goto failed; + } + } + else + { + $rdelspec = eval "qq{$rdel}" || do { + my $del; + for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',) + { next if $rdel =~ /\Q$_/; $del = $_; last } + unless ($del) { + use Carp; + croak "Can't interpolate right delimiter $rdel" + } + eval "qq$del$rdel$del"; + }; + } + + while (pos($$textref) < length($$textref)) + { + next if $$textref =~ m/\G\\./gc; + + if ($$textref =~ m/\G(\n[ \t]*\n)/gc ) + { + $parapos = pos($$textref) - length($1) + unless defined $parapos; + } + elsif ($$textref =~ m/\G($rdelspec)/gc ) + { + $closetagpos = pos($$textref)-length($1); + goto matched; + } + elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc) + { + next; + } + elsif ($bad && $$textref =~ m/\G($bad)/gcs) + { + pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS + goto short if ($omode eq 'PARA' || $omode eq 'MAX'); + _failmsg "Found invalid nested tag: $1", pos $$textref; + goto failed; + } + elsif ($$textref =~ m/\G($ldel)/gc) + { + my $tag = $1; + pos($$textref) -= length($tag); # REWIND TO NESTED TAG + unless (_match_tagged(@_)) # MATCH NESTED TAG + { + goto short if $omode eq 'PARA' || $omode eq 'MAX'; + _failmsg "Found unbalanced nested tag: $tag", + pos $$textref; + goto failed; + } + } + else { $$textref =~ m/./gcs } + } + +short: + $closetagpos = pos($$textref); + goto matched if $omode eq 'MAX'; + goto failed unless $omode eq 'PARA'; + + if (defined $parapos) { pos($$textref) = $parapos } + else { $parapos = pos($$textref) } + + return ( + $startpos, $opentagpos-$startpos, # PREFIX + $opentagpos, $textpos-$opentagpos, # OPENING TAG + $textpos, $parapos-$textpos, # TEXT + $parapos, 0, # NO CLOSING TAG + $parapos, length($$textref)-$parapos, # REMAINDER + ); + +matched: + $endpos = pos($$textref); + return ( + $startpos, $opentagpos-$startpos, # PREFIX + $opentagpos, $textpos-$opentagpos, # OPENING TAG + $textpos, $closetagpos-$textpos, # TEXT + $closetagpos, $endpos-$closetagpos, # CLOSING TAG + $endpos, length($$textref)-$endpos, # REMAINDER + ); + +failed: + _failmsg "Did not find closing tag", pos $$textref unless $@; + pos($$textref) = $startpos; + return; +} + +sub extract_variable (;$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + return ("","","") unless defined $$textref; + my $pre = defined $_[1] ? $_[1] : '\s*'; + + my @match = _match_variable($textref,$pre); + + return _fail wantarray, $textref unless @match; + + return _succeed wantarray, $textref, + @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX +} + +sub _match_variable($$) +{ +# $# +# $^ +# $$ + my ($textref, $pre) = @_; + my $startpos = pos($$textref) = pos($$textref)||0; + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg "Did not find prefix: /$pre/", pos $$textref; + return; + } + my $varpos = pos($$textref); + unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci) + { + unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc) + { + _failmsg "Did not find leading dereferencer", pos $$textref; + pos $$textref = $startpos; + return; + } + my $deref = $1; + + unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci + or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0) + or $deref eq '$#' or $deref eq '$$' ) + { + _failmsg "Bad identifier after dereferencer", pos $$textref; + pos $$textref = $startpos; + return; + } + } + + while (1) + { + next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc; + next if _match_codeblock($textref, + qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/, + qr/[({[]/, qr/[)}\]]/, + qr/[({[]/, qr/[)}\]]/, 0); + next if _match_codeblock($textref, + qr/\s*/, qr/[{[]/, qr/[}\]]/, + qr/[{[]/, qr/[}\]]/, 0); + next if _match_variable($textref,'\s*->\s*'); + next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc; + last; + } + + my $endpos = pos($$textref); + return ($startpos, $varpos-$startpos, + $varpos, $endpos-$varpos, + $endpos, length($$textref)-$endpos + ); +} + +sub extract_codeblock (;$$$$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $ldel_inner = defined $_[1] ? $_[1] : '{'; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner; + my $rd = $_[4]; + my $rdel_inner = $ldel_inner; + my $rdel_outer = $ldel_outer; + my $posbug = pos; + for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds } + for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds } + for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer) + { + $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')' + } + pos = $posbug; + + my @match = _match_codeblock($textref, $pre, + $ldel_outer, $rdel_outer, + $ldel_inner, $rdel_inner, + $rd); + return _fail($wantarray, $textref) unless @match; + return _succeed($wantarray, $textref, + @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX + ); + +} + +sub _match_codeblock($$$$$$$) +{ + my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_; + my $startpos = pos($$textref) = pos($$textref) || 0; + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg qq{Did not match prefix /$pre/ at"} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + return; + } + my $codepos = pos($$textref); + unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER + { + _failmsg qq{Did not find expected opening bracket at "} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + my $closing = $1; + $closing =~ tr/([<{/)]>}/; + my $matched; + my $patvalid = 1; + while (pos($$textref) < length($$textref)) + { + $matched = ''; + if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc) + { + $patvalid = 0; + next; + } + + if ($$textref =~ m/\G\s*#.*/gc) + { + next; + } + + if ($$textref =~ m/\G\s*($rdel_outer)/gc) + { + unless ($matched = ($closing && $1 eq $closing) ) + { + next if $1 eq '>'; # MIGHT BE A "LESS THAN" + _failmsg q{Mismatched closing bracket at "} . + substr($$textref,pos($$textref),20) . + qq{...". Expected '$closing'}, + pos $$textref; + } + last; + } + + if (_match_variable($textref,'\s*') || + _match_quotelike($textref,'\s*',$patvalid,$patvalid) ) + { + $patvalid = 0; + next; + } + + + # NEED TO COVER MANY MORE CASES HERE!!! + if ($$textref =~ m#\G\s*( [-+*x/%^&|.]=? + | [!=]~ + | =(?!>) + | (\*\*|&&|\|\||<<|>>)=? + | split|grep|map|return + | [([] + )#gcx) + { + $patvalid = 1; + next; + } + + if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) ) + { + $patvalid = 1; + next; + } + + if ($$textref =~ m/\G\s*$ldel_outer/gc) + { + _failmsg q{Improperly nested codeblock at "} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + last; + } + + $patvalid = 0; + $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc; + } + continue { $@ = undef } + + unless ($matched) + { + _failmsg 'No match found for opening bracket', pos $$textref + unless $@; + return; + } + + my $endpos = pos($$textref); + return ( $startpos, $codepos-$startpos, + $codepos, $endpos-$codepos, + $endpos, length($$textref)-$endpos, + ); +} + + +my %mods = ( + 'none' => '[cgimsox]*', + 'm' => '[cgimsox]*', + 's' => '[cegimsox]*', + 'tr' => '[cds]*', + 'y' => '[cds]*', + 'qq' => '', + 'qx' => '', + 'qw' => '', + 'qr' => '[imsx]*', + 'q' => '', + ); + +sub extract_quotelike (;$$) +{ + my $textref = $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $pre = defined $_[1] ? $_[1] : '\s*'; + + my @match = _match_quotelike($textref,$pre,1,0); + return _fail($wantarray, $textref) unless @match; + return _succeed($wantarray, $textref, + $match[2], $match[18]-$match[2], # MATCH + @match[18,19], # REMAINDER + @match[0,1], # PREFIX + @match[2..17], # THE BITS + @match[20,21], # ANY FILLET? + ); +}; + +sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) +{ + my ($textref, $pre, $rawmatch, $qmark) = @_; + + my ($textlen,$startpos, + $oppos, + $preld1pos,$ld1pos,$str1pos,$rd1pos, + $preld2pos,$ld2pos,$str2pos,$rd2pos, + $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 ); + + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg qq{Did not find prefix /$pre/ at "} . + substr($$textref, pos($$textref), 20) . + q{..."}, + pos $$textref; + return; + } + $oppos = pos($$textref); + + my $initial = substr($$textref,$oppos,1); + + if ($initial && $initial =~ m|^[\"\'\`]| + || $rawmatch && $initial =~ m|^/| + || $qmark && $initial =~ m|^\?|) + { + unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx) + { + _failmsg qq{Did not find closing delimiter to match '$initial' at "} . + substr($$textref, $oppos, 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + $modpos= pos($$textref); + $rd1pos = $modpos-1; + + if ($initial eq '/' || $initial eq '?') + { + $$textref =~ m/\G$mods{none}/gc + } + + my $endpos = pos($$textref); + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, 0, # NO OPERATOR + $oppos, 1, # LEFT DEL + $oppos+1, $rd1pos-$oppos-1, # STR/PAT + $rd1pos, 1, # RIGHT DEL + $modpos, 0, # NO 2ND LDEL + $modpos, 0, # NO 2ND STR + $modpos, 0, # NO 2ND RDEL + $modpos, $endpos-$modpos, # MODIFIERS + $endpos, $textlen-$endpos, # REMAINDER + ); + } + + unless ($$textref =~ m{\G((?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc) + { + _failmsg q{No quotelike operator found after prefix at "} . + substr($$textref, pos($$textref), 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + + my $op = $1; + $preld1pos = pos($$textref); + if ($op eq '<<') { + $ld1pos = pos($$textref); + my $label; + if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) { + $label = $1; + } + elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) ' + | \G " ([^"\\]* (?:\\.[^"\\]*)*) " + | \G ` ([^`\\]* (?:\\.[^`\\]*)*) ` + }gcsx) { + $label = $+; + } + else { + $label = ""; + } + my $extrapos = pos($$textref); + $$textref =~ m{.*\n}gc; + $str1pos = pos($$textref); + unless ($$textref =~ m{.*?\n(?=$label\n)}gc) { + _failmsg qq{Missing here doc terminator ('$label') after "} . + substr($$textref, $startpos, 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + $rd1pos = pos($$textref); + $$textref =~ m{$label\n}gc; + $ld2pos = pos($$textref); + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, length($op), # OPERATOR + $ld1pos, $extrapos-$ld1pos, # LEFT DEL + $str1pos, $rd1pos-$str1pos, # STR/PAT + $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL + $ld2pos, 0, # NO 2ND LDEL + $ld2pos, 0, # NO 2ND STR + $ld2pos, 0, # NO 2ND RDEL + $ld2pos, 0, # NO MODIFIERS + $ld2pos, $textlen-$ld2pos, # REMAINDER + $extrapos, $str1pos-$extrapos, # FILLETED BIT + ); + } + + $$textref =~ m/\G\s*/gc; + $ld1pos = pos($$textref); + $str1pos = $ld1pos+1; + + unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD + { + _failmsg "No block delimiter found after quotelike $op", + pos $$textref; + pos $$textref = $startpos; + return; + } + pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN + my ($ldel1, $rdel1) = ("\Q$1","\Q$1"); + if ($ldel1 =~ /[[(<{]/) + { + $rdel1 =~ tr/[({</])}>/; + _match_bracketed($textref,"",$ldel1,"","",$rdel1) + || do { pos $$textref = $startpos; return }; + } + else + { + $$textref =~ /$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs + || do { pos $$textref = $startpos; return }; + } + $ld2pos = $rd1pos = pos($$textref)-1; + + my $second_arg = $op =~ /s|tr|y/ ? 1 : 0; + if ($second_arg) + { + my ($ldel2, $rdel2); + if ($ldel1 =~ /[[(<{]/) + { + unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD + { + _failmsg "Missing second block for quotelike $op", + pos $$textref; + pos $$textref = $startpos; + return; + } + $ldel2 = $rdel2 = "\Q$1"; + $rdel2 =~ tr/[({</])}>/; + } + else + { + $ldel2 = $rdel2 = $ldel1; + } + $str2pos = $ld2pos+1; + + if ($ldel2 =~ /[[(<{]/) + { + pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD + _match_bracketed($textref,"",$ldel2,"","",$rdel2) + || do { pos $$textref = $startpos; return }; + } + else + { + $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs + || do { pos $$textref = $startpos; return }; + } + $rd2pos = pos($$textref)-1; + } + else + { + $ld2pos = $str2pos = $rd2pos = $rd1pos; + } + + $modpos = pos $$textref; + + $$textref =~ m/\G($mods{$op})/gc; + my $endpos = pos $$textref; + + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, length($op), # OPERATOR + $ld1pos, 1, # LEFT DEL + $str1pos, $rd1pos-$str1pos, # STR/PAT + $rd1pos, 1, # RIGHT DEL + $ld2pos, $second_arg, # 2ND LDEL (MAYBE) + $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE) + $rd2pos, $second_arg, # 2ND RDEL (MAYBE) + $modpos, $endpos-$modpos, # MODIFIERS + $endpos, $textlen-$endpos, # REMAINDER + ); +} + +my $def_func = +[ + sub { extract_variable($_[0], '') }, + sub { extract_quotelike($_[0],'') }, + sub { extract_codeblock($_[0],'{}','') }, +]; + +sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown) +{ + my $textref = defined($_[0]) ? \$_[0] : \$_; + my $posbug = pos; + my ($lastpos, $firstpos); + my @fields = (); + + #for ($$textref) + { + my @func = defined $_[1] ? @{$_[1]} : @{$def_func}; + my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000; + my $igunk = $_[3]; + + pos $$textref ||= 0; + + unless (wantarray) + { + use Carp; + carp "extract_multiple reset maximal count to 1 in scalar context" + if $^W && defined($_[2]) && $max > 1; + $max = 1 + } + + my $unkpos; + my $func; + my $class; + + my @class; + foreach $func ( @func ) + { + if (ref($func) eq 'HASH') + { + push @class, (keys %$func)[0]; + $func = (values %$func)[0]; + } + else + { + push @class, undef; + } + } + + FIELD: while (pos($$textref) < length($$textref)) + { + my ($field, $rem); + my @bits; + foreach my $i ( 0..$#func ) + { + my $pref; + $func = $func[$i]; + $class = $class[$i]; + $lastpos = pos $$textref; + if (ref($func) eq 'CODE') + { ($field,$rem,$pref) = @bits = $func->($$textref); + # print "[$field|$rem]" if $field; + } + elsif (ref($func) eq 'Text::Balanced::Extractor') + { @bits = $field = $func->extract($$textref) } + elsif( $$textref =~ m/\G$func/gc ) + { @bits = $field = defined($1) ? $1 : $& } + $pref ||= ""; + if (defined($field) && length($field)) + { + if (!$igunk) { + $unkpos = pos $$textref + if length($pref) && !defined($unkpos); + if (defined $unkpos) + { + push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref; + $firstpos = $unkpos unless defined $firstpos; + undef $unkpos; + last FIELD if @fields == $max; + } + } + push @fields, $class + ? bless (\$field, $class) + : $field; + $firstpos = $lastpos unless defined $firstpos; + $lastpos = pos $$textref; + last FIELD if @fields == $max; + next FIELD; + } + } + if ($$textref =~ /\G(.)/gcs) + { + $unkpos = pos($$textref)-1 + unless $igunk || defined $unkpos; + } + } + + if (defined $unkpos) + { + push @fields, substr($$textref, $unkpos); + $firstpos = $unkpos unless defined $firstpos; + $lastpos = length $$textref; + } + last; + } + + pos $$textref = $lastpos; + return @fields if wantarray; + + $firstpos ||= 0; + eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; + pos $$textref = $firstpos }; + return $fields[0]; +} + + +sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options) +{ + my $ldel = $_[0]; + my $rdel = $_[1]; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my %options = defined $_[3] ? %{$_[3]} : (); + my $omode = defined $options{fail} ? $options{fail} : ''; + my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) + : defined($options{reject}) ? $options{reject} + : '' + ; + my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) + : defined($options{ignore}) ? $options{ignore} + : '' + ; + + if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + + my $posbug = pos; + for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ } + pos = $posbug; + + my $closure = sub + { + my $textref = defined $_[0] ? \$_[0] : \$_; + my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); + + return _fail(wantarray, $textref) unless @match; + return _succeed wantarray, $textref, + $match[2], $match[3]+$match[5]+$match[7], # MATCH + @match[8..9,0..1,2..7]; # REM, PRE, BITS + }; + + bless $closure, 'Text::Balanced::Extractor'; +} + +package Text::Balanced::Extractor; + +sub extract($$) # ($self, $text) +{ + &{$_[0]}($_[1]); +} + +package Text::Balanced::ErrorMsg; + +use overload '""' => sub { "$_[0]->{error}, detected at offset $_[0]->{pos}" }; + +1; + +__END__ + +=head1 NAME + +Text::Balanced - Extract delimited text sequences from strings. + + +=head1 SYNOPSIS + + use Text::Balanced qw ( + extract_delimited + extract_bracketed + extract_quotelike + extract_codeblock + extract_variable + extract_tagged + extract_multiple + + gen_delimited_pat + gen_extract_tagged + ); + + # Extract the initial substring of $text that is delimited by + # two (unescaped) instances of the first character in $delim. + + ($extracted, $remainder) = extract_delimited($text,$delim); + + + # Extract the initial substring of $text that is bracketed + # with a delimiter(s) specified by $delim (where the string + # in $delim contains one or more of '(){}[]<>'). + + ($extracted, $remainder) = extract_bracketed($text,$delim); + + + # Extract the initial substring of $text that is bounded by + # an XML tag. + + ($extracted, $remainder) = extract_tagged($text); + + + # Extract the initial substring of $text that is bounded by + # a C<BEGIN>...C<END> pair. Don't allow nested C<BEGIN> tags + + ($extracted, $remainder) = + extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]}); + + + # Extract the initial substring of $text that represents a + # Perl "quote or quote-like operation" + + ($extracted, $remainder) = extract_quotelike($text); + + + # Extract the initial substring of $text that represents a block + # of Perl code, bracketed by any of character(s) specified by $delim + # (where the string $delim contains one or more of '(){}[]<>'). + + ($extracted, $remainder) = extract_codeblock($text,$delim); + + + # Extract the initial substrings of $text that would be extracted by + # one or more sequential applications of the specified functions + # or regular expressions + + @extracted = extract_multiple($text, + [ \&extract_bracketed, + \&extract_quotelike, + \&some_other_extractor_sub, + qr/[xyz]*/, + 'literal', + ]); + +# Create a string representing an optimized pattern (a la Friedl) +# that matches a substring delimited by any of the specified characters +# (in this case: any type of quote or a slash) + + $patstring = gen_delimited_pat(q{'"`/}); + + +# Generate a reference to an anonymous sub that is just like extract_tagged +# but pre-compiled and optimized for a specific pair of tags, and consequently +# much faster (i.e. 3 times faster). It uses qr// for better performance on +# repeated calls, so it only works under Perl 5.005 or later. + + $extract_head = gen_extract_tagged('<HEAD>','</HEAD>'); + + ($extracted, $remainder) = $extract_head->($text); + + +=head1 DESCRIPTION + +The various C<extract_...> subroutines may be used to +extract a delimited substring, possibly after skipping a +specified prefix string. By default, that prefix is +optional whitespace (C</\s*/>), but you can change it to whatever +you wish (see below). + +The substring to be extracted must appear at the +current C<pos> location of the string's variable +(or at index zero, if no C<pos> position is defined). +In other words, the C<extract_...> subroutines I<don't> +extract the first occurance of a substring anywhere +in a string (like an unanchored regex would). Rather, +they extract an occurance of the substring appearing +immediately at the current matching position in the +string (like a C<\G>-anchored regex would). + + + +=head2 General behaviour in list contexts + +In a list context, all the subroutines return a list, the first three +elements of which are always: + +=over 4 + +=item [0] + +The extracted string, including the specified delimiters. +If the extraction fails an empty string is returned. + +=item [1] + +The remainder of the input string (i.e. the characters after the +extracted string). On failure, the entire string is returned. + +=item [2] + +The skipped prefix (i.e. the characters before the extracted string). +On failure, the empty string is returned. + +=back + +Note that in a list context, the contents of the original input text (the first +argument) are not modified in any way. + +However, if the input text was passed in a variable, that variable's +C<pos> value is updated to point at the first character after the +extracted text. That means that in a list context the various +subroutines can be used much like regular expressions. For example: + + while ( $next = (extract_quotelike($text))[0] ) + { + # process next quote-like (in $next) + } + + +=head2 General behaviour in scalar and void contexts + +In a scalar context, the extracted string is returned, having first been +removed from the input text. Thus, the following code also processes +each quote-like operation, but actually removes them from $text: + + while ( $next = extract_quotelike($text) ) + { + # process next quote-like (in $next) + } + +Note that if the input text is a read-only string (i.e. a literal), +no attempt is made to remove the extracted text. + +In a void context the behaviour of the extraction subroutines is +exactly the same as in a scalar context, except (of course) that the +extracted substring is not returned. + +=head2 A note about prefixes + +Prefix patterns are matched without any trailing modifiers (C</gimsox> etc.) +This can bite you if you're expecting a prefix specification like +'.*?(?=<H1>)' to skip everything up to the first <H1> tag. Such a prefix +pattern will only succeed if the <H1> tag is on the current line, since +. normally doesn't match newlines. + +To overcome this limitation, you need to turn on /s matching within +the prefix pattern, using the C<(?s)> directive: '(?s).*?(?=<H1>)' + + +=head2 C<extract_delimited> + +The C<extract_delimited> function formalizes the common idiom +of extracting a single-character-delimited substring from the start of +a string. For example, to extract a single-quote delimited string, the +following code is typically used: + + ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s; + $extracted = $1; + +but with C<extract_delimited> it can be simplified to: + + ($extracted,$remainder) = extract_delimited($text, "'"); + +C<extract_delimited> takes up to four scalars (the input text, the +delimiters, a prefix pattern to be skipped, and any escape characters) +and extracts the initial substring of the text that +is appropriately delimited. If the delimiter string has multiple +characters, the first one encountered in the text is taken to delimit +the substring. +The third argument specifies a prefix pattern that is to be skipped +(but must be present!) before the substring is extracted. +The final argument specifies the escape character to be used for each +delimiter. + +All arguments are optional. If the escape characters are not specified, +every delimiter is escaped with a backslash (C<\>). +If the prefix is not specified, the +pattern C<'\s*'> - optional whitespace - is used. If the delimiter set +is also not specified, the set C</["'`]/> is used. If the text to be processed +is not specified either, C<$_> is used. + +In list context, C<extract_delimited> returns a array of three +elements, the extracted substring (I<including the surrounding +delimiters>), the remainder of the text, and the skipped prefix (if +any). If a suitable delimited substring is not found, the first +element of the array is the empty string, the second is the complete +original text, and the prefix returned in the third element is an +empty string. + +In a scalar context, just the extracted substring is returned. In +a void context, the extracted substring (and any prefix) are simply +removed from the beginning of the first argument. + +Examples: + + # Remove a single-quoted substring from the very beginning of $text: + + $substring = extract_delimited($text, "'", ''); + + # Remove a single-quoted Pascalish substring (i.e. one in which + # doubling the quote character escapes it) from the very + # beginning of $text: + + $substring = extract_delimited($text, "'", '', "'"); + + # Extract a single- or double- quoted substring from the + # beginning of $text, optionally after some whitespace + # (note the list context to protect $text from modification): + + ($substring) = extract_delimited $text, q{"'}; + + + # Delete the substring delimited by the first '/' in $text: + + $text = join '', (extract_delimited($text,'/','[^/]*')[2,1]; + +Note that this last example is I<not> the same as deleting the first +quote-like pattern. For instance, if C<$text> contained the string: + + "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }" + +then after the deletion it would contain: + + "if ('.$UNIXCMD/s) { $cmd = $1; }" + +not: + + "if ('./cmd' =~ ms) { $cmd = $1; }" + + +See L<"extract_quotelike"> for a (partial) solution to this problem. + + +=head2 C<extract_bracketed> + +Like C<"extract_delimited">, the C<extract_bracketed> function takes +up to three optional scalar arguments: a string to extract from, a delimiter +specifier, and a prefix pattern. As before, a missing prefix defaults to +optional whitespace and a missing text defaults to C<$_>. However, a missing +delimiter specifier defaults to C<'{}()[]E<lt>E<gt>'> (see below). + +C<extract_bracketed> extracts a balanced-bracket-delimited +substring (using any one (or more) of the user-specified delimiter +brackets: '(..)', '{..}', '[..]', or '<..>'). Optionally it will also +respect quoted unbalanced brackets (see below). + +A "delimiter bracket" is a bracket in list of delimiters passed as +C<extract_bracketed>'s second argument. Delimiter brackets are +specified by giving either the left or right (or both!) versions +of the required bracket(s). Note that the order in which +two or more delimiter brackets are specified is not significant. + +A "balanced-bracket-delimited substring" is a substring bounded by +matched brackets, such that any other (left or right) delimiter +bracket I<within> the substring is also matched by an opposite +(right or left) delimiter bracket I<at the same level of nesting>. Any +type of bracket not in the delimiter list is treated as an ordinary +character. + +In other words, each type of bracket specified as a delimiter must be +balanced and correctly nested within the substring, and any other kind of +("non-delimiter") bracket in the substring is ignored. + +For example, given the string: + + $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }"; + +then a call to C<extract_bracketed> in a list context: + + @result = extract_bracketed( $text, '{}' ); + +would return: + + ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" ) + +since both sets of C<'{..}'> brackets are properly nested and evenly balanced. +(In a scalar context just the first element of the array would be returned. In +a void context, C<$text> would be replaced by an empty string.) + +Likewise the call in: + + @result = extract_bracketed( $text, '{[' ); + +would return the same result, since all sets of both types of specified +delimiter brackets are correctly nested and balanced. + +However, the call in: + + @result = extract_bracketed( $text, '{([<' ); + +would fail, returning: + + ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" ); + +because the embedded pairs of C<'(..)'>s and C<'[..]'>s are "cross-nested" and +the embedded C<'E<gt>'> is unbalanced. (In a scalar context, this call would +return an empty string. In a void context, C<$text> would be unchanged.) + +Note that the embedded single-quotes in the string don't help in this +case, since they have not been specified as acceptable delimiters and are +therefore treated as non-delimiter characters (and ignored). + +However, if a particular species of quote character is included in the +delimiter specification, then that type of quote will be correctly handled. +for example, if C<$text> is: + + $text = '<A HREF=">>>>">link</A>'; + +then + + @result = extract_bracketed( $text, '<">' ); + +returns: + + ( '<A HREF=">>>>">', 'link</A>', "" ) + +as expected. Without the specification of C<"> as an embedded quoter: + + @result = extract_bracketed( $text, '<>' ); + +the result would be: + + ( '<A HREF=">', '>>>">link</A>', "" ) + +In addition to the quote delimiters C<'>, C<">, and C<`>, full Perl quote-like +quoting (i.e. q{string}, qq{string}, etc) can be specified by including the +letter 'q' as a delimiter. Hence: + + @result = extract_bracketed( $text, '<q>' ); + +would correctly match something like this: + + $text = '<leftop: conj /and/ conj>'; + +See also: C<"extract_quotelike"> and C<"extract_codeblock">. + + +=head2 C<extract_variable> + +C<extract_variable> extracts any valid Perl variable or +variable-involved expression, including scalars, arrays, hashes, array +accesses, hash look-ups, method calls through objects, subroutine calles +through subroutine references, etc. + +The subroutine takes up to two optional arguments: + +=over 4 + +=item 1. + +A string to be processed (C<$_> if the string is omitted or C<undef>) + +=item 2. + +A string specifying a pattern to be matched as a prefix (which is to be +skipped). If omitted, optional whitespace is skipped. + +=back + +On success in a list context, an array of 3 elements is returned. The +elements are: + +=over 4 + +=item [0] + +the extracted variable, or variablish expression + +=item [1] + +the remainder of the input text, + +=item [2] + +the prefix substring (if any), + +=back + +On failure, all of these values (except the remaining text) are C<undef>. + +In a scalar context, C<extract_variable> returns just the complete +substring that matched a variablish expression. C<undef> is returned on +failure. In addition, the original input text has the returned substring +(and any prefix) removed from it. + +In a void context, the input text just has the matched substring (and +any specified prefix) removed. + + +=head2 C<extract_tagged> + +C<extract_tagged> extracts and segments text between (balanced) +specified tags. + +The subroutine takes up to five optional arguments: + +=over 4 + +=item 1. + +A string to be processed (C<$_> if the string is omitted or C<undef>) + +=item 2. + +A string specifying a pattern to be matched as the opening tag. +If the pattern string is omitted (or C<undef>) then a pattern +that matches any standard XML tag is used. + +=item 3. + +A string specifying a pattern to be matched at the closing tag. +If the pattern string is omitted (or C<undef>) then the closing +tag is constructed by inserting a C</> after any leading bracket +characters in the actual opening tag that was matched (I<not> the pattern +that matched the tag). For example, if the opening tag pattern +is specified as C<'{{\w+}}'> and actually matched the opening tag +C<"{{DATA}}">, then the constructed closing tag would be C<"{{/DATA}}">. + +=item 4. + +A string specifying a pattern to be matched as a prefix (which is to be +skipped). If omitted, optional whitespace is skipped. + +=item 5. + +A hash reference containing various parsing options (see below) + +=back + +The various options that can be specified are: + +=over 4 + +=item C<reject =E<gt> $listref> + +The list reference contains one or more strings specifying patterns +that must I<not> appear within the tagged text. + +For example, to extract +an HTML link (which should not contain nested links) use: + + extract_tagged($text, '<A>', '</A>', undef, {reject => ['<A>']} ); + +=item C<ignore =E<gt> $listref> + +The list reference contains one or more strings specifying patterns +that are I<not> be be treated as nested tags within the tagged text +(even if they would match the start tag pattern). + +For example, to extract an arbitrary XML tag, but ignore "empty" elements: + + extract_tagged($text, undef, undef, undef, {ignore => ['<[^>]*/>']} ); + +(also see L<"gen_delimited_pat"> below). + + +=item C<fail =E<gt> $str> + +The C<fail> option indicates the action to be taken if a matching end +tag is not encountered (i.e. before the end of the string or some +C<reject> pattern matches). By default, a failure to match a closing +tag causes C<extract_tagged> to immediately fail. + +However, if the string value associated with <reject> is "MAX", then +C<extract_tagged> returns the complete text up to the point of failure. +If the string is "PARA", C<extract_tagged> returns only the first paragraph +after the tag (up to the first line that is either empty or contains +only whitespace characters). +If the string is "", the the default behaviour (i.e. failure) is reinstated. + +For example, suppose the start tag "/para" introduces a paragraph, which then +continues until the next "/endpara" tag or until another "/para" tag is +encountered: + + $text = "/para line 1\n\nline 3\n/para line 4"; + + extract_tagged($text, '/para', '/endpara', undef, + {reject => '/para', fail => MAX ); + + # EXTRACTED: "/para line 1\n\nline 3\n" + +Suppose instead, that if no matching "/endpara" tag is found, the "/para" +tag refers only to the immediately following paragraph: + + $text = "/para line 1\n\nline 3\n/para line 4"; + + extract_tagged($text, '/para', '/endpara', undef, + {reject => '/para', fail => MAX ); + + # EXTRACTED: "/para line 1\n" + +Note that the specified C<fail> behaviour applies to nested tags as well. + +=back + +On success in a list context, an array of 6 elements is returned. The elements are: + +=over 4 + +=item [0] + +the extracted tagged substring (including the outermost tags), + +=item [1] + +the remainder of the input text, + +=item [2] + +the prefix substring (if any), + +=item [3] + +the opening tag + +=item [4] + +the text between the opening and closing tags + +=item [5] + +the closing tag (or "" if no closing tag was found) + +=back + +On failure, all of these values (except the remaining text) are C<undef>. + +In a scalar context, C<extract_tagged> returns just the complete +substring that matched a tagged text (including the start and end +tags). C<undef> is returned on failure. In addition, the original input +text has the returned substring (and any prefix) removed from it. + +In a void context, the input text just has the matched substring (and +any specified prefix) removed. + + +=head2 C<gen_extract_tagged> + +(Note: This subroutine is only available under Perl5.005) + +C<gen_extract_tagged> generates a new anonymous subroutine which +extracts text between (balanced) specified tags. In other words, +it generates a function identical in function to C<extract_tagged>. + +The difference between C<extract_tagged> and the anonymous +subroutines generated by +C<gen_extract_tagged>, is that those generated subroutines: + +=over 4 + +=item * + +do not have to reparse tag specification or parsing options every time +they are called (whereas C<extract_tagged> has to effectively rebuild +its tag parser on every call); + +=item * + +make use of the new qr// construct to pre-compile the regexes they use +(whereas C<extract_tagged> uses standard string variable interpolation +to create tag-matching patterns). + +=back + +The subroutine takes up to four optional arguments (the same set as +C<extract_tagged> except for the string to be processed). It returns +a reference to a subroutine which in turn takes a single argument (the text to +be extracted from). + +In other words, the implementation of C<extract_tagged> is exactly +equivalent to: + + sub extract_tagged + { + my $text = shift; + $extractor = gen_extract_tagged(@_); + return $extractor->($text); + } + +(although C<extract_tagged> is not currently implemented that way, in order +to preserve pre-5.005 compatibility). + +Using C<gen_extract_tagged> to create extraction functions for specific tags +is a good idea if those functions are going to be called more than once, since +their performance is typically twice as good as the more general-purpose +C<extract_tagged>. + + +=head2 C<extract_quotelike> + +C<extract_quotelike> attempts to recognize, extract, and segment any +one of the various Perl quotes and quotelike operators (see +L<perlop(3)>) Nested backslashed delimiters, embedded balanced bracket +delimiters (for the quotelike operators), and trailing modifiers are +all caught. For example, in: + + extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #' + + extract_quotelike ' "You said, \"Use sed\"." ' + + extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; ' + + extract_quotelike ' tr/\\\/\\\\/\\\//ds; ' + +the full Perl quotelike operations are all extracted correctly. + +Note too that, when using the /x modifier on a regex, any comment +containing the current pattern delimiter will cause the regex to be +immediately terminated. In other words: + + 'm / + (?i) # CASE INSENSITIVE + [a-z_] # LEADING ALPHABETIC/UNDERSCORE + [a-z0-9]* # FOLLOWED BY ANY NUMBER OF ALPHANUMERICS + /x' + +will be extracted as if it were: + + 'm / + (?i) # CASE INSENSITIVE + [a-z_] # LEADING ALPHABETIC/' + +This behaviour is identical to that of the actual compiler. + +C<extract_quotelike> takes two arguments: the text to be processed and +a prefix to be matched at the very beginning of the text. If no prefix +is specified, optional whitespace is the default. If no text is given, +C<$_> is used. + +In a list context, an array of 11 elements is returned. The elements are: + +=over 4 + +=item [0] + +the extracted quotelike substring (including trailing modifiers), + +=item [1] + +the remainder of the input text, + +=item [2] + +the prefix substring (if any), + +=item [3] + +the name of the quotelike operator (if any), + +=item [4] + +the left delimiter of the first block of the operation, + +=item [5] + +the text of the first block of the operation +(that is, the contents of +a quote, the regex of a match or substitution or the target list of a +translation), + +=item [6] + +the right delimiter of the first block of the operation, + +=item [7] + +the left delimiter of the second block of the operation +(that is, if it is a C<s>, C<tr>, or C<y>), + +=item [8] + +the text of the second block of the operation +(that is, the replacement of a substitution or the translation list +of a translation), + +=item [9] + +the right delimiter of the second block of the operation (if any), + +=item [10] + +the trailing modifiers on the operation (if any). + +=back + +For each of the fields marked "(if any)" the default value on success is +an empty string. +On failure, all of these values (except the remaining text) are C<undef>. + + +In a scalar context, C<extract_quotelike> returns just the complete substring +that matched a quotelike operation (or C<undef> on failure). In a scalar or +void context, the input text has the same substring (and any specified +prefix) removed. + +Examples: + + # Remove the first quotelike literal that appears in text + + $quotelike = extract_quotelike($text,'.*?'); + + # Replace one or more leading whitespace-separated quotelike + # literals in $_ with "<QLL>" + + do { $_ = join '<QLL>', (extract_quotelike)[2,1] } until $@; + + + # Isolate the search pattern in a quotelike operation from $text + + ($op,$pat) = (extract_quotelike $text)[3,5]; + if ($op =~ /[ms]/) + { + print "search pattern: $pat\n"; + } + else + { + print "$op is not a pattern matching operation\n"; + } + + +=head2 C<extract_quotelike> and "here documents" + +C<extract_quotelike> can successfully extract "here documents" from an input +string, but with an important caveat in list contexts. + +Unlike other types of quote-like literals, a here document is rarely +a contiguous substring. For example, a typical piece of code using +here document might look like this: + + <<'EOMSG' || die; + This is the message. + EOMSG + exit; + +Given this as an input string in a scalar context, C<extract_quotelike> +would correctly return the string "<<'EOMSG'\nThis is the message.\nEOMSG", +leaving the string " || die;\nexit;" in the original variable. In other words, +the two separate pieces of the here document are successfully extracted and +concatenated. + +In a list context, C<extract_quotelike> would return the list + +=over 4 + +=item [0] + +"<<'EOMSG'\nThis is the message.\nEOMSG\n" (i.e. the full extracted here document, +including fore and aft delimiters), + +=item [1] + +" || die;\nexit;" (i.e. the remainder of the input text, concatenated), + +=item [2] + +"" (i.e. the prefix substring -- trivial in this case), + +=item [3] + +"<<" (i.e. the "name" of the quotelike operator) + +=item [4] + +"'EOMSG'" (i.e. the left delimiter of the here document, including any quotes), + +=item [5] + +"This is the message.\n" (i.e. the text of the here document), + +=item [6] + +"EOMSG" (i.e. the right delimiter of the here document), + +=item [7..10] + +"" (a here document has no second left delimiter, second text, second right +delimiter, or trailing modifiers). + +=back + +However, the matching position of the input variable would be set to +"exit;" (i.e. I<after> the closing delimiter of the here document), +which would cause the earlier " || die;\nexit;" to be skipped in any +sequence of code fragment extractions. + +To avoid this problem, when it encounters a here document whilst +extracting from a modifiable string, C<extract_quotelike> silently +rearranges the string to an equivalent piece of Perl: + + <<'EOMSG' + This is the message. + EOMSG + || die; + exit; + +in which the here document I<is> contiguous. It still leaves the +matching position after the here document, but now the rest of the line +on which the here document starts is not skipped. + +To prevent <extract_quotelike> from mucking about with the input in this way +(this is the only case where a list-context C<extract_quotelike> does so), +you can pass the input variable as an interpolated literal: + + $quotelike = extract_quotelike("$var"); + + +=head2 C<extract_codeblock> + +C<extract_codeblock> attempts to recognize and extract a balanced +bracket delimited substring that may contain unbalanced brackets +inside Perl quotes or quotelike operations. That is, C<extract_codeblock> +is like a combination of C<"extract_bracketed"> and +C<"extract_quotelike">. + +C<extract_codeblock> takes the same initial three parameters as C<extract_bracketed>: +a text to process, a set of delimiter brackets to look for, and a prefix to +match first. It also takes an optional fourth parameter, which allows the +outermost delimiter brackets to be specified separately (see below). + +Omitting the first argument (input text) means process C<$_> instead. +Omitting the second argument (delimiter brackets) indicates that only C<'{'> is to be used. +Omitting the third argument (prefix argument) implies optional whitespace at the start. +Omitting the fourth argument (outermost delimiter brackets) indicates that the +value of the second argument is to be used for the outermost delimiters. + +Once the prefix an dthe outermost opening delimiter bracket have been +recognized, code blocks are extracted by stepping through the input text and +trying the following alternatives in sequence: + +=over 4 + +=item 1. + +Try and match a closing delimiter bracket. If the bracket was the same +species as the last opening bracket, return the substring to that +point. If the bracket was mismatched, return an error. + +=item 2. + +Try to match a quote or quotelike operator. If found, call +C<extract_quotelike> to eat it. If C<extract_quotelike> fails, return +the error it returned. Otherwise go back to step 1. + +=item 3. + +Try to match an opening delimiter bracket. If found, call +C<extract_codeblock> recursively to eat the embedded block. If the +recursive call fails, return an error. Otherwise, go back to step 1. + +=item 4. + +Unconditionally match a bareword or any other single character, and +then go back to step 1. + +=back + + +Examples: + + # Find a while loop in the text + + if ($text =~ s/.*?while\s*\{/{/) + { + $loop = "while " . extract_codeblock($text); + } + + # Remove the first round-bracketed list (which may include + # round- or curly-bracketed code blocks or quotelike operators) + + extract_codeblock $text, "(){}", '[^(]*'; + + +The ability to specify a different outermost delimiter bracket is useful +in some circumstances. For example, in the Parse::RecDescent module, +parser actions which are to be performed only on a successful parse +are specified using a C<E<lt>defer:...E<gt>> directive. For example: + + sentence: subject verb object + <defer: {$::theVerb = $item{verb}} > + +Parse::RecDescent uses C<extract_codeblock($text, '{}E<lt>E<gt>')> to extract the code +within the C<E<lt>defer:...E<gt>> directive, but there's a problem. + +A deferred action like this: + + <defer: {if ($count>10) {$count--}} > + +will be incorrectly parsed as: + + <defer: {if ($count> + +because the "less than" operator is interpreted as a closing delimiter. + +But, by extracting the directive using +S<C<extract_codeblock($text, '{}', undef, 'E<lt>E<gt>')>> +the '>' character is only treated as a delimited at the outermost +level of the code block, so the directive is parsed correctly. + +=head2 C<extract_multiple> + +The C<extract_multiple> subroutine takes a string to be processed and a +list of extractors (subroutines or regular expressions) to apply to that string. + +In an array context C<extract_multiple> returns an array of substrings +of the original string, as extracted by the specified extractors. +In a scalar context, C<extract_multiple> returns the first +substring successfully extracted from the original string. In both +scalar and void contexts the original string has the first successfully +extracted substring removed from it. In all contexts +C<extract_multiple> starts at the current C<pos> of the string, and +sets that C<pos> appropriately after it matches. + +Hence, the aim of of a call to C<extract_multiple> in a list context +is to split the processed string into as many non-overlapping fields as +possible, by repeatedly applying each of the specified extractors +to the remainder of the string. Thus C<extract_multiple> is +a generalized form of Perl's C<split> subroutine. + +The subroutine takes up to four optional arguments: + +=over 4 + +=item 1. + +A string to be processed (C<$_> if the string is omitted or C<undef>) + +=item 2. + +A reference to a list of subroutine references and/or qr// objects and/or +literal strings and/or hash references, specifying the extractors +to be used to split the string. If this argument is omitted (or +C<undef>) the list: + + [ + sub { extract_variable($_[0], '') }, + sub { extract_quotelike($_[0],'') }, + sub { extract_codeblock($_[0],'{}','') }, + ] + +is used. + + +=item 3. + +An number specifying the maximum number of fields to return. If this +argument is omitted (or C<undef>), split continues as long as possible. + +If the third argument is I<N>, then extraction continues until I<N> fields +have been successfully extracted, or until the string has been completely +processed. + +Note that in scalar and void contexts the value of this argument is +automatically reset to 1 (under C<-w>, a warning is issued if the argument +has to be reset). + +=item 4. + +A value indicating whether unmatched substrings (see below) within the +text should be skipped or returned as fields. If the value is true, +such substrings are skipped. Otherwise, they are returned. + +=back + +The extraction process works by applying each extractor in +sequence to the text string. + +If the extractor is a subroutine it is called in a list context and is +expected to return a list of a single element, namely the extracted +text. It may optionally also return two further arguments: a string +representing the text left after extraction (like $' for a pattern +match), and a string representing any prefix skipped before the +extraction (like $` in a pattern match). Note that this is designed +to facilitate the use of other Text::Balanced subroutines with +C<extract_multiple>. Note too that the value returned by an extractor +subroutine need not bear any relationship to the corresponding substring +of the original text (see examples below). + +If the extractor is a precompiled regular expression or a string, +it is matched against the text in a scalar context with a leading +'\G' and the gc modifiers enabled. The extracted value is either +$1 if that variable is defined after the match, or else the +complete match (i.e. $&). + +If the extractor is a hash reference, it must contain exactly one element. +The value of that element is one of the +above extractor types (subroutine reference, regular expression, or string). +The key of that element is the name of a class into which the successful +return value of the extractor will be blessed. + +If an extractor returns a defined value, that value is immediately +treated as the next extracted field and pushed onto the list of fields. +If the extractor was specified in a hash reference, the field is also +blessed into the appropriate class, + +If the extractor fails to match (in the case of a regex extractor), or returns an empty list or an undefined value (in the case of a subroutine extractor), it is +assumed to have failed to extract. +If none of the extractor subroutines succeeds, then one +character is extracted from the start of the text and the extraction +subroutines reapplied. Characters which are thus removed are accumulated and +eventually become the next field (unless the fourth argument is true, in which +case they are disgarded). + +For example, the following extracts substrings that are valid Perl variables: + + @fields = extract_multiple($text, + [ sub { extract_variable($_[0]) } ], + undef, 1); + +This example separates a text into fields which are quote delimited, +curly bracketed, and anything else. The delimited and bracketed +parts are also blessed to identify them (the "anything else" is unblessed): + + @fields = extract_multiple($text, + [ + { Delim => sub { extract_delimited($_[0],q{'"}) } }, + { Brack => sub { extract_bracketed($_[0],'{}') } }, + ]); + +This call extracts the next single substring that is a valid Perl quotelike +operator (and removes it from $text): + + $quotelike = extract_multiple($text, + [ + sub { extract_quotelike($_[0]) }, + ], undef, 1); + +Finally, here is yet another way to do comma-separated value parsing: + + @fields = extract_multiple($csv_text, + [ + sub { extract_delimited($_[0],q{'"}) }, + qr/([^,]+)(.*)/, + ], + undef,1); + +The list in the second argument means: +I<"Try and extract a ' or " delimited string, otherwise extract anything up to a comma...">. +The undef third argument means: +I<"...as many times as possible...">, +and the true value in the fourth argument means +I<"...discarding anything else that appears (i.e. the commas)">. + +If you wanted the commas preserved as separate fields (i.e. like split +does if your split pattern has capturing parentheses), you would +just make the last parameter undefined (or remove it). + + +=head2 C<gen_delimited_pat> + +The C<gen_delimited_pat> subroutine takes a single (string) argument and + > builds a Friedl-style optimized regex that matches a string delimited +by any one of the characters in the single argument. For example: + + gen_delimited_pat(q{'"}) + +returns the regex: + + (?:\"(?:\\\"|(?!\").)*\"|\'(?:\\\'|(?!\').)*\') + +Note that the specified delimiters are automatically quotemeta'd. + +A typical use of C<gen_delimited_pat> would be to build special purpose tags +for C<extract_tagged>. For example, to properly ignore "empty" XML elements +(which might contain quoted strings): + + my $empty_tag = '<(' . gen_delimited_pat(q{'"}) . '|.)+/>'; + + extract_tagged($text, undef, undef, undef, {ignore => [$empty_tag]} ); + + +C<gen_delimited_pat> may also be called with an optional second argument, +which specifies the "escape" character(s) to be used for each delimiter. +For example to match a Pascal-style string (where ' is the delimiter +and '' is a literal ' within the string): + + gen_delimited_pat(q{'},q{'}); + +Different escape characters can be specified for different delimiters. +For example, to specify that '/' is the escape for single quotes +and '%' is the escape for double quotes: + + gen_delimited_pat(q{'"},q{/%}); + +If more delimiters than escape chars are specified, the last escape char +is used for the remaining delimiters. +If no escape char is specified for a given specified delimiter, '\' is used. + +Note that +C<gen_delimited_pat> was previously called +C<delimited_pat>. That name may still be used, but is now deprecated. + + +=head1 DIAGNOSTICS + +In a list context, all the functions return C<(undef,$original_text)> +on failure. In a scalar context, failure is indicated by returning C<undef> +(in this case the input text is not modified in any way). + +In addition, on failure in I<any> context, the C<$@> variable is set. +Accessing C<$@-E<gt>{error}> returns one of the error diagnostics listed +below. +Accessing C<$@-E<gt>{pos}> returns the offset into the original string at +which the error was detected (although not necessarily where it occurred!) +Printing C<$@> directly produces the error message, with the offset appended. +On success, the C<$@> variable is guaranteed to be C<undef>. + +The available diagnostics are: + +=over 4 + +=item C<Did not find a suitable bracket: "%s"> + +The delimiter provided to C<extract_bracketed> was not one of +C<'()[]E<lt>E<gt>{}'>. + +=item C<Did not find prefix: /%s/> + +A non-optional prefix was specified but wasn't found at the start of the text. + +=item C<Did not find opening bracket after prefix: "%s"> + +C<extract_bracketed> or C<extract_codeblock> was expecting a +particular kind of bracket at the start of the text, and didn't find it. + +=item C<No quotelike operator found after prefix: "%s"> + +C<extract_quotelike> didn't find one of the quotelike operators C<q>, +C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y> at the start of the substring +it was extracting. + +=item C<Unmatched closing bracket: "%c"> + +C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> encountered +a closing bracket where none was expected. + +=item C<Unmatched opening bracket(s): "%s"> + +C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> ran +out of characters in the text before closing one or more levels of nested +brackets. + +=item C<Unmatched embedded quote (%s)> + +C<extract_bracketed> attempted to match an embedded quoted substring, but +failed to find a closing quote to match it. + +=item C<Did not find closing delimiter to match '%s'> + +C<extract_quotelike> was unable to find a closing delimiter to match the +one that opened the quote-like operation. + +=item C<Mismatched closing bracket: expected "%c" but found "%s"> + +C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> found +a valid bracket delimiter, but it was the wrong species. This usually +indicates a nesting error, but may indicate incorrect quoting or escaping. + +=item C<No block delimiter found after quotelike "%s"> + +C<extract_quotelike> or C<extract_codeblock> found one of the +quotelike operators C<q>, C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y> +without a suitable block after it. + +=item C<Did not find leading dereferencer> + +C<extract_variable> was expecting one of '$', '@', or '%' at the start of +a variable, but didn't find any of them. + +=item C<Bad identifier after dereferencer> + +C<extract_variable> found a '$', '@', or '%' indicating a variable, but that +character was not followed by a legal Perl identifier. + +=item C<Did not find expected opening bracket at %s> + +C<extract_codeblock> failed to find any of the outermost opening brackets +that were specified. + +=item C<Improperly nested codeblock at %s> + +A nested code block was found that started with a delimiter that was specified +as being only to be used as an outermost bracket. + +=item C<Missing second block for quotelike "%s"> + +C<extract_codeblock> or C<extract_quotelike> found one of the +quotelike operators C<s>, C<tr> or C<y> followed by only one block. + +=item C<No match found for opening bracket> + +C<extract_codeblock> failed to find a closing bracket to match the outermost +opening bracket. + +=item C<Did not find opening tag: /%s/> + +C<extract_tagged> did not find a suitable opening tag (after any specified +prefix was removed). + +=item C<Unable to construct closing tag to match: /%s/> + +C<extract_tagged> matched the specified opening tag and tried to +modify the matched text to produce a matching closing tag (because +none was specified). It failed to generate the closing tag, almost +certainly because the opening tag did not start with a +bracket of some kind. + +=item C<Found invalid nested tag: %s> + +C<extract_tagged> found a nested tag that appeared in the "reject" list +(and the failure mode was not "MAX" or "PARA"). + +=item C<Found unbalanced nested tag: %s> + +C<extract_tagged> found a nested opening tag that was not matched by a +corresponding nested closing tag (and the failure mode was not "MAX" or "PARA"). + +=item C<Did not find closing tag> + +C<extract_tagged> reached the end of the text without finding a closing tag +to match the original opening tag (and the failure mode was not +"MAX" or "PARA"). + + + + +=back + + +=head1 AUTHOR + +Damian Conway (damian@conway.org) + + +=head1 BUGS AND IRRITATIONS + +There are undoubtedly serious bugs lurking somewhere in this code, if +only because parts of it give the impression of understanding a great deal +more about Perl than they really do. + +Bug reports and other feedback are most welcome. + + +=head1 COPYRIGHT + + Copyright (c) 1997-2001, Damian Conway. All Rights Reserved. + This module is free software. It may be used, redistributed + and/or modified under the same terms as Perl itself. |