pax_global_header00006660000000000000000000000064140271400020014500gustar00rootroot0000000000000052 comment=e70c19c020c7d5b066dccfff93639a137ce8de0b libtemplate-alloy-perl-1.022/000077500000000000000000000000001402714000200160645ustar00rootroot00000000000000libtemplate-alloy-perl-1.022/Changes000066400000000000000000000135071402714000200173650ustar00rootroot000000000000001.022 2021-03-22 * Cleanup 1.021 2021-03-22 * Clean use of use vars * Fix some older test issues * Fix plugin loading on some perls 1.020 2013-09-20 * Fix COMPILE_PERL with GLOBAL_CACHE compilation bug that was modifying the tree. * Fix caching bugs when GLOBAL_CACHE and COMPILE_PERL or COMPILE_JS are used in conjunction with each other. 1.019 2013-08-23 * Fix comment bug on perl 5.8 or older * Fix many pod typos that accumulated over the years 1.018 2013-08-22 * Final prep for release (1.017 never saw cpan) * RT #76570 - bugfix provided by onken@netcubed.de to fix encoding error or scalar ref templates. * RT #79641 - copy buggy behavior of Template::Toolkit in that we now allow for [% # comment %] all on one line (we previously supported [%# comment %]) * RT #69966 - allow for node_info to be a little safer, allow DUMP to also be more safe, allow block _filename to get passed along * Add real json methods * Fix warning when calling .html on undefined * Fix bug in HTE with ASSOCIATE pointed out by David Warring 1.017 2012-02-10 * Add necessary hooks to allow for COMPILE_JS (See Template::Alloy::JS) * Test suite cleanup * Add missing squote and dquote item vmethods * Fix bug in internal iterator 1.016 2011-01-26 * Add AUTO_FILTER configuration item to TT and HTE flavors. 1.015 2010-12-29 * Add missing Iterator features odd, even, parity * Add .xml vmethod/filter * Change .html method to not encode apostrophe - that is what .xml is for (thanks to Ashley Pond V) * Add STRICT and STRICT_THROW configuration items including code, tests, and documentation * Add tt_var_string method and document ast_string method. * Fix pod errors reported by Frank Wiegand in VMethod.pm * Update test suite to not test stringification of perl regex (thanks to ANDK@cpan) * Fix path of file cache names on MSWin32 (thanks to BEROV@cpan) * Fix EXPOSE_BLOCKS to follow TT 2.22 behavior * Add tests to cover block use from included/processed blocks 1.014 2010-03-31 * Fix localization issue in set 1.013 2008-09-18 * Make PLUGIN_BASE work like TT (always falls back to Template::Plugins) * Make case searching for PLUGINS work like TT (only those listed in PLUGINS or STD_PLUGINS apply. * Test all input and output methods (fix accompanying errors) * Fix local pos warning. * Fix Template::Alloy::Iterator to follow exact TT iterator behavior during new 1.012 2008-04-10 * Allow scalar refs passed as variables to be processed * Allow ADD_LOCAL_PATH to function in more areas (including INSERT) * Don't let ADD_LOCAL_PATH modify INCLUDE_PATHS * Let ADD_LOCAL_PATH be modified at runtime * Stream cleanup * Added CALL_CONTEXT configuration item * Added @() list context specifier * Added $() item context specifier * Cleanup some of the pod on vmethods. * Add the ITEM_METHOD API which is hybrid SCALAR_OPS and filters * Add the ->() MACRO operator * Allow map, grep, and sort to use the new operator * Add return values to RETURN directive * Add return item, list, and hash vmethods 1.011 2007-12-10 * Boneheaded release bug - add Stream.pm to manifest 1.010 2007-12-10 * Add missing ||= operator (we already had //=) * Cleanup some POD * Add STREAM support for printing out the template as it is generated. * Fix CASE_SENSITIVE on HT 1.009 2007-11-07 * Add ADD_LOCAL_PATH configuration item * Try to cleanup some failing tests on other platforms - particularly with Andy's view tests * Resample benchmarks to allow for updates to HTML::Template::Compiled 1.008 2007-10-26 * Fix split_paths to work with objects * Make 5.6 a requirement * Add patches for ENCODING (thanks to Carl Franks) * Fix broken tests on low perl version 1.007 2007-10-04 * Patch to bench_various_templaters.pl to fix HTC_file test (Tina Müller via RT) * Update coverage tests * Allow relative to get/set better when calling parse_file in Tmpl.pm * Fix DUMP directive to show keys when QR_PRIVATE is set to false. * Fix HTE mode to handle which is the same as (undocumented HT feature) 1.006 2007-07-03 * Fix parsing errors in HTE syntax with foo 1.005 2007-06-28 * Update evaluation order of files and arguments to PROCESS and INCLUDE 1.004 2007-06-20 * Fix braindead bug in COMPILE_DIR * Fix many caching bugs particularly with string refs * Add GLOBAL_CACHE support * Add 02_cache.t 1.003 2007-06-20 * Fix several issues with the HTE role * Add a few more tests 1.002 2007-06-12 * Documentation fixes * Allow for some easier subclassing 1.002 2007-06-08 * Fix initial release blues * Add support for overriding other classes * Document roles a little better. * Allow for STASH to be passed - even though we won't use its methods. * Make sure compile_RAWPERL works * Allow methods without entries in the Compile::DIRECTIVES table to defer to Play::DIRECTIVES table. 1.001 2007-06-07 * Added strref cache support * Added compile_perl support. * Added support of Text::Tmpl style templates * Added support for Velocity style templates * More edge cases * More sample syntax 1.000 2007-05-25 * First from CGI::Ex::Template version 2.13 libtemplate-alloy-perl-1.022/MANIFEST000066400000000000000000000021151402714000200172140ustar00rootroot00000000000000Changes lib/Template/Alloy.pm lib/Template/Alloy.pod lib/Template/Alloy/Compile.pm lib/Template/Alloy/Context.pm lib/Template/Alloy/Exception.pm lib/Template/Alloy/HTE.pm lib/Template/Alloy/Iterator.pm lib/Template/Alloy/Operator.pm lib/Template/Alloy/Parse.pm lib/Template/Alloy/Play.pm lib/Template/Alloy/Stream.pm lib/Template/Alloy/Tmpl.pm lib/Template/Alloy/TT.pm lib/Template/Alloy/Velocity.pm lib/Template/Alloy/VMethod.pm Makefile.PL MANIFEST MANIFEST.SKIP README samples/benchmark/bench_method_calling.pl samples/benchmark/bench_operator_storage.pl samples/benchmark/bench_optree.pl samples/benchmark/bench_template.pl samples/benchmark/bench_template_tag_parser.pl samples/benchmark/bench_various_templaters.pl samples/dprof_template.d samples/memory_template.pl t/00_use.t t/01_coverage.t t/02_cache.t t/05_tt_base.t t/10_tt_includes.t t/11_tt_input_output.t t/15_tt_view.t t/20_html_template.t t/25_text_tmp.t t/30_velocity.t META.yml Module meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) libtemplate-alloy-perl-1.022/MANIFEST.SKIP000066400000000000000000000002161402714000200177610ustar00rootroot00000000000000CVS/ ^tgz/ \.~$ \.# \w#$ \.bak$ Makefile$ Makefile\.old$ blib \.gz$ .cvsignore tmon\.out WrapEx.pm bench_various_templaters.pl.out ^cover_db/ libtemplate-alloy-perl-1.022/META.json000066400000000000000000000016401402714000200175060ustar00rootroot00000000000000{ "abstract" : "TT2/3, HT, HTE, Tmpl, and Velocity Engine", "author" : [ "Paul Seamons" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Template-Alloy", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Digest::MD5" : "1" } } }, "release_status" : "stable", "version" : "1.022", "x_serialization_backend" : "JSON::PP version 4.02" } libtemplate-alloy-perl-1.022/META.yml000066400000000000000000000010541402714000200173350ustar00rootroot00000000000000--- abstract: 'TT2/3, HT, HTE, Tmpl, and Velocity Engine' author: - 'Paul Seamons' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Template-Alloy no_index: directory: - t - inc requires: Digest::MD5: '1' version: '1.022' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' libtemplate-alloy-perl-1.022/Makefile.PL000066400000000000000000000023371402714000200200430ustar00rootroot00000000000000use 5.006; use ExtUtils::MakeMaker; ###----------------------------------------------------------------### # Copyright 2007-2011 - Paul Seamons # # Distributed under the GNU General Public License without warranty # ###----------------------------------------------------------------### WriteMakefile( NAME => "Template::Alloy", AUTHOR => "Paul Seamons", ABSTRACT_FROM => "lib/Template/Alloy.pod", VERSION_FROM => "lib/Template/Alloy.pm", INSTALLDIRS => 'site', PREREQ_PM => { 'Digest::MD5' => 1, }, dist => { DIST_DEFAULT => 'all tardist', COMPRESS => 'gzip -vf', SUFFIX => '.gz', }, clean => { FILES => '*~', }, realclean => { FILES => '*~', }, ); package MY; sub postamble { return qq^ pm_to_blib: README README: lib/Template/Alloy.pod pod2text lib/Template/Alloy.pod > README ^; } 1; libtemplate-alloy-perl-1.022/README000066400000000000000000003343421402714000200167550ustar00rootroot00000000000000NAME Template::Alloy - TT2/3, HT, HTE, Tmpl, and Velocity Engine SYNOPSIS Template::Toolkit style usage my $t = Template::Alloy->new( INCLUDE_PATH => ['/path/to/templates'], ); my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; # print to STDOUT $t->process('my/template.tt', $swap) || die $t->error; # process into a variable my $out = ''; $t->process('my/template.tt', $swap, \$out); ### Alloy uses the same syntax and configuration as Template::Toolkit HTML::Template::Expr style usage my $t = Template::Alloy->new( filename => 'my/template.ht', path => ['/path/to/templates'], ); my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; $t->param($swap); # print to STDOUT (errors die) $t->output(print_to => \*STDOUT); # process into a variable my $out = $t->output; ### Alloy can also use the same syntax and configuration as HTML::Template Text::Tmpl style usage my $t = Template::Alloy->new; my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; $t->set_delimiters('#[', ']#'); $t->set_strip(0); $t->set_values($swap); $t->set_dir('/path/to/templates'); my $out = $t->parse_file('my/template.tmpl'); my $str = "Foo #[echo $key1]# Bar"; my $out = $t->parse_string($str); ### Alloy uses the same syntax and configuration as Text::Tmpl Velocity (VTL) style usage my $t = Template::Alloy->new; my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; my $out = $t->merge('my/template.vtl', $swap); my $str = "#set($foo 1 + 3) ($foo) ($bar) ($!baz)"; my $out = $t->merge(\$str, $swap); Javascript style usage (requires Template::Alloy::JS) my $t = Template::Alloy->new; my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; my $out = ''; $t->process_js('my/template.jstem', $swap, \$out); my $str = "[% var foo = 1 + 3; write('(' + foo + ') (' + get('key1') + ')'); %]"; my $out = ''; $t->process_js(\$str, $swap, \$out); DESCRIPTION "An alloy is a homogeneous mixture of two or more elements" (http://en.wikipedia.org/wiki/Alloy). Template::Alloy represents the mixing of features and capabilities from all of the major mini-language based template systems (support for non-mini-language based systems will happen eventually). With Template::Alloy you can use your favorite template interface and syntax and get features from each of the other major template systems. And Template::Alloy is fast - whether your using mod_perl, CGI, or running from the commandline. There is even Template::Alloy::JS for getting a little more speed when that is necessary. Template::Alloy happened by accident (accidentally on purpose). The Template::Alloy (Alloy hereafter) was originally a part of the CGI::Ex suite that performed simple variable interpolation. It used TT2 style variables in TT2 style tags "[% foo.bar %]". That was all the original Template::Alloy did. This was fine and dandy for a couple of years. In winter of 2005-2006 Alloy was revamped to add a few features. One thing led to another and soon Alloy provided for most of the features of TT2 as well as some from TT3. Template::Alloy now provides a full-featured implementation of the Template::Toolkit language. After a move to a new company that was using HTML::Template::Expr and Text::Tmpl templates, support was investigated and interfaces for HTML::Template, HTML::Template::Expr, Text::Tmpl, and Velocity (VTL) were added. All of the various engines offer the same features - each using a different syntax and interface. More recently, the Template::Alloy::JS capabilities were introduced to bring Javascript templates to the server side (along with an increase in speed if ran in persistent environments). Template::Toolkit brought the most to the table. HTML::Template brought the LOOP directive. HTML::Template::Expr brought more vmethods and using vmethods as top level functions. Text::Tmpl brought the COMMENT directive and encouraged speed matching (Text::Tmpl is almost entirely C based and is very fast). The Velocity engine brought AUTO_EVAL and SHOW_UNDEFINED_INTERP. Most of the standard Template::Toolkit documentation covering directives, variables, configuration, plugins, filters, syntax, and vmethods should apply to Alloy just fine (This pod tries to explain everything - but there is too much). See Template::Alloy::TT for a listing of the differences between Alloy and TT. Most of the standard HTML::Template and HTML::Template::Expr documentation covering methods, variables, expressions, and syntax will apply to Alloy just fine as well. Most of the standard Text::Tmpl documentation applies, as does the documentation covering Velocity (VTL). So should you use Template::Alloy ? Well, try it out. It may give you no visible improvement. Or it could. BACKEND Template::Alloy uses a recursive regex based grammar (early versions during the CGI::Ex::Template phase did not). This allows for the embedding of opening and closing tags inside other tags (as in [% a = "[% 1 + 2 %]" ; a|eval %]). The individual methods such as parse_expr and play_expr may be used by external applications to add TT style variable parsing to other applications. The regex parser returns an AST (abstract syntax tree) of the text, directives, variables, and expressions. All of the different template syntax options compile to the same AST format. The AST is composed only of scalars and arrayrefs and is suitable for sending to JavaScript via JSON or sharing with other languages. The parse_tree method is used for returning this AST. Once at the AST stage, there are two modes of operation. Alloy can either operate directly on the AST using the Play role, or it can compile the AST to perl code via the Compile role, and then execute the code. To use the perl code route, you must set the COMPILE_PERL flag to 1. If you are running in a cached-in-memory environment such as mod_perl, this is the fastest option. If you are running in a non-cached-in-memory environment, then using the Play role to run the AST is generally faster. The AST method is also more secure as cached AST won't ever eval any "perl" (assuming PERL blocks are disabled - which is the default). ROLES Template::Alloy has split out its functionality into discrete roles. In Template::Toolkit, this functionality is split into separate classes. The roles in Template::Alloy simply add on more methods to the main class. When Perl 6 arrives, these roles will be translated into true Roles. The following is a list of roles used by Template::Alloy. Template::Alloy::Compile - Compile-to-perl role Template::Alloy::HTE - HTML::Template::Expr role Template::Alloy::Operator - Operator role Template::Alloy::Parse - Parse-to-AST role Template::Alloy::Play - Play-AST role Template::Alloy::Stream - Stream output role Template::Alloy::Tmpl - Text::Tmpl role Template::Alloy::TT - Template::Toolkit role Template::Alloy::Velocity - Velocity role Template::Alloy::VMethod - Virtual methods role Template::Alloy::JS - Javascript functionality - available separately Template::Alloy automatically loads the roles when they are needed or requested - but not sooner (with the exception of the Operator role and the VMethod role which are always needed and always loaded). This is good for a CGI environment. In mod_perl you may want to preload a role to make the most of shared memory. You may do this by passing either the role name or a method supplied by that role. # import roles necessary for running TT use Template::Alloy qw(Parse Play Compile TT); # import roles based on methods use Template::Alloy qw(parse_tree play_tree compile_tree process); Note: importing roles by method names does not import them into that namespace - it is autoloading the role and methods into the Template::Alloy namespace. To help make this more clear you may use the following syntax as well. # import roles necessary for running TT use Template::Alloy load => qw(Parse Play Compile TT); # import roles based on methods use Template::Alloy load => qw(process parse_tree play_tree compile_tree); # import roles based on methods use Template::Alloy Parse => 1, Play => 1, Compile => 1, TT => 1; Even with all roles loaded Template::Alloy is still relatively small. You can load all of the roles (except the JS role) by passing "all" to the use statement. use Template::Alloy 'all'; # or use Template::Alloy load => 'all'; # or use Template::Alloy all => 1; As a final option, Template::Alloy also includes the ability to stand-in for other template modules. It is able to do this because it supports the majority of the interface of the other template systems. You can do this in the following way: use Template::Alloy qw(Text::Tmpl HTML::Template); # or use Template::Alloy load => qw(Text::Tmpl HTML::Template); # or use Template::Alloy 'Text::Tmpl' => 1, 'HTML::Template' => 1; Note that the use statement will die if any of the passed module names are already loaded and not subclasses of Template::Alloy. This will avoid thinking that you are using Template::Alloy when you really aren't. Using the 'all' option won't automatically do this - you must mention the "stood-in" modules by name. The following modules may be "stood-in" for: Template Text::Tmpl HTML::Template HTML::Template::Expr This feature is intended to make using Template::Alloy with existing code easier. Most cases should work just fine. Almost all syntax will just work (except Alloy may make some things work that were previously broken). However Template::Alloy doesn't support 100% of the interface of any of the template systems. If you are using "features-on-the-edge" then you may need to re-write portions of your code that interact with the template system. PUBLIC METHODS The following section lists most of the publicly available methods. Some less commonly used public methods are listed later in this document. "new" my $obj = Template::Alloy->new({ INCLUDE_PATH => ['/my/path/to/content', '/my/path/to/content2'], }); Arguments may be passed as a hash or as a hashref. Returns a Template::Alloy object. There are currently no errors during Template::Alloy object creation. If you are using the HTML::Template interface, this is different behavior. The document is not parsed until the output or process methods are called. "process" This is the TT interface for starting processing. Any errors that result in the template processing being stopped will be stored and available via the ->error method. my $t = Template::Alloy->new; $t->process($in, $swap, $out) || die $t->error; Process takes three arguments. The $in argument can be any one of: String containing the filename of the template to be processed. The filename should be relative to INCLUDE_PATH. (See INCLUDE_PATH, ABSOLUTE, and RELATIVE configuration items). In memory caching and file side caching are available for this type. A reference to a scalar containing the contents of the template to be processed. A coderef that will be called to return the contents of the template. An open filehandle that will return the contents of the template when read. The $swap argument should be hashref containing key value pairs that will be available to variables swapped into the template. Values can be hashrefs, hashrefs of hashrefs and so on, arrayrefs, arrayrefs of arrayrefs and so on, coderefs, objects, and simple scalar values such as numbers and strings. See the section on variables. The $out argument can be any one of: undef - meaning to print the completed template to STDOUT. String containing a filename. The completed template will be placed in the file. A reference to a string. The contents will be appended to the scalar reference. A coderef. The coderef will be called with the contents as a single argument. An object that can run the method "print". The contents will be passed as a single argument to print. An arrayref. The contents will be pushed onto the array. An open filehandle. The contents will be printed to the open handle. Additionally - the $out argument can be configured using the OUTPUT configuration item. The process method defaults to using the "cet" syntax which will parse TT3 and most TT2 documents. To parse HT or HTE documents, you must pass the SYNTAX configuration item to the "new" method. All calls to process would then default to HTE syntax. my $obj = Template::Alloy->new(SYNTAX => 'hte'); "process_simple" Similar to the process method but with the following restrictions: The $in parameter is limited to a filename or a reference a string containing the contents. The $out parameter may only be a reference to a scalar string that output will be appended to. Additionally, the following configuration variables will be ignored: VARIABLES, PRE_DEFINE, BLOCKS, PRE_PROCESS, PROCESS, POST_PROCESS, AUTO_RESET, OUTPUT. "error" Should something go wrong during a "process" command, the error that occurred can be retrieved via the error method. $obj->process('somefile.html', {a => 'b'}, \$string_ref) || die $obj->error; "output" HTML::Template way to process a template. The output method requires that a filename, filehandle, scalarref, or arrayref argument was passed to the new method. All of the HT calling conventions for new are supported. The key difference is that Alloy will not actually process the template until the output method is called. my $obj = Template::Alloy->new(filename => 'myfile.html'); $obj->param(\%swap); print $obj->output; See the HTML::Template documentation for more information. The output method defaults to using the "hte" syntax which will parse HTE and HT documents. To parse TT3 or TT2 documents, you must pass the SYNTAX configuration item to the "new" method. All calls to process would then default to TT3 syntax. my $obj = Template::Alloy->new(SYNTAX => 'tt3'); Any errors that occur during the output method will die with the error as the die value. "param" HTML::Template way to get or set variable values that will be used by the output method. my $val = $obj->param('key'); # get one value $obj->param(key => $val); # set one value $obj->param(key => $val, key2 => $val2); # set multiple $obj->param({key => $val, key2 => $val2}); # set multiple See the HTML::Template documentation for more information. Note: Alloy does not support the die_on_bad_params configuration. This is because Alloy does not resolve variable names until the output method is called. "define_vmethod" This method is available for defining extra Virtual methods or filters. This method is similar to Template::Stash::define_vmethod. Template::Alloy->define_vmethod( 'text', reverse => sub { my $item = shift; return scalar reverse $item }, ); "register_function" This is the HTML::Template way of defining text vmethods. It is the same as calling define_vmethod with "text" as the first argument. Template::Alloy->register_function( reverse => sub { my $item = shift; return scalar reverse $item }, ); "define_directive" This method can be used for adding new directives or overridding existing ones. Template::Alloy->define_directive( MYDIR => { parse_sub => sub {}, # parse additional items in the tag play_sub => sub { my ($self, $ref, $node, $out_ref) = @_; $$out_ref .= "I always say the same thing!"; return; }, is_block => 1, # is this block like is_postop => 0, # not a post operative directive no_interp => 1, # no interpolation in this block continues => undef, # it doesn't "continue" any other directives }, ); Now with a template like: my $str = "([% MYDIR %]This is something[% END %])"; Template::Alloy->new->process(\$str); You will get: (I always say the same thing!) We'll add more details in later revisions of this document. "define_syntax" This method can be used for adding another syntax to or overriding existing ones in the list of choices available in Alloy. The syntax can be chosen by the SYNTAX configuration item. Template::Alloy->define_syntax( my_uber_syntax => sub { my $self = shift; local $self->{'V2PIPE'} = 0; local $self->{'V2EQUALS'} = 0; local $self->{'PRE_CHOMP'} = 0; local $self->{'POST_CHOMP'} = 0; local $self->{'NO_INCLUDES'} = 0; return $self->parse_tree_tt3(@_); }, ); The subroutine that is used must return an opcode tree (AST) that can be played by the execute_tree method. "define_operator" This method allows for adding new operators or overriding existing ones. Template::Alloy->define_operator({ type => 'right', # can be one of prefix, postfix, right, left, none, ternary, assign precedence => 84, # relative precedence for resolving multiple operators without parens symbols => ['foo', 'FOO'], # any mix of chars can be used for the operators play_sub => sub { my ($one, $two) = @_; return "You've been foo'ed ($one, $two)"; }, }); You can then use it in a template as in the following: my $str = "[% 'ralph' foo 1 + 2 * 3 %]"; Template::Alloy->new->process(\$str); You will get: You've been foo'ed (ralph, 7) Future revisions of this document will include more samples. This is an experimental feature and the API will probably change. "dump_parse_tree" This method allows for returning a Data::Dumper dump of a parsed template. It is mainly used for testing. "dump_parse_expr" This method allows for returning a Data::Dumper dump of a parsed variable. It is mainly used for testing. "import" All of the arguments that can be passed to "use" that are listed above in the section dealing with ROLES, can be used with the import method. # import by role Template::Alloy->import(qw(Compile Play Parse TT)); # import by method Template::Alloy->import(qw(compile_tree play_tree parse_tree process)); # import by "stand-in" class Template::Alloy->import('Text::Tmpl', 'HTML::Template::Expr'); As mentioned in the ROLE section - arguments passed to import are not imported into current namespace. Roles and methods are only imported into the Template::Alloy namespace. VARIABLES This section discusses how to use variables and expressions in the TT mini-language. A variable is the most simple construct to insert into the TT mini language. A variable name will look for the matching value inside Template::Alloys internal stash of variables which is essentially a hash reference. This stash is initially populated by either passing a hashref as the second argument to the process method, or by setting the "VARIABLES" or "PRE_DEFINE" configuration variables. If you are using either the HT or the HTE syntax, the VAR, IF, UNLESS, LOOP, and INCLUDE directives will accept a NAME attribute which may only be a single level (non-chained) HTML::Template variable name, or they may accept an EXPR attribute which may be any valid TT3 variable or expression. The following are some sample ways to access variables. ### some sample variables my %vars = ( one => '1.0', foo => 'bar', vname => 'one', some_code => sub { "You passed me (".join(', ', @_).")" }, some_data => { a => 'A', bar => 3234, c => [3, 1, 4, 1, 5, 9], vname => 'one', }, my_list => [20 .. 50], cet => Template::Alloy->new, ); ### pass the variables into the Alloy process $cet->process($template_name, \%vars) || die $cet->error; ### pass the variables during object creation (will be available to every process call) my $cet = Template::Alloy->new(VARIABLES => \%vars); GETTING VARIABLES Once you have variables defined, they can be used directly in the template by using their name in the stash. Or by using the GET directive. [% foo %] [% one %] [% GET foo %] Would print when processed: bar 1.0 bar To access members of a hashref or an arrayref, you can chain together the names using a ".". [% some_data.a %] [% my_list.0] [% my_list.1 %] [% my_list.-1 %] [% some_data.c.2 %] Would print: A 20 21 50 4 If the value of a variable is a code reference, it will be called. You can add a set of parenthesis and arguments to pass arguments. Arguments are variables and can be as complex as necessary. [% some_code %] [% some_code() %] [% some_code(foo) %] [% some_code(one, 2, 3) %] Would print: You passed me (). You passed me (). You passed me (bar). You passed me (1.0, 2, 3). If the value of a variable is an object, methods can be called using the "." operator. [% cet %] [% cet.dump_parse_expr('1 + 2').replace('\s+', ' ') %] Would print something like: Template::Alloy=HASH(0x814dc28) $VAR1 = [ [ undef, '+', '1', '2' ], 0 ]; Each type of data (string, array and hash) have virtual methods associated with them. Virtual methods allow for access to functions that are commonly used on those types of data. For the full list of built in virtual methods, please see the section titled VIRTUAL METHODS [% foo.length %] [% my_list.size %] [% some_data.c.join(" | ") %] Would print: 3 31 3 | 1 | 4 | 5 | 9 It is also possible to "interpolate" variable names using a "$". This allows for storing the name of a variable inside another variable. If a variable name is a little more complex it can be embedded inside of "${" and "}". [% $vname %] [% ${vname} %] [% ${some_data.vname} %] [% some_data.$foo %] [% some_data.${foo} %] Would print: 1.0 1.0 1.0 3234 3234 In Alloy it is also possible to embed any expression (non-directive) in "${" and "}" and it is possible to use non-integers for array access. (This is not available in TT2) [% ['a'..'z'].${ 2.3 } %] [% {ab => 'AB'}.${ 'a' ~ 'b' } %] [% color = qw/Red Blue/; FOR [1..4] ; color.${ loop.index % color.size } ; END %] Would print: c AB RedBlueRedBlue SETTING VARIABLES. To define variables during processing, you can use the = operator. In most cases this is the same as using the SET directive. [% a = 234 %][% a %] [% SET b = "Hello" %][% b %] Would print: 234 Hello It is also possible to create arrayrefs and hashrefs. [% a = [1, 2, 3] %] [% b = {key1 => 'val1', 'key2' => 'val2'} %] [% a.1 %] [% b.key1 %] [% b.key2 %] Would print: 2 val1 val2 It is possible to set multiple values in the same SET directive. [% SET a = 'A' b = 'B' c = 'C' %] [% a %] [% b %] [% c %] Would print: A B C It is also possible to unset variables, or to set members of nested data structures. [% a = 1 %] [% SET a %] [% b.0.c = 37 %] ([% a %]) [% b.0.c %] Would print () 37 LITERALS AND CONSTRUCTORS The following are the types of literals (numbers and strings) and constructors (hash and array constructs) allowed in Alloy. They can be used as arguments to functions, in place of variables in directives, and in place of variables in expressions. In Alloy it is also possible to call virtual methods on literal values. Integers and Numbers. [% 23423 %] Prints an integer. [% 3.14159 %] Prints a number. [% pi = 3.14159 %] Sets the value of the variable. [% 3.13159.length %] Prints 7 (the string length of the number) Scientific notation is supported. [% 314159e-5 + 0 %] Prints 3.14159. [% .0000001.fmt('%.1e') %] Prints 1.0e-07 Hexadecimal input is also supported. [% 0xff + 0 %] Prints 255 [% 48875.fmt('%x') %] Prints beeb Single quoted strings. Returns the string. No variable interpolation happens. [% 'foobar' %] Prints "foobar". [% '$foo\n' %] Prints "$foo\\n". # the \\n is a literal "\" and an "n" [% 'That\'s nice' %] Prints "That's nice". [% str = 'A string' %] Sets the value of str. [% 'A string'.split %] Splits the string on ' ' and returns the list. Note: virtual methods can only be used on literal strings in Alloy, not in TT. You may also embed the current tags in strings (Alloy only). [% '[% 1 + 2 %]' | eval %] Prints "3" Double quoted strings. Returns the string. Variable interpolation happens. [% "foobar" %] Prints "foobar". [% "$foo" %] Prints "bar" (assuming the value of foo is bar). [% "${foo}" %] Prints "bar" (assuming the value of foo is bar). [% "foobar\n" %] Prints "foobar\n". # the \n is a newline. [% str = "Hello" %] Sets the value of str. [% "foo".replace('foo','bar') %] Prints "bar". Note: virtual methods can only be used on literal strings in Alloy, not in TT. You may also embed the current tags in strings (Alloy only). [% "[% 1 + 2 %]" | eval %] Prints "3" Array Constructs. [% [1, 2, 3] %] Prints something like ARRAY(0x8309e90). [% array1 = [1 .. 3] %] Sets the value of array1. [% array2 = [foo, 'a', []] %] Sets the value of array2. [% [4, 5, 6].size %] Prints 3. [% [7, 8, 9].reverse.0 %] Prints 9. Note: virtual methods can only be used on array contructs in Alloy, not in TT. Quoted Array Constructs. [% qw/1 2 3/ %] Prints something like ARRAY(0x8309e90). [% array1 = qw{Foo Bar Baz} %] Sets the value of array1. [% qw[4 5 6].size %] Prints 3. [% qw(Red Blue).reverse.0 %] Prints Blue. Note: this works in Alloy and is planned for TT3. Hash Constructs. [% {foo => 'bar'} %] Prints something like HASH(0x8305880) [% hash = {foo => 'bar', c => {}} %] Sets the value of hash. [% {a => 'A', b => 'B'}.size %] Prints 2. [% {'a' => 'A', 'b' => 'B'}.size %] Prints 2. [% name = "Tom" %] [% {Tom => 'You are Tom', Kay => 'You are Kay'}.$name %] Prints You are Tom Note: virtual methods can only be used on hash contructs in Alloy, not in TT. Regex Constructs. [% /foo/ %] Prints (?-xism:foo) [% a = /(foo)/i %][% "FOO".match(a).0 %] Prints FOO Note: this works in Alloy and is planned for TT3. VIRTUAL METHODS Virtual methods (vmethods) are a TT feature that allow for operating on the swapped template variables. This document shows some samples of using vmethods. For a full listing of available virtual methods, see Template::Alloy::VMethod. EXPRESSIONS Expressions are one or more variables or literals joined together with operators. An expression can be used anywhere a variable can be used with the exception of the variable name in the SET directive, and the filename of PROCESS, INCLUDE, WRAPPER, and INSERT. For a full listing of operators, see Template::Alloy::Operator. The following section shows some samples of expressions. For a full list of available operators, please see the section titled OPERATORS. [% 1 + 2 %] Prints 3 [% 1 + 2 * 3 %] Prints 7 [% (1 + 2) * 3 %] Prints 9 [% x = 2 %] # assignments don't return anything [% (x = 2) %] Prints 2 # unless they are in parens [% y = 3 %] [% x * (y - 1) %] Prints 4 DIRECTIVES This section contains the alphabetical list of DIRECTIVES available in Alloy. DIRECTIVES are the "functions" and control structures that work in the various mini-languages. For further discussion and examples beyond what is listed below, please refer to the TT directives documentation or to the appropriate documentation for the particular directive. The examples given in this section are done using the Template::Toolkit syntax, but can be done in any of the various syntax options. See Template::Alloy::TT, Template::Alloy::HTE, Template::Alloy::Tmpl, and Template::Alloy::Velocity. [% IF 1 %]One[% END %] [% FOREACH a = [1 .. 3] %] a = [% a %] [% END %] [% SET a = 1 %][% SET a = 2 %][% GET a %] In TT multiple directives can be inside the same set of '[%' and '%]' tags as long as they are separated by space or semi-colons (;) (The Alloy version of Tmpl allows multiple also - but none of the other syntax options do). Any block directive that can also be used as a post-operative directive (such as IF, WHILE, FOREACH, UNLESS, FILTER, and WRAPPER) must be separated from preceding directives with a semi-colon if it is being used as a block directive. It is more safe to always use a semi-colon. Note: separating by space is only available in Alloy but is a planned TT3 feature. [% SET a = 1 ; SET a = 2 ; GET a %] [% SET a = 1 SET a = 2 GET a %] [% GET 1 IF 0 # is a post-operative GET 2 %] # prints 2 [% GET 1; IF 0 # it is block based GET 2 END %] # prints 1 The following is the list of directives. "BLOCK" Saves a block of text under a name for later use in PROCESS, INCLUDE, and WRAPPER directives. Blocks may be placed anywhere within the template being processed including after where they are used. [% BLOCK foo %]Some text[% END %] [% PROCESS foo %] Would print Some text [% INCLUDE foo %] [% BLOCK foo %]Some text[% END %] Would print Some text Anonymous BLOCKS can be used for capturing. [% a = BLOCK %]Some text[% END %][% a %] Would print Some text Anonymous BLOCKS can be used with macros. "BREAK" Alias for LAST. Used for exiting FOREACH and WHILE loops. "CALL" Calls the variable (and any underlying coderefs) as in the GET method, but always returns an empty string. "CASE" Used with the SWITCH directive. See the "SWITCH" directive. "CATCH" Used with the TRY directive. See the "TRY" directive. "CLEAR" Clears any of the content currently generated in the innermost block or template. This can be useful when used in conjunction with the TRY statement to clear generated content if an error occurs later. "COMMENT" Will comment out any text found between open and close tags. Note, that the intermediate items are still parsed and END tags must align - but the parsed content will be discarded. [% COMMENT %] This text won't be shown. [% IF 1 %]And this won't either.[% END %] [% END %] "CONFIG" Allow for changing the value of some compile time and runtime configuration options. [% CONFIG ANYCASE => 1 PRE_CHOMP => '-' %] The following compile time configuration options may be set: ANYCASE AUTO_EVAL AUTO_FILTER CACHE_STR_REFS ENCODING INTERPOLATE POST_CHOMP PRE_CHOMP SEMICOLONS SHOW_UNDEFINED_INTERP SYNTAX V1DOLLAR V2EQUALS V2PIPE The following runtime configuration options may be set: ADD_LOCAL_PATH CALL_CONTEXT DUMP VMETHOD_FUNCTIONS STRICT (can only be enabled, cannot be disabled) If non-named parameters as passed, they will show the current configuration: [% CONFIG ANYCASE, PRE_CHOMP %] CONFIG ANYCASE = undef CONFIG PRE_CHOMP = undef "DEBUG" Used to reset the DEBUG_FORMAT configuration variable, or to turn DEBUG statements on or off. This only has effect if the DEBUG_DIRS or DEBUG_ALL flags were passed to the DEBUG configuration variable. [% DEBUG format '($file) (line $line) ($text)' %] [% DEBUG on %] [% DEBUG off %] "DEFAULT" Similar to SET, but only sets the value if a previous value was not defined or was zero length. [% DEFAULT foo = 'bar' %][% foo %] => 'bar' [% foo = 'baz' %][% DEFAULT foo = 'bar' %][% foo %] => 'baz' "DUMP" DUMP inserts a Data::Dumper printout of the variable or expression. If no argument is passed it will dump the entire contents of the current variable stash (with private keys removed). The output also includes the current file and line number that the DUMP directive was called from. See the DUMP configuration item for ways to customize and control the output available to the DUMP directive. [% DUMP %] # dumps everything [% DUMP 1 + 2 %] "ELSE" Used with the IF directive. See the "IF" directive. "ELSIF" Used with the IF directive. See the "IF" directive. "END" Used to end a block directive. "EVAL" Same as the EVALUATE directive. "EVALUATE" Introduced by the Velocity templating language. Parses and processes the contents of the passed item. This is similar to the eval filter, but Velocity needs a directive. Named arguments may be used for re-configuring the parser. Any of the items that can be passed to the CONFIG directive may be passed here. [% EVALUATE "[% 1 + 3 %]" %] [% foo = "bar" %] [% EVALUATE "" SYNTAX => 'ht' %] "FILTER" Used to apply different treatments to blocks of text. It may operate as a BLOCK directive or as a post operative directive. Alloy supports all of the filters in Template::Filters. The lines between scalar virtual methods and filters is blurred (or non-existent) in Alloy. Anything that is a scalar virtual method may be used as a FILTER. TODO - enumerate the at least 7 ways to pass and use filters. '|' Alias for the FILTER directive. Note that | is similar to the '.' in Template::Alloy. Therefore a pipe cannot be used directly after a variable name in some situations (the pipe will act only on that variable). This is the behavior employed by TT3. To get the TT2 behavior for a PIPE, use the V2PIPE configuration item. "FINAL" Used with the TRY directive. See the "TRY" directive. "FOR" Alias for FOREACH "FOREACH" Allows for iterating over the contents of any arrayref. If the variable is not an arrayref, it is automatically promoted to one. [% FOREACH i IN [1 .. 3] %] The variable i = [% i %] [%~ END %] [% a = [1 .. 3] %] [% FOREACH j IN a %] The variable j = [% j %] [%~ END %] Would print: The variable i = 1 The variable i = 2 The variable i = 3 The variable j = 1 The variable j = 2 The variable j = 3 You can also use the "=" instead of "IN" or "in". [% FOREACH i = [1 .. 3] %] The variable i = [% i %] [%~ END %] Same as before. Setting into a variable is optional. [% a = [1 .. 3] %] [% FOREACH a %] Hi [% END %] Would print: hi hi hi If the item being iterated is a hashref and the FOREACH does not set into a variable, then values of the hashref are copied into the variable stash. [% FOREACH [{a => 1}, {a => 2}] %] Key a = [% a %] [%~ END %] Would print: Key a = 1 Key a = 2 The FOREACH process uses the Template::Alloy::Iterator class to handle iterations (It is compatible with Template::Iterator). During the FOREACH loop an object blessed into the iterator class is stored in the variable "loop". The loop variable provides the following information during a FOREACH: index - the current index max - the max index of the list size - the number of items in the list count - index + 1 number - index + 1 first - true if on the first item last - true if on the last item next - return the next item in the list prev - return the previous item in the list odd - return 1 if the current count is odd, 0 otherwise even - return 1 if the current count is even, 0 otherwise parity - return "odd" if the current count is odd, "even" otherwise The following: [% FOREACH [1 .. 3] %] [% loop.count %]/[% loop.size %] [% END %] Would print: 1/3 2/3 3/3 The iterator is also available using a plugin. This allows for access to multiple "loop" variables in a nested FOREACH directive. [%~ USE outer_loop = Iterator(["a", "b"]) %] [%~ FOREACH i = outer_loop %] [%~ FOREACH j = ["X", "Y"] %] [% outer_loop.count %]-[% loop.count %] = ([% i %] and [% j %]) [%~ END %] [%~ END %] Would print: 1-1 = (a and X) 1-2 = (a and Y) 2-1 = (b and X) 2-2 = (b and Y) FOREACH may also be used as a post operative directive. [% "$i" FOREACH i = [1 .. 5] %] => 12345 "GET" Return the value of a variable or expression. [% GET a %] The GET keyword may be omitted. [% a %] [% 7 + 2 - 3 %] => 6 See the section on VARIABLES. "IF (IF / ELSIF / ELSE)" Allows for conditional testing. Expects an expression as its only argument. If the expression is true, the contents of its block are processed. If false, the processor looks for an ELSIF block. If an ELSIF's expression is true then it is processed. Finally it looks for an ELSE block which is processed if none of the IF or ELSIF's expressions were true. [% IF a == b %]A equaled B[% END %] [% IF a == b -%] A equaled B [%- ELSIF a == c -%] A equaled C [%- ELSE -%] Couldn't determine that A equaled anything. [%- END %] IF may also be used as a post operative directive. [% 'A equaled B' IF a == b %] Note: If you are using HTML::Template style documents, the TMPL_IF tag parses using the limited HTML::Template parsing rules. However, you may use EXPR="" to embed a TT3 style expression. "INCLUDE" Parse the contents of a file or block and insert them. Variables defined or modifications made to existing variables are discarded after a template is included. [% INCLUDE path/to/template.html %] [% INCLUDE "path/to/template.html" %] [% file = "path/to/template.html" %] [% INCLUDE $file %] [% BLOCK foo %]This is foo[% END %] [% INCLUDE foo %] Arguments may also be passed to the template: [% INCLUDE "path/to/template.html" a = "An arg" b = "Another arg" %] Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE or RELATIVE configuration items are set. Multiple filenames can be passed by separating them with a plus, a space, or commas (TT2 doesn't support the comma). Any supplied arguments will be used on all templates. [% INCLUDE "path/to/template.html", "path/to/template2.html" a = "An arg" b = "Another arg" %] On Perl 5.6 on some platforms there may be some issues with the variable localization. There is no problem on 5.8 and greater. "INSERT" Insert the contents of a file without template parsing. Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE or RELATIVE configuration items are set. Multiple filenames can be passed by separating them with a plus, a space, or commas (TT2 doesn't support the comma). [% INSERT "path/to/template.html", "path/to/template2.html" %] "JS" Only available if the COMPILE_JS configuration item is true (default is false). This requires the Template::Alloy::JS module to be installed. Allow eval'ing the block of text as javascript. The block will be parsed and then eval'ed. [% a = "BimBam" %] [%~ JS %] write('The variable a was "' + get('a') + '"'); set('b', "FooBar"); [% END %] [% b %] Would print: The variable a was "BimBam" FooBar "LAST" Used to exit out of a WHILE or FOREACH loop. "LOOP" This directive operates similar to the HTML::Template loop directive. The LOOP directive expects a single variable name. This variable name should point to an arrayref of hashrefs. The keys of each hashref will be added to the variable stash when it is iterated. [% var a = [{b => 1}, {b => 2}, {b => 3}] %] [% LOOP a %] ([% b %]) [% END %] Would print: (1) (2) (3) If Alloy is in HT mode and GLOBAL_VARS is false, the contents of the hashref will be the only items available during the loop iteration. If LOOP_CONTEXT_VARS is true, and $QR_PRIVATE is false (default when called through the output method), then the variables __first__, __last__, __inner__, __odd__, and __counter__ will be set. See the HTML::Template loop_context_vars configuration item for more information. "MACRO" Takes a directive and turns it into a variable that can take arguments. [% MACRO foo(i, j) BLOCK %]You passed me [% i %] and [% j %].[% END %] [%~ foo("a", "b") %] [% foo(1, 2) %] Would print: You passed me a and b. You passed me 1 and 2. Another example: [% MACRO bar(max) FOREACH i = [1 .. max] %]([% i %])[% END %] [%~ bar(4) %] Would print: (1)(2)(3)(4) Starting with version 1.012 of Template::Alloy there is also a macro operator. [% foo = ->(i,j){ "You passed me $i and $j" } %] [% bar = ->(max){ FOREACH i = [1 .. max]; i ; END } %] See the Template::Alloy::Operator documentation for more examples. "META" Used to define variables that will be available via either the template or component namespace. Once defined, they cannot be overwritten. [% template.foobar %] [%~ META foobar = 'baz' %] [%~ META foobar = 'bing' %] Would print: baz "NEXT" Used to go to the next iteration of a WHILE or FOREACH loop. "PERL" Only available if the EVAL_PERL configuration item is true (default is false). Allow eval'ing the block of text as perl. The block will be parsed and then eval'ed. [% a = "BimBam" %] [%~ PERL %] my $a = "[% a %]"; print "The variable \$a was \"$a\""; $stash->set('b', "FooBar"); [% END %] [% b %] Would print: The variable $a was "BimBam" FooBar During execution, anything printed to STDOUT will be inserted into the template. Also, the $stash and $context variables are set and are references to objects that mimic the interface provided by Template::Context and Template::Stash. These are provided for compatibility only. $self contains the current Template::Alloy object. "PROCESS" Parse the contents of a file or block and insert them. Unlike INCLUDE, no variable localization happens so variables defined or modifications made to existing variables remain after the template is processed. [% PROCESS path/to/template.html %] [% PROCESS "path/to/template.html" %] [% file = "path/to/template.html" %] [% PROCESS $file %] [% BLOCK foo %]This is foo[% END %] [% PROCESS foo %] Arguments may also be passed to the template: [% PROCESS "path/to/template.html" a = "An arg" b = "Another arg" %] Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE or RELATIVE configuration items are set. Multiple filenames can be passed by separating them with a plus, a space, or commas (TT2 doesn't support the comma). Any supplied arguments will be used on all templates. [% PROCESS "path/to/template.html", "path/to/template2.html" a = "An arg" b = "Another arg" %] "RAWPERL" Only available if the EVAL_PERL configuration item is true (default is false). Similar to the PERL directive, but you will need to append to the $output variable rather than just calling PRINT. "RETURN" Used to exit the innermost block or template and continue processing in the surrounding block or template. There are two changes from TT2 behavior. First, In Alloy, a RETURN during a MACRO call will only exit the MACRO. Second, the RETURN directive takes an optional variable name or expression, if passed, the MACRO will return this value instead of the normal text from the MACRO. The process_simple method will also return this value. You can also use the item, list, and hash return vmethods. [% RETURN %] # just exits [% RETURN "foo" %] # return value is foo [% "foo".return %] # same thing "SET" Used to set variables. [% SET a = 1 %][% a %] => "1" [% a = 1 %][% a %] => "1" [% b = 1 %][% SET a = b %][% a %] => "1" [% a = 1 %][% SET a %][% a %] => "" [% SET a = [1, 2, 3] %][% a.1 %] => "2" [% SET a = {b => 'c'} %][% a.b %] => "c" "STOP" Used to exit the entire process method (out of all blocks and templates). No content will be processed beyond this point. "SWITCH" Allow for SWITCH and CASE functionality. [% a = "hi" %] [% b = "bar" %] [% SWITCH a %] [% CASE "foo" %]a was foo [% CASE b %]a was bar [% CASE ["hi", "hello"] %]You said hi or hello [% CASE DEFAULT %]I don't know what you said [% END %] Would print: You said hi or hello "TAGS" Change the type of enclosing braces used to delineate template tags. This remains in effect until the end of the enclosing block or template or until the next TAGS directive. Either a named set of tags must be supplied, or two tags themselves must be supplied. [% TAGS html %] [% TAGS %] The named tags are (duplicated from TT): asp => ['<%', '%>' ], # ASP default => ['\[%', '%\]' ], # default html => ['' ], # HTML comments mason => ['<%', '>' ], # HTML::Mason metatext => ['%%', '%%' ], # Text::MetaText php => ['<\?', '\?>' ], # PHP star => ['\[\*', '\*\]' ], # TT alternate template => ['\[%', '%\]' ], # Normal Template Toolkit template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style tt2 => ['\[%', '%\]' ], # TT2 If custom tags are supplied, by default they are escaped using quotemeta. You may also pass explicitly quoted strings, or regular expressions as arguments as well (if your regex begins with a ', ", or / you must quote it. [% TAGS [<] [>] %] matches "[<] tag [>]" [% TAGS '[<]' '[>]' %] matches "[<] tag [>]" [% TAGS "[<]" "[>]" %] matches "[<] tag [>]" [% TAGS /[<]/ /[>]/ %] matches "< tag >" [% TAGS ** ** %] matches "** tag **" [% TAGS /**/ /**/ %] Throws an exception. You should be sure that the start tag does not include grouping parens or INTERPOLATE will not function properly. "THROW" Allows for throwing an exception. If the exception is not caught via the TRY DIRECTIVE, the template will abort processing of the directive. [% THROW mytypes.sometime 'Something happened' arg1 => val1 %] See the TRY directive for examples of usage. "TRY" The TRY block directive will catch exceptions that are thrown while processing its block (It cannot catch parse errors unless they are in included files or evaltt'ed strings. The TRY block will then look for a CATCH block that will be processed. While it is being processed, the "error" variable will be set with the thrown exception as the value. After the TRY block - the FINAL block will be ran whether or not an error was thrown (unless a CATCH block throws an error). Note: Parse errors cannot be caught unless they are in an eval FILTER, or are in a separate template being INCLUDEd or PROCESSed. [% TRY %] Nothing bad happened. [% CATCH %] Caught the error. [% FINAL %] This section runs no matter what happens. [% END %] Would print: Nothing bad happened. This section runs no matter what happens. Another example: [% TRY %] [% THROW "Something happened" %] [% CATCH %] Error: [% error %] Error.type: [% error.type %] Error.info: [% error.info %] [% FINAL %] This section runs no matter what happens. [% END %] Would print: Error: undef error - Something happened Error.type: undef Error.info: Something happened This section runs no matter what happens. You can give the error a type and more information including named arguments. This information replaces the "info" property of the exception. [% TRY %] [% THROW foo.bar "Something happened" "grrrr" foo => 'bar' %] [% CATCH %] Error: [% error %] Error.type: [% error.type %] Error.info: [% error.info %] Error.info.0: [% error.info.0 %] Error.info.1: [% error.info.1 %] Error.info.args.0: [% error.info.args.0 %] Error.info.foo: [% error.info.foo %] [% END %] Would print something like: Error: foo.bar error - HASH(0x82a395c) Error.type: foo.bar Error.info: HASH(0x82a395c) Error.info.0: Something happened Error.info.1: grrrr Error.info.args.0: Something happened Error.info.foo: bar You can also give the CATCH block a type to catch. And you can nest TRY blocks. If types are specified, Alloy will try and find the closest matching type. Also, an error object can be re-thrown using $error as the argument to THROW. [% TRY %] [% TRY %] [% THROW foo.bar "Something happened" %] [% CATCH bar %] Caught bar. [% CATCH DEFAULT %] Caught default - but re-threw. [% THROW $error %] [% END %] [% CATCH foo %] Caught foo. [% CATCH foo.bar %] Caught foo.bar. [% CATCH %] Caught anything else. [% END %] Would print: Caught default - but re-threw. Caught foo.bar. "UNLESS" Same as IF but condition is negated. [% UNLESS 0 %]hi[% END %] => hi Can also be a post operative directive. "USE" Allows for loading a Template::Toolkit style plugin. [% USE iter = Iterator(['foo', 'bar']) %] [%~ iter.get_first %] [% iter.size %] Would print: foo 2 Note that it is possible to send arguments to the new object constructor. It is also possible to omit the variable name being assigned. In that case the name of the plugin becomes the variable. [% USE Iterator(['foo', 'bar', 'baz']) %] [%~ Iterator.get_first %] [% Iterator.size %] Would print: foo 3 Plugins that are loaded are looked up for in the namespace listed in the PLUGIN_BASE directive which defaults to Template::Plugin. So in the previous example, if Template::Toolkit was installed, the iter object would loaded by the class Template::Plugin::Iterator. In Alloy, an effective way to disable plugins is to set the PLUGIN_BASE to a non-existent base such as "_" (In TT it will still fall back to look in Template::Plugin). Note: The iterator plugin will fall back and use Template::Alloy::Iterator if Template::Toolkit is not installed. No other plugins come installed with Template::Alloy. The names of the Plugin being loaded from PLUGIN_BASE are case insensitive. However, using case insensitive names is bad as it requires scanning the @INC directories for any module matching the PLUGIN_BASE and caching the result (OK - not that bad). If the plugin is not found and the LOAD_PERL directive is set, then Alloy will try and load a module by that name (note: this type of lookup is case sensitive and will not scan the @INC dirs for a matching file). # The LOAD_PERL directive should be set to 1 [% USE ta = Template::Alloy %] [%~ ta.dump_parse_expr('2 * 3') %] Would print: [[undef, '*', 2, 3], 0]; See the PLUGIN_BASE, and PLUGINS configuration items. See the documentation for Template::Manual::Plugins. "VIEW" Implement a TT style view. For more information, please see the Template::View documentation. This DIRECTIVE will correctly parse the arguments and then pass them along to a newly created Template::View object. It will fail if Template::View can not be found. "WHILE" Will process a block of code while a condition is true. [% WHILE i < 3 %] [%~ i = i + 1 %] i = [% i %] [%~ END %] Would print: i = 1 i = 2 i = 3 You could also do: [% i = 4 %] [% WHILE (i = i - 1) %] i = [% i %] [%~ END %] Would print: i = 3 i = 2 i = 1 Note that (f = f - 1) is a valid expression that returns the value of the assignment. The parenthesis are not optional. WHILE has a built in limit of 1000 iterations. This is controlled by the global variable $WHILE_MAX in Template::Alloy. WHILE may also be used as a post operative directive. [% "$i" WHILE (i = i + 1) < 7 %] => 123456 "WRAPPER" Block directive. Processes contents of its block and then passes them in the [% content %] variable to the block or filename listed in the WRAPPER tag. [% WRAPPER foo b = 23 %] My content to be processed ([% b %]).[% a = 2 %] [% END %] [% BLOCK foo %] A header ([% a %]). [% content %] A footer ([% a %]). [% END %] This would print. A header (2). My content to be processed (23). A footer (2). The WRAPPER directive may also be used as a post operative directive. [% BLOCK baz %]([% content %])[% END -%] [% "foobar" WRAPPER baz %] Would print (foobar)'); Multiple filenames can be passed by separating them with a plus, a space, or commas (TT2 doesn't support the comma). Any supplied arguments will be used on all templates. Wrappers are processed in reverse order, so that the first wrapper listed will surround each subsequent wrapper listed. Variables from inner wrappers are available to the next wrapper that surrounds it. [% WRAPPER "path/to/outer.html", "path/to/inner.html" a = "An arg" b = "Another arg" %] DIRECTIVES (HTML::Template Style) HTML::Template templates use directives that look similar to the following: BAR The normal set of HTML::Template directives are TMPL_VAR, TMPL_IF, TMPL_ELSE, TMPL_UNLESS, TMPL_INCLUDE, and TMPL_LOOP. These tags should have either a NAME attribute, an EXPR attribute, or a bare variable name that is used to specify the value to be operated. If a NAME is specified, it may only be a single level value (as opposed to a TT chained variable). In the case of the TMPL_INCLUDE directive, the NAME is the file to be included. In Alloy, the EXPR attribute can be used with any of these types to specify TT compatible variable or expression that will be used for the value. Prints the value contained in foo Prints the value contained in foo Prints the value contained in foo Prints the value contained in {'foo.bar.baz'} Prints the value contained in {foo}->{bar}->{baz} Prints FOO if foo is true FOO Prints FOO unless foo is true FOO Includes the template in "foo.ht" Iterates on the arrayref foo Template::Alloy makes all of the other TT3 directives available in addition to the normal set of HTML::Template directives. For example, the following is valid in Alloy. You said The TMPL_VAR tag may also include an optional ESCAPE attribute. This specifies how the value of the tag should be escaped prior to substituting into the template. Escape value | Type of escape --------------------------------- HTML, 1 | HTML encoding URL | URL encoding JS | basic javascript encoding (\n, \r, and \") NONE, 0 | No encoding (default). The TMPL_VAR tag may also include an optional DEFAULT attribute that contains a string that will be used if the variable returns false. CHOMPING Chomping refers to the handling of whitespace immediately before and immediately after template tags. By default, nothing happens to this whitespace. Modifiers can be placed just inside the opening and just before the closing tags to control this behavior. Additionally, the PRE_CHOMP and POST_CHOMP configuration variables can be set and will globally control all chomping behavior for tags that do not have their own chomp modifier. PRE_CHOMP and POST_CHOMP can be set to any of the following values: none: 0 + Template::Constants::CHOMP_NONE one: 1 - Template::Constants::CHOMP_ONE collapse: 2 = Template::Constants::CHOMP_COLLAPSE greedy: 3 ~ Template::Constants::CHOMP_GREEDY CHOMP_NONE Don't do any chomping. The "+" sign is used to indicate CHOMP_NONE. Hello. [%+ "Hi." +%] Howdy. Would print: Hello. Hi. Howdy. CHOMP_ONE (formerly known as CHOMP_ALL) Delete any whitespace up to the adjacent newline. The "-" is used to indicate CHOMP_ONE. Hello. [%- "Hi." -%] Howdy. Would print: Hello. Hi. Howdy. CHOMP_COLLAPSE Collapse adjacent whitespace to a single space. The "=" is used to indicate CHOMP_COLLAPSE. Hello. [%= "Hi." =%] Howdy. Would print: Hello. Hi. Howdy. CHOMP_GREEDY Remove all adjacent whitespace. The "~" is used to indicate CHOMP_GREEDY. Hello. [%~ "Hi." ~%] Howdy. Would print: Hello.Hi.Howdy. CONFIGURATION The following configuration variables are supported (in alphabetical order). Note: for further discussion you can refer to the TT config documentation. Items may be passed in upper or lower case. If lower case names are passed they will be resolved to uppercase during the "new" method. All of the variables in this section can be passed to the "new" constructor. my $obj = Template::Alloy->new( VARIABLES => \%hash_of_variables, AUTO_RESET => 0, TRIM => 1, POST_CHOMP => "=", PRE_CHOMP => "-", ); ABSOLUTE Boolean. Default false. Are absolute paths allowed for included files. ADD_LOCAL_PATH If true, allows calls include_filename to temporarily add the directory of the current template being processed to the INCLUDE_PATHS arrayref. This allows templates to refer to files in the local template directory without specifying the local directory as part of the filename. Default is 0. If set to a negative value, the current directory will be added to the end of the current INCLUDE_PATHS. This property may also be set in the template using the CONFIG directive. [% CONFIG ADD_LOCAL_PATH => 1 %] ANYCASE Allow directive matching to be case insensitive. [% get 23 %] prints 23 with ANYCASE => 1 AUTO_RESET Boolean. Default 1. Clear blocks that were set during the process method. AUTO_EVAL Boolean. Default 0 (default 1 in Velocity syntax). If set to true, double quoted strings will automatically be passed to the eval filter. This configuration option may also be passed to the CONFIG directive. AUTO_FILTER Can be the name of any filter. Default undef. Any variable returned by a GET directive (including implicit GET) will be passed to the named filter. This configuration option may also be passed to the CONFIG directive. # with AUTO_FILTER => 'html' [% f = "&"; GET f %] prints & [% f = "&"; f %] prints & (implicit GET) If a variable already has another filter applied the AUTO_FILTER is not applied. The "none" scalar virtual method has been added to allow for using variables without reapplying filters. # with AUTO_FILTER => 'html' [% f = "&"; f | none %] prints & [% f = "&"; g = f; g %] prints & [% f = "&"; g = f; g | none %] prints & (because g = f is a SET directive) [% f = "&"; g = GET f; g | none %] prints & (because the actual GET directive was called) BLOCKS Only available via when using the process interface. A hashref of blocks that can be used by the process method. BLOCKS => { block_1 => sub { ... }, # coderef that returns a block block_2 => 'A String', # simple string }, Note that a Template::Document cannot be supplied as a value (TT supports this). However, it is possible to supply a value that is equal to the hashref returned by the load_template method. CACHE_SIZE Number of compiled templates to keep in memory. Default undef. Undefined means to allow all templates to cache. A value of 0 will force no caching. The cache mechanism will clear templates that have not been used recently. CACHE_STR_REFS Default 1. If set, any string refs will have an MD5 sum taken that will then be used for caching the document - both in memory and on the file system (if configured). This will give a significant speed boost. Note that this affects strings passed to the EVALUATE directive or eval filters as well. It may be set using the CONFIG directive. CALL_CONTEXT (Not in TT) Can be one of 'item', 'list', or 'smart'. The default type is 'smart'. The CALL_CONTEXT configuration specifies in what Perl context coderefs and methods used in the processed templates will be called. TT historically has avoided the distinction of item (scalar) vs list context. To avoid worrying about this, TT introduced 'smart' context. The "@()" and "$()" context specifiers make it easier to use CALL_CONTEXT in some situations. The following table shows the relationship between the various contexts: return values smart context list context item context ------------- ------------- ------------ ------------ A 'foo' 'foo' ['foo'] 'foo' B undef undef [undef] undef C (no return value) undef [] undef D (7) 7 [7] 7 E (7,8,9) [7,8,9] [7,8,9] 9 F @a = (7) 7 [7] 1 G @a = (7,8,9) [7,8,9] [7,8,9] 3 H ({b=>"c"}) {b=>"c"} [{b=>"c"}] {b=>"c"} I ([1]) [1] [[1]] [1] J ([1],[2]) [[1],[2]] [[1],[2]] [2] K [7,8,9] [7,8,9] [[7,8,9]] [7,8,9] L (undef, "foo") die "foo" [undef, "foo"] "foo" M wantarray?1:0 1 [1] 0 Cases F, H, I and M are common sticking points of the smart context in TT2. Note that list context always returns an arrayref from a method or function call. Smart context can give confusing results sometimes, especially the I and J cases. Case L for smart match is very surprising. The list and item context provide another feature for method calls. In smart context, TT will look for a hash key in the object by the same name as the method, if a method by that name doesn't exist. In item and list context Alloy will die if a method by that name cannot be found. The CALL_CONTEXT configuration item can be passed to new or it may also be set during runtime using the CONFIG directive. The following method call would be in list context: [% CONFIG CALL_CONTEXT => 'list'; results = my_obj.get_results; CONFIG CALL_CONTEXT => 'smart' %] Note that we needed to restore CALL_CONTEXT to the default 'smart' value. Template::Alloy has added the "@()" (list) and the "$()" (item) context specifiers. The previous example could be written as: [% results = @( my_obj.get_results ) %] To call that same method in item (scalar) context you would do the following: [% results = $( my_obj.get_results ) %] The "@()" and "$()" operators are based on the Perl 6 counterpart. COMPILE_DIR Base directory to store compiled templates. Default undef. Compiled templates will only be stored if one of COMPILE_DIR and COMPILE_EXT is set. If set, the AST of parsed documents will be cached. If COMPILE_PERL is set, the compiled perl code will also be stored. COMPILE_EXT Extension to add to stored compiled template filenames. Default undef. If set, the AST of parsed documents will be cached. If COMPILE_PERL is set, the compiled perl code will also be stored. COMPILE_JS Default false. Requires installation of Template::Alloy::JS. When enabled, the parsed templates will be translated into Javascript and executed using the V8 javascript engine. If compile_dir is also set, this compiled javascript will be cached to disk. If your templates are short, there is little benefit to using this other than you can then use the JS directive. If your templates are long or you are running in a cached environment, this will speed up your templates. Certain limitations exist when COMPILE_JS is set, most notably the USE and VIEW directives are not supported, and method calls on objects passed to the template do not work (code refs passed in do work however). These limitations are due to the nature of JavaScript::V8 bind and Perl/JavaScript OO differences. COMPILE_PERL Default false. If set to 1 or 2, will translate the normal AST into a perl 5 code document. This document can then be executed directly, cached in memory, or cached on the file system depending upon the configuration items set. If set to 1, a perl code document will always be generated. If set to 2, a perl code document will only be generated if an AST has already been cached for the document. This should give a speed benefit and avoid extra compilation unless the document has been used more than once. If Alloy is running in a cached environment such as mod_perl, then using compile_perl can offer some speed benefit and makes Alloy faster than Text::Tmpl and as fast as HTML::Template::Compiled (but Alloy has more features). If you are not running in a cached environment, such as from commandline, or from CGI, it is generally faster to only run from the AST (with COMPILE_PERL => 0). CONSTANTS Hashref. Used to define variables that will be "folded" into the compiled template. Variables defined here cannot be overridden. CONSTANTS => {my_constant => 42}, A template containing: [% constants.my_constant %] Will have the value 42 compiled in. Constants defined in this way can be chained as in [% constant.foo.bar.baz %]. CONSTANT_NAMESPACE Allow for setting the top level of values passed in CONSTANTS. Default value is 'constants'. DEBUG Takes a list of constants |'ed together which enables different debugging modes. Alternately the lowercase names may be used (multiple values joined by a ","). The only supported TT values are: DEBUG_UNDEF (2) - debug when an undefined value is used (now easier to use STRICT) DEBUG_DIRS (8) - debug when a directive is used. DEBUG_ALL (2047) - turn on all debugging. Either of the following would turn on undef and directive debugging: DEBUG => 'undef, dirs', # preferred DEBUG => 2 | 8, DEBUG => DEBUG_UNDEF | DEBUG_DIRS, # constants from Template::Constants DEBUG_FORMAT Change the format of messages inserted when DEBUG has DEBUG_DIRS set on. This essentially the same thing as setting the format using the DEBUG directive. DEFAULT The name of a default template file to use if the passed one is not found. DELIMITER String to use to split INCLUDE_PATH with. Default is :. It is more straight forward to just send INCLUDE_PATH an arrayref of paths. DUMP Configures the behavior of the DUMP tag. May be set to 0, a hashref, or another true value. Default is true. If set to 0, all DUMP directives will do nothing. This is useful if you would like to turn off the DUMP directives under some environments. IF set to a true value (or undefined) then DUMP directives will operate. If set to a hashref, the values of the hash can be used to configure the operation of the DUMP directives. The following are the values that can be set in this hash. EntireStash Default 1. If set to 0, then the DUMP directive will not print the entire contents of the stash when a DUMP directive is called without arguments. handler Defaults to an internal coderef. If set to a coderef, the DUMP directive will pass the arguments to be dumped and expects a string with the dumped data. This gives complete control over the dump process. Note 1: The default handler makes sure that values matching the private variable regex are not included. If you install your own handler, you will need to take care of these variables if you intend for them to not be shown. Note 2: If you would like the name of the variable to be dumped, include the string '$VAR1' and the DUMP directive will interpolate the value. For example, to dump all output as YAML - you could do the following: DUMP => { handler => sub { require YAML; return "\$VAR1 =\n".YAML::Dump(shift); }, } header Default 1. Controls whether a header is printed for each DUMP directive. The header contains the file and line number the DUMP directive was called from. If set to 0 the headers are disabled. html Defaults to 1 if $ENV{'REQUEST_METHOD'} is set - 0 otherwise. If set to 1, then the output of the DUMP directive is passed to the html filter and encased in "pre" tags. If set to 0 no html encoding takes place. Sortkeys, Useqq, Ident, Pad, etc Any of the Data::Dumper configuration items may be passed. ENCODING Default undef. If set, and if Perl version is greater than or equal to 5.7.3 (when Encode.pm was first included), then Encode::decode will be called every time a template file is processed and will be passed the value of ENCODING and text from the template. This item can also be set using [% CONFIG ENCODING => encoding %] before calling INCLUDE or PROCESS directives to change encodings on the fly. END_TAG Set a string to use as the closing delimiter for TT. Default is "%]". ERROR Used as a fall back when the processing of a template fails. May either be a single filename that will be used in all cases, or may be a hashref of options where the keynames represent error types that will be handled by the filename in their value. A key named default will be used if no other matching keyname can be found. The selection process is similar to that of the TRY/CATCH/THROW directives (see those directives for more information). my $t = Template::Alloy->new({ ERROR => 'general/catch_all_errors.html', }); my $t = Template::Alloy->new({ ERROR => { default => 'general/catch_all_errors.html', foo => 'catch_all_general_foo_errors.html', 'foo.bar' => 'catch_foo_bar_errors.html', }, }); Note that the ERROR handler will only be used for errors during the processing of the main document. It will not catch errors that occur in templates found in the PRE_PROCESS, POST_PROCESS, and WRAPPER configuration items. ERRORS Same as the ERROR configuration item. Both may be used interchangeably. EVAL_PERL Boolean. Default false. If set to a true value, PERL and RAWPERL blocks will be allowed to run. This is a potential security hole, as arbitrary perl can be included in the template. If Template::Toolkit is installed, a true EVAL_PERL value also allows the perl and evalperl filters to be used. FILTERS Allow for passing in TT style filters. my $filters = { filter1 => sub { my $str = shift; $s =~ s/./1/gs; $s }, filter2 => [sub { my $str = shift; $s =~ s/./2/gs; $s }, 0], filter3 => [sub { my ($context, @args) = @_; return sub { my $s = shift; $s =~ s/./3/gs; $s } }, 1], }; my $str = q{ [% a = "Hello" %] 1 ([% a | filter1 %]) 2 ([% a | filter2 %]) 3 ([% a | filter3 %]) }; my $obj = Template::Alloy->new(FILTERS => $filters); $obj->process(\$str) || die $obj->error; Would print: 1 (11111) 2 (22222) 3 (33333) Filters passed in as an arrayref should contain a coderef and a value indicating if they are dynamic or static (true meaning dynamic). The dynamic filters are passed the pseudo context object and any arguments and should return a coderef that will be called as the filter. The filter coderef is then passed the string. GLOBAL_CACHE Default 0. If true, documents will be cached in $Template::Alloy::GLOBAL_CACHE. It may also be passed a hashref, in which case the documents will be cached in the passed hashref. The TT, Tmpl, and velocity will automatically cache documents in the object. The HTML::Template interface uses a new object each time. Setting the HTML::Template's CACHE configuration is the same as setting GLOBAL_CACHE. INCLUDE_PATH A string or an arrayref or coderef that returns an arrayref that contains directories to look for files included by processed templates. Defaults to "." (the current directory). INCLUDE_PATHS Non-TT item. Same as INCLUDE_PATH but only takes an arrayref. If not specified then INCLUDE_PATH is turned into an arrayref and stored in INCLUDE_PATHS. Overrides INCLUDE_PATH. INTERPOLATE Boolean. Specifies whether variables in text portions of the template will be interpolated. For example, the $variable and ${var.value} would be substituted with the appropriate values from the variable cache (if INTERPOLATE is on). [% IF 1 %]The variable $variable had a value ${var.value}[% END %] LOAD_PERL Indicates if the USE directive can fall back and try and load a perl module if the indicated module was not found in the PLUGIN_BASE path. See the USE directive. This configuration has no bearing on the COMPILE_PERL directive used to indicate using compiled perl documents. MAX_EVAL_RECURSE (Alloy only) Will use $Template::Alloy::MAX_EVAL_RECURSE if not present. Default is 50. Prevents runaway on the following: [% f = "[% f|eval %]" %][% f|eval %] MAX_MACRO_RECURSE (Alloy only) Will use $Template::Alloy::MAX_MACRO_RECURSE if not present. Default is 50. Prevents runaway on the following: [% MACRO f BLOCK %][% f %][% END %][% f %] NAMESPACE No Template::Namespace::Constants support. Hashref of hashrefs representing constants that will be folded into the template at compile time. Template::Alloy->new(NAMESPACE => {constants => { foo => 'bar', }}); Is the same as Template::Alloy->new(CONSTANTS => { foo => 'bar', }); Any number of hashes can be added to the NAMESPACE hash. NEGATIVE_STAT_TTL (Not in TT) Defaults to STAT_TTL which defaults to $STAT_TTL which defaults to 1. Similar to STAT_TTL - but represents the time-to-live seconds until a document that was not found is checked again against the system for modifications. Setting this number higher will allow for fewer file system accesses. Setting it to a negative number will allow for the file system to be checked every hit. NO_INCLUDES Default false. If true, calls to INCLUDE, PROCESS, WRAPPER and INSERT will fail. This option is also available when using the process method. OUTPUT Alternate way of passing in the output location for processed templates. If process is not passed an output argument, it will look for this value. See the process method for a listing of possible values. OUTPUT_PATH Base path for files written out via the process method or via the redirect and file filters. See the redirect virtual method and the process method for more information. PLUGINS A hashref of mappings of plugin modules. PLUGINS => { Iterator => 'Template::Plugin::Iterator', DBI => 'MyDBI', }, See the USE directive for more information. PLUGIN_BASE Default value is Template::Plugin. The base module namespace that template plugins will be looked for. See the USE directive for more information. May be either a single namespace, or an arrayref of namespaces. POST_CHOMP Set the type of chomping at the ending of a tag. See the section on chomping for more information. POST_PROCESS Only available via when using the process interface. A list of templates to be processed and appended to the content after the main template. During this processing the "template" namespace will contain the name of the main file being processed. This is useful for adding a global footer to all templates. PRE_CHOMP Set the type of chomping at the beginning of a tag. See the section on chomping for more information. PRE_DEFINE Same as the VARIABLES configuration item. PRE_PROCESS Only available via when using the process interface. A list of templates to be processed before and pre-pended to the content before the main template. During this processing the "template" namespace will contain the name of the main file being processed. This is useful for adding a global header to all templates. PROCESS Only available via when using the process interface. Specify a file to use as the template rather than the one passed in to the ->process method. RECURSION Boolean. Default false. Indicates that INCLUDED or PROCESSED files can refer to each other in a circular manner. Be careful about recursion. RELATIVE Boolean. Default false. If true, allows filenames to be specified that are relative to the currently running process. SEMICOLONS Boolean. Default false. If true, then the syntax will require that semi-colons separate multiple directives in the same tag. This is useful for keeping the syntax a little more clean as well as trouble shooting some errors. SHOW_UNDEFINED_INTERP (Not in TT) Default false (default true in Velocity). If INTERPOLATE is true, interpolated dollar variables that return undef will be removed. With SHOW_UNDEFINED_INTERP set, undef values will leave the variable there. [% CONFIG INTERPOLATE => 1 %] [% SET foo = 1 %][% SET bar %] ($foo)($bar) ($!foo)($!bar) Would print: (1)() (1)() But the following: [% CONFIG INTERPOLATE => 1, SHOW_UNDEFINED_INTERP => 1 %] [% SET foo = 1 %][% SET bar %] ($foo)($bar) ($!foo)($!bar) Would print: (1)($bar) (1)() Note that you can use an exclamation point directly after the dollar to make the variable silent. This is similar to how Velocity works. START_TAG Set a string or regular expression to use as the opening delimiter for TT. Default is "[%". You should be sure that the tag does not include grouping parens or INTERPOLATE will not function properly. STASH Template::Alloy manages its own stash of variables. You can pass a Template::Stash or Template::Stash::XS object, but Template::Alloy will copy all of values out of the object into its own stash. Template::Alloy won't use any of the methods of the passed STASH object. The STASH option is only available when using the process method. STAT_TTL Defaults to $STAT_TTL which defaults to 1. Represents time-to-live seconds until a cached in memory document is compared to the file system for modifications. Setting this number higher will allow for fewer file system accesses. Setting it to a negative number will allow for the file system to be checked every hit. STREAM Defaults to false. If set to true, generated template content will be printed to the currently selected filehandle (default is STDOUT) as soon as it is ready - there will be no buffering of the output. The Stream role uses the Play role's directives (non-compiled_perl). All directives and configuration work, except for the following exceptions: CLEAR directive Because the output is not buffered - the CLEAR directive would have no effect. The CLEAR directive will throw an error when STREAM is on. TRIM configuration Because the output is not buffered - trim operations cannot be played on the output buffers. WRAPPER configuration/directive The WRAPPER configuration and directive items effectively turn off STREAM since the WRAPPERS are generated in reverse order and because the content is inserted into the middle of the WRAPPERS. WRAPPERS will still work, they just won't stream. VARIOUS errors Because the template is streaming, items that cause errors my result in partially printed pages - since the error would occur part way through the print. All output is printed directly to the currently selected filehandle (defaults to STDOUT) via the CORE::print function. Any output parameter passed to process or process_simple will be ignored. If you would like the output to go to another handle, you will need to select that handle, process the template, and re-select STDOUT. STRICT Defaults to false. If set to true, any undefined variable that is encountered will cause the processing of the template to abort. This can be caught with a TRY block. This can be useful for making sure that the template only attempts to use variables that were correctly initialized similar in spirit to Perl's "use strict." When this occurs the strict_throw method is called. See the STRICT_THROW configuration for additional options. Similar functionality could be implemented using UNDEFINED_ANY. The STRICT configuration item can be passed to new or it may also be set during runtime using the CONFIG directive. Once set though it cannot be disabled for the duration of the current template and sub components. For example you could call [% CONFIG STRICT => 1 %] in header.tt and strict mode would be enabled for the header.tt and any sub templates processed by header.tt. STRICT_THROW (not in TT) Default undef. Can be set to a subroutine which will be called when STRICT is set and an undefined variable is processed. It will be passed the error type, error message, and a hashref of template information containing the current component being processed, the current outer template being processed, the identity reference for the variable, and the stringified name of the identity. This override can be used for filtering allowable elements. my $ta = Template::Alloy->new({ STRICT => 1, STRICT_THROW => sub { my ($ta, $err_type, $msg, $args) = @_; return if $args->{'component'} eq 'header.tt' && $args->{'template'} eq 'main.html' && $args->{'name'} eq 'foo.bar(1)'; # stringified identity name $ta->throw($err_type, $msg); # all other undefined variables die }, }); SYNTAX (not in TT) Defaults to "cet". Indicates the syntax that will be used for parsing included templates or eval'ed strings. You can use the CONFIG directive to change the SYNTAX on the fly (it will not affect the syntax of the document currently being parsed). The syntax may be passed in upper or lower case. The available choices are: alloy - Template::Alloy style - the same as TT3 tt3 - Template::Toolkit ver3 - same as Alloy tt2 - Template::Toolkit ver2 - almost the same as TT3 tt1 - Template::Toolkit ver1 - almost the same as TT2 ht - HTML::Template - same as HTML::Template::Expr without EXPR hte - HTML::Template::Expr js - JavaScript style - requires compile_js to be set. jsr - JavaScript Raw style - requires compile_js to be set. Passing in a different syntax allows for the process method to use a non-TT syntax and for the output method to use a non-HT syntax. The following is a sample of HTML::Template interface usage parsing a Template::Toolkit style document. my $obj = Template::Alloy->new(filename => 'my/template.tt' syntax => 'cet'); $obj->param(\%swap); print $obj->output; The following is a sample of Template::Toolkit interface usage parsing a HTML::Template::Expr style document. my $obj = Template::Alloy->new(SYNTAX => 'hte'); $obj->process('my/template.ht', \%swap); You can use the define_syntax method to add another custom syntax to the list of available options. TAG_STYLE Allow for setting the type of tag delimiters to use for parsing the TT. See the TAGS directive for a listing of the available types. TRIM Remove leading and trailing whitespace from blocks and templates. This operation is performed after all enclosed template tags have been executed. UNDEFINED_ANY This is not a TT configuration option. This option expects to be a code ref that will be called if a variable is undefined during a call to play_expr. It is passed the variable identity array as a single argument. This is most similar to the "undefined" method of Template::Stash. It allows for the "auto-defining" of a variable for use in the template. It is suggested that UNDEFINED_GET be used instead as UNDEFINED_ANY is a little to general in defining variables. You can also sub class the module and override the undefined_any method. UNDEFINED_GET This is not a TT configuration option. This option expects to be a code ref that will be called if a variable is undefined during a call to GET. It is passed the variable identity array as a single argument. This is more useful than UNDEFINED_ANY in that it is only called during a GET directive rather than in embedded expressions (such as [% a || b || c %]). You can also sub class the module and override the undefined_get method. V1DOLLAR This allows for some compatibility with TT1 templates. The only real behavior change is that [% $foo %] becomes the same as [% foo %]. The following is a basic table of changes invoked by using V1DOLLAR. With V1DOLLAR Equivalent Without V1DOLLAR (Normal default) "[% foo %]" "[% foo %]" "[% $foo %]" "[% foo %]" "[% ${foo} %]" "[% ${foo} %]" "[% foo.$bar %]" "[% foo.bar %]" "[% ${foo.bar} %]" "[% ${foo.bar} %]" "[% ${foo.$bar} %]" "[% ${foo.bar} %]" "Text: $foo" "Text: $foo" "Text: ${foo}" "Text: ${foo}" "Text: ${$foo}" "Text: ${foo}" V2EQUALS Default 1 in the TT syntax, defaults to 0 in the HTML::Template syntax. If set to 1 then "==" is an alias for "eq" and "!= is an alias for "ne". [% CONFIG V2EQUALS => 1 %][% ('7' == '7.0') || 0 %] [% CONFIG V2EQUALS => 0 %][% ('7' == '7.0') || 0 %] Prints 0 1 V2PIPE Restores the behavior of the pipe operator to be compatible with TT2. With V2PIPE = 1 [%- BLOCK a %]b is [% b %] [% END %] [%- PROCESS a b => 237 | repeat(2) %] # output of block "a" with b set to 237 is passed to the repeat(2) filter b is 237 b is 237 With V2PIPE = 0 (default) [%- BLOCK a %]b is [% b %] [% END %] [% PROCESS a b => 237 | repeat(2) %] # b set to 237 repeated twice, and b passed to block "a" b is 237237 VARIABLES A hashref of variables to initialize the template stash with. These variables are available for use in any of the executed templates. See the section on VARIABLES for the types of information that can be passed in. VMETHOD_FUNCTIONS Defaults to 1. All scalar virtual methods are available as top level functions as well. This is not true of TT2. In Template::Alloy the following are equivalent: [% "abc".length %] [% length("abc") %] You may set VMETHOD_FUNCTIONS to 0 to disable this behavior. WRAPPER Only available via when using the process interface. Operates similar to the WRAPPER directive. The option can be given a single filename, or an arrayref of filenames that will be used to wrap the processed content. If an arrayref is passed the filenames are processed in reverse order, so that the first filename specified will end up being on the outside (surrounding all other wrappers). my $t = Template::Alloy->new( WRAPPER => ['my/wrappers/outer.html', 'my/wrappers/inner.html'], ); Content generated by the PRE_PROCESS and POST_PROCESS will come before and after (respectively) the content generated by the WRAPPER configuration item. See the WRAPPER directive for more examples of how wrappers are constructed. CONFIGURATION (HTML::Template STYLE) The following HTML::Template and HTML::Template::Expr configuration variables are supported (in HTML::Template documentation order). Note: for further discussion you can refer to the HT documentation. Many of the variables mentioned in the TT CONFIGURATION section apply here as well. Unless noted, these items only apply when using the output method. Items may be passed in upper or lower case. All passed items are resolved to upper case. These variables should be passed to the "new" constructor. my $obj = Template::Alloy->new( type => 'filename', source => 'my/template.ht', die_on_bad_params => 1, loop_context_vars => 1, global_vars => 1 post_chomp => "=", pre_chomp => "-", ); TYPE Can be one of filename, filehandle, arrayref, or scalarref. Indicates what type of input is in the "source" configuration item. SOURCE Stores where to read the input file. The type is specified in the "type" configuration item. FILENAME Indicates a filename to read the template from. Same as putting the filename in the "source" item and setting "type" to "filename". Must be set to enable caching. FILEHANDLE Should contain an open filehandle to read the template from. Same as putting the filehandle in the "source" item and setting "type" to "filehandle". Will not be cached. ARRAYREF Should contain an arrayref whose values are the lines of the template. Same as putting the arrayref in the "source" item and setting "type" to "arrayref". Will not be cached. SCALARREF Should contain an reference to a scalar that contains the template. Same as putting the scalar ref in the "source" item and setting "type" to "scalarref". Will not be cached. CACHE If set to one, then Alloy will use a global, in-memory document cache to store compiled templates in between calls. This is generally only useful in a mod_perl environment. The document is checked for a different modification time at each request. BLIND_CACHE Same as with cache enabled, but will not check if the document has been modified. FILE_CACHE If set to 1, will cache the compiled document on the file system. If true, file_cache_dir must be set. FILE_CACHE_DIR The directory where to store cached documents when file_cache is true. This is similar to the TT compile_dir option. DOUBLE_FILE_CACHE Uses a combination of file_cache and cache. PATH Same as INCLUDE_PATH when using the process method. ASSOCIATE May be a single CGI object or an arrayref of objects. The params from these objects will be added to the params during the output call. CASE_SENSITIVE Allow passed variables set through the param method, or the associate configuration to be used case sensitively. Default is off. It is highly suggested that this be set to 1. LOOP_CONTEXT_VARS Default false. When true, calls to the loop directive will create the following variables that give information about the current iteration of the loop: __first__ - True on first iteration only __last__ - True on last iteration only __inner__ - True on any iteration that isn't first or last __odd__ - True on odd iterations __counter__ - The iteration count These variables are also available to LOOPs run under TT syntax if loop_context_vars is set and if QR_PRIVATE is set to 0. GLOBAL_VARS. Default true in HTE mode. Default false in HT. Allows top level variables to be used in LOOPs. When false, only variables defined in the current LOOP iteration hashref will be available. DEFAULT_ESCAPE Controls the type of escape used on named variables in TMPL_VAR directives. Can be one of HTML, URL, or JS. The values of TMPL_VAR directives will be encoded with this type unless they specify their own type via an ESCAPE attribute. You may alternately use the AUTO_FILTER directive which can be any of the item vmethod filters (you must use lower case when specifying the AUTO_FILTER directive). The AUTO_FILTER directive will also be applied to TMPL_VAR EXPR and TMPL_GET items while DEFAULT_ESCAPE only applies to TMPL_VAR NAME items. NO_TT Default false in 'hte' syntax. Default true in 'ht' syntax. If true, no extended TT directives will be allowed. The output method uses 'hte' syntax by default. SEMI PUBLIC METHODS The following list of methods are other interesting methods of Alloy that may be re-implemented by subclasses of Alloy. "exception" Creates an exception object blessed into the package listed in Template::Alloy::Exception. "execute_tree" Executes a parsed tree (returned from parse_tree) "play_expr" Play the parsed expression. Turns a variable identity array into the parsed variable. This method is also responsible for playing operators and running virtual methods and filters. The variable identity array may also contain literal values, or operator identity arrays. "include_filename" Takes a file path, and resolves it into the full filename using paths from INCLUDE_PATH or INCLUDE_PATHS. "_insert" Resolves the file passed, and then returns its contents. "list_filters" Dynamically loads the filters list from Template::Filters when a filter is used that does not have a native implementation in Alloy. "load_template" Given a filename or a string reference will return a "document" hashref hash that contains the parsed tree. my $doc = $self->load_template($file); # errors die This method handles the in-memory caching of the document. "load_tree" Given the "document" hashref, will either load the parsed AST from file (if configured to do so), or will load the content, parse the content using the Parse role, and will return the tree. File based caching of the parsed AST happens here. "load_perl" Only used if COMPILE_PERL is true (default is false). Given the "document" hashref, will either load the compiled perl from file (if configured to do so), or will load the AST using "load_tree", will compile a new perl code document using the Compile role, and will return the perl code. File based caching of the compiled perl happens here. "parse_tree" Parses the passed string ref with the appropriate template syntax. See Template::Alloy::Parse for more details. "parse_expr" Parses the passed string ref for a variable or expression. See Template::Alloy::Parse for more details. "parse_args" See Template::Alloy::Parse for more details. "set_variable" Used to set a variable. Expects a variable identity array and the value to set. It will autovifiy as necessary. "strict_throw" Called during processing of template when STRICT configuration is set and an uninitialized variable is met. Arguments are the variable identity reference. Will call STRICT_THROW configuration item if set, otherwise will call throw with a useful message. "throw" Creates an exception object from the arguments and dies. "undefined_any" Called during play_expr if a value is returned that is undefined. This could be used to magically create variables on the fly. This is similar to Template::Stash::undefined. It is suggested that undefined_get be used instead. Default behavior returns undef. You may also pass a coderef via the UNDEFINED_ANY configuration variable. Also, you can try using the DEBUG => 'undef', configuration option which will throw an error on undefined variables. "undefined_get" Called when a variable is undefined during a GET directive. This is useful to see if a value that is about to get inserted into the text is undefined. undefined_any is a little too general for most cases. Also, you may pass a coderef via the UNDEFINED_GET configuration variable. OTHER UTILITY METHODS The following is a brief list of other methods used by Alloy. Generally, these shouldn't be overwritten by subclasses. "ast_string" Returns perl code representation of a variable. "context" Used to create a "pseudo" context object that allows for portability of TT plugins, filters, and perl blocks that need a context object. Uses the Template::Alloy::Context class. "debug_node" Used to get debug info on a directive if DEBUG_DIRS is set. "get_line_number_by_index" Used to turn string index position into line number "interpolate_node" Used for parsing text nodes for dollar variables when interpolate is on. "play_operator" Provided by the Operator role. Allows for playing an operator AST. See Template::Alloy::Operator for more details. "apply_precedence" Provided by the Parse role. Allows for parsed operator array to be translated to a tree based upon operator precedence. "_process" Called by process and the PROCESS, INCLUDE and other directives. "slurp" Reads contents of passed filename - throws file exception on error. "split_paths" Used to split INCLUDE_PATH or other directives if an arrayref is not passed. "tt_var_string" Returns a template toolkit representation of a variable. "_vars" Return a reference to the current stash of variables. This is currently only used by the pseudo context object and may disappear at some point. THANKS Thanks to Andy Wardley for creating Template::Toolkit. Thanks to Sam Tregar for creating HTML::Template. Thanks to David Lowe for creating Text::Tmpl. Thanks to the Apache Velocity guys. Thanks to Ben Grimm for a patch to allow passing a parsed document to the ->process method. Thanks to David Warring for finding a parse error in HTE syntax. Thanks to Carl Franks for adding the base ENCODING support. AUTHOR Paul Seamons LICENSE This module may be distributed under the same terms as Perl itself. libtemplate-alloy-perl-1.022/lib/000077500000000000000000000000001402714000200166325ustar00rootroot00000000000000libtemplate-alloy-perl-1.022/lib/Template/000077500000000000000000000000001402714000200204055ustar00rootroot00000000000000libtemplate-alloy-perl-1.022/lib/Template/Alloy.pm000077500000000000000000001142651402714000200220370ustar00rootroot00000000000000package Template::Alloy; ###----------------------------------------------------------------### # See the perldoc in Template/Alloy.pod # # Copyright 2007 - 2013 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### use strict; use warnings; use Template::Alloy::Exception; use Template::Alloy::Operator qw(play_operator define_operator); use Template::Alloy::VMethod qw(define_vmethod $SCALAR_OPS $ITEM_OPS $ITEM_METHODS $FILTER_OPS $LIST_OPS $HASH_OPS $VOBJS); our $VERSION = '1.022'; our $QR_PRIVATE = qr/^[_.]/; our $WHILE_MAX = 1000; our $MAX_EVAL_RECURSE = 50; our $MAX_MACRO_RECURSE = 50; our $STAT_TTL = 1; our $QR_INDEX = '(?:\d*\.\d+ | \d+)'; our @CONFIG_COMPILETIME = qw(SYNTAX CACHE_STR_REFS ANYCASE INTERPOLATE PRE_CHOMP POST_CHOMP ENCODING SEMICOLONS V1DOLLAR V2PIPE V2EQUALS AUTO_EVAL SHOW_UNDEFINED_INTERP AUTO_FILTER); our @CONFIG_RUNTIME = qw(ADD_LOCAL_PATH CALL_CONTEXT DUMP VMETHOD_FUNCTIONS STRICT); our $EVAL_CONFIG = {map {$_ => 1} @CONFIG_COMPILETIME, @CONFIG_RUNTIME}; our $EXTRA_COMPILE_EXT = '.sto'; our $PERL_COMPILE_EXT = '.pl'; our $JS_COMPILE_EXT = '.js'; our $GLOBAL_CACHE = {}; ###----------------------------------------------------------------### our $AUTOROLE = { Compile => [qw(load_perl compile_template compile_tree compile_expr)], HTE => [qw(parse_tree_hte param output register_function clear_param query new_file new_scalar_ref new_array_ref new_filehandle)], Parse => [qw(parse_tree parse_expr apply_precedence parse_args dump_parse_tree dump_parse_expr define_directive define_syntax)], Play => [qw(play_tree _macro_sub)], Stream => [qw(stream_tree)], JS => [qw(load_js compile_template_js compile_tree_js play_js js_context process_js parse_tree_js process_jsr parse_tree_jsr)], TT => [qw(parse_tree_tt3 process)], Tmpl => [qw(parse_tree_tmpl set_delimiters set_strip set_value set_values parse_string set_dir parse_file loop_iteration fetch_loop_iteration)], Velocity => [qw(parse_tree_velocity merge)], }; my $ROLEMAP = { map { my $type = $_; map { ($_ => $type) } @{ $AUTOROLE->{$type} } } keys %$AUTOROLE }; my %STANDIN = ('Template' => 'TT', 'Template::Toolkit' => 'TT', 'HTML::Template' => 'HTE', 'HTML::Template::Expr' => 'HTE', 'Text::Tmpl' => 'Tmpl'); our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my $meth = ($AUTOLOAD && $AUTOLOAD =~ /::(\w+)$/) ? $1 : $self->throw('autoload', "Invalid method $AUTOLOAD"); if (! $self->can($meth)) { require Carp; Carp::croak("Can't locate object method \"$meth\" via package ".ref($self)); } return $self->$meth(@_); } sub can { my ($self, $meth) = @_; __PACKAGE__->import($ROLEMAP->{$meth}) if $ROLEMAP->{$meth}; return $self->SUPER::can($meth); } sub DESTROY {} sub import { my $class = shift; foreach my $item (@_) { next if $item =~ /^(load|1)$/i; if (lc $item eq 'all') { local $AUTOROLE->{'JS'}; delete $AUTOROLE->{'JS'}; return $class->import(keys %$AUTOROLE); } my $type; if ($type = $STANDIN{$item}) { (my $file = "$item.pm") =~ s|::|/|g; if (! $INC{$file} || ! $item->isa(__PACKAGE__)) { if ($INC{$file}) { require Carp; Carp::croak("Class $item is already loaded - can't override") } eval "{package $item; our \@ISA = qw(".__PACKAGE__.");}"; $INC{$file} = __FILE__; next if ! $AUTOROLE->{$type}; # already imported } } $type ||= $AUTOROLE->{$item} ? $item : $ROLEMAP->{$item} || do { require Carp; Carp::croak("Invalid import option \"$item\"") }; my $pkg = __PACKAGE__."::$type"; (my $file = "$pkg.pm") =~ s|::|/|g; require $file; no strict 'refs'; *{__PACKAGE__."::$_"} = \&{"$pkg\::$_"} for @{ $AUTOROLE->{$type} }; $AUTOROLE->{$type} = []; } return 1; } ###----------------------------------------------------------------### sub new { my $class = shift; my $args = ref($_[0]) ? { %{ shift() } } : {@_}; ### allow for lowercase args if (my @keys = grep {/^[a-z][a-z_]+$/} keys %$args) { @{ $args }{ map { uc $_ } @keys } = delete @{ $args }{ @keys }; } return bless $args, $class; } ###----------------------------------------------------------------### sub run { shift->process_simple(@_) } sub process_simple { my $self = shift; my $in = shift || die "Missing input"; my $swap = shift || die "Missing variable hash"; my $out = shift || ($self->{'STREAM'} ? \ "" : die "Missing output string ref"); delete $self->{'error'}; eval { delete $self->{'_debug_off'}; delete $self->{'_debug_format'}; local $self->{'_start_top_level'} = 1; $self->_process($in, $swap, $out); }; if (my $err = $@) { if ($err->type !~ /stop|return|next|last|break/) { $self->{'error'} = $err; die $err if $self->{'RAISE_ERROR'}; return; } elsif ($err->type eq 'return' && UNIVERSAL::isa($err->info, 'HASH')) { return $err->info->{'return_val'}; } } return 1; } sub _process { my $self = shift; my $file = shift; local $self->{'_vars'} = shift || {}; my $out_ref = shift || $self->throw('undef', "Missing output ref"); local $self->{'_top_level'} = delete $self->{'_start_top_level'}; my $i = length $$out_ref; ### parse and execute my $doc; eval { $doc = (ref($file) eq 'HASH') ? $file : $self->load_template($file); ### prevent recursion $self->throw('file', "recursion into '$doc->{name}'") if ! $self->{'RECURSION'} && $self->{'_in'}->{$doc->{'name'}} && $doc->{'name'} ne 'input text'; local $self->{'_in'}->{$doc->{'name'}} = 1; local $self->{'_component'} = $doc; local $self->{'_template'} = $self->{'_top_level'} ? $doc : $self->{'_template'}; local @{ $self }{@CONFIG_RUNTIME} = @{ $self }{@CONFIG_RUNTIME}; ### run the document however we can if ($self->{'STREAM'}) { $self->throw('process', 'No _tree found') if ! $doc->{'_tree'}; $self->stream_tree($doc->{'_tree'}); } elsif ($self->{'COMPILE_JS'}) { $self->play_js($doc, $out_ref); } elsif ($doc->{'_perl'}) { $doc->{'_perl'}->{'code'}->($self, $out_ref); } elsif ($doc->{'_tree'}) { $self->play_tree($doc->{'_tree'}, $out_ref); } else { $self->throw('process', 'No _perl and no _tree found'); } ### trim whitespace from the beginning and the end of a block or template if ($self->{'TRIM'}) { substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ \s+ $ }{}x; # tail first substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ ^ \s+ }{}x; } }; ### handle exceptions if (my $err = $@) { $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type'); $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc; die $err if ! $self->{'_top_level'}; die $err if $err->type ne 'stop' && ($err->type ne 'return' || $err->info); } return 1; } ###----------------------------------------------------------------### sub load_template { my ($self, $file) = @_; $self->throw('undef', 'Undefined file passed to load_template') if ! defined $file; my $docs = $self->{'GLOBAL_CACHE'} || ($self->{'_documents'} ||= {}); $docs = $GLOBAL_CACHE if ! ref $docs; ### looks like a scalar ref my $doc; if (ref $file) { return $file if ref $file eq 'HASH'; if (! defined($self->{'CACHE_STR_REFS'}) || $self->{'CACHE_STR_REFS'}) { my $_file = $self->string_id($file); if ($docs->{$_file}) { # no-ttl necessary $doc = $docs->{$_file}; $doc->{'_perl'} = $self->load_perl($doc) if ! $doc->{'_perl'} && $self->{'COMPILE_PERL'}; # second hit return $doc; } $doc->{'_filename'} = $_file; } else { $doc->{'_no_perl'} = $self->{'FORCE_STR_REF_PERL'} ? 0 : 1; } $doc->{'_is_str_ref'} = 1; $doc->{'_content'} = $file; $doc->{'name'} = 'input text'; $doc->{'modtime'} = time; ### looks like a previously cached document } elsif ($docs->{$file}) { $doc = $docs->{$file}; if (time - $doc->{'cache_time'} < ($self->{'STAT_TTL'} || $STAT_TTL) # don't stat more than once a second || $doc->{'modtime'} == (stat $doc->{'_filename'})[9]) { # otherwise see if the file was modified $doc->{'_perl'} = $self->load_perl($doc) if ! $doc->{'_perl'} && $self->{'COMPILE_PERL'}; # second hit return $doc; } delete @$doc{qw(_tree modtime _content _line_offsets _perl _js)}; ### looks like a previously cached not-found } elsif ($self->{'_not_found'}->{$file}) { $doc = $self->{'_not_found'}->{$file}; if (time - $doc->{'cache_time'} < ($self->{'NEGATIVE_STAT_TTL'} || $self->{'STAT_TTL'} || $STAT_TTL)) { # negative cache for a second die $doc->{'exception'}; } delete $self->{'_not_found'}->{$file}; # clear cache on failure ### looks like a block passed in at runtime } elsif ($self->{'BLOCKS'}->{$file}) { my $block = $self->{'BLOCKS'}->{$file}; $block = $block->() if UNIVERSAL::isa($block, 'CODE'); if (! UNIVERSAL::isa($block, 'HASH')) { $self->throw('block', "Unsupported BLOCK type \"$block\"") if ref $block; $block = eval { $self->load_template(\$block) } || $self->throw('block', 'Parse error on predefined block'); } $doc->{'name'} = ($block->{'name'} && $block->{'name'} ne 'input text') ? $block->{'name'} : $file; $doc->{'_filename'} = $block->{'_filename'} if $block->{'_filename'}; if ($block->{'_perl'}) { $doc->{'_perl'} = $block->{'_perl'}; } elsif ($block->{'_tree'}) { $doc->{'_tree'} = $block->{'_tree'}; } else { $self->throw('block', "Invalid block definition (missing tree)"); } return $doc; } ### lookup the filename if (! $doc->{'_filename'} && ! ref $file) { $doc->{'name'} = $file; $doc->{'_filename'} = eval { $self->include_filename($file) }; if (my $err = $@) { ### allow for blocks in other files if ($self->{'EXPOSE_BLOCKS'} && ! $self->{'_looking_in_block_file'}) { local $self->{'_looking_in_block_file'} = 1; my $block_name = ''; OUTER: while ($file =~ s|/([^/.]+)$||) { $block_name = length($block_name) ? "$1/$block_name" : $1; my $ref = eval { $self->load_template($file) } || next; my $_tree = $ref->{'_tree'}; foreach my $node (@$_tree) { last if ! ref $node; next if $node->[0] eq 'META'; last if $node->[0] ne 'BLOCK'; next if $block_name ne $node->[3]; $doc->{'_tree'} = $node->[4]; @{$doc}{qw(modtime _content)} = @{$ref}{qw(modtime _content)}; $doc->{'_perl'} = { meta => {}, blocks => {}, code => $ref->{'_perl'}->{'blocks'}->{$block_name}->{'_perl'}->{'code'}, } if $ref->{'_perl'} && $ref->{'_perl'}->{'blocks'} && $ref->{'_perl'}->{'blocks'}->{$block_name}; $doc->{'_js'} = $self->load_js($doc) if $self->{'COMPILE_JS'} && $ref->{'_js'}; # have to regenerate because block is buried in js return $doc; } } } elsif ($self->{'DEFAULT'}) { $err = '' if ($doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) }); } if ($err) { ### cache the negative error if (! defined($self->{'NEGATIVE_STAT_TTL'}) || $self->{'NEGATIVE_STAT_TTL'}) { $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type'); $self->{'_not_found'}->{$file} = { cache_time => time, exception => $self->exception($err->type, $err->info." (cached)"), }; } die $err; } } } ### return perl - if they want perl - otherwise - the ast if (! $doc->{'_no_perl'} && $self->{'COMPILE_PERL'} && ($self->{'COMPILE_PERL'} ne '2' || $self->{'_tree'})) { $doc->{'_perl'} = $self->load_perl($doc); } elsif ($self->{'COMPILE_JS'}) { $self->load_js($doc); } else { $doc->{'_tree'} = $self->load_tree($doc); } ### cache parsed_tree in memory unless asked not to do so if (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'}) { $doc->{'cache_time'} = time; if (ref $file) { $docs->{$doc->{'_filename'}} = $doc if $doc->{'_filename'}; } else { $docs->{$file} ||= $doc; } ### allow for config option to keep the cache size down if ($self->{'CACHE_SIZE'}) { if (scalar(keys %$docs) > $self->{'CACHE_SIZE'}) { my $n = 0; foreach my $file (sort {$docs->{$b}->{'cache_time'} <=> $docs->{$a}->{'cache_time'}} keys %$docs) { delete($docs->{$file}) if ++$n > $self->{'CACHE_SIZE'}; } } } } return $doc; } sub string_id { my ($self, $ref) = @_; require Digest::MD5; my $str = ref($self) && $self->{'ENCODING'} # ENCODING is defined && eval { require Encode } # Encode.pm is available && defined &Encode::encode ? Encode::encode($self->{'ENCODING'}, $$ref) : $$ref; my $sum = Digest::MD5::md5_hex($str); return 'Alloy_str_ref_cache/'.substr($sum,0,3).'/'.$sum; } sub load_tree { my ($self, $doc) = @_; ### first look for a compiled optree if ($doc->{'_filename'}) { $doc->{'modtime'} ||= (stat $doc->{'_filename'})[9]; if ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) { my $file = $doc->{'_filename'}; if ($self->{'COMPILE_DIR'}) { $file =~ y|:|/| if $^O eq 'MSWin32'; $file = $self->{'COMPILE_DIR'} .'/'. $file; } elsif ($doc->{'_is_str_ref'}) { $file = ($self->include_paths->[0] || '.') .'/'. $file; } $file .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'}); $file .= $EXTRA_COMPILE_EXT if defined $EXTRA_COMPILE_EXT; if (-e $file && ($doc->{'_is_str_ref'} || (stat $file)[9] == $doc->{'modtime'})) { require Storable; return Storable::retrieve($file); } $doc->{'_storable_filename'} = $file; } } ### no cached tree - we will need to load our own $doc->{'_content'} ||= $self->slurp($doc->{'_filename'}); if ($self->{'CONSTANTS'}) { my $key = $self->{'CONSTANT_NAMESPACE'} || 'constants'; $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'}; } local $self->{'_component'} = $doc; my $tree = eval { $self->parse_tree($doc->{'_content'}) } || do { my $e = $@; $e->doc($doc) if UNIVERSAL::can($e, 'doc') && ! $e->doc; die $e }; # errors die ### save a cache on the fileside as asked if ($doc->{'_storable_filename'}) { my $dir = $doc->{'_storable_filename'}; $dir =~ s|/[^/]+$||; if (! -d $dir) { require File::Path; File::Path::mkpath($dir); } require Storable; Storable::store($tree, $doc->{'_storable_filename'}); utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_storable_filename'}; } return $tree; } ###----------------------------------------------------------------### ### allow for resolving full expression ASTs sub play_expr { return $_[1] if ! ref $_[1]; # allow for the parse tree to store literals my $self = shift; my $var = shift; my $ARGS = shift || {}; my $i = 0; ### determine the top level of this particular variable access my $ref; my $name = $var->[$i++]; my $args = $var->[$i++]; if (ref $name) { if (! defined $name->[0]) { # operator return $self->play_operator($name) if wantarray && $name->[1] eq '..'; $ref = ($name->[1] eq '-temp-') ? $name->[2] : $self->play_operator($name); } else { # a named variable access (ie via $name.foo) $name = $self->play_expr($name); if (defined $name) { return if $QR_PRIVATE && $name =~ $QR_PRIVATE; # don't allow vars that begin with _ return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name}; $ref = $self->{'_vars'}->{$name}; } } } elsif (defined $name) { return if $QR_PRIVATE && $name =~ $QR_PRIVATE; # don't allow vars that begin with _ return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name}; $ref = $self->{'_vars'}->{$name}; if (! defined $ref) { $ref = ($name eq 'template' || $name eq 'component') ? $self->{"_$name"} : $VOBJS->{$name}; $ref = $ITEM_METHODS->{$name} || $ITEM_OPS->{$name} if ! $ref && (! defined($self->{'VMETHOD_FUNCTIONS'}) || $self->{'VMETHOD_FUNCTIONS'}); $ref = $self->{'_vars'}->{lc $name} if ! defined $ref && $self->{'LOWER_CASE_VAR_FALLBACK'}; } } my %seen_filters; while (defined $ref) { ### check at each point if the returned thing was a code if (UNIVERSAL::isa($ref, 'CODE')) { return $ref if $i >= $#$var && $ARGS->{'return_ref'}; my @args = $args ? map { $self->play_expr($_) } @$args : (); my $type = $self->{'CALL_CONTEXT'} || ''; if ($type eq 'item') { $ref = $ref->(@args); } else { my @results = $ref->(@args); if ($type eq 'list') { $ref = \@results; } elsif (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { $ref = undef; last; } } } ### descend one chained level last if $i >= $#$var; my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; $name = $var->[$i++]; $args = $var->[$i++]; ### allow for named portions of a variable name (foo.$name.bar) if (ref $name) { if (ref($name) eq 'ARRAY') { $name = $self->play_expr($name); if (! defined($name) || ($QR_PRIVATE && $name =~ $QR_PRIVATE) || $name =~ /^\./) { $ref = undef; last; } } else { die "Shouldn't get a ". ref($name) ." during a vivify on chain"; } } if (! defined $name || ($QR_PRIVATE && $name =~ $QR_PRIVATE)) { # don't allow vars that begin with _ $ref = undef; last; } ### allow for scalar and filter access (this happens for every non virtual method call) if (! ref $ref) { if ($ITEM_METHODS->{$name}) { # normal scalar op $ref = $ITEM_METHODS->{$name}->($self, $ref, $args ? map { $self->play_expr($_) } @$args : ()); } elsif ($ITEM_OPS->{$name}) { # normal scalar op $ref = $ITEM_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op $ref = $LIST_OPS->{$name}->([$ref], $args ? map { $self->play_expr($_) } @$args : ()); } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args || $FILTER_OPS->{$name} # predefined filters in Alloy || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash || $self->list_filters->{$name}) { # filter defined in Template::Filters if (UNIVERSAL::isa($filter, 'CODE')) { $ref = eval { $filter->($ref) }; # non-dynamic filter - no args if (my $err = $@) { $self->throw('filter', $err) if ! UNIVERSAL::can($err, 'type'); die $err; } } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters eval { my $sub = $filter->[0]; if ($filter->[1]) { # it is a "dynamic filter" that will return a sub ($sub, my $err) = $sub->($self->context, $args ? map { $self->play_expr($_) } @$args : ()); if (! $sub && $err) { $self->throw('filter', $err) if ! UNIVERSAL::can($err, 'type'); die $err; } elsif (! UNIVERSAL::isa($sub, 'CODE')) { $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") if ! UNIVERSAL::can($sub, 'type'); die $sub; } } $ref = $sub->($ref); }; if (my $err = $@) { $self->throw('filter', $err) if ! UNIVERSAL::can($err, 'type'); die $err; } } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree $i = 2; } if (scalar keys %seen_filters && $seen_filters{$var->[$i - 5] || ''}) { $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); } } else { $ref = undef; } } else { ### method calls on objects if ($was_dot_call && UNIVERSAL::can($ref, 'can')) { return $ref if $i >= $#$var && $ARGS->{'return_ref'}; my $type = $self->{'CALL_CONTEXT'} || ''; my @args = $args ? map { $self->play_expr($_) } @$args : (); if ($type eq 'item') { $ref = $ref->$name(@args); next; } elsif ($type eq 'list') { $ref = [$ref->$name(@args)]; next; } my @results = eval { $ref->$name(@args) }; if ($@) { my $class = ref $ref; die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/ || $type eq 'list'; } elsif (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; next; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { $ref = undef; last; } # didn't find a method by that name - so fail down to hash and array access } if (UNIVERSAL::isa($ref, 'HASH')) { if ($was_dot_call && exists($ref->{$name}) ) { return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->{$name}; $ref = $ref->{$name}; } elsif ($HASH_OPS->{$name}) { $ref = $HASH_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); } elsif ($ARGS->{'is_namespace_during_compile'}) { return $var; # abort - can't fold namespace variable } else { return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'}; $ref = undef; } } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { if ($name =~ m{ ^ -? $QR_INDEX $ }ox) { return \ $ref->[$name] if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->[$name]; $ref = $ref->[$name]; } elsif ($LIST_OPS->{$name}) { $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ()); } else { $ref = undef; } } else { $ref = undef; } } } # end of while if (! defined $ref) { $self->strict_throw($var) if $self->{'STRICT'}; # will die die $self->tt_var_string($var)." is undefined\n" if $self->{'_debug_undef'}; $ref = $self->undefined_any($var); } return $ref; } sub set_variable { my ($self, $var, $val, $ARGS) = @_; $ARGS ||= {}; my $i = 0; ### allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %]) $var = [$var, 0] if ! ref $var; ### determine the top level of this particular variable access my $ref = $var->[$i++]; my $args = $var->[$i++]; if (ref $ref) { ### non-named types can't be set return if ref($ref) ne 'ARRAY'; if (! defined $ref->[0]) { return if ! $ref->[1] || $ref->[1] !~ /^[\$\@]\(\)$/; # do allow @( ) $ref = $self->play_operator($ref); } else { # named access (ie via $name.foo) $ref = $self->play_expr($ref); if (defined $ref && (! $QR_PRIVATE || $ref !~ $QR_PRIVATE)) { # don't allow vars that begin with _ if ($#$var <= $i) { return $self->{'_vars'}->{$ref} = $val; } else { $ref = $self->{'_vars'}->{$ref} ||= {}; } } else { return; } } } elsif (defined $ref) { return if $QR_PRIVATE && $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ if ($#$var <= $i) { return $self->{'_vars'}->{$ref} = $val; } else { $ref = $self->{'_vars'}->{$ref} ||= {}; } } while (defined $ref) { ### check at each point if the returned thing was a code if (UNIVERSAL::isa($ref, 'CODE')) { my $type = $self->{'CALL_CONTEXT'} || ''; my @args = $args ? map { $self->play_expr($_) } @$args : (); if ($type eq 'item') { $ref = $ref->(@args); } else { my @results = $ref->(@args); if ($type eq 'list') { $ref = \@results; } elsif (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { return; } } } ### descend one chained level last if $i >= $#$var; my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; my $name = $var->[$i++]; my $args = $var->[$i++]; ### allow for named portions of a variable name (foo.$name.bar) if (ref $name) { if (ref($name) eq 'ARRAY') { $name = $self->play_expr($name); if (! defined($name) || $name =~ /^[_.]/) { return; } } else { die "Shouldn't get a ".ref($name)." during a vivify on chain"; } } if ($QR_PRIVATE && $name =~ $QR_PRIVATE) { # don't allow vars that begin with _ return; } ### scalar access if (! ref $ref) { return; ### method calls on objects } elsif (UNIVERSAL::can($ref, 'can')) { my $lvalueish; my $type = $self->{'CALL_CONTEXT'} || ''; my @args = $args ? map { $self->play_expr($_) } @$args : (); if ($i >= $#$var) { $lvalueish = 1; push @args, $val; } if ($type eq 'item') { $ref = $ref->$name(@args); return if $lvalueish; next; } elsif ($type eq 'list') { $ref = [$ref->$name(@args)]; return if $lvalueish; next; } my @results = eval { $ref->$name(@args) }; if (! $@) { if (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { return; } return if $lvalueish; next; } my $class = ref $ref; die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/; # fall on down to "normal" accessors } if (UNIVERSAL::isa($ref, 'HASH')) { if ($#$var <= $i) { return $ref->{$name} = $val; } else { $ref = $ref->{$name} ||= {}; next; } } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { if ($name =~ m{ ^ -? $QR_INDEX $ }ox) { if ($#$var <= $i) { return $ref->[$name] = $val; } else { $ref = $ref->[$name] ||= {}; next; } } else { return; } } } return; } ###----------------------------------------------------------------### sub _vars { my $self = shift; $self->{'_vars'} = shift if @_ == 1; return $self->{'_vars'} ||= {}; } sub include_filename { my ($self, $file) = @_; if ($file =~ m|^/|) { $self->throw('file', "$file absolute paths are not allowed (set ABSOLUTE option)") if ! $self->{'ABSOLUTE'}; return $file if -e $file; } elsif ($file =~ m{(^|/)\.\./}) { $self->throw('file', "$file relative paths are not allowed (set RELATIVE option)") if ! $self->{'RELATIVE'}; return $file if -e $file; } my @paths = @{ $self->include_paths }; if ($self->{'ADD_LOCAL_PATH'} && $self->{'_component'} && $self->{'_component'}->{'_filename'} && $self->{'_component'}->{'_filename'} =~ m|^(.+)/[^/]+$|) { ($self->{'ADD_LOCAL_PATH'} < 0) ? push(@paths, $1) : unshift(@paths, $1); } foreach my $path (@paths) { return "$path/$file" if -e "$path/$file"; } $self->throw('file', "$file: not found"); } sub include_paths { my $self = shift; return $self->{'INCLUDE_PATHS'} ||= do { # TT does this everytime a file is looked up - we are going to do it just in time - the first time my $paths = $self->{'INCLUDE_PATH'} || ['.']; $paths = $paths->() if UNIVERSAL::isa($paths, 'CODE'); $paths = $self->split_paths($paths) if ! UNIVERSAL::isa($paths, 'ARRAY'); $paths; # return of the do }; } sub split_paths { my ($self, $path) = @_; return $path if UNIVERSAL::isa($path, 'ARRAY'); my $delim = $self->{'DELIMITER'} || ':'; $delim = ($delim eq ':' && $^O eq 'MSWin32') ? qr|:(?!/)| : qr|\Q$delim\E|; return [split $delim, "$path"]; # allow objects to stringify as necessary } sub slurp { my ($self, $file) = @_; open(my $fh, '<', $file) || $self->throw('file', "$file couldn't be opened: $!"); read $fh, my $txt, -s $file; if ($self->{'ENCODING'}) { # thanks to Carl Franks for this addition eval { require Encode }; if ($@ || ! defined &Encode::decode) { warn "Encode module not found, 'ENCODING' config only available on perl >= 5.7.3\n$@"; } else { $txt = Encode::decode($self->{'ENCODING'}, $txt); } } return \$txt; } sub error { shift->{'error'} } sub exception { my $self_or_class = shift; my $type = shift; my $info = shift; return $type if UNIVERSAL::can($type, 'type'); if (ref($info) eq 'ARRAY') { my $hash = ref($info->[-1]) eq 'HASH' ? pop(@$info) : {}; if (@$info >= 2 || scalar keys %$hash) { my $i = 0; $hash->{$_} = $info->[$_] for 0 .. $#$info; $hash->{'args'} = $info; $info = $hash; } elsif (@$info == 1) { $info = $info->[0]; } else { $info = $type; $type = 'undef'; } } return Template::Alloy::Exception->new($type, $info, @_); } sub throw { die shift->exception(@_) } sub context { my $self = shift; require Template::Alloy::Context; return Template::Alloy::Context->new({_template => $self}); } sub iterator { my $self = shift; require Template::Alloy::Iterator; Template::Alloy::Iterator->new(@_); } sub undefined_get { my ($self, $ident, $node) = @_; return $self->{'UNDEFINED_GET'}->($self, $ident, $node) if $self->{'UNDEFINED_GET'}; return ''; } sub undefined_any { my ($self, $ident) = @_; return $self->{'UNDEFINED_ANY'}->($self, $ident) if $self->{'UNDEFINED_ANY'}; return; } sub strict_throw { my ($self, $ident) = @_; my $v = $self->tt_var_string($ident); my $temp = $self->{'_template'}->{'name'}; my $comp = $self->{'_component'}->{'name'}; my $msg = "undefined variable: $v in $comp".($comp ne $temp ? " while processing $temp" : ''); return $self->{'STRICT_THROW'}->($self, 'var.undef', $msg, {name => $v, component => $comp, template => $temp, ident => $ident}) if $self->{'STRICT_THROW'}; $self->throw('var.undef', $msg); } sub list_filters { shift->{'_filters'} ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {} } sub debug_node { my ($self, $node) = @_; my $info = $self->node_info($node); my $format = $self->{'_debug_format'} || $self->{'DEBUG_FORMAT'} || "\n## \$file line \$line : [% \$text %] ##\n"; $format =~ s{\$(file|line|text)}{$info->{$1}}g; return $format; } sub node_info { my ($self, $node) = @_; my $doc = $self->{'_component'}; my $i = $node->[1]; my $j = $node->[2] || return ''; # META can be 0 return { file => $doc->{'name'}, line => 'unknown', text => 'unknown', } if !$doc->{'_filename'} && !$doc->{'_content'}; $doc->{'_content'} ||= $self->slurp($doc->{'_filename'}); my $s = substr(${ $doc->{'_content'} }, $i, $j - $i); $s =~ s/^\s+//; $s =~ s/\s+$//; return { file => $doc->{'name'}, line => $self->get_line_number_by_index($doc, $i), text => $s, }; } sub get_line_number_by_index { my ($self, $doc, $index, $include_char) = @_; if (! $index || $index <= 0) { return $include_char ? (1, 1) : 1; } my $lines = $doc->{'_line_offsets'} ||= do { $doc->{'_content'} ||= $self->slurp($doc->{'_filename'}); my $i = 0; my @lines = (0); while (1) { $i = index(${ $doc->{'_content'} }, "\n", $i) + 1; last if $i == 0; push @lines, $i; } \@lines; }; ### binary search them (this is fast even on big docs) my ($i, $j) = (0, $#$lines); if ($index > $lines->[-1]) { $i = $j; } else { while (1) { last if abs($i - $j) <= 1; my $k = int(($i + $j) / 2); $j = $k if $lines->[$k] >= $index; $i = $k if $lines->[$k] <= $index; } } return $include_char ? ($i + 1, $index - $lines->[$i]) : $i + 1; } sub ast_string { my ($self, $var) = @_; return 'undef' if ! defined $var; return '['.join(', ', map { $self->ast_string($_) } @$var).']' if ref $var; return $var if $var =~ /^(-?[1-9]\d{0,13}|0)$/; $var =~ s/([\'\\])/\\$1/g; return "'$var'"; } sub tt_var_string { my ($self, $ident) = @_; if (! ref $ident) { return $ident if $ident eq '0' || $ident =~ /^[1-9]\d{0,12}$/; $ident =~ s/\'/\\\'/g; return "'$ident'"; } my $v = ''; for (my $i = 0; $i < @$ident; ) { $v .= $ident->[$i++]; $v .= '('.join(',',map{$self->tt_var_string($_)} @{$ident->[$i-1]}).')' if $ident->[$i++]; $v .= $ident->[$i++] if $i < @$ident; } return $v; } sub item_method_eval { my $self = shift; my $text = shift; return '' if ! defined $text; my $args = shift || {}; local $self->{'_eval_recurse'} = $self->{'_eval_recurse'} || 0; $self->throw('eval_recurse', "MAX_EVAL_RECURSE $Template::Alloy::MAX_EVAL_RECURSE reached") if ++$self->{'_eval_recurse'} > ($self->{'MAX_EVAL_RECURSE'} || $MAX_EVAL_RECURSE); my %ARGS; @ARGS{ map {uc} keys %$args } = values %$args; delete @ARGS{ grep {! $Template::Alloy::EVAL_CONFIG->{$_}} keys %ARGS }; $self->throw("eval_strict", "Cannot disable STRICT once it is enabled") if exists $ARGS{'STRICT'} && ! $ARGS{'STRICT'}; local @$self{ keys %ARGS } = values %ARGS; my $out = ''; $self->process_simple(\$text, $self->_vars, \$out) || $self->throw($self->error); return $out; } 1; ### See the perldoc in Template/Alloy.pod libtemplate-alloy-perl-1.022/lib/Template/Alloy.pod000066400000000000000000003027601402714000200222010ustar00rootroot00000000000000=head1 NAME Template::Alloy - TT2/3, HT, HTE, Tmpl, and Velocity Engine =head1 SYNOPSIS =head2 Template::Toolkit style usage my $t = Template::Alloy->new( INCLUDE_PATH => ['/path/to/templates'], ); my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; # print to STDOUT $t->process('my/template.tt', $swap) || die $t->error; # process into a variable my $out = ''; $t->process('my/template.tt', $swap, \$out); ### Alloy uses the same syntax and configuration as Template::Toolkit =head2 HTML::Template::Expr style usage my $t = Template::Alloy->new( filename => 'my/template.ht', path => ['/path/to/templates'], ); my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; $t->param($swap); # print to STDOUT (errors die) $t->output(print_to => \*STDOUT); # process into a variable my $out = $t->output; ### Alloy can also use the same syntax and configuration as HTML::Template =head2 Text::Tmpl style usage my $t = Template::Alloy->new; my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; $t->set_delimiters('#[', ']#'); $t->set_strip(0); $t->set_values($swap); $t->set_dir('/path/to/templates'); my $out = $t->parse_file('my/template.tmpl'); my $str = "Foo #[echo $key1]# Bar"; my $out = $t->parse_string($str); ### Alloy uses the same syntax and configuration as Text::Tmpl =head2 Velocity (VTL) style usage my $t = Template::Alloy->new; my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; my $out = $t->merge('my/template.vtl', $swap); my $str = "#set($foo 1 + 3) ($foo) ($bar) ($!baz)"; my $out = $t->merge(\$str, $swap); =head2 Javascript style usage (requires Template::Alloy::JS) my $t = Template::Alloy->new; my $swap = { key1 => 'val1', key2 => 'val2', code => sub { 42 }, hash => {a => 'b'}, }; my $out = ''; $t->process_js('my/template.jstem', $swap, \$out); my $str = "[% var foo = 1 + 3; write('(' + foo + ') (' + get('key1') + ')'); %]"; my $out = ''; $t->process_js(\$str, $swap, \$out); =head1 DESCRIPTION "An alloy is a homogeneous mixture of two or more elements" (http://en.wikipedia.org/wiki/Alloy). Template::Alloy represents the mixing of features and capabilities from all of the major mini-language based template systems (support for non-mini-language based systems will happen eventually). With Template::Alloy you can use your favorite template interface and syntax and get features from each of the other major template systems. And Template::Alloy is fast - whether your using mod_perl, CGI, or running from the commandline. There is even Template::Alloy::JS for getting a little more speed when that is necessary. Template::Alloy happened by accident (accidentally on purpose). The Template::Alloy (Alloy hereafter) was originally a part of the CGI::Ex suite that performed simple variable interpolation. It used TT2 style variables in TT2 style tags "[% foo.bar %]". That was all the original Template::Alloy did. This was fine and dandy for a couple of years. In winter of 2005-2006 Alloy was revamped to add a few features. One thing led to another and soon Alloy provided for most of the features of TT2 as well as some from TT3. Template::Alloy now provides a full-featured implementation of the Template::Toolkit language. After a move to a new company that was using HTML::Template::Expr and Text::Tmpl templates, support was investigated and interfaces for HTML::Template, HTML::Template::Expr, Text::Tmpl, and Velocity (VTL) were added. All of the various engines offer the same features - each using a different syntax and interface. More recently, the Template::Alloy::JS capabilities were introduced to bring Javascript templates to the server side (along with an increase in speed if ran in persistent environments). Template::Toolkit brought the most to the table. HTML::Template brought the LOOP directive. HTML::Template::Expr brought more vmethods and using vmethods as top level functions. Text::Tmpl brought the COMMENT directive and encouraged speed matching (Text::Tmpl is almost entirely C based and is very fast). The Velocity engine brought AUTO_EVAL and SHOW_UNDEFINED_INTERP. Most of the standard Template::Toolkit documentation covering directives, variables, configuration, plugins, filters, syntax, and vmethods should apply to Alloy just fine (This pod tries to explain everything - but there is too much). See L for a listing of the differences between Alloy and TT. Most of the standard HTML::Template and HTML::Template::Expr documentation covering methods, variables, expressions, and syntax will apply to Alloy just fine as well. Most of the standard Text::Tmpl documentation applies, as does the documentation covering Velocity (VTL). So should you use Template::Alloy ? Well, try it out. It may give you no visible improvement. Or it could. =head1 BACKEND Template::Alloy uses a recursive regex based grammar (early versions during the CGI::Ex::Template phase did not). This allows for the embedding of opening and closing tags inside other tags (as in [% a = "[% 1 + 2 %]" ; a|eval %]). The individual methods such as parse_expr and play_expr may be used by external applications to add TT style variable parsing to other applications. The regex parser returns an AST (abstract syntax tree) of the text, directives, variables, and expressions. All of the different template syntax options compile to the same AST format. The AST is composed only of scalars and arrayrefs and is suitable for sending to JavaScript via JSON or sharing with other languages. The parse_tree method is used for returning this AST. Once at the AST stage, there are two modes of operation. Alloy can either operate directly on the AST using the Play role, or it can compile the AST to perl code via the Compile role, and then execute the code. To use the perl code route, you must set the COMPILE_PERL flag to 1. If you are running in a cached-in-memory environment such as mod_perl, this is the fastest option. If you are running in a non-cached-in-memory environment, then using the Play role to run the AST is generally faster. The AST method is also more secure as cached AST won't ever eval any "perl" (assuming PERL blocks are disabled - which is the default). =head1 ROLES Template::Alloy has split out its functionality into discrete roles. In Template::Toolkit, this functionality is split into separate classes. The roles in Template::Alloy simply add on more methods to the main class. When Perl 6 arrives, these roles will be translated into true Roles. The following is a list of roles used by Template::Alloy. Template::Alloy::Compile - Compile-to-perl role Template::Alloy::HTE - HTML::Template::Expr role Template::Alloy::Operator - Operator role Template::Alloy::Parse - Parse-to-AST role Template::Alloy::Play - Play-AST role Template::Alloy::Stream - Stream output role Template::Alloy::Tmpl - Text::Tmpl role Template::Alloy::TT - Template::Toolkit role Template::Alloy::Velocity - Velocity role Template::Alloy::VMethod - Virtual methods role Template::Alloy::JS - Javascript functionality - available separately Template::Alloy automatically loads the roles when they are needed or requested - but not sooner (with the exception of the Operator role and the VMethod role which are always needed and always loaded). This is good for a CGI environment. In mod_perl you may want to preload a role to make the most of shared memory. You may do this by passing either the role name or a method supplied by that role. # import roles necessary for running TT use Template::Alloy qw(Parse Play Compile TT); # import roles based on methods use Template::Alloy qw(parse_tree play_tree compile_tree process); Note: importing roles by method names does not import them into that namespace - it is autoloading the role and methods into the Template::Alloy namespace. To help make this more clear you may use the following syntax as well. # import roles necessary for running TT use Template::Alloy load => qw(Parse Play Compile TT); # import roles based on methods use Template::Alloy load => qw(process parse_tree play_tree compile_tree); # import roles based on methods use Template::Alloy Parse => 1, Play => 1, Compile => 1, TT => 1; Even with all roles loaded Template::Alloy is still relatively small. You can load all of the roles (except the JS role) by passing "all" to the use statement. use Template::Alloy 'all'; # or use Template::Alloy load => 'all'; # or use Template::Alloy all => 1; As a final option, Template::Alloy also includes the ability to stand-in for other template modules. It is able to do this because it supports the majority of the interface of the other template systems. You can do this in the following way: use Template::Alloy qw(Text::Tmpl HTML::Template); # or use Template::Alloy load => qw(Text::Tmpl HTML::Template); # or use Template::Alloy 'Text::Tmpl' => 1, 'HTML::Template' => 1; Note that the use statement will die if any of the passed module names are already loaded and not subclasses of Template::Alloy. This will avoid thinking that you are using Template::Alloy when you really aren't. Using the 'all' option won't automatically do this - you must mention the "stood-in" modules by name. The following modules may be "stood-in" for: Template Text::Tmpl HTML::Template HTML::Template::Expr This feature is intended to make using Template::Alloy with existing code easier. Most cases should work just fine. Almost all syntax will just work (except Alloy may make some things work that were previously broken). However Template::Alloy doesn't support 100% of the interface of any of the template systems. If you are using "features-on-the-edge" then you may need to re-write portions of your code that interact with the template system. =head1 PUBLIC METHODS The following section lists most of the publicly available methods. Some less commonly used public methods are listed later in this document. =over 4 =item C my $obj = Template::Alloy->new({ INCLUDE_PATH => ['/my/path/to/content', '/my/path/to/content2'], }); Arguments may be passed as a hash or as a hashref. Returns a Template::Alloy object. There are currently no errors during Template::Alloy object creation. If you are using the HTML::Template interface, this is different behavior. The document is not parsed until the output or process methods are called. =item C This is the TT interface for starting processing. Any errors that result in the template processing being stopped will be stored and available via the ->error method. my $t = Template::Alloy->new; $t->process($in, $swap, $out) || die $t->error; Process takes three arguments. The $in argument can be any one of: String containing the filename of the template to be processed. The filename should be relative to INCLUDE_PATH. (See INCLUDE_PATH, ABSOLUTE, and RELATIVE configuration items). In memory caching and file side caching are available for this type. A reference to a scalar containing the contents of the template to be processed. A coderef that will be called to return the contents of the template. An open filehandle that will return the contents of the template when read. The $swap argument should be hashref containing key value pairs that will be available to variables swapped into the template. Values can be hashrefs, hashrefs of hashrefs and so on, arrayrefs, arrayrefs of arrayrefs and so on, coderefs, objects, and simple scalar values such as numbers and strings. See the section on variables. The $out argument can be any one of: undef - meaning to print the completed template to STDOUT. String containing a filename. The completed template will be placed in the file. A reference to a string. The contents will be appended to the scalar reference. A coderef. The coderef will be called with the contents as a single argument. An object that can run the method "print". The contents will be passed as a single argument to print. An arrayref. The contents will be pushed onto the array. An open filehandle. The contents will be printed to the open handle. Additionally - the $out argument can be configured using the OUTPUT configuration item. The process method defaults to using the "cet" syntax which will parse TT3 and most TT2 documents. To parse HT or HTE documents, you must pass the SYNTAX configuration item to the "new" method. All calls to process would then default to HTE syntax. my $obj = Template::Alloy->new(SYNTAX => 'hte'); =item C Similar to the process method but with the following restrictions: The $in parameter is limited to a filename or a reference a string containing the contents. The $out parameter may only be a reference to a scalar string that output will be appended to. Additionally, the following configuration variables will be ignored: VARIABLES, PRE_DEFINE, BLOCKS, PRE_PROCESS, PROCESS, POST_PROCESS, AUTO_RESET, OUTPUT. =item C Should something go wrong during a "process" command, the error that occurred can be retrieved via the error method. $obj->process('somefile.html', {a => 'b'}, \$string_ref) || die $obj->error; =item C HTML::Template way to process a template. The output method requires that a filename, filehandle, scalarref, or arrayref argument was passed to the new method. All of the HT calling conventions for new are supported. The key difference is that Alloy will not actually process the template until the output method is called. my $obj = Template::Alloy->new(filename => 'myfile.html'); $obj->param(\%swap); print $obj->output; See the HTML::Template documentation for more information. The output method defaults to using the "hte" syntax which will parse HTE and HT documents. To parse TT3 or TT2 documents, you must pass the SYNTAX configuration item to the "new" method. All calls to process would then default to TT3 syntax. my $obj = Template::Alloy->new(SYNTAX => 'tt3'); Any errors that occur during the output method will die with the error as the die value. =item C HTML::Template way to get or set variable values that will be used by the output method. my $val = $obj->param('key'); # get one value $obj->param(key => $val); # set one value $obj->param(key => $val, key2 => $val2); # set multiple $obj->param({key => $val, key2 => $val2}); # set multiple See the HTML::Template documentation for more information. Note: Alloy does not support the die_on_bad_params configuration. This is because Alloy does not resolve variable names until the output method is called. =item C This method is available for defining extra Virtual methods or filters. This method is similar to Template::Stash::define_vmethod. Template::Alloy->define_vmethod( 'text', reverse => sub { my $item = shift; return scalar reverse $item }, ); =item C This is the HTML::Template way of defining text vmethods. It is the same as calling define_vmethod with "text" as the first argument. Template::Alloy->register_function( reverse => sub { my $item = shift; return scalar reverse $item }, ); =item C This method can be used for adding new directives or overridding existing ones. Template::Alloy->define_directive( MYDIR => { parse_sub => sub {}, # parse additional items in the tag play_sub => sub { my ($self, $ref, $node, $out_ref) = @_; $$out_ref .= "I always say the same thing!"; return; }, is_block => 1, # is this block like is_postop => 0, # not a post operative directive no_interp => 1, # no interpolation in this block continues => undef, # it doesn't "continue" any other directives }, ); Now with a template like: my $str = "([% MYDIR %]This is something[% END %])"; Template::Alloy->new->process(\$str); You will get: (I always say the same thing!) We'll add more details in later revisions of this document. =item C This method can be used for adding another syntax to or overriding existing ones in the list of choices available in Alloy. The syntax can be chosen by the SYNTAX configuration item. Template::Alloy->define_syntax( my_uber_syntax => sub { my $self = shift; local $self->{'V2PIPE'} = 0; local $self->{'V2EQUALS'} = 0; local $self->{'PRE_CHOMP'} = 0; local $self->{'POST_CHOMP'} = 0; local $self->{'NO_INCLUDES'} = 0; return $self->parse_tree_tt3(@_); }, ); The subroutine that is used must return an opcode tree (AST) that can be played by the execute_tree method. =item C This method allows for adding new operators or overriding existing ones. Template::Alloy->define_operator({ type => 'right', # can be one of prefix, postfix, right, left, none, ternary, assign precedence => 84, # relative precedence for resolving multiple operators without parens symbols => ['foo', 'FOO'], # any mix of chars can be used for the operators play_sub => sub { my ($one, $two) = @_; return "You've been foo'ed ($one, $two)"; }, }); You can then use it in a template as in the following: my $str = "[% 'ralph' foo 1 + 2 * 3 %]"; Template::Alloy->new->process(\$str); You will get: You've been foo'ed (ralph, 7) Future revisions of this document will include more samples. This is an experimental feature and the API will probably change. =item C This method allows for returning a Data::Dumper dump of a parsed template. It is mainly used for testing. =item C This method allows for returning a Data::Dumper dump of a parsed variable. It is mainly used for testing. =item C All of the arguments that can be passed to "use" that are listed above in the section dealing with ROLES, can be used with the import method. # import by role Template::Alloy->import(qw(Compile Play Parse TT)); # import by method Template::Alloy->import(qw(compile_tree play_tree parse_tree process)); # import by "stand-in" class Template::Alloy->import('Text::Tmpl', 'HTML::Template::Expr'); As mentioned in the ROLE section - arguments passed to import are not imported into current namespace. Roles and methods are only imported into the Template::Alloy namespace. =back =head1 VARIABLES This section discusses how to use variables and expressions in the TT mini-language. A variable is the most simple construct to insert into the TT mini language. A variable name will look for the matching value inside Template::Alloys internal stash of variables which is essentially a hash reference. This stash is initially populated by either passing a hashref as the second argument to the process method, or by setting the "VARIABLES" or "PRE_DEFINE" configuration variables. If you are using either the HT or the HTE syntax, the VAR, IF, UNLESS, LOOP, and INCLUDE directives will accept a NAME attribute which may only be a single level (non-chained) HTML::Template variable name, or they may accept an EXPR attribute which may be any valid TT3 variable or expression. The following are some sample ways to access variables. ### some sample variables my %vars = ( one => '1.0', foo => 'bar', vname => 'one', some_code => sub { "You passed me (".join(', ', @_).")" }, some_data => { a => 'A', bar => 3234, c => [3, 1, 4, 1, 5, 9], vname => 'one', }, my_list => [20 .. 50], cet => Template::Alloy->new, ); ### pass the variables into the Alloy process $cet->process($template_name, \%vars) || die $cet->error; ### pass the variables during object creation (will be available to every process call) my $cet = Template::Alloy->new(VARIABLES => \%vars); =head2 GETTING VARIABLES Once you have variables defined, they can be used directly in the template by using their name in the stash. Or by using the GET directive. [% foo %] [% one %] [% GET foo %] Would print when processed: bar 1.0 bar To access members of a hashref or an arrayref, you can chain together the names using a ".". [% some_data.a %] [% my_list.0] [% my_list.1 %] [% my_list.-1 %] [% some_data.c.2 %] Would print: A 20 21 50 4 If the value of a variable is a code reference, it will be called. You can add a set of parenthesis and arguments to pass arguments. Arguments are variables and can be as complex as necessary. [% some_code %] [% some_code() %] [% some_code(foo) %] [% some_code(one, 2, 3) %] Would print: You passed me (). You passed me (). You passed me (bar). You passed me (1.0, 2, 3). If the value of a variable is an object, methods can be called using the "." operator. [% cet %] [% cet.dump_parse_expr('1 + 2').replace('\s+', ' ') %] Would print something like: Template::Alloy=HASH(0x814dc28) $VAR1 = [ [ undef, '+', '1', '2' ], 0 ]; Each type of data (string, array and hash) have virtual methods associated with them. Virtual methods allow for access to functions that are commonly used on those types of data. For the full list of built in virtual methods, please see the section titled VIRTUAL METHODS [% foo.length %] [% my_list.size %] [% some_data.c.join(" | ") %] Would print: 3 31 3 | 1 | 4 | 5 | 9 It is also possible to "interpolate" variable names using a "$". This allows for storing the name of a variable inside another variable. If a variable name is a little more complex it can be embedded inside of "${" and "}". [% $vname %] [% ${vname} %] [% ${some_data.vname} %] [% some_data.$foo %] [% some_data.${foo} %] Would print: 1.0 1.0 1.0 3234 3234 In Alloy it is also possible to embed any expression (non-directive) in "${" and "}" and it is possible to use non-integers for array access. (This is not available in TT2) [% ['a'..'z'].${ 2.3 } %] [% {ab => 'AB'}.${ 'a' ~ 'b' } %] [% color = qw/Red Blue/; FOR [1..4] ; color.${ loop.index % color.size } ; END %] Would print: c AB RedBlueRedBlue =head2 SETTING VARIABLES. To define variables during processing, you can use the = operator. In most cases this is the same as using the SET directive. [% a = 234 %][% a %] [% SET b = "Hello" %][% b %] Would print: 234 Hello It is also possible to create arrayrefs and hashrefs. [% a = [1, 2, 3] %] [% b = {key1 => 'val1', 'key2' => 'val2'} %] [% a.1 %] [% b.key1 %] [% b.key2 %] Would print: 2 val1 val2 It is possible to set multiple values in the same SET directive. [% SET a = 'A' b = 'B' c = 'C' %] [% a %] [% b %] [% c %] Would print: A B C It is also possible to unset variables, or to set members of nested data structures. [% a = 1 %] [% SET a %] [% b.0.c = 37 %] ([% a %]) [% b.0.c %] Would print () 37 =head1 LITERALS AND CONSTRUCTORS The following are the types of literals (numbers and strings) and constructors (hash and array constructs) allowed in Alloy. They can be used as arguments to functions, in place of variables in directives, and in place of variables in expressions. In Alloy it is also possible to call virtual methods on literal values. =over 4 =item Integers and Numbers. [% 23423 %] Prints an integer. [% 3.14159 %] Prints a number. [% pi = 3.14159 %] Sets the value of the variable. [% 3.13159.length %] Prints 7 (the string length of the number) Scientific notation is supported. [% 314159e-5 + 0 %] Prints 3.14159. [% .0000001.fmt('%.1e') %] Prints 1.0e-07 Hexadecimal input is also supported. [% 0xff + 0 %] Prints 255 [% 48875.fmt('%x') %] Prints beeb =item Single quoted strings. Returns the string. No variable interpolation happens. [% 'foobar' %] Prints "foobar". [% '$foo\n' %] Prints "$foo\\n". # the \\n is a literal "\" and an "n" [% 'That\'s nice' %] Prints "That's nice". [% str = 'A string' %] Sets the value of str. [% 'A string'.split %] Splits the string on ' ' and returns the list. Note: virtual methods can only be used on literal strings in Alloy, not in TT. You may also embed the current tags in strings (Alloy only). [% '[% 1 + 2 %]' | eval %] Prints "3" =item Double quoted strings. Returns the string. Variable interpolation happens. [% "foobar" %] Prints "foobar". [% "$foo" %] Prints "bar" (assuming the value of foo is bar). [% "${foo}" %] Prints "bar" (assuming the value of foo is bar). [% "foobar\n" %] Prints "foobar\n". # the \n is a newline. [% str = "Hello" %] Sets the value of str. [% "foo".replace('foo','bar') %] Prints "bar". Note: virtual methods can only be used on literal strings in Alloy, not in TT. You may also embed the current tags in strings (Alloy only). [% "[% 1 + 2 %]" | eval %] Prints "3" =item Array Constructs. [% [1, 2, 3] %] Prints something like ARRAY(0x8309e90). [% array1 = [1 .. 3] %] Sets the value of array1. [% array2 = [foo, 'a', []] %] Sets the value of array2. [% [4, 5, 6].size %] Prints 3. [% [7, 8, 9].reverse.0 %] Prints 9. Note: virtual methods can only be used on array contructs in Alloy, not in TT. =item Quoted Array Constructs. [% qw/1 2 3/ %] Prints something like ARRAY(0x8309e90). [% array1 = qw{Foo Bar Baz} %] Sets the value of array1. [% qw[4 5 6].size %] Prints 3. [% qw(Red Blue).reverse.0 %] Prints Blue. Note: this works in Alloy and is planned for TT3. =item Hash Constructs. [% {foo => 'bar'} %] Prints something like HASH(0x8305880) [% hash = {foo => 'bar', c => {}} %] Sets the value of hash. [% {a => 'A', b => 'B'}.size %] Prints 2. [% {'a' => 'A', 'b' => 'B'}.size %] Prints 2. [% name = "Tom" %] [% {Tom => 'You are Tom', Kay => 'You are Kay'}.$name %] Prints You are Tom Note: virtual methods can only be used on hash contructs in Alloy, not in TT. =item Regex Constructs. [% /foo/ %] Prints (?-xism:foo) [% a = /(foo)/i %][% "FOO".match(a).0 %] Prints FOO Note: this works in Alloy and is planned for TT3. =back =head1 VIRTUAL METHODS Virtual methods (vmethods) are a TT feature that allow for operating on the swapped template variables. This document shows some samples of using vmethods. For a full listing of available virtual methods, see L. =head1 EXPRESSIONS Expressions are one or more variables or literals joined together with operators. An expression can be used anywhere a variable can be used with the exception of the variable name in the SET directive, and the filename of PROCESS, INCLUDE, WRAPPER, and INSERT. For a full listing of operators, see L. The following section shows some samples of expressions. For a full list of available operators, please see the section titled OPERATORS. [% 1 + 2 %] Prints 3 [% 1 + 2 * 3 %] Prints 7 [% (1 + 2) * 3 %] Prints 9 [% x = 2 %] # assignments don't return anything [% (x = 2) %] Prints 2 # unless they are in parens [% y = 3 %] [% x * (y - 1) %] Prints 4 =head1 DIRECTIVES This section contains the alphabetical list of DIRECTIVES available in Alloy. DIRECTIVES are the "functions" and control structures that work in the various mini-languages. For further discussion and examples beyond what is listed below, please refer to the TT directives documentation or to the appropriate documentation for the particular directive. The examples given in this section are done using the Template::Toolkit syntax, but can be done in any of the various syntax options. See L, L, L, and L. [% IF 1 %]One[% END %] [% FOREACH a = [1 .. 3] %] a = [% a %] [% END %] [% SET a = 1 %][% SET a = 2 %][% GET a %] In TT multiple directives can be inside the same set of '[%' and '%]' tags as long as they are separated by space or semi-colons (;) (The Alloy version of Tmpl allows multiple also - but none of the other syntax options do). Any block directive that can also be used as a post-operative directive (such as IF, WHILE, FOREACH, UNLESS, FILTER, and WRAPPER) must be separated from preceding directives with a semi-colon if it is being used as a block directive. It is more safe to always use a semi-colon. Note: separating by space is only available in Alloy but is a planned TT3 feature. [% SET a = 1 ; SET a = 2 ; GET a %] [% SET a = 1 SET a = 2 GET a %] [% GET 1 IF 0 # is a post-operative GET 2 %] # prints 2 [% GET 1; IF 0 # it is block based GET 2 END %] # prints 1 The following is the list of directives. =over 4 =item C Saves a block of text under a name for later use in PROCESS, INCLUDE, and WRAPPER directives. Blocks may be placed anywhere within the template being processed including after where they are used. [% BLOCK foo %]Some text[% END %] [% PROCESS foo %] Would print Some text [% INCLUDE foo %] [% BLOCK foo %]Some text[% END %] Would print Some text Anonymous BLOCKS can be used for capturing. [% a = BLOCK %]Some text[% END %][% a %] Would print Some text Anonymous BLOCKS can be used with macros. =item C Alias for LAST. Used for exiting FOREACH and WHILE loops. =item C Calls the variable (and any underlying coderefs) as in the GET method, but always returns an empty string. =item C Used with the SWITCH directive. See the L directive. =item C Used with the TRY directive. See the L directive. =item C Clears any of the content currently generated in the innermost block or template. This can be useful when used in conjunction with the TRY statement to clear generated content if an error occurs later. =item C Will comment out any text found between open and close tags. Note, that the intermediate items are still parsed and END tags must align - but the parsed content will be discarded. [% COMMENT %] This text won't be shown. [% IF 1 %]And this won't either.[% END %] [% END %] =item C Allow for changing the value of some compile time and runtime configuration options. [% CONFIG ANYCASE => 1 PRE_CHOMP => '-' %] The following compile time configuration options may be set: ANYCASE AUTO_EVAL AUTO_FILTER CACHE_STR_REFS ENCODING INTERPOLATE POST_CHOMP PRE_CHOMP SEMICOLONS SHOW_UNDEFINED_INTERP SYNTAX V1DOLLAR V2EQUALS V2PIPE The following runtime configuration options may be set: ADD_LOCAL_PATH CALL_CONTEXT DUMP VMETHOD_FUNCTIONS STRICT (can only be enabled, cannot be disabled) If non-named parameters as passed, they will show the current configuration: [% CONFIG ANYCASE, PRE_CHOMP %] CONFIG ANYCASE = undef CONFIG PRE_CHOMP = undef =item C Used to reset the DEBUG_FORMAT configuration variable, or to turn DEBUG statements on or off. This only has effect if the DEBUG_DIRS or DEBUG_ALL flags were passed to the DEBUG configuration variable. [% DEBUG format '($file) (line $line) ($text)' %] [% DEBUG on %] [% DEBUG off %] =item C Similar to SET, but only sets the value if a previous value was not defined or was zero length. [% DEFAULT foo = 'bar' %][% foo %] => 'bar' [% foo = 'baz' %][% DEFAULT foo = 'bar' %][% foo %] => 'baz' =item C DUMP inserts a Data::Dumper printout of the variable or expression. If no argument is passed it will dump the entire contents of the current variable stash (with private keys removed). The output also includes the current file and line number that the DUMP directive was called from. See the DUMP configuration item for ways to customize and control the output available to the DUMP directive. [% DUMP %] # dumps everything [% DUMP 1 + 2 %] =item C Used with the IF directive. See the L directive. =item C Used with the IF directive. See the L directive. =item C Used to end a block directive. =item C Same as the EVALUATE directive. =item C Introduced by the Velocity templating language. Parses and processes the contents of the passed item. This is similar to the eval filter, but Velocity needs a directive. Named arguments may be used for re-configuring the parser. Any of the items that can be passed to the CONFIG directive may be passed here. [% EVALUATE "[% 1 + 3 %]" %] [% foo = "bar" %] [% EVALUATE "" SYNTAX => 'ht' %] =item C Used to apply different treatments to blocks of text. It may operate as a BLOCK directive or as a post operative directive. Alloy supports all of the filters in Template::Filters. The lines between scalar virtual methods and filters is blurred (or non-existent) in Alloy. Anything that is a scalar virtual method may be used as a FILTER. TODO - enumerate the at least 7 ways to pass and use filters. =item C<'|'> Alias for the FILTER directive. Note that | is similar to the '.' in Template::Alloy. Therefore a pipe cannot be used directly after a variable name in some situations (the pipe will act only on that variable). This is the behavior employed by TT3. To get the TT2 behavior for a PIPE, use the V2PIPE configuration item. =item C Used with the TRY directive. See the L directive. =item C Alias for FOREACH =item C Allows for iterating over the contents of any arrayref. If the variable is not an arrayref, it is automatically promoted to one. [% FOREACH i IN [1 .. 3] %] The variable i = [% i %] [%~ END %] [% a = [1 .. 3] %] [% FOREACH j IN a %] The variable j = [% j %] [%~ END %] Would print: The variable i = 1 The variable i = 2 The variable i = 3 The variable j = 1 The variable j = 2 The variable j = 3 You can also use the "=" instead of "IN" or "in". [% FOREACH i = [1 .. 3] %] The variable i = [% i %] [%~ END %] Same as before. Setting into a variable is optional. [% a = [1 .. 3] %] [% FOREACH a %] Hi [% END %] Would print: hi hi hi If the item being iterated is a hashref and the FOREACH does not set into a variable, then values of the hashref are copied into the variable stash. [% FOREACH [{a => 1}, {a => 2}] %] Key a = [% a %] [%~ END %] Would print: Key a = 1 Key a = 2 The FOREACH process uses the Template::Alloy::Iterator class to handle iterations (It is compatible with Template::Iterator). During the FOREACH loop an object blessed into the iterator class is stored in the variable "loop". The loop variable provides the following information during a FOREACH: index - the current index max - the max index of the list size - the number of items in the list count - index + 1 number - index + 1 first - true if on the first item last - true if on the last item next - return the next item in the list prev - return the previous item in the list odd - return 1 if the current count is odd, 0 otherwise even - return 1 if the current count is even, 0 otherwise parity - return "odd" if the current count is odd, "even" otherwise The following: [% FOREACH [1 .. 3] %] [% loop.count %]/[% loop.size %] [% END %] Would print: 1/3 2/3 3/3 The iterator is also available using a plugin. This allows for access to multiple "loop" variables in a nested FOREACH directive. [%~ USE outer_loop = Iterator(["a", "b"]) %] [%~ FOREACH i = outer_loop %] [%~ FOREACH j = ["X", "Y"] %] [% outer_loop.count %]-[% loop.count %] = ([% i %] and [% j %]) [%~ END %] [%~ END %] Would print: 1-1 = (a and X) 1-2 = (a and Y) 2-1 = (b and X) 2-2 = (b and Y) FOREACH may also be used as a post operative directive. [% "$i" FOREACH i = [1 .. 5] %] => 12345 =item C Return the value of a variable or expression. [% GET a %] The GET keyword may be omitted. [% a %] [% 7 + 2 - 3 %] => 6 See the section on VARIABLES. =item C Allows for conditional testing. Expects an expression as its only argument. If the expression is true, the contents of its block are processed. If false, the processor looks for an ELSIF block. If an ELSIF's expression is true then it is processed. Finally it looks for an ELSE block which is processed if none of the IF or ELSIF's expressions were true. [% IF a == b %]A equaled B[% END %] [% IF a == b -%] A equaled B [%- ELSIF a == c -%] A equaled C [%- ELSE -%] Couldn't determine that A equaled anything. [%- END %] IF may also be used as a post operative directive. [% 'A equaled B' IF a == b %] Note: If you are using HTML::Template style documents, the TMPL_IF tag parses using the limited HTML::Template parsing rules. However, you may use EXPR="" to embed a TT3 style expression. =item C Parse the contents of a file or block and insert them. Variables defined or modifications made to existing variables are discarded after a template is included. [% INCLUDE path/to/template.html %] [% INCLUDE "path/to/template.html" %] [% file = "path/to/template.html" %] [% INCLUDE $file %] [% BLOCK foo %]This is foo[% END %] [% INCLUDE foo %] Arguments may also be passed to the template: [% INCLUDE "path/to/template.html" a = "An arg" b = "Another arg" %] Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE or RELATIVE configuration items are set. Multiple filenames can be passed by separating them with a plus, a space, or commas (TT2 doesn't support the comma). Any supplied arguments will be used on all templates. [% INCLUDE "path/to/template.html", "path/to/template2.html" a = "An arg" b = "Another arg" %] On Perl 5.6 on some platforms there may be some issues with the variable localization. There is no problem on 5.8 and greater. =item C Insert the contents of a file without template parsing. Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE or RELATIVE configuration items are set. Multiple filenames can be passed by separating them with a plus, a space, or commas (TT2 doesn't support the comma). [% INSERT "path/to/template.html", "path/to/template2.html" %] =item C Only available if the COMPILE_JS configuration item is true (default is false). This requires the L module to be installed. Allow eval'ing the block of text as javascript. The block will be parsed and then eval'ed. [% a = "BimBam" %] [%~ JS %] write('The variable a was "' + get('a') + '"'); set('b', "FooBar"); [% END %] [% b %] Would print: The variable a was "BimBam" FooBar =item C Used to exit out of a WHILE or FOREACH loop. =item C This directive operates similar to the HTML::Template loop directive. The LOOP directive expects a single variable name. This variable name should point to an arrayref of hashrefs. The keys of each hashref will be added to the variable stash when it is iterated. [% var a = [{b => 1}, {b => 2}, {b => 3}] %] [% LOOP a %] ([% b %]) [% END %] Would print: (1) (2) (3) If Alloy is in HT mode and GLOBAL_VARS is false, the contents of the hashref will be the only items available during the loop iteration. If LOOP_CONTEXT_VARS is true, and $QR_PRIVATE is false (default when called through the output method), then the variables __first__, __last__, __inner__, __odd__, and __counter__ will be set. See the HTML::Template loop_context_vars configuration item for more information. =item C Takes a directive and turns it into a variable that can take arguments. [% MACRO foo(i, j) BLOCK %]You passed me [% i %] and [% j %].[% END %] [%~ foo("a", "b") %] [% foo(1, 2) %] Would print: You passed me a and b. You passed me 1 and 2. Another example: [% MACRO bar(max) FOREACH i = [1 .. max] %]([% i %])[% END %] [%~ bar(4) %] Would print: (1)(2)(3)(4) Starting with version 1.012 of Template::Alloy there is also a macro operator. [% foo = ->(i,j){ "You passed me $i and $j" } %] [% bar = ->(max){ FOREACH i = [1 .. max]; i ; END } %] See the Template::Alloy::Operator documentation for more examples. =item C Used to define variables that will be available via either the template or component namespace. Once defined, they cannot be overwritten. [% template.foobar %] [%~ META foobar = 'baz' %] [%~ META foobar = 'bing' %] Would print: baz =item C Used to go to the next iteration of a WHILE or FOREACH loop. =item C Only available if the EVAL_PERL configuration item is true (default is false). Allow eval'ing the block of text as perl. The block will be parsed and then eval'ed. [% a = "BimBam" %] [%~ PERL %] my $a = "[% a %]"; print "The variable \$a was \"$a\""; $stash->set('b', "FooBar"); [% END %] [% b %] Would print: The variable $a was "BimBam" FooBar During execution, anything printed to STDOUT will be inserted into the template. Also, the $stash and $context variables are set and are references to objects that mimic the interface provided by Template::Context and Template::Stash. These are provided for compatibility only. $self contains the current Template::Alloy object. =item C Parse the contents of a file or block and insert them. Unlike INCLUDE, no variable localization happens so variables defined or modifications made to existing variables remain after the template is processed. [% PROCESS path/to/template.html %] [% PROCESS "path/to/template.html" %] [% file = "path/to/template.html" %] [% PROCESS $file %] [% BLOCK foo %]This is foo[% END %] [% PROCESS foo %] Arguments may also be passed to the template: [% PROCESS "path/to/template.html" a = "An arg" b = "Another arg" %] Filenames must be relative to INCLUDE_PATH unless the ABSOLUTE or RELATIVE configuration items are set. Multiple filenames can be passed by separating them with a plus, a space, or commas (TT2 doesn't support the comma). Any supplied arguments will be used on all templates. [% PROCESS "path/to/template.html", "path/to/template2.html" a = "An arg" b = "Another arg" %] =item C Only available if the EVAL_PERL configuration item is true (default is false). Similar to the PERL directive, but you will need to append to the $output variable rather than just calling PRINT. =item C Used to exit the innermost block or template and continue processing in the surrounding block or template. There are two changes from TT2 behavior. First, In Alloy, a RETURN during a MACRO call will only exit the MACRO. Second, the RETURN directive takes an optional variable name or expression, if passed, the MACRO will return this value instead of the normal text from the MACRO. The process_simple method will also return this value. You can also use the item, list, and hash return vmethods. [% RETURN %] # just exits [% RETURN "foo" %] # return value is foo [% "foo".return %] # same thing =item C Used to set variables. [% SET a = 1 %][% a %] => "1" [% a = 1 %][% a %] => "1" [% b = 1 %][% SET a = b %][% a %] => "1" [% a = 1 %][% SET a %][% a %] => "" [% SET a = [1, 2, 3] %][% a.1 %] => "2" [% SET a = {b => 'c'} %][% a.b %] => "c" =item C Used to exit the entire process method (out of all blocks and templates). No content will be processed beyond this point. =item C Allow for SWITCH and CASE functionality. [% a = "hi" %] [% b = "bar" %] [% SWITCH a %] [% CASE "foo" %]a was foo [% CASE b %]a was bar [% CASE ["hi", "hello"] %]You said hi or hello [% CASE DEFAULT %]I don't know what you said [% END %] Would print: You said hi or hello =item C Change the type of enclosing braces used to delineate template tags. This remains in effect until the end of the enclosing block or template or until the next TAGS directive. Either a named set of tags must be supplied, or two tags themselves must be supplied. [% TAGS html %] [% TAGS %] The named tags are (duplicated from TT): asp => ['<%', '%>' ], # ASP default => ['\[%', '%\]' ], # default html => ['' ], # HTML comments mason => ['<%', '>' ], # HTML::Mason metatext => ['%%', '%%' ], # Text::MetaText php => ['<\?', '\?>' ], # PHP star => ['\[\*', '\*\]' ], # TT alternate template => ['\[%', '%\]' ], # Normal Template Toolkit template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style tt2 => ['\[%', '%\]' ], # TT2 If custom tags are supplied, by default they are escaped using quotemeta. You may also pass explicitly quoted strings, or regular expressions as arguments as well (if your regex begins with a ', ", or / you must quote it. [% TAGS [<] [>] %] matches "[<] tag [>]" [% TAGS '[<]' '[>]' %] matches "[<] tag [>]" [% TAGS "[<]" "[>]" %] matches "[<] tag [>]" [% TAGS /[<]/ /[>]/ %] matches "< tag >" [% TAGS ** ** %] matches "** tag **" [% TAGS /**/ /**/ %] Throws an exception. You should be sure that the start tag does not include grouping parens or INTERPOLATE will not function properly. =item C Allows for throwing an exception. If the exception is not caught via the TRY DIRECTIVE, the template will abort processing of the directive. [% THROW mytypes.sometime 'Something happened' arg1 => val1 %] See the TRY directive for examples of usage. =item C The TRY block directive will catch exceptions that are thrown while processing its block (It cannot catch parse errors unless they are in included files or evaltt'ed strings. The TRY block will then look for a CATCH block that will be processed. While it is being processed, the "error" variable will be set with the thrown exception as the value. After the TRY block - the FINAL block will be ran whether or not an error was thrown (unless a CATCH block throws an error). Note: Parse errors cannot be caught unless they are in an eval FILTER, or are in a separate template being INCLUDEd or PROCESSed. [% TRY %] Nothing bad happened. [% CATCH %] Caught the error. [% FINAL %] This section runs no matter what happens. [% END %] Would print: Nothing bad happened. This section runs no matter what happens. Another example: [% TRY %] [% THROW "Something happened" %] [% CATCH %] Error: [% error %] Error.type: [% error.type %] Error.info: [% error.info %] [% FINAL %] This section runs no matter what happens. [% END %] Would print: Error: undef error - Something happened Error.type: undef Error.info: Something happened This section runs no matter what happens. You can give the error a type and more information including named arguments. This information replaces the "info" property of the exception. [% TRY %] [% THROW foo.bar "Something happened" "grrrr" foo => 'bar' %] [% CATCH %] Error: [% error %] Error.type: [% error.type %] Error.info: [% error.info %] Error.info.0: [% error.info.0 %] Error.info.1: [% error.info.1 %] Error.info.args.0: [% error.info.args.0 %] Error.info.foo: [% error.info.foo %] [% END %] Would print something like: Error: foo.bar error - HASH(0x82a395c) Error.type: foo.bar Error.info: HASH(0x82a395c) Error.info.0: Something happened Error.info.1: grrrr Error.info.args.0: Something happened Error.info.foo: bar You can also give the CATCH block a type to catch. And you can nest TRY blocks. If types are specified, Alloy will try and find the closest matching type. Also, an error object can be re-thrown using $error as the argument to THROW. [% TRY %] [% TRY %] [% THROW foo.bar "Something happened" %] [% CATCH bar %] Caught bar. [% CATCH DEFAULT %] Caught default - but re-threw. [% THROW $error %] [% END %] [% CATCH foo %] Caught foo. [% CATCH foo.bar %] Caught foo.bar. [% CATCH %] Caught anything else. [% END %] Would print: Caught default - but re-threw. Caught foo.bar. =item C Same as IF but condition is negated. [% UNLESS 0 %]hi[% END %] => hi Can also be a post operative directive. =item C Allows for loading a Template::Toolkit style plugin. [% USE iter = Iterator(['foo', 'bar']) %] [%~ iter.get_first %] [% iter.size %] Would print: foo 2 Note that it is possible to send arguments to the new object constructor. It is also possible to omit the variable name being assigned. In that case the name of the plugin becomes the variable. [% USE Iterator(['foo', 'bar', 'baz']) %] [%~ Iterator.get_first %] [% Iterator.size %] Would print: foo 3 Plugins that are loaded are looked up for in the namespace listed in the PLUGIN_BASE directive which defaults to Template::Plugin. So in the previous example, if Template::Toolkit was installed, the iter object would loaded by the class Template::Plugin::Iterator. In Alloy, an effective way to disable plugins is to set the PLUGIN_BASE to a non-existent base such as "_" (In TT it will still fall back to look in Template::Plugin). Note: The iterator plugin will fall back and use Template::Alloy::Iterator if Template::Toolkit is not installed. No other plugins come installed with Template::Alloy. The names of the Plugin being loaded from PLUGIN_BASE are case insensitive. However, using case insensitive names is bad as it requires scanning the @INC directories for any module matching the PLUGIN_BASE and caching the result (OK - not that bad). If the plugin is not found and the LOAD_PERL directive is set, then Alloy will try and load a module by that name (note: this type of lookup is case sensitive and will not scan the @INC dirs for a matching file). # The LOAD_PERL directive should be set to 1 [% USE ta = Template::Alloy %] [%~ ta.dump_parse_expr('2 * 3') %] Would print: [[undef, '*', 2, 3], 0]; See the PLUGIN_BASE, and PLUGINS configuration items. See the documentation for Template::Manual::Plugins. =item C Implement a TT style view. For more information, please see the Template::View documentation. This DIRECTIVE will correctly parse the arguments and then pass them along to a newly created Template::View object. It will fail if Template::View can not be found. =item C Will process a block of code while a condition is true. [% WHILE i < 3 %] [%~ i = i + 1 %] i = [% i %] [%~ END %] Would print: i = 1 i = 2 i = 3 You could also do: [% i = 4 %] [% WHILE (i = i - 1) %] i = [% i %] [%~ END %] Would print: i = 3 i = 2 i = 1 Note that (f = f - 1) is a valid expression that returns the value of the assignment. The parenthesis are not optional. WHILE has a built in limit of 1000 iterations. This is controlled by the global variable $WHILE_MAX in Template::Alloy. WHILE may also be used as a post operative directive. [% "$i" WHILE (i = i + 1) < 7 %] => 123456 =item C Block directive. Processes contents of its block and then passes them in the [% content %] variable to the block or filename listed in the WRAPPER tag. [% WRAPPER foo b = 23 %] My content to be processed ([% b %]).[% a = 2 %] [% END %] [% BLOCK foo %] A header ([% a %]). [% content %] A footer ([% a %]). [% END %] This would print. A header (2). My content to be processed (23). A footer (2). The WRAPPER directive may also be used as a post operative directive. [% BLOCK baz %]([% content %])[% END -%] [% "foobar" WRAPPER baz %] Would print (foobar)'); Multiple filenames can be passed by separating them with a plus, a space, or commas (TT2 doesn't support the comma). Any supplied arguments will be used on all templates. Wrappers are processed in reverse order, so that the first wrapper listed will surround each subsequent wrapper listed. Variables from inner wrappers are available to the next wrapper that surrounds it. [% WRAPPER "path/to/outer.html", "path/to/inner.html" a = "An arg" b = "Another arg" %] =back =head1 DIRECTIVES (HTML::Template Style) HTML::Template templates use directives that look similar to the following: BAR The normal set of HTML::Template directives are TMPL_VAR, TMPL_IF, TMPL_ELSE, TMPL_UNLESS, TMPL_INCLUDE, and TMPL_LOOP. These tags should have either a NAME attribute, an EXPR attribute, or a bare variable name that is used to specify the value to be operated. If a NAME is specified, it may only be a single level value (as opposed to a TT chained variable). In the case of the TMPL_INCLUDE directive, the NAME is the file to be included. In Alloy, the EXPR attribute can be used with any of these types to specify TT compatible variable or expression that will be used for the value. Prints the value contained in foo Prints the value contained in foo Prints the value contained in foo Prints the value contained in {'foo.bar.baz'} Prints the value contained in {foo}->{bar}->{baz} Prints FOO if foo is true FOO Prints FOO unless foo is true FOO Includes the template in "foo.ht" Iterates on the arrayref foo Template::Alloy makes all of the other TT3 directives available in addition to the normal set of HTML::Template directives. For example, the following is valid in Alloy. You said The TMPL_VAR tag may also include an optional ESCAPE attribute. This specifies how the value of the tag should be escaped prior to substituting into the template. Escape value | Type of escape --------------------------------- HTML, 1 | HTML encoding URL | URL encoding JS | basic javascript encoding (\n, \r, and \") NONE, 0 | No encoding (default). The TMPL_VAR tag may also include an optional DEFAULT attribute that contains a string that will be used if the variable returns false. =head1 CHOMPING Chomping refers to the handling of whitespace immediately before and immediately after template tags. By default, nothing happens to this whitespace. Modifiers can be placed just inside the opening and just before the closing tags to control this behavior. Additionally, the PRE_CHOMP and POST_CHOMP configuration variables can be set and will globally control all chomping behavior for tags that do not have their own chomp modifier. PRE_CHOMP and POST_CHOMP can be set to any of the following values: none: 0 + Template::Constants::CHOMP_NONE one: 1 - Template::Constants::CHOMP_ONE collapse: 2 = Template::Constants::CHOMP_COLLAPSE greedy: 3 ~ Template::Constants::CHOMP_GREEDY =over 4 =item CHOMP_NONE Don't do any chomping. The "+" sign is used to indicate CHOMP_NONE. Hello. [%+ "Hi." +%] Howdy. Would print: Hello. Hi. Howdy. =item CHOMP_ONE (formerly known as CHOMP_ALL) Delete any whitespace up to the adjacent newline. The "-" is used to indicate CHOMP_ONE. Hello. [%- "Hi." -%] Howdy. Would print: Hello. Hi. Howdy. =item CHOMP_COLLAPSE Collapse adjacent whitespace to a single space. The "=" is used to indicate CHOMP_COLLAPSE. Hello. [%= "Hi." =%] Howdy. Would print: Hello. Hi. Howdy. =item CHOMP_GREEDY Remove all adjacent whitespace. The "~" is used to indicate CHOMP_GREEDY. Hello. [%~ "Hi." ~%] Howdy. Would print: Hello.Hi.Howdy. =back =head1 CONFIGURATION The following configuration variables are supported (in alphabetical order). Note: for further discussion you can refer to the TT config documentation. Items may be passed in upper or lower case. If lower case names are passed they will be resolved to uppercase during the "new" method. All of the variables in this section can be passed to the "new" constructor. my $obj = Template::Alloy->new( VARIABLES => \%hash_of_variables, AUTO_RESET => 0, TRIM => 1, POST_CHOMP => "=", PRE_CHOMP => "-", ); =over 4 =item ABSOLUTE Boolean. Default false. Are absolute paths allowed for included files. =item ADD_LOCAL_PATH If true, allows calls include_filename to temporarily add the directory of the current template being processed to the INCLUDE_PATHS arrayref. This allows templates to refer to files in the local template directory without specifying the local directory as part of the filename. Default is 0. If set to a negative value, the current directory will be added to the end of the current INCLUDE_PATHS. This property may also be set in the template using the CONFIG directive. [% CONFIG ADD_LOCAL_PATH => 1 %] =item ANYCASE Allow directive matching to be case insensitive. [% get 23 %] prints 23 with ANYCASE => 1 =item AUTO_RESET Boolean. Default 1. Clear blocks that were set during the process method. =item AUTO_EVAL Boolean. Default 0 (default 1 in Velocity syntax). If set to true, double quoted strings will automatically be passed to the eval filter. This configuration option may also be passed to the CONFIG directive. =item AUTO_FILTER Can be the name of any filter. Default undef. Any variable returned by a GET directive (including implicit GET) will be passed to the named filter. This configuration option may also be passed to the CONFIG directive. # with AUTO_FILTER => 'html' [% f = "&"; GET f %] prints & [% f = "&"; f %] prints & (implicit GET) If a variable already has another filter applied the AUTO_FILTER is not applied. The "none" scalar virtual method has been added to allow for using variables without reapplying filters. # with AUTO_FILTER => 'html' [% f = "&"; f | none %] prints & [% f = "&"; g = f; g %] prints & [% f = "&"; g = f; g | none %] prints & (because g = f is a SET directive) [% f = "&"; g = GET f; g | none %] prints & (because the actual GET directive was called) =item BLOCKS Only available via when using the process interface. A hashref of blocks that can be used by the process method. BLOCKS => { block_1 => sub { ... }, # coderef that returns a block block_2 => 'A String', # simple string }, Note that a Template::Document cannot be supplied as a value (TT supports this). However, it is possible to supply a value that is equal to the hashref returned by the load_template method. =item CACHE_SIZE Number of compiled templates to keep in memory. Default undef. Undefined means to allow all templates to cache. A value of 0 will force no caching. The cache mechanism will clear templates that have not been used recently. =item CACHE_STR_REFS Default 1. If set, any string refs will have an MD5 sum taken that will then be used for caching the document - both in memory and on the file system (if configured). This will give a significant speed boost. Note that this affects strings passed to the EVALUATE directive or eval filters as well. It may be set using the CONFIG directive. =item CALL_CONTEXT (Not in TT) Can be one of 'item', 'list', or 'smart'. The default type is 'smart'. The CALL_CONTEXT configuration specifies in what Perl context coderefs and methods used in the processed templates will be called. TT historically has avoided the distinction of item (scalar) vs list context. To avoid worrying about this, TT introduced 'smart' context. The C<@()> and C<$()> context specifiers make it easier to use CALL_CONTEXT in some situations. The following table shows the relationship between the various contexts: return values smart context list context item context ------------- ------------- ------------ ------------ A 'foo' 'foo' ['foo'] 'foo' B undef undef [undef] undef C (no return value) undef [] undef D (7) 7 [7] 7 E (7,8,9) [7,8,9] [7,8,9] 9 F @a = (7) 7 [7] 1 G @a = (7,8,9) [7,8,9] [7,8,9] 3 H ({b=>"c"}) {b=>"c"} [{b=>"c"}] {b=>"c"} I ([1]) [1] [[1]] [1] J ([1],[2]) [[1],[2]] [[1],[2]] [2] K [7,8,9] [7,8,9] [[7,8,9]] [7,8,9] L (undef, "foo") die "foo" [undef, "foo"] "foo" M wantarray?1:0 1 [1] 0 Cases F, H, I and M are common sticking points of the smart context in TT2. Note that list context always returns an arrayref from a method or function call. Smart context can give confusing results sometimes, especially the I and J cases. Case L for smart match is very surprising. The list and item context provide another feature for method calls. In smart context, TT will look for a hash key in the object by the same name as the method, if a method by that name doesn't exist. In item and list context Alloy will die if a method by that name cannot be found. The CALL_CONTEXT configuration item can be passed to new or it may also be set during runtime using the CONFIG directive. The following method call would be in list context: [% CONFIG CALL_CONTEXT => 'list'; results = my_obj.get_results; CONFIG CALL_CONTEXT => 'smart' %] Note that we needed to restore CALL_CONTEXT to the default 'smart' value. Template::Alloy has added the C<@()> (list) and the C<$()> (item) context specifiers. The previous example could be written as: [% results = @( my_obj.get_results ) %] To call that same method in item (scalar) context you would do the following: [% results = $( my_obj.get_results ) %] The C<@()> and C<$()> operators are based on the Perl 6 counterpart. =item COMPILE_DIR Base directory to store compiled templates. Default undef. Compiled templates will only be stored if one of COMPILE_DIR and COMPILE_EXT is set. If set, the AST of parsed documents will be cached. If COMPILE_PERL is set, the compiled perl code will also be stored. =item COMPILE_EXT Extension to add to stored compiled template filenames. Default undef. If set, the AST of parsed documents will be cached. If COMPILE_PERL is set, the compiled perl code will also be stored. =item COMPILE_JS Default false. Requires installation of L. When enabled, the parsed templates will be translated into Javascript and executed using the V8 javascript engine. If compile_dir is also set, this compiled javascript will be cached to disk. If your templates are short, there is little benefit to using this other than you can then use the JS directive. If your templates are long or you are running in a cached environment, this will speed up your templates. Certain limitations exist when COMPILE_JS is set, most notably the USE and VIEW directives are not supported, and method calls on objects passed to the template do not work (code refs passed in do work however). These limitations are due to the nature of JavaScript::V8 bind and Perl/JavaScript OO differences. =item COMPILE_PERL Default false. If set to 1 or 2, will translate the normal AST into a perl 5 code document. This document can then be executed directly, cached in memory, or cached on the file system depending upon the configuration items set. If set to 1, a perl code document will always be generated. If set to 2, a perl code document will only be generated if an AST has already been cached for the document. This should give a speed benefit and avoid extra compilation unless the document has been used more than once. If Alloy is running in a cached environment such as mod_perl, then using compile_perl can offer some speed benefit and makes Alloy faster than Text::Tmpl and as fast as HTML::Template::Compiled (but Alloy has more features). If you are not running in a cached environment, such as from commandline, or from CGI, it is generally faster to only run from the AST (with COMPILE_PERL => 0). =item CONSTANTS Hashref. Used to define variables that will be "folded" into the compiled template. Variables defined here cannot be overridden. CONSTANTS => {my_constant => 42}, A template containing: [% constants.my_constant %] Will have the value 42 compiled in. Constants defined in this way can be chained as in [% constant.foo.bar.baz %]. =item CONSTANT_NAMESPACE Allow for setting the top level of values passed in CONSTANTS. Default value is 'constants'. =item DEBUG Takes a list of constants |'ed together which enables different debugging modes. Alternately the lowercase names may be used (multiple values joined by a ","). The only supported TT values are: DEBUG_UNDEF (2) - debug when an undefined value is used (now easier to use STRICT) DEBUG_DIRS (8) - debug when a directive is used. DEBUG_ALL (2047) - turn on all debugging. Either of the following would turn on undef and directive debugging: DEBUG => 'undef, dirs', # preferred DEBUG => 2 | 8, DEBUG => DEBUG_UNDEF | DEBUG_DIRS, # constants from Template::Constants =item DEBUG_FORMAT Change the format of messages inserted when DEBUG has DEBUG_DIRS set on. This essentially the same thing as setting the format using the DEBUG directive. =item DEFAULT The name of a default template file to use if the passed one is not found. =item DELIMITER String to use to split INCLUDE_PATH with. Default is :. It is more straight forward to just send INCLUDE_PATH an arrayref of paths. =item DUMP Configures the behavior of the DUMP tag. May be set to 0, a hashref, or another true value. Default is true. If set to 0, all DUMP directives will do nothing. This is useful if you would like to turn off the DUMP directives under some environments. IF set to a true value (or undefined) then DUMP directives will operate. If set to a hashref, the values of the hash can be used to configure the operation of the DUMP directives. The following are the values that can be set in this hash. =over 4 =item EntireStash Default 1. If set to 0, then the DUMP directive will not print the entire contents of the stash when a DUMP directive is called without arguments. =item handler Defaults to an internal coderef. If set to a coderef, the DUMP directive will pass the arguments to be dumped and expects a string with the dumped data. This gives complete control over the dump process. Note 1: The default handler makes sure that values matching the private variable regex are not included. If you install your own handler, you will need to take care of these variables if you intend for them to not be shown. Note 2: If you would like the name of the variable to be dumped, include the string '$VAR1' and the DUMP directive will interpolate the value. For example, to dump all output as YAML - you could do the following: DUMP => { handler => sub { require YAML; return "\$VAR1 =\n".YAML::Dump(shift); }, } =item header Default 1. Controls whether a header is printed for each DUMP directive. The header contains the file and line number the DUMP directive was called from. If set to 0 the headers are disabled. =item html Defaults to 1 if $ENV{'REQUEST_METHOD'} is set - 0 otherwise. If set to 1, then the output of the DUMP directive is passed to the html filter and encased in "pre" tags. If set to 0 no html encoding takes place. =item Sortkeys, Useqq, Ident, Pad, etc Any of the Data::Dumper configuration items may be passed. =back =item ENCODING Default undef. If set, and if Perl version is greater than or equal to 5.7.3 (when Encode.pm was first included), then Encode::decode will be called every time a template file is processed and will be passed the value of ENCODING and text from the template. This item can also be set using [% CONFIG ENCODING => encoding %] before calling INCLUDE or PROCESS directives to change encodings on the fly. =item END_TAG Set a string to use as the closing delimiter for TT. Default is "%]". =item ERROR Used as a fall back when the processing of a template fails. May either be a single filename that will be used in all cases, or may be a hashref of options where the keynames represent error types that will be handled by the filename in their value. A key named default will be used if no other matching keyname can be found. The selection process is similar to that of the TRY/CATCH/THROW directives (see those directives for more information). my $t = Template::Alloy->new({ ERROR => 'general/catch_all_errors.html', }); my $t = Template::Alloy->new({ ERROR => { default => 'general/catch_all_errors.html', foo => 'catch_all_general_foo_errors.html', 'foo.bar' => 'catch_foo_bar_errors.html', }, }); Note that the ERROR handler will only be used for errors during the processing of the main document. It will not catch errors that occur in templates found in the PRE_PROCESS, POST_PROCESS, and WRAPPER configuration items. =item ERRORS Same as the ERROR configuration item. Both may be used interchangeably. =item EVAL_PERL Boolean. Default false. If set to a true value, PERL and RAWPERL blocks will be allowed to run. This is a potential security hole, as arbitrary perl can be included in the template. If Template::Toolkit is installed, a true EVAL_PERL value also allows the perl and evalperl filters to be used. =item FILTERS Allow for passing in TT style filters. my $filters = { filter1 => sub { my $str = shift; $s =~ s/./1/gs; $s }, filter2 => [sub { my $str = shift; $s =~ s/./2/gs; $s }, 0], filter3 => [sub { my ($context, @args) = @_; return sub { my $s = shift; $s =~ s/./3/gs; $s } }, 1], }; my $str = q{ [% a = "Hello" %] 1 ([% a | filter1 %]) 2 ([% a | filter2 %]) 3 ([% a | filter3 %]) }; my $obj = Template::Alloy->new(FILTERS => $filters); $obj->process(\$str) || die $obj->error; Would print: 1 (11111) 2 (22222) 3 (33333) Filters passed in as an arrayref should contain a coderef and a value indicating if they are dynamic or static (true meaning dynamic). The dynamic filters are passed the pseudo context object and any arguments and should return a coderef that will be called as the filter. The filter coderef is then passed the string. =item GLOBAL_CACHE Default 0. If true, documents will be cached in $Template::Alloy::GLOBAL_CACHE. It may also be passed a hashref, in which case the documents will be cached in the passed hashref. The TT, Tmpl, and velocity will automatically cache documents in the object. The HTML::Template interface uses a new object each time. Setting the HTML::Template's CACHE configuration is the same as setting GLOBAL_CACHE. =item INCLUDE_PATH A string or an arrayref or coderef that returns an arrayref that contains directories to look for files included by processed templates. Defaults to "." (the current directory). =item INCLUDE_PATHS Non-TT item. Same as INCLUDE_PATH but only takes an arrayref. If not specified then INCLUDE_PATH is turned into an arrayref and stored in INCLUDE_PATHS. Overrides INCLUDE_PATH. =item INTERPOLATE Boolean. Specifies whether variables in text portions of the template will be interpolated. For example, the $variable and ${var.value} would be substituted with the appropriate values from the variable cache (if INTERPOLATE is on). [% IF 1 %]The variable $variable had a value ${var.value}[% END %] =item LOAD_PERL Indicates if the USE directive can fall back and try and load a perl module if the indicated module was not found in the PLUGIN_BASE path. See the USE directive. This configuration has no bearing on the COMPILE_PERL directive used to indicate using compiled perl documents. =item MAX_EVAL_RECURSE (Alloy only) Will use $Template::Alloy::MAX_EVAL_RECURSE if not present. Default is 50. Prevents runaway on the following: [% f = "[% f|eval %]" %][% f|eval %] =item MAX_MACRO_RECURSE (Alloy only) Will use $Template::Alloy::MAX_MACRO_RECURSE if not present. Default is 50. Prevents runaway on the following: [% MACRO f BLOCK %][% f %][% END %][% f %] =item NAMESPACE No Template::Namespace::Constants support. Hashref of hashrefs representing constants that will be folded into the template at compile time. Template::Alloy->new(NAMESPACE => {constants => { foo => 'bar', }}); Is the same as Template::Alloy->new(CONSTANTS => { foo => 'bar', }); Any number of hashes can be added to the NAMESPACE hash. =item NEGATIVE_STAT_TTL (Not in TT) Defaults to STAT_TTL which defaults to $STAT_TTL which defaults to 1. Similar to STAT_TTL - but represents the time-to-live seconds until a document that was not found is checked again against the system for modifications. Setting this number higher will allow for fewer file system accesses. Setting it to a negative number will allow for the file system to be checked every hit. =item NO_INCLUDES Default false. If true, calls to INCLUDE, PROCESS, WRAPPER and INSERT will fail. This option is also available when using the process method. =item OUTPUT Alternate way of passing in the output location for processed templates. If process is not passed an output argument, it will look for this value. See the process method for a listing of possible values. =item OUTPUT_PATH Base path for files written out via the process method or via the redirect and file filters. See the redirect virtual method and the process method for more information. =item PLUGINS A hashref of mappings of plugin modules. PLUGINS => { Iterator => 'Template::Plugin::Iterator', DBI => 'MyDBI', }, See the USE directive for more information. =item PLUGIN_BASE Default value is Template::Plugin. The base module namespace that template plugins will be looked for. See the USE directive for more information. May be either a single namespace, or an arrayref of namespaces. =item POST_CHOMP Set the type of chomping at the ending of a tag. See the section on chomping for more information. =item POST_PROCESS Only available via when using the process interface. A list of templates to be processed and appended to the content after the main template. During this processing the "template" namespace will contain the name of the main file being processed. This is useful for adding a global footer to all templates. =item PRE_CHOMP Set the type of chomping at the beginning of a tag. See the section on chomping for more information. =item PRE_DEFINE Same as the VARIABLES configuration item. =item PRE_PROCESS Only available via when using the process interface. A list of templates to be processed before and pre-pended to the content before the main template. During this processing the "template" namespace will contain the name of the main file being processed. This is useful for adding a global header to all templates. =item PROCESS Only available via when using the process interface. Specify a file to use as the template rather than the one passed in to the ->process method. =item RECURSION Boolean. Default false. Indicates that INCLUDED or PROCESSED files can refer to each other in a circular manner. Be careful about recursion. =item RELATIVE Boolean. Default false. If true, allows filenames to be specified that are relative to the currently running process. =item SEMICOLONS Boolean. Default false. If true, then the syntax will require that semi-colons separate multiple directives in the same tag. This is useful for keeping the syntax a little more clean as well as trouble shooting some errors. =item SHOW_UNDEFINED_INTERP (Not in TT) Default false (default true in Velocity). If INTERPOLATE is true, interpolated dollar variables that return undef will be removed. With SHOW_UNDEFINED_INTERP set, undef values will leave the variable there. [% CONFIG INTERPOLATE => 1 %] [% SET foo = 1 %][% SET bar %] ($foo)($bar) ($!foo)($!bar) Would print: (1)() (1)() But the following: [% CONFIG INTERPOLATE => 1, SHOW_UNDEFINED_INTERP => 1 %] [% SET foo = 1 %][% SET bar %] ($foo)($bar) ($!foo)($!bar) Would print: (1)($bar) (1)() Note that you can use an exclamation point directly after the dollar to make the variable silent. This is similar to how Velocity works. =item START_TAG Set a string or regular expression to use as the opening delimiter for TT. Default is "[%". You should be sure that the tag does not include grouping parens or INTERPOLATE will not function properly. =item STASH Template::Alloy manages its own stash of variables. You can pass a Template::Stash or Template::Stash::XS object, but Template::Alloy will copy all of values out of the object into its own stash. Template::Alloy won't use any of the methods of the passed STASH object. The STASH option is only available when using the process method. =item STAT_TTL Defaults to $STAT_TTL which defaults to 1. Represents time-to-live seconds until a cached in memory document is compared to the file system for modifications. Setting this number higher will allow for fewer file system accesses. Setting it to a negative number will allow for the file system to be checked every hit. =item STREAM Defaults to false. If set to true, generated template content will be printed to the currently selected filehandle (default is STDOUT) as soon as it is ready - there will be no buffering of the output. The Stream role uses the Play role's directives (non-compiled_perl). All directives and configuration work, except for the following exceptions: =over 4 =item CLEAR directive Because the output is not buffered - the CLEAR directive would have no effect. The CLEAR directive will throw an error when STREAM is on. =item TRIM configuration Because the output is not buffered - trim operations cannot be played on the output buffers. =item WRAPPER configuration/directive The WRAPPER configuration and directive items effectively turn off STREAM since the WRAPPERS are generated in reverse order and because the content is inserted into the middle of the WRAPPERS. WRAPPERS will still work, they just won't stream. =item VARIOUS errors Because the template is streaming, items that cause errors my result in partially printed pages - since the error would occur part way through the print. =back All output is printed directly to the currently selected filehandle (defaults to STDOUT) via the CORE::print function. Any output parameter passed to process or process_simple will be ignored. If you would like the output to go to another handle, you will need to select that handle, process the template, and re-select STDOUT. =item STRICT Defaults to false. If set to true, any undefined variable that is encountered will cause the processing of the template to abort. This can be caught with a TRY block. This can be useful for making sure that the template only attempts to use variables that were correctly initialized similar in spirit to Perl's "use strict." When this occurs the strict_throw method is called. See the STRICT_THROW configuration for additional options. Similar functionality could be implemented using UNDEFINED_ANY. The STRICT configuration item can be passed to new or it may also be set during runtime using the CONFIG directive. Once set though it cannot be disabled for the duration of the current template and sub components. For example you could call [% CONFIG STRICT => 1 %] in header.tt and strict mode would be enabled for the header.tt and any sub templates processed by header.tt. =item STRICT_THROW (not in TT) Default undef. Can be set to a subroutine which will be called when STRICT is set and an undefined variable is processed. It will be passed the error type, error message, and a hashref of template information containing the current component being processed, the current outer template being processed, the identity reference for the variable, and the stringified name of the identity. This override can be used for filtering allowable elements. my $ta = Template::Alloy->new({ STRICT => 1, STRICT_THROW => sub { my ($ta, $err_type, $msg, $args) = @_; return if $args->{'component'} eq 'header.tt' && $args->{'template'} eq 'main.html' && $args->{'name'} eq 'foo.bar(1)'; # stringified identity name $ta->throw($err_type, $msg); # all other undefined variables die }, }); =item SYNTAX (not in TT) Defaults to "cet". Indicates the syntax that will be used for parsing included templates or eval'ed strings. You can use the CONFIG directive to change the SYNTAX on the fly (it will not affect the syntax of the document currently being parsed). The syntax may be passed in upper or lower case. The available choices are: alloy - Template::Alloy style - the same as TT3 tt3 - Template::Toolkit ver3 - same as Alloy tt2 - Template::Toolkit ver2 - almost the same as TT3 tt1 - Template::Toolkit ver1 - almost the same as TT2 ht - HTML::Template - same as HTML::Template::Expr without EXPR hte - HTML::Template::Expr js - JavaScript style - requires compile_js to be set. jsr - JavaScript Raw style - requires compile_js to be set. Passing in a different syntax allows for the process method to use a non-TT syntax and for the output method to use a non-HT syntax. The following is a sample of HTML::Template interface usage parsing a Template::Toolkit style document. my $obj = Template::Alloy->new(filename => 'my/template.tt' syntax => 'cet'); $obj->param(\%swap); print $obj->output; The following is a sample of Template::Toolkit interface usage parsing a HTML::Template::Expr style document. my $obj = Template::Alloy->new(SYNTAX => 'hte'); $obj->process('my/template.ht', \%swap); You can use the define_syntax method to add another custom syntax to the list of available options. =item TAG_STYLE Allow for setting the type of tag delimiters to use for parsing the TT. See the TAGS directive for a listing of the available types. =item TRIM Remove leading and trailing whitespace from blocks and templates. This operation is performed after all enclosed template tags have been executed. =item UNDEFINED_ANY This is not a TT configuration option. This option expects to be a code ref that will be called if a variable is undefined during a call to play_expr. It is passed the variable identity array as a single argument. This is most similar to the "undefined" method of Template::Stash. It allows for the "auto-defining" of a variable for use in the template. It is suggested that UNDEFINED_GET be used instead as UNDEFINED_ANY is a little to general in defining variables. You can also sub class the module and override the undefined_any method. =item UNDEFINED_GET This is not a TT configuration option. This option expects to be a code ref that will be called if a variable is undefined during a call to GET. It is passed the variable identity array as a single argument. This is more useful than UNDEFINED_ANY in that it is only called during a GET directive rather than in embedded expressions (such as [% a || b || c %]). You can also sub class the module and override the undefined_get method. =item V1DOLLAR This allows for some compatibility with TT1 templates. The only real behavior change is that [% $foo %] becomes the same as [% foo %]. The following is a basic table of changes invoked by using V1DOLLAR. With V1DOLLAR Equivalent Without V1DOLLAR (Normal default) "[% foo %]" "[% foo %]" "[% $foo %]" "[% foo %]" "[% ${foo} %]" "[% ${foo} %]" "[% foo.$bar %]" "[% foo.bar %]" "[% ${foo.bar} %]" "[% ${foo.bar} %]" "[% ${foo.$bar} %]" "[% ${foo.bar} %]" "Text: $foo" "Text: $foo" "Text: ${foo}" "Text: ${foo}" "Text: ${$foo}" "Text: ${foo}" =item V2EQUALS Default 1 in the TT syntax, defaults to 0 in the HTML::Template syntax. If set to 1 then "==" is an alias for "eq" and "!= is an alias for "ne". [% CONFIG V2EQUALS => 1 %][% ('7' == '7.0') || 0 %] [% CONFIG V2EQUALS => 0 %][% ('7' == '7.0') || 0 %] Prints 0 1 =item V2PIPE Restores the behavior of the pipe operator to be compatible with TT2. With V2PIPE = 1 [%- BLOCK a %]b is [% b %] [% END %] [%- PROCESS a b => 237 | repeat(2) %] # output of block "a" with b set to 237 is passed to the repeat(2) filter b is 237 b is 237 With V2PIPE = 0 (default) [%- BLOCK a %]b is [% b %] [% END %] [% PROCESS a b => 237 | repeat(2) %] # b set to 237 repeated twice, and b passed to block "a" b is 237237 =item VARIABLES A hashref of variables to initialize the template stash with. These variables are available for use in any of the executed templates. See the section on VARIABLES for the types of information that can be passed in. =item VMETHOD_FUNCTIONS Defaults to 1. All scalar virtual methods are available as top level functions as well. This is not true of TT2. In Template::Alloy the following are equivalent: [% "abc".length %] [% length("abc") %] You may set VMETHOD_FUNCTIONS to 0 to disable this behavior. =item WRAPPER Only available via when using the process interface. Operates similar to the WRAPPER directive. The option can be given a single filename, or an arrayref of filenames that will be used to wrap the processed content. If an arrayref is passed the filenames are processed in reverse order, so that the first filename specified will end up being on the outside (surrounding all other wrappers). my $t = Template::Alloy->new( WRAPPER => ['my/wrappers/outer.html', 'my/wrappers/inner.html'], ); Content generated by the PRE_PROCESS and POST_PROCESS will come before and after (respectively) the content generated by the WRAPPER configuration item. See the WRAPPER directive for more examples of how wrappers are constructed. =back =head1 CONFIGURATION (HTML::Template STYLE) The following HTML::Template and HTML::Template::Expr configuration variables are supported (in HTML::Template documentation order). Note: for further discussion you can refer to the HT documentation. Many of the variables mentioned in the TT CONFIGURATION section apply here as well. Unless noted, these items only apply when using the output method. Items may be passed in upper or lower case. All passed items are resolved to upper case. These variables should be passed to the "new" constructor. my $obj = Template::Alloy->new( type => 'filename', source => 'my/template.ht', die_on_bad_params => 1, loop_context_vars => 1, global_vars => 1 post_chomp => "=", pre_chomp => "-", ); =over 4 =item TYPE Can be one of filename, filehandle, arrayref, or scalarref. Indicates what type of input is in the "source" configuration item. =item SOURCE Stores where to read the input file. The type is specified in the "type" configuration item. =item FILENAME Indicates a filename to read the template from. Same as putting the filename in the "source" item and setting "type" to "filename". Must be set to enable caching. =item FILEHANDLE Should contain an open filehandle to read the template from. Same as putting the filehandle in the "source" item and setting "type" to "filehandle". Will not be cached. =item ARRAYREF Should contain an arrayref whose values are the lines of the template. Same as putting the arrayref in the "source" item and setting "type" to "arrayref". Will not be cached. =item SCALARREF Should contain an reference to a scalar that contains the template. Same as putting the scalar ref in the "source" item and setting "type" to "scalarref". Will not be cached. =item CACHE If set to one, then Alloy will use a global, in-memory document cache to store compiled templates in between calls. This is generally only useful in a mod_perl environment. The document is checked for a different modification time at each request. =item BLIND_CACHE Same as with cache enabled, but will not check if the document has been modified. =item FILE_CACHE If set to 1, will cache the compiled document on the file system. If true, file_cache_dir must be set. =item FILE_CACHE_DIR The directory where to store cached documents when file_cache is true. This is similar to the TT compile_dir option. =item DOUBLE_FILE_CACHE Uses a combination of file_cache and cache. =item PATH Same as INCLUDE_PATH when using the process method. =item ASSOCIATE May be a single CGI object or an arrayref of objects. The params from these objects will be added to the params during the output call. =item CASE_SENSITIVE Allow passed variables set through the param method, or the associate configuration to be used case sensitively. Default is off. It is highly suggested that this be set to 1. =item LOOP_CONTEXT_VARS Default false. When true, calls to the loop directive will create the following variables that give information about the current iteration of the loop: __first__ - True on first iteration only __last__ - True on last iteration only __inner__ - True on any iteration that isn't first or last __odd__ - True on odd iterations __counter__ - The iteration count These variables are also available to LOOPs run under TT syntax if loop_context_vars is set and if QR_PRIVATE is set to 0. =item GLOBAL_VARS. Default true in HTE mode. Default false in HT. Allows top level variables to be used in LOOPs. When false, only variables defined in the current LOOP iteration hashref will be available. =item DEFAULT_ESCAPE Controls the type of escape used on named variables in TMPL_VAR directives. Can be one of HTML, URL, or JS. The values of TMPL_VAR directives will be encoded with this type unless they specify their own type via an ESCAPE attribute. You may alternately use the AUTO_FILTER directive which can be any of the item vmethod filters (you must use lower case when specifying the AUTO_FILTER directive). The AUTO_FILTER directive will also be applied to TMPL_VAR EXPR and TMPL_GET items while DEFAULT_ESCAPE only applies to TMPL_VAR NAME items. =item NO_TT Default false in 'hte' syntax. Default true in 'ht' syntax. If true, no extended TT directives will be allowed. The output method uses 'hte' syntax by default. =back =head1 SEMI PUBLIC METHODS The following list of methods are other interesting methods of Alloy that may be re-implemented by subclasses of Alloy. =over 4 =item C Creates an exception object blessed into the package listed in Template::Alloy::Exception. =item C Executes a parsed tree (returned from parse_tree) =item C Play the parsed expression. Turns a variable identity array into the parsed variable. This method is also responsible for playing operators and running virtual methods and filters. The variable identity array may also contain literal values, or operator identity arrays. =item C Takes a file path, and resolves it into the full filename using paths from INCLUDE_PATH or INCLUDE_PATHS. =item C<_insert> Resolves the file passed, and then returns its contents. =item C Dynamically loads the filters list from Template::Filters when a filter is used that does not have a native implementation in Alloy. =item C Given a filename or a string reference will return a "document" hashref hash that contains the parsed tree. my $doc = $self->load_template($file); # errors die This method handles the in-memory caching of the document. =item C Given the "document" hashref, will either load the parsed AST from file (if configured to do so), or will load the content, parse the content using the Parse role, and will return the tree. File based caching of the parsed AST happens here. =item C Only used if COMPILE_PERL is true (default is false). Given the "document" hashref, will either load the compiled perl from file (if configured to do so), or will load the AST using "load_tree", will compile a new perl code document using the Compile role, and will return the perl code. File based caching of the compiled perl happens here. =item C Parses the passed string ref with the appropriate template syntax. See L for more details. =item C Parses the passed string ref for a variable or expression. See L for more details. =item C See L for more details. =item C Used to set a variable. Expects a variable identity array and the value to set. It will autovifiy as necessary. =item C Called during processing of template when STRICT configuration is set and an uninitialized variable is met. Arguments are the variable identity reference. Will call STRICT_THROW configuration item if set, otherwise will call throw with a useful message. =item C Creates an exception object from the arguments and dies. =item C Called during play_expr if a value is returned that is undefined. This could be used to magically create variables on the fly. This is similar to Template::Stash::undefined. It is suggested that undefined_get be used instead. Default behavior returns undef. You may also pass a coderef via the UNDEFINED_ANY configuration variable. Also, you can try using the DEBUG => 'undef', configuration option which will throw an error on undefined variables. =item C Called when a variable is undefined during a GET directive. This is useful to see if a value that is about to get inserted into the text is undefined. undefined_any is a little too general for most cases. Also, you may pass a coderef via the UNDEFINED_GET configuration variable. =back =head1 OTHER UTILITY METHODS The following is a brief list of other methods used by Alloy. Generally, these shouldn't be overwritten by subclasses. =over 4 =item C Returns perl code representation of a variable. =item C Used to create a "pseudo" context object that allows for portability of TT plugins, filters, and perl blocks that need a context object. Uses the Template::Alloy::Context class. =item C Used to get debug info on a directive if DEBUG_DIRS is set. =item C Used to turn string index position into line number =item C Used for parsing text nodes for dollar variables when interpolate is on. =item C Provided by the Operator role. Allows for playing an operator AST. See L for more details. =item C Provided by the Parse role. Allows for parsed operator array to be translated to a tree based upon operator precedence. =item C<_process> Called by process and the PROCESS, INCLUDE and other directives. =item C Reads contents of passed filename - throws file exception on error. =item C Used to split INCLUDE_PATH or other directives if an arrayref is not passed. =item C Returns a template toolkit representation of a variable. =item C<_vars> Return a reference to the current stash of variables. This is currently only used by the pseudo context object and may disappear at some point. =back =head1 THANKS Thanks to Andy Wardley for creating Template::Toolkit. Thanks to Sam Tregar for creating HTML::Template. Thanks to David Lowe for creating Text::Tmpl. Thanks to the Apache Velocity guys. Thanks to Ben Grimm for a patch to allow passing a parsed document to the ->process method. Thanks to David Warring for finding a parse error in HTE syntax. Thanks to Carl Franks for adding the base ENCODING support. =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/000077500000000000000000000000001402714000200214655ustar00rootroot00000000000000libtemplate-alloy-perl-1.022/lib/Template/Alloy/Compile.pm000066400000000000000000000742441402714000200234260ustar00rootroot00000000000000package Template::Alloy::Compile; =head1 NAME Template::Alloy::Compile - Compile role - allows for compiling the AST to perl code =cut use strict; use warnings; use Template::Alloy; use Template::Alloy::Iterator; our $VERSION = $Template::Alloy::VERSION; our $INDENT = ' ' x 4; our $DIRECTIVES = { BLOCK => \&compile_BLOCK, BREAK => \&compile_LAST, CALL => \&compile_CALL, CASE => undef, CATCH => undef, CLEAR => \&compile_CLEAR, '#' => sub {}, COMMENT => sub {}, CONFIG => \&compile_CONFIG, DEBUG => \&compile_DEBUG, DEFAULT => \&compile_DEFAULT, DUMP => \&compile_DUMP, ELSE => undef, ELSIF => undef, END => sub {}, EVAL => \&compile_EVAL, FILTER => \&compile_FILTER, '|' => \&compile_FILTER, FINAL => undef, FOR => \&compile_FOR, FOREACH => \&compile_FOR, GET => \&compile_GET, IF => \&compile_IF, INCLUDE => \&compile_INCLUDE, INSERT => \&compile_INSERT, JS => \&compile_JS, LAST => \&compile_LAST, LOOP => \&compile_LOOP, MACRO => \&compile_MACRO, META => \&compile_META, NEXT => \&compile_NEXT, PERL => \&compile_PERL, PROCESS => \&compile_PROCESS, RAWPERL => \&compile_RAWPERL, RETURN => \&compile_RETURN, SET => \&compile_SET, STOP => \&compile_STOP, SWITCH => \&compile_SWITCH, TAGS => sub {}, THROW => \&compile_THROW, TRY => \&compile_TRY, UNLESS => \&compile_UNLESS, USE => \&compile_USE, VIEW => \&compile_VIEW, WHILE => \&compile_WHILE, WRAPPER => \&compile_WRAPPER, }; sub new { die "This class is a role for use by packages such as Template::Alloy" } sub load_perl { my ($self, $doc) = @_; ### first look for a compiled perl document my $perl; if ($doc->{'_filename'}) { $doc->{'modtime'} ||= (stat $doc->{'_filename'})[9]; if ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) { my $file = $doc->{'_filename'}; if ($self->{'COMPILE_DIR'}) { $file =~ y|:|/| if $^O eq 'MSWin32'; $file = $self->{'COMPILE_DIR'} .'/'. $file; } elsif ($doc->{'_is_str_ref'}) { $file = ($self->include_paths->[0] || '.') .'/'. $file; } $file .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'}); $file .= $Template::Alloy::PERL_COMPILE_EXT if defined $Template::Alloy::PERL_COMPILE_EXT; if (-e $file && ($doc->{'_is_str_ref'} || (stat $file)[9] == $doc->{'modtime'})) { $perl = $self->slurp($file); } else { $doc->{'_compile_filename'} = $file; } } } $perl ||= $self->compile_template($doc); ### save a cache on the fileside as asked if ($doc->{'_compile_filename'}) { my $dir = $doc->{'_compile_filename'}; $dir =~ s|/[^/]+$||; if (! -d $dir) { require File::Path; File::Path::mkpath($dir); } open(my $fh, ">", $doc->{'_compile_filename'}) || $self->throw('compile', "Could not open file \"$doc->{'_compile_filename'}\" for writing: $!"); ### todo - think about locking if ($self->{'ENCODING'} && eval { require Encode } && defined &Encode::encode) { print {$fh} Encode::encode($self->{'ENCODING'}, $$perl); } else { print {$fh} $$perl; } close $fh; utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_compile_filename'}; } $perl = eval $$perl; $self->throw('compile', "Trouble loading compiled perl: $@") if ! $perl && $@; return $perl; } ###----------------------------------------------------------------### sub compile_template { my ($self, $doc) = @_; local $self->{'_component'} = $doc; my $tree = $doc->{'_tree'} ||= $self->load_tree($doc); local $self->{'_blocks'} = ''; local $self->{'_meta'} = ''; my $code = $self->compile_tree($tree, $INDENT); $self->{'_blocks'} .= "\n" if $self->{'_blocks'}; $self->{'_meta'} .= "\n" if $self->{'_meta'}; my $file = $doc->{'_filename'} || ''; $file =~ s/\'/\\\'/g; my $str = "# Generated by ".__PACKAGE__." v$VERSION on ".localtime()." my \$file = '$file'; my \$blocks = {$self->{'_blocks'}}; my \$meta = {$self->{'_meta'}}; my \$code = sub { ${INDENT}my (\$self, \$out_ref, \$var) = \@_;" .($self->{'_blocks'} ? "\n${INDENT}\@{ \$self->{'BLOCKS'} }{ keys %\$blocks } = values %\$blocks;" : "") .($self->{'_meta'} ? "\n${INDENT}\@{ \$self->{'_component'} }{ keys %\$meta } = values %\$meta;" : "") ."$code ${INDENT}return 1; }; { ${INDENT}blocks => \$blocks, ${INDENT}meta => \$meta, ${INDENT}code => \$code, };\n"; # print $str; return \$str; } ###----------------------------------------------------------------### sub _node_info { my ($self, $node, $indent) = @_; my $doc = $self->{'_component'} || return ''; $doc->{'_content'} ||= $self->slurp($doc->{'_filename'}); my ($line, $char) = $self->get_line_number_by_index($doc, $node->[1], 'include_chars'); return "\n\n${indent}# \"$node->[0]\" Line $line char $char (chars $node->[1] to $node->[2])"; } sub compile_tree { my ($self, $tree, $indent) = @_; my $code = ''; # node contains (0: DIRECTIVE, # 1: start_index, # 2: end_index, # 3: parsed tag details, # 4: sub tree for block types # 5: continuation sub trees for sub continuation block types (elsif, else, etc) # 6: flag to capture next directive my @doc; my $func; for my $node (@$tree) { # text nodes are just the bare text if (! ref $node) { my $copy = $node; # must make a copy before modification $copy =~ s/([\'\\])/\\$1/g; $code .= "\n\n${indent}\$\$out_ref .= '$copy';"; next; } if ($self->{'_debug_dirs'} && ! $self->{'_debug_off'}) { my $info = $self->node_info($node); my ($file, $line, $text) = @{ $info }{qw(file line text)}; s/\'/\\\'/g foreach $file, $line, $text; $code .= "\n ${indent}if (\$self->{'_debug_dirs'} && ! \$self->{'_debug_off'}) { # DEBUG ${indent}${INDENT}my \$info = {file => '$file', line => '$line', text => '$text'}; ${indent}${INDENT}my \$format = \$self->{'_debug_format'} || \$self->{'DEBUG_FORMAT'} || \"\\n## \\\$file line \\\$line : [% \\\$text %] ##\\n\"; ${indent}${INDENT}\$format =~ s{\\\$(file|line|text)}{\$info->{\$1}}g; ${indent}${INDENT}\$\$out_ref .= \$format; ${indent}}"; } $code .= _node_info($self, $node, $indent); if ($func = $DIRECTIVES->{$node->[0]}) { $func->($self, $node, \$code, $indent); } else { ### if the method isn't defined - delegate to the play directive (if there is one) require Template::Alloy::Play; if ($func = $Template::Alloy::Play::DIRECTIVES->{$node->[0]}) { _compile_defer_to_play($self, $node, \$code, $indent); } else { die "Couldn't find compile or play method for directive \"$node->[0]\""; } } } return $code; } sub compile_expr { my ($self, $var, $indent) = @_; return "\$self->play_expr(".$self->ast_string($var).")"; } sub _compile_defer_to_play { my ($self, $node, $str_ref, $indent) = @_; my $directive = $node->[0]; die "Invalid node name \"$directive\"" if $directive !~ /^\w+$/; $$str_ref .= " ${indent}require Template::Alloy::Play; ${indent}\$var = ".$self->ast_string($node->[3])."; ${indent}\$Template::Alloy::Play::DIRECTIVES->{'$directive'}->(\$self, \$var, ".$self->ast_string($node).", \$out_ref);"; return; } sub _is_empty_named_args { my ($hash_ident) = @_; # [[undef, '{}', 'key1', 'val1', 'key2, 'val2'], 0] return @{ $hash_ident->[0] } <= 2; } ###----------------------------------------------------------------### sub compile_BLOCK { my ($self, $node, $str_ref, $indent) = @_; my $ref = \ $self->{'_blocks'}; my $name = $node->[3]; $name =~ s/\'/\\\'/g; my $name2 = $self->{'_component'}->{'name'} .'/'. $node->[3]; $name2 =~ s/\'/\\\'/g; my $code = $self->compile_tree($node->[4], "$INDENT$INDENT$INDENT"); $$ref .= " ${INDENT}'$name' => { ${INDENT}${INDENT}name => '$name2', ${INDENT}${INDENT}_filename => \$file, ${INDENT}${INDENT}_perl => {code => sub { ${INDENT}${INDENT}${INDENT}my (\$self, \$out_ref, \$var) = \@_;$code ${INDENT}${INDENT}${INDENT}return 1; ${INDENT}${INDENT}}}, ${INDENT}},"; return; } sub compile_CALL { my ($self, $node, $str_ref, $indent) = @_; $$str_ref .= "\n${indent}scalar ".$self->compile_expr($node->[3], $indent).";"; return; } sub compile_CLEAR { my ($self, $node, $str_ref, $indent) = @_; $$str_ref .= " ${indent}\$\$out_ref = '';"; } sub compile_CONFIG { my ($self, $node, $str_ref, $indent) = @_; _compile_defer_to_play($self, $node, $str_ref, $indent); } sub compile_DEBUG { my ($self, $node, $str_ref, $indent) = @_; my $text = $node->[3]->[0]; if ($text eq 'on') { $$str_ref .= "\n${indent}delete \$self->{'_debug_off'};"; } elsif ($text eq 'off') { $$str_ref .= "\n${indent}\$self->{'_debug_off'} = 1;"; } elsif ($text eq 'format') { my $format = $node->[3]->[1]; $format =~ s/\'/\\\'/g; $$str_ref .= "\n${indent}\$self->{'_debug_format'} = '$format';"; } return; } sub compile_DEFAULT { my ($self, $node, $str_ref, $indent) = @_; local $self->{'_is_default'} = 1; $DIRECTIVES->{'SET'}->($self, $node, $str_ref, $indent); } sub compile_DUMP { my ($self, $node, $str_ref, $indent) = @_; _compile_defer_to_play($self, $node, $str_ref, $indent); } sub compile_GET { my ($self, $node, $str_ref, $indent) = @_; $$str_ref .= " $indent\$var = ".$self->compile_expr($node->[3], $indent)."; $indent\$\$out_ref .= defined(\$var) ? \$var : \$self->undefined_get(".$self->ast_string($node->[3]).");"; return; } sub compile_EVAL { my ($self, $node, $str_ref, $indent) = @_; my ($named, @strs) = @{ $node->[3] }; $$str_ref .= " ${indent}foreach (".join(",\n", map {$self->ast_string($_)} @strs).") { ${indent}${INDENT}my \$str = \$self->play_expr(\$_); ${indent}${INDENT}next if ! defined \$str; ${indent}${INDENT}\$\$out_ref .= \$self->play_expr([[undef, '-temp-', \$str], 0, '|', 'eval', [".$self->ast_string($named)."]]); ${indent}}"; } sub compile_FILTER { my ($self, $node, $str_ref, $indent) = @_; my ($name, $filter) = @{ $node->[3] }; return if ! @$filter; $$str_ref .= " ${indent}\$var = do { ${indent}${INDENT}my \$filter = ".$self->ast_string($filter).";"; ### allow for alias if (length $name) { $name =~ s/\'/\\\'/g; $$str_ref .= "\n${indent}${INDENT}\$self->{'FILTERS'}->{'$name'} = \$filter; # alias for future calls\n"; } $$str_ref .= " ${indent}${INDENT}my \$out = ''; ${indent}${INDENT}my \$out_ref = \\\$out;" .$self->compile_tree($node->[4], "$indent$INDENT")." ${indent}\$out = \$self->play_expr([[undef, '-temp-', \$out], 0, '|', \@\$filter]); ${indent}${INDENT}\$out; ${indent}}; ${indent}\$\$out_ref .= \$var if defined \$var;"; } sub compile_FOR { my ($self, $node, $str_ref, $indent) = @_; my ($name, $items) = @{ $node->[3] }; local $self->{'_in_loop'} = 'FOREACH'; my $code = $self->compile_tree($node->[4], "$indent$INDENT"); $$str_ref .= "\n${indent}do { ${indent}my \$loop = ".$self->compile_expr($items, $indent)."; ${indent}\$loop = [] if ! defined \$loop; ${indent}\$loop = \$self->iterator(\$loop) if ref(\$loop) !~ /Iterator\$/; ${indent}local \$self->{'_vars'}->{'loop'} = \$loop;"; if (! defined $name) { $$str_ref .= " ${indent}my \$swap = \$self->{'_vars'}; ${indent}local \$self->{'_vars'} = my \$copy = {%\$swap};"; } $$str_ref .= " ${indent}my (\$var, \$error) = \$loop->get_first; ${indent}FOREACH: while (! \$error) {"; if (defined $name) { $$str_ref .= "\n$indent$INDENT\$self->set_variable(".$self->ast_string($name).", \$var);"; } else { $$str_ref .= "\n$indent$INDENT\@\$copy{keys %\$var} = values %\$var if ref(\$var) eq 'HASH';"; } $$str_ref .= "$code ${indent}${INDENT}(\$var, \$error) = \$loop->get_next; ${indent}} ${indent}};"; return; } sub compile_FOREACH { shift->compile_FOR(@_) } sub compile_IF { my ($self, $node, $str_ref, $indent) = @_; $$str_ref .= "\n${indent}if (".$self->compile_expr($node->[3], $indent).") {"; $$str_ref .= $self->compile_tree($node->[4], "$indent$INDENT"); while ($node = $node->[5]) { # ELSE, ELSIF's $$str_ref .= _node_info($self, $node, $indent); if ($node->[0] eq 'ELSE') { $$str_ref .= "\n${indent}} else {"; $$str_ref .= $self->compile_tree($node->[4], "$indent$INDENT"); last; } else { $$str_ref .= "\n${indent}} elsif (".$self->compile_expr($node->[3], $indent).") {"; $$str_ref .= $self->compile_tree($node->[4], "$indent$INDENT"); } } $$str_ref .= "\n${indent}}"; } sub compile_INCLUDE { my ($self, $node, $str_ref, $indent) = @_; _compile_defer_to_play($self, $node, $str_ref, $indent); } sub compile_INSERT { my ($self, $node, $str_ref, $indent) = @_; _compile_defer_to_play($self, $node, $str_ref, $indent); } sub compile_JS { my ($self, $node, $str_ref, $indent) = @_; _compile_defer_to_play($self, $node, $str_ref, $indent); } sub compile_LAST { my ($self, $node, $str_ref, $indent) = @_; my $type = $self->{'_in_loop'} || die "Found LAST while not in FOR, FOREACH or WHILE"; $$str_ref .= "\n${indent}last $type;"; return; } sub compile_LOOP { my ($self, $node, $str_ref, $indent) = @_; my $ref = $node->[3]; $ref = [$ref, 0] if ! ref $ref; $$str_ref .= " ${indent}\$var = ".$self->compile_expr($ref, $indent)."; ${indent}if (\$var) { ${indent}${INDENT}my \$global = ! \$self->{'SYNTAX'} || \$self->{'SYNTAX'} ne 'ht' || \$self->{'GLOBAL_VARS'}; ${indent}${INDENT}my \$items = ref(\$var) eq 'ARRAY' ? \$var : ref(\$var) eq 'HASH' ? [\$var] : []; ${indent}${INDENT}my \$i = 0; ${indent}${INDENT}for my \$ref (\@\$items) { ${indent}${INDENT}${INDENT}\$self->throw('loop', 'Scalar value used in LOOP') if \$ref && ref(\$ref) ne 'HASH'; ${indent}${INDENT}${INDENT}local \$self->{'_vars'} = (! \$global) ? (\$ref || {}) : (ref(\$ref) eq 'HASH') ? {%{ \$self->{'_vars'} }, %\$ref} : \$self->{'_vars'}; ${indent}${INDENT}${INDENT}\@{ \$self->{'_vars'} }{qw(__counter__ __first__ __last__ __inner__ __odd__)} ${indent}${INDENT}${INDENT}${INDENT}= (++\$i, (\$i == 1 ? 1 : 0), (\$i == \@\$items ? 1 : 0), (\$i == 1 || \$i == \@\$items ? 0 : 1), (\$i % 2) ? 1 : 0) ${indent}${INDENT}${INDENT}${INDENT}${INDENT}if \$self->{'LOOP_CONTEXT_VARS'} && ! \$Template::Alloy::QR_PRIVATE;" .$self->compile_tree($node->[4], "$indent$INDENT$INDENT")." ${indent}${INDENT}} ${indent}}"; } sub compile_MACRO { my ($self, $node, $str_ref, $indent) = @_; my ($name, $args) = @{ $node->[3] }; ### get the sub tree my $sub_tree = $node->[4]; if (! $sub_tree || ! $sub_tree->[0]) { $$str_ref .= " ${indent}\$self->set_variable(".$self->ast_string($name).", undef);"; return; } elsif (ref($sub_tree->[0]) && $sub_tree->[0]->[0] eq 'BLOCK') { $sub_tree = $sub_tree->[0]->[4]; } my $code = $self->compile_tree($sub_tree, "$indent$INDENT"); $$str_ref .= " ${indent}do { ${indent}my \$self_copy = \$self; ${indent}eval {require Scalar::Util; Scalar::Util::weaken(\$self_copy)}; ${indent}\$var = sub { ${indent}${INDENT}my \$copy = \$self_copy->{'_vars'}; ${indent}${INDENT}local \$self_copy->{'_vars'}= {%\$copy}; ${indent}${INDENT}local \$self_copy->{'_macro_recurse'} = \$self_copy->{'_macro_recurse'} || 0; ${indent}${INDENT}my \$max = \$self_copy->{'MAX_MACRO_RECURSE'} || \$Template::Alloy::MAX_MACRO_RECURSE; ${indent}${INDENT}\$self_copy->throw('macro_recurse', \"MAX_MACRO_RECURSE \$max reached\") ${indent}${INDENT}${INDENT}if ++\$self_copy->{'_macro_recurse'} > \$max; "; foreach my $var (@$args) { $$str_ref .= " ${indent}${INDENT}\$self_copy->set_variable("; $$str_ref .= $self->ast_string($var); $$str_ref .= ", shift(\@_));"; } $$str_ref .= " ${indent}${INDENT}if (\@_ && \$_[-1] && UNIVERSAL::isa(\$_[-1],'HASH')) { ${indent}${INDENT}${INDENT}my \$named = pop \@_; ${indent}${INDENT}${INDENT}foreach my \$name (sort keys %\$named) { ${indent}${INDENT}${INDENT}${INDENT}\$self_copy->set_variable([\$name, 0], \$named->{\$name}); ${indent}${INDENT}${INDENT}} ${indent}${INDENT}} ${indent}${INDENT}my \$out = ''; ${indent}${INDENT}my \$out_ref = \\\$out;$code ${indent}${INDENT}return \$out; ${indent}}; ${indent}\$self->set_variable(".$self->ast_string($name).", \$var); ${indent}};"; return; } sub compile_META { my ($self, $node, $str_ref, $indent) = @_; if (my $kp = $node->[3]) { $kp = {@$kp} if ref($kp) eq 'ARRAY'; while (my($key, $val) = each %$kp) { s/\'/\\\'/g foreach $key, $val; $self->{'_meta'} .= "\n${indent}'$key' => '$val',"; } } return; } sub compile_NEXT { my ($self, $node, $str_ref, $indent) = @_; my $type = $self->{'_in_loop'} || die "Found next while not in FOR, FOREACH or WHILE"; $$str_ref .= "\n${indent}(\$var, \$error) = \$loop->get_next;" if $type eq 'FOREACH'; $$str_ref .= "\n${indent}next $type;"; return; } sub compile_PERL{ my ($self, $node, $str_ref, $indent) = @_; ### fill in any variables my $perl = $node->[4] || return; my $code = $self->compile_tree($perl, "$indent$INDENT"); $$str_ref .= " ${indent}\$self->throw('perl', 'EVAL_PERL not set') if ! \$self->{'EVAL_PERL'}; ${indent}require Template::Alloy::Play; ${indent}\$var = do { ${indent}${INDENT}my \$out = ''; ${indent}${INDENT}my \$out_ref = \\\$out;$code ${indent}${INDENT}\$out; ${indent}}; ${indent}#\$var = \$1 if \$var =~ /^(.+)\$/s; # blatant untaint ${indent}my \$err; ${indent}eval { ${indent}${INDENT}package Template::Alloy::Perl; ${indent}${INDENT}my \$context = \$self->context; ${indent}${INDENT}my \$stash = \$context->stash; ${indent}${INDENT}local *PERLOUT; ${indent}${INDENT}tie *PERLOUT, 'Template::Alloy::EvalPerlHandle', \$out_ref; ${indent}${INDENT}my \$old_fh = select PERLOUT; ${indent}${INDENT}eval \$var; ${indent}${INDENT}\$err = \$\@; ${indent}${INDENT}select \$old_fh; ${indent}}; ${indent}\$err ||= \$\@; ${indent}if (\$err) { ${indent}${INDENT}\$self->throw('undef', \$err) if ! UNIVERSAL::can(\$err, 'type'); ${indent}${INDENT}die \$err; ${indent}}"; return; } sub compile_PROCESS { my ($self, $node, $str_ref, $indent) = @_; _compile_defer_to_play($self, $node, $str_ref, $indent); } sub compile_RAWPERL { my ($self, $node, $str_ref, $indent) = @_; _compile_defer_to_play($self, $node, $str_ref, $indent); } sub compile_RETURN { my ($self, $node, $str_ref, $indent) = @_; if (defined($node->[3])) { $$str_ref .= " ${indent}\$var = {return_val => ".$self->compile_expr($node->[3])."}; ${indent}\$self->throw('return', \$var);"; } else { $$str_ref .= " ${indent}\$self->throw('return', undef);"; } } sub compile_SET { my ($self, $node, $str_ref, $indent) = @_; my $sets = $node->[3]; my $out = ''; foreach (@$sets) { my ($op, $set, $val) = @$_; if ($self->{'_is_default'}) { $$str_ref .= "\n${indent}if (! ".$self->compile_expr($set, $indent).") {"; $indent .= $INDENT; } $$str_ref .= "\n$indent\$var = "; if (! defined $val) { # not defined $$str_ref .= 'undef'; } elsif ($node->[4] && $val == $node->[4]) { # a captured directive my $sub_tree = $node->[4]; $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK'; my $code = $self->compile_tree($sub_tree, "$indent$INDENT"); $$str_ref .= "${indent}do { ${indent}${INDENT}my \$out = ''; ${indent}${INDENT}my \$out_ref = \\\$out;$code ${indent}${INDENT}\$out; ${indent}}" } else { # normal var $$str_ref .= $self->compile_expr($val, $indent); } if ($Template::Alloy::OP_DISPATCH->{$op}) { $$str_ref .= ' }'; } $$str_ref .= "; $indent\$self->set_variable(".$self->ast_string($set).", \$var);"; if ($self->{'_is_default'}) { substr($indent, -length($INDENT), length($INDENT), ''); $$str_ref .= "\n$indent}"; } $$str_ref .= ";"; } return $out; } sub compile_STOP { my ($self, $node, $str_ref, $indent) = @_; $$str_ref .= " ${indent}\$self->throw('stop', 'Control Exception');"; } sub compile_SWITCH { my ($self, $node, $str_ref, $indent) = @_; $$str_ref .= " ${indent}\$var = ".$self->compile_expr($node->[3], $indent).";"; my $default; my $i = 0; while ($node = $node->[5]) { # CASES if (! defined $node->[3]) { $default = $node; next; } $$str_ref .= _node_info($self, $node, $indent); $$str_ref .= "\n$indent" .($i++ ? "} els" : ""). "if (do { ${indent}${INDENT}no warnings; ${indent}${INDENT}my \$var2 = ".$self->compile_expr($node->[3], "$indent$INDENT")."; ${indent}${INDENT}scalar grep {\$_ eq \$var} (UNIVERSAL::isa(\$var2, 'ARRAY') ? \@\$var2 : \$var2); ${indent}${INDENT}}) { ${indent}${INDENT}my \$var;"; $$str_ref .= $self->compile_tree($node->[4], "$indent$INDENT"); } if ($default) { $$str_ref .= _node_info($self, $default, $indent); $$str_ref .= "\n$indent" .($i++ ? "} else {" : "if (1) {"); $$str_ref .= $self->compile_tree($default->[4], "$indent$INDENT"); } $$str_ref .= "\n$indent}" if $i; return; } sub compile_THROW { my ($self, $node, $str_ref, $indent) = @_; my ($name, $args) = @{ $node->[3] }; my ($named, @args) = @$args; push @args, $named if ! _is_empty_named_args($named); # add named args back on at end - if there are some $$str_ref .= " ${indent}\$self->throw(".$self->compile_expr($name, $indent).", [".join(", ", map{$self->compile_expr($_, $indent)} @args)."]);"; return; } sub compile_TRY { my ($self, $node, $str_ref, $indent) = @_; $$str_ref .= " ${indent}do { ${indent}my \$out = ''; ${indent}eval { ${indent}${INDENT}my \$out_ref = \\\$out;" . $self->compile_tree($node->[4], "$indent$INDENT") ." ${indent}}; ${indent}my \$err = \$\@; ${indent}\$\$out_ref .= \$out; ${indent}if (\$err) {"; my $final; my $i = 0; my $catches_str = ''; my @names; while ($node = $node->[5]) { # CATCHES if ($node->[0] eq 'FINAL') { $final = $node; next; } $catches_str .= _node_info($self, $node, "$indent$INDENT"); $catches_str .= "\n${indent}${INDENT}} elsif (\$index == ".(scalar @names).") {"; $catches_str .= $self->compile_tree($node->[4], "$indent$INDENT$INDENT"); push @names, $node->[3]; } if (@names) { $$str_ref .= " ${indent}${INDENT}\$err = \$self->exception('undef', \$err) if ! UNIVERSAL::can(\$err, 'type'); ${indent}${INDENT}my \$type = \$err->type; ${indent}${INDENT}die \$err if \$type =~ /stop|return/; ${indent}${INDENT}local \$self->{'_vars'}->{'error'} = \$err; ${indent}${INDENT}local \$self->{'_vars'}->{'e'} = \$err; ${indent}${INDENT}my \$index; ${indent}${INDENT}my \@names = ("; $i = 0; foreach $i (0 .. $#names) { if (defined $names[$i]) { $$str_ref .= "\n${indent}${INDENT}${INDENT}scalar(".$self->compile_expr($names[$i], "$indent$INDENT$INDENT")."), # $i;"; } else { $$str_ref .= "\n${indent}${INDENT}${INDENT}undef, # $i"; } } $$str_ref .= " ${indent}${INDENT}); ${indent}${INDENT}for my \$i (0 .. \$#names) { ${indent}${INDENT}${INDENT}my \$name = (! defined(\$names[\$i]) || lc(\$names[\$i]) eq 'default') ? '' : \$names[\$i]; ${indent}${INDENT}${INDENT}\$index = \$i if \$type =~ m{^ \\Q\$name\\E \\b}x && (! defined(\$index) || length(\$names[\$index]) < length(\$name)); ${indent}${INDENT}} ${indent}${INDENT}if (! defined \$index) { ${indent}${INDENT}${INDENT}die \$err;" .$catches_str." ${indent}${INDENT}}"; } else { $$str_ref .= " ${indent}\$self->throw('throw', 'Missing CATCH block');"; } $$str_ref .= " ${indent}}"; if ($final) { $$str_ref .= _node_info($self, $final, $indent); $$str_ref .= $self->compile_tree($final->[4], "$indent"); } $$str_ref .=" ${indent}};"; return; } sub compile_UNLESS { $DIRECTIVES->{'IF'}->(@_) } sub compile_USE { my ($self, $node, $str_ref, $indent) = @_; _compile_defer_to_play($self, $node, $str_ref, $indent); } sub compile_VIEW { my ($self, $node, $str_ref, $indent) = @_; my ($blocks, $args, $name) = @{ $node->[3] }; my $_name = $self->ast_string($name); # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0] $args = $args->[0]; $$str_ref .= " ${indent}do { ${indent}${INDENT}my \$name = $_name; ${indent}${INDENT}my \$hash = {};"; foreach (my $i = 2; $i < @$args; $i+=2) { $$str_ref .= " ${indent}${INDENT}\$var = ".$self->compile_expr($args->[$i+1], $indent)."; ${indent}${INDENT}"; my $key = $args->[$i]; if (ref $key) { if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) { $key = $key->[0]; } else { $$str_ref .= " ${indent}${INDENT}\$self->set_variable(".$self->compile_expr($key, $indent).", \$var);"; next; } } $key =~ s/([\'\\])/\\$1/g; $$str_ref .= "\$hash->{'$key'} = \$var;"; } $$str_ref .= " ${indent}${INDENT}my \$prefix = \$hash->{'prefix'} || (ref(\$name) && \@\$name == 2 && ! \$name->[1] && ! ref(\$name->[0])) ? \"\$name->[0]/\" : ''; ${indent}${INDENT}my \$blocks = \$hash->{'blocks'} = {};"; foreach my $key (keys %$blocks) { my $code = $self->compile_tree($blocks->{$key}, "$indent$INDENT$INDENT$INDENT"); $key =~ s/([\'\\])/\\$1/g; $$str_ref .= " ${indent}${INDENT}\$blocks->{'$key'} = { ${indent}${INDENT}${INDENT}name => \$prefix . '$key', ${indent}${INDENT}${INDENT}_perl => {code => sub { ${indent}${INDENT}${INDENT}${INDENT}my (\$self, \$out_ref, \$var) = \@_;$code ${indent}${INDENT}${INDENT}${INDENT}return 1; ${indent}${INDENT}${INDENT}} }, ${indent}${INDENT}};"; } $$str_ref .= " ${indent}${INDENT}\$self->throw('view', 'Could not load Template::View library') ${indent}${INDENT}${INDENT} if ! eval { require Template::View }; ${indent}${INDENT}my \$view = Template::View->new(\$self->context, \$hash) ${indent}${INDENT}${INDENT}|| \$self->throw('view', \$Template::View::ERROR); ${indent}${INDENT}my \$old_view = \$self->play_expr(['view', 0]); ${indent}${INDENT}\$self->set_variable(\$name, \$view); ${indent}${INDENT}\$self->set_variable(['view', 0], \$view);"; if ($node->[4]) { $$str_ref .= " ${indent}${INDENT}my \$out = ''; ${indent}${INDENT}my \$out_ref = \\\$out;" .$self->compile_tree($node->[4], "$indent$INDENT"); } $$str_ref .= " ${indent}${INDENT}\$self->set_variable(['view', 0], \$old_view); ${indent}${INDENT}\$view->seal; ${indent}};"; return; } sub compile_WHILE { my ($self, $node, $str_ref, $indent) = @_; local $self->{'_in_loop'} = 'WHILE'; my $code = $self->compile_tree($node->[4], "$indent$INDENT"); $$str_ref .= " ${indent}my \$count = \$Template::Alloy::WHILE_MAX; ${indent}WHILE: while (--\$count > 0) { ${indent}my \$var = ".$self->compile_expr($node->[3], $indent)."; ${indent}last if ! \$var;$code ${indent}}"; return; } sub compile_WRAPPER { my ($self, $node, $str_ref, $indent) = @_; my ($named, @files) = @{ $node->[3] }; $named = $self->ast_string($named); $$str_ref .= " ${indent}\$var = do { ${indent}${INDENT}my \$out = ''; ${indent}${INDENT}my \$out_ref = \\\$out;" .$self->compile_tree($node->[4], "$indent$INDENT")." ${indent}${INDENT}\$out; ${indent}}; ${indent}for my \$file (reverse(" .join(",${indent}${INDENT}", map {"\$self->play_expr(".$self->ast_string($_).")"} @files).")) { ${indent}${INDENT}local \$self->{'_vars'}->{'content'} = \$var; ${indent}${INDENT}\$var = ''; ${indent}${INDENT}require Template::Alloy::Play; ${indent}\$Template::Alloy::Play::DIRECTIVES->{'INCLUDE'}->(\$self, [$named, \$file], ['$node->[0]', $node->[1], $node->[2]], \\\$var); ${indent}} ${indent}\$\$out_ref .= \$var if defined \$var;"; return; } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::Compile role allows for taking the AST returned by the Parse role, and translating it into a perl code document. This is in contrast Template::Alloy::Play which executes the AST directly. =head1 TODO =over 4 =item Translate compile_RAWPERL to actually output rather than calling play_RAWPERL. =back =head1 ROLE METHODS =over 4 =item C Takes an AST returned by parse_tree and translates it into perl code using functions stored in the $DIRECTIVES hashref. A template that looked like the following: Foo [% GET foo %] [% GET bar %] Bar would parse to the following perl code: # Generated by Template::Alloy::Compile v1.001 on Thu Jun 7 12:58:33 2007 # From file /home/paul/bar.tt my $blocks = {}; my $meta = {}; my $code = sub { my ($self, $out_ref, $var) = @_; $$out_ref .= 'Foo'; # "GET" Line 2 char 2 (chars 6 to 15) $var = $self->play_expr(['foo', 0]); $$out_ref .= defined($var) ? $var : $self->undefined_get(['foo', 0]); # "GET" Line 3 char 2 (chars 22 to 31) $var = $self->play_expr(['bar', 0]); $$out_ref .= defined($var) ? $var : $self->undefined_get(['bar', 0]); $$out_ref .= 'Bar'; return 1; }; { blocks => $blocks, meta => $meta, code => $code, }; As you can see the output is quite a bit more complex than the AST, but under mod_perl conditions, the perl will run faster than playing the AST each time. =item C Takes an AST variable or expression and returns perl code that can lookup the variable. =back =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Context.pm000066400000000000000000000107371402714000200234570ustar00rootroot00000000000000package Template::Alloy::Context; =head1 NAME Template::Alloy::Context - Provide a TT style context =cut use strict; use warnings; use Template::Alloy; our $VERSION = $Template::Alloy::VERSION; our $AUTOLOAD; ###----------------------------------------------------------------### sub new { my $class = shift; my $self = shift || {}; die "Missing _template" if ! $self->{'_template'}; return bless $self, $class; } sub _template { shift->{'_template'} || die "Missing _template" } sub template { my ($self, $name) = @_; return $self->_template->{'BLOCKS'}->{$name} || $self->_template->load_template($name); } sub config { shift->_template } sub stash { my $self = shift; return $self->{'stash'} ||= bless {_template => $self->_template}, 'Template::Alloy::_ContextStash'; } sub insert { my ($self, $file) = @_;; my $t = $self->_template; my $ref = $t->slurp($t->include_filename($file)); return $$ref; } sub eval_perl { shift->_template->{'EVAL_PERL'} } sub process { my $self = shift; my $ref = shift; my $args = shift || {}; $self->_template->set_variable($_, $args->{$_}) for keys %$args; my $out = ''; $self->_template->_process($ref, $self->_template->_vars, \$out); return $out; } sub include { my $self = shift; my $ref = shift; my $args = shift || {}; my $t = $self->_template; my $swap = $t->{'_vars'}; local $t->{'_vars'} = {%$swap}; $t->set_variable($_, $args->{$_}) for keys %$args; my $out = ''; # have temp item to allow clear to correctly clear eval { $t->_process($ref, $t->_vars, \$out) }; if (my $err = $@) { die $err if ! UNIVERSAL::can($err, 'type') || $err->type !~ /return/; } return $out; } sub define_filter { my ($self, $name, $filter, $is_dynamic) = @_; $filter = [ $filter, 1 ] if $is_dynamic; $self->define_vmethod('filter', $name, $filter); } sub filter { my ($self, $name, $args, $alias) = @_; my $t = $self->_template; my $filter; if (! ref $name) { $filter = $t->{'FILTERS'}->{$name} || $Template::Alloy::FILTER_OPS->{$name} || $Template::Alloy::SCALAR_OPS->{$name}; $t->throw('filter', $name) if ! $filter; } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) { $filter = $name; } elsif (UNIVERSAL::can($name, 'factory')) { $filter = $name->factory || $t->throw($name->error); } else { $t->throw('undef', "$name: filter not found"); } if (UNIVERSAL::isa($filter, 'ARRAY')) { $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0]; } elsif ($args && @$args) { my $sub = $filter; $filter = sub { $sub->(shift, @$args) }; } $t->{'FILTERS'}->{$alias} = $filter if $alias; return $filter; } sub define_vmethod { shift->_template->define_vmethod(@_) } sub throw { my ($self, $type, $info) = @_; if (UNIVERSAL::can($type, 'type')) { die $type; } elsif (defined $info) { $self->_template->throw($type, $info); } else { $self->_template->throw('undef', $type); } } sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") } sub DESTROY {} ###----------------------------------------------------------------### package Template::Alloy::_ContextStash; our $AUTOLOAD; sub _template { shift->{'_template'} || die "Missing _template" } sub get { my ($self, $var) = @_; if (! ref $var) { if ($var =~ /^\w+$/) { $var = [$var, 0] } else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) } } return $self->_template->play_expr($var, {no_dots => 1}); } sub set { my ($self, $var, $val) = @_; if (! ref $var) { if ($var =~ /^\w+$/) { $var = [$var, 0] } else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) } } $self->_template->set_variable($var, $val, {no_dots => 1}); return $val; } sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") } sub DESTROY {} ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION Template::Alloy::Context provides compatibility with Template::Context and filters that require Template::Context. =head1 TODO Document all of the methods. =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Exception.pm000066400000000000000000000027671402714000200237750ustar00rootroot00000000000000package Template::Alloy::Exception; =head1 NAME Template::Alloy::Exception - Handle exceptions =cut use strict; use warnings; use overload '""' => \&as_string, bool => sub { defined shift }, fallback => 1; sub new { my ($class, $type, $info, $node, $pos, $doc) = @_; return bless [$type, $info, $node, $pos, $doc], $class; } sub type { $_[0]->[0] } sub info { $_[0]->[1] = $_[1] if @_ >= 2; $_[0]->[1] } sub node { $_[0]->[2] = $_[1] if @_ >= 2; $_[0]->[2] } sub offset { $_[0]->[3] = $_[1] if @_ >= 2; $_[0]->[3] } sub doc { $_[0]->[4] = $_[1] if @_ >= 2; $_[0]->[4] } sub as_string { my $self = shift; if ($self->type =~ /^parse/) { if (my $doc = $self->doc) { my ($line, $char) = Template::Alloy->get_line_number_by_index($doc, $self->offset, 'include_char'); return $self->type ." error - $doc->{'name'} line $line char $char: ". $self->info; } else { return $self->type .' error - '. $self->info .' (At char '. $self->offset .')'; } } else { return $self->type .' error - '. $self->info; } } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION Template::Alloy::Exception provides compatibility with Template::Exception and filters that require Template::Exception. =head1 TODO Document all of the methods. =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/HTE.pm000066400000000000000000000615701402714000200224540ustar00rootroot00000000000000package Template::Alloy::HTE; =head1 NAME Template::Alloy::HTE - HTML::Template and HTML::Template::Expr roles. =cut use strict; use warnings; use Template::Alloy; our $VERSION = $Template::Alloy::VERSION; sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### ### support for few HTML::Template and HTML::Template::Expr calling syntax sub register_function { my ($name, $sub) = @_; $Template::Alloy::SCALAR_OPS->{$name} = $sub; } sub clear_param { shift->{'_vars'} = {} } sub query { shift->throw('query', "Not implemented in Template::Alloy") } sub new_file { my $class = shift; my $in = shift; $class->new(source => $in, type => 'filename', @_) } sub new_scalar_ref { my $class = shift; my $in = shift; $class->new(source => $in, type => 'scalarref', @_) } sub new_array_ref { my $class = shift; my $in = shift; $class->new(source => $in, type => 'arrayref', @_) } sub new_filehandle { my $class = shift; my $in = shift; $class->new(source => $in, type => 'filehandle', @_) } ###----------------------------------------------------------------### sub parse_tree_hte { my $self = shift; my $str_ref = shift; if (! $str_ref || ! defined $$str_ref) { $self->throw('parse.no_string', "No string or undefined during parse", undef, 1); } local $self->{'V2EQUALS'} = $self->{'V2EQUALS'} || 0; local $self->{'NO_TT'} = $self->{'NO_TT'} || ($self->{'SYNTAX'} eq 'hte' ? 0 : 1); local $self->{'START_TAG'} = qr{<(|!--\s*)(/?)([+=~-]?)[Tt][Mm][Pp][Ll]_(\w+)\b}; local $self->{'_start_tag'} = (! $self->{'INTERPOLATE'}) ? $self->{'START_TAG'} : qr{(?: $self->{'START_TAG'} | (\$))}sx; local $self->{'_end_tag'}; # changes over time my $dirs = $Template::Alloy::Parse::DIRECTIVES; my $aliases = $Template::Alloy::Parse::ALIASES; local @{ $dirs }{ keys %$aliases } = values %$aliases; # temporarily add to the table local @{ $self }{@Template::Alloy::CONFIG_COMPILETIME} = @{ $self }{@Template::Alloy::CONFIG_COMPILETIME}; delete $dirs->{'JS'} if ! $self->{'COMPILE_JS'}; my @tree; # the parsed tree my $pointer = \@tree; # pointer to current tree to handle nested blocks my @state; # maintain block levels local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS) local $self->{'_no_interp'} = 0; # no interpolation in perl my @in_view; # let us know if we are in a view my @blocks; # storage for defined blocks my @meta; # place to store any found meta information (to go into META) my $post_chomp = 0; # previous post_chomp setting my $continue = 0; # flag for multiple directives in the same tag my $post_op = 0; # found a post-operative DIRECTIVE my $capture; # flag to start capture my $func; my $pre_chomp; my $node; my ($comment, $is_close); pos($$str_ref) = 0; my $allow_expr = ! defined($self->{'EXPR'}) || $self->{'EXPR'}; # default is on while (1) { ### allow for TMPL_SET foo = PROCESS foo if ($capture) { $func = $$str_ref =~ m{ \G \s* (\w+)\b }gcx ? uc $1 : $self->throw('parse', "Error looking for block in capture DIRECTIVE", undef, pos($$str_ref)); $func = $aliases->{$func} if $aliases->{$func}; if ($func ne 'VAR' && ! $dirs->{$func}) { $self->throw('parse', "Found unknown DIRECTIVE ($func)", undef, pos($$str_ref) - length($func)); } $node = [$func, pos($$str_ref) - length($func), undef]; push @{ $capture->[4] }, $node; undef $capture; ### handle all other TMPL tags } else { ### find the next opening tag $$str_ref =~ m{ \G (.*?) $self->{'_start_tag'} }gcxs || last; my ($text, $dollar) = ($1, $6); ($comment, $is_close, $pre_chomp, $func) = ($2, $3, $4, uc $5) if ! $dollar; ### found a text portion - chomp it and store it if (length $text) { if (! $post_chomp) { } elsif ($post_chomp == 1) { $text =~ s{ ^ [^\S\n]* \n }{}x } elsif ($post_chomp == 2) { $text =~ s{ ^ \s+ }{ }x } elsif ($post_chomp == 3) { $text =~ s{ ^ \s+ }{}x } push @$pointer, $text if length $text; } ### handle variable interpolation ($2 eq $) if ($dollar) { ### inspect previous text chunk for escape slashes my $n = ($text =~ m{ (\\+) $ }x) ? length($1) : 0; if ($n && ! $self->{'_no_interp'}) { my $chop = int(($n + 1) / 2); # were there odd escapes substr($pointer->[-1], -$chop, $chop, '') if defined($pointer->[-1]) && ! ref($pointer->[-1]); } if ($self->{'_no_interp'} || $n % 2) { push @$pointer, $dollar; next; } my $not = $$str_ref =~ m{ \G ! }gcx; my $mark = pos($$str_ref); my $ref; if ($$str_ref =~ m{ \G \{ }gcx) { local $self->{'_operator_precedence'} = 0; # allow operators local $self->{'_end_tag'} = qr{\}}; $ref = $self->parse_expr($str_ref); $$str_ref =~ m{ \G \s* $Template::Alloy::Parse::QR_COMMENTS \} }gcxo || $self->throw('parse', 'Missing close }', undef, pos($$str_ref)); } else { local $self->{'_operator_precedence'} = 1; # no operators local $Template::Alloy::Parse::QR_COMMENTS = qr{}; $ref = $self->parse_expr($str_ref); } $self->throw('parse', "Error while parsing for interpolated string", undef, pos($$str_ref)) if ! defined $ref; if (! $not && $self->{'SHOW_UNDEFINED_INTERP'}) { $ref = [[undef, '//', $ref, '$'.substr($$str_ref, $mark, pos($$str_ref)-$mark)], 0]; } push @$pointer, ['GET', $mark, pos($$str_ref), $ref]; $post_chomp = 0; # no chomping after dollar vars next; } ### make sure we know this directive $func = $aliases->{$func} if $aliases->{$func}; if ($func ne 'VAR' && ! $dirs->{$func}) { $self->throw('parse', "Found unknow DIRECTIVE ($func)", undef, pos($$str_ref) - length($func)); } $node = [$func, pos($$str_ref) - length($func) - length($pre_chomp) - 5, undef]; ### take care of chomping - yes HT now get CHOMP SUPPORT $pre_chomp ||= $self->{'PRE_CHOMP'}; $pre_chomp =~ y/-=~+/1230/ if $pre_chomp; if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) { if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x } elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x } elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x } splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length } push @$pointer, $node; $self->{'_end_tag'} = $comment ? qr{([+=~-]?)-->} : qr{([+=~-]?)>}; # how will this tag end } $$str_ref =~ m{ \G \s+ }gcx; ### parse remaining tag details if (! $is_close) { ### handle HT style nodes if ($func =~ /^(IF|ELSIF|ELSE|UNLESS|LOOP|VAR|INCLUDE)$/) { $func = $node->[0] = 'GET' if $func eq 'VAR'; ### handle EXPR attribute if ($func eq 'ELSE') { # do nothing } elsif ($$str_ref =~ m{ \G [Ee][Xx][Pp][Rr] \s*=\s* ([\"\']?) \s* }gcx) { if (! $allow_expr) { $self->throw('parse', 'EXPR are not allowed without hte mode', undef, pos($$str_ref)); } my $quote = $1; local $self->{'_end_tag'} = $quote ? qr{$quote\s*$self->{'_end_tag'}} : $self->{'_end_tag'}; $node->[3] = eval { $self->parse_expr($str_ref) }; if (! defined($node->[3])) { my $err = $@ || $self->exception('parse', 'Error while looking for EXPR', undef, pos($$str_ref)); $err->info($err->info . " (Could be a missing close quote near expr=$quote)") if $quote && UNIVERSAL::can($err, 'info'); $self->throw($err); } if ($quote) { $$str_ref =~ m{ \G $quote }gcx || $self->throw('parse', "Missing close quote ($quote)", undef, pos($$str_ref)); } if ($func eq 'INCLUDE') { $node->[0] = 'PROCESS'; # no need to localize the stash $node->[3] = [[[undef, '{}'],0], $node->[3]]; } elsif ($func eq 'UNLESS') { $node->[0] = 'IF'; $node->[3] = [[undef, '!', $node->[3]], 0]; } if ($self->{'AUTO_FILTER'}) { $node->[3] = [[undef, '~', $node->[3]], 0] if ! ref $node->[3]; push @{ $node->[3] }, '|', $self->{'AUTO_FILTER'}, 0 if @{ $node->[3] } < 3 || $node->[3]->[-3] ne '|'; } ### handle "normal" NAME attributes } else { my ($name, $escape, $default); while (1) { if ($$str_ref =~ m{ \G (\w+) \s*=\s* }gcx) { my $key = lc $1; my $val = $$str_ref =~ m{ \G ([\"\']) (.*?) (?throw('parse', "Error while looking for value of \"$key\" attribute", undef, pos($$str_ref)); if ($key eq 'name') { $name ||= $val; } else { $self->throw('parse', uc($key)." not allowed in TMPL_$func tag", undef, pos($$str_ref)) if $func ne 'GET'; if ($key eq 'escape') { $escape ||= lc $val } elsif ($key eq 'default') { $default ||= $val } else { $self->throw('parse', uc($key)." not allowed in TMPL_$func tag", undef, pos($$str_ref)) } } } elsif ($$str_ref =~ m{ \G ([\w./+_]+) \s* }gcx) { $name ||= $1; } elsif ($$str_ref =~ m{ \G ([\"\']) (.*?) (?throw('parse', 'Error while looking for NAME', undef, pos($$str_ref)) if ! defined($name) || ! length($name); if ($func eq 'INCLUDE') { $node->[0] = 'PROCESS'; # no need to localize the stash $node->[3] = [[[undef, '{}'],0], $name]; } elsif ($func eq 'UNLESS') { $node->[0] = 'IF'; $node->[3] = [[undef, '!', [$name, 0]], 0]; } else { $node->[3] = [$name, 0]; # set the variable } $node->[3] = [[undef, '||', $node->[3], $default], 0] if $default; ### dress up node before finishing $escape = lc $self->{'DEFAULT_ESCAPE'} if ! $escape && $self->{'DEFAULT_ESCAPE'}; if ($escape) { $self->throw('parse', "ESCAPE not allowed in TMPL_$func tag", undef, pos($$str_ref)) if $func ne 'GET'; if ($escape eq 'html' || $escape eq '1') { push @{ $node->[3] }, '|', 'html', 0; } elsif ($escape eq 'url') { push @{ $node->[3] }, '|', 'url', 0; } elsif ($escape eq 'js') { push @{ $node->[3] }, '|', 'js', 0; } } elsif ($self->{'AUTO_FILTER'}) { push @{ $node->[3] }, '|', $self->{'AUTO_FILTER'}, 0; } } $node->[2] = pos $$str_ref; ### handle TT Directive extensions } else { $self->throw('parse', "Found a TT tag $func with NO_TT enabled", undef, pos($$str_ref)) if $self->{'NO_TT'}; $node->[3] = eval { $dirs->{$func}->[0]->($self, $str_ref, $node) }; if (my $err = $@) { $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; die $err; } $node->[2] = pos $$str_ref; } } ### handle ending tags - or continuation blocks if ($is_close || $dirs->{$func}->[4]) { if (! @state) { $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref)); } my $parent_node = pop @state; ### TODO - check for matching loop close name $func = $node->[0] = 'END' if $is_close; ### handle continuation blocks such as elsif, else, catch etc if ($dirs->{$func}->[4]) { pop @$pointer; # we will store the node in the parent instead $parent_node->[5] = $node; my $parent_type = $parent_node->[0]; if (! $dirs->{$func}->[4]->{$parent_type}) { $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref)); } } ### restore the pointer up one level (because we hit the end of a block) $pointer = (! @state) ? \@tree : $state[-1]->[4]; ### normal end block if (! $dirs->{$func}->[4]) { if ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front if (defined($parent_node->[3]) && @in_view) { push @{ $in_view[-1] }, $parent_node; } else { push @blocks, $parent_node; } if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var splice(@$pointer, -1, 1, ()); } } elsif ($parent_node->[0] eq 'VIEW') { my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }}; unshift @{ $parent_node->[3] }, $ref; } elsif ($dirs->{$parent_node->[0]}->[5]) { # allow no_interp to turn on and off $self->{'_no_interp'}--; } ### continuation block - such as an elsif } else { push @state, $node; $pointer = $node->[4] ||= []; } $node->[2] = pos $$str_ref; ### handle block directives } elsif ($dirs->{$func}->[2]) { push @state, $node; $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node push @in_view, [] if $func eq 'VIEW'; $self->{'_no_interp'}++ if $dirs->{$node->[0]}->[5] # allow no_interp to turn on and off } elsif ($func eq 'META') { unshift @meta, @{ $node->[3] }; # first defined win $node->[3] = undef; # only let these be defined once - at the front of the tree } ### look for the closing tag if ($$str_ref =~ m{ \G \s* $self->{'_end_tag'} }gcxs) { $post_chomp = $1 || $self->{'POST_CHOMP'}; $post_chomp =~ y/-=~+/1230/ if $post_chomp; $continue = 0; $post_op = 0; next; ### setup capturing } elsif ($node->[6]) { $capture = $node; next; ### no closing tag } else { $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref)); } } ### cleanup the tree unshift(@tree, @blocks) if @blocks; unshift(@tree, ['META', 1, 1, \@meta]) if @meta; $self->throw('parse', "Missing 0; ### pull off the last text portion - if any if (pos($$str_ref) != length($$str_ref)) { my $text = substr $$str_ref, pos($$str_ref); if (! $post_chomp) { } elsif ($post_chomp == 1) { $text =~ s{ ^ [^\S\n]* \n }{}x } elsif ($post_chomp == 2) { $text =~ s{ ^ \s+ }{ }x } elsif ($post_chomp == 3) { $text =~ s{ ^ \s+ }{}x } push @$pointer, $text if length $text; } return \@tree; } ###----------------------------------------------------------------### ### a few HTML::Template and HTML::Template::Expr routines sub param { my $self = shift; my $args; if (@_ == 1) { my $key = shift; if (ref($key) ne 'HASH') { $key = lc $key if ! $self->{'CASE_SENSITIVE'}; return $self->{'_vars'}->{$key}; } $args = [%$key]; } else { $self->throw('param', "Odd number of parameters") if @_ % 2; $args = \@_; } while (@$args) { my $key = shift @$args; $key = lc $key if ! $self->{'CASE_SENSITIVE'}; $self->{'_vars'}->{$key} = shift @$args; } return; } sub output { my $self = shift; my $args = ref($_[0]) eq 'HASH' ? shift : {@_}; my $type = $self->{'TYPE'} || ''; my $content; if ($type eq 'filehandle' || $self->{'FILEHANDLE'}) { my $in = $self->{'FILEHANDLE'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type filehandle'); local $/ = undef; $content = <$in>; $content = \$content; } elsif ($type eq 'arrayref' || $self->{'ARRAYREF'}) { my $in = $self->{'ARRAYREF'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type arrayref'); $content = join "", @$in; $content = \$content; } elsif ($type eq 'filename' || $self->{'FILENAME'}) { $content = $self->{'FILENAME'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type filename'); } elsif ($type eq 'scalarref' || $self->{'SCALARREF'}) { $content = $self->{'SCALARREF'} || $self->{'SOURCE'} || $self->throw('output', 'Missing source for type scalarref'); } else { $self->throw('output', "Unknown input type"); } my $param = $self->{'_vars'} || {}; if (my $ref = $self->{'ASSOCIATE'}) { foreach my $obj (ref($ref) eq 'ARRAY' ? @$ref : $ref) { foreach my $key ($obj->param) { $self->{'_vars'}->{$self->{'CASE_SENSITIVE'} ? $key : lc($key)} = $obj->param($key); } } } ### override some TT defaults local $self->{'FILE_CACHE'} = $self->{'DOUBLE_FILE_CACHE'} ? 1 : $self->{'FILE_CACHE'}; my $cache_size = ($self->{'CACHE'}) ? undef : 0; my $compile_dir = (! $self->{'FILE_CACHE'}) ? undef : $self->{'FILE_CACHE_DIR'} || $self->throw('output', 'Missing file_cache_dir'); my $stat_ttl = (! $self->{'BLIND_CACHE'}) ? undef : 60; # not sure how high to set the blind cache $cache_size = undef if $self->{'DOUBLE_FILE_CACHE'}; local $self->{'SYNTAX'} = $self->{'SYNTAX'} || 'hte'; local $self->{'GLOBAL_CACHE'} = $self->{'CACHE'}; local $self->{'ADD_LOCAL_PATH'} = defined($self->{'ADD_LOCAL_PATH'}) ? $self->{'ADD_LOCAL_PATH'} : 1; local $self->{'CACHE_SIZE'} = $cache_size; local $self->{'STAT_TTL'} = $stat_ttl; local $self->{'COMPILE_DIR'} = $compile_dir; local $self->{'ABSOLUTE'} = 1; local $self->{'RELATIVE'} = 1; local $self->{'INCLUDE_PATH'} = $self->{'PATH'}; local $self->{'LOWER_CASE_VAR_FALLBACK'} = ! $self->{'CASE_SENSITIVE'}; # un-smart HTML::Template default local $Template::Alloy::QR_PRIVATE = undef; my $out = ''; $self->process_simple($content, $param, \$out) || die $self->error; if ($args->{'print_to'}) { print {$args->{'print_to'}} $out; return undef; } else { return $out; } } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::HTE role provides syntax and interface support for the HTML::Template and HTML::Template::Expr modules. Provides for extra or extended features that may not be as commonly used. This module should not normally be used by itself. See the Template::Alloy documentation for configuration and other parameters. =head1 HOW IS Template::Alloy DIFFERENT FROM HTML::Template Alloy can use the same base template syntax and configuration items as HTE and HT. The internals of Alloy were written to support TT3, but were general enough to be extended to support HTML::Template as well. The result is HTML::Template::Expr compatible syntax, with Alloy speed and a wide range of additional features. The TMPL_VAR, TMPL_IF, TMPL_ELSE, TMPL_UNLESS, TMPL_LOOP, and TMPL_INCLUDE all work identically to HTML::Template. =over 4 =item Added support for other TT3 directives and for TT style "dot notation." # similar to ...)> Any of the TT directives can be used in HTML::Template documents. For many die-hard HTML::Template fans, it is probably quite scary to be providing all of the TT functionality. All of the extended TT functionality can be disabled by setting the NO_TT configuration item. The NO_TT configuration is automatically set if the SYNTAX is set to "ht" and the output method is called. =item There is an ELSIF!!! FOO BAR Done then =item Added CHOMP capabilities (PRE_CHOMP and POST_CHOMP) Foo <~TMPL_VAR EXPR="1+2"~> Bar Prints Foo3Bar =item Added INTERPOLATE capability 1> $foo ${ 1 + 2 } Prints FOO FOO 3 =item Allow for HTML::Template templates to include TT style templates. 'tt3'> =item Allow for Expr parsing to follow proper precedence rules. Properly prints 7. =item Uses all of the caching and opcode tree optimizations provided by Template::Alloy and Template::Alloy::XS. =item Alloy does not provide the query method from HTML::Template. This is because parsing of the document is delayed until the output method is called, and because Alloy supports TT style chained variables which often are not resolvable until run time. =back =head1 UNSUPPORTED HT CONFIGURATION =over 4 =item die_on_bad_params Alloy does not resolve variables until the template is output. =item force_untaint =item strict Alloy is strict on parsing HT documents. =item shared_cache, double_cache Alloy doesn't have shared caching. Yet. =item search_path_on_include Alloy will check the full path array on each include. =item debug items The HTML::Template style options are included here, but you can use the TT style DEBUG and DUMP directives to do introspection. =item max_includes Alloy uses TT's recursion protection. =item filter Alloy doesn't offer these. =back =head1 ROLE METHODS =over 4 =item C Defines a new function for later use as text vmethod or top level function. =item C Empties the parameter list. =item C Not supported. =item C Creates a new object that will process the passed file. $obj = Template::Alloy->new_file("my/file.hte"); =item C Creates a new object that will process the passed scalar ref. $obj = Template::Alloy->new_scalar_ref(\"some template text"); =item C New object that will process the passed array (each item represents a line). $obj = Template::Alloy->new_array_ref(\@array); =item C $obj = Template::Alloy->new_filehandle(\*FH); =item C Called by parse_tree when syntax is set to ht or hte. Parses for tags HTML::Template style. =item C See L. =item C See L. =back =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Iterator.pm000066400000000000000000000034031402714000200236140ustar00rootroot00000000000000package Template::Alloy::Iterator; =head1 NAME Template::Alloy::Iterator - Handle foreach iterations =cut use strict; use warnings; sub new { my ($class, $items) = @_; $items = [] if ! defined $items; if (ref($items) eq 'HASH') { $items = [ map { {key => $_, value => $items->{ $_ }} } sort keys %$items ]; } elsif (UNIVERSAL::can($items, 'as_list')) { $items = $items->as_list; } elsif (ref($items) ne 'ARRAY') { $items = [$items]; } return bless [$items, 0], $class; } sub get_first { my $self = shift; return (undef, 3) if ! @{ $self->[0] }; return ($self->[0]->[$self->[1] = 0], undef); } sub get_next { my $self = shift; return (undef, 3) if ++ $self->[1] > $#{ $self->[0] }; return ($self->items->[$self->[1]], undef); } sub items { shift->[0] } sub index { shift->[1] } sub max { $#{ shift->[0] } } sub size { shift->max + 1 } sub count { shift->index + 1 } sub number { shift->index + 1 } sub first { (shift->index == 0) || 0 } sub last { my $self = shift; return ($self->index == $self->max) || 0 } sub odd { shift->count % 2 ? 1 : 0 } sub even { shift->count % 2 ? 0 : 1 } sub parity { shift->count % 2 ? 'odd' : 'even' } sub prev { my $self = shift; return undef if $self->index <= 0; return $self->items->[$self->index - 1]; } sub next { my $self = shift; return undef if $self->index >= $self->max; return $self->items->[$self->index + 1]; } 1; __END__ =head1 DESCRIPTION Template::Alloy::Iterator provides compatibility with Template::Iterator and filters that require Template::Iterator. =head1 TODO Document all of the methods. =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Operator.pm000066400000000000000000000526371402714000200236330ustar00rootroot00000000000000package Template::Alloy::Operator; =head1 NAME Template::Alloy::Operator - Operator role. =cut use strict; use warnings; use Template::Alloy; use base qw(Exporter); our @EXPORT_OK = qw(play_operator define_operator $QR_OP $QR_OP_ASSIGN $QR_OP_PREFIX $QR_PRIVATE $OP $OP_ASSIGN $OP_PREFIX $OP_POSTFIX $OP_DISPATCH); our $VERSION = $Template::Alloy::VERSION; sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### ### setup the operator parsing our $OPERATORS = [ # type precedence symbols action (undef means play_operator will handle) ['prefix', 99, ['\\'], undef], ['postfix', 98, ['++'], undef], ['postfix', 98, ['--'], undef], ['prefix', 97, ['++'], undef], ['prefix', 97, ['--'], undef], ['right', 96, ['**', 'pow'], sub { no warnings; $_[0] ** $_[1] } ], ['prefix', 93, ['!'], sub { no warnings; ! $_[0] } ], ['prefix', 93, ['-'], sub { no warnings; @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], ['left', 90, ['*'], sub { no warnings; $_[0] * $_[1] } ], ['left', 90, ['/'], sub { no warnings; $_[0] / $_[1] } ], ['left', 90, ['div', 'DIV'], sub { no warnings; int($_[0] / $_[1]) } ], ['left', 90, ['%', 'mod', 'MOD'], sub { no warnings; $_[0] % $_[1] } ], ['left', 85, ['+'], sub { no warnings; $_[0] + $_[1] } ], ['left', 85, ['-'], sub { no warnings; @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], ['left', 85, ['~', '_'], undef], ['none', 80, ['<'], sub { no warnings; $_[0] < $_[1] } ], ['none', 80, ['>'], sub { no warnings; $_[0] > $_[1] } ], ['none', 80, ['<='], sub { no warnings; $_[0] <= $_[1] } ], ['none', 80, ['>='], sub { no warnings; $_[0] >= $_[1] } ], ['none', 80, ['lt'], sub { no warnings; $_[0] lt $_[1] } ], ['none', 80, ['gt'], sub { no warnings; $_[0] gt $_[1] } ], ['none', 80, ['le'], sub { no warnings; $_[0] le $_[1] } ], ['none', 80, ['ge'], sub { no warnings; $_[0] ge $_[1] } ], ['none', 75, ['=='], sub { no warnings; $_[0] == $_[1] } ], ['none', 75, ['eq'], sub { no warnings; $_[0] eq $_[1] } ], ['none', 75, ['!='], sub { no warnings; $_[0] != $_[1] } ], ['none', 75, ['ne'], sub { no warnings; $_[0] ne $_[1] } ], ['none', 75, ['<=>'], sub { no warnings; $_[0] <=> $_[1] } ], ['none', 75, ['cmp'], sub { no warnings; $_[0] cmp $_[1] } ], ['left', 70, ['&&'], undef], ['right', 65, ['||'], undef], ['right', 65, ['//'], undef], ['none', 60, ['..'], sub { no warnings; $_[0] .. $_[1] } ], ['ternary', 55, ['?', ':'], undef], ['assign', 53, ['+='], undef], ['assign', 53, ['-='], undef], ['assign', 53, ['*='], undef], ['assign', 53, ['/='], undef], ['assign', 53, ['%='], undef], ['assign', 53, ['**='], undef], ['assign', 53, ['~=', '_='], undef], ['assign', 53, ['//='], undef], ['assign', 53, ['||='], undef], ['assign', 52, ['='], undef], ['prefix', 50, ['not', 'NOT'], sub { no warnings; ! $_[0] } ], ['left', 45, ['and', 'AND'], undef], ['right', 40, ['or', 'OR' ], undef], ['right', 40, ['err', 'ERR'], undef], ]; our ($QR_OP, $QR_OP_PREFIX, $QR_OP_ASSIGN, $OP, $OP_PREFIX, $OP_DISPATCH, $OP_ASSIGN, $OP_POSTFIX, $OP_TERNARY); _build_ops(); ###----------------------------------------------------------------### sub _op_qr { # no mixed \w\W operators my %used; my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {! /\{\}|\[\]/} grep {/^\W{2,}$/} @_; my $chr = join '', sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_; my $word = join '|', reverse sort grep {++$used{$_} < 2} grep {/^\w+$/} @_; $chr = "[$chr]" if $chr; $word = "\\b(?:$word)\\b" if $word; return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex"; } sub _build_ops { $QR_OP = _op_qr(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS); $QR_OP_PREFIX = _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS); $QR_OP_ASSIGN = _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS); $OP = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] ne 'prefix' } @$OPERATORS}; # all non-prefix $OP_PREFIX = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] eq 'prefix' } @$OPERATORS}; $OP_DISPATCH = {map {my $ref = $_; map {$_ => $ref->[3]} @{$ref->[2]}} grep {$_->[3] } @$OPERATORS}; $OP_ASSIGN = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'assign' } @$OPERATORS}; $OP_POSTFIX = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'postfix'} @$OPERATORS}; # bool is postfix $OP_TERNARY = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'ternary'} @$OPERATORS}; # bool is ternary } ###----------------------------------------------------------------### sub play_operator { my ($self, $tree) = @_; ### $tree looks like [undef, '+', 4, 5] return $OP_DISPATCH->{$tree->[1]}->(@$tree == 3 ? $self->play_expr($tree->[2]) : ($self->play_expr($tree->[2]), $self->play_expr($tree->[3]))) if $OP_DISPATCH->{$tree->[1]}; my $op = $tree->[1]; ### do custom and short-circuitable operators if ($op eq '=') { my $val = $self->play_expr($tree->[3]); $self->set_variable($tree->[2], $val); return $val; } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') { my $val = $self->play_expr($tree->[2]) || $self->play_expr($tree->[3]); return defined($val) ? $val : ''; } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') { my $val = $self->play_expr($tree->[2]) && $self->play_expr($tree->[3]); return defined($val) ? $val : ''; } elsif ($op eq '//' || $op eq 'err' || $op eq 'ERR') { my $val = $self->play_expr($tree->[2]); return $val if defined $val; return $self->play_expr($tree->[3]); } elsif ($op eq '?') { no warnings; return $self->play_expr($tree->[2]) ? $self->play_expr($tree->[3]) : $self->play_expr($tree->[4]); } elsif ($op eq '~' || $op eq '_') { no warnings; my $s = ''; $s .= $self->play_expr($tree->[$_]) for 2 .. $#$tree; return $s; } elsif ($op eq '[]') { return [map {$self->play_expr($tree->[$_])} 2 .. $#$tree]; } elsif ($op eq '{}') { no warnings; my @e; push @e, $self->play_expr($tree->[$_]) for 2 .. $#$tree; return {@e}; } elsif ($op eq '++') { no warnings; my $val = 0 + $self->play_expr($tree->[2]); $self->set_variable($tree->[2], $val + 1); return $tree->[3] ? $val : $val + 1; # ->[3] is set to 1 during parsing of postfix ops } elsif ($op eq '--') { no warnings; my $val = 0 + $self->play_expr($tree->[2]); $self->set_variable($tree->[2], $val - 1); return $tree->[3] ? $val : $val - 1; # ->[3] is set to 1 during parsing of postfix ops } elsif ($op eq '@()') { local $self->{'CALL_CONTEXT'} = 'list'; return $self->play_expr($tree->[2]); } elsif ($op eq '$()') { local $self->{'CALL_CONTEXT'} = 'item'; return $self->play_expr($tree->[2]); } elsif ($op eq '\\') { my $var = $tree->[2]; my $ref = $self->play_expr($var, {return_ref => 1}); return $ref if ! ref $ref; return sub { sub { $$ref } } if ref $ref eq 'SCALAR' || ref $ref eq 'REF'; my $self_copy = $self; eval {require Scalar::Util; Scalar::Util::weaken($self_copy)}; my $last = ['temp deref key', $var->[-1] ? [@{ $var->[-1] }] : 0]; return sub { sub { # return a double sub so that the current play_expr will return a coderef local $self_copy->{'_vars'}->{'temp deref key'} = $ref; $last->[-1] = (ref $last->[-1] ? [@{ $last->[-1] }, @_] : [@_]) if @_; return $self->play_expr($last); } }; } elsif ($op eq '->') { my $code = $self->_macro_sub($tree->[2], $tree->[3]); return sub { $code }; # do the double sub dance } elsif ($op eq 'qr') { return $tree->[3] ? qr{(?$tree->[3]:$tree->[2])} : qr{$tree->[2]}; } $self->throw('operator', "Un-implemented operation $op"); } ###----------------------------------------------------------------### sub define_operator { my ($self, $args) = @_; push @$OPERATORS, [@{ $args }{qw(type precedence symbols play_sub)}]; _build_ops(); return 1; } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::Operator role provides the regexes necessary for Template::Alloy::Parse to parse operators and place them in their appropriate precedence. It also provides the play_operator method which is used by Template::Alloy::Play and Template::Alloy::Compile for playing out the stored operator ASTs. =head1 ROLE METHODS =over 4 =item play_operator Takes an operator AST in the form of [undef, '+', 1, 2] Essentially, all operators are stored in RPN notation with a leading "undef" to disambiguate operators in a normal Alloy expression AST. =item define_operator Used for defining new operators. See L for more details. =back =head1 OPERATOR LIST The following operators are available in Template::Alloy. Except where noted these are the same operators available in TT. They are listed in the order of their precedence (the higher the precedence the tighter it binds). =over 4 =item C<.> The dot operator. Allows for accessing sub-members, methods, or virtual methods of nested data structures. my $obj->process(\$content, {a => {b => [0, {c => [34, 57]}]}}, \$output); [% a.b.1.c.0 %] => 34 Note: on access to hashrefs, any hash keys that match the sub key name will be used before a virtual method of the same name. For example if a passed hash contained pair with a keyname "defined" and a value of "2", then any calls to hash.defined(another_keyname) would always return 2 rather than using the vmethod named "defined." To get around this limitation use the "|" operator (listed next). Also - on objects the "." will always try and call the method by that name. To always call the vmethod - use "|". =item C<|> The pipe operator. Similar to the dot operator. Allows for explicit calling of virtual methods and filters (filters are "merged" with virtual methods in Template::Alloy and TT3) when accessing hashrefs and objects. See the note for the "." operator. The pipe character is similar to TT2 in that it can be used in place of a directive as an alias for FILTER. It similar to TT3 in that it can be used for virtual method access. This duality is one source of difference between Template::Alloy and TT2 compatibility. Templates that have directives that end with a variable name that then use the "|" directive to apply a filter will be broken as the "|" will be applied to the variable name. The following two cases will do the same thing. [% foo | html %] [% foo FILTER html %] Though they do the same thing, internally, foo|html is stored as a single variable while "foo FILTER html" is stored as the variable foo which is then passed to the FILTER html. A TT2 sample that would break in Template::Alloy or TT3 is: [% PROCESS foo a = b | html %] Under TT2 the content returned by "PROCESS foo a = b" would all be passed to the html filter. Under Template::Alloy and TT3, b would be passed to the html filter before assigning it to the variable "a" before the template foo was processed. A simple fix is to do any of the following: [% PROCESS foo a = b FILTER html %] [% | html %][% PROCESS foo a = b %][% END %] [% FILTER html %][% PROCESS foo a = b %][% END %] This shouldn't be too much hardship and offers the great return of disambiguating virtual method access. =item C<\> Unary. The reference operator. Not well publicized in TT. Stores a reference to a variable for use later. Can also be used to "alias" long names. [% f = 7 ; foo = \f ; f = 8 ; foo %] => 8 [% foo = \f.g.h.i.j.k; f.g.h.i.j.k = 7; foo %] => 7 [% f = "abcd"; foo = \f.replace("ab", "-AB-") ; foo %] => -AB-cd [% f = "abcd"; foo = \f.replace("bc") ; foo("-BC-") %] => a-BC-d [% f = "abcd"; foo = \f.replace ; foo("cd", "-CD-") %] => ab-CD- =item C<++ --> Pre and post increment and decrement. My be used as either a prefix or postfix operator. [% ++a %][% ++a %] => 12 [% a++ %][% a++ %] => 01 [% --a %][% --a %] => -1-2 [% a-- %][% a-- %] => 0-1 =item C<** ^ pow> Right associative binary. X raised to the Y power. This isn't available in TT 2.15. [% 2 ** 3 %] => 8 =item C Prefix not. Negation of the value. =item C<-> Prefix minus. Returns the value multiplied by -1. [% a = 1 ; b = -a ; b %] => -1 =item C<*> Left associative binary. Multiplication. =item C Left associative binary. Division. Note that / is floating point division, but div and DIV are integer division. [% 10 / 4 %] => 2.5 [% 10 div 4 %] => 2 =item C<% mod MOD> Left associative binary. Modulus. [% 15 % 8 %] => 7 =item C<+> Left associative binary. Addition. =item C<-> Left associative binary. Minus. =item C<_ ~> Left associative binary. String concatenation. [% "a" ~ "b" %] => ab =item C<< < > <= >= >> Non associative binary. Numerical comparators. =item C Non associative binary. String comparators. =item C Non associative binary. String equality test. =item C<==> Non associative binary. In TT syntaxes the V2EQUALS configuration item defaults to true which means this operator will operate the same as the "eq" operator. Setting V2EQUALS to 0 will change this operator to mean numeric equality. You could also use [% ! (a <=> b) %] but that is a bit messy. The HTML::Template syntaxes default V2EQUALS to 0 which means that it will test for numeric equality just as you would normally expect. In either case - you should always use "eq" when you mean "eq". The V2EQUALS will most likely eventually default to 0. =item C Non associative binary. String non-equality test. =item C Non associative binary. In TT syntaxes the V2EQUALS configuration item defaults to true which means this operator will operate the same as the "ne" operator. Setting V2EQUALS to 0 will change this operator to mean numeric non-equality. You could also use [% (a <=> b) %] but that is a bit messy. The HTML::Template syntaxes default V2EQUALS to 0 which means that it will test for numeric non-equality just as you would normally expect. In either case - you should always use "ne" when you mean "ne". The V2EQUALS will most likely eventually default to 0. =item C<< <=> >> Non associative binary. Numeric comparison operator. Returns -1 if the first argument is less than the second, 0 if they are equal, and 1 if the first argument is greater. =item C<< cmp >> Non associative binary. String comparison operator. Returns -1 if the first argument is less than the second, 0 if they are equal, and 1 if the first argument is greater. =item C<&&> Left associative binary. And. All values must be true. If all values are true, the last value is returned as the truth value. [% 2 && 3 && 4 %] => 4 =item C<||> Right associative binary. Or. The first true value is returned. [% 0 || '' || 7 %] => 7 Note: perl is left associative on this operator - but it doesn't matter because || has its own precedence level. Setting it to right allows for Alloy to short circuit earlier in the expression optree (left is (((1,2), 3), 4) while right is (1, (2, (3, 4))). =item C Right associative binary. Perl 6 err. The first defined value is returned. [% foo // bar %] =item C<..> Non associative binary. Range creator. Returns an arrayref containing the values between and including the first and last arguments. [% t = [1 .. 5] %] => variable t contains an array with 1,2,3,4, and 5 It is possible to place multiple ranges in the same [] constructor. This is not available in TT. [% t = [1..3, 6..8] %] => variable t contains an array with 1,2,3,6,7,8 The .. operator is the only operator that returns a list of items. =item C Ternary - right associative. Can be nested with other ?: pairs. [% 1 ? 2 : 3 %] => 2 [% 0 ? 2 : 3 %] => 3 =item C<*= += -= /= **= %= ~=> Self-modifying assignment - right associative. Sets the left hand side to the operation of the left hand side and right (clear as mud). In order to not conflict with SET, FOREACH and other operations, this operator is only available in parenthesis. [% a = 2 %][% a += 3 %] --- [% a %] => --- 5 # is handled by SET [% a = 2 %][% (a += 3) %] --- [% a %] => 5 --- 5 =item C<=> Assignment - right associative. Sets the left-hand side to the value of the righthand side. In order to not conflict with SET, FOREACH and other operations, this operator is only available in parenthesis. Returns the value of the righthand side. [% a = 1 %] --- [% a %] => --- 1 # is handled by SET [% (a = 1) %] --- [% a %] => 1 --- 1 =item C Prefix. Lower precedence version of the '!' operator. =item C Left associative. Lower precedence version of the '&&' operator. =item C Right associative. Lower precedence version of the '||' operator. =item C Right associative. Lower precedence version of the '//' operator. =item C<-E> (Not in TT2) Macro operator. Works like the MACRO directive but can be used in map, sort, and grep list operations. Syntax is based on the Perl 6 pointy sub. There are two differences from the MACRO directive. First is that if no argument list is specified, a default argument list with a single parameter named "this" will be used. Second, the C<-E> operator parses its block as if it was already in a template tag. [% foo = ->{ "Hi" } %][% foo %] => Hi [% foo = ->{ this.repeat(2) } %][% foo("Hi") %] => HiHi [% foo = ->(n){ n.repeat(2) } %][% foo("Hi") %] => HiHi [% foo = ->(a,b){ a; "|"; b } %][% foo(2,3) %] => 2|3 [% [0..10].grep(->{ this % 2 }).join %] => 1 3 5 7 9 [% ['a'..'c'].map(->{ this.upper }).join %] => A B C [% [1,2,3].sort(->(a,b){ b <=> a }).join %] prints 3 2 1 [% c = [{k => "wow"}, {k => "wee"}, {k => "a"}] %] [% c.sort(->(a,b){ a.k cmp b.k }).map(->{this.k}).join %] => a wee wow Note: Care should be used when attempting to sort large lists. The mini-language of Template::Alloy is a interpreted language running in Perl which is an interpreted language. There are likely to be performance issues when trying to do low level functions such as sort on large lists. The RETURN directive and return item, list, and hash vmethods can be used to return more interesting values from a MACRO. [% a = ->(n){ [1..n].return } %] [% a(3).join %] => 1 2 3 [% a(10).join %] => 1 2 3 4 5 6 7 8 9 10 The Schwartzian transform is now possible in Template::Alloy (somebody somewhere is rolling over in their grave). [%- qw(Z a b D y M) .map(->{ [this.lc, this].return }) .sort(->(a,b){a.0 cmp b.0}) .map(->{this.1}) .join %] => a b D M y Z =item C<{}> This operator is not exposed for external use. It is used internally by Template::Alloy to delay the creation of a hash until the execution of the compiled template. =item C<[]> This operator is not exposed for external use. It is used internally by Template::Alloy to delay the creation of an array until the execution of the compiled template. =item C<@()> List context specifier. Methods or functions inside this operator will always be called in list context and will always return an arrayref of the results. See the CALL_CONTEXT configuration directive. =item C<$()> Item context specifier. Methods or functions inside this operator will always be called in item (scalar) context. See the CALL_CONTEXT configuration directive. =item C This operator is not exposed for external use. It is used internally by Template::Alloy to store a regular expression and its options. It will return a compiled Regexp object when compiled. =item C<-temp-> This operator is not exposed for external use. It is used internally by some directives to pass temporary, literal data into play_expr to allow additional vmethods or filters to be called on existing data. =back =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Parse.pm000066400000000000000000001331141402714000200231000ustar00rootroot00000000000000package Template::Alloy::Parse; =head1 NAME Template::Alloy::Parse - Common parsing role for creating AST from templates =cut use strict; use warnings; use base qw(Exporter); use Template::Alloy; use Template::Alloy::Operator qw($QR_OP $QR_OP_ASSIGN $QR_OP_PREFIX $OP $OP_ASSIGN $OP_PREFIX $OP_POSTFIX); our $VERSION = $Template::Alloy::VERSION; our @EXPORT_OK = qw(define_directive define_syntax $ALIASES $DIRECTIVES $TAGS $QR_DIRECTIVE $QR_COMMENTS); sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### our $TAGS = { asp => ['<%', '%>' ], # ASP default => ['\[%', '%\]' ], # default html => ['' ], # HTML comments mason => ['<%', '>' ], # HTML::Mason metatext => ['%%', '%%' ], # Text::MetaText php => ['<\?', '\?>' ], # PHP star => ['\[\*', '\*\]' ], # TT alternate template => ['\[%', '%\]' ], # Normal Template Toolkit template1 => ['[\[%]%', '%[%\]]'], # TT1 tt2 => ['\[%', '%\]' ], # TT2 }; our $SYNTAX = { alloy => sub { shift->parse_tree_tt3(@_) }, js => sub { shift->parse_tree_js(@_) }, jsr => sub { shift->parse_tree_jsr(@_) }, ht => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; local $self->{'EXPR'} = 0; $self->parse_tree_hte(@_) }, hte => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; $self->parse_tree_hte(@_) }, tt3 => sub { shift->parse_tree_tt3(@_) }, tt2 => sub { my $self = shift; local $self->{'V2PIPE'} = 1; $self->parse_tree_tt3(@_) }, tt1 => sub { my $self = shift; local $self->{'V2PIPE'} = 1; local $self->{'V1DOLLAR'} = 1; $self->parse_tree_tt3(@_) }, tmpl => sub { shift->parse_tree_tmpl(@_) }, velocity => sub { shift->parse_tree_velocity(@_) }, }; our $DIRECTIVES = { #name parse_sub play_sub block postdir continue no_interp BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1], BREAK => [sub {}, \&play_control], CALL => [\&parse_CALL, \&play_CALL], CASE => [\&parse_CASE, undef, 0, 0, {SWITCH => 1, CASE => 1}], CATCH => [\&parse_CATCH, undef, 0, 0, {TRY => 1, CATCH => 1}], CLEAR => [sub {}, \&play_CLEAR], '#' => [sub {}, sub {}], COMMENT => [sub {}, sub {}, 1], CONFIG => [\&parse_CONFIG, \&play_CONFIG], DEBUG => [\&parse_DEBUG, \&play_DEBUG], DEFAULT => [\&parse_DEFAULT, \&play_DEFAULT], DUMP => [\&parse_DUMP, \&play_DUMP], ELSE => [sub {}, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}], ELSIF => [\&parse_IF, undef, 0, 0, {IF => 1, ELSIF => 1, UNLESS => 1}], END => [sub {}, sub {}], EVAL => [\&parse_EVAL, \&play_EVAL], FILTER => [\&parse_FILTER, \&play_FILTER, 1, 1], '|' => [\&parse_FILTER, \&play_FILTER, 1, 1], FINAL => [sub {}, undef, 0, 0, {TRY => 1, CATCH => 1}], FOR => [\&parse_FOR, \&play_FOR, 1, 1], FOREACH => [\&parse_FOR, \&play_FOR, 1, 1], GET => [\&parse_GET, \&play_GET], IF => [\&parse_IF, \&play_IF, 1, 1], INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE], INSERT => [\&parse_INSERT, \&play_INSERT], JS => [sub {}, \&play_JS, 1, 0, 0, 1], LAST => [sub {}, \&play_control], LOOP => [\&parse_LOOP, \&play_LOOP, 1, 1], MACRO => [\&parse_MACRO, \&play_MACRO], META => [\&parse_META, \&play_META], NEXT => [sub {}, \&play_control], PERL => [sub {}, \&play_PERL, 1, 0, 0, 1], PROCESS => [\&parse_PROCESS, \&play_PROCESS], RAWPERL => [sub {}, \&play_RAWPERL, 1, 0, 0, 1], RETURN => [\&parse_RETURN, \&play_control], SET => [\&parse_SET, \&play_SET], STOP => [sub {}, \&play_control], SWITCH => [\&parse_SWITCH, \&play_SWITCH, 1], TAGS => [\&parse_TAGS, sub {}], THROW => [\&parse_THROW, \&play_THROW], TRY => [sub {}, \&play_TRY, 1], UNLESS => [\&parse_UNLESS, \&play_UNLESS, 1, 1], USE => [\&parse_USE, \&play_USE], VIEW => [\&parse_VIEW, \&play_VIEW, 1], WHILE => [\&parse_WHILE, \&play_WHILE, 1, 1], WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER, 1, 1], #name parse_sub play_sub block postdir continue no_interp }; our $ALIASES = { EVALUATE => 'EVAL', }; our $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )'; our $QR_COMMENTS = '(?-s: \# .* \s*)*'; our $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\.][\w\-\.]* (?:/[\w\-\.]+)*'; our $QR_BLOCK = '\w+\b (?: :\w+\b)* )'; our $QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]?\d+ )?'; our $QR_AQ_SPACE = '(?: \\s+ | \$ | (?=;) )'; our $_escapes = {n => "\n", r => "\r", t => "\t", '"' => '"', '\\' => '\\', '$' => '$'}; our $QR_ESCAPES = qr{[nrt\"\$\\]}; sub define_directive { my ($self, $name, $args) = @_; $DIRECTIVES->{$name} = [@{ $args }{qw(parse_sub play_sub is_block is_postop continues no_interp)}]; return 1; } sub define_syntax { my ($self, $name, $sub) = @_; $SYNTAX->{$name} = $sub; return 1; } ###----------------------------------------------------------------### sub parse_tree { my $syntax = $_[0]->{'SYNTAX'} || 'alloy'; my $meth = $SYNTAX->{$syntax} || $_[0]->throw('config', "Unknown SYNTAX \"$syntax\""); return $meth->(@_); } ###----------------------------------------------------------------### sub parse_expr { my $self = shift; my $str_ref = shift; my $ARGS = shift || {}; my $is_aq = $ARGS->{'auto_quote'} ? 1 : 0; my $mark = pos $$str_ref; ### allow for custom auto_quoting (such as hash constructors) if ($is_aq) { if ($$str_ref =~ m{ \G \s* $QR_COMMENTS $ARGS->{'auto_quote'} }gcx) { return $1; ### allow for ${foo.bar} type constructs } elsif ($$str_ref =~ m{ \G \$\{ }gcx) { my $var = $self->parse_expr($str_ref); $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); return $var; ### allow for auto-quoted $foo } elsif ($$str_ref =~ m{ \G \$ }gcx) { return $self->parse_expr($str_ref) || $self->throw('parse', "Missing variable", undef, pos($$str_ref)); } } $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; ### allow for macro definer if ($$str_ref =~ m{ \G -> \s* }gcxo) { # longest token would be nice - until then this comes before prefix local $self->{'_operator_precedence'} = 0; # reset presedence my $args; if ($$str_ref =~ m{ \G \( \s* }gcx) { $args = $self->parse_args($str_ref, {positional_only => 1}); $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref)); } $$str_ref =~ m{ \G \{ $QR_COMMENTS }gcx || $self->throw('parse.missing', "Missing open '{'", undef, pos($$str_ref)); local $self->{'END_TAG'} = qr{ \} }x; my $tree = $self->parse_tree_tt3($str_ref, 'one_tag_only'); return [[undef, '->', $args || [['this',0]], $tree]]; } ### test for leading prefix operators my $has_prefix; while (! $is_aq && $$str_ref =~ m{ \G ($QR_OP_PREFIX) }gcxo) { push @{ $has_prefix }, $1; $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; } my @var; my $is_literal; my $is_namespace; my $already_parsed_args; ### allow hex if ($$str_ref =~ m{ \G 0x ( [a-fA-F0-9]+ ) }gcx) { my $number = eval { hex $1 } || 0; push @var, \ $number; $is_literal = 1; ### allow for numbers } elsif ($$str_ref =~ m{ \G ( $QR_NUM ) }gcx) { my $number = 0 + $1; push @var, \ $number; $is_literal = 1; ### allow for quoted array constructor } elsif (! $is_aq && $$str_ref =~ m{ \G qw ([^\w\s]) \s* }gcxo) { my $quote = $1; $quote =~ y|([{<|)]}>|; $$str_ref =~ m{ \G (.*?) (?throw('parse.missing.array_close', "Missing close \"$quote\"", undef, pos($$str_ref)); my $str = $1; $str =~ s{ ^ \s+ }{}x; $str =~ s{ \s+ $ }{}x; $str =~ s{ \\ \Q$quote\E }{$quote}gx; push @var, [undef, '[]', split /\s+/, $str]; ### looks like a normal variable start } elsif ($$str_ref =~ m{ \G (\w+) }gcx) { push @var, $1; $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1}; ### allow for regex constructor } elsif (! $is_aq && $$str_ref =~ m{ \G / }gcx) { $$str_ref =~ m{ \G (.*?) (?throw('parse', 'Unclosed regex tag "/"', undef, pos($$str_ref)); my ($str, $opts) = ($1, $2); $self->throw('parse', 'e option not allowed on regex', undef, pos($$str_ref)) if $opts =~ /e/; $self->throw('parse', 'g option not supported on regex', undef, pos($$str_ref)) if $opts =~ /g/; $str =~ s|\\n|\n|g; $str =~ s|\\t|\t|g; $str =~ s|\\r|\r|g; $str =~ s|\\\/|\/|g; $str =~ s|\\\$|\$|g; $self->throw('parse', "Invalid regex: $@", undef, pos($$str_ref)) if ! eval { "" =~ /$str/; 1 }; push @var, [undef, 'qr', $str, $opts]; ### allow for single quoted strings } elsif ($$str_ref =~ m{ \G \' (.*?) (?{$1} : '\\'; if (defined($pieces[-1]) && ! ref($pieces[-1])) { $pieces[-1] .= $chr; } else { push @pieces, $chr } next; } elsif ($item eq '"') { last; } elsif ($self->{'AUTO_EVAL'}) { if (defined($pieces[-1]) && ! ref($pieces[-1])) { $pieces[-1] .= '$'; } else { push @pieces, '$' } next; } my $not = $$str_ref =~ m{ \G ! }gcx; my $mark = pos($$str_ref); my $ref; if ($$str_ref =~ m{ \G \{ }gcx) { local $self->{'_operator_precedence'} = 0; # allow operators $ref = $self->parse_expr($str_ref); $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo || $self->throw('parse', 'Missing close }', undef, pos($$str_ref)); } else { local $self->{'_operator_precedence'} = 1; # no operators $ref = $self->parse_expr($str_ref) || $self->throw('parse', "Error while parsing for interpolated string", undef, pos($$str_ref)); } if (! $not && $self->{'SHOW_UNDEFINED_INTERP'}) { $ref = [[undef, '//', $ref, '$'.substr($$str_ref, $mark, pos($$str_ref)-$mark)], 0]; } push @pieces, $ref if defined $ref; } if (! @pieces) { # [% "" %] return '' if $is_aq; push @var, \ ''; $is_literal = 1; } elsif (@pieces == 1 && ref $pieces[0]) { # [% "$foo" %] or [% "${ 1 + 2 }" %] return $pieces[0] if $is_aq; push @var, @{ $pieces[0] }; $already_parsed_args = 1; } elsif ($self->{'AUTO_EVAL'}) { push @var, [undef, '~', @pieces], 0, '|', 'eval', 0; return \@var if $is_aq; $already_parsed_args = 1; } elsif (@pieces == 1) { # [% "foo" %] return $pieces[0] if $is_aq; push @var, \ $pieces[0]; $is_literal = 1; } else { # [% "foo $bar baz" %] push @var, [undef, '~', @pieces]; return [$var[0], 0] if $is_aq; } ### allow for leading $foo type constructs } elsif ($$str_ref =~ m{ \G \$ (\w+) \b }gcx) { if ($self->{'V1DOLLAR'}) { push @var, $1; $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1}; } else { push @var, [$1, 0]; } ### allow for ${foo.bar} type constructs } elsif ($$str_ref =~ m{ \G \$\{ }gcx) { push @var, $self->parse_expr($str_ref); $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); ### looks like an array constructor } elsif (! $is_aq && $$str_ref =~ m{ \G \[ }gcx) { local $self->{'_operator_precedence'} = 0; # reset presedence my $arrayref = [undef, '[]']; while (defined(my $var = $self->parse_expr($str_ref))) { push @$arrayref, $var; $$str_ref =~ m{ \G \s* $QR_COMMENTS , }gcxo; } $$str_ref =~ m{ \G \s* $QR_COMMENTS \] }gcxo || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, pos($$str_ref)); push @var, $arrayref; ### looks like a hash constructor } elsif (! $is_aq && $$str_ref =~ m{ \G \{ }gcx) { local $self->{'_operator_precedence'} = 0; # reset precedence my $hashref = [undef, '{}']; while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))) { $$str_ref =~ m{ \G \s* $QR_COMMENTS (?: = >? | [:,]) }gcxo; my $val = $self->parse_expr($str_ref); push @$hashref, $key, $val; $$str_ref =~ m{ \G \s* $QR_COMMENTS , }gcxo; } $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo || $self->throw('parse.missing.curly_bracket', "Missing close \}", undef, pos($$str_ref)); push @var, $hashref; ### looks like a paren grouper or a context specifier } elsif (! $is_aq && $$str_ref =~ m{ \G ([\$\@]?) \( }gcx) { local $self->{'_operator_precedence'} = 0; # reset precedence my $ctx = $1; my $var = $self->parse_expr($str_ref, {allow_parened_ops => 1}); $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo || $self->throw('parse.missing.paren', "Missing close \) in group", undef, pos($$str_ref)); $self->throw('parse', 'Paren group cannot be followed by an open paren', undef, pos($$str_ref)) if $$str_ref =~ m{ \G \( }gcx; $already_parsed_args = 1; if (! ref $var) { push @var, \$var, 0; $is_literal = 1; } elsif (! defined $var->[0]) { push @var, $var, 0; } else { push @var, @$var; } if ($ctx) { my $copy = [@var]; @var = ([undef, "$ctx()", $copy], 0); } ### nothing to find - return failure } else { pos($$str_ref) = $mark if $is_aq || $has_prefix; return; } # auto_quoted thing was too complicated if ($is_aq) { pos($$str_ref) = $mark; return; } ### looks for args for the initial if ($already_parsed_args) { # do nothing } elsif ($$str_ref =~ m{ \G \( }gcxo) { local $self->{'_operator_precedence'} = 0; # reset precedence my $args = $self->parse_args($str_ref, {is_parened => 1}); $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo || $self->throw('parse.missing.paren', "Missing close \) in args", undef, pos($$str_ref)); push @var, $args; } else { push @var, 0; } ### allow for nested items while ($$str_ref =~ m{ \G \s* $QR_COMMENTS ( \.(?!\.) | \|(?!\|) ) }gcx) { if ($1 eq '|' && $self->{'V2PIPE'}) { pos($$str_ref) -= 1; last; } push(@var, $1) if ! $ARGS->{'no_dots'}; $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; ### allow for interpolated variables in the middle - one.$foo.two if ($$str_ref =~ m{ \G \$ (\w+) \b }gcxo) { push @var, $self->{'V1DOLLAR'} ? $1 : [$1, 0]; ### or one.${foo.bar}.two } elsif ($$str_ref =~ m{ \G \$\{ }gcx) { push @var, $self->parse_expr($str_ref); $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref)); ### allow for names (foo.bar or foo.0 or foo.-1) } elsif ($$str_ref =~ m{ \G (-? \w+) }gcx) { push @var, $1; } else { $self->throw('parse', "Not sure how to continue parsing", undef, pos($$str_ref)); } ### looks for args for the nested item if ($$str_ref =~ m{ \G \( }gcx) { local $self->{'_operator_precedence'} = 0; # reset precedence my $args = $self->parse_args($str_ref, {is_parened => 1}); $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo || $self->throw('parse.missing.paren', "Missing close \) in args of nested item", undef, pos($$str_ref)); push @var, $args; } else { push @var, 0; } } ### flatten literals and constants as much as possible my $var; if ($is_literal) { $var = ${ $var[0] }; if ($#var != 1) { $var[0] = [undef, '~', $var]; $var = \@var; } } elsif ($is_namespace) { my $name = $var[0]; local $self->{'_vars'}->{$name} = $self->{'NAMESPACE'}->{$name}; $var = $self->play_expr(\@var, {is_namespace_during_compile => 1}); } else { $var = \@var; } ### allow for all "operators" if (! $self->{'_operator_precedence'}) { my $tree; my $found; while (1) { my $mark = pos $$str_ref; $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; if ($self->{'_end_tag'} && $$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) { pos($$str_ref) = $mark; last; } elsif ($$str_ref !~ m{ \G ($QR_OP) }gcxo) { pos($$str_ref) = $mark; last; } if ($OP_ASSIGN->{$1} && ! $ARGS->{'allow_parened_ops'}) { # only allow assignment in parens pos($$str_ref) = $mark; last; } local $self->{'_operator_precedence'} = 1; my $op = $1; $op = 'eq' if $op eq '==' && (! defined($self->{'V2EQUALS'}) || $self->{'V2EQUALS'}); $op = 'ne' if $op eq '!=' && (! defined($self->{'V2EQUALS'}) || $self->{'V2EQUALS'}); ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --) if ($OP_POSTFIX->{$op}) { $var = [[undef, $op, $var, 1], 0]; # cheat - give a "second value" to postfix ops next; ### allow for prefix operator precedence } elsif ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix->[-1]}->[1]) { if ($tree) { if ($#$tree == 1) { # only one operator - keep simple things fast $var = [[undef, $tree->[0], $var, $tree->[1]], 0]; } else { unshift @$tree, $var; $var = $self->apply_precedence($tree, $found, $str_ref); } undef $tree; undef $found; } $var = [[undef, $has_prefix->[-1], $var ], 0]; pop @$has_prefix; $has_prefix = undef if ! @$has_prefix; } ### add the operator to the tree my $var2 = $self->parse_expr($str_ref); $self->throw('parse', 'Missing variable after "'.$op.'"', undef, pos($$str_ref)) if ! defined $var2; push (@{ $tree ||= [] }, $op, $var2); $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op} } ### if we found operators - tree the nodes by operator precedence if ($tree) { if (@$tree == 2) { # only one operator - keep simple things fast if ($OP->{$tree->[0]}->[0] eq 'assign' && $tree->[0] =~ /(.+)=/) { $var = [[undef, '=', $var, [[undef, $1, $var, $tree->[1]], 0]], 0]; # "a += b" => "a = a + b" } else { $var = [[undef, $tree->[0], $var, $tree->[1]], 0]; } } else { unshift @$tree, $var; $var = $self->apply_precedence($tree, $found, $str_ref); } } } ### allow for prefix on non-chained variables if ($has_prefix) { $var = [[undef, $_, $var], 0] for reverse @$has_prefix; } return $var; } ### this is used to put the parsed variables into the correct operations tree sub apply_precedence { my ($self, $tree, $found, $str_ref) = @_; my @var; my $trees; ### look at the operators we found in the order we found them for my $prec (sort keys %$found) { my $ops = $found->{$prec}; local $found->{$prec}; delete $found->{$prec}; ### split the array on the current operators for this level my @ops; my @exprs; for (my $i = 1; $i <= $#$tree; $i += 2) { next if ! $ops->{ $tree->[$i] }; push @ops, $tree->[$i]; push @exprs, [splice @$tree, 0, $i, ()]; shift @$tree; $i = -1; } next if ! @exprs; # this iteration didn't have the current operator push @exprs, $tree if scalar @$tree; # add on any remaining items ### simplify sub expressions for my $node (@exprs) { if (@$node == 1) { $node = $node->[0]; # single item - its not a tree } elsif (@$node == 3) { $node = [[undef, $node->[1], $node->[0], $node->[2]], 0]; # single operator - put it straight on } else { $node = $self->apply_precedence($node, $found, $str_ref); # more complicated - recurse } } ### assemble this current level ### some rules: # 1) items at the same precedence level must all be either right or left or ternary associative # 2) ternary items cannot share precedence with anybody else. # 3) there really shouldn't be another operator at the same level as a postfix my $type = $OP->{$ops[0]}->[0]; if ($type eq 'ternary') { my $op = $OP->{$ops[0]}->[2]->[0]; # use the first op as what we are using ### return simple ternary if (@exprs == 3) { $self->throw('parse', "Ternary operator mismatch", undef, pos($$str_ref)) if $ops[0] ne $op; $self->throw('parse', "Ternary operator mismatch", undef, pos($$str_ref)) if ! $ops[1] || $ops[1] eq $op; return [[undef, $op, @exprs], 0]; } ### reorder complex ternary - rare case while ($#ops >= 1) { ### if we look starting from the back - the first lead ternary op will always be next to its matching op for (my $i = $#ops; $i >= 0; $i --) { next if $OP->{$ops[$i]}->[2]->[1] eq $ops[$i]; my ($op, $op2) = splice @ops, $i, 2, (); # remove the pair of operators my $node = [[undef, $op, @exprs[$i .. $i + 2]], 0]; splice @exprs, $i, 3, $node; } } return $exprs[0]; # at this point the ternary has been reduced to a single operator } elsif ($type eq 'right' || $type eq 'assign') { my $val = $exprs[-1]; for (reverse (0 .. $#exprs - 1)) { if ($type eq 'assign' && $ops[$_ - 1] =~ /(.+)=$/) { $val = [[undef, '=', $exprs[$_], [[undef, $1, $exprs[$_], $val], 0]], 0]; } else { $val = [[undef, $ops[$_ - 1], $exprs[$_], $val], 0]; } } return $val; } else { my $val = $exprs[0]; $val = [[undef, $ops[$_ - 1], $val, $exprs[$_]], 0] for (1 .. $#exprs); return $val; } } $self->throw('parse', "Couldn't apply precedence", undef, pos($$str_ref)); } ### look for arguments - both positional and named sub parse_args { my $self = shift; my $str_ref = shift; my $ARGS = shift || {}; my @args; my @named; my $name; my $end = $self->{'_end_tag'} || '(?!)'; while (1) { my $mark = pos $$str_ref; ### look to see if the next thing is a directive or a closing tag if (! $ARGS->{'is_parened'} && ! $ARGS->{'require_arg'} && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$end))) }gcxo && ((pos($$str_ref) = $mark) || 1) # always revert && $DIRECTIVES->{$self->{'ANYCASE'} ? uc($1) : $1} # looks like a directive - we are done ) { last; } if ($$str_ref =~ m{ \G [+=~-]? $end }gcx) { pos($$str_ref) = $mark; last; } ### find the initial arg my $name; if ($ARGS->{'allow_bare_filenames'}) { $name = $self->parse_expr($str_ref, {auto_quote => " ($QR_FILENAME # file name | $QR_BLOCK # or block (?= [+=~-]? $end # an end tag | \\s*[+,;] # followed by explicit + , or ; | \\s+ (?! [\\s=]) # or space not before an = ) \\s* $QR_COMMENTS"}); # filenames can be separated with a "+" - why a "+" ? if ($$str_ref =~ m{ \G \+ (?! \s* $QR_COMMENTS [+=~-]? $end) }gcxo) { push @args, $name; $ARGS->{'require_arg'} = 1; next; } } if (! defined $name) { $name = $self->parse_expr($str_ref); if (! defined $name) { if ($ARGS->{'require_arg'} && ! @args && ! $ARGS->{'positional_only'} && ! @named) { $self->throw('parse', 'Argument required', undef, pos($$str_ref)); } else { last; } } } $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; ### see if it is named or positional if ($$str_ref =~ m{ \G \s* $QR_COMMENTS = >? }gcxo) { $self->throw('parse', 'Named arguments not allowed', undef, $mark) if $ARGS->{'positional_only'}; my $val = $self->parse_expr($str_ref); $name = $name->[0] if ref($name) && @$name == 2 && ! $name->[1]; # strip a level of indirection on named arguments push @named, $name, $val; } else { push @args, $name; } ### look for trailing comma $ARGS->{'require_arg'} = ($$str_ref =~ m{ \G \s* $QR_COMMENTS , }gcxo) || 0; } ### allow for named arguments to be added at the front (if asked) if ($ARGS->{'named_at_front'}) { unshift @args, [[undef, '{}', @named], 0]; } elsif (scalar @named) { # only add at end - if there are some push @args, [[undef, '{}', @named], 0] } return \@args; } ###----------------------------------------------------------------### sub parse_BLOCK { my ($self, $str_ref, $node) = @_; my $end = $self->{'_end_tag'} || '(?!)'; my $block_name = $self->parse_expr($str_ref, {auto_quote => " ($QR_FILENAME # file name | $QR_BLOCK # or block (?= [+=~-]? $end # an end tag | \\s*[+,;] # followed by explicit + , or ; | \\s+ (?! [\\s=]) # or space not before an = ) \\s* $QR_COMMENTS"}); return '' if ! defined $block_name; my $prepend = join "/", map {$_->[3]} grep {ref($_) && $_->[0] eq 'BLOCK'} @{ $self->{'_state'} || {} }; return $prepend ? "$prepend/$block_name" : $block_name; } sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) } sub parse_CASE { my ($self, $str_ref) = @_; return if $$str_ref =~ m{ \G DEFAULT \s* }gcx; return $self->parse_expr($str_ref); } sub parse_CATCH { my ($self, $str_ref) = @_; return $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"}); } sub parse_CONFIG { my ($self, $str_ref) = @_; my %ctime = map {$_ => 1} @Template::Alloy::CONFIG_COMPILETIME; my %rtime = map {$_ => 1} @Template::Alloy::CONFIG_RUNTIME; my $mark = pos($$str_ref); my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1}); my $ref = $config->[0]->[0]; for (my $i = 2; $i < @$ref; $i += 2) { my $key = $ref->[$i] = uc $ref->[$i]; my $val = $ref->[$i + 1]; if ($ctime{$key}) { $self->{$key} = $self->play_expr($val); if ($key eq 'INTERPOLATE') { $self->{'_start_tag'} = (! $self->{'INTERPOLATE'}) ? $self->{'START_TAG'} : qr{(?: $self->{'START_TAG'} | (\$))}sx; } } elsif (! $rtime{$key}) { $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref)); } } for (my $i = 1; $i < @$config; $i++) { my $key = $config->[$i] = uc $config->[$i]->[0]; if ($ctime{$key}) { $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef'); } elsif (! $rtime{$key}) { $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref)); } } return $config; } sub parse_DEBUG { my ($self, $str_ref) = @_; $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref)); my $ret = [lc($1)]; if ($ret->[0] eq 'format') { $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs || $self->throw('parse', "Missing format string", undef, pos($$str_ref)); $ret->[1] = $2; } return $ret; } sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) } sub parse_DUMP { my ($self, $str_ref) = @_; return $self->parse_args($str_ref, {named_at_front => 1}); } sub parse_EVAL { my ($self, $str_ref) = @_; return $self->parse_args($str_ref, {named_at_front => 1}); } sub parse_FILTER { my ($self, $str_ref) = @_; my $name = ''; if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) { $name = $1; } my $filter = $self->parse_expr($str_ref); $filter = '' if ! defined $filter; return [$name, $filter]; } sub parse_FOR { my ($self, $str_ref) = @_; my $items = $self->parse_expr($str_ref); my $var; if ($$str_ref =~ m{ \G \s* $QR_COMMENTS (= | [Ii][Nn]\b) \s* }gcxo) { $var = [@$items]; $items = $self->parse_expr($str_ref); } return [$var, $items]; } sub parse_GET { my ($self, $str_ref) = @_; my $ref = $self->parse_expr($str_ref); $self->throw('parse', "Missing variable name", undef, pos($$str_ref)) if ! defined $ref; if ($self->{'AUTO_FILTER'}) { $ref = [[undef, '~', $ref], 0] if ! ref $ref; push @$ref, '|', $self->{'AUTO_FILTER'}, 0 if @$ref < 3 || $ref->[-3] ne '|'; } return $ref; } sub parse_IF { my ($self, $str_ref) = @_; return $self->parse_expr($str_ref); } sub parse_INCLUDE { $DIRECTIVES->{'PROCESS'}->[0]->(@_) } sub parse_INSERT { $DIRECTIVES->{'PROCESS'}->[0]->(@_) } sub parse_LOOP { my ($self, $str_ref, $node) = @_; return $self->parse_expr($str_ref) || $self->throw('parse', 'Missing variable on LOOP directive', undef, pos($$str_ref)); } sub parse_MACRO { my ($self, $str_ref, $node) = @_; my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.)"}); $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name; if (! ref $name) { $name = [ $name, 0 ]; } my $args; if ($$str_ref =~ m{ \G \( \s* }gcx) { $args = $self->parse_args($str_ref, {positional_only => 1}); $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref)); } elsif ($self->{'V1DOLLAR'}) { # allow for Velocity style macro args (no parens - but dollars are fine) while ($$str_ref =~ m{ \G (\s+ \$) }gcx) { my $lead = $1; my $arg = $self->parse_expr($str_ref); if (! defined $arg) { pos($$str_ref) -= length($lead); last; } push @$args, $arg; } } $node->[6] = 1; # set a flag to keep parsing return [$name, $args]; } sub parse_META { my ($self, $str_ref) = @_; my $args = $self->parse_args($str_ref, {named_at_front => 1}); my $hash; return [%$hash] if ($hash = $self->play_expr($args->[0])) && UNIVERSAL::isa($hash, 'HASH'); return undef; } sub parse_PROCESS { my ($self, $str_ref) = @_; return $self->parse_args($str_ref, { named_at_front => 1, allow_bare_filenames => 1, require_arg => 1, }); } sub parse_RETURN { my ($self, $str_ref) = @_; my $ref = $self->parse_expr($str_ref); # optional return value return $ref; } sub parse_SET { my ($self, $str_ref, $node, $initial_op, $initial_var) = @_; my @SET; my $func; if ($initial_op) { if ($initial_op eq '=' && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE }gcx # find a word && ((pos($$str_ref) -= length($1)) || 1) # always revert && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing $node->[6] = 1; # set a flag to keep parsing my $val = $node->[4] ||= []; # setup storage return [[$initial_op, $initial_var, $val]]; } else { # get a normal variable my $val = $self->parse_expr($str_ref); if ($initial_op =~ /(.+)=$/) { $initial_op = '='; $val = [[undef, $1, $initial_var, $val], 0]; } return [[$initial_op, $initial_var, $val]]; } } while (1) { my $set = $self->parse_expr($str_ref); last if ! defined $set; if ($$str_ref =~ m{ \G \s* $QR_COMMENTS ($QR_OP_ASSIGN) >? }gcx) { my $op = $1; if ($op eq '=' && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE }gcx # find a word && ((pos($$str_ref) -= length($1)) || 1) # always revert && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing $node->[6] = 1; # set a flag to keep parsing my $val = $node->[4] ||= []; # setup storage if ($op =~ /(.+)=$/) { $op = '='; $val = [[undef, $1, $set, $val], 0]; } push @SET, [$op, $set, $val]; last; } else { # get a normal variable push @SET, [$op, $set, $self->parse_expr($str_ref)]; } } else { push @SET, ['=', $set, undef]; } } return \@SET; } sub parse_SWITCH { $DIRECTIVES->{'GET'}->[0]->(@_) } sub parse_TAGS { my ($self, $str_ref, $node) = @_; my ($start, $end); if ($$str_ref =~ m{ \G (\w+) }gcxs) { my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref)); ($start, $end) = @$ref; } else { local $self->{'_operator_precedence'} = 1; # prevent operator matching $start = $$str_ref =~ m{ \G (?= \s* $QR_COMMENTS [\'\"\/]) }gcx ? $self->parse_expr($str_ref) : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s+ $QR_COMMENTS"}) || $self->throw('parse', "Invalid opening tag in TAGS", undef, pos($$str_ref)); $end = $$str_ref =~ m{ \G (?= \s* $QR_COMMENTS [\'\"\/]) }gcx ? $self->parse_expr($str_ref) : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s* $QR_COMMENTS"}) || $self->throw('parse', "Invalid closing tag in TAGS", undef, pos($$str_ref)); for my $tag ($start, $end) { $tag = $self->play_expr($tag); $tag = quotemeta($tag) if ! ref $tag; } } return [$start, $end]; } sub parse_THROW { my ($self, $str_ref, $node) = @_; my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"}); $self->throw('parse.missing', "Missing name in THROW", $node, pos($$str_ref)) if ! $name; my $args = $self->parse_args($str_ref, {named_at_front => 1}); return [$name, $args]; } sub parse_UNLESS { my $ref = $DIRECTIVES->{'IF'}->[0]->(@_); return [[undef, '!', $ref], 0]; } sub parse_USE { my ($self, $str_ref) = @_; my $var; my $mark = pos $$str_ref; if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"})) && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment || ((pos($$str_ref) = $mark) && 0)) # otherwise we need to rollback ) { $var = $_var; } my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"}); $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module; $module =~ s/\./::/g; my $args; my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo; $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1}); if ($open) { $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref)); } return [$var, $module, $args]; } sub parse_VIEW { my ($self, $str_ref) = @_; my $ref = $self->parse_args($str_ref, { named_at_front => 1, require_arg => 1, }); return $ref; } sub parse_WHILE { $DIRECTIVES->{'IF'}->[0]->(@_) } sub parse_WRAPPER { $DIRECTIVES->{'PROCESS'}->[0]->(@_) } ###----------------------------------------------------------------### sub dump_parse_tree { my $self = shift; $self = $self->new if ! ref $self; my $str = shift; my $ref = ref($str) ? $str : \$str; my $sub; my $nest; $sub = sub { my ($tree, $indent) = @_; my $out = "[\n"; foreach my $node (@$tree) { if (! ref($node) || (! $node->[4] && ! $node->[5])) { $out .= "$indent ".$self->ast_string($node).",\n"; next; } $out .= "$indent " . $nest->($node, "$indent "); } $out .= "$indent]"; }; $nest = sub { my ($node, $indent) = @_; my $out = $self->ast_string([@{$node}[0..3]]); chop $out; if ($node->[4]) { $out .= ", "; $out .= $sub->($node->[4], "$indent"); } if ($node->[5]) { $out .= ", ". $nest->($node->[5], "$indent") . $indent; } elsif (@$node >= 6) { $out .= ", ". $self->ast_string($node->[5]); } if (@$node >= 7) { $out.= ", ". $self->ast_string($node->[6]) }; $out .= "],\n"; return $out; }; return $sub->($self->parse_tree($ref), '') ."\n"; } sub dump_parse_expr { my $self = shift; $self = $self->new if ! ref $self; my $str = shift; my $ref = ref($str) ? $str : \$str; return $self->ast_string($self->parse_expr($ref)); } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::Parse role is reponsible for storing the majority of directive parsing code, as well as for delegating to the TT, HTE, Tmpl, and Velocity roles for finding variables and directives. =head1 ROLE METHODS =over 4 =item parse_tree Used by load_tree. This is the main grammar engine of the program. It delegates to the syntax found in $self->{'SYNTAX'} (defaults to 'alloy') and calls the function found in the $SYNTAX hashref. The majority of these syntaxes use methods found in the $DIRECTIVES hashref to parse different DIRECTIVE types for each particular syntax. A template that looked like the following: Foo [%- GET foo -%] [%- GET bar -%] Bar would parse to the following AST: [ 'Foo', ['GET', 6, 15, ['foo', 0]], ['GET', 22, 31, ['bar', 0]], 'Bar', ] The "GET" words represent the directive used. The 6, 15 represent the beginning and ending characters of the directive in the document. The remaining items are the variables necessary for running the particular directive. =item parse_expr Used to parse a variable, an expression, a literal string, or a number. It returns a parsed variable tree. Samples of parsed variables can be found in the VARIABLE PARSE TREE section. my $str = "1 + 2 * 3"; my $ast = $self->parse_expr(\$str); # $ast looks like [[undef, '+', 1, [[undef, '*', 2, 3], 0]], 0] =item C Allow for the multitudinous ways that TT parses arguments. This allows for positional as well as named arguments. Named arguments can be separated with a "=" or "=>", and positional arguments should be separated by " " or ",". This only returns an array of parsed variables. To get the actual values, you must call play_expr on each value. =item C This method allows for returning a string of perl code representing the AST of the parsed tree. It is mainly used for testing. =item C This method allows for returning a Data::Dumper dump of a parsed variable. It is mainly used for testing. =item C Methods by these names are used by parse_tree to parse the template. These are the grammar. They are used by all of the various template syntaxes Unless otherwise mentioned, these methods are not exposed via the role. =back =head1 VARIABLE PARSE TREE Template::Alloy parses templates into an tree of operations (an AST or abstract syntax tree). Even variable access is parsed into a tree. This is done in a manner somewhat similar to the way that TT operates except that nested variables such as foo.bar|baz contain the '.' or '|' in between each name level. Operators are parsed and stored as part of the variable (it may be more appropriate to say we are parsing a term or an expression). The following table shows a variable or expression and the corresponding parsed tree (this is what the parse_expr method would return). one [ 'one', 0 ] one() [ 'one', [] ] one.two [ 'one', 0, '.', 'two', 0 ] one|two [ 'one', 0, '|', 'two', 0 ] one.$two [ 'one', 0, '.', ['two', 0 ], 0 ] one(two) [ 'one', [ ['two', 0] ] ] one.${two().three} [ 'one', 0, '.', ['two', [], '.', 'three', 0], 0] 2.34 2.34 "one" "one" 1 + 2 [ [ undef, '+', 1, 2 ], 0] a + b [ [ undef, '+', ['a', 0], ['b', 0] ], 0 ] "one"|length [ [ undef, '~', "one" ], 0, '|', 'length', 0 ] "one $a two" [ [ undef, '~', 'one ', ['a', 0], ' two' ], 0 ] [0, 1, 2] [ [ undef, '[]', 0, 1, 2 ], 0 ] [0, 1, 2].size [ [ undef, '[]', 0, 1, 2 ], 0, '.', 'size', 0 ] ['a', a, $a ] [ [ undef, '[]', 'a', ['a', 0], [['a', 0], 0] ], 0] {a => 'b'} [ [ undef, '{}', 'a', 'b' ], 0 ] {a => 'b'}.size [ [ undef, '{}', 'a', 'b' ], 0, '.', 'size', 0 ] {$a => b} [ [ undef, '{}', ['a', 0], ['b', 0] ], 0 ] a * (b + c) [ [ undef, '*', ['a', 0], [ [undef, '+', ['b', 0], ['c', 0]], 0 ]], 0 ] (a + b) [ [ undef, '+', ['a', 0], ['b', 0] ]], 0 ] (a + b) * c [ [ undef, '*', [ [undef, '+', ['a', 0], ['b', 0] ], 0 ], ['c', 0] ], 0 ] a ? b : c [ [ undef, '?', ['a', 0], ['b', 0], ['c', 0] ], 0 ] a || b || c [ [ undef, '||', ['a', 0], [ [undef, '||', ['b', 0], ['c', 0] ], 0 ] ], 0 ] ! a [ [ undef, '!', ['a', 0] ], 0 ] Some notes on the parsing. Operators are parsed as part of the variable and become part of the variable tree. Operators are stored in the variable tree using an operator identity array which contains undef as the first value, the operator, and the operator arguments. This allows for quickly descending the parsed variable tree and determining that the next node is an operator. Parenthesis () can be used at any point in an expression to disambiguate precedence. "Variables" that appear to be literal strings or literal numbers are returned as the literal (no operator tree). The following perl can be typed at the command line to view the parsed variable tree: perl -e 'use Template::Alloy; print Template::Alloy->dump_parse_expr("foo.bar + 2")."\n"' Also the following can be included in a template to view the output in a template: [% USE cet = Template::Alloy %] [%~ cet.dump_parse_expr('foo.bar + 2').replace('\s+', ' ') %] =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Play.pm000066400000000000000000000744101402714000200227360ustar00rootroot00000000000000package Template::Alloy::Play; =head1 NAME Template::Alloy::Play - Play role - allows for playing out the AST =cut use strict; use warnings; use Template::Alloy; use Template::Alloy::Iterator; use Template::Alloy::Context; our $VERSION = $Template::Alloy::VERSION; our $QR_NUM = '(?:\d*\.\d+ | \d+)'; our $DIRECTIVES = { BLOCK => \&play_BLOCK, BREAK => \&play_control, CALL => \&play_CALL, CASE => undef, CATCH => undef, CLEAR => \&play_CLEAR, '#' => sub {}, COMMENT => sub {}, CONFIG => \&play_CONFIG, DEBUG => \&play_DEBUG, DEFAULT => \&play_DEFAULT, DUMP => \&play_DUMP, ELSE => undef, ELSIF => undef, END => sub {}, EVAL => \&play_EVAL, FILTER => \&play_FILTER, '|' => \&play_FILTER, FINAL => undef, FOR => \&play_FOR, FOREACH => \&play_FOR, GET => \&play_GET, IF => \&play_IF, INCLUDE => \&play_INCLUDE, INSERT => \&play_INSERT, LAST => \&play_control, LOOP => \&play_LOOP, MACRO => \&play_MACRO, META => \&play_META, NEXT => \&play_control, PERL => \&play_PERL, PROCESS => \&play_PROCESS, RAWPERL => \&play_RAWPERL, RETURN => \&play_RETURN, SET => \&play_SET, STOP => \&play_control, SWITCH => \&play_SWITCH, TAGS => sub {}, THROW => \&play_THROW, TRY => \&play_TRY, UNLESS => \&play_UNLESS, USE => \&play_USE, VIEW => \&play_VIEW, WHILE => \&play_WHILE, WRAPPER => \&play_WRAPPER, }; sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### sub play_tree { my ($self, $tree, $out_ref) = @_; return $self->stream_tree($tree) if $self->{'STREAM'}; # node contains (0: DIRECTIVE, # 1: start_index, # 2: end_index, # 3: parsed tag details, # 4: sub tree for block types # 5: continuation sub trees for sub continuation block types (elsif, else, etc) # 6: flag to capture next directive for my $node (@$tree) { ### text nodes are just the bare text if (! ref $node) { $$out_ref .= $node if defined $node; next; } $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'}; $DIRECTIVES->{$node->[0]}->($self, $node->[3], $node, $out_ref); } } sub _is_empty_named_args { my ($hash_ident) = @_; # [[undef, '{}', 'key1', 'val1', 'key2, 'val2'], 0] return @{ $hash_ident->[0] } <= 2; } ###----------------------------------------------------------------### sub play_BLOCK { my ($self, $block_name, $node, $out_ref) = @_; # store a named reference - but do nothing until something processes it my $comp = $self->{'_component'}; $self->{'BLOCKS'}->{$block_name} = { _tree => $node->[4], name => $comp->{'name'} .'/'. $block_name, ($comp->{'_filename'} ? (_filename => $comp->{'_filename'}) : ()), }; return; } sub play_CALL { my ($self, $ident, $node) = @_; my $var = $self->play_expr($ident); $var = $self->undefined_get($ident, $node) if ! defined $var; return; } sub play_control { my ($self, $undef, $node) = @_; $self->throw(lc($node->[0]), 'Control exception', $node); } sub play_CLEAR { my ($self, $undef, $node, $out_ref) = @_; $$out_ref = ''; return; } sub play_CONFIG { my ($self, $config, $node, $out_ref) = @_; my %rtime = map {$_ => 1} @Template::Alloy::CONFIG_RUNTIME; ### do runtime config - not many options get these my ($named, @the_rest) = @$config; $named = $self->play_expr($named); $self->throw("config.strict", "Cannot disable STRICT once it is enabled", $node) if exists $named->{'STRICT'} && ! $named->{'STRICT'}; @{ $self }{keys %$named} = @{ $named }{keys %$named}; ### show what current values are $$out_ref .= join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest); return; } sub play_DEBUG { my ($self, $ref) = @_; if ($ref->[0] eq 'on') { delete $self->{'_debug_off'}; } elsif ($ref->[0] eq 'off') { $self->{'_debug_off'} = 1; } elsif ($ref->[0] eq 'format') { $self->{'_debug_format'} = $ref->[1]; } return; } sub play_DEFAULT { my ($self, $set) = @_; foreach my $item (@$set) { my ($op, $set, $default) = @$item; next if ! defined $set; my $val = $self->play_expr($set); if (! $val) { $default = defined($default) ? $self->play_expr($default) : ''; $self->set_variable($set, $default); } } return; } sub play_DUMP { my ($self, $dump, $node, $out_ref) = @_; my $conf = $self->{'DUMP'}; return if ! $conf && defined $conf; # DUMP => 0 $conf = {} if ref $conf ne 'HASH'; ### allow for handler override my $handler = $conf->{'handler'}; if (! $handler) { require Data::Dumper; my $obj = Data::Dumper->new([]); my $meth; foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) } my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1; $obj->Sortkeys(sub { my $h = shift; [grep {! $Template::Alloy::QR_PRIVATE || $_ !~ $Template::Alloy::QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] }); $handler = sub { $obj->Values([@_]); $obj->Dump } } my ($named, @dump) = @$dump; push @dump, $named if ! _is_empty_named_args($named); # add named args back on at end - if there are some $_ = $self->play_expr($_) foreach @dump; ### look for the text describing what to dump my $info = eval { $self->node_info($node) } || {text => 'unknown', file => 'unknown', line => 'unknown'}; my $out; if (@dump) { $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump); my $name = $info->{'text'}; $name =~ s/^[+=~-]?\s*DUMP\s+//; $name =~ s/\s*[+=~-]?$//; $out =~ s/\$VAR1/$name/; } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) { $out = ''; } else { $out = $handler->($self->{'_vars'}); $out =~ s/\$VAR1/EntireStash/g; } if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) { $out = $Template::Alloy::SCALAR_OPS->{'xml'}->($out); $out = "
$out
"; $out = "DUMP: File \"$info->{file}\" line $info->{line}$out" if $conf->{'header'} || ! defined $conf->{'header'}; } else { $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'}; } $$out_ref .= $out; return; } sub play_EVAL { my ($self, $ref, $node, $out_ref) = @_; my ($named, @strs) = @$ref; foreach my $str (@strs) { $str = $self->play_expr($str); next if ! defined $str; $str = $self->play_expr([[undef, '-temp-', $str], 0, '|', 'eval', [$named]]); $$out_ref .= $str if defined $str; } return; } sub play_FILTER { my ($self, $ref, $node, $out_ref) = @_; my ($name, $filter) = @$ref; return '' if ! @$filter; $self->{'FILTERS'}->{$name} = $filter if length $name; my $sub_tree = $node->[4]; ### play the block my $out = ''; eval { local $self->{'STREAM'} = undef; $self->play_tree($sub_tree, \$out) }; die $@ if $@ && ! UNIVERSAL::can($@, 'type'); # TODO - shouldn't they all die ? $out = $self->play_expr([[undef, '-temp-', $out], 0, '|', @$filter]); $$out_ref .= $out if defined $out; return; } sub play_FOR { my ($self, $ref, $node, $out_ref) = @_; ### get the items - make sure it is an arrayref my ($var, $items) = @$ref; $items = $self->play_expr($items); return '' if ! defined $items; if (ref($items) !~ /Iterator$/) { $items = $self->iterator($items); } my $sub_tree = $node->[4]; local $self->{'_vars'}->{'loop'} = $items; ### if the FOREACH tag sets a var - then nothing but the loop var gets localized if (defined $var) { my ($item, $error) = $items->get_first; while (! $error) { $self->set_variable($var, $item); eval { $self->play_tree($sub_tree, $out_ref) }; if (my $err = $@) { die $err if ! UNIVERSAL::can($err, 'type'); last if $err->type =~ /last|break/; die if $err->type ne 'next'; } ($item, $error) = $items->get_next; } die $error if $error && $error != 3; # Template::Constants::STATUS_DONE; ### if the FOREACH tag doesn't set a var - then everything gets localized } else { ### localize variable access for the foreach my $swap = $self->{'_vars'}; local $self->{'_vars'} = my $copy = {%$swap}; ### iterate use the iterator object #foreach (my $i = $items->index; $i <= $#$vals; $items->index(++ $i)) { my ($item, $error) = $items->get_first; while (! $error) { @$copy{keys %$item} = values %$item if ref($item) eq 'HASH'; eval { $self->play_tree($sub_tree, $out_ref) }; if (my $err = $@) { die $err if ! UNIVERSAL::can($err, 'type'); last if $err->type =~ /last|break/; die if $err->type ne 'next'; } ($item, $error) = $items->get_next; } die $error if $error && $error != 3; # Template::Constants::STATUS_DONE; } return; } sub play_GET { my ($self, $ident, $node, $out_ref) = @_; my $var = $self->play_expr($ident); if (defined $var) { $$out_ref .= $var; } else { $var = $self->undefined_get($ident, $node); $$out_ref .= $var if defined $var; } return; } sub play_IF { my ($self, $var, $node, $out_ref) = @_; my $val = $self->play_expr($var); if ($val) { my $body_ref = $node->[4] ||= []; $self->play_tree($body_ref, $out_ref); return; } while ($node = $node->[5]) { # ELSE, ELSIF's if ($node->[0] eq 'ELSE') { my $body_ref = $node->[4] ||= []; $self->play_tree($body_ref, $out_ref); return; } my $var = $node->[3]; my $val = $self->play_expr($var); if ($val) { my $body_ref = $node->[4] ||= []; $self->play_tree($body_ref, $out_ref); return; } } return; } sub play_INCLUDE { my ($self, $str_ref, $node, $out_ref) = @_; ### localize the swap my $swap = $self->{'_vars'} || {}; local $self->{'_vars'} = {%$swap}; ### localize the blocks my $blocks = $self->{'BLOCKS'} || {}; local $self->{'BLOCKS'} = {%$blocks}; return $DIRECTIVES->{'PROCESS'}->($self, $str_ref, $node, $out_ref); } sub play_INSERT { my ($self, $args, $node, $out_ref) = @_; if ($self->{'NO_INCLUDES'}) { $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive"); } my ($named, @files) = @$args; foreach my $name (@files) { my $file = $self->play_expr($name); my $ref = $self->slurp($self->include_filename($file)); $$out_ref .= $$ref; } return; } sub play_JS { my $self = shift; $self->throw('js', 'COMPILE_JS not set while running a JS block') if ! $self->{'COMPILE_JS'}; $self->throw('js', 'Cannot run JS directly'); } sub play_LOOP { my ($self, $ref, $node, $out_ref) = @_; my $var = $self->play_expr(ref($ref) ? $ref : [$ref,0]); # allow for "string" identified loops my $sub_tree = $node->[4]; my $global = ! $self->{'SYNTAX'} || $self->{'SYNTAX'} ne 'ht' || $self->{'GLOBAL_VARS'}; my $items = ref($var) eq 'ARRAY' ? $var : ref($var) eq 'HASH' ? [$var] : []; my $i = 0; for my $ref (@$items) { ### setup the loop $self->throw('loop', 'Scalar value used in LOOP') if $ref && ref($ref) ne 'HASH'; local $self->{'_vars'} = (! $global) ? ($ref || {}) : (ref($ref) eq 'HASH') ? {%{ $self->{'_vars'} }, %$ref} : $self->{'_vars'}; if ($self->{'LOOP_CONTEXT_VARS'} && ! $Template::Alloy::QR_PRIVATE) { $self->{'_vars'}->{'__counter__'} = ++$i; $self->{'_vars'}->{'__first__'} = $i == 1 ? 1 : 0; $self->{'_vars'}->{'__last__'} = $i == @$items ? 1 : 0; $self->{'_vars'}->{'__inner__'} = $i == 1 || $i == @$items ? 0 : 1; $self->{'_vars'}->{'__odd__'} = ($i % 2) ? 1 : 0; } ### execute the sub tree $self->play_tree($sub_tree, $out_ref); } return; } sub play_MACRO { my ($self, $ref, $node, $out_ref) = @_; my ($name, $args) = @$ref; ### get the sub tree my $sub_tree = $node->[4]; if (! $sub_tree || ! $sub_tree->[0]) { $self->set_variable($name, undef); return; } elsif (ref($sub_tree->[0]) && $sub_tree->[0]->[0] eq 'BLOCK') { $sub_tree = $sub_tree->[0]->[4]; } ### install a closure in the stash that will handle the macro $self->set_variable($name, $self->_macro_sub($args, $sub_tree, $out_ref)); return; } sub _macro_sub { my ($self, $args, $sub_tree, $out_ref) = @_; my $self_copy = $self; my $sub = sub { ### macros localize my $copy = $self_copy->{'_vars'}; local $self_copy->{'_vars'}= {%$copy}; ### prevent recursion local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0; my $max = $self_copy->{'MAX_MACRO_RECURSE'} || $Template::Alloy::MAX_MACRO_RECURSE; $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $max reached") if ++$self_copy->{'_macro_recurse'} > $max; ### set arguments my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args; my @positional = @_; foreach my $var (@$args) { $self_copy->set_variable($var, shift(@positional)); } foreach my $name (sort keys %$named) { $self_copy->set_variable([$name, 0], $named->{$name}); } local $self->{'STREAM'} = undef; ### finally - run the sub tree my $out = ''; eval { $self_copy->play_tree($sub_tree, \$out) }; if (my $err = $@) { die $err if $err->type ne 'return'; return $err->info->{'return_val'} if UNIVERSAL::isa($err->info, 'HASH'); return; } return $out; }; eval {require Scalar::Util; Scalar::Util::weaken($self_copy)}; return $sub; } sub play_META { my ($self, $hash) = @_; return if ! $hash; $hash = {@$hash} if ref($hash) eq 'ARRAY'; my @keys = keys %$hash; my $ref; if ($self->{'_top_level'}) { $ref = $self->{'_template'} ||= {}; } else { $ref = $self->{'_component'} ||= {}; } @{ $ref }{ @keys } = @{ $hash }{ @keys }; return; } sub play_PERL { my ($self, $info, $node, $out_ref) = @_; $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'}; ### fill in any variables my $perl = $node->[4] || return; my $out = ''; { local $self->{'STREAM'} = undef; $self->play_tree($perl, \$out); }; $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway ### try the code my $err; eval { package Template::Alloy::Perl; my $context = $self->context; my $stash = $context->stash; ### setup a fake handle local *PERLOUT; tie *PERLOUT, 'Template::Alloy::EvalPerlHandle', $out_ref; my $old_fh = select PERLOUT; eval $out; $err = $@; ### put the handle back select $old_fh; }; $err ||= $@; if ($err) { $self->throw('undef', $err) if ! UNIVERSAL::can($err, 'type'); die $err; } return; } sub play_PROCESS { my ($self, $info, $node, $out_ref) = @_; if ($self->{'NO_INCLUDES'}) { $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive"); } my ($args, @files) = @$info; ### process files first foreach my $ref (@files) { $ref = $self->play_expr($ref) if defined $ref; } ### set passed args # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0] $args = $args->[0]; foreach (my $i = 2; $i < @$args; $i+=2) { my $key = $args->[$i]; my $val = $self->play_expr($args->[$i+1]); if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever foreach my $key (keys %$val) { $self->set_variable([$key,0], $val->{$key}); } next; } $self->set_variable($key, $val); } ### iterate on any passed block or filename foreach my $filename (@files) { next if ! defined $filename; my $out = ''; # have temp item to allow clear to correctly clear ### normal blocks or filenames if (! ref($filename) || ref($filename) eq 'SCALAR') { eval { $self->_process($filename, $self->{'_vars'}, \$out) }; # restart the swap - passing it our current stash ### allow for $template which is used in some odd instances } else { my $doc = $filename; $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'}; local $self->{'_process_dollar_template'} = 1; local $self->{'_component'} = $doc; ### run the document however we can if (ref($doc) ne 'HASH' || (! $doc->{'_perl'} && ! $doc->{'_tree'})) { $self->throw('process', "Passed item doesn't appear to be a valid document"); } elsif ($doc->{'_perl'}) { eval { $doc->{'_perl'}->{'code'}->($self, \$out) }; } else { eval { $self->play_tree($doc->{'_tree'}, \$out) }; } if ($self->{'TRIM'}) { $out =~ s{ \s+ $ }{}x; $out =~ s{ ^ \s+ }{}x; } ### handle exceptions if (my $err = $@) { $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type'); $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc; } } ### append any output $$out_ref .= $out; if (my $err = $@) { die $err if ! UNIVERSAL::can($err, 'type') || $err->type !~ /return/; } } return; } sub play_RAWPERL { my ($self, $info, $node, $out_ref) = @_; $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'}; ### fill in any variables my $tree = $node->[4] || return; my $perl = ''; { local $self->{'STREAM'} = undef; $self->play_tree($tree, \$perl); } $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway ### try the code my $err; my $output = ''; eval { package Template::Alloy::Perl; my $context = $self->context; my $stash = $context->stash; eval $perl; $err = $@; }; $err ||= $@; $$out_ref .= $output; if ($err) { $self->throw('undef', $err) if ! UNIVERSAL::can($err, 'type'); die $err; } return; } sub play_RETURN { my ($self, $undef, $node) = @_; my $var = $node->[3]; $var = {return_val => $self->play_expr($var)} if defined $var; $self->throw('return', $var, $node); } sub play_SET { my ($self, $set, $node) = @_; foreach my $item (@$set) { my ($op, $set, $val) = @$item; if (! defined $val) { # not defined # do nothing - allow for setting to undef } elsif ($node->[4] && $val == $node->[4]) { # a captured directive my $sub_tree = $node->[4]; $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK'; $val = ''; local $self->{'STREAM'} = undef; $self->play_tree($sub_tree, \$val); } else { # normal var $val = $self->play_expr($val); } $self->set_variable($set, $val); } return; } sub play_SWITCH { my ($self, $var, $node, $out_ref) = @_; my $val = $self->play_expr($var); $val = '' if ! defined $val; ### $node->[4] is thrown away my $default; while ($node = $node->[5]) { # CASES my $var = $node->[3]; if (! defined $var) { $default = $node->[4]; next; } my $val2 = $self->play_expr($var); $val2 = [$val2] if ! UNIVERSAL::isa($val2, 'ARRAY'); for my $test (@$val2) { # find matching values next if ! defined $val && defined $test; next if defined $val && ! defined $test; next if $val ne $test; my $body_ref = $node->[4] ||= []; $self->play_tree($body_ref, $out_ref); return; } } if ($default) { $self->play_tree($default, $out_ref); } return; } sub play_THROW { my ($self, $ref, $node) = @_; my ($name, $args) = @$ref; $name = $self->play_expr($name); my ($named, @args) = @$args; push @args, $named if ! _is_empty_named_args($named); # add named args back on at end - if there are some @args = map { $self->play_expr($_) } @args; $self->throw($name, \@args, $node); # dies return; # but return just in case } sub play_TRY { my ($self, $foo, $node, $out_ref) = @_; my $out = ''; my $body_ref = $node->[4]; eval { $self->play_tree($body_ref, \$out) }; my $err = $@; if (! $node->[5]) { # no catch or final if (! $err) { # no final block and no error $$out_ref .= $out; return; } $self->throw('parse.missing', "Missing CATCH block", $node); } if ($err) { $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type'); if ($err->type =~ /stop|return/) { $$out_ref .= $out; die $err; } } ### loop through the nested catch and final blocks my $catch_body_ref; my $last_found; my $type = $err ? $err->type : ''; my $final; while ($node = $node->[5]) { # CATCH if ($node->[0] eq 'FINAL') { $final = $node->[4]; next; } next if ! $err; my $name = $self->play_expr($node->[3]); $name = '' if ! defined $name || lc($name) eq 'default'; if ($type =~ / ^ \Q$name\E \b /x && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins $catch_body_ref = $node->[4] || []; $last_found = $name; } } ### play the best catch block if ($err) { if (! $catch_body_ref) { $$out_ref .= $out; die $err; } local $self->{'_vars'}->{'error'} = $err; local $self->{'_vars'}->{'e'} = $err; eval { $self->play_tree($catch_body_ref, \$out) }; if (my $err = $@) { $$out_ref .= $out; die $err; } } ### the final block $self->play_tree($final, \$out) if $final; $$out_ref .= $out; return; } sub play_UNLESS { return $DIRECTIVES->{'IF'}->(@_) } sub play_USE { my ($self, $ref, $node, $out_ref, $foreign) = @_; # foreign allows for usage from JS my ($var, $module, $args) = @$ref; ### get the stash storage location - default to the module $var = $module if ! defined $var; my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var; pop @var; # remove the trailing '.' my ($named, @args) = @$args; push @args, $named if ! _is_empty_named_args($named); # add named args back on at end - if there are some ### try and load the module - fall back to bare module if allowed my $obj; if (my $fact = $self->{'PLUGIN_FACTORY'}->{$module} || $self->{'PLUGIN_FACTORY'}->{lc $module}) { if (UNIVERSAL::isa($fact, 'CODE')) { $obj = $fact->($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args); } } elsif (my $pkg = $self->{'PLUGINS'}->{$module} || $self->{'PLUGINS'}->{lc $module}) { (my $req = "$pkg.pm") =~ s|::|/|g; if ($INC{$req} || eval { require $req }) { my $shape = $pkg->load; $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args); } } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works fine too) $obj = $self->iterator($foreign ? @$foreign : map { $self->play_expr($_) } @args); } else { my $found; my $BASE = $self->{'PLUGIN_BASE'}; foreach my $base ((ref($BASE) eq 'ARRAY' ? @$BASE : $BASE), (my $e = 'TP-Fallback')) { if ($base && $base eq 'TP-Fallback' && eval { require Template::Plugins }) { # want to allow Template::Plugins without requiring we use them $base = $Template::Plugins::PLUGIN_BASE || next; if ($Template::Plugins::STD_PLUGINS && (my $pkg = $Template::Plugins::STD_PLUGINS->{lc $module})) { (my $req = "$pkg.pm") =~ s|::|/|g; $found = 1; if (eval { require $req }) { my $shape = $pkg->load; $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args); } last; } } next if ! $base; my $pkg = "${base}::${module}"; (my $req = "$pkg.pm") =~ s|::|/|g; if ($pkg->can('load') || eval { require $req }) { my $shape = $pkg->load; $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args); $found = 1; last; } } if (! $found && $self->{'LOAD_PERL'}) { (my $req = "$module.pm") =~ s|::|/|g; if ($module->can('new') || eval { require $req }) { $obj = $module->new($foreign ? @$foreign : map { $self->play_expr($_) } @args); } } } if (! defined $obj) { my $err = "$module: plugin not found"; $self->throw('plugin', $err); } return $obj if $foreign; $self->set_variable(\@var, $obj); return; } sub play_VIEW { my ($self, $ref, $node, $out_ref) = @_; my ($blocks, $args, $name) = @$ref; ### get args ready # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0] $args = $args->[0]; my $hash = {}; foreach (my $i = 2; $i < @$args; $i+=2) { my $key = $args->[$i]; my $val = $self->play_expr($args->[$i+1]); if (ref $key) { if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) { $key = $key->[0]; } else { $self->set_variable($key, $val); next; # what TT does } } $hash->{$key} = $val; } ### prepare the blocks my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : ''; foreach my $key (keys %$blocks) { $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}}; } $hash->{'blocks'} = $blocks; ### get the view if (! eval { require Template::View }) { $self->throw('view', 'Could not load Template::View library'); } my $view = Template::View->new($self->context, $hash) || $self->throw('view', $Template::View::ERROR); ### 'play it' my $old_view = $self->play_expr(['view', 0]); $self->set_variable($name, $view); $self->set_variable(['view', 0], $view); if ($node->[4]) { my $out = ''; $self->play_tree($node->[4], \$out); # throw away $out } $self->set_variable(['view', 0], $old_view); $view->seal; return; } sub play_WHILE { my ($self, $var, $node, $out_ref) = @_; return if ! defined $var; my $sub_tree = $node->[4]; ### iterate use the iterator object my $count = $Template::Alloy::WHILE_MAX; while (--$count > 0) { $self->play_expr($var) || last; ### execute the sub tree eval { $self->play_tree($sub_tree, $out_ref) }; if (my $err = $@) { if (UNIVERSAL::can($err, 'type')) { next if $err->type =~ /next/; last if $err->type =~ /last|break/; } die $err; } } die "WHILE loop terminated (> $Template::Alloy::WHILE_MAX iterations)\n" if ! $count; return; } sub play_WRAPPER { my ($self, $args, $node, $out_ref) = @_; my $sub_tree = $node->[4] || return; my ($named, @files) = @$args; my $out = ''; { local $self->{'STREAM'} = undef; $self->play_tree($sub_tree, \$out); foreach my $name (reverse @files) { local $self->{'_vars'}->{'content'} = $out; $out = ''; $DIRECTIVES->{'INCLUDE'}->($self, [$named, $name], $node, \$out); } } if ($self->{'STREAM'}) { print $out; $out = ''; } $$out_ref .= $out; return; } ###----------------------------------------------------------------### package Template::Alloy::EvalPerlHandle; sub TIEHANDLE { my ($class, $out_ref) = @_; return bless [$out_ref], $class; } sub PRINT { my $self = shift; ${ $self->[0] } .= $_ for grep {defined && length} @_; return 1; } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::Play role allows for taking the AST returned by the Parse role, and executes it directly. This is in contrast Template::Alloy::Compile which translates the AST into perl code and then executes the perl code. =head1 ROLE METHODS =over 4 =item C Takes the AST output of load_tree and executes it directly. It should be passed an AST tree and an output string reference that the content will be appended to. my $tree = $self->load_tree('somefile'); my $out = ''; $self->play_tree($tree, \$out); =item C Methods by these names are used by execute_tree to execute the parsed tree. =back =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Stream.pm000066400000000000000000000045571402714000200232710ustar00rootroot00000000000000package Template::Alloy::Stream; =head1 NAME Template::Alloy::Stream - Stream role - allows for playing out the AST and printing straight to file handle =cut use strict; use warnings; use Template::Alloy; use Template::Alloy::Play; our $VERSION = $Template::Alloy::VERSION; sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### sub stream_tree { my ($self, $tree) = @_; local $Template::Alloy::Play::DIRECTIVES->{'CLEAR'} = \&stream_CLEAR; # node contains (0: DIRECTIVE, # 1: start_index, # 2: end_index, # 3: parsed tag details, # 4: sub tree for block types # 5: continuation sub trees for sub continuation block types (elsif, else, etc) # 6: flag to capture next directive for my $node (@$tree) { ### text nodes are just the bare text if (! ref $node) { print $node if defined $node; next; } print $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'}; my $out = ''; $Template::Alloy::Play::DIRECTIVES->{$node->[0]}->($self, $node->[3], $node, \$out); print $out; } } sub stream_CLEAR { my ($self, $undef, $node) = @_; $self->throw('stream', 'Cannot use CLEAR directive when STREAM is being used', $node); } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::Stream role works similar to the PLAY role, but instead of accumulating the data, it prints it as soon as it is available. All directives are supported except for the CLEAR directive which is meaningless. Most configuration items are supported - except for the TRIM directive which cannot be used because the output is not buffered into a variable that can be trimmed. The WRAPPER directive is still supported - but it essentially turns off STREAM as the content must be generated before playing the WRAPPER templates. =head1 ROLE METHODS =over 4 =item C Similar to play_tree from the Play role, but prints output to the screen as soon as it is ready. =back =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/TT.pm000066400000000000000000001120201402714000200223460ustar00rootroot00000000000000package Template::Alloy::TT; =head1 NAME Template::Alloy::TT - Template::Toolkit role =cut use strict; use warnings; use Template::Alloy; use Template::Alloy::Operator qw($QR_OP_ASSIGN); our $VERSION = $Template::Alloy::VERSION; our $QR_COMMENTS; use constant posessive => ($^V >= 5.009) || 0; # perl 5.10 allows possessive sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### sub parse_tree_tt3 { my $self = shift; my $str_ref = shift; my $one_tag_only = shift() ? 1 : 0; if (! $str_ref || ! defined $$str_ref) { $self->throw('parse.no_string', "No string or undefined during parse", undef, 1); } my $STYLE = $self->{'TAG_STYLE'} || 'default'; local $self->{'_end_tag'} = $self->{'END_TAG'} || $Template::Alloy::Parse::TAGS->{$STYLE}->[1]; local $self->{'START_TAG'} = $self->{'START_TAG'} || $Template::Alloy::Parse::TAGS->{$STYLE}->[0]; local $self->{'_start_tag'} = (! $self->{'INTERPOLATE'}) ? $self->{'START_TAG'} : qr{(?: $self->{'START_TAG'} | (\$))}sx; local $QR_COMMENTS = $QR_COMMENTS || (posessive() ? (local $Template::Alloy::Parse::QR_COMMENTS = "(?sm: \\s*+ \\# .*? (?: \$ | (?=$self->{'_end_tag'}) ) )*+ \\s*+") : $Template::Alloy::Parse::QR_COMMENTS); my $dirs = $Template::Alloy::Parse::DIRECTIVES; my $aliases = $Template::Alloy::Parse::ALIASES; local @{ $dirs }{ keys %$aliases } = values %$aliases; # temporarily add to the table local @{ $self }{@Template::Alloy::CONFIG_COMPILETIME} = @{ $self }{@Template::Alloy::CONFIG_COMPILETIME}; delete $dirs->{'JS'} if ! $self->{'COMPILE_JS'}; my @tree; # the parsed tree my $pointer = \@tree; # pointer to current tree to handle nested blocks my @state; # maintain block levels local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS) local $self->{'_no_interp'} = 0; # no interpolation in some blocks (usually PERL) my @in_view; # let us know if we are in a view my @blocks; # store blocks for later moving to front my @meta; # place to store any found meta information (to go into META) my $post_chomp = 0; # previous post_chomp setting my $continue = 0; # flag for multiple directives in the same tag my $post_op = 0; # found a post-operative DIRECTIVE my $capture; # flag to start capture my $func; my $node; pos($$str_ref) = 0 if ! $one_tag_only; while (1) { ### continue looking for information in a semi-colon delimited tag if ($continue) { $node = [undef, $continue, undef]; } elsif ($one_tag_only) { $node = [undef, pos($$str_ref), undef]; ### find the next opening tag } else { $$str_ref =~ m{ \G (.*?) $self->{'_start_tag'} }gcxs || last; my ($text, $dollar) = ($1, $2); # dollar is set only on an interpolated var ### found a text portion - chomp it and store it if (length $text) { if (! $post_chomp) { } elsif ($post_chomp == 1) { $text =~ s{ ^ [^\S\n]* \n }{}x } elsif ($post_chomp == 2) { $text =~ s{ ^ \s+ }{ }x } elsif ($post_chomp == 3) { $text =~ s{ ^ \s+ }{}x } push @$pointer, $text if length $text; } ### handle variable interpolation ($2 eq $) if ($dollar) { ### inspect previous text chunk for escape slashes my $n = ($text =~ m{ (\\+) $ }x) ? length($1) : 0; if ($self->{'_no_interp'} || $n % 2) { # were there odd escapes my $prev_text; $prev_text = \$pointer->[-1] if defined($pointer->[-1]) && ! ref($pointer->[-1]); chop($$prev_text) if $n % 2; if ($prev_text) { $$prev_text .= $dollar } else { push @$pointer, $dollar } next; } my $not = $$str_ref =~ m{ \G ! }gcx; my $mark = pos($$str_ref); my $ref; if ($$str_ref =~ m{ \G \{ }gcx) { local $self->{'_operator_precedence'} = 0; # allow operators $ref = $self->parse_expr($str_ref); $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcx || $self->throw('parse', 'Missing close }', undef, pos($$str_ref)); } else { local $self->{'_operator_precedence'} = 1; # no operators local $QR_COMMENTS = local $Template::Alloy::Parse::QR_COMMENTS = qr{}; $ref = $self->parse_expr($str_ref); } $self->throw('parse', "Error while parsing for interpolated string", undef, pos($$str_ref)) if ! defined $ref; if (! $not && $self->{'SHOW_UNDEFINED_INTERP'}) { $ref = [[undef, '//', $ref, '$'.substr($$str_ref, $mark, pos($$str_ref)-$mark)], 0]; } push @$pointer, ['GET', $mark, pos($$str_ref), $ref]; $post_chomp = 0; # no chomping after dollar vars next; } $node = [undef, pos($$str_ref), undef]; ### take care of whitespace and comments flags my $pre_chomp = $$str_ref =~ m{ \G ([+=~-]) }gcx ? $1 : $self->{'PRE_CHOMP'}; $pre_chomp =~ y/-=~+/1230/ if $pre_chomp; if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) { if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x } elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x } elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x } splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length } ### leading # means to comment the entire section if ($$str_ref =~ m{ \G \# }gcx) { $$str_ref =~ m{ \G (.*?) ([+~=-]?) ($self->{'_end_tag'}) }gcxs # brute force - can't comment tags with nested %] || $self->throw('parse', "Missing closing tag", undef, pos($$str_ref)); $node->[0] = '#'; $node->[2] = pos($$str_ref) - length($3) - length($2); push @$pointer, $node; $post_chomp = $2; $post_chomp ||= $self->{'POST_CHOMP'}; $post_chomp =~ y/-=~+/1230/ if $post_chomp; next; } #$$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo; } ### look for DIRECTIVES if ($$str_ref =~ m{ \G \s* $QR_COMMENTS $Template::Alloy::Parse::QR_DIRECTIVE }gcxo # find a word && ($func = $self->{'ANYCASE'} ? uc($1) : $1) && ($dirs->{$func} || ((pos($$str_ref) -= length $1) && 0)) ) { # is it a directive $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcx; $func = $aliases->{$func} if $aliases->{$func}; $node->[0] = $func; ### store out this current node level to the appropriate tree location # on a post operator - replace the original node with the new one - store the old in the new if ($dirs->{$func}->[3] && $post_op) { my @post_op = @$post_op; @$post_op = @$node; $node = $post_op; $node->[4] = [\@post_op]; # if there was not a semi-colon - see if semis were required } elsif ($post_op && $self->{'SEMICOLONS'}) { $self->throw('parse', "Missing semi-colon with SEMICOLONS => 1", undef, $node->[1]); # handle directive captures for an item like "SET foo = BLOCK" } elsif ($capture) { push @{ $capture->[4] }, $node; undef $capture; # normal nodes } else{ push @$pointer, $node; } ### parse any remaining tag details $node->[3] = eval { $dirs->{$func}->[0]->($self, $str_ref, $node) }; if (my $err = $@) { $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; die $err; } $node->[2] = pos $$str_ref; ### anything that behaves as a block ending if ($func eq 'END' || $dirs->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc) if (! @state) { $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref)); } my $parent_node = pop @state; if ($func ne 'END') { pop @$pointer; # we will store the node in the parent instead $parent_node->[5] = $node; my $parent_type = $parent_node->[0]; if (! $dirs->{$func}->[4]->{$parent_type}) { $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref)); } } ### restore the pointer up one level (because we hit the end of a block) $pointer = (! @state) ? \@tree : $state[-1]->[4]; ### normal end block if ($func eq 'END') { if ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front if (defined($parent_node->[3]) && @in_view) { push @{ $in_view[-1] }, $parent_node; } else { push @blocks, $parent_node if length $parent_node->[3]; # macro blocks may not have a name } if ($pointer->[-1] && ! $pointer->[-1]->[6]) { splice(@$pointer, -1, 1, ()); } } elsif ($parent_node->[0] eq 'VIEW') { my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }}; unshift @{ $parent_node->[3] }, $ref; } elsif ($dirs->{$parent_node->[0]}->[5]) { # allow no_interp to turn on and off $self->{'_no_interp'}--; } ### continuation block - such as an elsif } else { push @state, $node; $pointer = $node->[4] ||= []; } ### handle block directives } elsif ($dirs->{$func}->[2] && ! $post_op) { push @state, $node; $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node push @in_view, [] if $func eq 'VIEW'; $self->{'_no_interp'}++ if $dirs->{$node->[0]}->[5] # allow no_interp to turn on and off } elsif ($func eq 'TAGS') { ($self->{'_start_tag'}, $self->{'_end_tag'}, my $old_end) = (@{ $node->[3] }[0,1], $self->{'_end_tag'}); ### allow for one more closing tag of the old style if ($$str_ref =~ m{ \G \s* $QR_COMMENTS ([+~=-]?) $old_end }gcxs) { $Template::Alloy::Parse::QR_COMMENTS = "(?sm: \\s*+ \\# .*? (?: \$ | (?=$self->{'_end_tag'}) ) )*+ \\s*+" if posessive(); $QR_COMMENTS = $Template::Alloy::Parse::QR_COMMENTS; $post_chomp = $1 || $self->{'POST_CHOMP'}; $post_chomp =~ y/-=~+/1230/ if $post_chomp; $continue = 0; $post_op = 0; next; } $Template::Alloy::Parse::QR_COMMENTS = "(?sm: \\s*+ \\# .*? (?: \$ | (?=$self->{'_end_tag'}) ) )*+ \\s*+" if posessive(); $QR_COMMENTS = $Template::Alloy::Parse::QR_COMMENTS; } elsif ($func eq 'META') { unshift @meta, @{ $node->[3] }; # first defined win $node->[3] = undef; # only let these be defined once - at the front of the tree } ### allow for bare variable getting and setting } elsif (defined(my $var = $self->parse_expr($str_ref))) { if ($post_op && $self->{'SEMICOLONS'}) { $self->throw('parse', "Missing semi-colon with SEMICOLONS => 1", undef, $node->[1]); } push @$pointer, $node; if ($$str_ref =~ m{ \G \s* $QR_COMMENTS ($QR_OP_ASSIGN) >? (?! [+=~-]? $self->{'_end_tag'}) \s* $QR_COMMENTS }gcx) { $node->[0] = 'SET'; $node->[3] = eval { $dirs->{'SET'}->[0]->($self, $str_ref, $node, $1, $var) }; if (my $err = $@) { $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; die $err; } } else { if ($self->{'AUTO_FILTER'}) { $var = [[undef, '~', $var], 0] if ! ref $var; push @$var, '|', $self->{'AUTO_FILTER'}, 0 if @$var < 3 || $var->[-3] ne '|'; } $node->[0] = 'GET'; $node->[3] = $var; } $node->[2] = pos $$str_ref; } ### look for the closing tag if ($$str_ref =~ m{ \G \s* $QR_COMMENTS (?: ; \s* $QR_COMMENTS)? ([+=~-]?) $self->{'_end_tag'} }gcxs) { if ($one_tag_only) { $self->throw('parse', "Invalid char \"$1\" found at end of block") if $1; $self->throw('parse', "Missing END directive", $state[-1], pos($$str_ref)) if @state > 0; return \@tree; } $post_chomp = $1 || $self->{'POST_CHOMP'}; $post_chomp =~ y/-=~+/1230/ if $post_chomp; $continue = 0; $post_op = 0; next; } ### semi-colon = end of statement - we will need to continue parsing this tag if ($$str_ref =~ m{ \G ; \s* $QR_COMMENTS }gcxo) { $post_op = 0; ### we are flagged to start capturing the output of the next directive - set it up } elsif ($node->[6]) { $post_op = 0; $capture = $node; ### allow next directive to be post-operative (or not) } else { $post_op = $node; } ### no closing tag yet - no need to get an opening tag on next loop $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref)) if $continue == pos $$str_ref; $continue = pos $$str_ref; } ### cleanup the tree unshift(@tree, @blocks) if @blocks; unshift(@tree, ['META', 1, 1, \@meta]) if @meta; $self->throw('parse', "Missing END directive", $state[-1], pos($$str_ref)) if @state > 0; ### pull off the last text portion - if any if (pos($$str_ref) != length($$str_ref)) { my $text = substr $$str_ref, pos($$str_ref); if (! $post_chomp) { } elsif ($post_chomp == 1) { $text =~ s{ ^ [^\S\n]* \n }{}x } elsif ($post_chomp == 2) { $text =~ s{ ^ \s+ }{ }x } elsif ($post_chomp == 3) { $text =~ s{ ^ \s+ }{}x } push @$pointer, $text if length $text; } return \@tree; } ###----------------------------------------------------------------### sub process { my ($self, $in, $swap, $out, @ARGS) = @_; delete $self->{'error'}; if ($self->{'DEBUG'}) { # "enable" some types of tt style debugging $self->{'_debug_dirs'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/; $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/; } my $args; $args = ($#ARGS == 0 && UNIVERSAL::isa($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS; ### get the content my $content; if (ref $in) { if (ref($in) eq 'SCALAR') { # reference to a string $content = $in; } elsif (UNIVERSAL::isa($in, 'CODE')) { $in = $in->(); $content = \$in; } elsif (ref($in) eq 'HASH') { # pre-prepared document $content = $in; } else { # should be a file handle local $/ = undef; $in = <$in>; $content = \$in; } } else { ### should be a filename $content = $in; } ### prepare block localization my $blocks = $self->{'BLOCKS'} ||= {}; ### do the swap my $output = ''; eval { ### localize the stash $swap ||= {}; my $var1 = $self->{'_vars'} ||= {}; my $var2 = $self->{'STASH'} || $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {}; $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing my $copy = {%$var2, %$var1, %$swap}; local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore local $self->{'_template'}; delete $self->{'_debug_off'}; delete $self->{'_debug_format'}; ### handle pre process items that go before every document my $pre = ''; if ($self->{'PRE_PROCESS'}) { _load_template_meta($self, $content); foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) { $self->_process($name, $copy, \$pre); } } ### process the central file now - catching errors to allow for the ERROR config eval { local $self->{'STREAM'} = undef if $self->{'WRAPPER'}; ### handle the PROCESS config - which loads another template in place of the real one if (exists $self->{'PROCESS'}) { _load_template_meta($self, $content); foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) { next if ! length $name; $self->_process($name, $copy, \$output); } ### handle "normal" content } else { local $self->{'_start_top_level'} = 1; $self->_process($content, $copy, \$output); } }; ### catch errors with ERROR config if (my $err = $@) { $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type'); die $err if $err->type =~ /stop|return/; my $catch = $self->{'ERRORS'} || $self->{'ERROR'} || die $err; $catch = {default => $catch} if ! ref $catch; my $type = $err->type; my $last_found; my $file; foreach my $name (keys %$catch) { my $_name = (! defined $name || lc($name) eq 'default') ? '' : $name; if ($type =~ / ^ \Q$_name\E \b /x && (! defined($last_found) || length($last_found) < length($_name))) { # more specific wins $last_found = $_name; $file = $catch->{$name}; } } ### found error handler - try it out if (defined $file) { $output = ''; local $copy->{'error'} = local $copy->{'e'} = $self->{'COMPILE_JS'} ? {type => $type, info => $err->info} : $err; local $self->{'STREAM'} = undef if $self->{'WRAPPER'}; $self->_process($file, $copy, \$output); } } ### handle wrapper directives if (exists $self->{'WRAPPER'}) { _load_template_meta($self, $content); foreach my $name (reverse @{ $self->split_paths($self->{'WRAPPER'}) }) { next if ! length $name; local $copy->{'content'} = $output; my $out = ''; local $self->{'STREAM'} = undef; $self->_process($name, $copy, \$out); $output = $out; } if ($self->{'STREAM'}) { print $output; $output = 1; } } $output = $pre . $output if length $pre; ### handle post process items that go after every document if ($self->{'POST_PROCESS'}) { _load_template_meta($self, $content); foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) { $self->_process($name, $copy, \$output); } } }; ### clear blocks as asked (AUTO_RESET) defaults to on $self->{'BLOCKS'} = $blocks if exists($self->{'AUTO_RESET'}) && ! $self->{'AUTO_RESET'}; if (my $err = $@) { $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type'); if ($err->type !~ /stop|return|next|last|break/) { $self->{'error'} = $err; die $err if $self->{'RAISE_ERROR'}; return; } } ### send the content back out $out ||= $self->{'OUTPUT'}; if (ref $out) { if (UNIVERSAL::isa($out, 'CODE')) { $out->($output); } elsif (UNIVERSAL::can($out, 'print')) { $out->print($output); } elsif (UNIVERSAL::isa($out, 'SCALAR')) { # reference to a string $$out = $output; } elsif (UNIVERSAL::isa($out, 'ARRAY')) { push @$out, $output; } else { # should be a file handle print {$out} $output; } } elsif ($out) { # should be a filename my $file; if ($out =~ m|^/|) { if (! $self->{'ABSOLUTE'}) { $self->throw($self->{'error'} = $self->exception('file', "ABSOLUTE paths disabled")); } else { $file = $out; } } elsif ($out =~ m|^\.\.?/|) { if (! $self->{'RELATIVE'}) { $self->throw($self->{'error'} = $self->exception('file', "RELATIVE paths disabled")); } else { $file = $out; } } else { my $path = $self->{'OUTPUT_PATH'}; $path = '.' if ! defined $path; if (! -d $path) { require File::Path; File::Path::mkpath($path); } $file = "$path/$out"; } open(my $fh, '>', $file) || $self->throw($self->{'error'} = $self->exception('file', "$out couldn't be opened for writing: $!")); if (my $bm = $args->{'binmode'}) { if (+$bm == 1) { binmode $fh } else { binmode $fh, $bm } } elsif ($self->{'ENCODING'}) { if (eval { require Encode } && defined &Encode::encode) { $output = Encode::encode($self->{'ENCODING'}, $output); } } print {$fh} $output; } else { print $output; } return if $self->{'error'}; return 1; } sub _load_template_meta { my $self = shift; return if $self->{'_template'}; # only do once as need eval { ### load the meta data for the top document ### this is needed by some of the custom handlers such as PRE_PROCESS and POST_PROCESS my $content = shift; my $doc = $self->{'_template'} = ref($content) eq 'HASH' ? $content : $self->load_template($content) || {}; my $meta = $doc->{'_perl'} ? $doc->{'_perl'}->{'meta'} : ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META') ? $doc->{'_tree'}->[0]->[3] : {}; $meta = {@$meta} if ref($meta) eq 'ARRAY'; $self->{'_template'} = $doc; @{ $doc }{keys %$meta} = values %$meta; }; return; } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::TT role provides the syntax and the interface for Template::Toolkit version 1, 2, and 3. It also brings many of the features from the various templating systems. And it is fast. See the Template::Alloy documentation for configuration and other parameters. =head1 HOW IS Template::Alloy DIFFERENT FROM Template::Toolkit Alloy uses the same base template syntax and configuration items as TT2, but the internals of Alloy were written from scratch. Additionally much of the planned TT3 syntax is supported as well as most of that of HTML::Template::Expr. The following is a list of some of the ways that the configuration and syntax of Alloy are different from that of TT2. Note: items that are planned to work in TT3 are marked with (TT3). =over 4 =item Numerical hash keys work [% a = {1 => 2} %] =item Quoted hash key interpolation is fine [% a = {"$foo" => 1} %] =item Multiple ranges in same constructor [% a = [1..10, 21..30] %] =item Constructor types can call virtual methods. (TT3) [% a = [1..10].reverse %] [% "$foo".length %] [% 123.length %] # = 3 [% 123.4.length %] # = 5 [% -123.4.length %] # = -5 ("." binds more tightly than "-") [% (a ~ b).length %] [% "hi".repeat(3) %] # = hihihi [% {a => b}.size %] # = 1 =item The "${" and "}" variable interpolators can contain expressions, not just variables. [% [0..10].${ 1 + 2 } %] # = 4 [% {ab => 'AB'}.${ 'a' ~ 'b' } %] # = AB [% color = qw/Red Blue/; FOR [1..4] ; color.${ loop.index % color.size } ; END %] # = RedBlueRedBlue =item You can use regular expression quoting. [% "foo".match( /(F\w+)/i ).0 %] # = foo =item Tags can be nested. [% f = "[% (1 + 2) %]" %][% f|eval %] # = 3 =item Arrays can be accessed with non-integer numbers. [% [0..10].${ 2.3 } %] # = 3 =item Reserved names are less reserved. (TT3) [% GET GET %] # gets the variable named "GET" [% GET $GET %] # gets the variable who's name is stored in "GET" =item Filters and SCALAR_OPS are interchangeable. (TT3) [% a | length %] [% b . lower %] =item Pipe "|" can be used anywhere dot "." can be and means to call the virtual method. (TT3) [% a = {size => "foo"} %][% a.size %] # = foo [% a = {size => "foo"} %][% a|size %] # = 1 (size of hash) =item Pipe "|" and "." can be mixed. (TT3) [% "aa" | repeat(2) . length %] # = 4 =item Added V2PIPE configuration item Restores the behavior of the pipe operator to be compatible with TT2. With V2PIPE = 1 [% PROCESS a | repeat(2) %] # = value of block or file a repeated twice With V2PIPE = 0 (default) [% PROCESS a | repeat(2) %] # = process block or file named a ~ a =item Added V2EQUALS configuration item Allows for turning off TT2 "==" behavior. Defaults to 1 in TT syntaxes and to 0 in HT syntaxes. [% CONFIG V2EQUALS => 1 %][% ('7' == '7.0') || 0 %] [% CONFIG V2EQUALS => 0 %][% ('7' == '7.0') || 0 %] Prints 0 1 =item Added AUTO_EVAL configuration item. Default false. If true, will automatically call eval filter on double quoted strings. =item Added SHOW_UNDEFINED_INTERP configuration item. Default false. If true, will leave in place interpolated values that weren't defined. You can then use the Velocity notation $!foo to not show these values. =item Added Virtual Object Namespaces. (TT3) The Text, List, and Hash types give direct access to virtual methods. [% a = "foobar" %][% Text.length(a) %] # = 6 [% a = [1 .. 10] %][% List.size(a) %] # = 10 [% a = {a=>"A", b=>"B"} ; Hash.size(a) %] = 2 [% foo = {a => 1, b => 2} | Hash.keys | List.join(", ") %] # = a, b =item Added "fmt" scalar, list, and hash virtual methods. [% list.fmt("%s", ", ") %] [% hash.fmt("%s => %s", "\n") %] =item Added missing HTML::Template::Expr vmethods The following vmethods were added - they correspond to the perl functions of the same name. abs atan2 cos exp hex lc log oct sin sprintf sqrt srand uc =item Allow all Scalar vmethods to behave as top level functions. [% sprintf("%d %d", 7, 8) %] # = "7 8" The following are equivalent in Alloy: [% "abc".length %] [% length("abc") %] This feature may be disabling by setting the VMETHOD_FUNCTIONS configuration item to 0. This is similar to how HTML::Template::Expr operates, but now you can use this functionality in TT templates as well. =item Whitespace is less meaningful. (TT3) [% 2-1 %] # = 1 (fails in TT2) =item Added pow operator. [% 2 ** 3 %] [% 2 pow 3 %] # = 8 8 =item Added string comparison operators (gt ge lt le cmp) [% IF "a" lt "b" %]a is less[% END %] =item Added numeric comparison operator (<=>) This can be used to make up for the fact that TT2 made == the same as eq (which will hopefully change - use eq when you mean eq). [% IF ! (a <=> b) %]a == b[% END %] [% IF (a <=> b) %]a != b[% END %] =item Added self modifiers (+=, -=, *=, /=, %=, **=, ~=). (TT3) [% a = 2; a *= 3 ; a %] # = 6 [% a = 2; (a *= 3) ; a %] # = 66 =item Added pre and post increment and decrement (++ --). (TT3) [% ++a ; ++a %] # = 12 [% a-- ; a-- %] # = 0-1 =item Added qw// contructor. (TT3) [% a = qw(a b c); a.1 %] # = b [% qw/a b c/.2 %] # = c =item Added regex contructor. (TT3) [% "FOO".match(/(foo)/i).0 %] # = FOO [% a = /(foo)/i; "FOO".match(a).0 %] # = FOO =item Allow for scientific notation. (TT3) [% a = 1.2e-20 %] [% 123.fmt('%.3e') %] # = 1.230e+02 =item Allow for hexadecimal input. (TT3) [% a = 0xff0000 %][% a %] # = 16711680 [% a = 0xff2 / 0xd; a.fmt('%x') %] # = 13a =item FOREACH variables can be nested. [% FOREACH f.b = [1..10] ; f.b ; END %] Note that nested variables are subject to scoping issues. f.b will not be reset to its value before the FOREACH. =item Post operative directives can be nested. (TT3) Andy Wardley calls this side-by-side effect notation. [% one IF two IF three %] same as [% IF three %][% IF two %][% one %][% END %][% END %] [% a = [[1..3], [5..7]] %][% i FOREACH i = j FOREACH j = a %] # = 123567 =item Semi-colons on directives in the same tag are optional. (TT3) [% SET a = 1 GET a %] [% FOREACH i = [1 .. 10] i END %] Note: a semi-colon is still required in front of any block directive that can be used as a post-operative directive. [% 1 IF 0 2 %] # prints 2 [% 1; IF 0 2 END %] # prints 1 Note2: This behavior can be disabled by setting the SEMICOLONS configuration item to a true value. If SEMICOLONS is true, then a SEMICOLON must be set after any directive that isn't followed by a post-operative directive. =item CATCH blocks can be empty. TT2 requires them to contain something. =item Added a DUMP directive. Used for Data::Dumper'ing the passed variable or expression. [% DUMP a.a %] =item Added CONFIG directive. [% CONFIG ANYCASE => 1 PRE_CHOMP => '-' %] =item Configuration options can use lowercase names instead of the all uppercase names that TT2 uses. my $t = Template::Alloy->new({ anycase => 1, interpolate => 1, }); =item Added LOOP directive (works the same as LOOP in HTML::Template. [%- var = [{key => 'a'}, {key => 'b'}] %] [%- LOOP var %] ([% key %]) [%- END %] Prints (a) (b) =item Alloy can parse HTML::Template and HTML::Template::Expr documents as well as TT2 and TT3 documents. =item Added SYNTAX configuration. The SYNTAX configuration can be used to change what template syntax will be used for parsing included templates or eval'ed strings. [% CONFIG SYNTAX => 'hte' %] [% var = '' %] [% var | eval %] =item Added @() and $() and CALL_CONTEXT. Template::Toolkit uses a \concept that Alloy refers to as "smart" context. All function calls or method calls of variables in Template::Toolkit are made in list context. If one item is in the list, it is returned. If two or more items are returned - it returns an arrayref. This "does the right thing" most of the time - but can cause confusion in some cases and is difficult to work around without writing wrappers for the functions or methods in Perl. Alloy has introduced the CALL_CONTEXT configuration item which defaults to "smart," but can also be set to "list" or "item." List context will always return an arrayref from called functions and methods and will call in list context. Item context will always call in item (scalar) context and will return one item. The @() and $() operators allow for functions embedded inside to use list and item context (respectively). They are modeled after the corresponding Perl 6 context specifiers. See the Template::Alloy::Operators perldoc and CALL_CONTEXT configuration documentation for more information. [% array = @( this.get_rows ) %] [% item = $( this.get_something ) %] =item Added -E() MACRO operator. The -E() operator behaves similarly to the MACRO directive, but can be used to pass functions to map, grep, and sort vmethods. [% MACRO foo(n) BLOCK %]Say [% n %][% END %] [% foo = ->(n){ "Say $n" } %] [% [0..10].grep(->(this % 2)).join %] prints 3 5 7 9 [% ['a' .. 'c'].map(->(a){ a.upper }).join %] prints A B C [% [1,2,3].sort(->(a,b){ b <=> a }).join %] prints 3 2 1 =item The RETURN directive can take a variable or expression as a return value. Their are also "return" list, item, and hash vmethods. Return will also return from an enclosing MACRO. [% a = ->(n){ [1..n].return } %] =item Alloy does not generate Perl code. It generates an "opcode" tree. The opcode tree is an arrayref of scalars and array refs nested as deeply as possible. This "simple" structure could be shared TT implementations in other languages via JSON or YAML. You can optionally enable generating Perl code by setting COMPILE_PERL = 1. =item Alloy uses storable for its compiled templates. If EVAL_PERL is off, Alloy will not eval_string on ANY piece of information. =item There is eval_filter and MACRO recursion protection You can control the nested nature of eval_filter and MACRO recursion using the MAX_EVAL_RECURSE and MAX_MACRO_RECURSE configuration items. =item There is no context. Alloy provides a context object that mimics the Template::Context interface for use by some TT filters, eval perl blocks, views, and plugins. =item There is no provider. Alloy uses the load_template method to get and cache templates. =item There is no parser/grammar. Alloy has its own built-in recursive regex based parser and grammar system. Alloy can actually be substituted in place of the native Template::Parser and Template::Grammar in TT by using the Template::Parser::Alloy module. This module uses the output of parse_tree to generate a TT style compiled perl document. =item The DEBUG directive is more limited. It only understands DEBUG_DIRS (8) and DEBUG_UNDEF (2). =item Alloy has better line information When debug dirs is on, directives on different lines separated by colons show the line they are on rather than a general line range. Parse errors actually know what line and character they occurred at. =back =head1 UNSUPPORTED TT2 CONFIGURATION =over 4 =item LOAD_TEMPLATES Template::Alloy has its own mechanism for loading and storing compiled templates. TT would use a Template::Provider that would return a Template::Document. The closest thing in Template::Alloy is the load_template method. There is no immediate plan to support the TT behavior. =item LOAD_PLUGINS Template::Alloy uses its own mechanism for loading plugins. TT would use a Template::Plugins object to load plugins requested via the USE directive. The functionality for doing this in Template::Alloy is contained in the list_plugins method and the play_USE method. There is no immediate plan to support the TT behavior. Full support is offered for the PLUGINS and LOAD_PERL configuration items. Also note that Template::Alloy only has native support for the Iterator plugin. Any of the other plugins requested will need to provided by installing Template::Toolkit or the appropriate plugin module. =item LOAD_FILTERS Template::Alloy uses its own mechanism for loading filters. TT would use the Template::Filters object to load filters requested via the FILTER directive. The functionality for doing this in Template::Alloy is contained in the list_filters method and the play_expr method. Full support is offered for the FILTERS configuration item. =item TOLERANT This option is used by the LOAD_TEMPLATES and LOAD_PLUGINS options and is not applicable in Template::Alloy. =item SERVICE Template::Alloy has no concept of service (theoretically the Template::Alloy is the "service"). =item CONTEXT Template::Alloy provides its own pseudo context object to plugins, filters, and perl blocks. The Template::Alloy model doesn't really allow for a separate context. Template::Alloy IS the context. =item PARSER Template::Alloy has its own built in parser. The closest similarity is the parse_tree method. The output of parse_tree is an optree that is later run by execute_tree. Alloy provides a backend to the Template::Parser::Alloy module which can be used to replace the default parser when using the standard Template::Toolkit library. =item GRAMMAR Template::Alloy maintains its own grammar. The grammar is defined in the parse_tree method and the callbacks listed in the global $Template::Alloy::Parse::DIRECTIVES hashref. =back =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Tmpl.pm000066400000000000000000000112741402714000200227440ustar00rootroot00000000000000package Template::Alloy::Tmpl; =head1 NAME Template::Alloy::Tmpl - Text::Tmpl role =cut use strict; use warnings; use Template::Alloy; our $VERSION = $template::Alloy::VERSION; our $error; sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### sub parse_tree_tmpl { my $self = shift; local @{ $Template::Alloy::Parse::ALIASES }{qw(ECHO INCLUDE IFN ENDCOMMENT ENDIF ENDIFN ENDLOOP)} = qw(GET PROCESS UNLESS END END END END); local $self->{'V1DOLLAR'} = defined($self->{'V1DOLLAR'}) ? $self->{'V1DOLLAR'} : 1; local $self->{'ANYCASE'} = defined($self->{'ANYCASE'}) ? $self->{'ANYCASE'} : 1; local $self->{'TAG_STYLE'} = $self->{'TAG_STYLE'} || 'html'; return $self->parse_tree_tt3(@_); } ###----------------------------------------------------------------### ### support for few Text::Tmpl calling syntax sub set_delimiters { my $self = shift; $self->{'START_TAG'} = quotemeta(shift || $self->throw('set', 'missing start_tag')); $self->{'END_TAG'} = quotemeta(shift || $self->throw('set', 'missing end_tag')); } sub strerror { $Template::Alloy::Tmpl::error } sub set_strip { my $self = shift; $self->{'POST_CHOMP'} = $_[0] ? '-' : '+'; 1 } sub set_value { my $self = shift; $self->{'_vars'}->{$_[0]} = $_[1]; 1 } sub set_values { my ($self, $hash) = @_; @{ $self->{'_vars'} ||= {} }{keys %$hash} = values %$hash; 1 } sub parse_string { my $self = shift; return $self->parse_file(\$_[0]) } sub set_dir { my $self = shift; $self->{'INCLUDE_PATHS'} = [shift, './']; } sub parse_file { my ($self, $content) = @_; my $vars = $self->{'_vars'} || {}; local $self->{'SYNTAX'} = $self->{'SYNTAX'} || 'tmpl'; local $Template::Alloy::QR_PRIVATE = undef; local $self->{'ABSOLUTE'} = defined($self->{'ABSOLUTE'}) ? $self->{'ABSOLUTE'} : 1; local $self->{'RELATIVE'} = defined($self->{'RELATIVE'}) ? $self->{'RELATIVE'} : 1; $error = undef; my $out = ''; $self->process_simple($content, $vars, \$out) || ($error = $self->error); return $out; } sub loop_iteration { my $self = shift; my $name = shift; my $ref = $self->{'_vars'}->{$name} ||= []; my $vars; $self->throw('loop', "Variable $name is not an arrayref during loop_iteration") if ref($ref) ne 'ARRAY'; if (defined(my $index = shift)) { $vars = $ref->[$index] || $self->throw('loop', "Index $index is not yet defined on loop $name"); } else { $vars = {}; push @$ref, $vars; } return ref($self)->new('_vars' => $vars); } sub fetch_loop_iteration { shift->loop_iteration(@_) } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::Tmpl role provides the syntax and the interface for Text::Tmpl. It also brings many of the features from the various templating systems. See the Template::Alloy documentation for configuration and other parameters. =head1 ROLE_METHODS =over 4 =item C Called by parse_tree when syntax is set to tmpl. Parses for tags Text::Tmpl style. =item C Sets the START_TAG and END_TAG to use for parsing. $obj->set_delimiters('#[', ']#'); =item C Can be used for checking the error when compile fails (or you can use ->error). May be called as function or method (Text::Tmpl only allows as function). =item C Determines if trailing whitespace on same line is removed. Default is false. =item C Sets the path to look for included templates in. =item C Sets a single value that will be used during processing of the template. $obj->set_value(key => $value); =item C Sets multiple values for use during processing. $obj->set_values(\%values); =item C Processes the passed string. my $out = $obj->process_string("#[echo $foo]#"); =item C Processes the passed filename. my $out = $obj->process_file("my/file.tmpl"); =item C Same as the Text::Tmpl method - used for adding iterations to a loop. my $ref = $obj->loop_iteration('loop1'); # creates iteration 0 $ref->set_values($hash); =item C Gets a previously created loop iteration. my $ref = $obj->fetch_loop_iteration('loop1', 0); $ref->set_values($hash); =back =head1 UNSUPPORTED Text::Tmpl METHODS register_simple, register_pair, alias_simple, alias_pair, remove_simple, remove_pair, set_debug, errno =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/VMethod.pm000066400000000000000000001032251402714000200233740ustar00rootroot00000000000000package Template::Alloy::VMethod; =head1 NAME Template::Alloy::VMethod - VMethod role. =cut use strict; use warnings; use Template::Alloy; use base qw(Exporter); our @EXPORT_OK = qw(define_vmethod $ITEM_OPS $ITEM_METHODS $SCALAR_OPS $LIST_OPS $LIST_METHODS $HASH_OPS $FILTER_OPS $VOBJS); sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### our ($JSON, $JSONP); sub json { $JSON ||= do { require JSON; JSON->new->utf8->allow_nonref->allow_unknown->allow_blessed->convert_blessed->canonical } } sub jsonp { $JSONP ||= do { require JSON; JSON->new->utf8->allow_nonref->allow_unknown->allow_blessed->convert_blessed->canonical->pretty } } our $SCALAR_OPS = our $ITEM_OPS = { '0' => sub { $_[0] }, abs => sub { no warnings; abs shift }, atan2 => sub { no warnings; atan2($_[0], $_[1]) }, chunk => \&vmethod_chunk, collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ }, cos => sub { no warnings; cos $_[0] }, defined => sub { defined $_[0] ? 1 : '' }, dquote => sub { local $_ = $_[0]; return if ! $_; s/([\"\\])/\\$1/g; s/\n/\\n/g; $_ }, exp => sub { no warnings; exp $_[0] }, fmt => \&vmethod_fmt_scalar, 'format' => \&vmethod_format, hash => sub { {value => $_[0]} }, hex => sub { no warnings; hex $_[0] }, html => sub { local $_ = $_[0]; return $_ if ! $_; s/&/&/g; s//>/g; s/\"/"/g; $_ }, indent => \&vmethod_indent, int => sub { no warnings; int $_[0] }, item => sub { $_[0] }, js => sub { local $_ = $_[0]; return if ! $_; s/\n/\\n/g; s/\r/\\r/g; s/(? sub { return json()->encode($_[0]) if ! $_[1]; my $j = jsonp()->encode($_[0]); chomp $j; $j }, lc => sub { lc $_[0] }, lcfirst => sub { lcfirst $_[0] }, length => sub { defined($_[0]) ? length($_[0]) : 0 }, list => sub { [$_[0]] }, log => sub { no warnings; log $_[0] }, lower => sub { lc $_[0] }, match => \&vmethod_match, new => sub { defined $_[0] ? $_[0] : '' }, none => sub { $_[0] }, null => sub { '' }, oct => sub { no warnings; oct $_[0] }, print => sub { no warnings; "@_" }, rand => sub { no warnings; rand shift }, remove => sub { vmethod_replace(shift, shift, '', 1) }, repeat => \&vmethod_repeat, replace => \&vmethod_replace, 'return' => \&vmethod_return, search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ }, sin => sub { no warnings; sin $_[0] }, size => sub { 1 }, split => \&vmethod_split, sprintf => sub { no warnings; my $pat = shift; sprintf($pat, @_) }, sqrt => sub { no warnings; sqrt $_[0] }, squote => sub { local $_ = $_[0]; return if ! $_; s/([\'\\])/\\$1/g; $_ }, srand => sub { no warnings; srand $_[0]; '' }, stderr => sub { print STDERR $_[0]; '' }, substr => \&vmethod_substr, trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ }, uc => sub { uc $_[0] }, ucfirst => sub { ucfirst $_[0] }, upper => sub { uc $_[0] }, uri => \&vmethod_uri, url => \&vmethod_url, xml => sub { local $_ = $_[0]; s/&/&/g; s//>/g; s/\"/"/g; s/\'/'/g; $_ }, }; our $ITEM_METHODS = { eval => \&Template::Alloy::item_method_eval, evaltt => \&Template::Alloy::item_method_eval, file => \&item_method_redirect, redirect => \&item_method_redirect, block_exists => sub { defined($_[1]) && UNIVERSAL::isa($_[0], 'HASH') && $_[0]->{'BLOCKS'} && exists($_[0]->{'BLOCKS'}->{$_[1]}) || 0 }, }; our $FILTER_OPS = {}; # generally - non-dynamic filters belong in scalar ops our $LIST_OPS = { defined => sub { return 1 if @_ == 1; defined $_[0]->[ defined($_[1]) ? $_[1] : 0 ] }, first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]}, fmt => \&vmethod_fmt_list, grep => sub { no warnings; my ($ref, $pat) = @_; UNIVERSAL::isa($pat, 'CODE') ? [grep {$pat->($_)} @$ref] : [grep {/$pat/} @$ref] }, hash => sub { no warnings; my $list = shift; return {@$list} if ! @_; my $i = shift || 0; return {map {$i++ => $_} @$list} }, import => sub { my $ref = shift; push @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_; '' }, item => sub { $_[0]->[ $_[1] || 0 ] }, join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; no warnings; return join $join, @$ref }, json => sub { return json()->encode($_[0]) if ! $_[1]; my $j = jsonp()->encode($_[0]); chomp $j; $j }, last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]}, list => sub { $_[0] }, map => sub { no warnings; my ($ref, $code) = @_; UNIVERSAL::isa($code, 'CODE') ? [map {$code->($_)} @$ref] : [map {$code} @$ref] }, max => sub { no warnings; $#{ $_[0] } }, merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] }, new => sub { no warnings; return [@_] }, null => sub { '' }, nsort => \&vmethod_nsort, pick => \&vmethod_pick, pop => sub { pop @{ $_[0] } }, push => sub { my $ref = shift; push @$ref, @_; return '' }, 'return' => \&vmethod_return, reverse => sub { [ reverse @{ $_[0] } ] }, shift => sub { shift @{ $_[0] } }, size => sub { no warnings; scalar @{ $_[0] } }, slice => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] }, sort => \&vmethod_sort, splice => \&vmethod_splice, unique => sub { my %u; return [ grep { ! $u{$_}++ } @{ $_[0] } ] }, unshift => sub { my $ref = shift; unshift @$ref, @_; return '' }, }; our $LIST_METHODS = { }; our $HASH_OPS = { defined => sub { return 1 if @_ == 1; defined $_[0]->{ defined($_[1]) ? $_[1] : '' } }, delete => sub { my $h = shift; delete @{ $h }{map {defined($_) ? $_ : ''} @_}; '' }, each => sub { [%{ $_[0] }] }, exists => sub { exists $_[0]->{ defined($_[1]) ? $_[1] : '' } }, fmt => \&vmethod_fmt_hash, hash => sub { $_[0] }, import => sub { my ($a, $b) = @_; @{$a}{keys %$b} = values %$b if ref($b) eq 'HASH'; '' }, item => sub { my ($h, $k) = @_; $k = '' if ! defined $k; $Template::Alloy::QR_PRIVATE && $k =~ $Template::Alloy::QR_PRIVATE ? undef : $h->{$k} }, items => sub { [ %{ $_[0] } ] }, json => sub { return json()->encode($_[0]) if ! $_[1]; my $j = jsonp()->encode($_[0]); chomp $j; $j }, keys => sub { [keys %{ $_[0] }] }, list => \&vmethod_list_hash, new => sub { no warnings; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} }, null => sub { '' }, nsort => sub { my $ref = shift; [sort { $ref->{$a} <=> $ref->{$b}} keys %$ref] }, pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } sort keys %{ $_[0] } ] }, 'return' => \&vmethod_return, size => sub { scalar keys %{ $_[0] } }, sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] }, values => sub { [values %{ $_[0] }] }, }; our $VOBJS = { Text => $SCALAR_OPS, List => $LIST_OPS, Hash => $HASH_OPS, }; foreach (values %$VOBJS) { $_->{'Text'} = $_->{'fmt'}; $_->{'Hash'} = $_->{'hash'}; $_->{'List'} = $_->{'list'}; } ###----------------------------------------------------------------### ### long virtual methods or filters ### many of these vmethods have used code from Template/Stash.pm to ### assure conformance with the TT spec. sub define_vmethod { my ($self, $type, $name, $sub) = @_; if ( $type =~ /scalar|item|text/i) { $SCALAR_OPS->{$name} = $sub } elsif ($type =~ /array|list/i ) { $LIST_OPS->{ $name} = $sub } elsif ($type =~ /hash/i ) { $HASH_OPS->{ $name} = $sub } elsif ($type =~ /filter/i ) { $FILTER_OPS->{$name} = $sub } else { die "Invalid type vmethod type $type" } return 1; } sub vmethod_fmt_scalar { my $str = shift; $str = '' if ! defined $str; my $pat = shift; $pat = '%s' if ! defined $pat; no warnings; return @_ ? sprintf($pat, $_[0], $str) : sprintf($pat, $str); } sub vmethod_fmt_list { my $ref = shift || return ''; my $pat = shift; $pat = '%s' if ! defined $pat; my $sep = shift; $sep = ' ' if ! defined $sep; no warnings; return @_ ? join($sep, map {sprintf $pat, $_[0], $_} @$ref) : join($sep, map {sprintf $pat, $_} @$ref); } sub vmethod_fmt_hash { my $ref = shift || return ''; my $pat = shift; $pat = "%s\t%s" if ! defined $pat; my $sep = shift; $sep = "\n" if ! defined $sep; no warnings; return ! @_ ? join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref) : @_ == 1 ? join($sep, map {sprintf $pat, $_[0], $_, $ref->{$_}} sort keys %$ref) # don't get to pick - it applies to the key : join($sep, map {sprintf $pat, $_[0], $_, $_[1], $ref->{$_}} sort keys %$ref); } sub vmethod_chunk { my $str = shift; my $size = shift || 1; my @list; if ($size < 0) { # chunk from the opposite end $str = reverse $str; $size = -$size; unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg; } else { push(@list, $1) while $str =~ /( .{$size} | .+ )/xg; } return \@list; } sub vmethod_indent { my $str = shift; $str = '' if ! defined $str; my $pre = shift; $pre = 4 if ! defined $pre; $pre = ' ' x $pre if $pre =~ /^\d+$/; $str =~ s/^/$pre/mg; return $str; } sub vmethod_format { my $str = shift; $str = '' if ! defined $str; my $pat = shift; $pat = '%s' if ! defined $pat; if (@_) { return join "\n", map{ sprintf $pat, $_[0], $_ } split(/\n/, $str); } else { return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str); } } sub vmethod_list_hash { my ($hash, $what) = @_; $what = 'pairs' if ! $what || $what !~ /^(keys|values|each|pairs)$/; return $HASH_OPS->{$what}->($hash); } sub vmethod_match { my ($str, $pat, $global) = @_; return [] if ! defined $str || ! defined $pat; my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/); return @res ? \@res : ''; } sub vmethod_nsort { my ($list, $field) = @_; return defined($field) ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field} : UNIVERSAL::can($_, $field) ? $_->$field() : $_)]} @$list ] : [sort {$a <=> $b} @$list]; } sub vmethod_pick { my $ref = shift; no warnings; my $n = int(shift); $n = 1 if $n < 1; my @ind = map { $ref->[ rand @$ref ] } 1 .. $n; return $n == 1 ? $ind[0] : \@ind; } sub vmethod_repeat { my ($str, $n, $join) = @_; return '' if ! defined $str || ! length $str; $n = 1 if ! defined($n) || ! length $n; $join = '' if ! defined $join; return join $join, ($str) x $n; } ### This method is a combination of my submissions along ### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum sub vmethod_replace { my ($text, $pattern, $replace, $global) = @_; $text = '' unless defined $text; $pattern = '' unless defined $pattern; $replace = '' unless defined $replace; $global = 1 unless defined $global; my $expand = sub { my ($chunk, $start, $end) = @_; $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{ $1 ? $1 : ($2 > $#$start || $2 == 0) ? '' : substr($text, $start->[$2], $end->[$2] - $start->[$2]); }exg; $chunk; }; if ($global) { $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg; } else { $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e; } return $text; } sub vmethod_return { my $obj = shift; Template::Alloy->throw('return', {return_val => $obj}); } sub vmethod_sort { my ($list, $field) = @_; if (! defined $field) { return [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive } elsif (UNIVERSAL::isa($field, 'CODE')) { return [sort {int($field->($a, $b))} @$list]; } else { return [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field} : UNIVERSAL::can($_, $field) ? $_->$field() : $_)]} @$list ]; } } sub vmethod_splice { my ($ref, $i, $len, @replace) = @_; @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY'; if (defined $len) { return [splice @$ref, $i || 0, $len, @replace]; } elsif (defined $i) { return [splice @$ref, $i]; } else { return [splice @$ref]; } } sub vmethod_split { my ($str, $pat, $lim) = @_; $str = '' if ! defined $str; if (defined $lim) { return defined $pat ? [split $pat, $str, $lim] : [split ' ', $str, $lim] } else { return defined $pat ? [split $pat, $str ] : [split ' ', $str ] } } sub vmethod_substr { my ($str, $i, $len, $replace) = @_; $i ||= 0; return '' if ! defined $str; return substr($str, $i) if ! defined $len; return substr($str, $i, $len) if ! defined $replace; substr($str, $i, $len, $replace); return $str; } sub vmethod_uri { my $str = shift; return '' if ! defined $str; utf8::upgrade($str) if defined &utf8::upgrade; $str =~ s/([^A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg; return $str; } sub vmethod_url { my $str = shift; return '' if ! defined $str; utf8::upgrade($str) if defined &utf8::upgrade; $str =~ s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg; return $str; } sub item_method_redirect { my ($t, $text, $file, $options) = @_; my $path = $t->{'OUTPUT_PATH'} || $t->throw('redirect', 'OUTPUT_PATH is not set'); $t->throw('redirect', 'Invalid filename - cannot include "/../"') if $file =~ m{(^|/)\.\./}; if (! -d $path) { require File::Path; File::Path::mkpath($path) || $t->throw('redirect', "Couldn't mkpath \"$path\": $!"); } open (my $fh, '>', "$path/$file") || $t->throw('redirect', "Couldn't open \"$file\": $!"); if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) { if (+$bm == 1) { binmode $fh } else { binmode $fh, $bm} } print $fh $text; return ''; } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::VMethod role provides all of the extra vmethods, filters, and virtual objects that add to the base feature set of Template::Alloy. Most of the vmethods listed here are similar to those provided by Template::Toolkit. We will try to keep Template::Alloy's in sync. Template::Alloy also provides several extra methods that are needed for HTML::Template::Expr support. =head1 ROLE METHODS =over 4 =item define_vmethod Defines a vmethod. See L for more details. =item C Methods by these names implement virtual methods that are more complex than oneliners. These methods are not exposed via the role. =item C Methods by these names implement filters that are more complex than one liners. These methods are not exposed via the role. =back =head1 VIRTUAL METHOD LIST The following is the list of builtin virtual methods and filters that can be called on each type of data. In Template::Alloy, the "|" operator can be used to call virtual methods just the same way that the "." operator can. The main difference between the two is that on access to hashrefs or objects, the "|" means to always call the virtual method or filter rather than looking in the hashref for a key by that name, or trying to call that method on the object. This is similar to how TT3 will function. Virtual methods are also made available via Virtual Objects which are discussed in a later section. =head2 SCALAR VIRTUAL METHODS AND FILTERS The following is the list of builtin virtual methods and filters that can be called on scalar data types. In Alloy and TT3, filters and virtual methods are more closely related than in TT2. In general anywhere a virtual method can be used a filter can be used also - and likewise all scalar virtual methods can be used as filters. In addition to the filters listed below, Alloy will automatically load Template::Filters and use them if Template::Toolkit is installed. In addition to the scalar virtual methods, any scalar will be automatically converted to a single item list if a list virtual method is called on it. Scalar virtual methods are also available through the "Text" virtual object (except for true filters such as eval and redirect). All scalar virtual methods are available as top level functions as well. This is not true of TT2. In Template::Alloy the following are equivalent: [% "abc".length %] [% length("abc") %] You may set VMETHOD_FUNCTIONS to 0 to disable this behavior. =over 4 =item '0' [% item = 'foo' %][% item.0 %] Returns foo. Allows for scalars to mask as arrays (scalars already will, but this allows for more direct access). Not available in TT. =item abs [% -1.abs %] Returns the absolute value =item atan2 [% pi = 4 * 1.atan2(1) %] Returns the arctangent. The item itself represents Y, the passed argument represents X. Not available in TT - available in HTML::Template::Expr. =item chunk [% item.chunk(60).join("\n") %] Split string up into a list of chunks of text 60 chars wide. =item collapse [% item.collapse %] Strip leading and trailing whitespace and collapse all other space to one space. =item cos [% item.cos %] Returns the cosine of the item. Not available in TT - available in HTML::Template::Expr. =item defined [% item.defined %] Always true - because the undef sub translates all undefs to ''. =item eval [% item.eval %] Process the string as though it was a template. This will start the parsing engine and will use the same configuration as the current process. Alloy is several times faster at doing this than TT is and is considered acceptable. This is a filter and is not available via the Text virtual object. Template::Alloy has attempted to make the compile process painless and fast. By default an MD5 sum of evaled is taken and used to cache the AST. This behavior can be disabled using the CACHE_STR_REFS configuration item. Template::Alloy also allows for named parameters to be passed to the eval filter. [% '[% 1 + 2 %]'.eval %] [% '${ 1 + 2 }'.eval(interpolate => 1) %] [% "#get( 1 + 2)"|eval(syntax => 'velocity') %] [% ''.eval(syntax => 'hte') %] [% ''.eval(syntax => 'hte') %] =item evaltt Same as the eval filter. =item exp [% 1.exp %] Something like 2.71828182845905 Returns "e" to the power of the item. =item file Same as the redirect filter. =item fmt [% item.fmt('%d') %] [% item.fmt('%6s') %] [% item.fmt('%*s', 6) %] Similar to format. Returns a string formatted with the passed pattern. Default pattern is %s. Opposite from of the sprintf vmethod. =item format [% item.format('%d') %] [% item.format('%6s') %] [% item.format('%*s', 6) %] Print the string out in the specified format. It is similar to the "fmt" virtual method, except that the item is split on newline and each line is processed separately. =item hash [% item.hash %] Returns a one item hash with a key of "value" and a value of the item. =item hex [% "FF".hex %] Returns the decimal value of the passed hex numbers. Note that you may also just use [% 0xFF %]. Not available in TT - available in HTML::Template::Expr. =item html [% item.html %] Performs a very basic html encoding (swaps out &, <, > and " with the corresponding html entities) Previously it also encoded the ' but this behavior did not match TT2's behavior. Use .xml to obtain that behavior. =item indent [% item.indent(3) %] Indent by that number of spaces if an integer is passed (default is 4). [% item.indent("Foo: ") %] Add the string "Foo: " to the beginning of every line. =item int [% item.int %] Return the integer portion of the value (0 if none). =item json [% item.json %] Returns a JSON encoded representation. [% item.json(1) %] Returns a pretty JSON encoded representation. =item lc Same as the lower vmethod. Returns the lowercased version of the item. =item lcfirst [% item.lcfirst %] Lowercase the leading letter. =item length [% item.length %] Return the length of the string. =item list [% item.list %] Returns a list (arrayref) with a single value of the item. =item log [% 8.exp.log %] Equal to 8. Returns the natural log base "e" of the item. Not available in TT - available in HTML::Template::Expr. =item lower [% item.lower %] Return the string lowercased. =item match [% item.match("(\w+) (\w+)") %] Return a list of items matching the pattern. [% item.match("(\w+) (\w+)", 1) %] Same as before - but match globally. In Template::Alloy and TT3 you can use regular expressions notation as well. [% item.match( /(\w+) (\w+)/ ) %] Same as before. [% item.match( m{(\w+) (\w+)} ) %] Same as before. Note that you can't use the 'g' regex modifier - you must pass the second argument to turn on global match. =item none Returns the item without modification. This was added as a compliment case when the AUTO_FILTER configuration is specified. Note that it must be called as a filter to bypass the application of the AUTO_FILTER. [% item | none %] Returns the item without modification. =item null [% item.null %] Return nothing. If the item contains a coderef it will still be executed, but the result would be ignored. =item oct [% "377".oct %] Returns the decimal value of the octal string. On recent versions of perl you may also pass numbers starting with 0x which will be interpreted as hexadecimal, and starting with 0b which will be interpreted as binary. Not available in TT - available in HTML::Template::Expr. =item rand [% item = 10; item.rand %] Returns a number greater or equal to 0 but less than 10. [% 1.rand %] Note: This filter is not available as of TT2.15. =item remove [% item.remove("\s+") %] Same as replace - but is global and replaces with nothing. =item redirect [% item.redirect("output_file.html") %] Writes the contents out to the specified file. The filename must be relative to the OUTPUT_PATH configuration variable and the OUTPUT_PATH variable must be set. This is a filter and is not available via the Text virtual object. =item repeat [% item.repeat(3) %] Repeat the item 3 times [% item.repeat(3, ' | ') %] Repeat the item 3 times separated with ' | ' =item replace [% item.replace("\s+", " ") %] Globally replace all space with   [% item.replace("foo", "bar", 0) %] Replace only the first instance of foo with bar. [% item.replace("(\w+)", "($1)") %] Surround all words with parenthesis. In Template::Alloy and TT3 you may also use normal regular expression notation. [% item.replace(/(\w+)/, "($1)") %] Same as before. Note that you can't use the 'g' regex modifier - global match is on by default. You must pass the third argument of false to turn off global match. =item return Returns the item from the inner most block, macro, or file. Similar to the RETURN directive. [% item.return %] [% RETURN item %] =item search [% item.search("(\w+)") %] Tests if the given pattern is in the string. In Template::Alloy and TT3 you may also use normal regular expression notation. [% item.search(/(\w+)/) %] Same as before. =item sin [% item.sin %] Returns the sine of the item. =item size [% item.size %] Always returns 1. =item split [% item.split %] Returns an arrayref from the item split on " " [% item.split("\s+") %] Returns an arrayref from the item split on /\s+/ [% item.split("\s+", 3) %] Returns an arrayref from the item split on /\s+/ splitting until 3 elements are found. In Template::Alloy and TT3 you may also use normal regular expression notation. [% item.split( /\s+/, 3 ) %] Same as before. =item sprintf [% item = "%d %d" %] [% item.sprintf(7, 8) %] Uses the pattern stored in self, and passes it to sprintf with the passed arguments. Opposite from the fmt vmethod. =item sqrt [% item.sqrt %] Returns the square root of the number. =item srand Calls the perl srand function to set the internal random seed. This will affect future calls to the rand vmethod. =item stderr [% item.stderr %] Print the item to the current STDERR handle. =item substr [% item.substr(i) %] Returns a substring of item starting at i and going to the end of the string. [% item.substr(i, n) %] Returns a substring of item starting at i and going n characters. =item trim [% item.trim %] Strips leading and trailing whitespace. =item uc Same as the upper command. Returns uppercased string. =item ucfirst [% item.ucfirst %] Uppercase the leading letter. =item upper [% item.upper %] Return the string uppercased. =item uri [% item.uri %] Perform a very basic URI encoding. =item url [% item.url %] Perform a URI encoding - but some characters such as : and / are left intact. =item xml [% item.xml %] Performs a very basic xml encoding (swaps out &, <, >, ' and " with the corresponding xml entities) =back =head2 LIST VIRTUAL METHODS The following methods can be called on an arrayref type data structures (scalar types will automatically promote to a single element list and call these methods if needed): Additionally, list virtual methods can be accessed via the List Virtual Object. =over 4 =item fmt [% mylist.fmt('%s', ', ') %] [% mylist.fmt('%6s', ', ') %] [% mylist.fmt('%*s', ', ', 6) %] Passed a pattern and an string to join on. Returns a string of the values of the list formatted with the passed pattern and joined with the passed string. Default pattern is %s and the default join string is a space. =item first [% mylist.first(3) %] Returns a list of the first 3 items in the list. =item grep [% mylist.grep("^\w+\.\w+$") %] Returns a list of all items matching the pattern. In Template::Alloy and TT3 you may also use normal regular expression notation. [% mylist.grep(/^\w+\.\w+$/) %] Same as before. [% mylist.grep(->(a){ a.foo.bar } =item hash [% mylist.hash %] Returns a hashref with the array indexes as keys and the values as values. =item join [% mylist.join %] Joins on space. [% mylist.join(", ") Joins on the passed argument. =item json [% mylist.json %] Returns a JSON encoded representation. [% mylist.json(1) %] Returns a pretty JSON encoded representation. =item last [% mylist.last(3) %] Returns a list of the last 3 items in the list. =item list [% mylist.list %] Returns a reference to the list. =item map (Not in TT2) [% mylist.map(->{ this.upper }) %] Returns a list with the macro played on each item. [% mylist.map(->(a){ a.upper }) %] Same thing The RETURN directive or return list, item, and hash vmethods allow for returning more interesting items. [% [1..3].map(->(a){ [1..a].return }) %] =item max [% mylist.max %] Returns the last item in the array. =item merge [% mylist.merge(list2) %] Returns a new list with all defined items from list2 added. =item nsort [% mylist.nsort %] Returns the numerically sorted items of the list. If the items are hashrefs, a key containing the field to sort on can be passed. =item pop [% mylist.pop %] Removes and returns the last element from the arrayref (the stash is modified). =item push [% mylist.push(23) %] Adds an element to the end of the arrayref (the stash is modified). =item pick [% mylist.pick %] Returns a random item from the list. [% ['a' .. 'z'].pick %] An additional numeric argument is how many items to return. [% ['a' .. 'z'].pick(8).join('') %] Note: This filter is not available as of TT2.15. =item return Returns the list from the inner most block, macro, or file. Similar to the RETURN directive. [% mylist.return %] [% RETURN mylist %] =item reverse [% mylist.reverse %] Returns the list in reverse order. =item shift [% mylist.shift %] Removes and returns the first element of the arrayref (the stash is modified). =item size [% mylist.size %] Returns the number of elements in the array. =item slice [% mylist.slice(i, n) %] Returns a list from the arrayref beginning at index i and continuing for n items. =item sort [% mylist.sort %] Returns the alphabetically sorted items of the list. If the items are hashrefs, a key containing the field to sort on can be passed. =item splice [% mylist.splice(i, n) %] Removes items from array beginning at i and continuing for n items. [% mylist.splice(i, n, list2) %] Same as before, but replaces removed items with the items from list2. =item unique [% mylist.unique %] Return a list of the unique items in the array. =item unshift [% mylist.unshift(23) %] Adds an item to the beginning of the arrayref. =back =head2 HASH VIRTUAL METHODS The following methods can be called on hash type data structures: Additionally, list virtual methods can be accessed via the Hash Virtual Object. =over 4 =item fmt [% myhash.fmt('%s => %s', "\n") %] [% myhash.fmt('%4s => %5s', "\n") %] [% myhash.fmt('%*s => %*s', "\n", 4, 5) %] Passed a pattern and an string to join on. Returns a string of the key/value pairs of the hash formatted with the passed pattern and joined with the passed string. Default pattern is "%s\t%s" and the default join string is a newline. =item defined [% myhash.defined('a') %] Checks if a is defined in the hash. =item delete [% myhash.delete('a') %] Deletes the item from the hash. Unlink Perl the value is not returned. Multiple values may be passed and represent the keys to be deleted. =item each [% myhash.each.join(", ") %] Turns the contents of the hash into a list - subject to change as TT is changing the operations of each and list. =item exists [% myhash.exists('a') %] Checks if a is in the hash. =item hash [% myhash.hash %] Returns a reference to the hash. =item import [% myhash.import(hash2) %] Overlays the keys of hash2 over the keys of myhash. =item item [% myhash.item(key) %] Returns the hashes value for that key. =item items [% myhash.items %] Returns a list of the key and values (flattened hash) =item json [% myhash.json %] Returns a JSON encoded representation. [% myhash.json(1) %] Returns a pretty JSON encoded representation. =item keys [% myhash.keys.join(', ') %] Returns an arrayref of the keys of the hash. =item list [% myhash.list %] Returns an arrayref with the hash as a single value (subject to change). =item pairs [% myhash.pairs %] Returns an arrayref of hashrefs where each hash contains {key => $key, value => $value} for each value of the hash. =item nsort [% myhash.nsort.join(", ") %] Returns a list of keys numerically sorted by the values. =item return Returns the hash from the inner most block, macro, or file. Similar to the RETURN directive. [% myhash.return %] [% RETURN myhash %] =item size [% myhash.size %] Returns the number of key/value pairs in the hash. =item sort [% myhash.sort.join(", ") Returns a list of keys alphabetically sorted by the values. =item values [% myhash.values.join(', ') %] Returns an arrayref of the values of the hash. =back =head1 VIRTUAL OBJECTS TT3 has a concept of Text, List, and Hash virtual objects which provide direct access to the scalar, list, and hash virtual methods. In the TT3 engine this will allow for more concise generated code. Because Alloy does not generated perl code to be executed later, Alloy provides for these virtual objects but does so as more of a namespace (using the methods does not provide a speed optimization in your template - just may help clarify things). [% a = "foo"; a.length %] => 3 [% a = "foo"; Text.length(a) %] => 3 [% a = Text.new("foo"); a.length %] => 3 [% a = [1 .. 30]; a.size %] => 30 [% a = [1 .. 30]; List.size(a) %] => 30 [% a = List.new(1 .. 30); a.size %] => 30 [% a = {a => 1, b => 2}; a.size %] => 2 [% a = {a => 1, b => 2}; Hash.size(a) %] => 2 [% a = Hash.new({a => 1, b => 2}); a.size %] => 2 [% a = Hash.new(a => 1, b => 2); a.size %] => 2 [% a = Hash.new(a = 1, b = 2); a.size %] => 2 [% a = Hash.new('a', 1, 'b', 2); a.size %] => 2 One limitation is that if you pass a key named "Text", "List", or "Hash" in your variable stash - the corresponding virtual object will be hidden. Additionally, you can use all of the Virtual object methods with the pipe operator. [% {a => 1, b => 2} | Hash.keys | List.join(", ") %] => a, b Again, there aren't any speed optimizations to using the virtual objects in Alloy, but it can help clarify the intent in some cases. Note: these aren't really objects. All of the "virtual objects" are references to the $SCALAR_OPS, $LIST_OPS, and $HASH_OPS hashes found in the $VOBJS hash of Template::Alloy. =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/lib/Template/Alloy/Velocity.pm000066400000000000000000000420411402714000200236220ustar00rootroot00000000000000package Template::Alloy::Velocity; =head1 NAME Template::Alloy::Velocity - Velocity (VTL) role =cut use strict; use warnings; use Template::Alloy; our $VERSION = $Template::Alloy::VERSION; sub new { die "This class is a role for use by packages such as Template::Alloy" } ###----------------------------------------------------------------### sub parse_tree_velocity { my $self = shift; my $str_ref = shift; if (! $str_ref || ! defined $$str_ref) { $self->throw('parse.no_string', "No string or undefined during parse", undef, 1); } local $self->{'V2EQUALS'} = $self->{'V2EQUALS'} || 0; local $self->{'INTERPOLATE'} = defined($self->{'INTERPOLATE'}) ? $self->{'INTERPOLATE'} : 1; local $self->{'V1DOLLAR'} = defined($self->{'V1DOLLAR'}) ? $self->{'V1DOLLAR'} : 1; local $self->{'ANYCASE'} = defined($self->{'ANYCASE'}) ? $self->{'ANYCASE'} : 1; local $self->{'AUTO_EVAL'} = defined($self->{'AUTO_EVAL'}) ? $self->{'AUTO_EVAL'} : 1; local $self->{'SHOW_UNDEFINED_INTERP'} = defined($self->{'SHOW_UNDEFINED_INTERP'}) ? $self->{'SHOW_UNDEFINED_INTERP'} : 1; local $self->{'START_TAG'} = qr{\#}; local $self->{'_start_tag'} = (! $self->{'INTERPOLATE'}) ? $self->{'START_TAG'} : qr{(?: $self->{'START_TAG'} | (\$))}sx; local $self->{'_end_tag'}; # changes over time local @{ $Template::Alloy::Parse::ALIASES }{qw(PARSE INCLUDE _INCLUDE ELSEIF)} = qw(PROCESS INSERT INCLUDE ELSIF); my $dirs = $Template::Alloy::Parse::DIRECTIVES; my $aliases = $Template::Alloy::Parse::ALIASES; local @{ $dirs }{ keys %$aliases } = values %$aliases; # temporarily add to the table local @{ $self }{@Template::Alloy::CONFIG_COMPILETIME} = @{ $self }{@Template::Alloy::CONFIG_COMPILETIME}; delete $dirs->{'JS'} if ! $self->{'COMPILE_JS'}; my @tree; # the parsed tree my $pointer = \@tree; # pointer to current tree to handle nested blocks my @state; # maintain block levels local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS) local $self->{'_no_interp'} = 0; # no interpolation in perl my @in_view; # let us know if we are in a view my @blocks; # storage for defined blocks my @meta; # place to store any found meta information (to go into META) my $post_chomp = 0; # previous post_chomp setting my $continue = 0; # flag for multiple directives in the same tag my $post_op = 0; # found a post-operative DIRECTIVE my $capture; # flag to start capture my $func; my $pre_chomp; my $node; my $macro_block; pos($$str_ref) = 0; while (1) { ### allow for #set(foo = PROCESS foo) if ($capture) { if ($macro_block) { $macro_block = 0; push @state, $capture; $pointer = $capture->[4] ||= []; undef $capture; next; } elsif ($$str_ref =~ m{ \G \s* (\w+)\b }gcx) { $func = $self->{'ANYCASE'} ? uc($1) : $1; $func = $aliases->{$func} if $aliases->{$func}; $self->throw('parse', "Found unknown DIRECTIVE ($func)", undef, pos($$str_ref) - length($func)) if ! $dirs->{$func}; $node = [$func, pos($$str_ref) - length($func), undef]; } else { $self->throw('parse', "Error looking for block in capture DIRECTIVE", undef, pos($$str_ref)); } push @{ $capture->[4] }, $node; undef $capture; ### handle all other } else { ### find the next opening tag $$str_ref =~ m{ \G (.*?) $self->{'_start_tag'} }gcxs || last; my ($text, $dollar) = ($1, $2); ### found a text portion - chomp it and store it if (length $text) { if (! $post_chomp) { } elsif ($post_chomp == 1) { $text =~ s{ ^ [^\S\n]* \n }{}x } elsif ($post_chomp == 2) { $text =~ s{ ^ \s+ }{ }x } elsif ($post_chomp == 3) { $text =~ s{ ^ \s+ }{}x } push @$pointer, $text if length $text; } ### handle variable interpolation ($2 eq $) if ($dollar) { ### inspect previous text chunk for escape slashes my $n = ($text =~ m{ (\\+) $ }x) ? length($1) : 0; if ($n && ! $self->{'_no_interp'}) { my $chop = int(($n + 1) / 2); # were there odd escapes substr($pointer->[-1], -$chop, $chop, '') if defined($pointer->[-1]) && ! ref($pointer->[-1]); } if ($self->{'_no_interp'} || $n % 2) { push @$pointer, $dollar; next; } my $not = $$str_ref =~ m{ \G ! }gcx; my $mark = pos($$str_ref); my $ref; if ($$str_ref =~ m{ \G \{ }gcx) { local $self->{'_operator_precedence'} = 0; # allow operators local $self->{'_end_tag'} = qr{\}}; $ref = $self->parse_expr($str_ref); $$str_ref =~ m{ \G \s* $Template::Alloy::Parse::QR_COMMENTS \} }gcxo || $self->throw('parse', 'Missing close }', undef, pos($$str_ref)); } else { local $self->{'_operator_precedence'} = 1; # no operators local $Template::Alloy::Parse::QR_COMMENTS = qr{}; $ref = $self->parse_expr($str_ref); } $self->throw('parse', "Error while parsing for interpolated string", undef, pos($$str_ref)) if ! defined $ref; if (! $not && $self->{'SHOW_UNDEFINED_INTERP'}) { $ref = [[undef, '//', $ref, '$'.substr($$str_ref, $mark, pos($$str_ref)-$mark)], 0]; } push @$pointer, ['GET', $mark, pos($$str_ref), $ref]; $post_chomp = 0; # no chomping after dollar vars next; } ### allow for escaped # my $n = ($text =~ m{ (\\+) $ }x) ? length($1) : 0; if ($n) { my $chop = int(($n + 1) / 2); # were there odd escapes substr($pointer->[-1], -$chop, $chop, '') if defined($pointer->[-1]) && ! ref($pointer->[-1]); if ($n % 2) { push @$pointer, '#'; next; } } if ($$str_ref =~ m{ \G \# .*\n? }gcx # single line comment || $$str_ref =~ m{ \G \* .*? \*\# }gcxs) { # multi-line comment next; } $$str_ref =~ m{ \G (\w+) }gcx || $$str_ref =~ m{ \G \{ (\w+) (\}) }gcx || $self->throw('parse', 'Missing directive name', undef, pos($$str_ref)); $func = $self->{'ANYCASE'} ? uc($1) : $1; ### make sure we know this directive - if we don't then allow fallback to macros (velocity allows them as directives) $func = $aliases->{$func} if $aliases->{$func}; if (! $dirs->{$func}) { my $name = $1; my $mark = pos($$str_ref) - length($func) - ($2 ? 2 : 0); my $args = 0; if ($$str_ref =~ m{ \G \( }gcx) { local $self->{'_operator_precedence'} = 0; # reset precedence $args = $self->parse_args($str_ref, {is_parened => 1}); $$str_ref =~ m{ \G \s* $Template::Alloy::Parse::QR_COMMENTS \) }gcxo || $self->throw('parse.missing.paren', "Missing close \) in directive args", undef, pos($$str_ref)); } $node = ['GET', $mark, pos($$str_ref), [$name, $args]]; push @$pointer, $node; next; #$self->throw('parse', "Found unknow DIRECTIVE ($func)", undef, pos($$str_ref) - length($func)); } $node = [$func, pos($$str_ref), undef]; if ($$str_ref =~ m{ \G \( ([+=~-]?) }gcx) { $self->{'_end_tag'} = qr{\s*([+=~-]?)\)}; $pre_chomp = $1; } else { $self->{'_end_tag'} = ''; $pre_chomp = ''; } ### take care of chomping (this is an extention to velocity $pre_chomp ||= $self->{'PRE_CHOMP'}; $pre_chomp =~ y/-=~+/1230/ if $pre_chomp; if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) { if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x } elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x } elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x } splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length } push @$pointer, $node; } $$str_ref =~ m{ \G \s+ }gcx; ### parse remaining tag details if ($func ne 'END') { $node->[3] = eval { $dirs->{$func}->[0]->($self, $str_ref, $node) }; if (my $err = $@) { $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; die $err; } $node->[2] = pos $$str_ref; } ### handle ending tags - or continuation blocks if ($func eq 'END' || $dirs->{$func}->[4]) { if (! @state) { print Data::Dumper::Dumper(\@tree); $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref)); } my $parent_node = pop @state; ### handle continuation blocks such as elsif, else, catch etc if ($dirs->{$func}->[4]) { pop @$pointer; # we will store the node in the parent instead $parent_node->[5] = $node; my $parent_type = $parent_node->[0]; if (! $dirs->{$func}->[4]->{$parent_type}) { $self->throw('parse', "Found unmatched nested block", $node, pos($$str_ref)); } } ### restore the pointer up one level (because we hit the end of a block) $pointer = (! @state) ? \@tree : $state[-1]->[4]; ### normal end block if (! $dirs->{$func}->[4]) { if ($parent_node->[0] eq 'BLOCK') { # move BLOCKS to front if (defined($parent_node->[3]) && @in_view) { push @{ $in_view[-1] }, $parent_node; } else { push @blocks, $parent_node; } if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var splice(@$pointer, -1, 1, ()); } } elsif ($parent_node->[0] eq 'VIEW') { my $ref = { map {($_->[3] => $_->[4])} @{ pop @in_view }}; unshift @{ $parent_node->[3] }, $ref; } elsif ($dirs->{$parent_node->[0]}->[5]) { # allow no_interp to turn on and off $self->{'_no_interp'}--; } ### continuation block - such as an elsif } else { push @state, $node; $pointer = $node->[4] ||= []; } $node->[2] = pos $$str_ref; ### handle block directives } elsif ($dirs->{$func}->[2]) { push @state, $node; $pointer = $node->[4] ||= []; # allow future parsed nodes before END tag to end up in current node push @in_view, [] if $func eq 'VIEW'; $self->{'_no_interp'}++ if $dirs->{$node->[0]}->[5] # allow no_interp to turn on and off } elsif ($func eq 'META') { unshift @meta, @{ $node->[3] }; # first defined win $node->[3] = undef; # only let these be defined once - at the front of the tree } ### look for the closing tag if ($$str_ref =~ m{ \G $self->{'_end_tag'} }gcxs) { $post_chomp = $1 || $self->{'POST_CHOMP'}; $post_chomp =~ y/-=~+/1230/ if $post_chomp; $continue = 0; $post_op = 0; if ($node->[6] && $node->[0] eq 'MACRO') { # allow for MACRO's without a BLOCK $capture = $node; $macro_block = 1; } next; ### setup capturing } elsif ($node->[6]) { $capture = $node; next; ### no closing tag } else { $self->throw('parse', "Not sure how to handle tag", $node, pos($$str_ref)); } } ### cleanup the tree unshift(@tree, @blocks) if @blocks; unshift(@tree, ['META', 1, 1, \@meta]) if @meta; $self->throw('parse', "Missing end tag", $state[-1], pos($$str_ref)) if @state > 0; ### pull off the last text portion - if any if (pos($$str_ref) != length($$str_ref)) { my $text = substr $$str_ref, pos($$str_ref); if (! $post_chomp) { } elsif ($post_chomp == 1) { $text =~ s{ ^ [^\S\n]* \n }{}x } elsif ($post_chomp == 2) { $text =~ s{ ^ \s+ }{ }x } elsif ($post_chomp == 3) { $text =~ s{ ^ \s+ }{}x } push @$pointer, $text if length $text; } return \@tree; } sub merge { my ($self, $in, $swap, $out) = @_; local $self->{'SYNTAX'} = $self->{'SYNTAX'} || 'velocity'; return $self->process_simple($in, $swap, $out); } ###----------------------------------------------------------------### 1; __END__ =head1 DESCRIPTION The Template::Alloy::Velocity role provides the syntax and the interface for the Velocity Templating Language (VTL). It also brings many of the features from the various templating systems. See the Template::Alloy documentation for configuration and other parameters. The following documents have more information about the velocity language. http://velocity.apache.org/engine/devel/vtl-reference-guide.html http://www.javaworld.com/javaworld/jw-12-2001/jw-1228-velocity.html?page=4 =head1 TODO Add language usage and samples. =head1 ROLE METHODS =over 4 =item C Used bh the parse_tree method when SYNTAX is set to 'velocity'. =item C Similar to process_simple, but with syntax set to velocity. =back =head1 UNSUPPORTED VELOCITY SPEC =over 4 =item The magic Java Velocity property lookups don't exist. You must use the actual method name, Alloy will not try to guess it for you. Java Velocity allows you to type $object.Attribute and Java Velocity will look for the Attribute, getAttribute, getattribute, isAttribute methods. In Perl Alloy, you can call $object.can('Attribute') to introspect the object. =item Escaping of variables is consistent. The Java Velocity spec is not. The velocity spec says that "\\$email" will return "\\$email" if email is not defined and it will return "\foo" if email is equal to "foo". The slash behavior magically changes according to the spec. In Alloy the "\\$email" would be "\$email" if email is not defined. =item You can set items to null (undefined) in Alloy. According to the Java Velocity reference-guide you have to configure Velocity to do this. To get the other behavior, you would need to do "#if($questionable)#set($foo=$questionable)#end". The default Velocity spec way provides no way for checking null return values. =item There currently isn't a "literal" directive. The VTL reference-guide doesn't mention #literal, but the user-guide does. In Alloy you can use the following: #get('#foreach($a in [1..3]) $a #end') We will probably add the literal support - but it will still have to parse the document, so unless you are using compile_perl, you will parse literal sections multiple times. =item There is no "$velocityCount" . Use "$loop.count" . =item In Alloy, excess whitespace outside of the directive matters. In the VTL user-guide it mentions that all excess whitespace is gobbled up. Alloy supports the TT chomp operators. These operators are placed just inside the open and close parenthesis of directives as in the following: #set(~ $a = 1 ~) =item In Alloy, division using "/" is always floating point. If you want integer division, use "div". In Java Velocity, "/" division is integer only if both numbers are integers. =item Perl doesn't support negative ranges. However, arrays do have the reverse method. #foreach( $bar in [-2 .. 2].reverse ) $bar #end =item In Alloy arguments to macros are passed by value, not by name. This is easy to achieve with alloy - simply encase your arguments in single quotes and then eval the argument inside the macro. The velocity people claim this feature as a jealously guarded feature. My first template system "WrapEx" had the same feature. It happened as an accident. It represents lazy software architecture and is difficult to optimize. =back =head1 AUTHOR Paul Seamons =head1 LICENSE This module may be distributed under the same terms as Perl itself. =cut libtemplate-alloy-perl-1.022/samples/000077500000000000000000000000001402714000200175305ustar00rootroot00000000000000libtemplate-alloy-perl-1.022/samples/benchmark/000077500000000000000000000000001402714000200214625ustar00rootroot00000000000000libtemplate-alloy-perl-1.022/samples/benchmark/bench_method_calling.pl000077500000000000000000000036031402714000200261340ustar00rootroot00000000000000#!/usr/bin/perl -w use strict; use Benchmark qw(cmpthese); use CGI::Ex::Dump qw(debug); my $n = 500_000; { package A; our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my $meth = ($AUTOLOAD =~ /::(\w+)$/) ? $1 : die "Bad method $AUTOLOAD"; die "Unknown property $meth" if ! exists $self->{$meth}; if ($#_ != -1) { $self->{$meth} = shift; } else { return $self->{$meth} } } sub DETROY {} } { package B; sub add_property { my $self = shift; my $prop = shift; no strict 'refs'; * {"B::$prop"} = sub { my $self = shift; if ($#_ != -1) { $self->{$prop} = shift; } else { return $self->{$prop}; } }; $self->$prop(@_) if $#_ != -1; } } { package C; sub add_property { my $self = shift; my $prop = shift; no strict 'refs'; my $name = __PACKAGE__ ."::". $prop; *$name = sub : lvalue { my $self = shift; $self->{$prop} = shift() if $#_ != -1; $self->{$prop}; } if ! defined &$name; $self->$prop() = shift() if $#_ != -1; } } my $a = bless {}, 'A'; $a->{foo} = 1; #debug $a->foo(); #$a->foo(2); #debug $a->foo(); my $b = bless {}, 'B'; $b->add_property('foo', 1); #debug $b->foo(); #$b->foo(2); #debug $b->foo(); my $c = bless {}, 'C'; $c->add_property('foo', 1); #debug $c->foo(); #$c->foo(2); #debug $c->foo(); my $d = bless {}, 'C'; $d->add_property('foo', 1); #debug $d->foo(); #$d->foo = 2; #debug $d->foo(); use constant do_set => 1; cmpthese($n, { autoloadonly => sub { my $v = $a->foo(); if (do_set) { $a->foo(2); } }, addproperty => sub { my $v = $b->foo(); if (do_set) { $b->foo(2); } }, addproperty_withlvalue => sub { my $v = $c->foo(); if (do_set) { $c->foo(2); } }, addproperty_withlvalue2 => sub { my $v = $d->foo(); if (do_set) { $d->foo = 2; } }, }); libtemplate-alloy-perl-1.022/samples/benchmark/bench_operator_storage.pl000066400000000000000000000064441402714000200265450ustar00rootroot00000000000000#!/usr/bin/perl -w =head1 NAME bench_operator_storage.pl - Look at different ways of storing operators and how to call them =cut use strict; use Benchmark qw(cmpthese timethese); use CGI::Ex::Dump qw(debug); use constant skip_execute => 1; my $total_size = eval { require Devel::Size } ? sub { Devel::Size::total_size($_[0]) } : sub { "Skip Devel::Size check" }; ###----------------------------------------------------------------### ### check basic setting speed - almost irrelvant as we are in the 300_000's my $set_w_ref = sub { my $s = [ \ [ '+', 4, 5], 0] }; my $set_undef = sub { my $s = [ [undef, '+', 4, 5], 0] }; my $set_array = sub { my $s = [ [[ '+', 4, 5]], 0] }; my $set_arra2 = sub { my $s = [ [[], '+', 4, 5], 0] }; my $set_bless = sub { my $s = [ bless([ '+', 4, 5],'CGI::Ex::Template::Op::foo'), 0] }; print "Set_w_ref size: ". $total_size->($set_w_ref->()) ."\n"; print "Set_undef size: ". $total_size->($set_undef->()) ."\n"; print "Set_array size: ". $total_size->($set_array->()) ."\n"; print "Set_arra2 size: ". $total_size->($set_arra2->()) ."\n"; print "Set_bless size: ". $total_size->($set_bless->()) ."\n"; cmpthese timethese -1, { set_w_ref => $set_w_ref, set_undef => $set_undef, set_array => $set_array, set_arra2 => $set_arra2, set_bless => $set_bless, }; ###----------------------------------------------------------------### ### time basic variable checking my $check_w_ref = sub { my $s = shift; if (ref $s eq 'REF') { $s = $$s->[0] eq '..' ? 1 : 2; } else { $s = 0; } }; my $check_undef = sub { my $s = shift; if (! defined $s->[0]) { $s = $s->[1] eq '..' ? 1 : 2; } else { $s = 0; } }; cmpthese timethese -1, { w_ref_pos => sub { $check_w_ref->(\ ['+', 4, 5]) }, w_ref_dots => sub { $check_w_ref->(\ ['..', 4, 5]) }, w_ref_neg => sub { $check_w_ref->(['a', 0]) }, undef_pos => sub { $check_undef->([undef, '+', 4, 5]) }, undef_dots => sub { $check_undef->([undef, '..', 4, 5]) }, undef_neg => sub { $check_undef->(['a', 0]) }, }; ###----------------------------------------------------------------### ### check for calling speed my $play_w_ref = sub { my $tree = shift; my $op = $tree->[0]; my @args = ($tree->[1], $tree->[2]); }; my $play_undef = sub { my $tree = shift; my $op = $tree->[1]; my @args = ($tree->[2], $tree->[3]); }; my $play_undef2 = sub { my $op = shift; my @args = @_; }; my $call_w_ref = sub { my $s = shift; return $play_w_ref->($$s); }; my $call_undef = sub { my $s = shift; return $play_undef->($s); }; my $call_undef2 = sub { my $s = shift; return $play_undef2->(@$s[1..$#$s]); }; cmpthese timethese -1, { small_w_ref => sub { $call_w_ref->(\ ['~', 1 .. 2]) }, med___w_ref => sub { $call_w_ref->(\ ['~', 1 .. 200]) }, large_w_ref => sub { $call_w_ref->(\ ['~', 1 .. 2000]) }, small_undef => sub { $call_undef->([undef, '~', 1 .. 2]) }, med___undef => sub { $call_undef->([undef, '~', 1 .. 200]) }, large_undef => sub { $call_undef->([undef, '~', 1 .. 2000]) }, small_undef2 => sub { $call_undef2->([undef, '~', 1 .. 2]) }, med___undef2 => sub { $call_undef2->([undef, '~', 1 .. 200]) }, large_undef2 => sub { $call_undef2->([undef, '~', 1 .. 2000]) }, }; libtemplate-alloy-perl-1.022/samples/benchmark/bench_optree.pl000066400000000000000000000623711402714000200244650ustar00rootroot00000000000000#!/usr/bin/perl -w =head1 NAME bench_optree.pl - Look at different ways of storing data that transform fast. =cut use strict; use Benchmark qw(cmpthese timethese); use CGI::Ex::Dump qw(debug); use constant skip_execute => 1; #my $obj = bless [1, 2], __PACKAGE__; #my $struct1 = \ [ '-', 1, 2 ]; #my $struct2 = ['-', 1, 2]; # #sub call { $_[0]->[0] - $_[0]->[1] } # #sub obj_meth { $obj->call } #sub ref_type { if (ref($struct1) eq 'REF') { if (${$struct1}->[0] eq '-') { ${$struct1}->[1] - ${$struct1}->[2] } } } # #print "(".obj_meth().")\n"; #print "(".ref_type().")\n"; #cmpthese timethese(-2, { # obj_meth => \&obj_meth, # ref_type => \&ref_type, #}, 'auto'); ###----------------------------------------------------------------### ### setup a new way of storing and executing the variable tree sub get_var2 { ref($_[1]) ? $_[1]->call($_[0]) : $_[1] } { package Num; sub new { my $c = shift; bless \@_, $c }; sub call { $_[0]->[0] } package A::B; sub new { my $c = shift; bless \@_, $c } # sub new { my $c = shift; bless [map{ref$_?$_:Num->new($_)} @_], $c } package A::B::Minus; our @ISA = qw(A::B); sub call { $_[1]->get_var2($_[0]->[0]) - $_[1]->get_var2($_[0]->[1]) } package A::B::Plus; our @ISA = qw(A::B); sub call { $_[1]->get_var2($_[0]->[0]) + $_[1]->get_var2($_[0]->[1]) } package A::B::Mult; our @ISA = qw(A::B); sub call { $_[1]->get_var2($_[0]->[0]) * $_[1]->get_var2($_[0]->[1]) } package A::B::Div; our @ISA = qw(A::B); sub call { $_[1]->get_var2($_[0]->[0]) / $_[1]->get_var2($_[0]->[1]) } package A::B::Var; our @ISA = qw(A::B); our $HASH_OPS = $CGI::Ex::Template::HASH_OPS; our $LIST_OPS = $CGI::Ex::Template::LIST_OPS; our $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS; our $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS; our $OP_FUNC = $CGI::Ex::Template::OP_FUNC; use constant trace => 0; sub call { my $var = shift; my $self = shift; my $ARGS = shift || {}; my $i = 0; my $generated_list; ### determine the top level of this particular variable access my $ref = $var->[$i++]; my $args = $var->[$i++]; warn "get_variable: begin \"$ref\"\n" if trace; if (defined $ref) { if ($ARGS->{'is_namespace_during_compile'}) { $ref = $self->{'NAMESPACE'}->{$ref}; } else { return if $ref =~ /^[_.]/; # don't allow vars that begin with _ $ref = $self->{'_vars'}->{$ref}; } } my %seen_filters; while (defined $ref) { ### check at each point if the returned thing was a code if (UNIVERSAL::isa($ref, 'CODE')) { my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); if (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { $ref = undef; last; } } ### descend one chained level last if $i >= $#$var; my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; my $name = $var->[$i++]; my $args = $var->[$i++]; warn "get_variable: nested \"$name\"\n" if trace; ### allow for named portions of a variable name (foo.$name.bar) if (ref $name) { $name = $name->call($self); if (! defined($name) || $name =~ /^[_.]/) { $ref = undef; last; } } if ($name =~ /^_/) { # don't allow vars that begin with _ $ref = undef; last; } ### allow for scalar and filter access (this happens for every non virtual method call) if (! ref $ref) { if ($SCALAR_OPS->{$name}) { # normal scalar op $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ()); } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args || $FILTER_OPS->{$name} # predefined filters in CET || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash || $self->list_filters->{$name}) { # filter defined in Template::Filters if (UNIVERSAL::isa($filter, 'CODE')) { $ref = eval { $filter->($ref) }; # non-dynamic filter - no args if (my $err = $@) { $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters eval { my $sub = $filter->[0]; if ($filter->[1]) { # it is a "dynamic filter" that will return a sub ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ()); if (! $sub && $err) { $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } elsif (! UNIVERSAL::isa($sub, 'CODE')) { $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") if ref($sub) !~ /Template::Exception$/; die $sub; } } $ref = $sub->($ref); }; if (my $err = $@) { $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree $i = 2; } if (scalar keys %seen_filters && $seen_filters{$var->[$i - 5] || ''}) { $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); } } else { $ref = undef; } } else { ### method calls on objects if (UNIVERSAL::can($ref, 'can')) { my @args = $args ? @{ $self->vivify_args($args) } : (); my @results = eval { $ref->$name(@args) }; if ($@) { die $@ if ref $@ || $@ !~ /Can\'t locate object method/; } elsif (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; next; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { $ref = undef; last; } # didn't find a method by that name - so fail down to hash and array access } ### hash member access if (UNIVERSAL::isa($ref, 'HASH')) { if ($was_dot_call && exists($ref->{$name}) ) { $ref = $ref->{$name}; } elsif ($HASH_OPS->{$name}) { $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); } elsif ($ARGS->{'is_namespace_during_compile'}) { return $var; # abort - can't fold namespace variable } else { $ref = undef; } ### array access } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { if ($name =~ /^\d+$/) { $ref = ($name > $#$ref) ? undef : $ref->[$name]; } else { $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); } } } } # end of while ### allow for undefinedness if (! defined $ref) { if ($self->{'_debug_undef'}) { my $chunk = $var->[$i - 2]; $chunk = $chunk->call($self) if ref $chunk; die "$chunk is undefined\n"; } else { $ref = $self->undefined_any($var); } } ### allow for special behavior for the '..' operator if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') { return @$ref; } return $ref; } }; sub plus ($$) { A::B::Plus->new( @_) } sub minus ($$) { A::B::Minus->new(@_) } sub mult ($$) { A::B::Mult->new( @_) } sub div ($$) { A::B::Div->new( @_) } sub var { A::B::Var->new( @_) }; $INC{'A/B.pm'} = 1; $INC{'A/B/Plus.pm'} = 1; $INC{'A/B/Minus.pm'} = 1; $INC{'A/B/Mult.pm'} = 1; $INC{'A/B/Div.pm'} = 1; $INC{'A/B/Var.pm'} = 1; ###----------------------------------------------------------------### ### now benchmark the different variable storage methods my $vars = { foo => {bar => {baz => [qw(a b c)]}}, bing => 'bang', }; my $self = bless {'_vars' => $vars}, __PACKAGE__; #pauls@pslaptop:~/perl/CGI-Ex/lib$ perl -e 'my $a = "1 + 2 * (3 + (4 / 5) * 9) - 20"; # use CGI::Ex::Template; # use Data::Dumper; # print Dumper(CGI::Ex::Template->new->parse_variable(\$a));' ###----------------------------------------------------------------### my $Y0 = '$self->{_vars}->{bing}'; my $Y1 = [ 'bing', 0 ]; my $Y2 = var('bing', 0); debug $Y2; ### are they all the same print eval($Y0)."\n"; print $self->get_variable($Y1)."\n"; print $self->get_var2($Y2)."\n"; if (! skip_execute) { cmpthese timethese (-2, { perl => sub { eval $Y0 }, bare_data => sub { $self->get_variable($Y1) }, method_call => sub { $self->get_var2($Y2) }, }, 'auto'); } ###----------------------------------------------------------------### my $Z0 = '$self->{_vars}->{foo}->{bar}->{baz}->[1]'; my $Z1 = [ 'foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0]; my $Z2 = var('foo', 0, '.', 'bar', 0, '.', 'baz', 0, '.', 1, 0); debug $Z2; ### are they all the same print eval($Z0)."\n"; print $self->get_variable($Z1)."\n"; print $self->get_var2($Z2)."\n"; if (! skip_execute) { cmpthese timethese (-2, { perl => sub { eval $Z0 }, bare_data => sub { $self->get_variable($Z1) }, method_call => sub { $self->get_var2($Z2) }, }, 'auto'); } ###----------------------------------------------------------------### ### $A0 = perl, $A1 = old optree, $A2 = new optree my $A0 = "1 + 2 * (3 + (4 / 5) * 9) - 20"; my $A1 = [ \[ '-', [ \[ '+', '1', [ \[ '*', '2', [ \[ '+', '3', [ \[ '*', [ \[ '/', '4', '5' ], 0 ], '9' ], 0 ] ], 0 ] ], 0 ] ], 0 ], '20' ], 0 ]; my $A2 = minus(plus(1, mult(2, plus(3, mult(div(4,5), 9)))), 20); debug $A2; ### are they all the same print eval($A0)."\n"; print $self->get_variable($A1)."\n"; print $self->get_var2($A2)."\n"; if (! skip_execute) { cmpthese timethese (-2, { perl => sub { eval $A0 }, bare_data => sub { $self->get_variable($A1) }, method_call => sub { $self->get_var2($A2) }, }, 'auto'); } ###----------------------------------------------------------------### my $B0 = "1 + 2"; my $B1 = [ \[ '+', 1, 2] ]; my $B2 = plus(1, 2); debug $B2; ### are they all the same print eval($B0)."\n"; print $self->get_variable($B1)."\n"; print $self->get_var2($B2)."\n"; if (! skip_execute) { cmpthese timethese (-2, { perl => sub { eval $B0 }, bare_data => sub { $self->get_variable($B1) }, method_call => sub { $self->get_var2($B2) }, }, 'auto'); } ###----------------------------------------------------------------### ### Test (de)serialization speed use Storable; my $d1 = Storable::freeze($A1); my $d2 = Storable::freeze($A2); Storable::thaw($d1); # load lib print length($d1)."\n"; print length($d2)."\n"; cmpthese timethese (-2, { freeze_bare => sub { Storable::freeze($A1) }, freeze_meth => sub { Storable::freeze($A2) }, }, 'auto'); cmpthese timethese (-2, { thaw_bare => sub { Storable::thaw($d1) }, thaw_meth => sub { Storable::thaw($d2) }, }, 'auto'); ###----------------------------------------------------------------### ### create libraries similar to those from CGI::Ex::Template 1.201 use CGI::Ex::Template; our $HASH_OPS = $CGI::Ex::Template::HASH_OPS; our $LIST_OPS = $CGI::Ex::Template::LIST_OPS; our $SCALAR_OPS = $CGI::Ex::Template::SCALAR_OPS; our $FILTER_OPS = $CGI::Ex::Template::FILTER_OPS; our $OP_FUNC = $CGI::Ex::Template::OP_FUNC; use constant trace => 0; sub get_variable { ### allow for the parse tree to store literals return $_[1] if ! ref $_[1]; my $self = shift; my $var = shift; my $ARGS = shift || {}; my $i = 0; my $generated_list; ### determine the top level of this particular variable access my $ref = $var->[$i++]; my $args = $var->[$i++]; warn "get_variable: begin \"$ref\"\n" if trace; if (ref $ref) { if (ref($ref) eq 'SCALAR') { # a scalar literal $ref = $$ref; } elsif (ref($ref) eq 'REF') { # operator return $self->play_operator($$ref) if ${ $ref }->[0] eq '\\'; # return the closure $generated_list = 1 if ${ $ref }->[0] eq '..'; $ref = $self->play_operator($$ref); } else { # a named variable access (ie via $name.foo) $ref = $self->get_variable($ref); if (defined $ref) { return if $ref =~ /^[_.]/; # don't allow vars that begin with _ $ref = $self->{'_vars'}->{$ref}; } } } elsif (defined $ref) { if ($ARGS->{'is_namespace_during_compile'}) { $ref = $self->{'NAMESPACE'}->{$ref}; } else { return if $ref =~ /^[_.]/; # don't allow vars that begin with _ $ref = $self->{'_vars'}->{$ref}; } } my %seen_filters; while (defined $ref) { ### check at each point if the returned thing was a code if (UNIVERSAL::isa($ref, 'CODE')) { my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); if (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { $ref = undef; last; } } ### descend one chained level last if $i >= $#$var; my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; my $name = $var->[$i++]; my $args = $var->[$i++]; warn "get_variable: nested \"$name\"\n" if trace; ### allow for named portions of a variable name (foo.$name.bar) if (ref $name) { if (ref($name) eq 'ARRAY') { $name = $self->get_variable($name); if (! defined($name) || $name =~ /^[_.]/) { $ref = undef; last; } } else { die "Shouldn't get a ". ref($name) ." during a vivify on chain"; } } if ($name =~ /^_/) { # don't allow vars that begin with _ $ref = undef; last; } ### allow for scalar and filter access (this happens for every non virtual method call) if (! ref $ref) { if ($SCALAR_OPS->{$name}) { # normal scalar op $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ()); } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args || $FILTER_OPS->{$name} # predefined filters in CET || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash || $self->list_filters->{$name}) { # filter defined in Template::Filters if (UNIVERSAL::isa($filter, 'CODE')) { $ref = eval { $filter->($ref) }; # non-dynamic filter - no args if (my $err = $@) { $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters eval { my $sub = $filter->[0]; if ($filter->[1]) { # it is a "dynamic filter" that will return a sub ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ()); if (! $sub && $err) { $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } elsif (! UNIVERSAL::isa($sub, 'CODE')) { $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)") if ref($sub) !~ /Template::Exception$/; die $sub; } } $ref = $sub->($ref); }; if (my $err = $@) { $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree $i = 2; } if (scalar keys %seen_filters && $seen_filters{$var->[$i - 5] || ''}) { $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)"); } } else { $ref = undef; } } else { ### method calls on objects if (UNIVERSAL::can($ref, 'can')) { my @args = $args ? @{ $self->vivify_args($args) } : (); my @results = eval { $ref->$name(@args) }; if ($@) { die $@ if ref $@ || $@ !~ /Can\'t locate object method/; } elsif (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; next; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { $ref = undef; last; } # didn't find a method by that name - so fail down to hash and array access } ### hash member access if (UNIVERSAL::isa($ref, 'HASH')) { if ($was_dot_call && exists($ref->{$name}) ) { $ref = $ref->{$name}; } elsif ($HASH_OPS->{$name}) { $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); } elsif ($ARGS->{'is_namespace_during_compile'}) { return $var; # abort - can't fold namespace variable } else { $ref = undef; } ### array access } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { if ($name =~ /^\d+$/) { $ref = ($name > $#$ref) ? undef : $ref->[$name]; } else { $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); } } } } # end of while ### allow for undefinedness if (! defined $ref) { if ($self->{'_debug_undef'}) { my $chunk = $var->[$i - 2]; $chunk = $self->get_variable($chunk) if ref($chunk) eq 'ARRAY'; die "$chunk is undefined\n"; } else { $ref = $self->undefined_any($var); } } ### allow for special behavior for the '..' operator if ($generated_list && $ARGS->{'list_context'} && ref($ref) eq 'ARRAY') { return @$ref; } return $ref; } sub vivify_args { my $self = shift; my $vars = shift; my $args = shift || {}; return [map {$self->get_variable($_, $args)} @$vars]; } sub play_operator { my $self = shift; my $tree = shift; my $ARGS = shift || {}; my $op = $tree->[0]; $tree = [@$tree[1..$#$tree]]; ### allow for operator function override if (exists $OP_FUNC->{$op}) { return $OP_FUNC->{$op}->($self, $op, $tree, $ARGS); } ### do constructors and short-circuitable operators if ($op eq '~' || $op eq '_') { return join "", grep {defined} @{ $self->vivify_args($tree) }; } elsif ($op eq 'arrayref') { return $self->vivify_args($tree, {list_context => 1}); } elsif ($op eq 'hashref') { my $args = $self->vivify_args($tree); push @$args, undef if ! ($#$args % 2); return {@$args}; } elsif ($op eq '?') { if ($self->get_variable($tree->[0])) { return defined($tree->[1]) ? $self->get_variable($tree->[1]) : undef; } else { return defined($tree->[2]) ? $self->get_variable($tree->[2]) : undef; } } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') { for my $node (@$tree) { my $var = $self->get_variable($node); return $var if $var; } return ''; } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') { my $var; for my $node (@$tree) { $var = $self->get_variable($node); return 0 if ! $var; } return $var; } elsif ($op eq '!') { my $var = ! $self->get_variable($tree->[0]); return defined($var) ? $var : ''; } ### equality operators local $^W = 0; my $n = $self->get_variable($tree->[0]); $tree = [@$tree[1..$#$tree]]; if ($op eq '==') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 } elsif ($op eq '!=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 } elsif ($op eq 'eq') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n eq $_) }; return 1 } elsif ($op eq 'ne') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ne $_) }; return 1 } elsif ($op eq '<') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n < $_); $n = $_ }; return 1 } elsif ($op eq '>') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n > $_); $n = $_ }; return 1 } elsif ($op eq '<=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n <= $_); $n = $_ }; return 1 } elsif ($op eq '>=') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n >= $_); $n = $_ }; return 1 } elsif ($op eq 'lt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n lt $_); $n = $_ }; return 1 } elsif ($op eq 'gt') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n gt $_); $n = $_ }; return 1 } elsif ($op eq 'le') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n le $_); $n = $_ }; return 1 } elsif ($op eq 'ge') { for (@$tree) { $_ = $self->get_variable($_); return '' if ! ($n ge $_); $n = $_ }; return 1 } ### numeric operators my $args = $self->vivify_args($tree); if (! @$args) { if ($op eq '-') { return - $n } $self->throw('operator', "Not enough args for operator \"$op\""); } if ($op eq '..') { return [($n || 0) .. ($args->[-1] || 0)] } elsif ($op eq '+') { $n += $_ for @$args; return $n } elsif ($op eq '-') { $n -= $_ for @$args; return $n } elsif ($op eq '*') { $n *= $_ for @$args; return $n } elsif ($op eq '/') { $n /= $_ for @$args; return $n } elsif ($op eq 'div' || $op eq 'DIV') { $n = int($n / $_) for @$args; return $n } elsif ($op eq '%' || $op eq 'mod' || $op eq 'MOD') { $n %= $_ for @$args; return $n } elsif ($op eq '**' || $op eq 'pow') { $n **= $_ for @$args; return $n } $self->throw('operator', "Un-implemented operation $op"); } libtemplate-alloy-perl-1.022/samples/benchmark/bench_template.pl000066400000000000000000000407071402714000200250010ustar00rootroot00000000000000#!/usr/bin/perl -w =head1 NAME bench_template.pl - Test relative performance of Template::Alloy to Template::Toolkit =cut use strict; use Benchmark qw(cmpthese timethese); use POSIX qw(tmpnam); use File::Path qw(rmtree); use Template::Alloy; use CGI::Ex::Dump qw(debug); use Template; use constant test_taint => 0 && eval { require Taint::Runtime }; # s/0/1/ to check tainting Taint::Runtime::taint_start() if test_taint; my $tt_cache_dir = tmpnam; END { rmtree $tt_cache_dir }; mkdir $tt_cache_dir, 0755; my $swap = { one => "ONE", a_var => "a", foo => '[% bar %]', bar => "baz", hash => {a => 1, b => 2, c => { d => [{hee => ["hmm"]}] }}, array => [qw(A B C D E a A)], code => sub {"(@_)"}, filt => sub {sub {$_[0]x2}}, }; use Template::Stash;; my $s = Template::Stash->new($swap); #use Template::Stash::XS; #$s = Template::Stash::XS->new($swap); ###----------------------------------------------------------------### ### get objects ready my @config1 = (STASH => $s, ABSOLUTE => 1, CONSTANTS => {simple => 'var'}, EVAL_PERL => 1, INCLUDE_PATH => $tt_cache_dir); #push @config1, (INTERPOLATE => 1); my @config2 = (@config1, COMPILE_EXT => '.ttc'); my $tt1 = Template->new(@config1); my $tap = Template::Alloy->new(@config1, COMPILE_PERL => 1); #use Template::Alloy::XS; #my $tt1 = Template::Alloy::XS->new(@config1); #my $tap = Template::Alloy::XS->new(@config1, COMPILE_PERL => 1); #$swap->{$_} = $_ for (1 .. 1000); # swap size affects benchmark speed ###----------------------------------------------------------------### ### write out some file to be used later my $fh; my $bar_template = "$tt_cache_dir/bar.tt"; END { unlink $bar_template }; open($fh, ">$bar_template") || die "Couldn't open $bar_template: $!"; print $fh "BAR"; close $fh; my $baz_template = "$tt_cache_dir/baz.tt"; END { unlink $baz_template }; open($fh, ">$baz_template") || die "Couldn't open $baz_template: $!"; print $fh "[% SET baz = 42 %][% baz %][% bing %]"; close $fh; my $longer_template = "[% INCLUDE bar.tt %]" ."[% array.join('|') %]" .("123"x200) ."[% FOREACH a IN array %]foobar[% IF a == 'A' %][% INCLUDE baz.tt %][% END %]bazbing[% END %]" .("456"x200) ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]" .("789"x200) ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]" .("012"x200) ."[% IF foo ; bar ; ELSIF baz ; bing ; ELSE ; bong ; END %]" ."[% array.join('|') %]" ."[% PROCESS bar.tt %]"; my $hello2000 = "[% title %] [% array = [ \"Hello\", \"World\", \"2000\", \"Hello\", \"World\", \"2000\" ] %] [% sorted = array.sort %] [% multi = [ sorted, sorted, sorted, sorted, sorted ] %] [% FOREACH row = multi %] [% FOREACH col = row %] [% END %] [% END %]
[% col %]
[% param = integer %] [% FOREACH i = [ 1 .. 10 ] %] [% var = i + param %]" .("\n [%var%] Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
"x20)." [% END %] "; ###----------------------------------------------------------------### ### set a few globals that will be available in our subs my $show_list = grep {$_ eq '--list'} @ARGV; my $run_all = grep {$_ eq '--all'} @ARGV; my @run = $run_all ? () : @ARGV; my $str_ref; my $filename; ### uncomment to run a specific test - otherwise all tests run #@run = qw(07); # ### All percents are Template::Alloy vs TT2 # ### (The percent that Alloy is faster than TT) # Existing object by string ref # # New object with CACHE_EXT set # # # New object each time (undef CACHE_SIZE) # # # # This percent is compiled in memory (repeated calls) # # # # my $tests = { # # # # # '01_empty' => "", # 157% # 357% # 318% # 386% # 17173.6/s # '02_var_sma' => "[% one %]", # 131% # 361% # 359% # 709% # 14022.8/s # '03_var_lar' => "[% one %]"x100, # 33% # 238% # 61% # 1694% # 1046.3/s # '04_set_sma' => "[% SET one = 2 %]", # 142% # 311% # 331% # 889% # 14614.1/s # '05_set_lar' => "[% SET one = 2 %]"x100, # 66% # 172% # 22% # 3621% # 1436.4/s # '06_set_range' => "[% SET one = [0..30] %]", # 72% # 223% # 246% # 648% # 9774.1/s # '07_chain_sm' => "[% hash.a %]", # 138% # 376% # 336% # 786% # 13001.4/s # '08_mixed_sma' => "".((" "x100)."[% one %]\n")x10, # 81% # 333% # 216% # 1617% # 6483.7/s # '09_mixed_med' => "".((" "x10)."[% one %]\n")x100, # 35% # 306% # 97% # 2156% # 1017.8/s # '10_str_sma' => "".("[% \"".(" "x100)."\$one\" %]\n")x10, # -19% # 1345% # 95% # 4956% # 2873.3/s # '11_str_lar' => "".("[% \"".(" "x10)."\$one\" %]\n")x100, # -50% # 325% # 2% # 1218% # 370.4/s # '12_num_lterl' => "[% 2 %]", # 150% # 346% # 362% # 755% # 16365.4/s # '13_plus' => "[% 1 + 2 %]", # 100% # 304% # 318% # 691% # 13031.8/s # '14_chained' => "[% c.d.0.hee.0 %]", # 117% # 399% # 314% # 891% # 12271.8/s # '15_chain_set' => "[% SET c.d.0.hee.0 = 2 %]", # 120% # 327% # 292% # 924% # 10048.1/s # '16_chain_lar' => "[% c.d.0.hee.0 %]"x100, # -2% # 379% # 54% # 1880% # 520.7/s # '17_chain_sl' => "[% SET c.d.0.hee.0 = 2 %]"x100, # 99% # 257% # 72% # 1663% # 354.2/s # '18_cplx_comp' => "[% t = 1 || 0 ? 0 : 1 || 2 ? 2 : 3 %][% t %]", # 66% # 199% # 233% # 1090% # 9359.2/s # '19_if_sim_t' => "[% a=1 %][% IF a %]Two[% END %]", # 126% # 306% # 299% # 1145% # 12739.3/s # '20_if_sim_f' => " [% IF a %]Two[% END %]", # 137% # 377% # 314% # 935% # 13652.8/s # '21_if_else' => "[% IF a %]A[% ELSE %]B[% END %]", # 134% # 383% # 314% # 1061% # 13651.9/s # '22_if_elsif' => "[% IF a %]A[% ELSIF b %]B[% ELSE %]C[% END %]", # 109% # 346% # 276% # 1179% # 11572.2/s # '23_for_i_sml' => "[% FOREACH i = [0..10] ; i ; END %]", # 43% # 156% # 138% # 348% # 3258.5/s # '24_for_i_med' => "[% FOREACH i = [0..100] ; i ; END %]", # 7% # 27% # 12% # 56% # 506.4/s # '25_for_sml' => "[% FOREACH [0..10] ; i ; END %]", # 41% # 161% # 142% # 341% # 3163.9/s # '26_for_med' => "[% FOREACH [0..100] ; i ; END %]", # 19% # 35% # 18% # 71% # 509.1/s # '27_while' => "[% f = 10 %][%WHILE f%][%f=f- 1%][%f%][% END %]", # 14% # 143% # 73% # 262% # 1848.0/s # '28_whl_set_l' => "[% f = 10; WHILE (g=f) ; f = f - 1 ; f ; END %]", # 4% # 105% # 58% # 190% # 1420.1/s # '29_whl_set_s' => "[% f = 1; WHILE (g=f) ; f = f - 1 ; f ; END %]", # 55% # 201% # 190% # 891% # 6351.0/s # '30_file_proc' => "[% PROCESS bar.tt %]", # 171% # 345% # 331% # 638% # 9388.6/s # '31_file_incl' => "[% INCLUDE baz.tt %]", # 122% # 274% # 238% # 432% # 6426.3/s # '32_process' => "[% BLOCK foo %]Hi[% END %][% PROCESS foo %]", # 118% # 339% # 295% # 928% # 9431.1/s # '33_include' => "[% BLOCK foo %]Hi[% END %][% INCLUDE foo %]", # 106% # 322% # 286% # 802% # 8298.5/s # '34_macro' => "[% MACRO foo BLOCK %]Hi[% END %][% foo %]", # 91% # 194% # 241% # 793% # 8881.4/s # '35_macro_arg' => "[% MACRO foo(n) BLOCK %]Hi[%n%][%END%][%foo(2)%]", # 70% # 189% # 223% # 899% # 7111.7/s # '36_macro_pro' => "[% MACRO foo PROCESS bar;BLOCK bar%]7[%END;foo%]", # 79% # 211% # 255% # 793% # 6189.0/s # '37_filter2' => "[% n = 1 %][% n | repeat(2) %]", # 126% # 317% # 297% # 1173% # 11058.5/s # '38_filter' => "[% n = 1 %][% n FILTER repeat(2) %]", # 99% # 252% # 257% # 995% # 9657.4/s # '39_fltr_name' => "[% n=1; n FILTER echo=repeat(2); n FILTER echo%]", # 47% # 239% # 194% # 912% # 6633.8/s # '40_constant' => "[% constants.simple %]", # 167% # 359% # 360% # 1060% # 16677.6/s # '41_perl' => "[%one='ONE'%][% PERL %]print \"[%one%]\"[%END%]", # 63% # 297% # 239% # 827% # 7242.2/s # '42_filtervar' => "[% 'hi' | \$filt %]", # 55% # 352% # 272% # 607% # 8618.4/s # '43_filteruri' => "[% ' ' | uri %]", # 76% # 360% # 277% # 689% # 10118.0/s # '44_filterevl' => "[% foo | eval %]", # 367% # 319% # 334% # 752% # 6482.5/s # '45_capture' => "[% foo = BLOCK %]Hi[% END %][% foo %]", # 120% # 270% # 260% # 1002% # 12199.6/s # '46_refs' => "[% b = \\code(1); b(2) %]", # 33% # 201% # 175% # 545% # 6132.4/s # '47_complex' => "$longer_template", # 62% # 194% # 136% # 790% # 1302.9/s # '48_hello2000' => "$hello2000", # 29% # 145% # 40% # 303% # 251.9/s # # overall # 86% # 291% # 214% # 999% # # With Stash::XS #'47_complex' => "$longer_template", # 15% # 184% # 100% # 12% # 1952.5/s # #'48_hello2000' => "$hello2000", # 28% # 104% # -12% # 29% # 574.0/s # ## overall # 15% # 277% # 186% # 15% # }; ### load the code representation my $text = {}; seek DATA, 0, 0; my $data = do { local $/ = undef; }; foreach my $key (keys %$tests) { $data =~ m/(.*\Q$key\E.*)/ || next; $text->{$key} = $1; } if ($show_list) { foreach my $text (sort values %$text) { print "$text\n"; } exit; } my $run = join("|", @run); @run = grep {/$run/} sort keys %$tests; ###----------------------------------------------------------------### sub file_TT_new { my $out = ''; my $t = Template->new(@config1); $t->process($filename, $swap, \$out); return $out; } sub str_TT_new { my $out = ''; my $t = Template->new(@config1); $t->process($str_ref, $swap, \$out); return $out; } sub file_TT { my $out = ''; $tt1->process($filename, $swap, \$out); return $out; } sub str_TT { my $out = ''; $tt1->process($str_ref, $swap, \$out) || debug $tt1->error; return $out; } sub file_TT_cache_new { my $out = ''; my $t = Template->new(@config2); $t->process($filename, $swap, \$out); return $out; } ###----------------------------------------------------------------### sub file_Alloy_new { my $out = ''; my $t = Template::Alloy->new(@config1); $t->process($filename, $swap, \$out); return $out; } sub str_Alloy_new { my $out = ''; my $t = Template::Alloy->new(@config1); $t->process($str_ref, $swap, \$out); return $out; } sub file_Alloy { my $out = ''; $tap->process($filename, $swap, \$out); return $out; } sub str_Alloy { my $out = ''; $tap->process($str_ref, $swap, \$out); return $out; } sub file_Alloy_cache_new { my $out = ''; my $t = Template::Alloy->new(@config2); $t->process($filename, $swap, \$out); return $out; } ###----------------------------------------------------------------### @run = sort(keys %$tests) if $#run == -1; my $output = ''; my %cumulative; foreach my $test_name (@run) { die "Invalid test $test_name" if ! exists $tests->{$test_name}; my $txt = $tests->{$test_name}; my $sample = $text->{$test_name}; $sample =~ s/^.+=>//; $sample =~ s/\#.+$//; print "-------------------------------------------------------------\n"; print "Running test $test_name\n"; print "Test text: $sample\n"; ### set the global file types $str_ref = \$txt; $filename = $tt_cache_dir ."/$test_name.tt"; open(my $fh, ">$filename") || die "Couldn't open $filename: $!"; print $fh $txt; close $fh; #debug file_Alloy(), str_TT(); #debug $tap->parse_tree($file); ### check output - and also allow for caching for (1..2) { if (file_Alloy() ne str_TT()) { debug $tap->parse_tree($str_ref); debug file_Alloy(), str_TT(); die "file_Alloy didn't match"; } die "file_TT didn't match " if file_TT() ne str_TT(); die "str_Alloy didn't match " if str_Alloy() ne str_TT(); die "file_Alloy_cache_new didn't match " if file_Alloy_cache_new() ne str_TT(); die "file_TT_cache_new didn't match " if file_TT_cache_new() ne str_TT(); } next if test_taint; ###----------------------------------------------------------------### my $r = eval { timethese (-2, { file_TT_n => \&file_TT_new, # str_TT_n => \&str_TT_new, file_TT => \&file_TT, str_TT => \&str_TT, file_TT_c_n => \&file_TT_cache_new, file_Alloy_n => \&file_Alloy_new, # str_Alloy_n => \&str_Alloy_new, file_Alloy => \&file_Alloy, str_Alloy => \&str_Alloy, file_Alloy_c_n => \&file_Alloy_cache_new, }) }; if (! $r) { debug "$@"; next; } eval { cmpthese $r }; my $copy = $text->{$test_name}; $copy =~ s/\#.+//; $output .= $copy; eval { my $hash = { '1 cached_in_memory ' => ['file_Alloy', 'file_TT'], '2 new_object ' => ['file_Alloy_n', 'file_TT_n'], '3 cached_on_file (new_object)' => ['file_Alloy_c_n', 'file_TT_c_n'], '4 string reference ' => ['str_Alloy', 'str_TT'], '5 Alloy new vs TT in mem ' => ['file_Alloy_n', 'file_TT'], '6 Alloy in mem vs TT new ' => ['file_Alloy', 'file_TT_n'], '7 Alloy in mem vs Alloy new ' => ['file_Alloy', 'file_Alloy_n'], '8 TT in mem vs TT new ' => ['file_TT', 'file_TT_n'], }; foreach my $type (sort keys %$hash) { my ($key1, $key2) = @{ $hash->{$type} }; my $ct = $r->{$key1}; my $tt = $r->{$key2}; my $ct_s = $ct->iters / ($ct->cpu_a || 1); my $tt_s = $tt->iters / ($tt->cpu_a || 1); my $p = int(100 * ($ct_s - $tt_s) / ($tt_s || 1)); print "$type - Alloy is $p% faster than TT\n"; $output .= sprintf('# %3s%% ', $p) if $type =~ /^[1234]/; ### store cumulatives if (abs($p) < 10000) { $cumulative{$type} ||= [0, 0]; $cumulative{$type}->[0] += $p; $cumulative{$type}->[1] ++; } } }; debug "$@" if $@; $output .= "# ".sprintf("%.1f", $r->{'file_Alloy'}->iters / ($r->{'file_Alloy'}->cpu_a || 1))."/s #\n"; # $output .= "#\n"; foreach my $row (values %cumulative) { $row->[2] = sprintf('%.1f', $row->[0] / ($row->[1]||1)); } if ($#run > 0) { foreach (sort keys %cumulative) { printf "Cumulative $_: %6.1f\n", $cumulative{$_}->[2]; } } } ### add the final total row if ($#run > 0) { $output .= " # overall" . (" "x61); foreach my $type (sort keys %cumulative) { $output .= sprintf('# %3s%% ', int $cumulative{$type}->[2]) if $type =~ /^[1234]/; } $output .= "#\n"; } print $output; #print `ls -lR $tt_cache_dir`; __DATA__ libtemplate-alloy-perl-1.022/samples/benchmark/bench_template_tag_parser.pl000066400000000000000000000176551402714000200272160ustar00rootroot00000000000000#!/usr/bin/perl -w use strict; use Benchmark qw(timethese cmpthese countit timestr); use IO::Socket; my $str; $str = "--[% one %][% two %]--\n"; # Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds... # grammar: 4 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 36585.78/s (n=74635) # index: 4 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 81146.23/s (n=172030) # index2: 4 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 71674.76/s (n=150517) # match: 4 wallclock secs ( 2.12 usr + 0.01 sys = 2.13 CPU) @ 57690.14/s (n=122880) # split: 2 wallclock secs ( 2.06 usr + 0.00 sys = 2.06 CPU) @ 36230.58/s (n=74635) # Rate split grammar match index2 index # split 36231/s -- -1% -37% -49% -55% # grammar 36586/s 1% -- -37% -49% -55% # match 57690/s 59% 58% -- -20% -29% # index2 71675/s 98% 96% 24% -- -12% # index 81146/s 124% 122% 41% 13% -- $str = ((" "x1000)."[% one %]\n")x10; # Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds... # grammar: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 689.52/s (n=1448) # index: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 10239.52/s (n=21503) # index2: 4 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 10095.31/s (n=21503) # match: 4 wallclock secs ( 2.13 usr + 0.00 sys = 2.13 CPU) @ 6727.23/s (n=14329) # split: 4 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 5023.83/s (n=10751) # Rate grammar split match index2 index # grammar 690/s -- -86% -90% -93% -93% # split 5024/s 629% -- -25% -50% -51% # match 6727/s 876% 34% -- -33% -34% # index2 10095/s 1364% 101% 50% -- -1% # index 10240/s 1385% 104% 52% 1% -- #$str = ((" "x10)."[% one %]\n")x1000; # Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds... # grammar: 3 wallclock secs ( 2.10 usr + 0.01 sys = 2.11 CPU) @ 81.52/s (n=172) # index: 4 wallclock secs ( 2.11 usr + 0.01 sys = 2.12 CPU) @ 207.55/s (n=440) # index2: 4 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 209.52/s (n=440) # match: 3 wallclock secs ( 2.07 usr + 0.00 sys = 2.07 CPU) @ 173.43/s (n=359) # split: 4 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 91.98/s (n=195) # Rate grammar split match index index2 # grammar 81.5/s -- -11% -53% -61% -61% # split 92.0/s 13% -- -47% -56% -56% # match 173/s 113% 89% -- -16% -17% # index 208/s 155% 126% 20% -- -1% # index2 210/s 157% 128% 21% 1% -- ###----------------------------------------------------------------### ### use a regular expression to go through the string sub parse_match { my $new = ''; my $START = quotemeta '[%'; my $END = quotemeta '%]'; my $pos; local pos($_[0]) = 0; while ($_[0] =~ / \G (.*?) $START (.*?) $END /gsx) { my ($begin, $tag) = ($1, $2); $pos = pos($_[0]); $new .= $begin; $new .= "($tag)"; } return $pos ? $new . substr($_[0], $pos) : $_[0]; } ### good ole index - hard coded sub parse_index { my $new = ''; my $last = 0; while (1) { my $i = index($_[0], '[%', $last); last if $i == -1; $new .= substr($_[0], $last, $i - $last), my $j = index($_[0], '%]', $i + 2); die "Unclosed tag" if $j == -1; my $tag = substr($_[0], $i + 2, $j - ($i + 2)); $new .= "($tag)"; $last = $j + 2; } return $last ? $new . substr($_[0], $last) : $_[0]; } ### index searching - but configurable sub parse_index2 { my $new = ''; my $START = '[%'; my $END = '%]'; my $len_s = length $START; my $len_e = length $END; my $last = 0; while (1) { my $i = index($_[0], $START, $last); last if $i == -1; $new .= substr($_[0], $last, $i - $last), my $j = index($_[0], $END, $i + $len_s); $last = $j + $len_e; if ($j == -1) { # missing closing tag $last = length($_[0]); last; } my $tag = substr($_[0], $i + $len_s, $j - ($i + $len_s)); $new .= "($tag)"; } return $last ? $new . substr($_[0], $last) : $_[0]; } ### using a split method (several other split methods were also tried - but were slower) sub parse_split { my $new = ''; my $START = quotemeta '[%'; my $END = quotemeta '%]'; my @all = split /($START .*? $END)/sx, $_[0]; for my $piece (@all) { next if ! length $piece; if ($piece !~ /^$START (.*) $END$/sx) { $new .= $piece; next; } my $tag = $1; $new .= "($tag)"; } return $new; } ### a regex grammar type matcher sub parse_grammar { my $new = ''; my $START = quotemeta '[%'; my $END = quotemeta '%]'; local pos($_[0]) = 0; while (1) { ### find the start tag last if $_[0] !~ /\G (.*?) $START /gcxs; $new .= $1; if ($_[0] !~ /\G (.*?) $END /gcxs) { die "Unmatched $START tag"; } $new .= "($1)"; } return pos($_[0]) ? $new . substr($_[0], pos $_[0]) : $_[0]; } ### a regex grammar type matcher sub parse_grammar2 { my $new = ''; my $START = quotemeta '[%'; my $END = quotemeta '%]'; local pos $_[0] = 0; my $last = 0; while (1) { ### find the start tag last if $_[0] !~ / ($START) /gcxs; my $i = pos $_[0]; $new .= substr $_[0], $last, $i - length($1) - $last; if ($_[0] !~ / ($END) /gcxs) { die "Unmatched $START tag"; } $last = pos $_[0]; my $j = $last - length $1; $new .= "(".substr($_[0], $i, $j - $i).")"; } return pos($_[0]) ? $new . substr($_[0], pos $_[0]) : $_[0]; } ### use a regular expression to go through the string bruteforce sub parse_pos_array { my $new = ''; my $START = '[%'; my $END = '%]'; local pos($_[0]) = 0; my @start1; my @start2; while ($_[0] =~ /(\Q$START\E)/g) { push @start1, $-[1]; push @start2, $+[1] } local pos($_[0]) = 0; my @end1; my @end2; while ($_[0] =~ /(\Q$END\E)/g) { push @end1, $-[1]; push @end2, $+[1] } my $last = 0; while (1) { last if ! @start1; my $i = shift @start1; my $i2 = shift @start2; $new .= substr($_[0], $last, $i - $last); die "Unclosed tag" if ! @end1; my $j = shift @end1; my $j2 = shift @end2; my $tag = substr($_[0], $i2, $j - $i2); $new.= "($tag)"; $last = $j2; } return $last ? $new . substr($_[0], $last) : $_[0]; } ###----------------------------------------------------------------### ### check compliance #print parse_match($str); #print "---\n"; #print parse_split($str); #print "---\n"; #print parse_grammar($str); #print "---\n"; #print parse_index($str); #print "---\n"; #print parse_pos_array($str); #exit; die "parse_split didn't match" if parse_split($str) ne parse_match($str); die "parse_grammar didn't match" if parse_grammar($str) ne parse_match($str); die "parse_grammar2 didn't match" if parse_grammar2($str) ne parse_match($str); die "parse_index didn't match" if parse_index($str) ne parse_match($str); die "parse_index2 didn't match" if parse_index2($str) ne parse_match($str); die "parse_pos_array didn't match" if parse_pos_array($str) ne parse_match($str); #exit; ### and run them cmpthese timethese (-2, { index => sub { parse_index($str) }, index2 => sub { parse_index2($str) }, match => sub { parse_match($str) }, split => sub { parse_split($str) }, grammar => sub { parse_grammar($str) }, grammar2 => sub { parse_grammar2($str) }, pos_array => sub { parse_pos_array($str) }, }); libtemplate-alloy-perl-1.022/samples/benchmark/bench_various_templaters.pl000066400000000000000000001057241402714000200271170ustar00rootroot00000000000000#!/usr/bin/perl -w =head1 NAME bench_various_templaters.pl - test the relative performance of several different types of template engines. =cut use strict; use Benchmark qw(timethese cmpthese); use Template; use Template::Stash; use Template::Stash::XS; use Template::Parser::CET; use Text::Template; use Text::Tmpl; use HTML::Template; use HTML::Template::Compiled; use HTML::Template::Expr; use HTML::Template::JIT; use Template::Alloy; use Template::Alloy::XS; use POSIX qw(tmpnam); use File::Path qw(mkpath rmtree); ###----------------------------------------------------------------### my $names = { TA => 'Template::Alloy using TT interface', TA_NOCACHE => 'Template::Alloy with string ref caching off using process_simple', TA_H_NOCACHE => 'Template::Alloy with string ref caching off using HTML::Template interface', TA_P => 'Template::Alloy - Perl code eval based', TA_S => 'Template::Alloy::XS using TT interface using process_simple', TA_X => 'Template::Alloy::XS using TT interface', TA_PS => 'Template::Alloy - Perl code eval based using process_simple', TA_XS => 'Template::Alloy::XS - using process_simple', TA_XP => 'Template::Alloy::XS - Perl code eval based', TA_XPS => 'Template::Alloy::XS - Perl code eval based using process_simple', TA_H => 'Template::Alloy using HTML::Template interface', TA_H_X => 'Template::Alloy::XS using HTML::Template interface', TA_H_XP => 'Template::Alloy::XS using HTML::Template interface - Perl code eval based', TA_XTMPL => 'CGI::Ex::Temmplate::XS using Text::Tmpl interface', HT => 'HTML::Template', HTE => 'HTML::Template::Expr', HTJ => 'HTML::Template::JIT - Compiled to C template', HTC => 'HTML::Template::Compiled', TextTemplate => 'Text::Template - Perl code eval based', TT => 'Template::Toolkit', TTX => 'Template::Toolkit with Stash::XS', TTXCET => 'Template::Toolkit with Stash::XS and Template::Parser::CET', TMPL => 'Text::Tmpl - Engine is C based', RAW => 'Raw perl - no template engine', mem => 'Compiled in memory', file => 'Loaded from file', str => 'From string ref - cached if possible', }; ###----------------------------------------------------------------### ### get cache and compile dirs ready my $dir = tmpnam; my $dir2 = "$dir.cache"; mkpath($dir); mkpath($dir2); END {rmtree $dir; rmtree $dir2}; my @dirs = ($dir); ###----------------------------------------------------------------### my $form = { foo => 'bar', pass_in_something => 'what ever you want', }; my $filler = ((" foo" x 10)."\n") x 10; my $stash_t = { shell_header => "This is a header", shell_footer => "This is a footer", shell_start => "", shell_end => "", a_stuff => [qw(one two three four)], }; my $stash_ht = { shell_header => "This is a header", shell_footer => "This is a footer", shell_start => "", shell_end => "", a_stuff => [map {{name => $_}} qw(one two three four)], }; $FOO::shell_header = $FOO::shell_footer = $FOO::shell_start = $FOO::shell_end = $FOO::a_stuff; $FOO::shell_header = "This is a header"; $FOO::shell_footer = "This is a footer"; $FOO::shell_start = ""; $FOO::shell_end = ""; $FOO::a_stuff = [qw(one two three four)]; ###----------------------------------------------------------------### ### TT style template my $content_tt = <<"DOC"; [% shell_header %] [% shell_start %] $filler [% IF foo %] This is some text. [% END %] [% FOREACH i IN a_stuff %][% i %][% END %] [% pass_in_something %] $filler [% shell_end %] [% shell_footer %] DOC if (open (my $fh, ">$dir/foo.tt")) { print $fh $content_tt; close $fh; } ###----------------------------------------------------------------### ### HTML::Template style my $content_ht = <<"DOC"; $filler This is some text. $filler DOC if (open (my $fh, ">$dir/foo.ht")) { print $fh $content_ht; close $fh; } ###----------------------------------------------------------------### ### Text::Template style template my $content_p = <<"DOC"; {\$shell_header} {\$shell_start} $filler { if (\$foo) { \$OUT .= " This is some text. "; } } { \$OUT .= \$_ foreach \@\$a_stuff; } {\$pass_in_something} $filler {\$shell_end} {\$shell_footer} DOC ###----------------------------------------------------------------### ### Tmpl style template my $content_tmpl = <<"DOC"; $filler This is some text. $filler DOC if (open (my $fh, ">$dir/foo.tmpl")) { print $fh $content_tmpl; close $fh; } ###----------------------------------------------------------------### ### Pure perl base case my $content_raw = sub { my $args = shift; return "$args->{shell_header} $args->{shell_start} $filler ".($args->{foo} ? " This is some text. " : "")." ".(do { my $t = ''; $t .= $_ foreach @{ $args->{a_stuff} }; $t; })." $args->{pass_in_something} $filler $args->{shell_end} $args->{shell_footer} "; }; ###----------------------------------------------------------------### ### The TT interface allows for a single object to be cached and reused. my %Alloy_DOCUMENTS; my %AlloyX_DOCUMENTS; my %AlloyXP_DOCUMENTS; my $tt = Template->new( INCLUDE_PATH => \@dirs, STASH => Template::Stash->new($stash_t)); my $ttx = Template->new( INCLUDE_PATH => \@dirs, STASH => Template::Stash::XS->new($stash_t)); my $ta = Template::Alloy->new( INCLUDE_PATH => \@dirs, VARIABLES => $stash_t); my $tap = Template::Alloy->new( INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_PERL => 1); my $taps = Template::Alloy->new( INCLUDE_PATH => \@dirs, COMPILE_PERL => 1); my $tax = Template::Alloy::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t); my $taxs = Template::Alloy::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t); my $taxp = Template::Alloy::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_PERL => 1); my $taxps = Template::Alloy::XS->new(INCLUDE_PATH => \@dirs, COMPILE_PERL => 1); ###----------------------------------------------------------------### my $tests = { ###----------------------------------------------------------------### ### str infers that we are pulling from a string reference TextTemplate_str => sub { my $pt = Text::Template->new( TYPE => 'STRING', SOURCE => $content_p, HASH => $form); my $out = $pt->fill_in(PACKAGE => 'FOO', HASH => $form); }, TT_str => sub { my $t = Template->new(STASH => Template::Stash->new($stash_t)); my $out = ""; $t->process(\$content_tt, $form, \$out); $out; }, TTX_str => sub { my $t = Template->new(STASH => Template::Stash::XS->new($stash_t)); my $out = ""; $t->process(\$content_tt, $form, \$out); $out; }, TTXCET_str => sub { my $t = Template->new(STASH => Template::Stash::XS->new($stash_t), PARSER => Template::Parser::CET->new); my $out = ""; $t->process(\$content_tt, $form, \$out); $out; }, TA_str => sub { my $t = Template::Alloy->new(VARIABLES => $stash_t); $t->{'_documents'} = \%Alloy_DOCUMENTS; my $out = ""; $t->process(\$content_tt, $form, \$out); $out; }, TA_NOCACHE_str => sub { my $t = Template::Alloy->new(CACHE_STR_REFS => 0); my $out = ""; $t->process_simple(\$content_tt, {%$stash_t, %$form}, \$out); $out; }, TA_X_str => sub { my $t = Template::Alloy::XS->new(VARIABLES => $stash_t); $t->{'_documents'} = \%AlloyX_DOCUMENTS; my $out = ""; $t->process(\$content_tt, $form, \$out); $out; }, TA_XP_str => sub { my $t = Template::Alloy::XS->new(VARIABLES => $stash_t, COMPILE_PERL => 1); $t->{'_documents'} = \%AlloyXP_DOCUMENTS; my $out = ""; $t->process(\$content_tt, $form, \$out); $out; }, TA_XPS_str => sub { my $t = Template::Alloy::XS->new(COMPILE_PERL => 1); $t->{'_documents'} = \%AlloyXP_DOCUMENTS; my $out = ""; $t->process_simple(\$content_tt, {%$stash_t, %$form}, \$out); $out; }, TA_H_str => sub { my $t = Template::Alloy->new( type => 'scalarref', source => \$content_ht, case_sensitve=>1, cache => 1); $t->{'_documents'} = \%Alloy_DOCUMENTS; $t->param($stash_ht); $t->param($form); my $out = $t->output; }, TA_H_NOCACHE_str => sub { my $t = Template::Alloy->new( type => 'scalarref', source => \$content_ht, case_sensitve=>1, CACHE_STR_REFS => 1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, TA_H_X_str => sub { my $t = Template::Alloy::XS->new(type => 'scalarref', source => \$content_ht, case_sensitve=>1, cache => 1); $t->{'_documents'} = \%AlloyX_DOCUMENTS; $t->param($stash_ht); $t->param($form); my $out = $t->output; }, TA_H_XP_str => sub { my $t = Template::Alloy::XS->new(type => 'scalarref', source => \$content_ht, case_sensitve=>1, COMPILE_PERL => 1, cache => 1); $t->{'_documents'} = \%AlloyXP_DOCUMENTS; $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HT_str => sub { my $t = HTML::Template->new( type => 'scalarref', source => \$content_ht, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HTE_str => sub { my $t = HTML::Template::Expr->new( type => 'scalarref', source => \$content_ht, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HTC_str => sub { my $t = HTML::Template::Compiled->new(type => 'scalarref', source => \$content_ht, case_sensitve=>1, cache => 1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, TMPL_str => sub { my $t = Text::Tmpl->new; for my $ref (@{ $stash_ht->{'a_stuff'} }) { $t->loop_iteration('a_stuff')->set_values($ref); } $t->set_values($stash_ht); $t->set_values($form); $t->set_delimiters(''); $t->set_dir("$dir/"); $t->set_strip(0); my $out = $t->parse_string($content_tmpl); }, ###----------------------------------------------------------------### ### compile means item was compiled to optree or perlcode and stored on disk ### this should try to load the template from disk each time TT_file => sub { my $tt = Template->new(INCLUDE_PATH => \@dirs, STASH => Template::Stash->new($stash_t), COMPILE_DIR => $dir2); my $out = ""; $tt->process('foo.tt', $form, \$out); $out; }, TTX_file => sub { my $tt = Template->new(INCLUDE_PATH => \@dirs, STASH => Template::Stash::XS->new($stash_t), COMPILE_DIR => $dir2); my $out = ""; $tt->process('foo.tt', $form, \$out); $out; }, TA_file => sub { my $t = Template::Alloy->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_DIR => $dir2); my $out = ''; $t->process('foo.tt', $form, \$out); $out; }, TA_P_file => sub { my $t = Template::Alloy->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_DIR => $dir2, COMPILE_PERL => 1); my $out = ''; $t->process('foo.tt', $form, \$out); $out; }, TA_S_file => sub { my $t = Template::Alloy->new(INCLUDE_PATH => \@dirs, COMPILE_DIR => $dir2); my $out = ''; $t->process_simple('foo.tt', {%$stash_t, %$form}, \$out); $out; }, TA_X_file => sub { my $t = Template::Alloy::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_DIR => $dir2); my $out = ''; $t->process('foo.tt', $form, \$out); $out; }, TA_XS_file => sub { my $t = Template::Alloy::XS->new(INCLUDE_PATH => \@dirs, COMPILE_DIR => $dir2); my $out = ''; $t->process_simple('foo.tt', {%$stash_t, %$form}, \$out); $out; }, TA_XP_file => sub { my $t = Template::Alloy::XS->new(INCLUDE_PATH => \@dirs, VARIABLES => $stash_t, COMPILE_DIR => $dir2, COMPILE_PERL => 1); my $out = ''; $t->process('foo.tt', $form, \$out); $out; }, TA_XPS_file => sub { my $t = Template::Alloy::XS->new(INCLUDE_PATH => \@dirs, COMPILE_DIR => $dir2, COMPILE_PERL => 1); my $out = ""; $t->process_simple(\$content_tt, {%$stash_t, %$form}, \$out); $out; }, TA_H_file => sub { my $t = Template::Alloy->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, TA_H_X_file => sub { my $t = Template::Alloy::XS->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, TA_H_XP_file => sub { my $t = Template::Alloy::XS->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, case_sensitve=>1, compile_perl => 1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HT_file => sub { my $t = HTML::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HTC_file => sub { my $t = HTML::Template::Compiled->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2, case_sensitve=>1, cache => 0); $t->param($stash_ht); $t->param($form); my $out = $t->output; # $t->clear_cache; # caches in memory by default - can't disable it # return $out; }, TMPL_file => sub { my $t = Text::Tmpl->new; for my $ref (@{ $stash_ht->{'a_stuff'} }) { $t->loop_iteration('a_stuff')->set_values($ref); } $t->set_values($stash_ht); $t->set_values($form); $t->set_delimiters(''); $t->set_dir("$dir/"); $t->set_strip(0); my $out = $t->parse_file("foo.tmpl"); }, TA_XTMPL_file => sub { my $t = Template::Alloy::XS->new; for my $ref (@{ $stash_ht->{'a_stuff'} }) { $t->loop_iteration('a_stuff')->set_values($ref); } $t->set_values($stash_ht); $t->set_values($form); $t->set_delimiters(''); $t->set_dir("$dir/"); $t->set_strip(0); my $out = $t->parse_file("foo.tmpl"); }, ###----------------------------------------------------------------### ### mem indicates that the compiled form is stored in memory TT_mem => sub { my $out = ""; $tt->process( 'foo.tt', $form, \$out); $out }, TTX_mem => sub { my $out = ""; $ttx->process( 'foo.tt', $form, \$out); $out }, TA_mem => sub { my $out = ""; $ta->process( 'foo.tt', $form, \$out); $out }, TA_PS_mem => sub { my $out = ""; $taps->process_simple( 'foo.tt', {%$stash_t, %$form}, \$out); $out }, TA_X_mem => sub { my $out = ""; $tax->process( 'foo.tt', $form, \$out); $out }, TA_XP_mem => sub { my $out = ""; $taxp->process('foo.tt', $form, \$out); $out }, TA_XPS_mem => sub { my $out = ""; $taxps->process_simple('foo.tt', {%$stash_t, %$form}, \$out); $out }, TA_P_mem => sub { my $out = ""; $tap->process( 'foo.tt', $form, \$out); $out }, TA_H_mem => sub { my $t = Template::Alloy->new( filename => "foo.ht", path => \@dirs, cache => 1, case_sensitve=>1); $t->{'_documents'} = \%Alloy_DOCUMENTS; $t->param($stash_ht); $t->param($form); my $out = $t->output; }, TA_H_X_mem => sub { my $t = Template::Alloy::XS->new(filename => "foo.ht", path => \@dirs, cache => 1, case_sensitve=>1); $t->{'_documents'} = \%AlloyX_DOCUMENTS; $t->param($stash_ht); $t->param($form); my $out = $t->output; }, TA_H_XP_mem => sub { my $t = Template::Alloy::XS->new(filename => "foo.ht", path => \@dirs, cache => 1, case_sensitve=>1, compile_perl => 1, cache => 1); $t->{'_documents'} = \%AlloyXP_DOCUMENTS; $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HT_mem => sub { my $t = HTML::Template->new( filename => "foo.ht", path => \@dirs, cache => 1, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HTC_mem => sub { my $t = HTML::Template::Compiled->new( filename => "foo.ht", path => \@dirs, cache => 1, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HTE_mem => sub { my $t = HTML::Template::Expr->new( filename => "foo.ht", path => \@dirs, cache => 1, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, HTJ_mem => sub { # this is interesting - it is compiled - but it is pulled into memory just once my $t = HTML::Template::JIT->new( filename => "foo.ht", path => \@dirs, jit_path => $dir2, case_sensitve=>1); $t->param($stash_ht); $t->param($form); my $out = $t->output; }, #RAW_mem => sub { # my $out = $content_raw->({%$stash_t, %$form}); #}, }; my $test = $tests->{'TT_str'}->(); foreach my $name (sort keys %$tests) { if ($test ne $tests->{$name}->()) { print "--------------------------TT_str-------\n"; print $test; print "--------------------------$name--------\n"; print $tests->{$name}->(); die "$name did not match TT_str output\n"; } $name =~ /(\w+)_(\w+)/; print "$name - $names->{$1} - ($names->{$2})\n"; } ###----------------------------------------------------------------### ### and now - the tests - grouped by common capability my %mem_tests = map {my $k=$_; $k=~s/_mem$//; $k => $tests->{$_}} grep {/_mem$/} keys %$tests; my %cpl_tests = map {my $k=$_; $k=~s/_file$//; $k => $tests->{$_}} grep {/_file$/} keys %$tests; my %str_tests = map {my $k=$_; $k=~s/_str$//; $k => $tests->{$_}} grep {/_str$/} keys %$tests; print "---Match Run Through----------------------------------------------------\n"; my $match; # run through once to make sure they are working foreach my $key (sort keys %$tests) { my $out = $tests->{$key}->(); if ($match) { die "$key didn't match" if $out ne $match } else { $match = $out } } print " All test output matched!\n"; print "---STR------------------------------------------------------------------\n"; print "From a string or scalarref tests\n"; cmpthese timethese (-2, \%str_tests); print "---FILE-----------------------------------------------------------------\n"; print "Compiled and cached on the file system tests\n"; cmpthese timethese (-2, \%cpl_tests); print "---MEM------------------------------------------------------------------\n"; print "Cached in memory tests\n"; cmpthese timethese (-2, \%mem_tests); #print "------------------------------------------------------------------------\n"; #print "All variants together\n"; #cmpthese timethese (-2, $tests); ###----------------------------------------------------------------### __END__ =head1 VERSIONS Template::Alloy 1.009 Template 2.19 Template::Parser::CET 0.05 Text::Tmpl 0.30 Text::Template 1.44 HTML::Template 2.9 HTML::Template::Expr 0.07 HTML::Template::JIT 0.05 HTML::Template::Compiled 0.89 =head1 SAMPLE OUTPUT HTC_file - HTML::Template::Compiled - (Loaded from file) HTC_mem - HTML::Template::Compiled - (Compiled in memory) HTC_str - HTML::Template::Compiled - (From string ref - cached if possible) HTE_mem - HTML::Template::Expr - (Compiled in memory) HTE_str - HTML::Template::Expr - (From string ref - cached if possible) HTJ_mem - HTML::Template::JIT - Compiled to C template - (Compiled in memory) HT_file - HTML::Template - (Loaded from file) HT_mem - HTML::Template - (Compiled in memory) HT_str - HTML::Template - (From string ref - cached if possible) TA_H_NOCACHE_str - Template::Alloy with string ref caching off using HTML::Template interface - (From string ref - cached if possible) TA_H_XP_file - Template::Alloy::XS using HTML::Template interface - Perl code eval based - (Loaded from file) TA_H_XP_mem - Template::Alloy::XS using HTML::Template interface - Perl code eval based - (Compiled in memory) TA_H_XP_str - Template::Alloy::XS using HTML::Template interface - Perl code eval based - (From string ref - cached if possible) TA_H_X_file - Template::Alloy::XS using HTML::Template interface - (Loaded from file) TA_H_X_mem - Template::Alloy::XS using HTML::Template interface - (Compiled in memory) TA_H_X_str - Template::Alloy::XS using HTML::Template interface - (From string ref - cached if possible) TA_H_file - Template::Alloy using HTML::Template interface - (Loaded from file) TA_H_mem - Template::Alloy using HTML::Template interface - (Compiled in memory) TA_H_str - Template::Alloy using HTML::Template interface - (From string ref - cached if possible) TA_NOCACHE_str - Template::Alloy with string ref caching off using process_simple - (From string ref - cached if possible) TA_PS_mem - Template::Alloy - Perl code eval based using process_simple - (Compiled in memory) TA_P_file - Template::Alloy - Perl code eval based - (Loaded from file) TA_P_mem - Template::Alloy - Perl code eval based - (Compiled in memory) TA_S_file - Template::Alloy::XS using TT interface using process_simple - (Loaded from file) TA_XPS_file - Template::Alloy::XS - Perl code eval based using process_simple - (Loaded from file) TA_XPS_mem - Template::Alloy::XS - Perl code eval based using process_simple - (Compiled in memory) TA_XPS_str - Template::Alloy::XS - Perl code eval based using process_simple - (From string ref - cached if possible) TA_XP_file - Template::Alloy::XS - Perl code eval based - (Loaded from file) TA_XP_mem - Template::Alloy::XS - Perl code eval based - (Compiled in memory) TA_XP_str - Template::Alloy::XS - Perl code eval based - (From string ref - cached if possible) TA_XS_file - Template::Alloy::XS - using process_simple - (Loaded from file) TA_XTMPL_file - CGI::Ex::Temmplate::XS using Text::Tmpl interface - (Loaded from file) TA_X_file - Template::Alloy::XS using TT interface - (Loaded from file) TA_X_mem - Template::Alloy::XS using TT interface - (Compiled in memory) TA_X_str - Template::Alloy::XS using TT interface - (From string ref - cached if possible) TA_file - Template::Alloy using TT interface - (Loaded from file) TA_mem - Template::Alloy using TT interface - (Compiled in memory) TA_str - Template::Alloy using TT interface - (From string ref - cached if possible) TMPL_file - Text::Tmpl - Engine is C based - (Loaded from file) TMPL_str - Text::Tmpl - Engine is C based - (From string ref - cached if possible) TTXCET_str - Template::Toolkit with Stash::XS and Template::Parser::CET - (From string ref - cached if possible) TTX_file - Template::Toolkit with Stash::XS - (Loaded from file) TTX_mem - Template::Toolkit with Stash::XS - (Compiled in memory) TTX_str - Template::Toolkit with Stash::XS - (From string ref - cached if possible) TT_file - Template::Toolkit - (Loaded from file) TT_mem - Template::Toolkit - (Compiled in memory) TT_str - Template::Toolkit - (From string ref - cached if possible) TextTemplate_str - Text::Template - Perl code eval based - (From string ref - cached if possible) ---Match Run Through---------------------------------------------------- All test output matched! ---STR------------------------------------------------------------------ From a string or scalarref tests Benchmark: running HT, HTC, HTE, TA, TA_H, TA_H_NOCACHE, TA_H_X, TA_H_XP, TA_NOCACHE, TA_X, TA_XP, TA_XPS, TMPL, TT, TTX, TTXCET, TextTemplate for at least 2 CPU seconds... HT: 2 wallclock secs ( 2.08 usr + 0.00 sys = 2.08 CPU) @ 1230.29/s (n=2559) HTC: 2 wallclock secs ( 2.09 usr + 0.00 sys = 2.09 CPU) @ 210.53/s (n=440) HTE: 3 wallclock secs ( 2.17 usr + 0.00 sys = 2.17 CPU) @ 884.79/s (n=1920) TA: 3 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 3617.92/s (n=7670) TA_H: 3 wallclock secs ( 2.17 usr + 0.01 sys = 2.18 CPU) @ 3793.58/s (n=8270) TA_H_NOCACHE: 2 wallclock secs ( 2.02 usr + 0.01 sys = 2.03 CPU) @ 1400.99/s (n=2844) TA_H_X: 2 wallclock secs ( 2.15 usr + 0.00 sys = 2.15 CPU) @ 5321.40/s (n=11441) TA_H_XP: 2 wallclock secs ( 2.19 usr + 0.00 sys = 2.19 CPU) @ 5293.15/s (n=11592) TA_NOCACHE: 2 wallclock secs ( 2.00 usr + 0.01 sys = 2.01 CPU) @ 1292.04/s (n=2597) TA_X: 2 wallclock secs ( 2.06 usr + 0.01 sys = 2.07 CPU) @ 5607.73/s (n=11608) TA_XP: 2 wallclock secs ( 2.16 usr + 0.00 sys = 2.16 CPU) @ 7106.48/s (n=15350) TA_XPS: 2 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 8063.68/s (n=17095) TMPL: 2 wallclock secs ( 2.02 usr + 0.02 sys = 2.04 CPU) @ 8107.35/s (n=16539) TT: 2 wallclock secs ( 2.14 usr + 0.01 sys = 2.15 CPU) @ 312.09/s (n=671) TTX: 2 wallclock secs ( 2.16 usr + 0.01 sys = 2.17 CPU) @ 326.27/s (n=708) TTXCET: 2 wallclock secs ( 2.16 usr + 0.01 sys = 2.17 CPU) @ 516.13/s (n=1120) TextTemplate: 2 wallclock secs ( 1.99 usr + 0.01 sys = 2.00 CPU) @ 1197.50/s (n=2395) Rate HTC TT TTX TTXCET HTE TextTemplate HT TA_NOCACHE TA_H_NOCACHE TA TA_H TA_H_XP TA_H_X TA_X TA_XP TA_XPS TMPL HTC 211/s -- -33% -35% -59% -76% -82% -83% -84% -85% -94% -94% -96% -96% -96% -97% -97% -97% TT 312/s 48% -- -4% -40% -65% -74% -75% -76% -78% -91% -92% -94% -94% -94% -96% -96% -96% TTX 326/s 55% 5% -- -37% -63% -73% -73% -75% -77% -91% -91% -94% -94% -94% -95% -96% -96% TTXCET 516/s 145% 65% 58% -- -42% -57% -58% -60% -63% -86% -86% -90% -90% -91% -93% -94% -94% HTE 885/s 320% 184% 171% 71% -- -26% -28% -32% -37% -76% -77% -83% -83% -84% -88% -89% -89% TextTemplate 1197/s 469% 284% 267% 132% 35% -- -3% -7% -15% -67% -68% -77% -77% -79% -83% -85% -85% HT 1230/s 484% 294% 277% 138% 39% 3% -- -5% -12% -66% -68% -77% -77% -78% -83% -85% -85% TA_NOCACHE 1292/s 514% 314% 296% 150% 46% 8% 5% -- -8% -64% -66% -76% -76% -77% -82% -84% -84% TA_H_NOCACHE 1401/s 565% 349% 329% 171% 58% 17% 14% 8% -- -61% -63% -74% -74% -75% -80% -83% -83% TA 3618/s 1619% 1059% 1009% 601% 309% 202% 194% 180% 158% -- -5% -32% -32% -35% -49% -55% -55% TA_H 3794/s 1702% 1116% 1063% 635% 329% 217% 208% 194% 171% 5% -- -28% -29% -32% -47% -53% -53% TA_H_XP 5293/s 2414% 1596% 1522% 926% 498% 342% 330% 310% 278% 46% 40% -- -1% -6% -26% -34% -35% TA_H_X 5321/s 2428% 1605% 1531% 931% 501% 344% 333% 312% 280% 47% 40% 1% -- -5% -25% -34% -34% TA_X 5608/s 2564% 1697% 1619% 986% 534% 368% 356% 334% 300% 55% 48% 6% 5% -- -21% -30% -31% TA_XP 7106/s 3276% 2177% 2078% 1277% 703% 493% 478% 450% 407% 96% 87% 34% 34% 27% -- -12% -12% TA_XPS 8064/s 3730% 2484% 2371% 1462% 811% 573% 555% 524% 476% 123% 113% 52% 52% 44% 13% -- -1% TMPL 8107/s 3751% 2498% 2385% 1471% 816% 577% 559% 527% 479% 124% 114% 53% 52% 45% 14% 1% -- ---FILE----------------------------------------------------------------- Compiled and cached on the file system tests Benchmark: running HT, HTC, TA, TA_H, TA_H_X, TA_H_XP, TA_P, TA_S, TA_X, TA_XP, TA_XPS, TA_XS, TA_XTMPL, TMPL, TT, TTX for at least 2 CPU seconds... HT: 3 wallclock secs ( 2.10 usr + 0.05 sys = 2.15 CPU) @ 1902.33/s (n=4090) HTC: 2 wallclock secs ( 2.18 usr + 0.02 sys = 2.20 CPU) @ 867.73/s (n=1909) TA: 2 wallclock secs ( 2.10 usr + 0.08 sys = 2.18 CPU) @ 2462.84/s (n=5369) TA_H: 3 wallclock secs ( 2.03 usr + 0.06 sys = 2.09 CPU) @ 2345.93/s (n=4903) TA_H_X: 3 wallclock secs ( 2.09 usr + 0.06 sys = 2.15 CPU) @ 2937.67/s (n=6316) TA_H_XP: 2 wallclock secs ( 2.03 usr + 0.05 sys = 2.08 CPU) @ 1229.81/s (n=2558) TA_P: 2 wallclock secs ( 2.15 usr + 0.04 sys = 2.19 CPU) @ 1302.74/s (n=2853) TA_S: 2 wallclock secs ( 1.92 usr + 0.10 sys = 2.02 CPU) @ 2575.74/s (n=5203) TA_X: 2 wallclock secs ( 2.04 usr + 0.11 sys = 2.15 CPU) @ 3330.23/s (n=7160) TA_XP: 2 wallclock secs ( 2.04 usr + 0.06 sys = 2.10 CPU) @ 1522.38/s (n=3197) TA_XPS: 2 wallclock secs ( 2.05 usr + 0.05 sys = 2.10 CPU) @ 1556.19/s (n=3268) TA_XS: 2 wallclock secs ( 2.06 usr + 0.11 sys = 2.17 CPU) @ 3534.10/s (n=7669) TA_XTMPL: 2 wallclock secs ( 2.11 usr + 0.02 sys = 2.13 CPU) @ 1201.41/s (n=2559) TMPL: 2 wallclock secs ( 1.90 usr + 0.20 sys = 2.10 CPU) @ 6977.14/s (n=14652) TT: 2 wallclock secs ( 2.09 usr + 0.03 sys = 2.12 CPU) @ 756.13/s (n=1603) TTX: 2 wallclock secs ( 2.14 usr + 0.03 sys = 2.17 CPU) @ 824.88/s (n=1790) Rate TT TTX HTC TA_XTMPL TA_H_XP TA_P TA_XP TA_XPS HT TA_H TA TA_S TA_H_X TA_X TA_XS TMPL TT 756/s -- -8% -13% -37% -39% -42% -50% -51% -60% -68% -69% -71% -74% -77% -79% -89% TTX 825/s 9% -- -5% -31% -33% -37% -46% -47% -57% -65% -67% -68% -72% -75% -77% -88% HTC 868/s 15% 5% -- -28% -29% -33% -43% -44% -54% -63% -65% -66% -70% -74% -75% -88% TA_XTMPL 1201/s 59% 46% 38% -- -2% -8% -21% -23% -37% -49% -51% -53% -59% -64% -66% -83% TA_H_XP 1230/s 63% 49% 42% 2% -- -6% -19% -21% -35% -48% -50% -52% -58% -63% -65% -82% TA_P 1303/s 72% 58% 50% 8% 6% -- -14% -16% -32% -44% -47% -49% -56% -61% -63% -81% TA_XP 1522/s 101% 85% 75% 27% 24% 17% -- -2% -20% -35% -38% -41% -48% -54% -57% -78% TA_XPS 1556/s 106% 89% 79% 30% 27% 19% 2% -- -18% -34% -37% -40% -47% -53% -56% -78% HT 1902/s 152% 131% 119% 58% 55% 46% 25% 22% -- -19% -23% -26% -35% -43% -46% -73% TA_H 2346/s 210% 184% 170% 95% 91% 80% 54% 51% 23% -- -5% -9% -20% -30% -34% -66% TA 2463/s 226% 199% 184% 105% 100% 89% 62% 58% 29% 5% -- -4% -16% -26% -30% -65% TA_S 2576/s 241% 212% 197% 114% 109% 98% 69% 66% 35% 10% 5% -- -12% -23% -27% -63% TA_H_X 2938/s 289% 256% 239% 145% 139% 125% 93% 89% 54% 25% 19% 14% -- -12% -17% -58% TA_X 3330/s 340% 304% 284% 177% 171% 156% 119% 114% 75% 42% 35% 29% 13% -- -6% -52% TA_XS 3534/s 367% 328% 307% 194% 187% 171% 132% 127% 86% 51% 43% 37% 20% 6% -- -49% TMPL 6977/s 823% 746% 704% 481% 467% 436% 358% 348% 267% 197% 183% 171% 138% 110% 97% -- ---MEM------------------------------------------------------------------ Cached in memory tests Benchmark: running HT, HTC, HTE, HTJ, TA, TA_H, TA_H_X, TA_H_XP, TA_P, TA_PS, TA_X, TA_XP, TA_XPS, TT, TTX for at least 2 CPU seconds... HT: 2 wallclock secs ( 2.10 usr + 0.04 sys = 2.14 CPU) @ 2670.56/s (n=5715) HTC: 3 wallclock secs ( 2.00 usr + 0.05 sys = 2.05 CPU) @ 8212.68/s (n=16836) HTE: 2 wallclock secs ( 2.16 usr + 0.01 sys = 2.17 CPU) @ 1543.78/s (n=3350) HTJ: 2 wallclock secs ( 1.99 usr + 0.08 sys = 2.07 CPU) @ 6197.58/s (n=12829) TA: 2 wallclock secs ( 2.08 usr + 0.03 sys = 2.11 CPU) @ 3872.51/s (n=8171) TA_H: 2 wallclock secs ( 2.11 usr + 0.02 sys = 2.13 CPU) @ 3882.63/s (n=8270) TA_H_X: 2 wallclock secs ( 2.07 usr + 0.05 sys = 2.12 CPU) @ 5396.70/s (n=11441) TA_H_XP: 2 wallclock secs ( 2.15 usr + 0.03 sys = 2.18 CPU) @ 5248.17/s (n=11441) TA_P: 2 wallclock secs ( 2.11 usr + 0.03 sys = 2.14 CPU) @ 4565.42/s (n=9770) TA_PS: 2 wallclock secs ( 2.08 usr + 0.04 sys = 2.12 CPU) @ 4829.72/s (n=10239) TA_X: 2 wallclock secs ( 2.07 usr + 0.02 sys = 2.09 CPU) @ 6225.36/s (n=13011) TA_XP: 2 wallclock secs ( 2.06 usr + 0.06 sys = 2.12 CPU) @ 8068.40/s (n=17105) TA_XPS: 2 wallclock secs ( 2.09 usr + 0.07 sys = 2.16 CPU) @ 9045.83/s (n=19539) TT: 2 wallclock secs ( 2.22 usr + 0.01 sys = 2.23 CPU) @ 2297.31/s (n=5123) TTX: 2 wallclock secs ( 2.10 usr + 0.02 sys = 2.12 CPU) @ 3377.36/s (n=7160) Rate HTE TT HT TTX TA TA_H TA_P TA_PS TA_H_XP TA_H_X HTJ TA_X TA_XP HTC TA_XPS HTE 1544/s -- -33% -42% -54% -60% -60% -66% -68% -71% -71% -75% -75% -81% -81% -83% TT 2297/s 49% -- -14% -32% -41% -41% -50% -52% -56% -57% -63% -63% -72% -72% -75% HT 2671/s 73% 16% -- -21% -31% -31% -42% -45% -49% -51% -57% -57% -67% -67% -70% TTX 3377/s 119% 47% 26% -- -13% -13% -26% -30% -36% -37% -46% -46% -58% -59% -63% TA 3873/s 151% 69% 45% 15% -- -0% -15% -20% -26% -28% -38% -38% -52% -53% -57% TA_H 3883/s 152% 69% 45% 15% 0% -- -15% -20% -26% -28% -37% -38% -52% -53% -57% TA_P 4565/s 196% 99% 71% 35% 18% 18% -- -5% -13% -15% -26% -27% -43% -44% -50% TA_PS 4830/s 213% 110% 81% 43% 25% 24% 6% -- -8% -11% -22% -22% -40% -41% -47% TA_H_XP 5248/s 240% 128% 97% 55% 36% 35% 15% 9% -- -3% -15% -16% -35% -36% -42% TA_H_X 5397/s 250% 135% 102% 60% 39% 39% 18% 12% 3% -- -13% -13% -33% -34% -40% HTJ 6198/s 301% 170% 132% 84% 60% 60% 36% 28% 18% 15% -- -0% -23% -25% -31% TA_X 6225/s 303% 171% 133% 84% 61% 60% 36% 29% 19% 15% 0% -- -23% -24% -31% TA_XP 8068/s 423% 251% 202% 139% 108% 108% 77% 67% 54% 50% 30% 30% -- -2% -11% HTC 8213/s 432% 257% 208% 143% 112% 112% 80% 70% 56% 52% 33% 32% 2% -- -9% TA_XPS 9046/s 486% 294% 239% 168% 134% 133% 98% 87% 72% 68% 46% 45% 12% 10% -- =cut libtemplate-alloy-perl-1.022/samples/dprof_template.d000066400000000000000000000022441402714000200227040ustar00rootroot00000000000000# -*-perl-*- # run with perl -d:DProf $0 ; dprofpp use strict; use POSIX qw(tmpnam); use File::Path qw(rmtree); use Template::Alloy; #use Template::Alloy_60; my $tt_cache_dir = tmpnam; END { rmtree $tt_cache_dir }; mkdir $tt_cache_dir, 0755; my $cet = Template::Alloy->new(ABSOLUTE => 1); #use Template; #my $cet = Template->new(ABSOLUTE => 1); ###----------------------------------------------------------------### my $swap = { one => "ONE", two => "TWO", three => "THREE", a_var => "a", hash => {a => 1, b => 2, c => { d => ["hmm"] }}, array => [qw(A B C D E a A)], code => sub {"($_[0])"}, cet => $cet, }; my $txt = ''; $txt .= "[% one %]\n"; $txt .= ((" "x1000)."[% one %]\n")x100; $txt .= "[%f=10; WHILE (g=f) ; f = f - 1 ; f ; END %]"; $txt .= ("[% \"".(" "x10)."\$one\" %]\n")x1000; my $file = \$txt; if (1) { $file = $tt_cache_dir .'/template.txt'; open(my $fh, ">$file") || die "Couldn't open $file: $!"; print $fh $txt; close $fh; } ###----------------------------------------------------------------### sub cet { my $out = ''; $cet->process($file, $swap, \$out); return $out; } cet() for 1 .. 500; libtemplate-alloy-perl-1.022/samples/memory_template.pl000066400000000000000000000054471402714000200233020ustar00rootroot00000000000000#!/usr/bin/perl -w my $swap = { one => "ONE", two => "TWO", three => "THREE", a_var => "a", hash => {a => 1, b => 2}, code => sub {"($_[0])"}, }; my $txt = "[% one %][% two %][% three %][% hash.keys.join %] [% code(one).length %] [% hash.\$a_var %]\n"; #$txt = hello2000(); ###----------------------------------------------------------------### my $module; my $name; if (! fork) { $module = 'Template::Alloy'; } elsif (! fork) { $module = 'Template::Alloy::XS'; } elsif (! fork) { $module = 'Template'; } elsif (! fork) { $module = 'Template'; $name = 'Template Stash::XS'; require Template::Stash::XS; } elsif (! fork) { $module = 'HTML::Template'; } elsif (! fork) { $module = 'HTML::Template::Expr'; } elsif (! fork) { $module = 'HTML::Template::Compiled'; } elsif (! fork) { $module = 'Text::Tmpl'; } elsif (! fork) { $module = 'Template::Alloy'; $name = 'Template::Alloy - bare'; } elsif (! fork) { $module = 'Template::Alloy::XS'; $name = 'Template::Alloy::XS - bare'; } elsif (! fork) { $module = 'Template'; $name = 'Template::Parser::CET'; require Template::Parser::CET; Template::Parser::CET->activate; } if ($module) { $name ||= $module; $0 = "$0 - $name"; my $pm = "$module.pm"; $pm =~ s|::|/|g; require $pm; if ($module =~ /HTML::Template/) { my $t = eval { $module->new }; } elsif ($module eq 'Text::Tmpl') { my $t = eval { $module->new->parse_string($txt) }; } elsif ($name =~ /bare/) { my $t = eval { $module->new }; } else { my $t = $module->new(ABSOLUTE => 1); my $out = ''; $t->process(\$txt, $swap, \$out); print "$name $out"; for (1..30) { my $out; $t->process(\$txt, $swap, \$out); }; } # print "$name $_\n" foreach sort keys %INC; print "$name times: (@{[times]})\n"; sleep 15; exit; } sleep 2; print grep {/\Q$0\E/} `ps fauwx`; #sleep 15; # go and check the 'ps fauwx|grep perl' exit; ###----------------------------------------------------------------### sub hello2000 { my $hello2000 = "[% title %] [% array = [ \"Hello\", \"World\", \"2000\", \"Hello\", \"World\", \"2000\" ] %] [% sorted = array.sort %] [% multi = [ sorted, sorted, sorted, sorted, sorted ] %] [% FOREACH row = multi %] [% FOREACH col = row %] [% END %] [% END %]
[% col %]
[% param = integer %] [% FOREACH i = [ 1 .. 10 ] %] [% var = i + param %]" .("\n [%var%] Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World Hello World
"x20)." [% END %] "; } libtemplate-alloy-perl-1.022/t/000077500000000000000000000000001402714000200163275ustar00rootroot00000000000000libtemplate-alloy-perl-1.022/t/00_use.t000066400000000000000000000105201402714000200176050ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 00_use.t - Test the use/import/can functionality of Template::Alloy =cut use strict; use warnings; use Test::More tests => 43; ###----------------------------------------------------------------### ### loading via can, use, and import use_ok('Template::Alloy'); ### autoload via can ok(! $INC{'Template/Alloy/Parse.pm'}, "Parse role isn't loaded yet"); ok(Template::Alloy->can('parse_tree'), "But it can parse anyway"); ok($INC{'Template/Alloy/Parse.pm'}, "Parse role is now loaded"); ok(! eval "use Template::Alloy qw(garbage); 1", "Can't import invalid method"); ### autoload via Role in use ok(! $INC{'Template/Alloy/Play.pm'}, "Play role isn't loaded yet"); ok(eval "use Template::Alloy qw(Play); 1", "It can be imported ($@)"); ok($INC{'Template/Alloy/Play.pm'}, "Play role is now loaded"); ### autoload via Role in use with sugar ok(! $INC{'Template/Alloy/Compile.pm'}, "Compile role isn't loaded yet"); ok(eval "use Template::Alloy load => 'Compile'; 1", "It can be imported ($@)"); ok($INC{'Template/Alloy/Compile.pm'}, "Compile role is now loaded"); ok(eval "use Template::Alloy load => 'Compile'; 1", "It can be imported twice ($@)"); ### autoload via Role in use with sugar ok(! $INC{'Template/Alloy/Velocity.pm'}, "Velocity role isn't loaded yet"); ok(eval "use Template::Alloy Velocity => 1; 1", "It can be imported ($@)"); ok($INC{'Template/Alloy/Velocity.pm'}, "Velocity role is now loaded"); ### autoload via method in use with sugar ok(! $INC{'Template/Alloy/Tmpl.pm'}, "Tmpl role isn't loaded yet"); ok(eval "use Template::Alloy parse_string => 1; 1", "It can be imported ($@)"); ok($INC{'Template/Alloy/Tmpl.pm'}, "Tmpl role is now loaded"); ### override module namespace that isn't yet loaded ok(! $INC{'Text/Tmpl.pm'}, "Text::Tmpl isn't loaded"); ok(eval "use Template::Alloy 'Text::Tmpl'; 1", "It can be imported ($@)"); ok($INC{'Text/Tmpl.pm'}, "Text::Tmpl is now loaded"); ok(Text::Tmpl->isa('Template::Alloy'), "Text::Tmpl is a Template::Alloy"); ok(eval "use Template::Alloy 'Text::Tmpl'; 1", "It can be imported twice"); ### override module namespace that isn't yet loaded ok(! $INC{'HTML/Template.pm'}, "HTML::Template isn't loaded"); eval "{package HTML::Template; \$INC{'HTML/Template.pm'}=1}"; # simulate loading HTML::Template ok(! eval "use Template::Alloy 'HTML::Template'; 1", "It can't be imported because another non-Alloy package already is using it"); ok(! HTML::Template->isa('Template::Alloy'), "HTML::Template is not a Template::Alloy"); ### override module namespace that isn't yet loaded ok(! $INC{'HTML/Template/Expr.pm'}, "HTML::Template::Expr isn't loaded"); ok(eval{Template::Alloy->import('HTML::Template::Expr')}, "It can be imported ($@)"); ok($INC{'HTML/Template/Expr.pm'}, "HTML::Template::Expr is now loaded"); ok(HTML::Template::Expr->isa('Template::Alloy'), "HTML::Template::Expr is a Template::Alloy"); ok(eval{Template::Alloy->import('HTML::Template::Expr')}, "It can be imported twice"); ### autoload via "all" ok(! $INC{'Template/Alloy/TT.pm'}, "TT role isn't loaded yet"); ok(eval "use Template::Alloy load => 'all'; 1", "It can be imported via all ($@)"); ok($INC{'Template/Alloy/TT.pm'}, "TT role is now loaded"); ok(eval "use Template::Alloy load => 'all'; 1", "It can be imported twice ($@)"); ### override module namespace that isn't yet loaded ok(! $INC{'Template.pm'}, "Template isn't loaded"); ok(eval "use Template::Alloy 'Template'; 1", "It can be imported ($@)"); ok($INC{'Template.pm'}, "Template is now loaded"); ok(Template->isa('Template::Alloy'), "Template is a Template::Alloy"); ok(eval "use Template::Alloy 'Template'; 1", "It can be imported twice"); ###----------------------------------------------------------------### ok(! eval { Template::Alloy->flabbergast } && $@, "Got an error on invalid methods ($@)"); my $meth = ''; ok(! eval { Template::Alloy->$meth() } && $@, "Got an error on invalid methods ($@)"); $meth = 'foo&bar'; ok(! eval { Template::Alloy->$meth() } && $@, "Got an error on invalid methods ($@)"); ###----------------------------------------------------------------### libtemplate-alloy-perl-1.022/t/01_coverage.t000066400000000000000000000060171402714000200206130ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 01_coverage.t - Test various use cases to make sure the code is exercised for correctness. =cut use strict; use warnings; use Test::More tests => 31; ###----------------------------------------------------------------### use_ok('Template::Alloy'); my $o = Template::Alloy->new({foo => 1}); ok($o && $o->{'FOO'}, "Initialize with hashref and get hashref based object"); $o = Template::Alloy->new(foo => 1); ok($o && $o->{'FOO'}, "Initialize with hash and get hashref based object"); ok(! eval { $o->process_simple } && $@, "Got an error for process_simple"); ok(! eval { $o->process_simple(\q{wow}) } && $@, "Got an error for process_simple"); ok(! eval { $o->process_simple(\q{wow}, {}) } && $@, "Got an error for process_simple"); my $out = ''; ok($o->process_simple(\q{wow}, {}, \$out) && ! $o->error, "Ran process_simple without error"); $out = ''; ok(! $o->process_simple(\q{odd[% THROW foo %]interesting}, {}, \$out), "Ran process_simple and threw error"); ok($o->error, "And got error"); ok($out eq 'odd', "Got right output"); $out = ''; ok($o->process_simple(\q{odd[% STOP %]interesting}, {}, \$out), "Ran process_simple and stopped"); ok(! $o->error, "And got no error"); ok($out eq 'odd', "Got right output"); ###----------------------------------------------------------------### $out = ''; ok($o->_process(\q{wow}, undef, \$out), "Ran _process"); ok(! $o->error, "And got error"); ok($out eq 'wow', "Got right output"); ok(! eval { $o->_process(\q{wow}, undef) } && $@, "Ran _process and got error"); $out = ''; ok($o->_process(\q{}, undef, \$out), "Ran _process"); ok(! $o->error, "And got error"); ok($out eq '', "Got right output"); $out = ''; $o->{'_documents'} = {foobar => undef}; ok(! eval { $o->_process('foobar', undef, \$out) }, "Ran _process ($@)"); $out = ''; ok(! eval { $o->_process({name => 'foo'}, undef, \$out) }, "Ran _process ($@)"); $out = ''; ok(eval { $o->_process({name => 'foo', _tree=>['wow']}, undef, \$out) }, "Ran _process"); ###----------------------------------------------------------------### ok(! eval { $o->load_template } && $@, "Can't load_template without a file"); ok($o->load_template({foo => 'bar'})->{'foo'} eq 'bar', "load_template assumes we know what we are doing if we pass a hash"); $o->{'BLOCKS'} = { foo => 'One + Two = [% 1 + 2 %]', code => sub {'[% 2 * 2 * 2 %]'}, ok => $o->load_template(\ '[% 3 * 5 %]'), ok2 => do { local $o->{'COMPILE_PERL'} = 1; $o->load_template(\ '[% 3 * 5 %]') }, nok => {}, nok2 => '[% 3', bad => [], }; is($o->load_template('foo')->{'name'}, 'foo', "Can load a string block"); is($o->load_template('code')->{'name'}, 'code', "Can load a code block"); is($o->load_template('ok')->{'name'}, 'ok', "Can load a previously loaded template"); ok(! eval { $o->load_template('nok') } && $@, "Can't load a poorly formed block"); ok(! eval { $o->load_template('nok2') } && $@, "Can't load a string block with parse errors"); ok(! eval { $o->load_template('bad') } && $@, "Can't load a ref block"); libtemplate-alloy-perl-1.022/t/02_cache.t000066400000000000000000000513601402714000200200650ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 02_cache.t - Test caching features =cut use 5.006; our ($n_tests, $has_encode); BEGIN { if (eval { require Encode; require utf8 }) { $has_encode = 1; } $n_tests = 193; $n_tests += 12 if $has_encode; }; use strict; use Test::More tests => $n_tests; use constant test_taint => 0 && eval { require Taint::Runtime }; if (! eval { require File::Path }) { SKIP: { skip("File::Path not installed, skipping tests", $n_tests); }; exit; } my $module = 'Template::Alloy'; use_ok($module); Taint::Runtime::taint_start() if test_taint; my $name = "bar.tt"; ### find a place to allow for testing my $test_dir = $0 .'.test_dir'; END { if($test_dir){ flush_dir($test_dir); rmdir($test_dir) || die "Couldn't rmdir $test_dir: $!"} } mkdir $test_dir, 0755; ok(-d $test_dir, "Got a test dir up and running"); ### find a place to allow for testing my $test_dir2 = $0 .'.test_dir2'; END { if($test_dir2){flush_dir($test_dir2); rmdir $test_dir2 || die "Couldn't rmdir $test_dir2: $!"} } mkdir $test_dir2, 0755; ok(-d $test_dir2, "Got a test dir up and running"); ###----------------------------------------------------------------### sub process_ok { # process the value and say if it was ok my $str = shift; my $test = shift; my $vars = shift || {}; my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || []; push @$conf, (INCLUDE_PATH => $test_dir); my $obj = shift || $module->new(@$conf); # new object each time my $out = ''; my $line = (caller)[2]; delete $vars->{'tt_config'}; Taint::Runtime::taint(\$str) if test_taint; $obj->process_simple($str, $vars, \$out); my $ok = ref($test) ? $out =~ $test : $out eq $test; if ($ok) { ok(1, "Line $line \"".(ref($str) ? $$str : $str)."\" => \"$out\""); return $obj; } else { ok(0, "Line $line \"".(ref($str) ? $$str : $str)); warn "# Was:\n$out\n# Should've been:\n$test\n"; print $obj->error if $obj->can('error'); print $obj->dump_parse_tree(\$str) if $obj->can('dump_parse_tree'); # exit; } } sub pristine { my $contents = shift || "[% blue %]BAR"; my $encoding = shift; if ($encoding) { $contents = Encode::encode( $encoding, $contents ); } $Template::Alloy::GLOBAL_CACHE = {}; flush_dir($test_dir); flush_dir($test_dir2); if (! ref $name) { my $fh; open($fh, ">$test_dir/$name") || die "Couldn't open $name in $test_dir: $!"; print $fh $contents; close $fh; } } sub flush_dir { my $dir = shift; opendir(my $dh, $dir) || die "Couldn't open $dir: $!"; my @files = map { "$dir/$_"} grep {! /^\.\.?$/} readdir $dh; # print "Unlinking (@files) in $dir\n"; File::Path::rmtree($_) foreach @files; } sub test_cache { my ($file, $pkg, $line) = caller; my $not_ok; foreach my $i (0 .. $#_) { my $ref = $_[$i] || return; my $_line = $line + $i; my ($dir, $name, $exists) = @$ref; if ($exists) { my $ok = -e "$dir/$name"; ok($ok, "Line $_line: Found $name in $dir"); $not_ok++ if ! $ok; } else { my $ok = ! -e "$dir/$name"; ok($ok, "Line $_line: Didn't find $name in $dir"); $not_ok++ if ! $ok; } } if ($not_ok) { print "#-------------------------\n"; print `find $test_dir $test_dir2 -type f`; print "#-------------------------\n"; } } ###----------------------------------------------------------------### pristine(); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$name$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$name}, "Not in GLOBAL_CACHE"); ###----------------------------------------------------------------### print "### COMPILE_PERL => 0 ################################################\n"; pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue'}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$name$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$name}, "Not in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => 1]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$name$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok($Template::Alloy::GLOBAL_CACHE->{$name}, "Is in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); my $cache = {}; process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => $cache]}); ok($cache->{$name}, "Is in CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_EXT => '.ttc']}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], ); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_DIR => $test_dir2]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::PERL_COMPILE_EXT", 0], ); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_DIR => $test_dir2, COMPILE_EXT => '.ttc']}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$name}, "Is in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_DIR => $test_dir2, COMPILE_EXT => '.ttc', GLOBAL_CACHE => 1]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok($Template::Alloy::GLOBAL_CACHE->{$name}, "Is in GLOBAL_CACHE"); ok(! $Template::Alloy::GLOBAL_CACHE->{$name}->{'_perl'}, "Doesn't Have perl"); ###----------------------------------------------------------------### if ($has_encode) { my $encoding = 'UTF-8'; my $template = "[% blue %]BAR ¥"; pristine($template, $encoding); my $in = 'fü'; my $out = 'füBAR ¥'; process_ok($name => $out, {blue => $in, tt_config => [ENCODING => $encoding, COMPILE_EXT => '.ttc']}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], ); process_ok($name => $out, {blue => $in, tt_config => [ENCODING => $encoding, COMPILE_EXT => '.ttc']}); my $tt = $module->new(ENCODING => 'UTF8'); $template = "\x{200b}"; my $fail; $out = ''; $tt->process(\$template, {}, \ $out) or $fail = $@; ok(!$fail, 'lives ok') || diag $fail; } ###----------------------------------------------------------------### print "### COMPILE_PERL => 1 ################################################\n"; pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_PERL => 1]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$name$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$name}, "Not in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_PERL => 1, GLOBAL_CACHE => 1]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$name$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok($Template::Alloy::GLOBAL_CACHE->{$name}, "Is in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_PERL => 1, COMPILE_EXT => '.ttc']}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 1], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], ); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_PERL => 1, COMPILE_DIR => $test_dir2]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name$Template::Alloy::PERL_COMPILE_EXT", 1], ); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_PERL => 1, COMPILE_DIR => $test_dir2, COMPILE_EXT => '.ttc']}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 1], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$name}, "Is in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_PERL => 1, COMPILE_DIR => $test_dir2, COMPILE_EXT => '.ttc', GLOBAL_CACHE => 1]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], [$test_dir2, "$test_dir/$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 1], ); ok($Template::Alloy::GLOBAL_CACHE->{$name}, "Is in GLOBAL_CACHE"); ok($Template::Alloy::GLOBAL_CACHE->{$name}->{'_perl'}, "Has perl"); ###----------------------------------------------------------------### if ($has_encode) { my $encoding = 'UTF-8'; my $template = "[% blue %]BAR ¥"; pristine($template, $encoding); my $in = 'fü'; my $out = 'füBAR ¥'; process_ok($name => $out, {blue => $in, tt_config => [ENCODING => $encoding, COMPILE_PERL => 1, COMPILE_EXT => '.ttc']}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 1], ); process_ok($name => $out, {blue => $in, tt_config => [ENCODING => $encoding, COMPILE_PERL => 1, COMPILE_EXT => '.ttc']}); } ###----------------------------------------------------------------### print "### COMPILE_PERL => 2 ################################################\n"; pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_PERL => 2, COMPILE_EXT => '.ttc', GLOBAL_CACHE => 1]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok($Template::Alloy::GLOBAL_CACHE->{$name}, "Is in GLOBAL_CACHE"); ok(! $Template::Alloy::GLOBAL_CACHE->{$name}->{'_perl'}, "Doesn't Have perl"); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_PERL => 2, COMPILE_EXT => '.ttc', GLOBAL_CACHE => 1]}); test_cache([$test_dir, $name, 1], [$test_dir2, $name, 0], [$test_dir, "$name.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$name.ttc$Template::Alloy::PERL_COMPILE_EXT", 1], ); ok($Template::Alloy::GLOBAL_CACHE->{$name}, "Is in GLOBAL_CACHE"); ok($Template::Alloy::GLOBAL_CACHE->{$name}->{'_perl'}, "Has perl"); ###----------------------------------------------------------------### print "### STRING_REF #######################################################\n"; $name = \ "[% blue %]BAR"; my $file = Template::Alloy->string_id($name); pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue'}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$file}, "Not in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => 1]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok($Template::Alloy::GLOBAL_CACHE->{$file}, "Is in GLOBAL_CACHE"); ok(! $Template::Alloy::GLOBAL_CACHE->{$file}->{'_perl'}, "Doesn't Have perl"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => 1, CACHE_STR_REFS => 0]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$file}, "Not in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => 1, CACHE_STR_REFS => 0, COMPILE_PERL => 1]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$file}, "Not in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => 1, CACHE_STR_REFS => 0, COMPILE_PERL => 1, FORCE_STR_REF_PERL => 1]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok(! $Template::Alloy::GLOBAL_CACHE->{$file}, "Not in GLOBAL_CACHE"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => 1, COMPILE_PERL => 1]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok($Template::Alloy::GLOBAL_CACHE->{$file}, "Is in GLOBAL_CACHE"); ok($Template::Alloy::GLOBAL_CACHE->{$file}->{'_perl'}, "Has perl"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => 1, COMPILE_PERL => 2]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok($Template::Alloy::GLOBAL_CACHE->{$file}, "Is in GLOBAL_CACHE"); ok(! $Template::Alloy::GLOBAL_CACHE->{$file}->{'_perl'}, "Doesn't Have perl"); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [GLOBAL_CACHE => 1, COMPILE_PERL => 2]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 0], [$test_dir, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ok($Template::Alloy::GLOBAL_CACHE->{$file}, "Is in GLOBAL_CACHE"); ok($Template::Alloy::GLOBAL_CACHE->{$file}->{'_perl'}, "Now has perl"); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_DIR => $test_dir2]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir2, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir2, "$file$Template::Alloy::PERL_COMPILE_EXT", 0], ); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_EXT => '.ttc']}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$file.ttc$Template::Alloy::PERL_COMPILE_EXT", 0], ); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_DIR => $test_dir2, COMPILE_PERL => 1]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir2, "$file$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir2, "$file$Template::Alloy::PERL_COMPILE_EXT", 1], ); ###----------------------------------------------------------------### pristine(); process_ok($name => 'BlueBAR', {blue => 'Blue', tt_config => [COMPILE_EXT => '.ttc', COMPILE_PERL => 1]}); test_cache([$test_dir, $file, 0], [$test_dir2, $file, 0], [$test_dir, "$file.ttc$Template::Alloy::EXTRA_COMPILE_EXT", 1], [$test_dir, "$file.ttc$Template::Alloy::PERL_COMPILE_EXT", 1], ); ###----------------------------------------------------------------### print "### DONE #############################################################\n"; libtemplate-alloy-perl-1.022/t/05_tt_base.t000066400000000000000000003063461402714000200204550ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 05_tt_base.t - Test the basic language functionality of Template::Alloy - including many edge cases =cut use 5.006; our ($module, $is_tt, $compile_perl, $use_stream, $five_six, $five_eight, $has_tt_filter); BEGIN { $module = 'Template::Alloy'; if ($ENV{'USE_TT'} || grep {/tt/i} @ARGV) { $module = 'Template'; } $is_tt = $module eq 'Template'; $five_six = ($^V < 5.007) ? 1 : 0; $five_eight = ($^V < 5.009) ? 1 : 0; $has_tt_filter = !eval { require Template::Filters } ? 0 : $is_tt ? 1 : 3; }; use strict; use Test::More tests => (! $is_tt ? 3260 : 674) - (!$five_six ? 0 : 3*($is_tt ? 1 : 3)) + $has_tt_filter; use constant test_taint => 0 && eval { require Taint::Runtime }; use Data::Dumper; use_ok($module); Taint::Runtime::taint_start() if test_taint; my $test_dir = $0 .'.test_dir'; END { unlink "$test_dir/stream.out"; rmdir $test_dir } mkdir $test_dir, 0755; ok(-d $test_dir, "Got a test dir up and running"); ###----------------------------------------------------------------### sub process_ok { # process the value and say if it was ok my $str = shift; my $test = shift; my $vars = shift || {}; my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || []; push @$conf, (COMPILE_PERL => $compile_perl) if $compile_perl; push @$conf, (STREAM => 1) if $use_stream; my $obj = shift || $module->new(@$conf); # new object each time my $out = ''; my $line = (caller)[2]; delete $vars->{'tt_config'}; Taint::Runtime::taint(\$str) if test_taint; my $fh; if ($use_stream) { open($fh, ">", "$test_dir/stream.out") || return ok(0, "Line $line \"$str\" - Can't open stream.out: $!"); select $fh; } $obj->process(\$str, $vars, \$out); if ($use_stream) { select STDOUT; close $fh; open($fh, "<", "$test_dir/stream.out") || return ok(0, "Line $line \"$str\" - Can't read stream.out: $!"); $out = ''; read($fh, $out, -s "$test_dir/stream.out"); } my $ok = ref($test) ? $out =~ $test : $out eq $test; if ($ok) { ok(1, "Line $line \"$str\" => \"$out\""); return $obj; } else { ok(0, "Line $line \"$str\""); warn "# Was:\n$out\n# Should've been:\n$test\n"; print map {"$_\n"} grep { defined } $obj->error if $obj->can('error'); print $obj->dump_parse_tree(\$str) if $obj->can('dump_parse_tree'); my ($k,$v) = each %{ $obj->{'_documents'} }; #local $Data::Dumper::Terse = 1; #local $Data::Dumper::Indent = 0; #print " ".Data::Dumper::Dumper($v->{'_tree'}),"\n"; exit; } } ###----------------------------------------------------------------### ### set up some dummy packages for various tests local $INC{'MyTestPlugin/FooTest.pm'} = $0; local $INC{'FooTest2.pm'} = $0; { package MyTestPlugin::FooTest; sub load { $_[0] } sub new { my $class = shift; my $context = shift; # note the plugin style object that needs to shift off context my $args = shift || {}; return bless $args, $class; } sub bar { my $self = shift; return join('', map {"$_$self->{$_}"} sort keys %$self) } sub seven { 7 } sub many { return 1, 2, 3 } sub echo { my $self = shift; $_[0] } } { package FooTest2; use base qw(MyTestPlugin::FooTest); our $AUTOLOAD; sub new { my $class = shift; my $args = shift || {}; # note - no plugin context return bless $args, $class; } sub leave {} # hacks to allow tt to do the plugins passed via PLUGINS sub delocalise {} # hacks to allow tt to do the plugins passed via PLUGINS } my $cctx_last; my $cctx_data = {};; my $cctx = { last_context => sub { $cctx_last || '' }, call_me => sub { $cctx_last = (wantarray ? 'list' : defined(wantarray) ? 'scalar' : 'void').(shift || '') }, array => sub { return my @a = (1, 2, 3) }, array2 => sub { return my @a = (4) }, list => sub { return (5, 6, 7) }, scalar => sub { return 8 }, dataref => sub { return $cctx_data }, clear => sub { $cctx_last = undef; $cctx_data = {} }, }; { package CallContext; our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my $meth = ($AUTOLOAD =~ /::(\w+)$/) ? $1 : die "Invalid method"; return $cctx->{$meth}->(@_) if ref($cctx->{$meth}) eq 'CODE'; return $cctx->{$meth} if $cctx->{$meth}; die "Invalid method $AUTOLOAD\n" if $meth ne 'DESTROY'; } } my $cctxo = bless {}, 'CallContext'; my $obj = FooTest2->new; my $vars; my $stash = {foo => 'Stash', bingo => 'bango'}; $stash = Template::Stash->new($stash) if eval{require Template::Stash}; for my $opt ('normal', 'compile_perl', 'stream') { $compile_perl = ($opt eq 'compile_perl'); $use_stream = ($opt eq 'stream'); next if $is_tt && ($compile_perl || $use_stream); my $engine_option = "engine_option ($opt)"; ###----------------------------------------------------------------### print "### GET ############################################# $engine_option\n"; process_ok("[% foo %]" => ""); process_ok("[% foo %]" => "7", {foo => 7}); process_ok("[% foo %]" => "7", {tt_config => [VARIABLES => {foo => 7}]}); process_ok("[% foo %]" => "7", {tt_config => [PRE_DEFINE => {foo => 7}]}); process_ok("[% foo %]" => "Stash", {tt_config => [STASH => $stash]}); process_ok("[% foo %]" => "V", {tt_config => [VARIABLES => {foo => 'V'}, PRE_DEFINE => {foo => 'PD'}]}); process_ok("[% bar %]" => "", {tt_config => [VARIABLES => {foo => 'V'}, PRE_DEFINE => {bar => 'PD'}]}); process_ok("[% foo %]" => "Stash", {tt_config => [VARIABLES => {foo => 'V'}, STASH => $stash]}); process_ok("[% bar %]" => "", {tt_config => [VARIABLES => {bar => 'V'}, STASH => $stash]}); process_ok("[% foo %]" => "Stash", {tt_config => [STASH => $stash, VARIABLES => {foo => 'V'}]}); process_ok("[% foo %]" => "Stash", {tt_config => [STASH => $stash, PRE_DEFINE => {foo => 'PD'}]}); process_ok("[% foo %][% foo %][% foo %]" => "777", {foo => 7}); process_ok("[% foo() %]" => "7", {foo => 7}); process_ok("[% foo.bar %]" => ""); process_ok("[% foo.bar %]" => "", {foo => {}}); process_ok("[% foo.bar %]" => "7", {foo => {bar => 7}}); process_ok("[% foo().bar %]" => "7", {foo => {bar => 7}}); process_ok("[% foo.0 %]" => "7", {foo => [7, 2, 3]}); process_ok("[% foo.10 %]" => "", {foo => [7, 2, 3]}); process_ok("[% foo %]" => 7, {foo => sub { 7 }}); process_ok("[% foo(7) %]" => 7, {foo => sub { $_[0] }}); process_ok("[% foo.length %]" => 1, {foo => sub { 7 }}); process_ok("[% foo.0 %]" => 7, {foo => sub { return 7, 2, 3 }}); process_ok("[% foo(bar) %]" => 7, {foo => sub { $_[0] }, bar => 7}); process_ok("[% foo(bar.baz) %]" => 7,{foo => sub { $_[0] }, bar => {baz => 7}}); process_ok("[% foo.seven %]" => 7, {foo => $obj}); process_ok("[% foo.seven() %]" => 7, {foo => $obj}); process_ok("[% foo.seven.length %]" => 1, {foo => $obj}); process_ok("[% foo.echo(7) %]" => 7, {foo => $obj}); process_ok("[% foo.many.0 %]" => 1, {foo => $obj}); process_ok("[% foo.many.10 %]" => '',{foo => $obj}); process_ok("[% foo.nomethod %]" => '',{foo => $obj}); process_ok("[% foo.nomethod.0 %]" => '',{foo => $obj}); process_ok("[% GET foo %]" => ""); process_ok("[% GET foo %]" => "7", {foo => 7}); process_ok("[% GET foo.bar %]" => ""); process_ok("[% GET foo.bar %]" => "", {foo => {}}); process_ok("[% GET foo.bar %]" => "7", {foo => {bar => 7}}); process_ok("[% GET foo.0 %]" => "7", {foo => [7, 2, 3]}); process_ok("[% GET foo %]" => 7, {foo => sub { 7 }}); process_ok("[% GET foo(7) %]" => 7, {foo => sub { $_[0] }}); process_ok("[% \$name %]" => "", {name => 'foo'}); process_ok("[% \$name %]" => "7", {name => 'foo', foo => 7}); process_ok("[% \$name.bar %]" => "", {name => 'foo'}); process_ok("[% \$name.bar %]" => "", {name => 'foo', foo => {}}); process_ok("[% \$name.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); process_ok("[% \$name().bar %]" => "7", {name => 'foo', foo => {bar => 7}}); process_ok("[% \$name.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); process_ok("[% \$name %]" => 7, {name => 'foo', foo => sub { 7 }}); process_ok("[% \$name(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); process_ok("[% GET \$name %]" => "", {name => 'foo'}); process_ok("[% GET \$name %]" => "7", {name => 'foo', foo => 7}); process_ok("[% GET \$name.bar %]" => "", {name => 'foo'}); process_ok("[% GET \$name.bar %]" => "", {name => 'foo', foo => {}}); process_ok("[% GET \$name.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); process_ok("[% GET \$name.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); process_ok("[% GET \$name %]" => 7, {name => 'foo', foo => sub { 7 }}); process_ok("[% GET \$name(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); process_ok("[% \$name %]" => "", {name => 'foo foo', foo => 7}); process_ok("[% GET \$name %]" => "", {name => 'foo foo', foo => 7}); process_ok("[% \${name} %]" => "", {name => 'foo'}); process_ok("[% \${name} %]" => "7", {name => 'foo', foo => 7}); process_ok("[% \${name}.bar %]" => "", {name => 'foo'}); process_ok("[% \${name}.bar %]" => "", {name => 'foo', foo => {}}); process_ok("[% \${name}.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); process_ok("[% \${name}().bar %]" => "7", {name => 'foo', foo => {bar => 7}}); process_ok("[% \${name}.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); process_ok("[% \${name} %]" => 7, {name => 'foo', foo => sub { 7 }}); process_ok("[% \${name}(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); process_ok("[% GET \${name} %]" => "", {name => 'foo'}); process_ok("[% GET \${name} %]" => "7", {name => 'foo', foo => 7}); process_ok("[% GET \${name}.bar %]" => "", {name => 'foo'}); process_ok("[% GET \${name}.bar %]" => "", {name => 'foo', foo => {}}); process_ok("[% GET \${name}.bar %]" => "7", {name => 'foo', foo => {bar => 7}}); process_ok("[% GET \${name}.0 %]" => "7", {name => 'foo', foo => [7, 2, 3]}); process_ok("[% GET \${name} %]" => 7, {name => 'foo', foo => sub { 7 }}); process_ok("[% GET \${name}(7) %]" => 7, {name => 'foo', foo => sub { $_[0] }}); process_ok("[% \${name} %]" => "", {name => 'foo foo', foo => 7}); process_ok("[% GET \${name} %]" => "", {name => 'foo foo', foo => 7}); process_ok("[% GET \${'foo'} %]" => 'bar', {foo => 'bar'}); process_ok("[% foo.\$name %]" => '', {name => 'bar'}); process_ok("[% foo.\$name %]" => 7, {name => 'bar', foo => {bar => 7}}); process_ok("[% foo.\$name.baz %]" => '', {name => 'bar', bar => {baz => 7}}); process_ok("[% \"hi\" %]" => 'hi'); process_ok("[% \"hi %]" => ''); process_ok("[% 'hi' %]" => 'hi'); process_ok("[% 'hi %]" => ''); process_ok("[% \"\$foo\" %]" => '7', {foo => 7}); process_ok("[% \"hi \$foo\" %]" => 'hi 7', {foo => 7}); process_ok("[% \"hi \${foo}\" %]" => 'hi 7', {foo => 7}); process_ok("[% 'hi \$foo' %]" => 'hi $foo', {foo => 7}); process_ok("[% 'hi \${foo}' %]" => 'hi ${foo}', {foo => 7}); process_ok("[% 7 %]" => 7); process_ok("[% -7 %]" => -7); process_ok("[% \"hi \${foo.seven}\" %]" => 'hi 7', {foo => $obj}); process_ok("[% \"hi \${foo.echo(7)}\" %]" => 'hi 7', {foo => $obj}); process_ok("[% _foo %]2" => '2', {_foo => 1}); process_ok("[% \$bar %]2" => '2', {_foo => 1, bar => '_foo'}); process_ok("[% __foo %]2" => '2', {__foo => 1}); process_ok("[% qw/Foo Bar Baz/.0 %]" => 'Foo') if ! $is_tt; process_ok('[% [0..10].-1 %]' => '10') if ! $is_tt; process_ok('[% [0..10].${ 2.3 } %]' => '2') if ! $is_tt; process_ok("[% (1 + 2)() %]" => ''); # parse error process_ok("[% (1 + 2) %]" => '3'); process_ok("[% (a) %]" => '2', {a => 2}); process_ok("[% ('foo') %]" => 'foo'); process_ok("[% (a(2)) %]" => '2', {a => sub { $_[0] }}); # make sure JS stub functions don't interfere with existing uses process_ok("[% JS 3 %]" => "3") if ! $is_tt; process_ok("[% JS 3 %]" => "43", {JS => 4}) if ! $is_tt; process_ok("[% JS; 3; END %]" => ""); ###----------------------------------------------------------------### print "### SET ############################################# $engine_option\n"; process_ok("[% SET foo bar %][% foo %]" => ''); process_ok("[% SET foo = 1 %][% foo %]" => '1'); process_ok("[% SET foo = 1 bar = 2 %][% foo %][% bar %]" => '12'); process_ok("[% SET foo bar = 1 %][% foo %]" => ''); process_ok("[% SET foo = 1 ; bar = 1 %][% foo %]" => '1'); process_ok("[% SET foo = 1 %][% SET foo %][% foo %]" => ''); process_ok("[% SET foo = [] %][% foo.0 %]" => ""); process_ok("[% SET foo = [1, 2, 3] %][% foo.1 %]" => 2); process_ok("[% SET foo = {} %][% foo.0 %]" => ""); process_ok("[% SET foo = {1 => 2} %][% foo.1 %]" => "2") if ! $is_tt; process_ok("[% SET foo = {'1' => 2} %][% foo.1 %]" => "2"); process_ok("[% SET name = 1 %][% SET foo = name %][% foo %]" => "1"); process_ok("[% SET name = 1 %][% SET foo = \$name %][% foo %]" => ""); process_ok("[% SET name = 1 %][% SET foo = \${name} %][% foo %]" => ""); process_ok("[% SET name = 1 %][% SET foo = \"\$name\" %][% foo %]" => "1"); process_ok("[% SET name = 1 foo = name %][% foo %]" => '1'); process_ok("[% SET name = 1 %][% SET foo = {\$name => 2} %][% foo.1 %]" => "2"); process_ok("[% SET name = 1 %][% SET foo = {\"\$name\" => 2} %][% foo.1 %]" => "2") if ! $is_tt; process_ok("[% SET name = 1 %][% SET foo = {\${name} => 2} %][% foo.1 %]" => "2"); process_ok("[% SET name = 7 %][% SET foo = {'2' => name} %][% foo.2 %]" => "7"); process_ok("[% SET name = 7 %][% SET foo = {'2' => \"\$name\"} %][% foo.2 %]" => "7"); process_ok("[% SET name = 7 %][% SET foo = [1, name, 3] %][% foo.1 %]" => "7"); process_ok("[% SET name = 7 %][% SET foo = [1, \"\$name\", 3] %][% foo.1 %]" => "7"); process_ok("[% SET foo = { bar => { baz => [0, 7, 2] } } %][% foo.bar.baz.1 %]" => "7"); process_ok("[% SET foo.bar = 1 %][% foo.bar %]" => '1'); process_ok("[% SET foo.bar.baz.bing = 1 %][% foo.bar.baz.bing %]" => '1'); process_ok("[% SET foo.bar.2 = 1 %][% foo.bar.2 %] [% foo.bar.size %]" => '1 1'); process_ok("[% SET foo.bar = [] %][% SET foo.bar.2 = 1 %][% foo.bar.2 %] [% foo.bar.size %]" => '1 3'); process_ok("[% SET name = 'two' %][% SET \$name = 3 %][% two %]" => 3); process_ok("[% SET name = 'two' %][% SET \${name} = 3 %][% two %]" => 3); process_ok("[% SET name = 2 %][% SET foo.\$name = 3 %][% foo.2 %]" => 3); process_ok("[% SET name = 2 %][% SET foo.\$name = 3 %][% foo.\$name %]" => 3); process_ok("[% SET name = 2 %][% SET foo.\${name} = 3 %][% foo.2 %]" => 3); process_ok("[% SET name = 2 %][% SET foo.\${name} = 3 %][% foo.2 %]" => 3); process_ok("[% SET name = 'two' %][% SET \$name.foo = 3 %][% two.foo %]" => 3); process_ok("[% SET name = 'two' %][% SET \${name}.foo = 3 %][% two.foo %]" => 3); process_ok("[% SET name = 'two' %][% SET foo.\$name.foo = 3 %][% foo.two.foo %]" => 3); process_ok("[% SET name = 'two' %][% SET foo.\${name}.foo = 3 %][% foo.two.foo %]" => 3); process_ok("[% SET foo = [1..10] %][% foo.6 %]" => 7); process_ok("[% SET foo = [10..1] %][% foo.6 %]" => ''); process_ok("[% SET foo = [-10..-1] %][% foo.6 %]" => -4); process_ok("[% SET foo = [1..10, 21..30] %][% foo.12 %]" => 23) if ! $is_tt; process_ok("[% SET foo = [..100] bar = 7 %][% bar %][% foo.0 %]" => ''); process_ok("[% SET foo = [100..] bar = 7 %][% bar %][% foo.0 %]" => ''); process_ok("[% SET foo = ['a'..'z'] %][% foo.6 %]" => 'g'); process_ok("[% SET foo = ['z'..'a'] %][% foo.6 %]" => ''); process_ok("[% SET foo = ['a'..'z'].reverse %][% foo.6 %]" => 't') if ! $is_tt; process_ok("[% foo = 1 %][% foo %]" => '1'); process_ok("[% foo = 1 ; bar = 2 %][% foo %][% bar %]" => '12'); process_ok("[% foo.bar = 2 %][% foo.bar %]" => '2'); process_ok('[% a = "a" %]|[% (b = a) %]|[% a %]|[% b %]' => '|a|a|a'); process_ok('[% a = "a" %][% (c = (b = a)) %][% a %][% b %][% c %]' => 'aaaa'); process_ok("[% a = qw{Foo Bar Baz} ; a.2 %]" => 'Baz') if ! $is_tt; process_ok("[% _foo = 1 %][% _foo %]2" => '2'); process_ok("[% foo._bar %]2" => '2', {foo => {_bar =>1}}); ###----------------------------------------------------------------### print "### multiple statements in same tag ################# $engine_option\n"; process_ok("[% foo; %]" => '1', {foo => 1}); process_ok("[% GET foo; %]" => '1', {foo => 1}); process_ok("[% GET foo; GET foo %]" => '11', {foo => 1}); process_ok("[% GET foo GET foo %]" => '11', {foo => 1}) if ! $is_tt; process_ok("[% GET foo GET foo %]" => '', {foo => 1, tt_config => [SEMICOLONS => 1]}); process_ok("[% foo = 1 bar = 2 %][% foo %][% bar %]" => '12'); process_ok("[% foo = 1 bar = 2 %][% foo = 3 bar %][% foo %][% bar %]" => '232') if ! $is_tt; process_ok("[% a = 1 a = a + 2 a %]" => '3') if ! $is_tt; process_ok("[% foo = 1 bar = 2 %][% foo %][% bar %]" => '', {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; process_ok("[% foo = 1 bar = 2 %][% foo = 3 bar %][% foo %][% bar %]" => '', {tt_config => [SEMICOLONS => 1]}); process_ok("[% a = 1 a = a + 2 a %]" => '', {tt_config => [SEMICOLONS => 1]}); ###----------------------------------------------------------------### print "### CALL / DEFAULT ################################## $engine_option\n"; process_ok("[% DEFAULT foo = 7 %][% foo %]" => 7); process_ok("[% SET foo = 5 %][% DEFAULT foo = 7 %][% foo %]" => 5); process_ok("[% DEFAULT foo.bar.baz.bing = 6 %][% foo.bar.baz.bing %]" => 6); my $t = 0; process_ok("[% foo %]" => 'hi', {foo => sub {$t++; 'hi'}}); process_ok("[% GET foo %]" => 'hi', {foo => sub {$t++; 'hi'}}); process_ok("[% CALL foo %]" => '', {foo => sub {$t++; 'hi'}}); ok($t == 3, "CALL method actually called var"); die if $t != 3; ###----------------------------------------------------------------### print "### scalar vmethods ################################# $engine_option\n"; process_ok("[% n.0 %]" => '7', {n => 7}) if ! $is_tt; process_ok("[% n.abs %]" => '7', {n => 7}) if ! $is_tt; process_ok("[% n.abs %]" => '7', {n => -7}) if ! $is_tt; process_ok("[% n.atan2.substr(0, 6) %]" => '1.5707', {n => 7}) if ! $is_tt; process_ok("[% (4 * n.atan2(1)).substr(0, 7) %]" => '3.14159', {n => 1}) if ! $is_tt; process_ok("[% n.chunk(3).join %]" => 'abc def g', {n => 'abcdefg'}); process_ok("[% n.chunk(-3).join %]" => 'a bcd efg', {n => 'abcdefg'}); process_ok("[% n|collapse %]" => "a b", {n => ' a b '}); # TT2 filter process_ok("[% n.cos.substr(0,5) %]" => "1", {n => 0}) if ! $is_tt; process_ok("[% n.cos.substr(0,5) %]" => "0.707", {n => atan2(1,1)}) if ! $is_tt; process_ok("[% n.defined %]" => "1", {n => ''}); process_ok("[% n.defined %]" => "", {n => undef}); process_ok("[% n.defined %]" => "1", {n => '1'}); process_ok("[% n.dquote %]" => "(\\n|\\\\|\\\")", {n => "(\n|\\|\")"}); process_ok("[% n.exp.substr(0,5) %]" => "2.718", {n => 1}) if ! $is_tt; process_ok("[% n.exp.log.substr(0,5) %]" => "8", {n => 8}) if ! $is_tt; process_ok("[% n.fmt %]" => '7', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%02d') %]" => '07', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%0*d', 3) %]" => '007', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('(%s)') %]" => "(a\nb)", {n => "a\nb"}) if ! $is_tt; process_ok("[% n|format('%02d') %]" => '07', {n => 7}); # TT2 filter process_ok("[% n|format('%0*d', 3) %]" => '007', {n => 7}) if ! $is_tt; process_ok("[% n|format('(%s)') %]" => "(a)\n(b)", {n => "a\nb"}); # TT2 filter process_ok("[% n.hash.items.1 %]" => "b", {n => {a => "b"}}); process_ok("[% n.hex %]" => "255", {n => "FF"}) if ! $is_tt; process_ok("[% n|html %]" => "&<>"'", {n => '&<>"\''}); # TT2 filter process_ok("[% n|html_entity %]" => "&", {n => '&'}) if $has_tt_filter; # TT2 native filter process_ok("[% n|xml %]" => "&<>"'", {n => '&<>"\''}); # TT2 filter process_ok("[% n|indent %]" => " a\n b", {n => "a\nb"}); # TT2 filter process_ok("[% n|indent(2) %]" => " a\n b", {n => "a\nb"}); # TT2 filter process_ok("[% n|indent('wow ') %]" => "wow a\nwow b", {n => "a\nb"}); # TT2 filter process_ok("[% n.int %]" => "123", {n => "123.234"}) if ! $is_tt; process_ok("[% n.int %]" => "123", {n => "123gggg"}) if ! $is_tt; process_ok("[% n.int %]" => "0", {n => "ff123.234"}) if ! $is_tt; process_ok("[% n.item %]" => '7', {n => 7}); process_ok("[% n.lc %]" => 'abc', {n => "ABC"}) if ! $is_tt; process_ok("[% n|lcfirst %]" => 'fOO', {n => "FOO"}); # TT2 filter process_ok("[% n.length %]" => 3, {n => "abc"}); process_ok("[% n.list.0 %]" => 'abc', {n => "abc"}); process_ok("[% n.log.substr(0,5) %]" => "4.605", {n => 100}) if ! $is_tt; process_ok("[% n|lower %]" => 'abc', {n => "ABC"}); # TT2 filter process_ok("[% n.match('foo').join %]" => '', {n => "bar"}); process_ok("[% n.match('foo').join %]" => '1', {n => "foo"}); process_ok("[% n.match('foo',1).join %]" => 'foo', {n => "foo"}); process_ok("[% n.match('(foo)').join %]" => 'foo', {n => "foo"}); process_ok("[% n.match('(foo)').join %]" => 'foo', {n => "foofoo"}); process_ok("[% n.match('(foo)',1).join %]" => 'foo foo', {n => "foofoo"}); process_ok("[% n.null %]" => '', {n => "abc"}); process_ok("[% n.oct %]" => "255", {n => "377"}) if ! $is_tt; process_ok("[% n.rand %]" => qr{^\d+\.\d+}, {n => "2"}) if ! $is_tt; process_ok("[% n.rand %]" => qr{^\d+\.\d+}, {n => "ab"}) if ! $is_tt; process_ok("[% n.remove('bc') %]" => "a", {n => "abc"}); process_ok("[% n.remove('bc') %]" => "aa", {n => "abcabc"}); process_ok("[% n.repeat %]" => '1', {n => 1}) if ! $is_tt; # tt2 virtual method defaults to 0 process_ok("[% n.repeat(0) %]" => '', {n => 1}); process_ok("[% n.repeat(1) %]" => '1', {n => 1}); process_ok("[% n.repeat(2) %]" => '11', {n => 1}); process_ok("[% n.repeat(2,'|') %]" => '1|1', {n => 1}) if ! $is_tt; process_ok("[% n.replace('foo', 'bar') %]" => 'barbar', {n => 'foofoo'}); process_ok("[% n.replace('(foo)', 'bar\$1') %]" => 'barfoobarfoo', {n => 'foofoo'}) if ! $is_tt; process_ok("[% n.replace('foo', 'bar', 0) %]" => 'barfoo', {n => 'foofoo'}) if ! $is_tt; process_ok("[% n.search('foo') %]" => '', {n => "bar"}); process_ok("[% n.search('foo') %]" => '1', {n => "foo"}); process_ok("[% n.sin.substr(0,5) %]" => "0", {n => 0}) if ! $is_tt; process_ok("[% n.sin.substr(0,5) %]" => "1", {n => 2*atan2(1,1)}) if ! $is_tt; process_ok("[% n.size %]" => '1', {n => "foo"}); process_ok("[% n.split.join('|') %]" => "abc", {n => "abc"}); process_ok("[% n.split.join('|') %]" => "a|b|c", {n => "a b c"}); process_ok("[% n.split.join('|') %]" => "a|b|c", {n => "a b c"}); process_ok("[% n.split(u,2).join('|') %]" => "a|b c", {n => "a b c", u => undef}) if ! $is_tt; process_ok("[% n.split(u,2).join('|') %]" => "a| b c", {n => "a b c", u => undef}) if $is_tt; process_ok("[% n.split('/').join('|') %]" => "a|b|c", {n => "a/b/c"}); process_ok("[% n.split('/', 2).join('|') %]" => "a|b/c", {n => "a/b/c"}); process_ok("[% n.sprintf(7) %]" => '7', {n => '%d'}) if ! $is_tt; process_ok("[% n.sprintf(3, 7, 12) %]" => '007 12', {n => '%0*d %d'}) if ! $is_tt; process_ok("[% n.sqrt %]" => "3", {n => 9}) if ! $is_tt; process_ok("[% n.squote %]" => "(\n|\\\\|\\\')", {n => "(\n|\\|\')"}); process_ok("[% n.srand; 12 %]" => "12", {n => 9}) if ! $is_tt; process_ok("[% n.stderr %]" => "", {n => "# testing stderr ... ok\r"}); process_ok("[% n|trim %]" => "a b", {n => ' a b '}); # TT2 filter process_ok("[% n.uc %]" => 'FOO', {n => "foo"}) if ! $is_tt; # TT2 filter process_ok("[% n|ucfirst %]" => 'Foo', {n => "foo"}); # TT2 filter process_ok("[% n|upper %]" => 'FOO', {n => "foo"}); # TT2 filter process_ok("[% n|uri %]" => 'a%20b', {n => "a b"}); # TT2 filter process_ok("[% n.fmt('%c') %]" => 'B', {n => 66}) if ! $is_tt; process_ok("[% n.fmt('%3X') %]" => ' C', {n => 12}) if ! $is_tt; process_ok("[% n.fmt('%-3X') %]" => 'C ', {n => 12}) if ! $is_tt; process_ok("[% n.fmt('%03X') %]" => '00C', {n => 12}) if ! $is_tt; process_ok("[% n.fmt('%03X') %]" => '00C', {n => 12}) if ! $is_tt; process_ok("[% n.fmt('%#03X') %]" => '0XC', {n => 12}) if ! $is_tt; process_ok("[% n.fmt('%#07X') %]" => '0X0000C', {n => 12}) if ! $is_tt; process_ok("[% n.fmt('%o') %]" => '10', {n => 8}) if ! $is_tt; process_ok("[% n.fmt('%#o') %]" => '010', {n => 8}) if ! $is_tt; process_ok("[% n.fmt('%#o') %]" => '0', {n => 0}) if ! $is_tt; process_ok("[% n.fmt('%02d') %]" => '07', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%04.2d') %]" => ($^V < 5.008009 ? '0007' : ' 07'), {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%+04.2d') %]" => ($^V < 5.008009 ? '+007' : ' +07'), {n => 7}) if ! $is_tt; process_ok("[% n.fmt('% 04.2d') %]" => ($^V < 5.008009 ? ' 007' : ' 07'), {n => 7}) if ! $is_tt; process_ok("[% n.fmt('% +04.2d') %]" => ($^V < 5.008009 ? '+007' : ' +07'), {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%02f') %]" => '7.000000', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%04.2f') %]" => '7.00', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%05.2f') %]" => '07.00', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('% 5.2f') %]" => ' 7.00', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%+04.2f') %]" => '+7.00', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('% 04.2f') %]" => ' 7.00', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('% +6.2f') %]" => ' +7.00', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%0+6.2f') %]" => '+07.00', {n => 7}) if ! $is_tt; process_ok("[% n.fmt('%.5g') %]" => '12345', {n => 12345}) if ! $is_tt; process_ok("[% n.fmt('%.5g') %]" => qr/^1\.2346e\+0*6$/, {n => 1234567}) if ! $is_tt; ###----------------------------------------------------------------### print "### list vmethods ################################### $engine_option\n"; process_ok("[% a.defined %]" => '1', {a => [2,3]}); process_ok("[% a.defined(1) %]" => '1', {a => [2,3]}); process_ok("[% a.defined(3) %]" => '', {a => [2,3]}); process_ok("[% a.first %]" => '2', {a => [2..10]}); process_ok("[% a.first(3).join %]" => '2 3 4', {a => [2..10]}); process_ok("[% a.fmt %]" => '2 3', {a => [2,3]}) if ! $is_tt; process_ok("[% a.fmt('%02d') %]" => '02 03', {a => [2,3]}) if ! $is_tt; process_ok("[% a.fmt('%02d',' ') %]" => '02 03', {a => [2,3]}) if ! $is_tt; process_ok("[% a.fmt('%02d','|') %]" => '02|03', {a => [2,3]}) if ! $is_tt; process_ok("[% a.fmt('%0*d','|', 3) %]" => '002|003', {a => [2,3]}) if ! $is_tt; process_ok("[% a.grep.join %]" => '2 3', {a => [2,3]}); process_ok("[% a.grep(2).join %]" => '2', {a => [2,3]}); process_ok("[% a.grep(->(n){n % 2}).join %]" => '3 5 7', {a => [2..7]}) if ! $is_tt; process_ok("[% a.hash.items.join %]" => '2 3', {a => [2,3]}); process_ok("[% a.hash(5).items.sort.join %]" => '2 3 5 6', {a => [2,3]}); process_ok("[% a.import(5) %]|[% a.join %]" => '|2 3', {a => [2,3]}) if ! $is_tt; process_ok("[% a.import(5) %]|[% a.join %]" => qr{^ARRAY.+|2 3$ }x, {a => [2,3]}) if $is_tt; process_ok("[% a.import([5]) %]|[% a.join %]" => '|2 3 5', {a => [2,3]}) if ! $is_tt; process_ok("[% a.import([5]) %]|[% a.join %]" => qr{ARRAY.+|2 3 5$ }x, {a => [2,3]}) if $is_tt; process_ok("[% a.item %]" => '2', {a => [2,3]}); process_ok("[% a.item(1) %]" => '3', {a => [2,3]}); process_ok("[% a.join %]" => '2 3', {a => [2,3]}); process_ok("[% a.join('|') %]" => '2|3', {a => [2,3]}); process_ok("[% a.last %]" => '10', {a => [2..10]}); process_ok("[% a.last(3).join %]" => '8 9 10', {a => [2..10]}); process_ok("[% a.list.join %]" => '2 3', {a => [2, 3]}); process_ok("[% a.map(->(n){ n.repeat(3) }).join %]" => '222 333', {a => [2,3]}) if ! $is_tt; process_ok("[% a.max %]" => '1', {a => [2, 3]}); process_ok("[% a.merge(5).join %]" => '2 3', {a => [2,3]}); process_ok("[% a.merge([5]).join %]" => '2 3 5', {a => [2,3]}); process_ok("[% a.merge([5]).null %][% a.join %]" => '2 3', {a => [2,3]}); process_ok("[% a.nsort.join %]" => '1 2 3', {a => [2, 3, 1]}); process_ok("[% a.nsort('b').0.b %]" => '7', {a => [{b => 23}, {b => 7}]}); process_ok("[% a.pop %][% a.join %]" => '32', {a => [2, 3]}); process_ok("[% a.push(3) %][% a.join %]" => '2 3 3', {a => [2, 3]}); process_ok("[% a.pick %]" => qr{ ^[23]$ }x, {a => [2, 3]}) if ! $is_tt; process_ok("[% a.pick(5).join('') %]" => qr{ ^[23]{5}$ }x, {a => [2, 3]}) if ! $is_tt; process_ok("[% a.reverse.join %]" => '3 2', {a => [2, 3]}); process_ok("[% a.shift %][% a.join %]" => '23', {a => [2, 3]}); process_ok("[% a.size %]" => '2', {a => [2, 3]}); process_ok("[% a.slice.join %]" => '2 3 4 5', {a => [2..5]}); process_ok("[% a.slice(2).join %]" => '4 5', {a => [2..5]}); process_ok("[% a.slice(0,2).join %]" => '2 3 4', {a => [2..5]}); process_ok("[% a.sort.join %]" => '1 2 3', {a => [2, 3, 1]}); process_ok("[% a.sort('b').0.b %]" => 'wee', {a => [{b => "wow"}, {b => "wee"}]}); process_ok("[% c.sort(->(a,b){ a.k cmp b.k }).map(->{this.k}).join %]" => 'a wee wow', {c => [{k => "wow"}, {k => "wee"}, {k => "a"}]}) if ! $is_tt; process_ok("[% a.splice.join %]|[% a.join %]" => '2 3 4 5|', {a => [2..5]}); process_ok("[% a.splice(2).join %]|[% a.join %]" => '4 5|2 3', {a => [2..5]}); process_ok("[% a.splice(0,2).join %]|[% a.join %]" => '2 3|4 5', {a => [2..5]}); process_ok("[% a.splice(0,2,'hrm').join %]|[% a.join %]" => '2 3|hrm 4 5', {a => [2..5]}); process_ok("[% a.unique.join %]" => '2 3', {a => [2,3,3,3,2]}); process_ok("[% a.unshift(3) %][% a.join %]" => '3 2 3', {a => [2, 3]}); ###----------------------------------------------------------------### print "### hash vmethods ################################### $engine_option\n"; process_ok("[% h.defined %]" => "1", {h => {}}); process_ok("[% h.defined('a') %]" => "1", {h => {a => 1}}); process_ok("[% h.defined('b') %]" => "", {h => {a => 1}}); process_ok("[% h.defined('a') %]" => "", {h => {a => undef}}); process_ok("[% h.delete('a') %]|[% h.keys.0 %]" => "|b", {h => {a => 1, b=> 2}}); process_ok("[% h.delete('a', 'b').join %]|[% h.keys.0 %]" => "|", {h => {a => 1, b=> 2}}); process_ok("[% h.delete('a', 'c').join %]|[% h.keys.0 %]" => "|b", {h => {a => 1, b=> 2}}); process_ok("[% h.each.sort.join %]" => "1 2 a b", {h => {a => 1, b=> 2}}); process_ok("[% h.exists('a') %]" => "1", {h => {a => 1}}); process_ok("[% h.exists('b') %]" => "", {h => {a => 1}}); process_ok("[% h.exists('a') %]" => "1", {h => {a => undef}}); process_ok("[% h.fmt %]" => "b\tB\nc\tC", {h => {b => "B", c => "C"}}) if ! $is_tt; process_ok("[% h.fmt('%s => %s') %]" => "b => B\nc => C", {h => {b => "B", c => "C"}}) if ! $is_tt; process_ok("[% h.fmt('%s => %s', '|') %]" => "b => B|c => C", {h => {b => "B", c => "C"}}) if ! $is_tt; process_ok("[% h.fmt('%*s=>%s', '|', 3) %]" => " b=>B| c=>C", {h => {b => "B", c => "C"}}) if ! $is_tt; process_ok("[% h.fmt('%*s=>%*s', '|', 3, 4) %]" => " b=> B| c=> C", {h => {b => "B", c => "C"}}) if ! $is_tt; process_ok("[% h.hash.fmt %]" => "b\tB\nc\tC", {h => {b => "B", c => "C"}}) if ! $is_tt; process_ok("[% h.import('a') %]|[% h.items.sort.join %]" => "|b B c C", {h => {b => "B", c => "C"}}); process_ok("[% h.import({'b' => 'boo'}) %]|[% h.items.sort.join %]" => "|b boo c C", {h => {b => "B", c => "C"}}); process_ok("[% h.item('a') %]" => 'A', {h => {a => 'A'}}); process_ok("[% h.item('_a') %]" => '', {h => {_a => 'A'}}) if ! $is_tt; process_ok("[% h.items.sort.join %]" => "1 2 a b", {h => {a => 1, b=> 2}}); process_ok("[% h.keys.sort.join %]" => "a b", {h => {a => 1, b=> 2}}); process_ok("[% h.list('each').sort.join %]" => "1 2 a b", {h => {a => 1, b=> 2}}); process_ok("[% h.list('keys').sort.join %]" => "a b", {h => {a => 1, b=> 2}}); process_ok("[% h.list('pairs').0.items.sort.join %]" => "1 a key value", {h => {a => 1, b=> 2}}); process_ok("[% h.list('values').sort.join %]" => "1 2", {h => {a => 1, b=> 2}}); process_ok("[% h.null %]" => "", {h => {}}); process_ok("[% h.nsort.join %]" => "b a", {h => {a => 7, b => 2}}); process_ok("[% h.pairs.0.items.sort.join %]" => "1 a key value", {h => {a => 1, b=> 2}}); process_ok("[% h.size %]" => "2", {h => {a => 1, b=> 2}}); process_ok("[% h.sort.join %]" => "b a", {h => {a => "BBB", b => "A"}}); process_ok("[% h.values.sort.join %]" => "1 2", {h => {a => 1, b=> 2}}); ###----------------------------------------------------------------### print "### vmethods as functions ########################### $engine_option\n"; process_ok("[% sprintf('%d %d', 7, 8) %] d" => '7 8 d') if ! $is_tt; process_ok("[% sprintf('%d %d', 7, 8) %] d" => '7 8 d', {tt_config => [VMETHOD_FUNCTIONS => 1]}) if ! $is_tt; process_ok("[% sprintf('%d %d', 7, 8) %] d" => ' d', {tt_config => [VMETHOD_FUNCTIONS => 0]}) if ! $is_tt; process_ok("[% int(2.234) %]" => '2') if ! $is_tt; process_ok("[% int(2.234) ; int = 44; int(2.234) ; SET int; int(2.234) %]" => '2442') if ! $is_tt; # hide and unhide ###----------------------------------------------------------------### print "### more virtual methods / filters ################## $engine_option\n"; process_ok("[% [0 .. 10].reverse.1 %]" => 9) if ! $is_tt; process_ok("[% {a => 'A'}.a %]" => 'A') if ! $is_tt; process_ok("[% 'This is a string'.length %]" => 16) if ! $is_tt; process_ok("[% 123.length %]" => 3) if ! $is_tt; process_ok("[% 123.2.length %]" => 5) if ! $is_tt; process_ok("[% -123.2.length %]" => -5) if ! $is_tt; # the - doesn't bind as tight as the dot methods process_ok("[% (-123.2).length %]" => 6) if ! $is_tt; process_ok("[% a = 23; a.0 %]" => 23) if ! $is_tt; # '0' is a scalar_op process_ok('[% 1.rand %]' => qr/^0\.\d+(?:e-?\d+)?$/) if ! $is_tt; process_ok("[% n.size %]", => 'SIZE', {n => {size => 'SIZE', a => 'A'}}); process_ok("[% n|size %]", => '2', {n => {size => 'SIZE', a => 'A'}}) if ! $is_tt; # tt2 | is alias for FILTER process_ok('[% "1" | indent(2) %]' => ' 1'); process_ok("[% n FILTER size %]", => '1', {n => {size => 'SIZE', a => 'A'}}) if ! $is_tt; # tt2 doesn't have size process_ok("[% n FILTER repeat %]" => '1', {n => 1}); process_ok("[% n FILTER repeat(0) %]" => '', {n => 1}); process_ok("[% n FILTER repeat(1) %]" => '1', {n => 1}); process_ok("[% n FILTER repeat(2) %]" => '11', {n => 1}); process_ok("[% n FILTER repeat(2,'|') %]" => '1|1', {n => 1}) if ! $is_tt; process_ok("[% n FILTER echo = repeat(2) %][% n FILTER echo %]" => '1111', {n => 1}); process_ok("[% n FILTER echo = repeat(2) %][% n | echo %]" => '1111', {n => 1}); process_ok("[% n FILTER echo = repeat(2) %][% n|echo.length %]" => '112', {n => 1}) if ! $is_tt; process_ok("[% n FILTER echo = repeat(2) %][% n FILTER \$foo %]" => '1111', {n => 1, foo => 'echo'}); process_ok("[% n FILTER echo = repeat(2) %][% n | \$foo %]" => '1111', {n => 1, foo => 'echo'}); process_ok("[% n FILTER echo = repeat(2) %][% n|\$foo.length %]" => '112', {n => 1, foo => 'echo'}) if ! $is_tt; process_ok('[% "hi" FILTER $foo %]' => 'hihi', {foo => sub {sub {$_[0]x2}}}); # filter via a passed var process_ok('[% FILTER $foo %]hi[% END %]' => 'hihi', {foo => sub {sub {$_[0]x2}}}); # filter via a passed var process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => sub {$_[0]x2}}]}); process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {$_[0]x2},0]}]}); process_ok('[% "hi" FILTER foo(2) %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {my$a=$_[1];sub{$_[0]x$a}},1]}]}); process_ok('[% ["0".."9"].pick %]' => qr/^[0-9]/) if ! $is_tt; process_ok("[% ' ' | uri %]" => '%20'); process_ok('[% "one".fmt %]' => "one") if ! $is_tt; process_ok('[% 2.fmt("%02d") %]' => "02") if ! $is_tt; process_ok('[% [1..3].fmt %]' => "1 2 3") if ! $is_tt; process_ok('[% [1..3].fmt("%02d") %]' => '01 02 03') if ! $is_tt; process_ok('[% [1..3].fmt("%s", ", ") %]' => '1, 2, 3') if ! $is_tt; process_ok('[% {a => "B", c => "D"}.fmt %]' => "a\tB\nc\tD") if ! $is_tt; process_ok('[% {a => "B", c => "D"}.fmt("%s:%s") %]' => "a:B\nc:D") if ! $is_tt; process_ok('[% {a => "B", c => "D"}.fmt("%s:%s", "; ") %]' => "a:B; c:D") if ! $is_tt; process_ok('[% 1|format("%s") %]' => '1') if ! $is_tt; process_ok('[% 1|format("%*s", 6) %]' => ' 1') if ! $is_tt; process_ok('[% 1|format("%-*s", 6) %]' => '1 ') if ! $is_tt; process_ok('[% 1.fmt("%-*s", 6) %]' => '1 ') if ! $is_tt; process_ok('[% [1,2].fmt("%-*s", "|", 6) %]' => '1 |2 ') if ! $is_tt; process_ok('[% {1=>2,3=>4}.fmt("%*s:%*s", "|", 3, 3) %]' => ' 1: 2| 3: 4') if ! $is_tt; process_ok('[% foo %]', => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; process_ok('[% "&" %]', => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; process_ok('[% foo | none %]', => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; process_ok('[% foo.bar %]', => '&', {foo => {bar => '&'}, tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; process_ok('[% foo.bar | none %]', => '&', {foo => {bar => '&'}, tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; process_ok('[% GET foo %]', => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; process_ok('[% GET "&" %]', => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; process_ok('[% GET foo | none %]', => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; process_ok('[% Text.length(foo) %]', => '1', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if ! $is_tt; ###----------------------------------------------------------------### print "### virtual objects ################################# $engine_option\n"; process_ok('[% a = "foobar" %][% Text.length(a) %]' => 6) if ! $is_tt; process_ok('[% a = [1 .. 10] %][% List.size(a) %]' => 10) if ! $is_tt; process_ok('[% a = {a=>"A", b=>"B"} ; Hash.size(a) %]' => 2) if ! $is_tt; process_ok('[% a = Text.new("This is a string") %][% a.length %]' => 16) if ! $is_tt; process_ok('[% a = List.new("one", "two", "three") %][% a.size %]' => 3) if ! $is_tt; process_ok('[% a = Hash.new("one", "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; process_ok('[% a = Hash.new(one = "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; process_ok('[% a = Hash.new(one => "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; process_ok('[% {a => 1, b => 2} | Hash.keys | List.sort | List.join(", ") %]' => 'a, b') if ! $is_tt; ###----------------------------------------------------------------### print "### chomping ######################################## $engine_option\n"; process_ok(" [% foo %]" => ' '); process_ok(" [%- foo %]" => ''); process_ok("\n[%- foo %]" => ''); process_ok("\n [%- foo %]" => ''); process_ok("\n\n[%- foo %]" => "\n"); process_ok(" \n\n[%- foo %]" => " \n"); process_ok(" \n[%- foo %]" => " ") if ! $is_tt; process_ok(" \n \n[%- foo %]" => " \n ") if ! $is_tt; process_ok("[% 7 %] " => '7 '); process_ok("[% 7 -%] " => '7 '); process_ok("[% 7 -%]\n" => '7'); process_ok("[% 7 -%] \n" => '7'); process_ok("[% 7 -%]\n " => '7 '); process_ok("[% 7 -%]\n\n\n" => "7\n\n"); process_ok("[% 7 -%] \n " => '7 '); ###----------------------------------------------------------------### print "### string operators ################################ $engine_option\n"; process_ok('[% a = "foo"; a _ "bar" %]' => 'foobar'); process_ok('[% a = "foo"; a ~ "bar" %]' => 'foobar') if ! $is_tt; process_ok('[% a = "foo"; a ~= "bar"; a %]' => 'foobar') if ! $is_tt; process_ok('[% "b" gt "c" %]<<<' => '<<<') if ! $is_tt; process_ok('[% "b" gt "a" %]<<<' => '1<<<') if ! $is_tt; process_ok('[% "b" ge "c" %]<<<' => '<<<') if ! $is_tt; process_ok('[% "b" ge "b" %]<<<' => '1<<<') if ! $is_tt; process_ok('[% "b" lt "c" %]<<<' => '1<<<') if ! $is_tt; process_ok('[% "b" lt "a" %]<<<' => '<<<') if ! $is_tt; process_ok('[% "b" le "a" %]<<<' => '<<<') if ! $is_tt; process_ok('[% "b" le "b" %]<<<' => '1<<<') if ! $is_tt; process_ok('[% "a" cmp "b" %]<<<' => '-1<<<') if ! $is_tt; process_ok('[% "b" cmp "b" %]<<<' => '0<<<') if ! $is_tt; process_ok('[% "c" cmp "b" %]<<<' => '1<<<') if ! $is_tt; ###----------------------------------------------------------------### print "### math operators ################################## $engine_option\n"; process_ok("[% 1 + 2 %]" => 3); process_ok("[% 1 + 2 + 3 %]" => 6); process_ok("[% (1 + 2) %]" => 3); process_ok("[% 2 - 1 %]" => 1); process_ok("[% -1 + 2 %]" => 1); process_ok("[% -1+2 %]" => 1); process_ok("[% 2 - 1 %]" => 1); process_ok("[% 2-1 %]" => 1) if ! $is_tt; process_ok("[% 2 - -1 %]" => 3); process_ok("[% 4 * 2 %]" => 8); process_ok("[% 4 / 2 %]" => 2); process_ok("[% 10 / 3 %]" => qr/^3.333/); process_ok("[% 10 div 3 %]" => '3'); process_ok("[% 2 ** 3 %]" => 8) if ! $is_tt; process_ok("[% 1 + 2 * 3 %]" => 7); process_ok("[% 3 * 2 + 1 %]" => 7); process_ok("[% (1 + 2) * 3 %]" => 9); process_ok("[% 3 * (1 + 2) %]" => 9); process_ok("[% 1 + 2 ** 3 %]" => 9) if ! $is_tt; process_ok("[% 2 * 2 ** 3 %]" => 16) if ! $is_tt; process_ok("[% SET foo = 1 %][% foo + 2 %]" => 3); process_ok("[% SET foo = 1 %][% (foo + 2) %]" => 3); process_ok("[% a = 1; (a += 2) %]" => 3) if ! $is_tt; process_ok("[% a = 1; (a -= 2) %]" => -1) if ! $is_tt; process_ok("[% a = 4; (a /= 2) %]" => 2) if ! $is_tt; process_ok("[% a = 1; (a *= 2) %]" => 2) if ! $is_tt; process_ok("[% a = 3; (a **= 2) %]" => 9) if ! $is_tt; process_ok("[% a = 1; (a %= 2) %]" => 1) if ! $is_tt; process_ok("[% a = 1; (a += 2 + 3) %]" => 6) if ! $is_tt; process_ok("[% a = 1; b = 2; (a += b += 3) %]|[% a %]|[% b %]" => "6|6|5") if ! $is_tt; process_ok("[% a = 1; b = 2; (a += (b += 3)) %]|[% a %]|[% b %]" => "6|6|5") if ! $is_tt; process_ok('[% a += 1 %]-[% a %]-[% a += 1 %]-[% a %]' => '-1--2') if ! $is_tt; process_ok('[% (a += 1) %]-[% (a += 1) %]' => '1-2') if ! $is_tt; process_ok('[% a = 2; a -= 3; a %]' => '-1') if ! $is_tt; process_ok('[% a = 2; a *= 3; a %]' => '6') if ! $is_tt; process_ok('[% a = 2; a /= .5; a %]' => '4') if ! $is_tt; process_ok('[% a = 8; a %= 3; a %]' => '2') if ! $is_tt; process_ok('[% a = 2; a **= 3; a %]' => '8') if ! $is_tt; process_ok('[% a = 1 %][% ++a %][% a %]' => '22') if ! $is_tt; process_ok('[% a = 1 %][% a++ %][% a %]' => '12') if ! $is_tt; process_ok('[% a = 1 %][% --a %][% a %]' => '00') if ! $is_tt; process_ok('[% a = 1 %][% a-- %][% a %]' => '10') if ! $is_tt; process_ok('[% a++ FOR [1..3] %]' => '012') if ! $is_tt; process_ok('[% --a FOR [1..3] %]' => '-1-2-3') if ! $is_tt; process_ok('[% 2 > 3 %]<<<' => '<<<'); process_ok('[% 2 > 1 %]<<<' => '1<<<'); process_ok('[% 2 >= 3 %]<<<' => '<<<'); process_ok('[% 2 >= 2 %]<<<' => '1<<<'); process_ok('[% 2 < 3 %]<<<' => '1<<<'); process_ok('[% 2 < 1 %]<<<' => '<<<'); process_ok('[% 2 <= 1 %]<<<' => '<<<'); process_ok('[% 2 <= 2 %]<<<' => '1<<<'); process_ok('[% 1 <=> 2 %]<<<' => '-1<<<') if ! $is_tt; process_ok('[% 2 <=> 2 %]<<<' => '0<<<') if ! $is_tt; process_ok('[% 3 <=> 2 %]<<<' => '1<<<') if ! $is_tt; ###----------------------------------------------------------------### print "### boolean operators ############################### $engine_option\n"; process_ok("[% 5 && 6 %]" => 6); process_ok("[% 5 || 6 %]" => 5); process_ok("[% 0 || 6 %]" => 6); process_ok("[% 0 && 6 %]" => 0); process_ok("[% 0 && 0 %]" => 0); process_ok("[% 5 && 6 && 7%]" => 7); process_ok("[% 0 || 1 || 2 %]" => 1); process_ok("[% 5 + (0 || 5) %]" => 10); process_ok("[% 1 ? 2 : 3 %]" => '2'); process_ok("[% 0 ? 2 : 3 %]" => '3'); process_ok("[% 0 ? (1 ? 2 : 3) : 4 %]" => '4'); process_ok("[% 0 ? 1 ? 2 : 3 : 4 %]" => '4'); process_ok("[% t = 1 || 0 ? 3 : 4 %][% t %]" => 3); process_ok("[% t = 0 or 1 ? 3 : 4 %][% t %]" => 3); process_ok("[% t = 1 or 0 ? 3 : 4 %][% t %]" => 1) if ! $is_tt; process_ok("[% 0 ? 2 : 3 %]" => '3'); process_ok("[% 1 ? 2 : 3 %]" => '2'); process_ok("[% 0 ? 1 ? 2 : 3 : 4 %]" => '4'); process_ok("[% t = 0 ? 1 ? [1..4] : [2..4] : [3..4] %][% t.0 %]" => '3'); process_ok("[% t = 1 || 0 ? 0 : 1 || 2 ? 2 : 3 %][% t %]" => '0'); process_ok("[% t = 0 or 0 ? 0 : 1 or 2 ? 2 : 3 %][% t %]" => '1') if ! $is_tt; process_ok("[% t = 0 or 0 ? 0 : 0 or 2 ? 2 : 3 %][% t %]" => '2'); process_ok("[% 0 ? 1 ? 1 + 2 * 3 : 1 + 2 * 4 : 1 + 2 * 5 %]" => '11'); process_ok("[% foo //= 2 ; foo %]" => 2) if ! $is_tt; process_ok("[% foo = 3; foo //= 2; foo %]" => 3) if ! $is_tt; process_ok("[% foo = 3; SET foo; foo //= 2; foo %]" => 2) if ! $is_tt; process_ok("[% 5 // 6 %]" => 5) if ! $is_tt; process_ok("[% foo // 6 %]" => 6) if ! $is_tt; process_ok("[% foo // 6 %]" => 6, {foo => undef}) if ! $is_tt; process_ok("[% foo // 6 %]" => '', {foo => ''}) if ! $is_tt; process_ok("[% foo // 6 %]" => 'bar', {foo => 'bar'}) if ! $is_tt; process_ok("[% foo err 6 %]" => 6, {foo => undef}) if ! $is_tt; process_ok("[% foo ERR 6 %]" => 6, {foo => undef}) if ! $is_tt; ###----------------------------------------------------------------### print "### regex ########################################### $engine_option\n"; if (! $is_tt) { process_ok("[% 'foo'.match(/foo/) ? 1 : 0 %]" => '1'); process_ok("[% 'foo'.match(/foo) ? 1 : 0 %]" => ''); process_ok("[% 'foo'.match(/fo o/x) ? 1 : 0 %]" => '1'); process_ok("[% 'foo'.match(/Foo/i) ? 1 : 0 %]" => '1'); process_ok("[% 'f\no'.match(/f.o/s) ? 1 : 0 %]" => '1'); process_ok("[% '\nfoo'.match(/^foo/m) ? 1 : 0 %]" => '1'); process_ok("[% 'foo'.match(/foo/e) ? 1 : 0 %]" => ''); process_ok("[% 'foo'.match(/foo/g) ? 1 : 0 %]" => ''); process_ok("[% 'foo'.match(/foo) ? 1 : 0 %]" => ''); process_ok("[% 'foo'.match(/foo**/) ? 1 : 0 %]" => ''); process_ok("[% 'fo/o'.match(/fo\\/o/) ? 1 : 0 %]" => '1'); process_ok("[% 'foobar'.match(/(f\\w\\w)/).0 %]" => 'foo'); } ###----------------------------------------------------------------### print "### BLOCK / PROCESS / INCLUDE / WRAPPER ############# $engine_option\n"; process_ok("[% PROCESS foo %]one" => ''); process_ok("[% BLOCK foo %]one" => ''); process_ok("[% BLOCK foo %][% END %]one" => 'one'); process_ok("[% BLOCK %][% END %]one" => 'one'); process_ok("[% BLOCK foo %]hi there[% END %]one" => 'one'); process_ok("[% BLOCK foo %][% BLOCK foo %][% END %][% END %]" => ''); process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo %]" => 'hi there'); process_ok("[% PROCESS foo %][% BLOCK foo %]hi there[% END %]" => 'hi there'); process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo foo %]" => 'hi therehi there') if ! $is_tt; process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo, foo %]" => 'hi therehi there') if ! $is_tt; process_ok("[% BLOCK foo %]hi there[% END %][% PROCESS foo + foo %]" => 'hi therehi there'); process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo %]" => 'hi ONE there', {one => 'ONE'}); process_ok("[% BLOCK foo %]hi [% IF 1 %]Yes[% END %] there[% END %]<<[% PROCESS foo %]>>" => '<>'); process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo one = 'two' %]" => 'hi two there'); process_ok("[% BLOCK foo %]hi [% one.two %] there[% END %][% PROCESS foo one.two = 'two' %]" => 'hi two there'); process_ok("[% BLOCK foo %]hi [% one.two %] there[% END %][% PROCESS foo + foo one.two = 'two' %]" => 'hi two there'x2); process_ok("[% BLOCK foo %][% BLOCK bar %]hi [% one %] there[% END %][% END %][% PROCESS foo/bar one => 'two' %]" => 'hi two there'); process_ok("[% BLOCK b %]Ta-Da[% END %][% self = {a => 'b'} %][% PROCESS \$self.a self = 'blah' %]" => 'Ta-Da'); process_ok("[% BLOCK b %]Ta-Da[% END %][% self = {a => 'b'} %][% INCLUDE \$self.a self = 'blah' %]" => 'Ta-Da') if ! $five_six; process_ok("[% BLOCK b %]Ta-Da[% END %][% self = 'b' %][% PROCESS \$self self = 'blah'; self %]" => 'Ta-Dablah'); process_ok("[% BLOCK b %]Ta-Da[% END %][% self = 'b' %][% INCLUDE \$self self = 'blah'; self %]" => 'Ta-Dab') if ! $five_six; process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% PROCESS foo one = 'two' %][% one %]" => 'hi two theretwo'); process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% INCLUDE foo one = 'two' %][% one %]" => 'hi two there') if ! $five_six; process_ok("[% BLOCK foo %]FOO[% IF ! a ; a = 1; PROCESS bar; END %][% END %][% BLOCK bar %]BAR[% PROCESS foo %][% END %][% PROCESS foo %]" => "") if ! $is_tt && ! $use_stream; process_ok("[% BLOCK foo %]FOO[% IF ! a ; a = 1; PROCESS bar; END %][% END %][% BLOCK bar %]BAR[% PROCESS foo %][% END %][% PROCESS foo %]d" => "FOOBAR") if $use_stream; process_ok("[% BLOCK foo %]FOO[% IF ! a ; a = 1; PROCESS bar; END %][% END %][% BLOCK bar %]BAR[% PROCESS foo %][% END %][% PROCESS foo %]" => "FOOBARFOO", {tt_config => [RECURSION => 1]}); process_ok("[% BLOCK foo %]([% content %])[% END %][% WRAPPER foo %]hi there[% END %]" => "(hi there)"); process_ok("[% BLOCK foo %]([% one = 1; content %])[% END %][% WRAPPER foo %]hi there[% END %][% one %]" => "(hi there)won", {one => 'won'}); process_ok('[% a = 23; PROCESS $foo %]' => 'bar 23 baz', {foo => \ "bar [% a %] baz"}); ###----------------------------------------------------------------### print "### IF / UNLESS / ELSIF / ELSE ###################### $engine_option\n"; process_ok("[% IF 1 %]Yes[% END %]" => 'Yes'); process_ok("[% IF 0 %]Yes[% END %]" => ''); process_ok("[% IF 0 %]Yes[% ELSE %]No[% END %]" => 'No'); process_ok("[% IF 0 %]Yes[% ELSIF 1 %]No[% END %]" => 'No'); process_ok("[% IF 0 %]Yes[% ELSIF 0 %]No[% END %]" => ''); process_ok("[% IF 0 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm'); process_ok("[% UNLESS 1 %]Yes[% END %]" => ''); process_ok("[% UNLESS 0 %]Yes[% END %]" => 'Yes'); process_ok("[% UNLESS 0 %]Yes[% ELSE %]No[% END %]" => 'Yes'); process_ok("[% UNLESS 1 %]Yes[% ELSIF 1 %]No[% END %]" => 'No'); process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% END %]" => ''); process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm'); ###----------------------------------------------------------------### print "### comments ######################################## $engine_option\n"; process_ok("[%# one %]f" => 'f', {one => 'ONE'}); process_ok("[%#\n one %]f" => 'f', {one => 'ONE'}); process_ok("[%-#\n one %]f" => 'f', {one => 'ONE'}) if ! $is_tt; process_ok("[% #\n one %]f" => 'ONEf', {one => 'ONE'}); process_ok("[% # one %]\n one %]f" => "\n one %]f", {one => "ONE"}) if $is_tt || !$five_eight; process_ok("[% # one %]\n one %]f" => "ONEf", {one => "ONE"}) if !$is_tt && $five_eight; # I personally think this is the more correct behavior process_ok("[%# BLOCK one %]" => ''); process_ok("[%# BLOCK one %]two" => 'two'); process_ok("[%# BLOCK one %]two[% END %]" => ''); process_ok("[%# BLOCK one %]two[% END %]three" => ''); process_ok("[% %]" => ''); process_ok("[% # Some comment CALL 1 -%] foo" => "foo"); ###----------------------------------------------------------------### print "### FOREACH / NEXT / LAST ########################### $engine_option\n"; process_ok("[% FOREACH foo %]" => ''); process_ok("[% FOREACH foo %][% END %]" => ''); process_ok("[% FOREACH foo %]bar[% END %]" => ''); process_ok("[% FOREACH foo %]bar[% END %]" => 'bar', {foo => 1}); process_ok("[% FOREACH f IN foo %]bar[% f %][% END %]" => 'bar1bar2', {foo => [1,2]}); process_ok("[% FOREACH f = foo %]bar[% f %][% END %]" => 'bar1bar2', {foo => [1,2]}); process_ok("[% FOREACH f = [1,2] %]bar[% f %][% END %]" => 'bar1bar2'); process_ok("[% FOREACH f = [1..3] %]bar[% f %][% END %]" => 'bar1bar2bar3'); process_ok("[% FOREACH f = [{a=>'A'},{a=>'B'}] %]bar[% f.a %][% END %]" => 'barAbarB'); process_ok("[% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %]" => 'barAbarB'); process_ok("[% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %][% a %]" => 'barAbarB'); process_ok("[% FOREACH f = [1..3] %][% loop.count %]/[% loop.size %] [% END %]" => '1/3 2/3 3/3 '); process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% f %][% END %][% END %]" => '1'); process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% f %][% END %][% END %]" => '3'); process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% NEXT %][% END %][% f %][% END %]" => '23'); process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% LAST %][% END %][% f %][% END %]" => ''); process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% NEXT %][% END %][% END %]" => '123'); process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% LAST %][% END %][% END %]" => '1'); process_ok("[% loop.odd FOREACH [1..5] %]" => '10101'); process_ok("[% loop.even FOREACH [1..5] %]" => '01010'); process_ok("[% loop.parity FOREACH [1..5] %]" => 'oddevenoddevenodd'); process_ok('[% a = ["Red", "Blue"] ; FOR [0..3] ; a.${ loop.index % a.size } ; END %]' => 'RedBlueRedBlue') if ! $is_tt; ### TT is not consistent in what is localized - well it is documented ### if you set a variable in the FOREACH tag, then nothing in the loop gets localized ### if you don't set a variable - everything gets localized process_ok("[% foo = 1 %][% FOREACH [1..10] %][% foo %][% foo = 2 %][% END %]" => '1222222222'); process_ok("[% f = 1 %][% FOREACH i = [1..10] %][% i %][% f = 2 %][% END %][% f %]" => '123456789102'); process_ok("[% f = 1 %][% FOREACH [1..10] %][% f = 2 %][% END %][% f %]" => '1'); process_ok("[% f = 1 %][% FOREACH f = [1..10] %][% f %][% END %][% f %]" => '1234567891010'); process_ok("[% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => ''); process_ok("[% a %][% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => ''); process_ok("[% a = 2 %][% FOREACH [1] %][% SET a = 1 %][% END %][% a %]" => '2'); process_ok("[% a = 2 %][% FOREACH [1] %][% a = 1 %][% END %][% a %]" => '2'); process_ok("[% a = 2 %][% FOREACH i = [1] %][% a = 1 %][% END %][% a %]" => '1'); process_ok("[% FOREACH i = [1] %][% SET a = 1 %][% END %][% a %]" => '1'); process_ok("[% f.b = 1 %][% FOREACH f.b = [1..10] %][% f.b %][% END %][% f.b %]" => '1234567891010') if ! $is_tt; process_ok("[% a = 1 %][% FOREACH [{a=>'A'},{a=>'B'}] %]bar[% a %][% END %][% a %]" => 'barAbarB1'); process_ok("[% FOREACH [1..3] %][% loop.size %][% END %][% loop.size %]" => '333'); process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '333') if ! $is_tt; process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '3331') if $is_tt; process_ok('[% FOREACH f = [1..3]; 1; END %]' => '111'); process_ok('[% FOREACH f = [1..3]; f; END %]' => '123'); process_ok('[% FOREACH f = [1..3]; "$f"; END %]' => '123'); process_ok('[% FOREACH f = [1..3]; f + 1; END %]' => '234'); process_ok('[% FOREACH f IN [2,3,4]; FOREACH g IN [6,7,8]; f;g;", "; END; END %]' => '26, 27, 28, 36, 37, 38, 46, 47, 48, '); { package TEST_HASH_OBJ; sub n { shift->{'n'} } } { package TEST_ARRAY_OBJ; sub n { shift->[0] } } my @objs = map { bless {n => $_}, 'TEST_HASH_OBJ' } 1..3; process_ok('[% FOREACH i IN foo; i.n; END %]' => '123', {foo => sub { \@objs }}); process_ok('[% FOREACH i IN foo; i.n; END %]' => '1', {foo => sub { [$objs[0]] }}); process_ok('[% FOREACH i IN foo; i.n; END %]' => '123', {foo => sub { @objs }}); process_ok('[% FOREACH i IN foo; i.n; END %]' => '1', {foo => sub { $objs[0] }}); @objs = map { bless [$_], 'TEST_ARRAY_OBJ' } 1..3; process_ok('[% FOREACH i IN foo; i.n; END %]' => '123', {foo => sub { \@objs }}); process_ok('[% FOREACH i IN foo; i.n; END %]' => '1', {foo => sub { [$objs[0]] }}); process_ok('[% FOREACH i IN foo; i.n; END %]' => '123', {foo => sub { @objs }}); process_ok('[% FOREACH i IN foo; i.n; END %]' => '1', {foo => sub { $objs[0] }}); ###----------------------------------------------------------------### print "### LOOP ############################################ $engine_option\n"; process_ok("[% var = [{key => 'a'}, {key => 'b'}] -%] [% LOOP var -%] ([% key %]) [% END %]" => " (a)\n (b)\n") if ! $is_tt; if (! $is_tt) { local $Template::Alloy::QR_PRIVATE = 0; local $Template::Alloy::QR_PRIVATE = 0; # warn clean process_ok("[% var = [{key => 'a'}, {key => 'b'}, {key => 'c'}] -%] [% LOOP var -%] ([% key; '|'; __first__; '|'; __last__; '|'; __inner__; '|'; __odd__ %]) [% END -%]" => "(a|1|0|0|1) (b|0|0|1|0) (c|0|1|0|1) ", {tt_config => [LOOP_CONTEXT_VARS => 1]}); } ###----------------------------------------------------------------### print "### WHILE ########################################### $engine_option\n"; process_ok("[% WHILE foo %]" => ''); process_ok("[% WHILE foo %][% END %]" => ''); process_ok("[% WHILE (foo = foo - 1) %][% END %]" => ''); process_ok("[% WHILE (foo = foo - 1) %][% foo %][% END %]" => '21', {foo => 3}); process_ok("[% WHILE foo %][% foo %][% foo = foo - 1 %][% END %]" => '321', {foo => 3}); process_ok("[% WHILE 1 %][% foo %][% foo = foo - 1 %][% LAST IF foo == 1 %][% END %]" => '32', {foo => 3}); process_ok("[% f = 10; WHILE f; f = f - 1 ; f ; END %]" => '9876543210'); process_ok("[% f = 10; WHILE f; f = f - 1 ; f ; END ; f %]" => '98765432100'); process_ok("[% f = 10; a = 2; WHILE f; f = f - 1 ; f ; a=3; END ; a%]" => '98765432103'); process_ok("[% f = 10; WHILE (g=f); f = f - 1 ; f ; END %]" => '9876543210'); process_ok("[% f = 10; WHILE (g=f); f = f - 1 ; f ; END ; f %]" => '98765432100'); process_ok("[% f = 10; a = 2; WHILE (g=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432103'); process_ok("[% f = 10; a = 2; WHILE (a=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432100'); ###----------------------------------------------------------------### print "### STOP / RETURN / CLEAR ########################### $engine_option\n"; process_ok("[% STOP %]" => ''); process_ok("One[% STOP %]Two" => 'One'); process_ok("[% BLOCK foo %]One[% STOP %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstOne'); process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% STOP %][% END %][% END %]" => '1'); process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% STOP %][% END %][% f %][% END %]" => ''); process_ok("[% RETURN %]" => ''); process_ok("One[% RETURN %]Two" => 'One'); process_ok("[% BLOCK foo %]One[% RETURN %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstOneLast'); process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% RETURN %][% END %][% END %]" => '1'); process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% RETURN %][% END %][% f %][% END %]" => ''); process_ok("[% CLEAR %]" => ''); process_ok("One[% CLEAR %]Two" => 'Two') if ! $use_stream; process_ok("[% BLOCK foo %]One[% CLEAR %]Two[% END %]First[% PROCESS foo %]Last" => 'FirstTwoLast') if ! $use_stream; process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% CLEAR %][% END %][% END %]" => '23') if ! $use_stream; process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% CLEAR %][% END %][% f %][% END %]" => '123') if ! $use_stream; process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.last %][% CLEAR %][% END %][% END %]" => '') if ! $use_stream; process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% CLEAR %][% END %][% f %][% END %]" => '3') if ! $use_stream; ###----------------------------------------------------------------### print "### post opererative directives ##################### $engine_option\n"; process_ok("[% GET foo IF 1 %]" => '1', {foo => 1}); process_ok("[% f FOREACH f = [1..3] %]" => '123'); process_ok("2[% GET foo IF 1 IF 2 %]" => '21', {foo => 1}) if ! $is_tt; process_ok("2[% GET foo IF 1 IF 0 %]" => '2', {foo => 1}) if ! $is_tt; process_ok("[% f FOREACH f = [1..3] IF 1 %]" => '123') if ! $is_tt; process_ok("[% f FOREACH f = [1..3] IF 0 %]" => '') if ! $is_tt; process_ok("[% f FOREACH f = g FOREACH g = [1..3] %]" => '123') if ! $is_tt; process_ok("[% f FOREACH f = g.a FOREACH g = [{a=>1}, {a=>2}, {a=>3}] %]" => '123') if ! $is_tt; process_ok("[% f FOREACH f = a FOREACH [{a=>1}, {a=>2}, {a=>3}] %]" => '123') if ! $is_tt; process_ok("[% FOREACH f = [1..3] IF 1 %]([% f %])[% END %]" => '(1)(2)(3)') if ! $is_tt; process_ok("[% FOREACH f = [1..3] IF 0 %]([% f %])[% END %]" => '') if ! $is_tt; process_ok("[% BLOCK bar %][% foo %][% foo = foo - 1 %][% END %][% PROCESS bar WHILE foo %]" => '321', {foo => 3}); ###----------------------------------------------------------------### print "### capturing ####################################### $engine_option\n"; process_ok("[% foo = BLOCK %]Hi[% END %][% foo %][% foo %]" => 'HiHi'); process_ok("[% BLOCK foo %]Hi[% END %][% bar = PROCESS foo %]-[% bar %]" => '-Hi'); process_ok("[% foo = IF 1 %]Hi[% END %][% foo %]" => 'Hi'); process_ok("[% BLOCK foo %]([% i %])[% END %][% wow = PROCESS foo i='bar' %][% wow %]" => "(bar)"); process_ok("[% BLOCK foo %]([% i %])[% END %][% SET wow = PROCESS foo i='bar' %][% wow %]" => "(bar)") if ! $is_tt; ###----------------------------------------------------------------### print "### TAGS ############################################ $engine_option\n"; process_ok("[% TAGS asp %]<% 1 + 2 %>" => 3); process_ok("[% TAGS default %][% 1 + 2 %]" => 3); process_ok("[% TAGS html %]" => '3'); process_ok("[% TAGS mason %]<% 1 + 2 >" => 3); process_ok("[% TAGS metatext %]%% 1 + 2 %%" => 3); process_ok("[% TAGS php %]" => 3); process_ok("[% TAGS star %][* 1 + 2 *]" => 3); process_ok("[% TAGS template %][% 1 + 2 %]" => 3); process_ok("[% TAGS template1 %][% 1 + 2 %]" => 3); process_ok("[% TAGS template1 %]%% 1 + 2 %%" => 3); process_ok("[% TAGS tt2 %][% 1 + 2 %]" => 3); process_ok("[% TAGS html %] " => '3'); process_ok("[% TAGS html %]" => '3') if ! $is_tt; process_ok("[% TAGS html %]\n" => '3'); process_ok("[% BLOCK foo %][% TAGS html %] " => '3 3'); process_ok("[% BLOCK foo %][% TAGS html %][% END %][% PROCESS foo %] [% 1 + 2 %]" => ''); process_ok("[% TAGS %]" => '3'); process_ok("[% TAGS [<] [>] %][<] 1 + 2 [>]" => 3); process_ok("[% TAGS '[<]' '[>]' %][<] 1 + 2 [>]" => 3) if ! $is_tt; process_ok("[% TAGS /[<]/ /[>]/ %]< 1 + 2 >" => 3) if ! $is_tt; process_ok("[% TAGS ** ** %]** 1 + 2 **" => 3); process_ok("[% TAGS '**' '**' %]** 1 + 2 **" => 3) if ! $is_tt; process_ok("[% TAGS /**/ /**/ %]** 1 + 2 **" => "") if ! $is_tt; process_ok("[% TAGS html -->" => '3') if ! $is_tt; process_ok("[% TAGS html ; 7 -->" => '73') if ! $is_tt; process_ok("[% TAGS html ; 7 %]" => '') if ! $is_tt; # error - the old closing tag must come next ###----------------------------------------------------------------### print "### SWITCH / CASE ################################### $engine_option\n"; process_ok("[% SWITCH 1 %][% END %]hi" => 'hi'); process_ok("[% SWITCH 1 %][% CASE %]bar[% END %]hi" => 'barhi'); process_ok("[% SWITCH 1 %]Pre[% CASE %]bar[% END %]hi" => 'barhi'); process_ok("[% SWITCH 1 %][% CASE DEFAULT %]bar[% END %]hi" => 'barhi'); process_ok("[% SWITCH 1 %][% CASE 0 %]bar[% END %]hi" => 'hi'); process_ok("[% SWITCH 1 %][% CASE 1 %]bar[% END %]hi" => 'barhi'); process_ok("[% SWITCH 1 %][% CASE foo %][% CASE 1 %]bar[% END %]hi" => 'barhi'); process_ok("[% SWITCH 1 %][% CASE [1..10] %]bar[% END %]hi" => 'barhi'); process_ok("[% SWITCH 11 %][% CASE [1..10] %]bar[% END %]hi" => 'hi'); process_ok("[% SWITCH 1.0 %][% CASE [1..10] %]bar[% END %]hi" => 'barhi'); ###----------------------------------------------------------------### print "### TRY / THROW / CATCH / FINAL ##################### $engine_option\n"; process_ok("[% TRY %][% END %]hi" => 'hi'); process_ok("[% TRY %]Foo[% END %]hi" => 'Foohi'); process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% END %]hi" => ($use_stream ? 'Foo' : '')); process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH %][% END %]hi" => 'Foohi') if ! $is_tt; process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH %]there[% END %]hi" => 'Footherehi'); process_ok("[% TRY %]Foo[% THROW foo 'for fun' %]bar[% CATCH foo %]there[% END %]hi" => 'Footherehi'); process_ok("[% TRY %]Foo[% TRY %]Foo[% THROW foo 'for fun' %][% CATCH bar %]one[% END %][% CATCH %]two[% END %]hi" => 'FooFootwohi'); process_ok("[% TRY %]Foo[% TRY %]Foo[% THROW foo 'for fun' %][% CATCH bar %]one[% END %][% CATCH s %]two[% END %]hi" => ($use_stream ? 'FooFoo' : '')); process_ok("[% TRY %]Foo[% THROW foo.bar 'for fun' %][% CATCH foo %]one[% CATCH foo.bar %]two[% END %]hi" => 'Footwohi'); process_ok("[% TRY %]Foo[% FINAL %]Bar[% END %]hi" => 'FooBarhi'); process_ok("[% TRY %]Foo[% THROW foo %][% FINAL %]Bar[% CATCH %]one[% END %]hi" => ''); process_ok("[% TRY %]Foo[% THROW foo %][% CATCH %]one[% FINAL %]Bar[% END %]hi" => 'FoooneBarhi'); process_ok("[% TRY %]Foo[% THROW foo %][% CATCH bar %]one[% FINAL %]Bar[% END %]hi" => ($use_stream ? 'Foo' : '')); process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error %][% END %]" => 'foo error - bar'); process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error.type %][% END %]" => 'foo'); process_ok("[% TRY %][% THROW foo 'bar' %][% CATCH %][% error.info %][% END %]" => 'bar'); process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.type %][% END %]" => 'undef'); process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.info %][% END %]" => 'foo'); ###----------------------------------------------------------------### print "### named args ###################################### $engine_option\n"; process_ok("[% foo(bar = 'one', baz = 'two') %]" => "baronebaztwo", {foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}}); process_ok("[%bar='ONE'%][% foo(\$bar = 'one') %]" => "ONEone", {foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}}); ###----------------------------------------------------------------### print "### USE ############################################# $engine_option\n"; my @config_p = (PLUGIN_BASE => 'MyTestPlugin', LOAD_PERL => 1); process_ok("[% USE son_of_gun_that_does_not_exist %]one" => '', {tt_config => \@config_p}); process_ok("[% USE Iterator([3..6]) %]hey[% CALL Iterator.get_first; Iterator.size %]" => "hey4"); process_ok("[% USE FooTest %]one" => 'one', {tt_config => \@config_p}); process_ok("[% USE FooTest2 %]one" => 'one', {tt_config => \@config_p}); process_ok("[% USE FooTest(bar = 'baz') %]one[% FooTest.bar %]" => 'onebarbaz', {tt_config => \@config_p}); process_ok("[% USE FooTest2(bar = 'baz') %]one[% FooTest2.bar %]" => 'onebarbaz', {tt_config => \@config_p}); process_ok("[% USE FooTest(bar = 'baz') %]one[% FooTest.bar %]" => 'onebarbaz', {tt_config => \@config_p}); process_ok("[% USE d = FooTest(bar = 'baz') %]one[% d.bar %]" => 'onebarbaz', {tt_config => \@config_p}); process_ok("[% USE d.d = FooTest(bar = 'baz') %]one[% d.d.bar %]" => '', {tt_config => \@config_p}); process_ok("[% USE FooTest(somerand = 8) %]one[% FooTest.somerand %]" => 'one8', {tt_config => \@config_p}); process_ok("[% USE a(bar = 'baz') %]one[% a.seven %]" => '', {tt_config => [@config_p, PLUGINS => {a=>'FooTest'}, ]}); process_ok("[% USE a(bar = 'baz') %]one[% a.seven %]" => 'one7', {tt_config => [@config_p, PLUGINS => {a=>'FooTest2'},]}); @config_p = (PLUGIN_BASE => ['NonExistant', 'MyTestPlugin'], LOAD_PERL => 1); process_ok("[% USE FooTest %]three" => 'three', {tt_config => \@config_p}); ###----------------------------------------------------------------### print "### MACRO ########################################### $engine_option\n"; process_ok("[% MACRO foo PROCESS bar %][% BLOCK bar %]Hi[% END %][% foo %]" => 'Hi'); process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi'); process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi'); process_ok("[% MACRO foo(n) BLOCK %]Hi[% n %][% END %][% foo(2) %]" => 'Hi2'); process_ok("[%n=1%][% MACRO foo(n) BLOCK %]Hi[% n %][% END %][% foo(2) %][%n%]" => 'Hi21'); process_ok("[%n=1%][% MACRO foo BLOCK %]Hi[% n = 2%][% END %][% foo %][%n%]" => 'Hi1'); process_ok("[% MACRO foo(n) FOREACH i=[1..n] %][% i %][% END %][% foo(3) %]" => '123'); process_ok('[% MACRO f BLOCK %]>[% TRY; f ; CATCH ; "caught" ; END %][% END %][% f %]' => '>>>caught', {tt_config => [MAX_MACRO_RECURSE => 3]}) if ! $is_tt; if (! $is_tt) { process_ok("[% foo = ->{ 'Hi' } %][% foo %]" => 'Hi'); process_ok("[% foo = ->{ 'Hi'; this } %][% foo(2) %]" => 'Hi2'); process_ok("[% foo = ->(n){ 'Hi'; n } %][% foo(2) %]" => 'Hi2'); process_ok("[%n=1%][% foo = ->(n) { 'Hi' ; n } %][% foo(2) %][%n%]" => 'Hi21'); process_ok("[% foo = ->(n) { FOREACH i=[1..n]; i ; END } %][% foo(3) %]" => '123'); } ###----------------------------------------------------------------### print "### DEBUG ########################################### $engine_option\n"; process_ok("\n\n[% one %]" => "\n\n\n## input text line 3 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]}); process_ok("[% one %]" => "\n## input text line 1 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]}); process_ok("[% one %]\n\n" => "(1)ONE\n\n", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']}); process_ok("1\n2\n3[% one %]" => "1\n2\n3(3)ONE", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']}); process_ok("[% one;\n one %]" => "(1)ONE(2)ONE", {one=>'ONE', tt_config => ['DEBUG' => 8, 'DEBUG_FORMAT' => '($line)']}) if ! $is_tt; process_ok("[% DEBUG format '(\$line)' %][% one %]" => qr/\(1\)/, {one=>'ONE', tt_config => ['DEBUG' => 8]}); process_ok("[% TRY %][% abc %][% CATCH %][% error %][% END %]" => "undef error - abc is undefined\n", {tt_config => ['DEBUG' => 2]}); process_ok("[% TRY %][% abc.def %][% CATCH %][% error %][% END %]" => "undef error - def is undefined\n", {abc => {}, tt_config => ['DEBUG' => 2]}) if $is_tt; process_ok("[% TRY %][% abc.def %][% CATCH %][% error %][% END %]" => "undef error - abc.def is undefined\n", {abc => {}, tt_config => ['DEBUG' => 2]}) if !$is_tt; ###----------------------------------------------------------------### print "### constants ####################################### $engine_option\n"; my @config_c = ( CONSTANTS => { harry => sub {'do_this_once'}, foo => { bar => {baz => 42}, bim => 57, }, bing => 'baz', bang => 'bim', }, VARIABLES => { bam => 'bar', }, ); process_ok("[% constants.harry %]" => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c}); process_ok("[% constants.harry.length %]" => '12', {tt_config => \@config_c}); process_ok("[% SET constants.something = 1 %][% constants.something %]one" => '1one', {tt_config => \@config_c}); process_ok("[% SET constants.harry = 1 %][% constants.harry %]one" => 'do_this_onceone', {tt_config => \@config_c}); process_ok("[% constants.foo.\${constants.bang} %]" => '57', {tt_config => [@config_c]}); process_ok("[% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt; process_ok("[% bam = 'somethingelse' %][% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt; process_ok('[% constants.${"harry"} %]' => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c}); process_ok('[% ${"constants"}.harry %]' => 'foo', {constants => {harry => 'foo'}, tt_config => \@config_c}) if ! $is_tt; process_ok('[% ${"constants"}.harry %]' => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c}) if $is_tt; process_ok('[% ${"con${"s"}tants"}.harry %]' => 'foo', {constants => {harry => 'foo'}, tt_config => \@config_c}) if ! $is_tt; ###----------------------------------------------------------------### print "### CONTEXT ######################################### $engine_option\n"; $cctx->{'bang'} = 'bing'; process_ok("[% CALL cctx.call_me %][% cctx.last_context %]" => "list", {cctx => $cctx}); process_ok("[% cctx.array %]" => qr{^ARRAY}, {cctx => $cctx}); process_ok("[% cctx.array2 %]" => "4", {cctx => $cctx}); process_ok("[% cctx.list %]" => qr{^ARRAY}, {cctx => $cctx}); process_ok("[% cctx.scalar %]" => "8", {cctx => $cctx}); process_ok("[% cctx.bang %]" => "bing", {cctx => $cctx}); if (! $is_tt) { $cctx->{'clear'}->(); process_ok('[% CALL cctx.call_me %][% cctx.last_context %]' => "list", {cctx => $cctx}); process_ok('[% CALL @(cctx.call_me) %][% cctx.last_context %]' => "list", {cctx => $cctx}); process_ok('[% CALL $(cctx.call_me) %][% cctx.last_context %]' => "scalar", {cctx => $cctx}); process_ok('[% CALL call_cctx %][% cctx.last_context %]' => "list", {cctx => $cctx, call_cctx => sub { $cctx->{'call_me'}->() }}); process_ok('[% CALL @(call_cctx) %][% cctx.last_context %]' => "list", {cctx => $cctx, call_cctx => sub { $cctx->{'call_me'}->() }}); process_ok('[% CALL $(call_cctx) %][% cctx.last_context %]' => "scalar", {cctx => $cctx, call_cctx => sub { $cctx->{'call_me'}->() }}); process_ok('[% CALL cctx.call_me %][% cctx.last_context %]' => "list", {cctx => $cctx, tt_config => [CALL_CONTEXT => 'smart']}); process_ok('[% CALL cctx.call_me %][% cctx.last_context.0 %]' => "list", {cctx => $cctx, tt_config => [CALL_CONTEXT => 'list']}); process_ok('[% CALL cctx.call_me %][% cctx.last_context %]' => "scalar", {cctx => $cctx, tt_config => [CALL_CONTEXT => 'item']}); process_ok('[% cctx.array %]' => qr{^ARRAY}, {cctx => $cctx}); process_ok('[% @(cctx.array) %]' => qr{^ARRAY}, {cctx => $cctx}); process_ok('[% $(cctx.array) %]' => '3', {cctx => $cctx}); process_ok('[% cctx.array2 %]' => '4', {cctx => $cctx}); process_ok('[% @(cctx.array2) %]' => qr{^ARRAY}, {cctx => $cctx}); process_ok('[% $(cctx.array2) %]' => '1', {cctx => $cctx}); process_ok('[% cctx.list %]' => qr{^ARRAY}, {cctx => $cctx}); process_ok('[% @(cctx.list) %]' => qr{^ARRAY}, {cctx => $cctx}); process_ok('[% $(cctx.list) %]' => '7', {cctx => $cctx}); process_ok('[% cctx.scalar %]' => '8', {cctx => $cctx}); process_ok('[% @(cctx.scalar) %]' => qr{^ARRAY}, {cctx => $cctx}); process_ok('[% $(cctx.scalar) %]' => '8', {cctx => $cctx}); process_ok('[% cctx.bang %] ~' => 'bing ~', {cctx => $cctx}); process_ok('[% @(cctx.bang) %] ~' => 'bing ~', {cctx => $cctx}); process_ok('[% $(cctx.bang) %] ~' => 'bing ~', {cctx => $cctx}); $cctx->{'clear'}->(); process_ok('[% CONFIG CALL_CONTEXT => "list"; CALL cctx.call_me; CONFIG CALL_CONTEXT => "smart" %][% cctx.last_context %]' => "list", {cctx => $cctx}); $cctx->{'clear'}->(); process_ok('[% CONFIG CALL_CONTEXT => "item"; CALL cctx.call_me %][% cctx.last_context %]' => "scalar", {cctx => $cctx}); delete $cctx->{'data'}; process_ok('[% cctx.dataref.0.foo = 7; cctx.dataref.0.foo %]' => "7", {cctx => $cctx}); delete $cctx->{'data'}; process_ok('[% @(cctx.dataref).0.foo = 7; cctx.dataref.foo %]' => "7", {cctx => $cctx}); delete $cctx->{'data'}; process_ok('[% $(cctx.dataref).0.foo = 7; cctx.dataref.0.foo %]'=> "7", {cctx => $cctx}); delete $cctx->{'data'}; process_ok('[% CONFIG CALL_CONTEXT => "list"; cctx.dataref.0.foo = 7; CONFIG CALL_CONTEXT => "item"; cctx.dataref.foo %]'=> "7", {cctx => $cctx}); } # call context with methods process_ok("[% cctxo.data = 1 %] ~" => "", {cctxo => $cctxo}) if $is_tt; # TT lets you read but not write - weird process_ok("[% cctxo.bang = 1 %] ~" => " ~", {cctxo => $cctxo}); process_ok("[% cctxo.dataref.foo = 7; cctxo.dataref.foo %]" => "7", {cctxo => $cctxo}); if (! $is_tt) { process_ok('[% CALL cctxo.call_me %][% cctxo.last_context %]' => "list", {cctxo => $cctxo}); process_ok('[% CALL @(cctxo.call_me) %][% cctxo.last_context %]' => "list", {cctxo => $cctxo}); process_ok('[% CALL $(cctxo.call_me) %][% cctxo.last_context %]' => "scalar", {cctxo => $cctxo}); process_ok('[% CALL call_cctxo %][% cctxo.last_context %]' => "list", {cctxo => $cctxo, call_cctxo => sub { $cctxo->call_me }}); process_ok('[% CALL @(call_cctxo) %][% cctxo.last_context %]' => "list", {cctxo => $cctxo, call_cctxo => sub { $cctxo->call_me }}); process_ok('[% CALL $(call_cctxo) %][% cctxo.last_context %]' => "scalar", {cctxo => $cctxo, call_cctxo => sub { $cctxo->call_me }}); process_ok('[% CALL cctxo.call_me %][% cctxo.last_context %]' => "list", {cctxo => $cctxo, tt_config => [CALL_CONTEXT => 'smart']}); process_ok('[% CALL cctxo.call_me %][% cctxo.last_context.0 %]' => "list", {cctxo => $cctxo, tt_config => [CALL_CONTEXT => 'list']}); process_ok('[% CALL cctxo.call_me %][% cctxo.last_context %]' => "scalar", {cctxo => $cctxo, tt_config => [CALL_CONTEXT => 'item']}); process_ok('[% cctxo.array %]' => qr{^ARRAY}, {cctxo => $cctxo}); process_ok('[% @(cctxo.array) %]' => qr{^ARRAY}, {cctxo => $cctxo}); process_ok('[% $(cctxo.array) %]' => '3', {cctxo => $cctxo}); process_ok('[% cctxo.array2 %]' => '4', {cctxo => $cctxo}); process_ok('[% @(cctxo.array2) %]' => qr{^ARRAY}, {cctxo => $cctxo}); process_ok('[% $(cctxo.array2) %]' => '1', {cctxo => $cctxo}); process_ok('[% cctxo.list %]' => qr{^ARRAY}, {cctxo => $cctxo}); process_ok('[% @(cctxo.list) %]' => qr{^ARRAY}, {cctxo => $cctxo}); process_ok('[% $(cctxo.list) %]' => '7', {cctxo => $cctxo}); process_ok('[% cctxo.scalar %]' => '8', {cctxo => $cctxo}); process_ok('[% @(cctxo.scalar) %]' => qr{^ARRAY}, {cctxo => $cctxo}); process_ok('[% $(cctxo.scalar) %]' => '8', {cctxo => $cctxo}); process_ok('[% cctxo.bang %] ~' => 'bing ~', {cctxo => $cctxo}); $cctx->{'clear'}->(); process_ok('[% SET cctxo.call_me = 2 %][% cctxo.last_context %]' => "list2", {cctxo => $cctxo}); $cctx->{'clear'}->(); process_ok('[% CALL @(cctxo.call_me = 3) %][% cctxo.last_context %]' => "list3", {cctxo => $cctxo}); $cctx->{'clear'}->(); process_ok('[% CALL $(cctxo.call_me = 4) %][% cctxo.last_context %]' => "scalar4", {cctxo => $cctxo}); } ###----------------------------------------------------------------### print "### INTERPOLATE ##################################### $engine_option\n"; process_ok("Foo \$one Bar" => 'Foo ONE Bar', {one => 'ONE', tt_config => ['INTERPOLATE' => 1]}); process_ok("[% PERL %] my \$n=7; print \$n [% END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]}); process_ok("[% TRY ; PERL %] my \$n=7; print \$n [% END ; END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]}); my $slash = '\\'; my $interp_i = 0; process_ok("Foo $slash Bar" => "Foo $slash Bar", {tt_config => ['INTERPOLATE' => 1]}); process_ok("Foo $slash$slash Bar" => "Foo $slash$slash Bar", {tt_config => ['INTERPOLATE' => 1]}); process_ok("Foo ${slash}n Bar" => "Foo ${slash}n Bar", {tt_config => ['INTERPOLATE' => 1]}); process_ok("Foo $slash\$a Bar" => "Foo \$a Bar", {a=>7, tt_config => ['INTERPOLATE' => 1]}); process_ok("Foo $slash$slash\$a Bar" => "Foo $slash${slash}7 Bar", {a=>7, tt_config => ['INTERPOLATE' => 1]}); process_ok("Foo $slash$slash$slash\$a Bar" => "Foo $slash$slash\$a Bar", {a=>7, tt_config => ['INTERPOLATE' => 1]}); process_ok('Foo $a.B Bar' => 'Foo 7 Bar', {a=>{B=>7,b=>{c=>sub{"(@_)"}}}, tt_config => ['INTERPOLATE' => 1]}); process_ok('Foo ${ a.B } Bar' => 'Foo 7 Bar', {a=>{B=>7,b=>{c=>sub{"(@_)"}}}, tt_config => ['INTERPOLATE' => 1]}); process_ok('Foo $a.b.c("hi") Bar' => "Foo Bar", {a=>{B=>7,b=>{c=>sub{"<@_>"}}}, tt_config => ['INTERPOLATE' => 1]}) if ! $is_tt; process_ok('Foo $a.b.c("hi") Bar' => "Foo <>(\"hi\") Bar", {a=>{B=>7,b=>{c=>sub{"<@_>"}}}, tt_config => ['INTERPOLATE' => 1]}) if $is_tt; process_ok('Foo ${a.b.c("hi")} Bar' => "Foo Bar", {a=>{B=>7,b=>{c=>sub{"<@_>"}}}, tt_config => ['INTERPOLATE' => 1]}); process_ok('Foo $a Bar $!a Baz' => "Foo 7 Bar 7 Baz", {a => 7, tt_config => ['INTERPOLATE' => 1]}) if ! $is_tt; process_ok('Foo $a Bar $!{a} Baz' => "Foo 7 Bar 7 Baz", {a => 7, tt_config => ['INTERPOLATE' => 1]}) if ! $is_tt; process_ok('Foo $a Bar $!a Baz' => "Foo 7 Bar 7 Baz", {a => 7, tt_config => ['INTERPOLATE' => 1, SHOW_UNDEFINED_INTERP => 1]}) if ! $is_tt; process_ok('Foo $a Bar $!{a} Baz' => "Foo 7 Bar 7 Baz", {a => 7, tt_config => ['INTERPOLATE' => 1, SHOW_UNDEFINED_INTERP => 1]}) if ! $is_tt; process_ok('Foo $a Bar $!a Baz' => "Foo \$a Bar Baz", {tt_config => ['INTERPOLATE' => 1, SHOW_UNDEFINED_INTERP => 1]}) if ! $is_tt; process_ok('Foo ${a} Bar $!{a} Baz' => "Foo \${a} Bar Baz", {tt_config => ['INTERPOLATE' => 1, SHOW_UNDEFINED_INTERP => 1]}) if ! $is_tt; ###----------------------------------------------------------------### print "### ANYCASE / TRIM ################################## $engine_option\n"; process_ok("[% GET %]" => '', {GET => 'ONE'}); process_ok("[% GET GET %]" => 'ONE', {GET => 'ONE'}) if ! $is_tt; process_ok("[% get one %]" => 'ONE', {one => 'ONE', tt_config => ['ANYCASE' => 1]}); process_ok("[% get %]" => '', {get => 'ONE', tt_config => ['ANYCASE' => 1]}); process_ok("[% get get %]" => 'ONE', {get => 'ONE', tt_config => ['ANYCASE' => 1]}) if ! $is_tt; process_ok("[% BLOCK foo %]\nhi\n[% END %][% PROCESS foo %]" => "\nhi\n"); process_ok("[% BLOCK foo %]\nhi[% END %][% PROCESS foo %]" => ($use_stream ? "\nhi" : "hi"), {tt_config => [TRIM => 1]}); process_ok("[% BLOCK foo %]hi\n[% END %][% PROCESS foo %]" => ($use_stream ? "hi\n" : "hi"), {tt_config => [TRIM => 1]}); process_ok("[% BLOCK foo %]hi[% nl %][% END %][% PROCESS foo %]" => ($use_stream ? "hi\n" : "hi"), {nl => "\n", tt_config => [TRIM => 1]}); process_ok("[% BLOCK foo %][% nl %]hi[% END %][% PROCESS foo %]" => ($use_stream ? "\nhi" : "hi"), {nl => "\n", tt_config => [TRIM => 1]}); process_ok("A[% TRY %]\nhi\n[% END %]" => ($use_stream ? "A\nhi\n" : "A\nhi"), {tt_config => [TRIM => 1]}); process_ok("[% FOO %]" => 'foo', {foo => 'foo', tt_config => [LOWER_CASE_VAR_FALLBACK => 1]}) if ! $is_tt; ###----------------------------------------------------------------### print "### V1DOLLAR ######################################## $engine_option\n"; process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|bar|bar|A', {a => 'A', A => 'bar'}); process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|A|bar|A', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1]}); $vars = {a => {b => {c=>'Cb'}, B => {c=>'CB'}}, b => 'B', Cb => 'bar', CB => 'Bar'}; process_ok('[% a.b.c %]|[% $a.b.c %]|[% a.$b.c %]|[% ${ a.b.c } %]' => 'Cb||CB|bar', $vars); process_ok('[% a.b.c %]|[% $a.b.c %]|[% a.$b.c %]|[% ${ a.b.c } %]' => 'Cb|Cb|Cb|bar', {%$vars, tt_config => [V1DOLLAR => 1]}); process_ok('[% "$a" %]/$a/[% "${a}" %]/${a}' => 'A/$a/A/${a}', {a => 'A', A => 'bar'}); process_ok('[% "$a" %]/$a/[% "${a}" %]/${a}' => 'A/$a/A/${a}', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1]}); process_ok('[% "$a" %]/$a/[% "${a}" %]/${a}' => 'A/A/A/A', {a => 'A', A => 'bar', tt_config => [INTERPOLATE => 1]}); process_ok('[% "$a" %]/$a/[% "${a}" %]/${a}' => 'A/A/A/A', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1, INTERPOLATE => 1]}); process_ok('[% constants.a %]|[% $constants.a %]|[% constants.$a %]' => 'A|A|A', {tt_config => [V1DOLLAR => 1, CONSTANTS => {a => 'A'}]}); ###----------------------------------------------------------------### print "### V2PIPE / V2EQUALS ############################### $engine_option\n"; process_ok("[%- BLOCK a %]b is [% b %] [% END %] [%- PROCESS a b => 237 | repeat(2) %]" => "b is 237 b is 237\n", {tt_config => [V2PIPE => 1]}); process_ok("[%- BLOCK a %]b is [% b %] [% END %] [%- PROCESS a b => 237 | repeat(2) %]" => "b is 237237\n") if ! $is_tt; process_ok("[% ('a' == 'b') || 0 %]" => 0); process_ok("[% ('a' != 'b') || 0 %]" => 1); process_ok("[% ('a' == 'b') || 0 %]" => 0, {tt_config => [V2EQUALS => 1]}) if ! $is_tt; process_ok("[% ('a' != 'b') || 0 %]" => 1, {tt_config => [V2EQUALS => 1]}) if ! $is_tt; process_ok("[% ('a' == 'b') || 0 %]" => 1, {tt_config => [V2EQUALS => 0]}) if ! $is_tt; process_ok("[% ('a' != 'b') || 0 %]" => 0, {tt_config => [V2EQUALS => 0]}) if ! $is_tt; process_ok("[% ('7' == '7.0') || 0 %]" => 0); process_ok("[% ('7' == '7.0') || 0 %]" => 1, {tt_config => [V2EQUALS => 0]}) if ! $is_tt; process_ok("[% (7 == 7.0) || 0 %]" => 1); process_ok("[% (7 == 7.0) || 0 %]" => 1, {tt_config => [V2EQUALS => 0]}) if ! $is_tt; ###----------------------------------------------------------------### print "### configuration ################################### $engine_option\n"; process_ok('[% a = 7 %]$a' => 7, {tt_config => ['INTERPOLATE' => 1]}); process_ok('[% a = 7 %]$a' => 7, {tt_config => ['interpolate' => 1]}) if ! $is_tt; ###----------------------------------------------------------------### print "### PERL ############################################ $engine_option\n"; process_ok("[% TRY %][% PERL %][% END %][% CATCH ; error; END %]" => 'perl error - EVAL_PERL not set'); process_ok("[% PERL %] print \"[% one %]\" [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]}); process_ok("[% PERL %] print \$stash->get('one') [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]}); process_ok("[% PERL %] print \$stash->set('a.b.c', 7) [% END %][% a.b.c %]" => '77', {tt_config => ['EVAL_PERL' => 1]}); process_ok("[% RAWPERL %]\$output .= 'interesting'[% END %]" => 'interesting', {tt_config => ['EVAL_PERL' => 1]}); ###----------------------------------------------------------------### print "### recursion prevention ############################ $engine_option\n"; process_ok("[% BLOCK foo %][% PROCESS bar %][% END %][% BLOCK bar %][% PROCESS foo %][% END %][% PROCESS foo %]" => '') if ! $is_tt; ###----------------------------------------------------------------### print "### META ############################################ $engine_option\n"; process_ok("[% template.name %]" => 'input text'); process_ok("[% META foo = 'bar' %][% template.foo %]" => 'bar'); process_ok("[% META name = 'bar' %][% template.name %]" => 'bar'); process_ok("[% META foo = 'bar' %][% component.foo %]" => 'bar'); process_ok("[% META foo = 'bar' %][% component = '' %][% component.foo %]|foo" => '|foo'); process_ok("[% META foo = 'bar' %][% template = '' %][% template.foo %]|foo" => '|foo'); ###----------------------------------------------------------------### print "### references ###################################### $engine_option\n"; process_ok("[% a=3; b=\\a; b; a %]" => 33); process_ok("[% a=3; b=\\a; a=7; b; a %]" => 77); process_ok("[% a={}; a.1=7; b=\\a.1; b; a.1 %]" => '77'); process_ok("[% a={}; a.1=7; b=\\a.20; a.20=7; b; a.20 %]" => '77'); process_ok("[% a=[]; a.1=7; b=\\a.1; b; a.1 %]" => '77'); process_ok("[% a=[]; a.1=7; b=\\a.20; a.20=7; b; a.20 %]" => '77'); process_ok("[% \\a %]" => qr/^CODE/, {a => sub { return "a sub [@_]" } }); process_ok("[% b=\\a; b %]" => 'a sub []', {a => sub { return "a sub [@_]" } }); process_ok("[% b=\\a(1); b %]" => 'a sub [1]', {a => sub { return "a sub [@_]" } }); process_ok("[% b=\\a; b(2) %]" => 'a sub [2]', {a => sub { return "a sub [@_]" } }); process_ok("[% b=\\a(1); b(2) %]" => 'a sub [1 2]', {a => sub { return "a sub [@_]" } }); process_ok("[% f=\\j.k; j.k=7; f %]" => '7', {j => {k => 3}}); process_ok('[% a = "a" ; f = {a=>"A",b=>"B"} ; foo = \f.$a ; foo %]' => 'A'); process_ok('[% a = "a" ; f = {a=>"A",b=>"B"} ; foo = \f.$a ; a = "b" ; foo %]' => 'A'); process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-") ; a = "cd"; foo %]' => '-AB-cd'); process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-").replace("-AB-", "*") ; a = "cd"; foo %]' => '*cd'); process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-") ; f = "ab"; foo %]' => '-AB-cd'); process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-").replace("-AB-", "*") ; f = "ab"; foo %]' => '*cd'); ###----------------------------------------------------------------### print "### reserved words ################################## $engine_option\n"; $vars = { GET => 'named_get', get => 'lower_named_get', named_get => 'value of named_get', hold_get => 'GET', }; process_ok("[% GET %]" => '', $vars); process_ok("[% GET GET %]" => 'named_get', $vars) if ! $is_tt; process_ok("[% GET get %]" => 'lower_named_get', $vars); process_ok("[% GET \${'GET'} %]" => 'bar', {GET => 'bar'}); process_ok("[% GET = 1 %][% GET GET %]" => '', $vars); process_ok("[% SET GET = 1 %][% GET GET %]" => '1', $vars) if ! $is_tt; process_ok("[% GET \$hold_get %]" => 'named_get', $vars); process_ok("[% GET \$GET %]" => 'value of named_get', $vars) if ! $is_tt; process_ok("[% BLOCK GET %]hi[% END %][% PROCESS GET %]" => 'hi') if ! $is_tt; process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo a = GET %]" => 'hi', $vars) if ! $is_tt; process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo GET = 1 %]" => ''); process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo IF GET %]" => 'hi', $vars) if ! $is_tt; ###----------------------------------------------------------------### print "### embedded items ################################## $engine_option\n"; process_ok('[% " \" " %]' => ' " '); process_ok('[% " \$foo " %]' => ' $foo '); process_ok('[% " \${foo} " %]' => ' ${foo} '); process_ok('[% " \n " %]' => " \n "); process_ok('[% " \t " %]' => " \t "); process_ok('[% " \r " %]' => " \r "); process_ok("[% 'foo\\'bar' %]" => "foo'bar"); process_ok('[% "foo\\"bar" %]' => 'foo"bar'); process_ok('[% qw(foo \)).1 %]' => ')') if ! $is_tt; process_ok('[% qw|foo \||.1 %]' => '|') if ! $is_tt; process_ok("[% ' \\' ' %]" => " ' "); process_ok("[% ' \\r ' %]" => ' \r '); process_ok("[% ' \\n ' %]" => ' \n '); process_ok("[% ' \\t ' %]" => ' \t '); process_ok("[% ' \$foo ' %]" => ' $foo '); process_ok('[% A = "bar" ; ${ "A" } %]' => 'bar'); process_ok('[% A = "bar" ; "(${ A })" %]' => '(bar)'); process_ok('[% A = "bar" ; ${ {a => "A"}.a } %]' => 'bar') if ! $is_tt; process_ok('[% A = "bar" ; "(${ {a => "A"}.a })" %]' => '(A)') if ! $is_tt; process_ok('[% A = "bar" ; "(${ ${ {a => "A"}.a } })" %]' => '(bar)') if ! $is_tt; process_ok('[% A = "bar" %](${ {a => "A"}.a })' => '(A)', {tt_config => [INTERPOLATE => 1]}) if ! $is_tt; process_ok('[% A = "bar" %](${ ${ {a => "A"}.a } })' => '(bar)', {tt_config => [INTERPOLATE => 1]}) if ! $is_tt; process_ok('[% "[%" %]' => '[%') if ! $is_tt; process_ok('[% "%]" %]' => '%]') if ! $is_tt; process_ok('[% a = "[% %]" %][% a %]' => '[% %]') if ! $is_tt; process_ok('[% qw([% 1 + 2 %]).join %]' => '[% 1 + 2 %]') if ! $is_tt; ###----------------------------------------------------------------### print "### STRICT ########################################## $engine_option\n"; process_ok("[% TRY; foo; CATCH; error; END %]" => qr'var.undef error - undefined variable: foo.*', {tt_config => [STRICT => 1]}); process_ok("[% TRY; foo.bar(1); CATCH; error; END %]" => qr'var.undef error - undefined variable: foo\.bar\(1\).*', {tt_config => [STRICT => 1]}); process_ok("[% TRY; 1 IF foo.bar.baz; CATCH; error; END %]" => qr'var.undef error - undefined variable: foo\.bar\.baz.*', {tt_config => [STRICT => 1]}); if (! $is_tt) { process_ok("[% foo.bar() %]ok" => 'ok', {tt_config => [STRICT => 1, STRICT_THROW => sub { my ($t, $y, $m, $args) = @_; return if $args->{'name'} eq 'foo.bar()'; $t->throw($y,$m)}]}); process_ok("[% foo.baz() %]ok" => '', {tt_config => [STRICT => 1, STRICT_THROW => sub { my ($t, $y, $m, $args) = @_; return if $args->{'name'} eq 'foo.bar()'; $t->throw($y,$m)}]}); } ###----------------------------------------------------------------### print "### EVALUATE ######################################## $engine_option\n"; process_ok('[% foo | eval %]' => 'baz', {foo => '[% bar %]', bar => 'baz'}); process_ok('[% "[% 1 + 2 %]" | eval %]' => '3') if ! $is_tt; process_ok('[% qw([% 1 + 2 %]).join.eval %]' => '3') if ! $is_tt; process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'caught\' ; END %]"; f.eval %]' => '>>>>>caught', {tt_config => [MAX_EVAL_RECURSE => 5]}) if ! $is_tt; process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'caught\' ; END %]"; f.eval; f.eval %]' => '>>>>>caught>>>>>caught', {tt_config => [MAX_EVAL_RECURSE => 5]}) if ! $is_tt; process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'foo\' ; END %]"; f.eval;f.eval %]' => '>>foo>>foo', {tt_config => [MAX_EVAL_RECURSE => 2]}) if ! $is_tt; process_ok("[% '#set(\$foo = 12)'|eval(syntax => 'velocity') %]|[% foo %]" => '|12') if ! $is_tt; process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'caught\' ; END %]"; EVALUATE f %]' => '>>>>>caught', {tt_config => [MAX_EVAL_RECURSE => 5]}) if ! $is_tt; process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'foo\' ; END %]"; EVALUATE f; EVALUATE f %]' => '>>foo>>foo', {tt_config => [MAX_EVAL_RECURSE => 2]}) if ! $is_tt; process_ok("[% EVALUATE '#set(\$foo = 12)' syntax => 'velocity' %]|[% foo %]" => '|12') if ! $is_tt; if (!$is_tt) { process_ok("[% TRY; '[% bar %]'.eval(STRICT => 1); CATCH; error; END %]" => 'var.undef error - undefined variable: bar in input text'); process_ok("[% TRY; CONFIG STRICT => 1; '[% bar %]'.eval(STRICT => 0); CATCH; error; END %]" => 'eval_strict error - Cannot disable STRICT once it is enabled'); process_ok("[% TRY; '[% bar %]'.eval(STRICT => 1); CATCH; error.type; END; bing %] - ok" => 'var.undef - ok'); # restricted to sub components } ###----------------------------------------------------------------### print "### DUMP ############################################ $engine_option\n"; if (! $is_tt) { local $ENV{'REQUEST_METHOD'} = 0; process_ok("[% DUMP a %]" => "DUMP: File \"input text\" line 1\n a = undef;\n"); process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = undef;'); process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = \'s\';', {a => "s"}); process_ok("[%\n p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 2 a = \'s\';', {a => "s"}); process_ok("[% p = DUMP a, b; p.collapse %]" => 'DUMP: File "input text" line 1 a, b = [ \'s\', undef ];', {a => "s"}); process_ok("[% p = DUMP a Useqq => 'b'; p.collapse %]" => 'DUMP: File "input text" line 1 a Useqq => \'b\' = [ \'s\', { \'Useqq\' => \'b\' } ];', {a => "s"}); process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = "s";', {a => "s", tt_config => [DUMP => {Useqq => 1}]}); process_ok("[% p = DUMP a; p.collapse %]|foo" => '|foo', {a => "s", tt_config => [DUMP => 0]}); process_ok("[% p = DUMP _a, b; p.collapse %]" => 'DUMP: File "input text" line 1 _a, b = [ undef, \'c\' ];', {_a => "s", b=> "c"}); process_ok("[% p = DUMP {a => 'b'}; p.collapse %]" => 'DUMP: File "input text" line 1 {a => \'b\'} = { \'a\' => \'b\' };'); process_ok("[% p = DUMP _a; p.collapse %]" => 'DUMP: File "input text" line 1 _a = undef;', {_a => "s"}); process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = { \'b\' => \'c\' };', {a => {b => 'c'}}); process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = {};', {a => {_b => 'c'}}); process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 a = {};', {a => {_b => 'c'}, tt_config => [DUMP => {Sortkeys => 1}]}); process_ok("[% p = DUMP a; p.collapse %]" => 'DUMP: File "input text" line 1 Dump(7)', {a => 7, tt_config => [DUMP => {handler=>sub {"Dump(@_)"}}]}); process_ok("[% p = DUMP a; p.collapse %]" => 'a = \'s\';', {a => "s", tt_config => [DUMP => {header => 0}]}); process_ok("[% p = DUMP a; p.collapse %]" => '
a = 's';
', {a => "s", tt_config => [DUMP => {header => 0, html => 1}]}); local $ENV{'REQUEST_METHOD'} = 1; process_ok("[% p = DUMP a; p.collapse %]" => '
a = 's';
', {a => "s", tt_config => [DUMP => {header => 0}]}); process_ok("[% p = DUMP a; p.collapse %]" => 'a = \'s\';', {a => "s", tt_config => [DUMP => {header => 0, html => 0}]}); local $ENV{'REQUEST_METHOD'} = 0; process_ok("[% SET global; p = DUMP; p.collapse %]" => "DUMP: File \"input text\" line 1 EntireStash = { 'a' => 'b', 'global' => undef };", {a => 'b', tt_config => [DUMP => {Sortkeys => 1}]}); process_ok("[% SET global; p = DUMP; p.collapse %]" => "DUMP: File \"input text\" line 1 EntireStash = { 'a' => 'b', 'global' => undef };", {a => 'b', tt_config => [DUMP => {Sortkeys => 1, EntireStash => 1}]}); process_ok("[% SET global; p = DUMP; p.collapse %]" => "DUMP: File \"input text\" line 1", {a => 'b', tt_config => [DUMP => {Sortkeys => 1, EntireStash => 0}]}); } ###----------------------------------------------------------------### print "### SYNTAX ########################################## $engine_option\n"; if (! $is_tt) { process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "", {tt_config => [SYNTAX => 'garbage']}); process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237237"); process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237237", {tt_config => [SYNTAX => 'alloy']}); process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237237", {tt_config => [SYNTAX => 'tt3']}); process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237b is 237", {tt_config => [SYNTAX => 'tt2']}); process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237b is 237", {tt_config => [SYNTAX => 'tt1']}); process_ok("[%- BLOCK a %]b is [% b %][% END %][% PROCESS a b => 237 | repeat(2) %]" => "b is 237b is 237", {tt_config => [SYNTAX => 'tt1']}); process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|bar|bar|A', {a => 'A', A => 'bar'}); process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|bar|bar|A', {a => 'A', A => 'bar', tt_config => [SYNTAX => 'tt2']}); process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|A|bar|A', {a => 'A', A => 'bar', tt_config => [SYNTAX => 'tt1']}); process_ok("" => "FOO", {foo => "FOO", tt_config => [SYNTAX => 'ht']}); process_ok("" => "7 8", {tt_config => [SYNTAX => 'hte']}); process_ok("" => "1", {tt_config => [SYNTAX => 'hte']}); process_ok("" => "1", {tt_config => [SYNTAX => 'hte']}); process_ok("d" => "", {tt_config => [SYNTAX => 'ht']}); process_ok("[% \"\"|eval(syntax => 'hte') %] = [% 6 %]" => "6 = 6"); process_ok("[% \"\"|eval(syntax => 'ht') %] = [% 6 %]" => ""); process_ok("[% \"\"|eval(syntax => 'ht') %] = [% 12 %]" => "12 = 12", {foo => 12}); } ###----------------------------------------------------------------### print "### CONFIG ########################################## $engine_option\n"; if (! $is_tt) { process_ok("[% CONFIG ANYCASE => 1 %][% get 234 %]" => 234); process_ok("[% CONFIG anycase => 1 %][% get 234 %]" => 234); process_ok("[% CONFIG PRE_CHOMP => '-' %]\n[% 234 %]" => 234); process_ok("[% CONFIG POST_CHOMP => '-' %][% 234 %]\n" => 234); process_ok("[% CONFIG INTERPOLATE => 1 %]\${ 234 }" => 234); process_ok("[% CONFIG V1DOLLAR => 1 %][% a = 234 %][% \$a %]" => 234); process_ok("[% CONFIG V2PIPE => 1 %][% BLOCK a %]b is [% b %][% END %][% PROCESS a b => 234 | repeat(2) %]" => "b is 234b is 234"); process_ok("[% CONFIG V2EQUALS => 1 %][% ('7' == '7.0') || 0 %]" => 0); process_ok("[% CONFIG V2EQUALS => 0 %][% ('7' == '7.0') || 0 %]" => 1); process_ok("[% CONFIG BOGUS => 2 %]bar" => ''); process_ok("[% CONFIG ANYCASE %]|[% CONFIG ANYCASE => 1 %][% CONFIG ANYCASE %]" => 'CONFIG ANYCASE = undef|CONFIG ANYCASE = 1'); process_ok("[% CONFIG ANYCASE %]|[% CONFIG ANYCASE => 1 %][% CONFIG ANYCASE %]" => 'CONFIG ANYCASE = undef|CONFIG ANYCASE = 1'); process_ok("[% \"[% GET 1+2+3 %]\" | eval %] = [% get 6 %]" => "", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; process_ok("[% CONFIG ANYCASE => 1 %][% get 6 %]" => "6", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; process_ok("[% CONFIG ANYCASE => 1 %][% \"[% get 1+2+3 %]\" | eval %] = [% get 6 %]" => "6 = 6", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; process_ok("[% \"[% CONFIG ANYCASE => 1 %][% get 1+2+3 %]\" | eval %] = [% get 6 %]" => "", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; process_ok("[% \"[% CONFIG ANYCASE => 1 %][% get 1+2+3 %]\" | eval %] = [% GET 6 %]" => "6 = 6", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; process_ok("[% CONFIG SYNTAX => 'hte' %][% \"\"|eval %] = [% 6 %]" => "6 = 6"); process_ok("[% \"[% get 1+2+3 %]\" | eval(ANYCASE => 1) %] = [% GET 6 %]" => "6 = 6", {tt_config => [SEMICOLONS => 1]}) if ! $is_tt; process_ok("[% CONFIG DUMP %]|[% CONFIG DUMP => 0 %][% DUMP %]bar" => 'CONFIG DUMP = undef|bar'); process_ok("[% CONFIG DUMP => {Useqq=>1, header=>0, html=>0} %][% DUMP 'foo' %]" => "'foo' = \"foo\";\n"); process_ok("[% CONFIG VMETHOD_FUNCTIONS => 0 %][% sprintf('%d %d', 7, 8) %] d" => ' d'); process_ok("[% TRY; foo; CONFIG STRICT => 1; bar; CATCH; error; END %]" => 'var.undef error - undefined variable: bar in input text'); process_ok("[% TRY; foo; CONFIG STRICT => 1; CONFIG STRICT => 0; bar; CATCH; error; END %]" => 'config.strict error - Cannot disable STRICT once it is enabled'); process_ok("[% BLOCK foo; CONFIG STRICT => 1; baz; END; TRY; bam; PROCESS foo; bar; CATCH; error.type; END; bing %] - ok" => 'var.undef - ok'); # restricted to sub components process_ok('[% CONFIG AUTO_FILTER => "html"; foo %]', => '&', {foo => '&'}) if ! $is_tt; } ###----------------------------------------------------------------### print "### DONE ############################################ $engine_option\n"; } # end of for libtemplate-alloy-perl-1.022/t/10_tt_includes.t000066400000000000000000000441701402714000200213370ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 01_includes.t - Test the file include functionality of Template::Alloy - including some edge cases =cut our ($module, $is_tt, $compile_perl, $use_stream); BEGIN { $module = 'Template::Alloy'; if ($ENV{'USE_TT'} || grep {/tt/i} @ARGV) { $module = 'Template'; } $is_tt = $module eq 'Template'; }; use strict; use Test::More tests => (! $is_tt) ? 351 : 106; use constant test_taint => 0 && eval { require Taint::Runtime }; use_ok($module); Taint::Runtime::taint_start() if test_taint; ### find a place to allow for testing my $test_dir = $0 .'.test_dir'; END { unlink "$test_dir/stream.out"; rmdir $test_dir } mkdir $test_dir, 0755; ok(-d $test_dir, "Got a test dir up and running"); mkdir "$test_dir/nested", 0755; END { rmdir "$test_dir/nested" } ok(-d $test_dir, "Got a nested test dir up and running"); sub process_ok { # process the value and say if it was ok my $str = shift; my $test = shift; my $vars = shift || {}; my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || []; push @$conf, (COMPILE_PERL => $compile_perl) if $compile_perl; push @$conf, (STREAM => 1) if $use_stream; my $obj = shift || $module->new(@$conf, ABSOLUTE => 1, INCLUDE_PATH => $test_dir); # new object each time my $out = ''; my $line = (caller)[2]; delete $vars->{'tt_config'}; Taint::Runtime::taint(\$str) if test_taint; my $fh; if ($use_stream) { open($fh, ">", "$test_dir/stream.out") || return ok(0, "Line $line \"$str\" - Can't open stream.out: $!"); select $fh; } $obj->process(\$str, $vars, \$out); if ($use_stream) { select STDOUT; close $fh; open($fh, "<", "$test_dir/stream.out") || return ok(0, "Line $line \"$str\" - Can't read stream.out: $!"); $out = ''; read($fh, $out, -s "$test_dir/stream.out"); } my $ok = ref($test) ? $out =~ $test : $out eq $test; if ($ok) { ok(1, "Line $line \"$str\" => \"$out\""); return $obj; } else { ok(0, "Line $line \"$str\""); warn "# Was:\n$out\n# Should've been:\n$test\n"; print map {"$_\n"} grep { defined } $obj->error if $obj->can('error'); print $obj->dump_parse_tree(\$str) if $obj->can('dump_parse_tree'); if ($compile_perl && $obj->can('compile_template')) { foreach my $key (sort keys %{ $obj->{'_documents'} }) { my $v = $obj->{'_documents'}->{$key}; print "--------------------- $key ---------------------\n"; print ${ $obj->compile_template($v) }; } } exit; } } ### create some files to include my @files; END { unlink @files }; sub write_file { my ($file, $content) = @_; push @files, $file; open(my $fh, ">", $file) || die "Couldn't open $file: $!"; print $fh $content; close $fh; } write_file("$test_dir/foo.tt", "([% template.foo %][% INCLUDE bar.tt %])"); write_file("$test_dir/bar.tt", "[% blue %]BAR"); write_file("$test_dir/baz.tt", "[% SET baz = 42 %][% baz %][% bing %]"); write_file("$test_dir/wrap.tt", "Hi[% baz; template.foo; baz = 'wrap' %][% content %]there"); write_file("$test_dir/meta.tt", "[% META bar='meta.tt' %]Metafoo([% component.foo %]) Metabar([% component.bar %])"); write_file("$test_dir/catch.tt", "Error ([% error.type %]) - ([% error.info %])"); write_file("$test_dir/catch2.tt", "Error2 ([% error.type %]) - ([% error.info %])"); write_file("$test_dir/die.tt", "[% THROW bing 'blang' %])"); write_file("$test_dir/config.tt", "[% CONFIG DUMP => {html => 1} %][% DUMP foo %]"); write_file("$test_dir/config2.tt", "[% PROCESS nested %][% BLOCK nested %][% CONFIG DUMP => {html => 0} %][% DUMP foo %][% END %]"); write_file("$test_dir/template.tt", "<<[% PROCESS \$template %][% content %]>>"); write_file("$test_dir/nested/foo.tt", "(Nested foo [% INCLUDE bar.tt %])"); write_file("$test_dir/nested/bar.tt", "Nested bar"); write_file("$test_dir/nested/foo2.tt", "(Nested foo [% INCLUDE bar2.tt %])"); write_file("$test_dir/nested/bar2.tt", "Nested bar2"); write_file("$test_dir/blocks.tt", " [%~ BLOCK bar %]bar[% END ~%] [%~ BLOCK foo %]I am [% text || 'foo' %] - [% template.blam %][% PROCESS bar %][% END ~%] [%~ MACRO foo_m(text) BLOCK %]I am [% text || 'foo_m' %] - [% template.blam %][% END ~%] [%~ META blam = 'BLAM' ~%] "); for my $opt ('normal', 'compile_perl', 'stream') { $compile_perl = ($opt eq 'compile_perl'); $use_stream = ($opt eq 'stream'); next if $is_tt && ($compile_perl || $use_stream); my $engine_option = "engine_option ($opt)"; ###----------------------------------------------------------------### print "### INSERT ########################################## $engine_option\n"; process_ok("([% INSERT bar.tt %])" => '([% blue %]BAR)'); process_ok("([% SET file = 'bar.tt' %][% INSERT \$file %])" => '([% blue %]BAR)'); process_ok("([% SET file = 'bar.tt' %][% INSERT \${file} %])" => '([% blue %]BAR)') if ! $is_tt; process_ok("([% SET file = 'bar.tt' %][% INSERT \"\$file\" %])" => '([% blue %]BAR)'); process_ok("([% SET file = 'bar' %][% INSERT \"\${file}.tt\" %])" => '([% blue %]BAR)'); ###----------------------------------------------------------------### print "### INCLUDE ######################################### $engine_option\n"; process_ok("([% INCLUDE bar.tt %])" => '(BAR)'); process_ok("[% PROCESS foo.tt %]" => '(BAR)'); process_ok("[% PROCESS meta.tt %]" => 'Metafoo() Metabar(meta.tt)'); process_ok("[% META foo = 'string'; PROCESS meta.tt %]" => 'Metafoo() Metabar(meta.tt)'); process_ok("[% PROCESS meta.tt %][% template.bar %]" => 'Metafoo() Metabar(meta.tt)'); process_ok("[% META foo = 'meta'; PROCESS foo.tt %]" => '(metaBAR)'); process_ok("([% SET file = 'bar.tt' %][% INCLUDE \$file %])" => '(BAR)'); process_ok("([% SET file = 'bar.tt' %][% INCLUDE \${file} %])" => '(BAR)') if ! $is_tt; process_ok("([% SET file = 'bar.tt' %][% INCLUDE \"\$file\" %])" => '(BAR)'); process_ok("([% SET file = 'bar' %][% INCLUDE \"\${file}.tt\" %])" => '(BAR)'); process_ok("([% INCLUDE baz.tt %])" => '(42)'); process_ok("([% INCLUDE baz.tt %])[% baz %]" => '(42)'); process_ok("[% SET baz = 21 %]([% INCLUDE baz.tt %])[% baz %]" => '(42)21'); process_ok("([% META blam = 5; INCLUDE blocks.tt %])" => '()'); process_ok("([% META blam = 5; INCLUDE blocks.tt %])([% PROCESS foo text => 'bar' %])" => ($use_stream ? '()(' : '')); process_ok("([% META blam = 5; INCLUDE blocks.tt %])([% foo_m('hey') %])" => '()()'); process_ok("([% META blam = 5; INCLUDE blocks.tt/foo text => 'bar' %])" => ($use_stream ? '(' : '')); process_ok("([% META blam = 5; INCLUDE blocks.tt/bar %])" => '(bar)', {tt_config => [EXPOSE_BLOCKS => 1]}); process_ok("([% META blam = 5; INCLUDE blocks.tt/foo text => 'bar' %])" => ($use_stream ? '(I am bar - 5' : ''), {tt_config => [EXPOSE_BLOCKS => 1]}); ###----------------------------------------------------------------### print "### PROCESS ######################################### $engine_option\n"; process_ok("([% PROCESS bar.tt %])" => '(BAR)'); process_ok("[% PROCESS foo.tt %]" => '(BAR)'); process_ok("[% PROCESS meta.tt %]" => 'Metafoo() Metabar(meta.tt)'); process_ok("[% META foo = 'string'; PROCESS meta.tt %]" => 'Metafoo() Metabar(meta.tt)'); process_ok("[% PROCESS meta.tt %][% template.bar %]" => 'Metafoo() Metabar(meta.tt)'); process_ok("[% META foo = 'meta'; PROCESS foo.tt %]" => '(metaBAR)'); process_ok("([% SET file = 'bar.tt' %][% PROCESS \$file %])" => '(BAR)'); process_ok("([% SET file = 'bar.tt' %][% PROCESS \${file} %])" => '(BAR)') if ! $is_tt; process_ok("([% SET file = 'bar.tt' %][% PROCESS \"\$file\" %])" => '(BAR)'); process_ok("([% SET file = 'bar' %][% PROCESS \"\${file}.tt\" %])" => '(BAR)'); process_ok("([% PROCESS baz.tt %])" => '(42)'); process_ok("([% PROCESS baz.tt %])[% baz %]" => '(42)42'); process_ok("[% SET baz = 21 %]([% PROCESS baz.tt %])[% baz %]" => '(42)42'); process_ok("[% PROCESS nested/foo.tt %]" => '(Nested foo BAR)'); process_ok("[% PROCESS nested/foo.tt %]" => '(Nested foo Nested bar)', {tt_config => [ADD_LOCAL_PATH => 1]}) if ! $is_tt; process_ok("[% PROCESS nested/foo.tt %]" => '(Nested foo BAR)', {tt_config => [ADD_LOCAL_PATH => -1]}) if ! $is_tt; process_ok("[% CONFIG ADD_LOCAL_PATH => 1 ; PROCESS nested/foo.tt %]" => '(Nested foo Nested bar)') if ! $is_tt; process_ok("[% PROCESS nested/foo2.tt %]" => ($use_stream ? '(Nested foo ' : '')); process_ok("[% PROCESS nested/foo2.tt %]" => '(Nested foo Nested bar2)', {tt_config => [ADD_LOCAL_PATH => 1]}) if ! $is_tt; process_ok("[% PROCESS nested/foo2.tt %]" => '(Nested foo Nested bar2)', {tt_config => [ADD_LOCAL_PATH => -1]}) if ! $is_tt; process_ok("[% CONFIG ADD_LOCAL_PATH => 1 ; PROCESS nested/foo2.tt %]" => '(Nested foo Nested bar2)') if ! $is_tt; process_ok("([% META blam = 5; PROCESS blocks.tt %])" => '()'); process_ok("([% META blam = 5; PROCESS blocks.tt %])([% PROCESS foo text => 'bar' %])" => '()(I am bar - 5bar)'); process_ok("([% META blam = 5; PROCESS blocks.tt %])([% foo_m('hey') %])" => '()(I am hey - 5)'); process_ok("([% META blam = 5; PROCESS blocks.tt/foo text => 'bar' %])" => ($use_stream ? '(' : '')); process_ok("([% META blam = 5; PROCESS blocks.tt/bar %])" => '(bar)', {tt_config => [EXPOSE_BLOCKS => 1]}); process_ok("([% META blam = 5; PROCESS blocks.tt/foo text => 'bar' %])" => ($use_stream ? '(I am bar - 5' : ''), {tt_config => [EXPOSE_BLOCKS => 1]}); ###----------------------------------------------------------------### print "### WRAPPER ######################################### $engine_option\n"; process_ok("([% WRAPPER wrap.tt %])" => ''); process_ok("([% WRAPPER wrap.tt %] one [% END %])" => '(Hi one there)'); process_ok("([% WRAPPER wrap.tt %] ([% baz %]) [% END %])" => '(Hi () there)'); process_ok("([% WRAPPER wrap.tt %] one [% END %])" => '(HiBAZ one there)', {baz => 'BAZ'}); process_ok("([% WRAPPER wrap.tt %] ([% baz; baz='-local' %]) [% END %][% baz %])" => '(Hi-local () there-local)'); process_ok("([% WRAPPER wrap.tt %][% META foo='BLAM' %] [% END %])" => '(HiBLAM there)'); ###----------------------------------------------------------------### print "### CONFIG PRE_PROCESS ############################## $engine_option\n"; process_ok("Foo" => "BARFoo", {tt_config => [PRE_PROCESS => 'bar.tt']}); process_ok("Foo" => "BARFoo", {tt_config => [PRE_PROCESS => ['bar.tt']]}); process_ok("Foo" => "(BAR)BARFoo", {tt_config => [PRE_PROCESS => ['foo.tt', 'bar.tt']]}); process_ok("Foo" => "BlueBARFoo", {tt_config => [PRE_PROCESS => 'bar.tt'], blue => 'Blue'}); process_ok("Foo[% blue='Blue' %]" => "BARFoo", {tt_config => [PRE_PROCESS => 'bar.tt']}); process_ok("Foo[% META foo='meta' %]" => "(metaBAR)Foo", {tt_config => [PRE_PROCESS => 'foo.tt']}); process_ok("([% WRAPPER wrap.tt %] one [% END %])" => 'BAR(Hi one there)', {tt_config => [PRE_PROCESS => 'bar.tt']}); process_ok("Foo" => "<>Foo", {tt_config => [PRE_PROCESS => 'template.tt']}); ###----------------------------------------------------------------### print "### CONFIG POST_PROCESS ############################# $engine_option\n"; process_ok("Foo" => "FooBAR", {tt_config => [POST_PROCESS => 'bar.tt']}); process_ok("Foo" => "FooBAR", {tt_config => [POST_PROCESS => ['bar.tt']]}); process_ok("Foo" => "Foo(BAR)BAR", {tt_config => [POST_PROCESS => ['foo.tt', 'bar.tt']]}); process_ok("Foo" => "FooBlueBAR", {tt_config => [POST_PROCESS => 'bar.tt'], blue => 'Blue'}); process_ok("Foo[% blue='Blue' %]" => "FooBlueBAR", {tt_config => [POST_PROCESS => 'bar.tt']}); process_ok("Foo[% META foo='meta' %]" => "Foo(metaBAR)", {tt_config => [POST_PROCESS => 'foo.tt']}); process_ok("([% WRAPPER wrap.tt %] one [% END %])" => '(Hi one there)BAR', {tt_config => [POST_PROCESS => 'bar.tt']}); process_ok("Foo" => "Foo<>", {tt_config => [POST_PROCESS => 'template.tt']}); ###----------------------------------------------------------------### print "### CONFIG PROCESS ################################## $engine_option\n"; process_ok("Foo" => "BAR", {tt_config => [PROCESS => 'bar.tt']}); process_ok("Foo" => "BAR", {tt_config => [PROCESS => ['bar.tt']]}); process_ok("Foo" => "(BAR)BAR", {tt_config => [PROCESS => ['foo.tt', 'bar.tt']]}); process_ok("Foo" => "BlueBAR", {tt_config => [PROCESS => 'bar.tt'], blue => 'Blue'}); process_ok("Foo[% META foo='meta' %]" => "(metaBAR)", {tt_config => [PROCESS => 'foo.tt']}); process_ok("Foo[% META foo='meta' %]" => "BAR(metaBAR)", {tt_config => [PRE_PROCESS => 'bar.tt', PROCESS => 'foo.tt']}); process_ok("Foo[% META foo='meta' %]" => "(metaBAR)BAR", {tt_config => [POST_PROCESS => 'bar.tt', PROCESS => 'foo.tt']}); process_ok("Foo" => "<>", {tt_config => [PROCESS => 'template.tt']}); ###----------------------------------------------------------------### print "### CONFIG WRAPPER ################################## $engine_option\n"; process_ok(" one " => 'Hi one there', {tt_config => [WRAPPER => 'wrap.tt']}); process_ok(" one " => 'Hi one there', {tt_config => [WRAPPER => ['wrap.tt']]}); process_ok(" one " => 'HiwrapHi one therethere', {tt_config => [WRAPPER => ['wrap.tt', 'wrap.tt']]}); process_ok(" ([% baz %]) " => 'Hi () there', {tt_config => [WRAPPER => 'wrap.tt']}); process_ok(" one " => 'HiBAZ one there', {baz => 'BAZ', tt_config => [WRAPPER => 'wrap.tt']});; process_ok(" ([% baz; baz='-local' %]) " => 'Hi-local () there', {tt_config => [WRAPPER => 'wrap.tt']}); process_ok("[% META foo='BLAM' %] " => 'HiBLAM there', {tt_config => [WRAPPER => 'wrap.tt']}); process_ok(" one " => 'BARHi one there', {tt_config => [WRAPPER => 'wrap.tt', PRE_PROCESS => 'bar.tt']}); process_ok(" one " => 'HiBARthere', {tt_config => [WRAPPER => 'wrap.tt', PROCESS => 'bar.tt']}); process_ok(" one " => 'Hi one thereBAR', {tt_config => [WRAPPER => 'wrap.tt', POST_PROCESS => 'bar.tt']}); process_ok("Foo" => "<>", {tt_config => [WRAPPER => 'template.tt']}); ###----------------------------------------------------------------### print "### CONFIG ERRORS ################################### $engine_option\n"; process_ok("[% THROW foo 'bar' %]" => 'Error (foo) - (bar)', {tt_config => [ERROR => 'catch.tt']}); process_ok("[% THROW foo 'bar' %]" => 'Error (foo) - (bar)', {tt_config => [ERRORS => 'catch.tt']}); process_ok("[% THROW foo 'bar' %]" => 'Error (foo) - (bar)', {tt_config => [ERROR => {default => 'catch.tt'}]}); process_ok("[% THROW foo 'bar' %]" => 'Error (foo) - (bar)', {tt_config => [ERRORS => {default => 'catch.tt'}]}); process_ok("[% THROW foo 'bar' %]" => 'Error2 (foo) - (bar)', {tt_config => [ERRORS => {foo => 'catch2.tt', default => 'catch.tt'}]}); process_ok("[% THROW foo.baz 'bar' %]" => 'Error2 (foo.baz) - (bar)', {tt_config => [ERRORS => {foo => 'catch2.tt', default => 'catch.tt'}]}); process_ok("[% THROW foo.baz 'bar' %]" => 'Error2 (foo.baz) - (bar)', {tt_config => [ERRORS => {'foo.baz' => 'catch2.tt', default => 'catch.tt'}]}); process_ok("[% THROW foo 'bar' %]" => 'Error (foo) - (bar)', {tt_config => [ERRORS => {'foo.baz' => 'catch2.tt', default => 'catch.tt'}]}); process_ok("[% THROW foo.baz 'bar' %]" => 'Error2 (foo.baz) - (bar)', {tt_config => [ERRORS => {foo => 'catch2.tt', default => 'catch.tt'}]}); process_ok("[% THROW foo 'bar' %]" => 'BARError (foo) - (bar)', {tt_config => [ERROR => 'catch.tt', PRE_PROCESS => 'bar.tt']}); process_ok("[% THROW foo 'bar' %]" => 'Error (bing) - (blang)', {tt_config => [ERROR => 'catch.tt', PROCESS => 'die.tt']}); process_ok("[% THROW foo 'bar' %]" => 'Error (bing) - (blang)', {tt_config => [ERROR => 'catch.tt', PROCESS => ['bar.tt', 'die.tt']]}) if ! $use_stream; process_ok("[% THROW foo 'bar' %]" => 'BARError (bing) - (blang)', {tt_config => [ERROR => 'catch.tt', PROCESS => ['bar.tt', 'die.tt']]}) if $use_stream; process_ok("[% THROW foo 'bar' %]" => 'Error (foo) - (bar)BAR', {tt_config => [ERROR => 'catch.tt', POST_PROCESS => 'bar.tt']}); process_ok("[% THROW foo 'bar' %]" => 'HiError (foo) - (bar)there', {tt_config => [ERROR => 'catch.tt', WRAPPER => 'wrap.tt']}); process_ok("(outer)[% PROCESS 'die.tt' %]" => 'Error (bing) - (blang)', {tt_config => [ERROR => 'catch.tt']}) if ! $use_stream; process_ok("(outer)[% PROCESS 'die.tt' %]" => '(outer)Error (bing) - (blang)', {tt_config => [ERROR => 'catch.tt']}) if $use_stream; process_ok("(outer)[% TRY %][% PROCESS 'die.tt' %][% CATCH %] [% END %]" => '(outer) ', {tt_config => [ERROR => 'catch.tt']}); process_ok(" one " => '', {tt_config => [ERROR => 'catch.tt', PRE_PROCESS => 'die.tt']}); process_ok(" one " => ($use_stream ? ' one ' : ''), {tt_config => [ERROR => 'catch.tt', POST_PROCESS => 'die.tt']}); process_ok(" one " => '', {tt_config => [ERROR => 'catch.tt', WRAPPER => 'die.tt']}); ###----------------------------------------------------------------### print "### CONFIG and DUMP ################################# $engine_option\n"; process_ok("[% CONFIG DUMP => {html => 0}; DUMP foo; PROCESS config.tt; DUMP foo %]" => qq{DUMP: File "input text" line 1 foo = 'FOO'; DUMP: File "config.tt" line 1
foo = 'FOO';
DUMP: File "input text" line 1 foo = 'FOO'; }, {foo => 'FOO'}) if ! $is_tt; process_ok("[% PROCESS 'config2.tt' %]" => qq{DUMP: File "config2.tt/nested" line 1 foo = 'FOO'; }, {foo => 'FOO'}) if ! $is_tt; ###----------------------------------------------------------------### print "### NOT FOUND CACHE ################################# $engine_option\n"; process_ok("[% BLOCK foo; TRY; PROCESS blurty.tt; CATCH %]([% error.type %])([% error.info %])\n[% END; END; PROCESS foo; PROCESS foo %]" => "(file)(blurty.tt: not found)\n(file)(blurty.tt: not found (cached))\n", {tt_config => [NEGATIVE_STAT_TTL => 2]}) if ! $is_tt; process_ok("[% BLOCK foo; TRY; PROCESS blurty.tt; CATCH %]([% error.type %])([% error.info %])\n[% END; END; PROCESS foo; PROCESS foo %]" => "(file)(blurty.tt: not found)\n(file)(blurty.tt: not found)\n", {tt_config => [NEGATIVE_STAT_TTL => -1]}) if ! $is_tt; process_ok("[% BLOCK foo; TRY; PROCESS blurty.tt; CATCH %]([% error.type %])([% error.info %])\n[% END; END; PROCESS foo; PROCESS foo %]" => "(file)(blurty.tt: not found)\n(file)(blurty.tt: not found)\n", {tt_config => [STAT_TTL => -1]}) if ! $is_tt; ###----------------------------------------------------------------### print "### DONE ############################################ $engine_option\n"; } # end of for libtemplate-alloy-perl-1.022/t/11_tt_input_output.t000066400000000000000000000134361402714000200223120ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 11_tt_input_output.t - Test the plethora of ways TT takes files in and out =cut our ($module, $is_tt); BEGIN { $module = 'Template::Alloy'; if (grep {/tt/i} @ARGV) { $module = 'Template'; } $is_tt = $module eq 'Template'; }; use strict; use Test::More tests => (! $is_tt) ? 21 : 18; use_ok($module); ### find a place to allow for testing (my $test_dir = $0) =~ s/\.t$/.dir/; my $test_file_short = "inout.txt"; my $test_file = "$test_dir/$test_file_short"; sub delete_file { unlink $test_file } END { delete_file(); rmdir $test_dir } if (! -d $test_dir) { mkdir($test_dir, 0755) || die "Couldn't mkdir $test_dir: $!" } ok(-d $test_dir, "Got a test dir up and running"); sub get_file { my $txt = ''; if (open my $fh, "<", $test_file) { read $fh, $txt, -s $test_file; } return $txt; } sub set_file { open(my $fh, ">", $test_file) || die "Couldn't open file $test_file: $!"; print $fh @_; } ###----------------------------------------------------------------### my $obj = $module->new(INCLUDE_PATH => $test_dir); my $out; print "### INPUT ###########################################\n"; $out = ''; $obj->process(\ "hi [% 1 + 2 %]", {}, \$out); is($out, "hi 3", 'process(\$in, {}, \$out)') || diag $obj->error; $out = ''; set_file("hi [% 1 + 2 %]"); $obj->process($test_file_short , {}, \$out); is($out, "hi 3", 'process($filename, {}, \$out)') || diag $obj->error; if (! $is_tt) { # tt is supposed to handle this - it doesn't $out = ''; $obj->process(sub { "hi [% 1 + 2 %]" } , {}, \$out); is($out, "hi 3", 'process(\&code, {}, \$out)') || diag $obj->error; } if (! $is_tt) { $out = ''; my $doc = $obj->load_template(\ "hi [% 1 + 2 %]"); $obj->process($doc, {}, \$out); is($out, "hi 3", 'process($obj->load_template($filename), {}, \$out)') || diag $obj->error; } $out = ''; set_file("hi [% 1 + 2 %]"); open(IO_TEST_IN, "<", $test_file) || die "Couldn't open $test_file for reading: $!"; $obj->process(\*IO_TEST_IN, {}, \$out); is($out, "hi 3", 'process(\*FH, {}, \$out)') || diag $obj->error; $out = ''; set_file("hi [% 1 + 2 %]"); open(my $fh, "<", $test_file) || die "Couldn't open $test_file for reading: $!"; $obj->process($fh , {}, \$out); is($out, "hi 3", 'process($fh, {}, \$out)') || diag $obj->error; ###----------------------------------------------------------------### print "### OUTPUT ##########################################\n"; { $out = ''; local $obj->{'OUTPUT'} = \$out; $obj->process(\ "hi [% 1 + 2 %]"); is($out, "hi 3", 'new(OUTPUT=>\$out)->process(\$str)'); } $out = ''; $obj->process(\ "hi [% 1 + 2 %]", {}, sub { $out = shift }); is($out, "hi 3", 'process(\$str, {}, \&code)'); { package IO_TEST_PRINT; our $out = ''; sub print { my $self = shift; $out = shift } } $obj->process(\ "hi [% 1 + 2 %]", {}, bless {}, 'IO_TEST_PRINT'); is($IO_TEST_PRINT::out, "hi 3", 'process(\$str, {}, $obj) - where $obj->can("print")'); $out = ''; $obj->process(\ "hi [% 1 + 2 %]", {}, \$out); is($out, "hi 3", 'process(\$str, {}, \$out)'); my @out = ("foo"); $obj->process(\ "hi [% 1 + 2 %]", {}, \@out); is($out[-1], "hi 3", 'process(\$str, {}, \@out)'); set_file(""); open(IO_TEST_OUT, ">", $test_file) || die "Couldn't open $test_file for writing: $!"; $obj->process(\ "hi [% 1 + 2 %]", {}, \*IO_TEST_OUT); close(IO_TEST_OUT); is(get_file(), "hi 3", 'process(\$str, {}, \*FH)') || diag $obj->error; set_file(""); open($fh, ">", $test_file) || die "Couldn't open $test_file for writing: $!"; $obj->process(\ "hi [% 1 + 2 %]", {}, $fh); close($fh); is(get_file(), "hi 3", 'process(\$str, {}, $fh)') || diag $obj->error; if (! $is_tt && $test_file =~ m{ ^/ }x) { set_file(""); eval { $obj->process(\ "hi [% 1 + 2 %]", {}, $test_file) }; is(get_file(), "", 'process(\$str, {}, $filename) - with ABSOLUTE error') || diag $obj->error; ok($obj->error =~ /ABSOLUTE/, "Right ABSOLUTE error"); local $obj->{'ABSOLUTE'} = 1; $obj->process(\ "hi [% 1 + 2 %]", {}, $test_file); is(get_file(), "hi 3", 'process(\$str, {}, $filename) - with ABSOLUTE file') || diag $obj->error; } elsif (! $is_tt && $test_file =~ m{ ^\.\.?/ }x) { set_file(""); eval { $obj->process(\ "hi [% 1 + 2 %]", {}, $test_file) }; is(get_file(), "", 'process(\$str, {}, $filename) - with RELATIVE error') || diag $obj->error; ok($obj->error =~ /RELATIVE/, "Right RELATIVE error"); local $obj->{'RELATIVE'} = 1; $obj->process(\ "hi [% 1 + 2 %]", {}, $test_file); is(get_file(), "hi 3", 'process(\$str, {}, $filename) - with RELATIVE file') || diag $obj->error; } else { ok(1, "Skip ABSOLUTE/RELATIVE output tests") for 1 .. 3; # without calling skip() } { set_file(""); local $obj->{'OUTPUT_PATH'} = $test_dir; $obj->process(\ "hi [% 1 + 2 %]", {}, $test_file_short); is(get_file(), "hi 3", 'process(\$str, {}, $filename) - with OUTPUT_PATH') || diag $obj->error; set_file(""); local $obj->{'OUTPUT_PATH'} = $test_dir; $obj->process(\ "hi [% 1 + 2 %]", {}, $test_file_short, {binmode => 1}); is(get_file(), "hi 3", 'process(\$str, {}, $filename) - with binmode') || diag $obj->error; } if (! $is_tt) { { package tt_input_output_handle; sub TIEHANDLE { my ($class, $out_ref) = @_; return bless [$out_ref], $class; } sub PRINT { my $self = shift; ${ $self->[0] } .= $_ for grep {defined && length} @_; return 1; } } $out = ''; local *IO_OUT; tie *IO_OUT, 'tt_input_output_handle', \$out; my $old_fh = select IO_OUT; $obj->process(\ "hi [% 1 + 2 %]"); is($out, "hi 3", 'process(\$str)'); select $old_fh; } ###----------------------------------------------------------------### print "### DONE ############################################\n"; libtemplate-alloy-perl-1.022/t/15_tt_view.t000066400000000000000000000461351402714000200205130ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 02_view.t - Test the ability to handle views in Template::Alloy =cut #============================================================= -*-perl-*- # # The tests used here where originally written by Andy Wardley # They have been modified to work with this testing framework # The following is the original Copyright notice included with # the t/view.t document that these tests were taken from. # # Tests the 'View' plugin. # # Written by Andy Wardley # # Copyright (C) 2000 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # Id: view.t 131 2001-06-14 13:20:12Z abw # #======================================================================== our ($module, $N, $is_tt, $compile_perl); BEGIN { $module = 'Template::Alloy'; if (grep {/tt/i} @ARGV) { $module = 'Template'; } $is_tt = $module eq 'Template'; $N = ! $is_tt ? 105 : 53; }; use strict; use Test::More tests => $N; use_ok($module); my $skipped; SKIP: { if (! eval { require Template::View } || ! $Template::View::VERSION) { $skipped = 1; skip("Template::View is not installed - skipping Template::View integration tests", $N - 1); } elsif (! UNIVERSAL::isa('Template::View', 'Template::Base')) { $skipped = 1; skip("Template::View doesn't appear to be from the Template Toolkit installation - skipping Template::View integration tests", $N - 1); } elsif ($Template::View::VERSION < 2.14) { $skipped = 1; skip("Template::View is not recent version - skipping Template::View integration tests", $N - 1); } elsif ($Template::View::VERSION >= 3) { $skipped = 1; skip("Template::View seems to be an experimental version - skipping Template::View integration tests", $N - 1); } }; exit if $skipped; sub process_ok { # process the value and say if it was ok my $str = shift; my $test = shift; my $vars = shift || {}; my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || []; push @$conf, (COMPILE_PERL => $compile_perl) if $compile_perl; my $obj = shift || $module->new(@$conf); # new object each time my $out = ''; my $line = (caller)[2]; delete $vars->{'tt_config'}; $obj->process(\$str, $vars, \$out); my $ok = ref($test) ? $out =~ $test : $out eq $test; if ($ok) { ok(1, "Line $line \"$str\" => \"$out\""); return $obj; } else { ok(0, "Line $line \"$str\""); warn "# Was:\n$out\n# Should've been:\n$test\n"; print $obj->error if $obj->can('error'); print $obj->dump_parse_tree(\$str) if $obj->can('dump_parse_tree'); exit; } } ### This next section of code is verbatim from Andy's code #------------------------------------------------------------------------ { package Foo; sub new { my $class = shift; bless { @_ }, $class; } sub present { my $self = shift; return '{ ' . join(', ', map { "$_ => $self->{ $_ }" } sort keys %$self) . ' }'; } sub reverse { my $self = shift; return '{ ' . join(', ', map { "$_ => $self->{ $_ }" } reverse sort keys %$self) . ' }'; } } #------------------------------------------------------------------------ { package Blessed::List; sub as_list { my $self = shift; return @$self; } } #------------------------------------------------------------------------ my $vars = { foo => Foo->new( pi => 3.14, e => 2.718 ), blessed_list => bless([ "Hello", "World" ], 'Blessed::List'), }; for $compile_perl (($is_tt) ? (0) : (0, 1)) { my $is_compile_perl = "compile perl ($compile_perl)"; ###----------------------------------------------------------------### ### These are Andy's tests coded as Paul's process_oks ### View plugin usage process_ok("[% USE v = view -%] [[% v.prefix %]]" => "[]", $vars); process_ok("[% USE v = view( map => { default='any' } ) -%] [[% v.map.default %]]" => "[any]", $vars); process_ok("[% USE view( prefix=> 'foo/', suffix => '.tt2') -%] [[% view.prefix %]bar[% view.suffix %]] [[% view.template_name('baz') %]]" => "[foo/bar.tt2] [foo/baz.tt2]", $vars); process_ok("[% USE view( prefix=> 'foo/', suffix => '.tt2') -%] [[% view.prefix %]bar[% view.suffix %]] [[% view.template_name('baz') %]]" => "[foo/bar.tt2] [foo/baz.tt2]", $vars); process_ok("[% USE view -%] [% view.print('Hello World') %] [% BLOCK text %]TEXT: [% item %][% END -%]" => "TEXT: Hello World\n", $vars); process_ok("[% USE view -%] [% view.print( { foo => 'bar' } ) %] [% BLOCK hash %]HASH: { [% FOREACH key = item.keys.sort -%] [% key %] => [% item.\$key %] [%- END %] } [% END -%]" => "HASH: { foo => bar }\n\n", $vars); process_ok("[% USE view -%] [% view = view.clone( prefix => 'my_' ) -%] [% view.view('hash', { bar => 'baz' }) %] [% BLOCK my_hash %]HASH: { [% FOREACH key = item.keys.sort -%] [% key %] => [% item.\$key %] [%- END %] } [% END -%]" => "HASH: { bar => baz }\n\n", $vars); process_ok("[% USE view(prefix='my_') -%] [% view.print( foo => 'wiz', bar => 'waz' ) %] [% BLOCK my_hash %]KEYS: [% item.keys.sort.join(', ') %][% END %] " => "KEYS: bar, foo\n\n\n", $vars); process_ok("[% USE view -%] [% view.print( view ) %] [% BLOCK Template_View %]Printing a Template::View object[% END -%]" => "Printing a Template::View object\n", $vars); process_ok("[% USE view(prefix='my_') -%] [% view.print( view ) %] [% view.print( view, prefix='your_' ) %] [% BLOCK my_Template_View %]Printing my Template::View object[% END -%] [% BLOCK your_Template_View %]Printing your Template::View object[% END -%]" => "Printing my Template::View object Printing your Template::View object\n" , $vars); process_ok("[% USE view(prefix='my_', notfound='any' ) -%] [% view.print( view ) %] [% view.print( view, prefix='your_' ) %] [% BLOCK my_any %]Printing any of my objects[% END -%] [% BLOCK your_any %]Printing any of your objects[% END -%]" => "Printing any of my objects Printing any of your objects ", $vars); process_ok("[% USE view(prefix => 'my_', map => { default => 'catchall' } ) -%] [% view.print( view ) %] [% view.print( view, default='catchsome' ) %] [% BLOCK my_catchall %]Catching all defaults[% END -%] [% BLOCK my_catchsome %]Catching some defaults[% END -%]" => "Catching all defaults Catching some defaults ", $vars); process_ok("[% USE view(prefix => 'my_', map => { default => 'catchnone' } ) -%] [% view.default %] [% view.default = 'catchall' -%] [% view.default %] [% view.print( view ) %] [% view.print( view, default='catchsome' ) %] [% BLOCK my_catchall %]Catching all defaults[% END -%] [% BLOCK my_catchsome %]Catching some defaults[% END -%]" => "catchnone catchall Catching all defaults Catching some defaults ", $vars); process_ok("[% USE view(prefix='my_', default='catchall' notfound='lost') -%] [% view.print( view ) %] [% BLOCK my_lost %]Something has been found[% END -%]" => "Something has been found ", $vars); process_ok("[% USE view -%] [% TRY ; view.print( view ) ; CATCH view ; \"[\$error.type] \$error.info\" ; END %]" => qr{^\Q[view] file error - Template_View: not found\E}, $vars); process_ok("[% USE view -%] [% view.print( foo ) %]" => "{ e => 2.718, pi => 3.14 }", $vars); process_ok("[% USE view -%] [% view.print( foo, method => 'reverse' ) %]" => "{ pi => 3.14, e => 2.718 }", $vars); process_ok("[% USE view(prefix='my_', include_naked=0, view_naked=1) -%] [% BLOCK my_foo; \"Foo: \$item\"; END -%] [[% view.view_foo(20) %]] [[% view.foo(30) %]]" => "[Foo: 20] [Foo: 30]", $vars); process_ok("[% USE view(prefix='my_', include_naked=0, view_naked=0) -%] [% BLOCK my_foo; \"Foo: \$item\"; END -%] [[% view.view_foo(20) %]] [% TRY ; view.foo(30) ; CATCH ; error.info ; END %]" => "[Foo: 20] no such view member: foo", $vars); process_ok("[% USE view(map => { HASH => 'my_hash', ARRAY => 'your_list' }) -%] [% BLOCK text %]TEXT: [% item %][% END -%] [% BLOCK my_hash %]HASH: [% item.keys.sort.join(', ') %][% END -%] [% BLOCK your_list %]LIST: [% item.join(', ') %][% END -%] [% view.print(\"some text\") %] [% view.print({ alpha => 'a', bravo => 'b' }) %] [% view.print([ 'charlie', 'delta' ]) %]" => "TEXT: some text HASH: alpha, bravo LIST: charlie, delta", $vars); process_ok("[% USE view(item => 'thing', map => { HASH => 'my_hash', ARRAY => 'your_list' }) -%] [% BLOCK text %]TEXT: [% thing %][% END -%] [% BLOCK my_hash %]HASH: [% thing.keys.sort.join(', ') %][% END -%] [% BLOCK your_list %]LIST: [% thing.join(', ') %][% END -%] [% view.print(\"some text\") %] [% view.print({ alpha => 'a', bravo => 'b' }) %] [% view.print([ 'charlie', 'delta' ]) %]" => "TEXT: some text HASH: alpha, bravo LIST: charlie, delta", $vars); process_ok("[% USE view -%] [% view.print('Hello World') %] [% view1 = view.clone( prefix='my_') -%] [% view1.print('Hello World') %] [% view2 = view1.clone( prefix='dud_', notfound='no_text' ) -%] [% view2.print('Hello World') %] [% BLOCK text %]TEXT: [% item %][% END -%] [% BLOCK my_text %]MY TEXT: [% item %][% END -%] [% BLOCK dud_no_text %]NO TEXT: [% item %][% END -%]" => "TEXT: Hello World MY TEXT: Hello World NO TEXT: Hello World ", $vars); process_ok("[% USE view( prefix = 'base_', default => 'any' ) -%] [% view1 = view.clone( prefix => 'one_') -%] [% view2 = view.clone( prefix => 'two_') -%] [% view.default %] / [% view.map.default %] [% view1.default = 'anyone' -%] [% view1.default %] / [% view1.map.default %] [% view2.map.default = 'anytwo' -%] [% view2.default %] / [% view2.map.default %] [% view.print(\"Hello World\") %] / [% view.print(blessed_list) %] [% view1.print(\"Hello World\") %] / [% view1.print(blessed_list) %] [% view2.print(\"Hello World\") %] / [% view2.print(blessed_list) %] [% BLOCK base_text %]ANY TEXT: [% item %][% END -%] [% BLOCK one_text %]ONE TEXT: [% item %][% END -%] [% BLOCK two_text %]TWO TEXT: [% item %][% END -%] [% BLOCK base_any %]BASE ANY: [% item.as_list.join(', ') %][% END -%] [% BLOCK one_anyone %]ONE ANY: [% item.as_list.join(', ') %][% END -%] [% BLOCK two_anytwo %]TWO ANY: [% item.as_list.join(', ') %][% END -%]" => "any / any anyone / anyone anytwo / anytwo ANY TEXT: Hello World / BASE ANY: Hello, World ONE TEXT: Hello World / ONE ANY: Hello, World TWO TEXT: Hello World / TWO ANY: Hello, World ", $vars); process_ok("[% USE view( prefix => 'my_', item => 'thing' ) -%] [% view.view('thingy', [ 'foo', 'bar'] ) %] [% BLOCK my_thingy %]thingy: [ [% thing.join(', ') %] ][%END %]" => "thingy: [ foo, bar ] ", $vars); process_ok("[% USE view -%] [% view.map.\${'Template::View'} = 'myview' -%] [% view.print(view) %] [% BLOCK myview %]MYVIEW[% END%]" => "MYVIEW ", $vars); process_ok("[% USE view -%] [% view.include('greeting', msg => 'Hello World!') %] [% BLOCK greeting %]msg: [% msg %][% END -%]" => "msg: Hello World! ", $vars); process_ok("[% USE view( prefix=\"my_\" )-%] [% view.include('greeting', msg => 'Hello World!') %] [% BLOCK my_greeting %]msg: [% msg %][% END -%]" => "msg: Hello World! ", $vars); process_ok("[% USE view( prefix=\"my_\" )-%] [% view.include_greeting( msg => 'Hello World!') %] [% BLOCK my_greeting %]msg: [% msg %][% END -%]" => "msg: Hello World! ", $vars); process_ok("[% USE view( prefix=\"my_\" )-%] [% INCLUDE \$view.template('greeting') msg = 'Hello World!' %] [% BLOCK my_greeting %]msg: [% msg %][% END -%]" => "msg: Hello World! ", $vars); process_ok("[% USE view( title=\"My View\" )-%] [% view.title %]" => "My View", $vars); process_ok("[% USE view( title=\"My View\" )-%] [% newview = view.clone( col = 'Chartreuse') -%] [% newerview = newview.clone( title => 'New Title' ) -%] [% view.title %] [% newview.title %] [% newview.col %] [% newerview.title %] [% newerview.col %]" => "My View My View Chartreuse New Title Chartreuse", $vars); ###----------------------------------------------------------------### ### VIEW directive usage process_ok("[% VIEW fred prefix='blat_' %] This is the view [% END -%] [% BLOCK blat_foo; 'This is blat_foo'; END -%] [% fred.view_foo %]" => "This is blat_foo", $vars); process_ok("[% VIEW fred %] This is the view [% view.prefix = 'blat_' %] [% END -%] [% BLOCK blat_foo; 'This is blat_foo'; END -%] [% fred.view_foo %]" => "This is blat_foo", $vars); process_ok("[% VIEW fred %] This is the view [% view.prefix = 'blat_' %] [% view.thingy = 'bloop' %] [% fred.name = 'Freddy' %] [% END -%] [% fred.prefix %] [% fred.thingy %] [% fred.name %]" => "blat_ bloop Freddy", $vars); process_ok("[% VIEW fred prefix='blat_'; view.name='Fred'; END -%] [% fred.prefix %] [% fred.name %] [% TRY; fred.prefix = 'nonblat_'; CATCH; error; END %] [% TRY; fred.name = 'Derek'; CATCH; error; END %]" => "blat_ Fred view error - cannot update config item in sealed view: prefix view error - cannot update item in sealed view: name", $vars); process_ok("[% VIEW foo prefix='blat_' default=\"default\" notfound=\"notfound\" title=\"fred\" age=23 height=1.82 %] [% view.other = 'another' %] [% END -%] [% BLOCK blat_hash -%] [% FOREACH key = item.keys.sort -%] [% key %] => [% item.\$key %] [% END -%] [% END -%] [% foo.print(foo.data) %]" => " age => 23 height => 1.82 other => another title => fred ", $vars); process_ok("[% VIEW foo %] [% BLOCK hello -%] Hello World! [% END %] [% BLOCK goodbye -%] Goodbye World! [% END %] [% END -%] [% TRY; INCLUDE foo; CATCH; error; END %] [% foo.include_hello %]" => qr{^\Qfile error - foo: not found Hello World! \E}, $vars); process_ok("[% title = \"Previous Title\" -%] [% VIEW foo include_naked = 1 title = title or 'Default Title' copy = 'me, now' -%] [% view.bgcol = '#ffffff' -%] [% BLOCK header -%] Header: bgcol: [% view.bgcol %] title: [% title %] view.title: [% view.title %] [%- END %] [% BLOCK footer -%] © Copyright [% view.copy %] [%- END %] [% END -%] [% title = 'New Title' -%] [% foo.header %] [% foo.header(bgcol='#dead' title=\"Title Parameter\") %] [% foo.footer %] [% foo.footer(copy=\"you, then\") %] " => "Header: bgcol: #ffffff title: New Title view.title: Previous Title Header: bgcol: #ffffff title: Title Parameter view.title: Previous Title © Copyright me, now © Copyright me, now ", $vars); process_ok("[% VIEW foo title = 'My View' author = 'Andy Wardley' bgcol = bgcol or '#ffffff' -%] [% view.arg1 = 'argument #1' -%] [% view.data.arg2 = 'argument #2' -%] [% END -%] [% foo.title %] [% foo.author %] [% foo.bgcol %] [% foo.arg1 %] [% foo.arg2 %] [% bar = foo.clone( title='New View', arg1='New Arg1' ) %]cloned! [% bar.title %] [% bar.author %] [% bar.bgcol %] [% bar.arg1 %] [% bar.arg2 %] originals: [% foo.title %] [% foo.arg1 %] " => " My View Andy Wardley #ffffff argument #1 argument #2 cloned! New View Andy Wardley #ffffff New Arg1 argument #2 originals: My View argument #1 ", $vars); process_ok("[% VIEW basic title = \"My Web Site\" %] [% BLOCK header -%] This is the basic header: [% title or view.title %] [%- END -%] [% END -%] [%- VIEW fancy title = \"\$basic.title\" basic = basic %] [% BLOCK header ; view.basic.header(title = title or view.title) %] Fancy new part of header [%- END %] [% END -%] === [% basic.header %] [% basic.header( title = \"New Title\" ) %] === [% fancy.header %] [% fancy.header( title = \"Fancy Title\" ) %]" => "=== This is the basic header: My Web Site This is the basic header: New Title === This is the basic header: My Web Site Fancy new part of header This is the basic header: Fancy Title Fancy new part of header", $vars); process_ok("[% VIEW baz notfound='lost' %] [% BLOCK lost; 'lost, not found'; END %] [% END -%] [% baz.any %]" => "lost, not found", $vars); process_ok("[% VIEW woz prefix='outer_' %] [% BLOCK wiz; 'The inner wiz'; END %] [% END -%] [% BLOCK outer_waz; 'The outer waz'; END -%] [% woz.wiz %] [% woz.waz %]" => "The inner wiz The outer waz", $vars); process_ok("[% VIEW foo %] [% BLOCK file -%] File: [% item.name %] [%- END -%] [% BLOCK directory -%] Dir: [% item.name %] [%- END %] [% END -%] [% foo.view_file({ name => 'some_file' }) %] [% foo.include_file(item => { name => 'some_file' }) %] [% foo.view('directory', { name => 'some_dir' }) %]" => " File: some_file File: some_file Dir: some_dir", $vars); process_ok("[% BLOCK parent -%] This is the base block [%- END -%] [% VIEW super %] [%- BLOCK parent -%] [%- INCLUDE parent FILTER replace('base', 'super') -%] [%- END -%] [% END -%] base: [% INCLUDE parent %] super: [% super.parent %]" => "base: This is the base block super: This is the super block", $vars); process_ok("[% BLOCK foo -%] public foo block [%- END -%] [% VIEW plain %] [% BLOCK foo -%] [% PROCESS foo %] [%- END %] [% END -%] [% VIEW fancy %] [% BLOCK foo -%] [%- plain.foo | replace('plain', 'fancy') -%] [%- END %] [% END -%] [% plain.foo %] [% fancy.foo %]" => "public foo block public foo block", $vars); process_ok("[% VIEW foo %] [% BLOCK Blessed_List -%] This is a list: [% item.as_list.join(', ') %] [% END -%] [% END -%] [% foo.print(blessed_list) %]" => "This is a list: Hello, World ", $vars); process_ok("[% VIEW my.foo value=33; END -%] n: [% my.foo.value %]" => "n: 33", $vars); process_ok("[% VIEW parent -%] [% BLOCK one %]This is base one[% END %] [% BLOCK two %]This is base two[% END %] [% END -%] [%- VIEW child1 base=parent %] [% BLOCK one %]This is child1 one[% END %] [% END -%] [%- VIEW child2 base=parent %] [% BLOCK two %]This is child2 two[% END %] [% END -%] [%- VIEW child3 base=child2 %] [% BLOCK two %]This is child3 two[% END %] [% END -%] [%- FOREACH child = [ child1, child2, child3 ] -%] one: [% child.one %] [% END -%] [% FOREACH child = [ child1, child2, child3 ] -%] two: [% child.two %] [% END %] " => "one: This is child1 one one: This is base one one: This is base one two: This is base two two: This is child2 two two: This is child3 two ", $vars); process_ok("[% VIEW my.view.default prefix = 'view/default/' value = 3.14; END -%] value: [% my.view.default.value %]" => "value: 3.14", $vars); process_ok("[% VIEW my.view.default prefix = 'view/default/' value = 3.14; END; VIEW my.view.one base = my.view.default prefix = 'view/one/'; END; VIEW my.view.two base = my.view.default value = 2.718; END; -%] [% BLOCK view/default/foo %]Default foo[% END -%] [% BLOCK view/one/foo %]One foo[% END -%] 0: [% my.view.default.foo %] 1: [% my.view.one.foo %] 2: [% my.view.two.foo %] 0: [% my.view.default.value %] 1: [% my.view.one.value %] 2: [% my.view.two.value %]" => "0: Default foo 1: One foo 2: Default foo 0: 3.14 1: 3.14 2: 2.718", $vars); process_ok("[% VIEW foo number = 10 sealed = 0; END -%] a: [% foo.number %] b: [% foo.number = 20 %] c: [% foo.number %] d: [% foo.number(30) %] e: [% foo.number %]" => "a: 10 b: c: 20 d: 30 e: 30", $vars); process_ok("[% VIEW foo number = 10 silent = 1; END -%] a: [% foo.number %] b: [% foo.number = 20 %] c: [% foo.number %] d: [% foo.number(30) %] e: [% foo.number %]" => "a: 10 b: c: 10 d: 10 e: 10", $vars); ###----------------------------------------------------------------### print "### DONE ############################################ $is_compile_perl\n"; } # end of for libtemplate-alloy-perl-1.022/t/20_html_template.t000066400000000000000000000361621402714000200216640ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 03_html_template.t - Test the ability to parse and play html template =cut our ($module, $is_ht, $is_hte, $is_ta, $compile_perl); BEGIN { $module = 'Template::Alloy'; if (grep {/hte/i} @ARGV) { $module = 'HTML::Template::Expr'; } elsif (grep {/ht/i} @ARGV) { $module = 'HTML::Template'; } $is_hte = $module eq 'HTML::Template::Expr'; $is_ht = $module eq 'HTML::Template'; $is_ta = $module eq 'Template::Alloy'; }; use strict; use Test::More tests => ($is_ta) ? 250 : ($is_ht) ? 75 : 82; use constant test_taint => 0 && eval { require Taint::Runtime }; use_ok($module); Taint::Runtime::taint_start() if test_taint; ### find a place to allow for testing my $test_dir = $0 .'.test_dir'; END { rmdir $test_dir } mkdir $test_dir, 0755; ok(-d $test_dir, "Got a test dir up and running"); sub process_ok { # process the value and say if it was ok my $str = shift; my $test = shift; my $vars = shift || {}; my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || []; push @$conf, (COMPILE_PERL => $compile_perl) if $compile_perl; my $line = (caller)[2]; delete $vars->{'tt_config'}; Taint::Runtime::taint(\$str) if test_taint; my $obj; my $out; eval { $obj = shift || $module->new(scalarref => \$str, die_on_bad_params => 0, path => $test_dir, @$conf); # new object each time $obj->param($vars); $out = $obj->output; }; my $err = $@; $out = '' if ! defined $out; my $ok = ref($test) ? $out =~ $test : $out eq $test; if ($ok) { ok(1, "Line $line \"$str\" => \"$out\""); return $obj; } else { ok(0, "Line $line \"$str\""); warn "# Was:\n$out\n# Should've been:\n$test\n"; print "$err\n"; if ($obj && $obj->can('dump_parse_tree')) { local $obj->{'SYNTAX'} = 'hte'; print $obj->dump_parse_tree(\$str); print $err; } exit; } } ### create some files to include my $foo_template = "$test_dir/foo.ht"; END { unlink $foo_template }; open(my $fh, ">$foo_template") || die "Couldn't open $foo_template: $!"; print $fh "Good Day!"; close $fh; ### create some files to include my $bar_template = "$test_dir/bar.ht"; END { unlink $bar_template }; open($fh, ">$bar_template") || die "Couldn't open $bar_template: $!"; print $fh "()"; close $fh; for $compile_perl ((! $is_ta) ? (0) : (0, 1)) { my $is_compile_perl = "compile perl ($compile_perl)"; ###----------------------------------------------------------------### print "### VAR ############################################# $is_compile_perl\n"; process_ok("Foo" => "Foo"); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>", tt_config => [default_escape => 'html']}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "%3C%3E", {foo => "<>"}); process_ok("" => "<>\\n\\r\t\\\"\\\'", {foo => "<>\n\r\t\"\'"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "<>", {foo => "<>"}); process_ok("" => "FOO", {foo => "FOO", bar => "BAR"}); process_ok("" => "FOO", {foo => "FOO", bar => "BAR"}); process_ok("" => "FOO", {foo => "FOO", bar => "BAR"}); process_ok("d" => "bard", {foo => undef, bar => "BAR"}); process_ok("d" => "bard", {foo => undef, bar => "BAR"}); process_ok("d" => "bard"); process_ok("" => "FOO", {foo => "FOO"}) if $is_ta; process_ok("" => "FOO", {foo => "FOO"}); process_ok("" => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if $is_ta; ###----------------------------------------------------------------### print "### IF / ELSE / UNLESS ############################## $is_compile_perl\n"; process_ok("bar" => "", {foo => ""}); process_ok("bar" => "bar", {foo => "1"}); process_ok("barbing" => "bing", {foo => ''}); process_ok("barbing" => "bar", {foo => '1'}); process_ok("barbing" => "bar", {foo => '1'}); process_ok("barbing" => "bar", {foo => '1'}); process_ok("barbing" => "bar", {foo => '1'}); process_ok("barbing" => "bar", {foo => '1'}); process_ok("barbing" => "bar") if ! $is_ht; process_ok("barbing" => "bing") if ! $is_ht; process_ok("barbing" => "bar") if ! $is_ht; process_ok("bar" => "") if ! $is_ht; process_ok("barbing" => "bar") if $is_ta; process_ok("barbaz" => "baz"); process_ok("bar" => "bar", {foo => ""}); process_ok("bar" => "", {foo => "1"}); process_ok("barbaz" => "barbaz"); process_ok("barbing" => "bing") if ! $is_ht; process_ok("barbing" => "bar") if ! $is_ht; process_ok("barbaz" => "", {foo => "1"}); process_ok("barbaz" => "", {foo => "1"}); ###----------------------------------------------------------------### print "### INCLUDE ######################################### $is_compile_perl\n"; process_ok("bar" => ""); process_ok("" => "Good Day!"); process_ok("" => "Good Day!", {tt_config => [path => '']}); process_ok("" => "Good Day!"); process_ok("" => "Good Day!"); process_ok("" => "Good Day!"); process_ok("" => "Good Day!"); process_ok("" => "", {tt_config => [no_includes => 1]}); process_ok("" => ""); process_ok("" => ""); process_ok("" => "Good Day!") if $is_ta; process_ok("" => "Good Day!", {foo => 'foo.ht'}) if $is_ta; process_ok("" => "Good Day!") if $is_ta; process_ok("" => "()"); process_ok("" => "(hi)", {bar => 'hi'}); ###----------------------------------------------------------------### print "### EXPR ############################################ $is_compile_perl\n"; process_ok("" => "777", {foo => "777"}) if ! $is_ht; process_ok("" => "777", {foo => "777"}) if ! $is_ht; process_ok("" => "777", {foo => "777"}) if ! $is_ht && ! $is_hte; # odd that HTE can't parse this process_ok("" => "777", {foo => "777"}) if ! $is_ht && ! $is_hte; process_ok("" => "777", {foo => "777"}) if ! $is_ht && ! $is_hte; process_ok("" => "<>", {foo => "<>"}) if ! $is_ht; process_ok("" => "", {foo => "<>"}) if ! $is_hte; process_ok("" => "", {foo => "FOO", bar => "BAR"}); process_ok("" => "FOO", {foo => "FOO"}) if ! $is_ht && ! $is_hte; process_ok("" => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if $is_ta; process_ok("" => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if $is_ta; ###----------------------------------------------------------------### print "### LOOP ############################################ $is_compile_perl\n"; process_ok("foo" => "foo"); process_ok("Hifoo" => "foo", {blah => 1}) if $is_ta; process_ok("Hifoo" => "Hifoo", {blah => {wow => 1}}) if $is_ta; process_ok("Hifoo" => "HiHifoo", {blah => [{}, {}]}); process_ok("()foo" => "(1)(2)(3)foo", {blah => [{i=>1}, {i=>2}, {i=>3}]}); process_ok("()foo" => "(1)(2)(3)foo", {blah => [{i=>1}, {i=>2}, {i=>3}]}); process_ok("()foo" => "(1)(2)(3)foo", {blah => [{i=>1}, {i=>2}, {i=>3}]}) if $is_ta; process_ok("()()foo" => "(1)()(2)()(3)()foo", {blah => [{i=>1}, {i=>2}, {i=>3}], blue => 'B'}) if $is_ht; process_ok("()()foo" => "(1)(B)(2)(B)(3)(B)foo", {blah => [{i=>1}, {i=>2}, {i=>3}], blue => 'B', tt_config => [GLOBAL_VARS => 1]}); process_ok("()()foo" => "(1)()(2)()(3)()foo", {blah => [{i=>1}, {i=>2}, {i=>3}], blue => 'B', tt_config => [SYNTAX => 'ht']}) if $is_ta; process_ok("()()foo" => "(1)(B)(2)(B)(3)(B)foo", {blah => [{i=>1}, {i=>2}, {i=>3}], blue => 'B', tt_config => [GLOBAL_VARS => 1, SYNTAX => 'ht']}) if $is_ta; process_ok("()foo" => "(1)()(3)foo", {blah => [{i=>1}, undef, {i=>3}]}); process_ok("\n(||||)foo" => " (||||) (||||) (||||)foo", {blah => [undef, undef, undef]}); process_ok("\n(||||)foo" => " (1||1|0|1) (0|0||1|2) (0|1|1|0|3)foo", {blah => [undef, undef, undef], tt_config => [LOOP_CONTEXT_VARS => 1]}) if ! $is_ta; process_ok("\n(||||)foo" => " (1|0|1|0|1) (0|0|0|1|2) (0|1|1|0|3)foo", {blah => [undef, undef, undef], tt_config => [LOOP_CONTEXT_VARS => 1]}) if $is_ta; ###----------------------------------------------------------------### print "### TT3 DIRECTIVES ################################## $is_compile_perl\n"; process_ok("" => "FOO", {foo => "FOO"}) if $is_ta; process_ok("" => "", {foo => "FOO", tt_config => [NO_TT => 1]}) if $is_ta; process_ok("" => "", {foo => "FOO", tt_config => [SYNTAX => 'ht']}) if $is_ta; process_ok("" => "10", {foo => "FOO"}) if $is_ta; process_ok("barweebing" => "bar", {foo => "1"}) if $is_ta; process_ok("()" => "(foo)") if $is_ta; process_ok("()" => "(foo)") if $is_ta; process_ok("()" => "(1)(2)(3)") if $is_ta; process_ok("()" => "(bar)") if $is_ta; process_ok("()" => "(bar)") if $is_ta; process_ok("" => "bar") if $is_ta; process_ok('You said ' => 'You said hello') if $is_ta; process_ok("" => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if $is_ta; process_ok("" => '&', {foo => '&', tt_config => [AUTO_FILTER => 'html']}) if $is_ta; ###----------------------------------------------------------------### print "### TT3 CHOMPING #################################### $is_compile_perl\n"; process_ok("\n" => "\nFOO", {foo => "FOO"}) if $is_ta; process_ok("\n" => "FOO", {foo => "FOO"}) if $is_ta; process_ok("\n<-TMPL_GET foo>" => "FOO", {foo => "FOO"}) if $is_ta; ###----------------------------------------------------------------### print "### TT3 INTERPOLATE ################################# $is_compile_perl\n"; process_ok('$foo ${ 1 + 2 }' => '$foo FOO ${ 1 + 2 }', {foo => "FOO"}) if $is_ta; process_ok('$foo ${ 1 + 2 }' => 'FOO FOO 3', {foo => "FOO", tt_config => [INTERPOLATE => 1]}) if $is_ta; process_ok(' 1>$foo ${ 1 + 2 }' => 'FOO FOO 3', {foo => "FOO"}) if $is_ta; process_ok('Foo $a Bar $!a Baz' => "Foo 7 Bar 7 Baz", {a => 7, tt_config => ['INTERPOLATE' => 1]}) if $is_ta; process_ok('Foo $a Bar $!{a} Baz' => "Foo 7 Bar 7 Baz", {a => 7, tt_config => ['INTERPOLATE' => 1]}) if $is_ta; process_ok('Foo $a Bar $!a Baz' => "Foo 7 Bar 7 Baz", {a => 7, tt_config => ['INTERPOLATE' => 1, SHOW_UNDEFINED_INTERP => 1]}) if $is_ta; process_ok('Foo $a Bar $!{a} Baz' => "Foo 7 Bar 7 Baz", {a => 7, tt_config => ['INTERPOLATE' => 1, SHOW_UNDEFINED_INTERP => 1]}) if $is_ta; process_ok('Foo $a Bar $!a Baz' => "Foo \$a Bar Baz", {tt_config => ['INTERPOLATE' => 1, SHOW_UNDEFINED_INTERP => 1]}) if $is_ta; process_ok('Foo ${a} Bar $!{a} Baz' => "Foo \${a} Bar Baz", {tt_config => ['INTERPOLATE' => 1, SHOW_UNDEFINED_INTERP => 1]}) if $is_ta; ###----------------------------------------------------------------### print "### DONE ############################################ $is_compile_perl\n"; } # end of for libtemplate-alloy-perl-1.022/t/25_text_tmp.t000066400000000000000000000173361402714000200207000ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 04_text_tmpl.t - Test the ability to parse and play Text::Tmpl =cut our ($module, $is_tt, $compile_perl); BEGIN { $module = 'Template::Alloy'; if (grep {/tt|tmpl/i} @ARGV) { $module = 'Text::Tmpl'; } $is_tt = $module eq 'Text::Tmpl'; }; use strict; use Test::More tests => (! $is_tt) ? 100 : 25; use constant test_taint => 0 && eval { require Taint::Runtime }; use_ok($module); Taint::Runtime::taint_start() if test_taint; ### find a place to allow for testing my $test_dir = $0 .'.test_dir'; END { rmdir $test_dir } mkdir $test_dir, 0755; ok(-d $test_dir, "Got a test dir up and running"); sub process_ok { # process the value and say if it was ok my $str = shift; my $test = shift; my $vars = shift || {}; my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || []; push @$conf, (COMPILE_PERL => $compile_perl) if $compile_perl; my $line = (caller)[2]; delete $vars->{'tt_config'}; Taint::Runtime::taint(\$str) if test_taint; my $obj = shift || $module->new(@$conf); # new object each time $obj->set_delimiters('#[', ']#'); $obj->set_strip(0); $obj->set_values($vars); $obj->set_dir("$test_dir/"); if ($vars->{'set_loop'}) { foreach my $hash (@{$vars->{'set_loop'}}) { my $ref = $obj->loop_iteration('loop1'); $ref->set_values($hash); } } my $out = eval { $obj->parse_string($str) }; $out = '' if ! defined $out; my $ok = ref($test) ? $out =~ $test : $out eq $test; if ($ok) { ok(1, "Line $line \"$str\" => \"$out\""); return $obj; } else { ok(0, "Line $line \"$str\""); warn "# Was:\n$out\n# Should've been:\n$test\n"; if ($obj->can('dump_parse_tree')) { print $obj->strerror if $obj->can('strerror'); local $obj->{'SYNTAX'} = 'tmpl'; print $obj->dump_parse_tree(\$str); print $obj->strerror if $obj->can('strerror'); } else { print eval($module."::strerror()"); } exit; } } ### create some files to include my $foo_template = "$test_dir/foo.tmpl"; END { unlink $foo_template }; open(my $fh, ">$foo_template") || die "Couldn't open $foo_template: $!"; print $fh "Good Day!"; close $fh; ### create some files to include my $bar_template = "$test_dir/bar.tmpl"; END { unlink $bar_template }; open($fh, ">$bar_template") || die "Couldn't open $bar_template: $!"; print $fh "(#[echo \$bar]#)"; close $fh; for $compile_perl (($is_tt) ? (0) : (0, 1)) { my $is_compile_perl = "compile perl ($compile_perl)"; ###----------------------------------------------------------------### print "### ECHO ############################################ $is_compile_perl\n"; process_ok("Foo" => "Foo"); process_ok('#[echo $foo]#bar' => "bar"); process_ok('#[echo $foo]#' => "FOO", {foo => "FOO"}); process_ok('#[echo $foo $foo]#' => "FOOFOO", {foo => "FOO"}); process_ok('#[echo $foo "bar" $foo]#' => "FOObarFOO", {foo => "FOO"}); process_ok('#[echo "hi"]#' => "hi", {foo => "FOO"}); process_ok('#[echo \'hi\']#' => "hi", {foo => "FOO"}) if ! $is_tt; process_ok('#[echo foo]#' => "FOO", {foo => "FOO"}) if ! $is_tt; ###----------------------------------------------------------------### print "### COMMENT ######################################### $is_compile_perl\n"; process_ok('#[comment]# Hi there #[endcomment]#bar' => "bar", {foo => "FOO"}); process_ok('#[comment]# Hi there #[end]#bar' => "bar", {foo => "FOO"}) if ! $is_tt; ###----------------------------------------------------------------### print "### IF / ELSIF / ELSE / IFN ######################### $is_compile_perl\n"; process_ok('#[if $foo]#bar#[endif]#bar' => "bar"); process_ok('#[if "1"]#bar#[endif]#' => "bar"); process_ok('#[if $foo]#bar#[endif]#' => "", {foo => ""}); process_ok('#[if $foo]#bar#[endif]#' => "bar", {foo => "1"}); process_ok('#[ifn $foo]#bar#[endifn]#' => "bar", {foo => ""}); process_ok('#[ifn $foo]#bar#[endifn]#' => "", {foo => "1"}); process_ok('#[if foo]#bar#[endif]#' => "", {foo => ""}) if ! $is_tt; process_ok('#[if foo]#bar#[endif]#' => "bar", {foo => "1"}) if ! $is_tt; process_ok('#[if $foo]#bar#[else]#bing#[endif]#' => "bing", {foo => ''}) if ! $is_tt; process_ok('#[if $foo]#bar#[else]#bing#[endif]#' => "bar", {foo => '1'}) if ! $is_tt; process_ok('#[if $foo]#bar#[elsif wow]#wee#[else]#bing#[endif]#' => "bar", {foo => 1}) if ! $is_tt; process_ok('#[if $foo]#bar#[elsif wow]#wee#[else]#bing#[endif]#' => "wee", {wow => 1}) if ! $is_tt; process_ok('#[if $foo]#bar#[elsif wow]#wee#[else]#bing#[endif]#' => "bing", {foo => ''}) if ! $is_tt; ####----------------------------------------------------------------### print "### INCLUDE ######################################### $is_compile_perl\n"; process_ok('#[include "wow.tmpl"]#bar' => "bar") if $is_tt; process_ok('#[include "foo.tmpl"]#' => "Good Day!"); process_ok("#[include \"$test_dir/foo.tmpl\"]#" => "Good Day!"); process_ok('#[include "bar.tmpl"]#' => "()"); process_ok('#[include "bar.tmpl"]#' => "(hi)", {bar => 'hi'}); ###----------------------------------------------------------------### print "### LOOP ############################################ $is_compile_perl\n"; process_ok('#[loop "loop1"]#Hi#[endloop]#foo' => "foo"); process_ok('#[loop "loop1"]#Hi#[endloop]#foo' => "Hifoo", {set_loop => [{}]}); process_ok('#[loop "loop1"]##[echo $bar]##[endloop]#foo' => "bingfoo", {set_loop => [{bar => 'bing'}]}); process_ok('#[loop "loop1"]##[echo $bar]##[endloop]#foo' => "bingfoo", {loop1 => [{bar => 'bing'}]}) if ! $is_tt; process_ok('#[loop "loop1"]##[echo $bar]##[endloop]#foo' => "bingbangfoo", {set_loop => [{bar => 'bing'}, {bar => 'bang'}]}); process_ok('#[loop "loop1"]##[echo $boop]##[endloop]#foo' => "bopfoo", {boop => 'bop', set_loop => [{bar => 'bing'}]}); ###----------------------------------------------------------------### print "### TT3 DIRECTIVES ################################## $is_compile_perl\n"; process_ok('#[GET foo]#' => "FOO", {foo => "FOO"}) if ! $is_tt; process_ok('#[GET 1+2+3+4]#' => "10", {foo => "FOO"}) if ! $is_tt; process_ok('#[IF foo]#bar#[ELSIF wow]#wee#[ELSE]#bing#[ENDIF]#' => "bar", {foo => "1"}) if ! $is_tt; process_ok('#[SET i = "foo"]#(#[VAR i]#)' => "(foo)") if ! $is_tt; process_ok('#[SET i = "foo"]#(#[GET i]#)' => "(foo)") if ! $is_tt; process_ok('#[FOR i IN [1..3]]#(#[VAR i]#)#[END]#' => "(1)(2)(3)") if ! $is_tt; process_ok('#[BLOCK foo]#(#[VAR i]#)#[END]##[PROCESS foo i="bar"]#' => "(bar)") if ! $is_tt; process_ok('#[BLOCK foo]#(#[VAR i]#)#[END]##[SET wow = PROCESS foo i="bar"]##[VAR wow]#' => "(bar)") if ! $is_tt; process_ok('#[GET template.foo]##[META foo = "bar"]#' => "bar") if ! $is_tt; process_ok('#[MACRO bar(n) BLOCK]#You said #[VAR n]##[END]##[GET bar("hello")]#' => 'You said hello') if ! $is_tt; ###----------------------------------------------------------------### print "### TT3 CHOMPING #################################### $is_compile_perl\n"; process_ok("\n#[GET foo]#" => "\nFOO", {foo => "FOO"}) if ! $is_tt; process_ok("#[GET foo-]#\n" => "FOO", {foo => "FOO"}) if ! $is_tt; process_ok("\n#[-GET foo]#" => "FOO", {foo => "FOO"}) if ! $is_tt; ###----------------------------------------------------------------### print "### TT3 INTERPOLATE ################################# $is_compile_perl\n"; process_ok('$foo #[GET foo]# ${ 1 + 2 }' => '$foo FOO ${ 1 + 2 }', {foo => "FOO"}) if ! $is_tt; process_ok('$foo #[GET foo]# ${ 1 + 2 }' => 'FOO FOO 3', {foo => "FOO", tt_config => [INTERPOLATE => 1]}) if ! $is_tt; process_ok('#[CONFIG INTERPOLATE => 1]#$foo #[GET foo]# ${ 1 + 2 }' => 'FOO FOO 3', {foo => "FOO"}) if ! $is_tt; ###----------------------------------------------------------------### print "### DONE ############################################ $is_compile_perl\n"; } # end of for libtemplate-alloy-perl-1.022/t/30_velocity.t000066400000000000000000000270721402714000200206640ustar00rootroot00000000000000# -*- Mode: Perl; -*- =head1 NAME 05_velocity.t - Test the ability to parse and play VTL (Velocity Template Language) =cut our $compile_perl; our $module = 'Template::Alloy'; use strict; use Test::More tests => 202; use constant test_taint => 0 && eval { require Taint::Runtime }; use_ok($module); Taint::Runtime::taint_start() if test_taint; ### find a place to allow for testing my $test_dir = $0 .'.test_dir'; END { rmdir $test_dir } mkdir $test_dir, 0755; ok(-d $test_dir, "Got a test dir up and running"); sub process_ok { # process the value and say if it was ok my $str = shift; my $test = shift; my $vars = shift || {}; my $conf = local $vars->{'tt_config'} = $vars->{'tt_config'} || []; push @$conf, (COMPILE_PERL => $compile_perl) if $compile_perl; my $obj = shift || $module->new(INCLUDE_PATH => $test_dir, @$conf); # new object each time my $out = ''; my $line = (caller)[2]; delete $vars->{'tt_config'}; Taint::Runtime::taint(\$str) if test_taint; $obj->merge(\$str, $vars, \$out); my $ok = ref($test) ? $out =~ $test : $out eq $test; if ($ok) { ok(1, "Line $line \"$str\" => \"$out\""); return $obj; } else { ok(0, "Line $line \"$str\""); warn "# Was:\n$out\n# Should've been:\n$test\n"; print $obj->error if $obj->can('error') && $obj->error; if ($obj->can('dump_parse_tree')) { local $obj->{'SYNTAX'} = 'velocity'; print $obj->dump_parse_tree(\$str); } exit; } } ### create some files to include my $foo_template = "$test_dir/foo.vel"; END { unlink $foo_template }; open(my $fh, ">$foo_template") || die "Couldn't open $foo_template: $!"; print $fh "Good Day!"; close $fh; ### create some files to include my $bar_template = "$test_dir/bar.vel"; END { unlink $bar_template }; open($fh, ">$bar_template") || die "Couldn't open $bar_template: $!"; print $fh "(\$bar)"; close $fh; for $compile_perl (0, 1) { my $is_compile_perl = "compile perl ($compile_perl)"; ###----------------------------------------------------------------### print "### VARIABLES ####################################### $is_compile_perl\n"; process_ok("Foo" => "Foo"); process_ok('$mud_Slinger_9' => "bar", {mud_Slinger_9 => 'bar'}); process_ok('$!mud_Slinger_9' => "bar", {mud_Slinger_9 => 'bar'}); process_ok('${mud_Slinger_9}' => "bar", {mud_Slinger_9 => 'bar'}); process_ok('$!{mud_Slinger_9}' => "bar", {mud_Slinger_9 => 'bar'}); process_ok('$mud_Slinger_9<<' => "\$mud_Slinger_9<<", {}); process_ok('$!mud_Slinger_9<<' => "<<", {}); process_ok('${mud_Slinger_9}<<' => "\${mud_Slinger_9}<<", {}); process_ok('$!{mud_Slinger_9}<<' => "<<", {}); ###----------------------------------------------------------------### print "### SET ############################################# $is_compile_perl\n"; process_ok('#set($foo = "bar")$foo' => 'bar'); process_ok('#set($monkey = $bill)$monkey' => 'Bill', {bill => 'Bill'}); process_ok('#set($monkey.Friend = \'monica\')$monkey.Friend' => 'monica'); process_ok('#set($monkey.Blame = $whitehouse.Leak)$monkey.Blame' => 'from_velocity_ref_guide', {whitehouse => {Leak => 'from_velocity_ref_guide'}}); process_ok('#set($monkey.Plan = $spindoctor.weave($web))$monkey.Plan' => '(spider)', {spindoctor => {weave => sub {"($_[0])"}}, web => 'spider'}); process_ok('#set($monkey.Number = 123)$monkey.Number' => '123'); process_ok('#set($monkey.Numbers = [1..3])$monkey.Numbers.2' => '3'); process_ok('#set($monkey.Map = {"banana" : "good"})$monkey.Map.banana' => 'good'); process_ok('#set($value = $foo + 1)$value' => '9', {foo => 8, bar => 4}); process_ok('#set($value = $bar - 1)$value' => '3', {foo => 8, bar => 4}); process_ok('#set($value = $foo * $bar)$value' => '32', {foo => 8, bar => 4}); process_ok('#set($value = $foo / $bar)$value' => '2', {foo => 8, bar => 4}); process_ok('#set($value = $foo % $bar)$value' => '0', {foo => 8, bar => 4}); process_ok('#set($!value = $foo + 1)$value' => '', {foo => 8, bar => 4}); # error because $!value is not a valid variable name in directives ###----------------------------------------------------------------### print "### QUOTED STRINGS ################################## $is_compile_perl\n"; process_ok('#set($value = "($foo)")$value' => '(bar)', {foo => 'bar'}); process_ok('#set($value = "(#get($foo))")$value' => '(bar)', {foo => 'bar'}); process_ok('#set($value = "($foo)")$value' => '(bar)', {foo => 'bar', tt_config => [AUTO_EVAL => 0]}); process_ok('#set($value = "(#get($foo))")$value' => '(#get(bar))', {foo => 'bar', tt_config => [AUTO_EVAL => 0]}); process_ok('#set($value = \'($foo)\')$value' => '($foo)', {foo => 'bar'}); process_ok('#set($value = \'(#get($foo))\')$value' => '(#get($foo))', {foo => 'bar'}); process_ok('#set($value = "($foo)")$value' => '($foo)', {}); process_ok('#set($value = "(#get($foo))")$value' => '()', {}); process_ok('#set($value = "($foo)")$value' => '($foo)', {tt_config => [AUTO_EVAL => 0]}); process_ok('#set($value = "(#get($foo))")$value' => '(#get($foo))', {tt_config => [AUTO_EVAL => 0]}); process_ok('#set($value = "($!foo)")$value' => '()', {}); process_ok('#set($value = "(#get($!foo))")$value' => '', {}); # error because $!foo is not a valid variable name in directives process_ok('#set($value = "($!foo)")$value' => '()', {tt_config => [AUTO_EVAL => 0]}); process_ok('#set($value = "(#get($!foo))")$value' => '(#get())', {tt_config => [AUTO_EVAL => 0]}); ###----------------------------------------------------------------### print "### COMMENTS ######################################## $is_compile_perl\n"; process_ok("Foo##interesting\nBar" => 'FooBar'); process_ok("Foo##interesting\n\nBar" => "Foo\nBar"); process_ok("Foo##interesting" => 'Foo'); process_ok("Foo#*interesting\n" => ''); process_ok("Foo#*interesting\n\n\n*#" => 'Foo'); process_ok("Foo#*interesting\n\n\n*#Bar" => 'FooBar'); ###----------------------------------------------------------------### print "### ESCAPING ######################################## $is_compile_perl\n"; process_ok(('\\'x0).'$email' => 'foo', {email => 'foo'}); process_ok(('\\'x1).'$email' => '$email', {email => 'foo'}); process_ok(('\\'x2).'$email' => '\\foo', {email => 'foo'}); process_ok(('\\'x3).'$email' => '\\$email', {email => 'foo'}); process_ok(('\\'x0).'$email' => '$email'); process_ok(('\\'x1).'$email' => '$email'); # according to VTL spec this is wrong - but that means that the VTL spec parses inconsistently process_ok(('\\'x2).'$email' => '\\$email'); process_ok(('\\'x3).'$email' => '\\$email'); # according to VTL spec this is wrong ###----------------------------------------------------------------### print "### IF / ELSEIF / ELSE ############################## $is_compile_perl\n"; process_ok('#if($foo)bar#{end}bar' => "bar"); process_ok('#if("1")bar#end' => "bar"); process_ok('#if($foo)bar#end' => "", {foo => ""}); process_ok('#if($foo)bar#end' => "bar", {foo => "1"}); process_ok('#if($foo)bar#{else}baz#end' => "bar", {foo => "1"}); process_ok('#if($foo)bar#{else}baz#end' => "baz", {foo => ""}); process_ok('#if($foo)bar#elseif($bing)bang#{else}baz#end' => "baz", {bing => ""}); process_ok('#if($foo)bar#elseif($bing)bang#{else}baz#end' => "bang", {bing => "1"}); ###----------------------------------------------------------------### print "### FOREACH ######################################## $is_compile_perl\n"; process_ok("#foreach( foo )bar#{end}" => 'bar', {foo => 1}); process_ok("#foreach( f IN foo )bar\$f#{end}" => 'bar1bar2', {foo => [1,2]}); process_ok("#foreach( f = foo )bar\$f#{end}" => 'bar1bar2', {foo => [1,2]}); process_ok("#foreach( f = [1,2] )bar\$f#{end}" => 'bar1bar2'); process_ok("#foreach( f = [1..3] )bar\$f#{end}" => 'bar1bar2bar3'); process_ok("#foreach( f = [{a=>'A'},{a=>'B'}] )bar\$f.a#{end}" => 'barAbarB'); process_ok("#foreach( [{a=>'A'},{a=>'B'}] )bar\$a#{end}" => 'barAbarB'); process_ok("#foreach( [{a=>'A'},{a=>'B'}] )bar\$a#{end}\$!a" => 'barAbarB'); process_ok("#foreach( f = [1..3] )\$loop.count/\$loop.size #{end}" => '1/3 2/3 3/3 '); ####----------------------------------------------------------------### print "### INCLUDE ######################################### $is_compile_perl\n"; process_ok('#include("foo.vel")' => "Good Day!"); process_ok('#parse($foo)' => "Good Day!", {foo => "foo.vel"}); process_ok('#include("bar.vel")' => "(\$bar)"); process_ok('#include("bar.vel")' => "(\$bar)", {bar => 'foo'}); ####----------------------------------------------------------------### print "### PARSE ############################################ $is_compile_perl\n"; process_ok('#parse("foo.vel")' => "Good Day!"); process_ok('#parse($foo)' => "Good Day!", {foo => "foo.vel"}); process_ok('#parse("bar.vel")' => "(\$bar)"); process_ok('#parse("bar.vel")' => "(foo)", {bar => 'foo'}); ###----------------------------------------------------------------### print "### STOP ############################################ $is_compile_perl\n"; process_ok("#stop" => ''); process_ok("One#{stop}Two" => 'One'); process_ok("#block('foo')One#{stop}Two#{end}First#process('foo')Last" => 'FirstOne'); process_ok("#foreach( \$f = [1..3] )\$f#if(loop.first)#end\$f#end" => '112233'); process_ok("#foreach( \$f = [1..3] )\$f#if(loop.first)#stop#end#end" => '1'); process_ok("#foreach( \$f = [1..3] )#if(loop.first)#stop#end\$f#end" => ''); ###----------------------------------------------------------------### print "### EVALUATE ######################################## $is_compile_perl\n"; process_ok('#set($f = \'>#try#evaluate($f)#{catch}caught#end\')#evaluate($f)' => '>>>>>caught', {tt_config => [MAX_EVAL_RECURSE => 5]}); process_ok('#set($f = \'>#try#eval($f)#{catch}foo#end\')#eval($f)#EVALUATE($f)' => '>>foo>>foo', {tt_config => [MAX_EVAL_RECURSE => 2]}); ###----------------------------------------------------------------### print "### MACRO ########################################### $is_compile_perl\n"; process_ok("#macro(foo PROCESS bar )#block(bar)Hi#end\$foo" => 'Hi'); process_ok("#macro(foo BLOCK)Hi#end\$foo" => 'Hi'); process_ok('#macro(foo $n BLOCK)Hi$n#end$foo' => 'Hi$n'); process_ok('#macro(foo $n BLOCK)Hi$n#end$foo(2)' => 'Hi2'); process_ok('#macro(foo(n) BLOCK)Hi$n#end$foo' => 'Hi$n'); process_ok('#macro(foo(n) BLOCK)Hi$n#end$foo(2)' => 'Hi2'); process_ok('#macro(foo $n)Hi$n#end$foo' => 'Hi$n'); process_ok('#macro(foo $n)Hi$n#end$foo(2)' => 'Hi2'); process_ok('#macro(foo $n)Hi$n#end#foo(2)' => 'Hi2'); process_ok('#macro(foo $n $m)Hi($n)($m)#end#foo(2 3)' => 'Hi(2)(3)'); process_ok('#macro( inner $foo ) inner : $foo #end #macro( outer $foo ) #set($bar = "outerlala") outer : $foo #end #set($bar = "calltimelala") #outer( "#inner($bar)" )' => ' outer : inner : calltimelala', {tt_config => [POST_CHOMP => '=', PRE_CHOMP => '~']}); process_ok('#macro( inner $foo ) inner : $foo #end #macro( outer $foo ) #set($bar = "outerlala") outer : $foo|eval #end #set($bar = "calltimelala") #outer( "#inner(\'$bar\')" )' => ' outer : inner : outerlala', {tt_config => [POST_CHOMP => '=', PRE_CHOMP => '~']}); ###----------------------------------------------------------------### print "### TT3 CHOMPING #################################### $is_compile_perl\n"; process_ok("\n#get( \$foo )" => "\nFOO", {foo => "FOO"}); process_ok("#get( \$foo -)\n" => "FOO", {foo => "FOO"}); process_ok("\n#get(- \$foo)" => "FOO", {foo => "FOO"}); process_ok("\n#get( -\$foo)" => "\n-7", {foo => "7"}); ###----------------------------------------------------------------### print "### DONE ############################################ $is_compile_perl\n"; } # end of for