Template-Toolkit-2.24/000755 000765 000765 00000000000 11714420735 014241 5ustar00abwabw000000 000000 Template-Toolkit-2.24/bin/000755 000765 000765 00000000000 11714420735 015011 5ustar00abwabw000000 000000 Template-Toolkit-2.24/Changes000644 000765 000765 00000474165 11714267117 015560 0ustar00abwabw000000 000000 #======================================================================== # # Changes # # DESCRIPTION # Revision history for the Template Toolkit. # # AUTHOR # Andy Wardley # #======================================================================== #----------------------------------------------------------------------- # Version 2.24 - 8th February 2012 #------------------------------------------------------------------------ * Added text virtual methods: upper, lower, ucfirst, lcfirst, squote, dquote, trim, collapse, html and xml. * Fixed bug RT#67918 - Bug in Makefile.PL command line parsing when 2 = signs were in an arguement. * Fixed bug RT#74335 - Added documentation for some methods that were lacking it to keep Pod::Coverage happy. #----------------------------------------------------------------------- # Version 2.23 - 21st January 2012 #------------------------------------------------------------------------ * Fixed bug RT#47929 which caused the XS Stash to die mysteriously when calling code that used string evaluation (e.g. DateTime). * Fixed bug RT#68722 so that list.defined('alpha') always returns false. * Added the TRACE_VARS option to keep track of what variables are used in a template. It's not documented yet. See t/trace_vars.t for an example of use. * Applied patch from RT#48989 to avoid Template::Plugin::Procedural from adding target class' methods AUTOLOAD and new methods multiple times (Jens Rehsack) * Applied patch from RT#53451 to accept negative epoch times in Template::Plugin::Date. * Applied patch from Marc Remy to add $Template::Directive::WHILE_MAX option to tpage. #----------------------------------------------------------------------- # Version 2.22 - 21st July 2009 #------------------------------------------------------------------------ * Changed pod coverage and kwalitee tests to only run when release testing. #----------------------------------------------------------------------- # Version 2.21_02 - 4th July 2009 #------------------------------------------------------------------------ * Added UTF8 support to the XS Stash. https://rt.cpan.org/Ticket/Display.html?id=45842 * Fixed the truncate filter to handle lengths shorter than the '...' string being appended on the end. https://rt.cpan.org/Ticket/Display.html?id=45617 * Fixed a bug in the parser/grammar to make NEXT/LAST work correctly inside nested loops. https://rt.cpan.org/Ticket/Display.html?id=40887 * Fixed a bug in Template::Plugin::Filter that was causing the weakened $self reference in a dynamic filter closure to be garbage collected too soon. (NOTE: this has probably un-fixed a previous bug) https://rt.cpan.org/Ticket/Display.html?id=46691 * Applied patch to allow list.sort to sort on multiple fields. https://rt.cpan.org/Ticket/Display.html?id=40637 #----------------------------------------------------------------------- # Version 2.21_01 - 4th July 2009 #------------------------------------------------------------------------ * Removed Template::Plugin::Autoformat and t/autoform.t. They're now available as a separate distribution. * Fixed some Win32 test failures and XS Stash compilation problems. #----------------------------------------------------------------------- # Version 2.21 - 30th June 2009 #------------------------------------------------------------------------ * Fixed a PRE_CHOMP bug that left \r characters lying around when confronted with templates with DOS \r\n line endings. https://rt.cpan.org/Ticket/Display.html?id=43345 * Applied patch from Bradley Baetz to fix defblock #line numbers http://rt.cpan.org/Public/Bug/Display.html?id=47024 #----------------------------------------------------------------------- # Version 2.20_4 (2.21 candidate) - 21st May 2009 #------------------------------------------------------------------------ * Added the even(), odd() and parity() methods to Template::Iterator to assist in making zebra tables. * Removed a post-5.6 perlism in Template::Context that broke on 5.6.2 https://rt.cpan.org/Ticket/Display.html?id=46250 * Replaced a whole bunch of UNIVERSAL::isa() calls with blessed/isa * Applied a patch from Norbert Buchmüller to prevent the #line markers from being whitespaced away from the first column. https://rt.cpan.org/Ticket/Display.html?id=46269 * Applied a patch from Denis F. Latypoff to fix uri/url filters with utf8 text https://rt.cpan.org/Ticket/Display.html?id=41173 #----------------------------------------------------------------------- # Version 2.20_3 (2.21 candidate) - 20th May 2009 #------------------------------------------------------------------------ * Fixed the XS Stash to compile properly in threaded Perls. https://rt.cpan.org/Public/Bug/Display.html?id=46240 * Applied a patch to the XS Stash from Alexey A. Kiritchun to make the scalar.length vmethod work correctly with utf8 strings. http://lists.tt2.org/pipermail/templates/2009-May/010803.html #----------------------------------------------------------------------- # Version 2.20_2 (2.21 candidate) - 17th May 2009 #------------------------------------------------------------------------ * Applied a patch to Template::Test from Andrew Ford to make it skip properly. http://lists.tt2.org/pipermail/templates/2009-March/010678.html * Changed the ttree -v/--verbose option so be less verbose and only report on things that have changed. To make it more verbose (like previous versions), add a second -v/--verbose flag, e.g. $ ttree -v -v * Also added the --summary option to tree to print a summary of what it did, and the --color/--colour option to make it print its verbose messages in colour (on ANSI terminals). * Applied a ttree patch from Lyle Brooks to allow ttree to accept a directory name as a command line argument. * Added the define_view() and define_views() method to Template::Context and added the VIEWS option to pre-define views when the Template object is created. Thanks to Timmy Chan for providing the groundwork on this. http://lists.tt2.org/pipermail/templates/2009-April/010689.html * Retrospectively fixed the Changes for 2.20 to mention the ttree --encoding option. * Applied a patch from Chisel Wright, changing uses of UNIVERSAL::can() to use blessed() and ->can(). http://lists.tt2.org/pipermail/templates/2009-May/010790.html * Fixed a memory leak in the XS Stash introduced in 2.20. Thanks to Breno G. de Oliveira for reporting the problem and helping to narrow it down. https://rt.cpan.org/Public/Bug/Display.html?id=46058 #------------------------------------------------------------------------ # Version 2.20_1 (2.21 candidate) - 7th April 2009 #------------------------------------------------------------------------ * Deleted all the old HTML documentation (now available separately from http://tt2.org/download/index.html#html_docs), examples, libraries and other cruft that was way out of date and badly unloved. * Tweaked Template::Parser to work better with the ANYCASE option. It now knows that anything following a dotop cannot be a keyword so that you can write data.last without the 'last' bit being interpreted as the LAST keyword. Thanks to Sean McAfee for the post that inspired it. http://lists.tt2.org/pipermail/templates/2008-September/010462.html * Fixed a broken test for Apache::Util in the html_entity filter. Added the use_html_entities() and use_apache_util() class methods to Template::Filters to allow end-user selection of one or the other. http://rt.cpan.org/Public/Bug/Display.html?id=40870 http://template-toolkit.org/svnweb/Template2/revision/?rev=1177 * Tweaked Template::Context to recognise Badger::Exception objects and convert them to Template::Exception objects. This is a temporary measure to keep things working during the transition to Badger-based modules. * Added the STRICT option which will cause the stash to throw an exception on encountering an undefined value. Thanks to Ben Tilly for the prod. * Applied a patch to Template::Iterator from Jonathon Padfield to make get_all() do the right thing if get_first() hasn't been called. * Applied a patch to Template::Stash::Context from Ben Tilly to make it easier to subclass. * Applied a patch from Robin Berjon to add the xml filter. #------------------------------------------------------------------------ # Version 2.20 - 13th August 2008 #------------------------------------------------------------------------ * Updated all the documentation. * Restored the GIF images that got mangled in the switch from CVS to Subversion. * Fixed the Makefile.PL to pre-glob the tests to keep things working smoothly in Win32. http://rt.cpan.org/Ticket/Display.html?id=25573 * Applied a patch to Template::Directives from Ben Morrow to fix the SWITCH/CASE directive when matching strings containing regex metacharacters. http://rt.cpan.org/Ticket/Display.html?id=24183 * Applied a patch to Template::Parser from Koichi Taniguchi to make it treat TAGS with case sensitivity. http://rt.cpan.org/Ticket/Display.html?id=19975 * Changed html_entity_filter_factory() in Template::Filters to only look for Apache::Utils and HTML::Entities once. http://rt.cpan.org/Ticket/Display.html?id=19837 Template::Stash --------------- * Applied a patch to Template::Stash from Jess Robinson which allows you to call a list method on a single object and have it automatically upgraded to a single item list. Changed the XS Stash to do the same. http://lists.tt2.org/pipermail/templates/2006-November/009115.html * Fixed a minor bug in the XS Stash which prevented it from updating hash entries with empty, but defined keys. Thanks to Yitzchak Scott-Thoennes for reporting the problem. http://lists.tt2.org/pipermail/templates/2007-November/009819.html * Applied a patch from Alexandr Ciornii to make the XS Stash compile cleanly under VC++ 6.0 and with Sun's C compiler. http://rt.cpan.org/Ticket/Display.html?id=20291 Template::Provider ------------------ * Fixed a minor bug in the Template::Provider code added in 2.19 that caused errors in templates to only be reported once. Subsequent fetches incorrectly returned 'not found' instead of repeating the error. * Made Template::Provider use File::Spec->catfile instead of using '/' and letting Perl worry about Doing The Right Thing. http://rt.cpan.org/Ticket/Display.html?id=34489 * Applied patch from Lyle Brooks to add binmode to the _template_content() method in Template::Provider. http://rt.cpan.org/Ticket/Display.html?id=38075 * Applied patch from Ted Carnahan to silence UNIVERSAL::isa warnings in Template::Provider. http://rt.cpan.org/Ticket/Display.html?id=25468 * Applied patch to Template::Provider from Andrew Hamlin which works around a bug in Strawberry Perl on Win32. http://rt.cpan.org/Ticket/Display.html?id=34578 Template::VMethods ------------------ * Applied a patch from Paul "LeoNerd" Evans to make the list.slice vmethod work properly with negative indices. http://lists.tt2.org/pipermail/templates/2008-March/010105.html Plugins ------- * Added the Math plugin and related files to the MANIFEST so they actually get shipped out as part of the distribution. D'Oh! http://rt.cpan.org/Ticket/Display.html?id=27375 * Added the Scalar plugin which adds the .scalar vmethod for calling object methods and subroutines in scalar context. * Added Template::Plugin::Assert which allows you to assert that values are defined. * Changed Template::Plugin::Filter to weaken the $self reference to avoid circular references and memory leaks. Thanks to Masahiro Honma for reporting the problem and suggesting the fix. * Applied patch from Ronald J Kimball to make Template::Plugin::Date accept dates with the year coming first. http://lists.tt2.org/pipermail/templates/2007-July/009540.html * Added C<1;> to the end of a few plugin modules that were missing it. ttree ----- * Changed the --accept option in ttree to match against the full file path (relative to --src dir) rather than just the file name. This makes it behave the same way as the --ignore option. * Applied patch from Lyle Brooks to add binmode to the process() call in ttree. http://rt.cpan.org/Ticket/Display.html?id=38076 * Added a patch from Nigel Metheringham also to set binmode in ttree but via a configuration option. https://rt.cpan.org/Ticket/Display.html?id=30760 * Applied a patch from Éric Cholet to add the --encoding option to ttree. http://lists.tt2.org/pipermail/templates/2008-August/010369.html #------------------------------------------------------------------------ # Version 2.19 - 27th April 2007 #------------------------------------------------------------------------ * Applied a patch to t/fileline.t from Steffen Müller which fixes the problems running on Win32 with backslashes in paths. https://rt.cpan.org/Ticket/Display.html?id=20488 * Applied a patch to the XS Stash from Randy Kobes which fixes some other Win32 problems. http://lists.tt2.org/pipermail/templates/2007-February/009247.html * Applied another patch to the XS Stash from Steve Peters which fixes a problem with tied hashes under more recent version of Perl. http://lists.tt2.org/pipermail/templates/2007-January/009181.html * Fixed a problem in the Perl Stash when using objects that have overloaded comparison operators. Thanks to Randal Schwartz, Tatsuhiko Miyagawa and Daisuke Maki for their contributions. http://lists.tt2.org/pipermail/templates/2007-March/009265.html * Applied a patch from Bill Moseley to Template::Provider which adds negative caching and moves some functionality into separate methods to make subclassing easier. Also added the STAT_TTL configuration parameter. http://lists.tt2.org/pipermail/templates/2007-January/009183.html * Added the url filter as a less aggressive form of the uri filter. Whereas the uri filter now (from v2.16 onwards) encodes all the reserved characters (@, :, /, etc.) as per RFC2396, the url filter leaves them intact and thus behaves just like the uri filter used to. http://lists.tt2.org/pipermail/templates/2007-March/009277.html #------------------------------------------------------------------------ # Version 2.18a - 9th February 2007 #------------------------------------------------------------------------ * Applied a patch from Steve Peters to the Stash.xs to allow it to compile with bleadperl 5.9.x https://rt.cpan.org/Public/Bug/Display.html?id=22506 #------------------------------------------------------------------------ # Version 2.18 - 9th February 2007 #------------------------------------------------------------------------ * Merged in Adam's changes in 2.16 and 2.17 back into the developer CVS repository and added his name to the credits. * Changed the parser grammar to accept expressions as arguments to a subroutine, method or virtual method call. I'm embarrassed to admit that it was a one line change that could (and should) have been made long ago, if only I had realised just how trivial it was. Anyway, you can now write nested expressions like this: [% add(a+5, b < 10 ? c : d + e*5) %] * Put the t/fileline.t test back in as this was fixed in 2.15a * Added the Template::Toolkit documentation-only module. #------------------------------------------------------------------------ # Version 2.17 - 8th Feb 2007 #------------------------------------------------------------------------ Another interim release from Adam Kennedy. * Change in Makefile.PL to force an upgrade to File::HomeDir 0.64 on darwin. This is due to problems caused by changes made to Perl on the new Intel versions of Mac OS X. * skip_all filelines.t on darwin #------------------------------------------------------------------------ # Version 2.16 - 23rd Jan 2007 #------------------------------------------------------------------------ Interim release from Adam Kennedy. * Skip fileline.t on Win32, as it has some hard-coded path seperator assumptions. This will be fixed more comprehensively later. * Handle spurious errors in Makefile.PL when a dev version of ExtUtils::MakeMaker is installed. * Don't say "nmake" on Win32 when $Config{make} is 'dmake'. This corrects the message on Strawberry Perl. #------------------------------------------------------------------------ # Version 2.15c - Not released ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed a bug in Template::Parser which caused it to get confused about block names if it encountered a syntax error inside a BLOCK. Thanks to Bill Moseley for reporting the problem. http://lists.tt2.org/pipermail/templates/2006-July/008815.html * Fixed a minor buglet in Template::Provider which came to light while investigating the above problem. If a previously cached template is changed on disk and then fails to compile, the provider now invalidates the cache entry immediately. Without this fix, the provider would report the error once, then reuse the cached good version of the template until $STAT_TTL ticked over when it would try to load and compile the disk version again. The problem was that error messages were only reported once every $STAT_TTL second(s) and any requests for the same template in the interim time would mysteriously work. This way errors get reported consistently and immediately and no-one has to waste an afternoon trying to figure out where the errors went! #------------------------------------------------------------------------ # Version 2.15b - 30th May 2006 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Changed the uri filter to escape all reserved characters as per URI::Escape and RFC2396. This now includes &, @, /, ;, :, =, +, ? and $ which were previously not escaped. Thanks to islue@cpan.org for reporting the problem. http://rt.cpan.org/Ticket/Display.html?id=19593 * Also changed the uri filter to encode all wide characters as the equivalent UTF escapes. Thanks to Jonathan Rockway for reporting the problem. http://rt.cpan.org/Ticket/Display.html?id=19354 * Fixed the redirect filter to not support relative paths. Thanks to Paul Seamons for spotting the problem and providing a solution. * Moved all the virtual methods out of Template::Stash and into a new Template::VMethods module. * Fixed the version number of Template::Stash which had rolled over to 2.102 making it appear to predate the 2.86 stash in TT v2.14. Thanks to Randal Schwartz for reporting the problem. Changed all version numbers in other modules to be a hard-coded numbers instead of grokking it automagically from the CVS revision. * Changed the _recover() method of Template::Service to check if the error thrown is a Template::Exception object rather than just a reference. Thanks to David Wheeler for reporting the problem. http://rt.cpan.org/Ticket/Display.html?id=17630 * Fixed the some tests in stash.t and stash-xs.t which were failing under Perl 5.6.2 due to a slightly different error message being generated. Thanks to Anton Berezin for reporting the problem. * Fixed a bug in the Template::Provider _load() method to check that $data is a hash ref before trying to mess with its innards. Thanks to barbie@cpan.org for reporting the problem. http://rt.cpan.org/Ticket/Display.html?id=18653 #------------------------------------------------------------------------ # Version 2.15a - 29th May 2006 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Removed the latex filter from Template::Filters and related config variables from Template::Config * Changed the t/fileline.t test to remove the line number from what Perl reports as "(eval $line)". It appears to get the $line wrong on FreeBSD, although the correct line number is reported following that so the tests still do the right thing. Thanks to Anton Berezin for reporting the problem. * Changed the t/compile3.t test to do something similar. #------------------------------------------------------------------------ # Version 2.15 - 26th May 2006 #------------------------------------------------------------------------ Chomping Options ---------------- * Added the CHOMP_GREEDY option and '~' chomping flag. Changed CHOMP_COLLAPSE to greedily chomp all whitespace (including multiple newlines) and replace it with a single space. Previously it only chomped one line. Renamed the CHOMP_ALL option to CHOMP_ONE which makes more sense. CHOMP_ALL is still provided as an alias for CHOMP_ONE for backwards compatibility. Thanks to Paul Seamons for doing all the hard work on this. http://lists.tt2.org/pipermail/templates/2006-February/thread.html#8354 * Added code to the replace text virtual method to use a faster and simpler implementation if the replacement text doesn't contain any back references. Thanks to Josh Rosenbaum for all his efforts on this. http://lists.tt2.org/pipermail/templates/2006-February/008344.html Stash ----- * Changed various tests for private/hidden variables (starting '_' or '.') to use a regex defined in the $PRIVATE package variable in Template::Stash. This can be redefined or undefined. Note that the XS Stash only looks to see if $PRIVATE is defined or not, and currently hard-codes the regex. Plugins ------- * Changed the Image plugin tag() method to call the name() method instead of accessing the name directly, making it easier for subclasses to provide an alternate name. Thanks to Cees Hek for his patch. http://lists.tt2.org/pipermail/templates/2006-February/008423.html * Change the AUTOLOAD regex in the Table plugin to be more robust. http://lists.tt2.org/pipermail/templates/2006-May/008602.html Documentation ------------- * Added the Template::Toolkit documentation pointing people to the right place. * Updated the Template::Stash::XS documentation to remove the "experimental" description and tidy things up a bit. #------------------------------------------------------------------------ # Version 2.14a - 2nd February 2006 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ Stash ----- * Activated a patch in Template::Stash from Stephen Howard which adds code for the full set of fallbacks for dot ops called against objects which don't implement the specific method. For example [% hashobj.vmethod %] [% listobj.2 %] and [% listobj.vmethod %] now all work with the Perl Template::Stash. Added code to the XS Stash to do the same and updated tests. http://template-toolkit.org/pipermail/templates/2003-December/005417.html * Added full support for tied hashes and tied lists in the XS Stash. Added some further tests to make sure it's all working as expected. http://lists.tt2.org/pipermail/templates/2006-January/008266.html * Applied path from Slaven Rezic to Template::Stash::XS to check return code in tt_fetch_item() in a way which plays nicely with tied hashes. http://rt.cpan.org/Ticket/Display.html?id=7830 * Changed Template::Stash and Template::Stash::XS to evaluate list vmethods in lvalues. http://lists.tt2.org/pipermail/templates/2006-January/008198.html * Changed Template::Stash to be a little more strict about what it considers a failed method call. This allows exception thrown within called methods to be propagated correctly rather than being ignored as undefined method. Thanks to Dave Howorth, Tom Insam and Stig Brautaset for reporting the problem and providing fixes. http://lists.tt2.org/pipermail/templates/2005-April/007375.html http://lists.tt2.org/pipermail/templates/2006-February/008367.html * Removed redundant performance profiling code from Template::Stash::XS. Must check with Doug that this is OK and he's not still using it... Virtual Methods --------------- * Added the scalar.remove, scalar.substr, hash.delete, hash.items, hash.pairs, list.import and list.hash virtual methods. * Changed the scalar.replace method to work properly with back references ($1, $2, etc) by incorporating ideas, code and tests from Nik Clayton, Paul Seamon, Sergey Martynoff, Josh Rosenbaum and others. http://lists.tt2.org/pipermail/templates/2006-February/008306.html http://lists.tt2.org/pipermail/templates/2006-February/008326.html * Changed list.push and list.unshift to accept multiple arguments, thanks to Bill Moseley. http://lists.tt2.org/pipermail/templates/2006-January/008294.html * Fixed the split scalar virtual method which wasn't accepting the second argument (limit) correctly. Thanks to Josh Rosenbaum for pointing out the problem. http://lists.tt2.org/pipermail/templates/2005-October/007982.html * Documented the fact that hash.list is going to change in the future, recommending people switch to hash.pairs. http://lists.tt2.org/pipermail/templates/2006-January/008256.html http://lists.tt2.org/pipermail/templates/2006-February/008312.html * Added the global option to the 'match' scalar virtual method. * Changed $element to $component in Template::Context to fix callers bug, thanks to Andy Maas who identified the problem and found the solution: http://lists.tt2.org/pipermail/templates/2004-December/007020.html * Changed the sort and nsort list virtual methods to always return references to lists, avoiding any ambiguity in return results. * Changed the hash.defined method to do the same thing as scalar.defined when called without arguments. Added list.defined to do the same thing as hash.defined. http://rt.cpan.org/Ticket/Display.html?id=9094 * Moved all the tests into t/vmethods/* Plugins ------- * Added the $Template::Plugins::PLUGIN_BASE package variable to define the default 'Template::Plugin' value for the PLUGIN_BASE option. By clearing this value before calling the Template new() constructor, you can avoid having Template::Plugin added to the PLUGIN_BASE by default. Also changed PLUGINS search to look for lower case plugin name as well as case-specific name. Thanks yet again Josh for addressing this issue. http://lists.tt2.org/pipermail/templates/2006-January/008225.html * Applied a single character patch from Lubomir Host which fixes the user attribute in Template::Plugin::File. * Added the Math Plugin to MANIFEST. * Changed the URL plugin to ignore parameters that are unset (e.g. defined but zero length) * Applied two patches to the Image plugin from Bill Moseley to escape attributes in the tag() method and to provide the 'file' options. Also adds proper documentation for the 'root' option. http://lists.tt2.org/pipermail/templates/2005-November/008086.html http://lists.tt2.org/pipermail/templates/2005-December/008189.html * Added the $JOINT package variable to Template::Plugin::URL to provide a work-around for the URL plugin which incorrectly (as we now know) encodes '&' as '&' http://rt.cpan.org//Ticket/Display.html?id=11551 http://lists.tt2.org/pipermail/templates/2005-December/008158.html * Added substr() method to the String plugin, as suggested here: http://rt.cpan.org/Ticket/Display.html?id=2619 * Moved all XML plugins and related tests into a separate Template-XML distribution. * Moved DBI plugin and tests into Template-DBI distribution. * Moved GD plugins and tests into Template-GD distribution. Filters ------- * Applied a patch to the truncate() filter from "Ashley" which adds a second argument. http://lists.tt2.org/pipermail/templates/2005-December/008145.html * Fixed a bug in the same truncate() filter to stop it from truncating strings that are exactly as long as the limit (change '<' to '<='), thanks to Nicholas at oxhoej.dk. http://rt.cpan.org/Ticket/Display.html?id=8911 * Added "use locale" to Template::Filters to enable locale-specific filters. http://rt.cpan.org/Ticket/Display.html?id=9094 http://rt.cpan.org/Ticket/Display.html?id=5695 * Updated documentation to reflect the fact that the html filter also escapes " as " Thanks to Geoff Richards for reporting it. * Moved Latex filters into Template-Latex distribution. ttree ----- * Applied patch from Yuri Pimenov to prevent ttree from raising a warning when the --depend_debug option is used. http://lists.tt2.org/pipermail/templates/2005-May/007400.html * Applied a patch to ttree from Slaven Rezic which fixes the arguments passed to mkpath. http://rt.cpan.org//Ticket/Display.html?id=14216 * Applied a patch to ttree from Mike Schilli to prevent it from going into an infinite loop on encountering a directory called "0" https://rt.cpan.org/Ticket/Display.html?id=14905 * Fixed configuration section to not prompt "Do you want me to create a sample .ttreerc file?" if the -h/--help options are specified, thanks to Slaven Rezic for reporting the problem. http://rt.cpan.org/Ticket/Display.html?id=4180 * added AppConfig EXPAND => EXPAND_ALL option to perl5lib, template_plugin_base, template_compile_dir and depend_file configuration options to allow them to contain ~ to indicate the user's home directory, or $WHATEVER for environment variables, as per the other path-specific options like src, lib, etc. Miscellaneous ------------- * Added code to Makefile.PL to detect $ENV{PERL_MM_USE_DEFAULT} to accept all defaults. Thanks to KANE. http://rt.cpan.org/Ticket/Display.html?id=14613 * Removed vStrings from Template::Document. Thanks to Dave Cross for reporting the problem. http://lists.tt2.org/pipermail/templates/2005-April/007357.html * Applied a patch from Barrie Slaymaker which corrects a bug in the Template::Parser line counting when using chomp flags. http://lists.tt2.org/pipermail/templates/2005-December/008157.html * Applied a patch from Jess Robinson to move the Template::Provider check for file freshness into a separate method, in order to play nicely with his Template::Provider::DBI module. http://lists.tt2.org/pipermail/templates/2005-December/008143.html * Fixed the regex matching relative paths in Template::Provider, thanks to Josh Rosenbaum http://lists.tt2.org/pipermail/templates/2005-January/007141.html * Applied a patch to Template::Provider to prevent a misleading error message, thanks to Slaven Rezic. http://rt.cpan.org/Ticket/Display.html?id=5327 * Added an eval wrapper around mkpath() in Template::Provider to handle errors more nicely. * Numerous documentation fixes. #------------------------------------------------------------------------ # Version 2.14 - 4th October 2004 #------------------------------------------------------------------------ * Applied patch from Harald Joerg to prevent ttree from spewing warnings when copying files. http://template-toolkit.org/pipermail/templates/2004-March/005897.html * Applied a patch from Paul Orrock to fix a couple of missing errors in ttree. http://template-toolkit.org/pipermail/templates/2004-September/006605.html * Commented out line 797 of Template::Directive.pm which serves no purpose and generates a warning. * Applied a patch from Mark Fowler to add support for Unicode to TT. http://template-toolkit.org/pipermail/templates/2004-June/006270.html * Changed the fourth argument to process() to accept named IO layers for binmode, e.g. process($in, $vars, $out, binmode => ':utf8'); * Added full range of command line options to tpage. http://template-toolkit.org/pipermail/templates/2004-September/006545.html * Applied patches from Tosh Cooey, Simon Wilcox and Kenny Gatdula to fix XML::Simple to allow direct access to XMLin() and XMLout() methods. See http://template-toolkit.org/pipermail/templates/2004-September/006620.html * Fixed a bug in the 'callers' list maintained by a template component which was failing to remove callers from the list after processing. http://template-toolkit.org/pipermail/templates/2004-April/006070.html * Applied a doc patch from Dave Cash documenting caller and callers. http://template-toolkit.org/pipermail/templates/2004-March/005960.html #------------------------------------------------------------------------ # Version 2.13 - 30th January 2004 #------------------------------------------------------------------------ * Applied patch from Dave Cash to add 'caller' and 'callers' to 'component', see http://lists.tt2.org/pipermail/templates/2004-January/005581.html * Applied patch from Dylan William Hardison to ttree which prevents dependencies from interfering with files that are copied. See http://lists.tt2.org/pipermail/templates/2003-December/005458.html #------------------------------------------------------------------------ # Version 2.12a - 13th January 2004 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed the bug in test 25 of t/date.t, hopefully for good this time, thanks to the efforts of Steve Peters. See: http://template-toolkit.org/pipermail/templates/2004-January/005560.html * Added the FILE_INFO option to Template::Parser. Enabled by default, this can be set to 0 to prevent the parser from adding file and line info to the generated Perl file. Don't ask me why - Autrijus wanted it (which probably means he's up to something twisted again :-). See: http://template-toolkit.org/pipermail/templates/2004-January/005552.html #------------------------------------------------------------------------ # Version 2.12 - 12th January 2004 #------------------------------------------------------------------------ * Added the module_version() method to Template::Base to report the version number of a module. Added some tests to t/base.t. * Added the --template_module option to ttree, to allow the user to specify a template processing module other than the default 'Template' to be used. Also changed various print statements to send all verbose output to stdout, whereas previously it was split across stdout and stderr. #------------------------------------------------------------------------ # Version 2.11b - 7th January 2004 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Applied patch from Myk Melez to ensure the 'component' variable remains correctly set to the current templates. See http://template-toolkit.org/pipermail/templates/2004-January/005483.html #------------------------------------------------------------------------ # Version 2.11a - 6th January 2004 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed bug in t/date.t and corrected version number of Template::Grammar. #------------------------------------------------------------------------ # Version 2.11 - 6th January 2004 #------------------------------------------------------------------------ * Bumped version number and updated documentation for release. #------------------------------------------------------------------------ # Version 2.10b - 2nd December 2003 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Changed the Template::Document process() method to pass itself to the context visit() method when it calls it. Similarly, changed the context visit() method to expect it. This is useful when subclassing the context but shouldn't have any other effect. * Modified parser to add the file name and line number of the source template to generated Perl code. This provides useful information when warnings and errors are generated by Perl at runtime. Added the t/fileline.t script to test it. #------------------------------------------------------------------------ # Version 2.10a - 9th October 2003 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Applied two patches from Axel Gerstmair to fix bugs in Makefile.PL and t/date.t. See. http://lists.tt2.org/pipermail/templates/2003-April/004553.html http://lists.tt2.org/pipermail/templates/2003-May/004572.html * Applied patch from Jim Cromie to t/autoform.t to skip tests on all versions of Perl from 5.8.0 onwards. * Changed $OUTPUT in Template::Directive to be a package variable, allowing it to be re-defined to permit a flushed output hack. http://lists.tt2.org/pipermail/templates/2003-October/005136.html * Applied a patch from Darren to the 'item' hash vmethod to protect against accessing private variables (prefixed '.' or '_') http://lists.tt2.org/pipermail/templates/2003-June/004761.html * Applied a patch from Ivan Adzhubey to template/splash/frame. http://lists.tt2.org/pipermail/templates/2003-August/004953.html * Applied a patch from Bryce Harrington to add the absolute and relative options to ttree. Also applied a patch from Mark Anderson to add the 'template_debug'. Removed the old debug option which was as good as useless. http://lists.tt2.org/pipermail/templates/2003-October/005110.html http://lists.tt2.org/pipermail/templates/2003-October/005126.html * Applied another patch from Mark to push files named on the command line through the process_file() sub to ensure that various options like accept checking, pemission preserving and copy processing (but not modification time) are applied. http://lists.tt2.org/pipermail/templates/2003-October/005132.html * Applied a variation of yet another ttree patch from Mark to add the 'suffix' option for changing the suffix of output files created. http://lists.tt2.org/pipermail/templates/2003-October/005121.html * Applied a variation of a patch from Dylan William Hardison which adds the 'depend' and 'depend_file' options to ttree. http://lists.tt2.org/pipermail/templates/2003-July/004783.html http://lists.tt2.org/pipermail/templates/2003-October/005147.html #------------------------------------------------------------------------ # Version 2.10 - 24th July 2003 #------------------------------------------------------------------------ * Merged in Darren's branch to add the define_vmethod() methods to Template::Context and Template::Stash. * Applied patch from Axel Gerstmair for minor fixes to Makefile.PL, t/gd.t and t/date.t. http://template-toolkit.org/pipermail/templates/2003-April/004545.html * Added undefined() method to the Stash which get() calls if a variable value is undefined. Currently just returns '' to implement existing behaviour, but it provides a method hook for subclasses to redefine. * Fixed a minor bug which prevented the Stash from being subclassable by removing references to __PACKAGE__ #------------------------------------------------------------------------ # Version 2.09c - 29th April 2003 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * applied patch from Ivan Kurmanov to XPath plugin to add handling for comments. * modified grammar to allow 'IN' as an alternate for '=' in FOREACH directives, thus allowing [% FOREACH item IN [ foo, bar, baz ] %] http://template-toolkit.org/pipermail/templates/2003-April/004519.html * changed test for PROCESS option in Template::Service init from 'exists' to 'defined' so that PROCESS set to undef Does The Right Thing. http://template-toolkit.org/pipermail/templates/2003-April/004536.html * changed Template::process() method to accept a hash reference or list of output options following any filename. This can now be used to explicitly set binary mode (or not) for the output of a file. Also changed Template::_output() method to expect a reference to text rather than a duplicated text string (for efficiency) and also the new hash reference of options. Also changed the redirect and stdout filters accordingly. * disabled the mandatory binmode setting on all files created under MSWin32. See previous item for details on how binmode can now be set explicitly, or link below for description of problem. http://template-toolkit.org/pipermail/templates/2003-April/004499.html * applied patch from Axel Gerstmair to Makefile.PL to add TT_EXTRAS item. http://template-toolkit.org/pipermail/templates/2003-April/004543.html #------------------------------------------------------------------------ # Version 2.09b - 24th April 2003 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * fixed bug introduced in 2.08e which caused some exception handling to fail under Perl 5.6.1 and earlier. http://template-toolkit.org/pipermail/templates/2003-April/004502.html * applied patch from Tatsuhiko Miyagawa to gd.t test to change size test from 6500 to 6000. * applied patch from Axel Gerstmair to the Image plugin. http://template-toolkit.org/pipermail/templates/2003-April/004496.html #------------------------------------------------------------------------ # Version 2.09a - 23rd April 2003 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * added WRAPPER configuration item, documentation and tests. Also added 'wrapper' configuration item to ttree. See Template::Manual::Config * applied patch from Axel Gerstmair to fix File::Spec and File::Temp versions in Makefile.PL. http://template-toolkit.org/pipermail/templates/2003-April/004480.html #------------------------------------------------------------------------ # Version 2.09 - 23rd April 2003 #------------------------------------------------------------------------ * Bumped version number for release. #------------------------------------------------------------------------ # Version 2.08e - 18th March 2003 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * changed Template::Provider and Template::Context to propagate nested exceptions (e.g. [ file => [ parse => 'blah blah' ] ]) to allow the caller to accurately differentiate between parse errors and missing file or other errors. http://lists.tt2.org/pipermail/templates/2003-March/004359.html * applied a patch from Gervase Markham to add set_legend() to the various GD::Graph modules that works with a list of arguments. http://lists.tt2.org/pipermail/templates/2003-March/004316.html #------------------------------------------------------------------------ # Version 2.08d - 18th March 2003 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Made Template::Exception DTRT with overloading (mark) * Applied a patch from Jonas Liljegren to lower the chunking limit of the parser regex to prevent a segfault. See http://lists.tt2.org/pipermail/templates/2003-February/004290.html * Applied Pudge's patch for the XS Stash bug. See http://lists.tt2.org/pipermail/templates/2003-February/004289.html #------------------------------------------------------------------------ # Version 2.08c - 4th November 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Applied a patch from Bradley Baetz to work around a bug in Perl when using an overridden die(), as CGI::Carp does, for example. * Added the Image plugin interfacing to the Image::Size module, based on examples posted to the mailing list by Darren and Mark. See http://lists.tt2.org/pipermail/templates/2002-November/003876.html #------------------------------------------------------------------------ # Version 2.08b - 1st November 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Applied two patches from Leon to fix bug in constant folding with multiple replacements (a missing 'g' on a s///) * Applied a patch from Tatsuhiko Miyagawa to Template::Constants to replace 'our' perl5.6isms. * Added the Template::Plugin::Procedural module for creating plugins that use subroutines rather than method calls. * Fixed a html.t test to allow numerical instead of named entities (mark) * Added the params() method to the CGI plugin. * Changed File::Temp and File::Basename to be loaded dynamically in Template::Document as and when needed. Thanks to a patch from Bradley Baetz. * Added a preload() method to Template::Config to preload in advance all the Template::* modules typically used. Also added call to preload() from Template module if $ENV{MOD_PERL} is set. * Applied a patch from Randal Schwartz to fix rowspan attribute in templates/html/cell and templates/html/row #------------------------------------------------------------------------ # Version 2.08a - 14th August 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Totally re-implemented the handling of the DEBUG parameter. Added DEBUG_* constants to Template::Constants which can be used to enable different debugging options and messages. * Added skip_all($reason) to Template::Test and fixed up a whole bunch of tests to use it. Also made other minor fixes to the tests to run nicely (or bail politely) under Perl 5.8.0 * Applied patch from Slaven Rezic to Template::Plugin::Data which modifies the locale loading to append various suffixes (e.g. '.UTF-8') in the case that the unadorned locale can't be loaded. * Bumped version number of File::Spec to 0.8 in Makefile.PL PREREQ_PM. Previous versions didn't include splitdir(). Thanks to Slaven Rezic for reporting the problem. #------------------------------------------------------------------------ # Version 2.08 - 30th July 2002 #------------------------------------------------------------------------ * Applied two minor patches from Leon to remove 'use warnings' from 2 test scripts to maintain compatability with 5.005 #------------------------------------------------------------------------ # Version 2.07c - 22nd July 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed a bug in Date plugin introduced in last version which caused it to ignore the 'time' parameter. * Modified INCLUDE_PATH handling in Template::Provider to accept a reference to a subroutine or object implementing a paths() method as an element in the list. This is then called to return a dynamically generated path. Documented and tested. * Changed the implementation of the NAMESPACE calling code to leave the namespace prefix intact on the ident list which then gets passed to the handler's ident() method. Modified the ident() method of Template::Namespace::Constants to expect and remove it. Constant folding now *doesn't* happen for constants that return a reference or undefined value. These get compiled as regular runtime variable lookups. * Added new list virtual methods: 'unique' to cull multiple identical items, 'merge' to merge lists together, 'splice' which acts just like Perl's splice, and 'slice' which returns a slice of the list. Also modified first and last virtual methods to take an argument indicating the number of items to return from the start or end of the list. Added the 'chunk' scalar virtual method to split a string into chunks of a particular flushed either left or right. (darren, mark, abw) * Moved documentation for virtual methods into a separate manpage, Template::Manual::VMethods * Modifed Template::Test to allow -- name testname -- comments to be added to tests to give them names, reported by test harness (darren) * Merged functionality of process() and include() methods into process() with optional third $localize flag. (darren) * Modified the OUTPUT option to accept a reference to a list (darren) #------------------------------------------------------------------------ # Version 2.07b - 7th July 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Added the CONSTANTS, CONSTANTS_NAMESPACE and NAMESPACE options, the Template::Namespace::Constants module, documentation and t/constants.t test suite. This adds support for compile-time constant folding and other custom namespace handlers. #------------------------------------------------------------------------ # Version 2.07a - 5th July 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Changed the Perl and XS stashes to automatically promote a scalar to a list and apply a list virtual method (if defined) as a last ditch attempt. * Changed Template::Stash::Context virtual methods to import those of Template::Stash. * Fixed a potential race condition when using compiled templates by changing Template::Document::write_perl_file() to write to a temporary file and then rename it into place, thus preventing two separate processes attempting to write the same file at the same time. * Added the DEBUG and DEBUG_FORMAT options and the corresponding DEBUG directive. * Fixed bug introduced to Template::Provider in 2.06g which changed handling of trailing slashes on COMPILE_DIR. * Fixed a bug in Template::Parser to preserve any post-chomp flags that were otherwise ignored when an entire directive is commented out, e.g. [%# blah # blah -%] * Applied a patch from Harald Joerg so that ttree considers files with equal mtime to be "not modified". * Applied a patch from Keith Murphy adding the gmt flag to the Date plugin. * Applied Makefile.PL portability patch from Chris Nandor. * Minor documentation fixes. #------------------------------------------------------------------------ # Version 2.07 - 17th April 2002 #------------------------------------------------------------------------ * Changed example in synopsis of Template::Plugin::XML::Style to one based on that posted to the mailing list by Tony Bowden. * Fixed a single/double quoting bug in docsrc which prevented [% and %] being correctly displayed in the tables of contents in HTML docs. #------------------------------------------------------------------------ # Version 2.06g - 15th April 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed a bug in ttree which prevented it from passing the recurse option onto the Template object due to a name mismatch: recurse/recursion * Changed Template::Test to accept messages to ok(). Also added is() as an alias for match(). * Fixed an oversight/bug in the XS stash where a missing aTHX_ around line 546 caused compilation to fail under Win32. * Applied a patch to Template::Provider from Alexander Schilling which untaints paths before calling mkpath() to prevent errors under -T. * Fixed Template::Parser so that the INTERPOLATE option now works with files > 32K, thanks to the efforts of Stephen Adkins. #------------------------------------------------------------------------ # Version 2.06f - 13th March 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed a bug in both the Perl and XS Stash modules which resulted in virtual methods being called on the base stash, e.g. [% size %] was treated as [% stash.size %]. The only exception that we allow through is 'import' so that we can [% import(another_hash) %] * Fixed the compilation of the XS Stash on earlier versions of Perl (e.g. 5.00503) and other platforms (e.g. Win32) by including the ppport.h file. * Fixed a warning about undefined values in Template::Plugin::Format raised by t/format.t * Fixed a warning in t/html.t raised when neither Apache::Util nor HTML::Entities is installed. #------------------------------------------------------------------------ # Version 2.06e - 12th March 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed a minor bug in t/tiedhash.t which was trying to use the XS stash even if it wasn't enabled. Thanks to Lyle Brooks for the patch. * Added the 'match' virtual method for matching a string against a regex and returning a reference to a list of (captured) (backrefs). * Changed html filter back into a fast and simple static filter. Added html_entity filter which uses Apache::Util or HTML::Entities to do a complete and thorough (but slower) job. The undocumented 'entity' option of the html filter is now removed (but may appear elsewhere). * Added the size virtual method for scalars to prove a consistent way of testing something.size to see if it has some value(s). For scalars it returns 1. * Modified the 'sort' and 'nsort' list virtual methods to allow a sort key passed to represent a method to be called on objects in the list as well as the key of a value to be fetched from hash references in the list. e.g. [% books.sort('author') %] allows 'books' to contain a list of hash refs with an 'author' key or objects with an 'author' method. Thanks to Tony Bowden for suggesting this improvement. * Applied a patch from Simon Wilcox to strip MS-DOS \r characters from end of lines read by the Datafile plugin. * Applied a patch from Ville Skyttä which fixes numerous minor bugs in various splash templates. * Added the 'defined' and 'exists' virtual hash methods for testing if a value has a defined value, or exists in the hash, respectively. * Applied a patch from Stathy Touloumis to make the XS Stash thread safe. * Added the 'grep' virtual list method. * Applied a patch from Mark Fowler to improve the XML XPath plugin's handling of nested elements. * Fixed handling of prefix support in template() and insert() methods of Template::Content. Any prefix is stripped from the name but passed as the second argument to the provider fetch() method. e.g. [% INCLUDE foo:bar %] calls the foo $provider->fetch('bar', 'foo') and [% INCLUDE http://tt2.org/t/templates/hello %] results in a call to $provider->fetch('//tt2.org/t/templates/hello', 'http') #------------------------------------------------------------------------ # Version 2.06d - 22nd January 2002 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Applied a patch to the DBI plugin from Simon Matthews to stop it from closing a DBH which was passed in open from an external source. * Applied another patch from Simon to fix a bug with compiled templates which were never being loaded due to a '<' comparison of timestamps rather than '<='. See http://lists.tt2.org/pipermail/templates/2002-January/002361.html * Applied a patch from Doug Steinwand which fixes a minor bug in the XS Stash as reported by Andrey Brindeew: http://lists.tt2.org/pipermail/templates/2002-January/002475.html * Changed URL plugin to accept multiple values for CGI parameters, e.g. [% USE URL('/cgi-bin/foo', items=[10,20]) %] generates a URL like: /cgi-bin/foo?item=10&item=20 * Applied a patch from David D. Kilzer to Makefile.PL to add -I flags to the various invocations of perl that we missed, and also to add a clean/FILES target for WriteMakefile(). See. http://lists.tt2.org/pipermail/templates/2002-January/002431.html * Fixed Makefile.PL to warn, not die, about mandatory modules, leaving it to the definitions in the PREREQ_PM which the CPAN module can understand. Thanks to Leon for waving the flag. * Applied Leon's doc patch to the Table plugin to demonstrate row/column transposition. * Added ucfirst and lcfirst filters to fold first character to upper or lower case respectively. Thanks to Paul Makepeace for the patch. * Fixed truncate method of String plugin to not append suffix if the string is already shorter than the required length. Thanks to Yann Kerhervé for the patch. #------------------------------------------------------------------------ # Version 2.06c - 20th December 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Changed both Perl and XS Stash modules to try to apply a SCALAR_OPS virtual method to a blessed object as a last-ditch chance if all else fails. Thanks to Tony Bowden for reporting the problem. See http://lists.tt2.org/pipermail/templates/2001-December/002263.html * Added tie() method to DBI plugin which interfaces to the Tie::DBI module, based on some plugin code sent to me courtesy of Dave Hodgkinson. Also made various minor cleanups to DBI code and updated documentation and tests. Incidentally, this tickled the missing feature in the XS stash which doesn't yet support tied hashes. * Applied a patch from Christian Schaffner which fixes a problem in the Makefile.PL for installation via the fink package manager under Mac OS X. * Fixed up some of the ugliness in the docsrc tools. #------------------------------------------------------------------------ # Version 2.06b - 2nd December 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Added the Template::Plugin::Filter module to make plugin filters easier to write and rewrote the Template::Plugin::XML::Style to use it. * Added the Template::Plugin::String module which provides a nice object oriented approach to string manipulation. * Added the '_' string concatenation operator. [% foo = bar _ baz %] * Applied Craig's suggested fixes to the parser to correct potential precendence problems and added tests to the test suite. See: http://lists.tt2.org/pipermail/templates/2001-November/002138.html * Applied Leon's patch to Template::Service to delete the 'template' entry added to the variable hash at the end of processing. * Fixed an obscured bug/oversight in Template::Plugins which tested generated plugin objects for truth rather than definedness to see if the plugin returned was valid. This can cause problems if your object has an overloaded stringification operator which gets called (but shouldn't) and could return an untrue (but correct) value. * Fixed t/dumper.t to only have one entry in each hash to avoid hash ordering problems. Thanks to Randal for reporting the problem. * Added the assert() subroutine to Template::Test. * Added some more content to the FAQ. #------------------------------------------------------------------------ # Version 2.06a - 19th November 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Added the XML::Style plugin for doing simple XML stylesheet like transformations and t/xmlstyle.t. * Fixed a bug in the DBI plugin where nested loops could cause the inner query to overwrite the _STH of the outer query causing the outer loop to end prematurely. Thanks to Dave Hodgkinson, Craig Barratt and Simon Matthews for working on the problem and solution. For more info, see http://lists.tt2.org/pipermail/templates/2001-November/002067.html * Applied a patch from Aleksey Nogin to Makefile.PL to call bin/gifsplash with the '-i' option. This fixes the problem reported by Kenny Flegal: http://www.tt2.org/pipermail/templates/2001-November/002028.html * Applied a patch from Stas Bekman to add 'align' to template/html/row. #------------------------------------------------------------------------ # Version 2.06 - 7th Nov 2001 #------------------------------------------------------------------------ * Fixed a bug in t/compile5.t which caused the following test warning on Win32: "Cannot chdir to D/blah/blah/Template-Toolkit-2.05c/t/test: No such file or directory at t\compile5.t line 73". Thanks to Chris Winters for finding the bug and testing the fix. #------------------------------------------------------------------------ # Version 2.05d - 6th Nov 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed a bug in the parser which was missing a '^' anchor on the regex matching the TAGS directive, causing it to match anywhere. Thanks to Dominic Mitchell and Adrian Howard for reporting and fixing the problem. See http://lists.tt2.org/pipermail/templates/2001-October/001760.html * Modified Template::Parser to correctly handle "\t" and "\r" in double quoted strings as well as "\n". Added test to t/parser.t * Applied a patch from Stas Bekman to add 'valign' as an option to the html/cell template. * Applied a patch from Harald Joerg to document the 3rd $default option to Template::Stash::set(). * Fixed a problem in the docsrc build whereby double quote strings were causing embedded variables to be incorrectly interpolated, e.g. [% INCLUDE xyz title="set($var, $val, $default)" %] is now [% INCLUDE xyz title='set($var, $val, $default)' %]. Thanks to Harald Joerg for reporting the problem. #------------------------------------------------------------------------ # Version 2.05c - 22 Oct 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Applied a patch from Tony Payne which fixes a bug where templates were being mangled under mod_perl due to a missing O_TRUNC on a sysopen(). See http://www.tt2.org/pipermail/templates/2001-October/001834.html * Fixed the mess I made of Pudge's XS Stash patch applied in 2.05b. * Updated the INSTALL/README guides to note the PPM installation for Win32 users. #------------------------------------------------------------------------ # Version 2.05b - 21 Sep 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Applied a patch from Chris Nandor to bring the XS stash in line with the regular Perl stash wrt accepting defined but empty keys. See http://www.tt2.org/pipermail/templates/2001-September/001695.html * Applied a patch to Template::Provider from Craig Barratt to fix a bug when caching is turned off (CACHE_SIZE = 0). See http://www.tt2.org/pipermail/templates/2001-September/001682.html * Moved installation out of README into a separate INSTALL file and added the HACKING document as a pointer to the internals docs. * Added the 'uri' filter for URI escaping text. #------------------------------------------------------------------------ # Version 2.05a - 12 Sep 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Applied a patch from Chris Nandor to use 'MSWin32' as a specific O/S detection rather than /win/i which gives a false positive for 'Darwin'. Needless to say, that's something of an insult to Darwin :-). Also fixes Template::Provider to use File::Spec::file_name_is_absolute() to test for absolute paths instead of the previous kludge. * Updated Template::Manual::Internals to include information about how to prepare patches and other useful information for potential TT hackers. * Added some code to the XS Stash to handle trivial access to tied hashes. Regular set/get/default should work as expected, but at present intermediate hashes are not auto-vivified on assignment, e.g. [% these.dont.get.created.in.XS.but.do.in.the.perl.stash = 10 %] #------------------------------------------------------------------------ # Version 2.05 - 11 Sep 2001 #------------------------------------------------------------------------ * Bumped version number and updated documentation for release. #------------------------------------------------------------------------ # Version 2.04f - 10 Sep 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed a bug in the Date plugin which was performing one localtime() too many when a date was passed in to the format() method. e.g. the result from date.format('12:59::00 30/09/2001', '%H:%M') was 13:59 not 12:59. Thanks to Thierry-Michel Barral and Matthew Tuck for reporting the problem. * Incorporated Doug's new version of the XS Stash. It fixes the problem with strings not being recognized as integers (and the item = item + 1 problem). It also adds a few additional tests for this situation to t/stash-xs.t * Fixed a minor bug in Makefile.PL which looked for 'msql' or 'mysql' as the default DBD for testing DBI but didn't select a suitable default if the above drivers weren't available. #------------------------------------------------------------------------ # Version 2.04e - 06 Sep 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed bug in 'list' entry in $HASH_OPS in both Template/Stash.pm and Template/Stash/Context.pm to return '%$hash' instead of 'values %$hash'. Thanks to Craig Barrett for reporting the problem. * Applied a patch from Craig to Stash.pm and Stash/Context.pm to accept negative integers as array indices, counting back from the end of the list as in Perl. This brings it into line with the new XS Stash. http://www.tt2.org/pipermail/templates/2001-August/001493.html * And another patch from Craig to allow $var and ${var} to be used as keys in hashes. http://www.tt2.org/pipermail/templates/2001-August/001410.html * Modified Template::Plugins fetch() method to accept $factory as a code reference. Then changed _load() to return a closure for regular Perl modules loaded (via LOAD_PERL option) which, which called by fetch(), removes the first argument, the $context reference, which the non-plugin module won't be expecting. This fixes the problem reported (and also fixed but in a slightly different way) by Lyle Brooks, here in these messages: http://www.tt2.org/pipermail/templates/2001-August/001397.html http://www.tt2.org/pipermail/templates/2001-August/001406.html * Removed the eq, ne, gt, lt, ge and ne operators added in 2.04d. Given that they can (and did) break code that had existing variables with those names, I decided it was best to strip them out again and think more carefully about adding them to an official release. Hence they're not going to be in 2.05. * Fixed an outrageous oversight in the HTML 'rgb' template by defining 'orange' as a valid colour (I can't believe Leon hasn't already sent me a patch for this!) Created a new custom colour scheme in the Makefile.PL which uses it. Hacked the Makefile.PL and the generated ttree config file to allow text colours to be specified as well as button background colours. #------------------------------------------------------------------------ # Version 2.04d - 29 Aug 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Incorporated Doug Steinwand's XS Stash. This adds the files in the 'xs' directory, t/stash-xs.t, bin/tt-bench.pl and includes some work on the Makefile.PL to incorporate the required prompting, etc. * Added gt, ge, lt and le as comparison operators which map directly to their Perl counterparts. Added tests to t/stash.t and relevant documentation to the IF directive. * Applied some patches from Leon and Doug to enhance the coverage of the test suite. * Added 'sorted' as a flag to the HTML plugin to return attributes in sorted order. Mainly for debugging purposes, as used in t/html.t. * Fixed Template::Parser.pm to recognise "\r" as a valid escape sequence in double quoted strings. #------------------------------------------------------------------------ # Version 2.04c - 04 Aug 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed t/dbi.t and t/latex*.t to not complain about "Test header seen twice". Thanks to Leon. #------------------------------------------------------------------------ # Version 2.04b - 04 Aug 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Fixed a bug in the Makefile.PL which prevented the correct targets from being added to the generated Makefile to install additional components, build HTML docs, etc. * Applied a patch from Chris Nandor to fix a bug introduced by the taint checks in 2.04 which barfed on ';' in filenames. Also changes open() to sysopen() in Template::Document for additional security. See http://www.tt2.org/pipermail/templates/2001-August/001348.html * Another part of the same pudge patch adds FACTORY as a default value to Template::Parser to allow Template::Directive factory class to be replaced. #------------------------------------------------------------------------ # Version 2.04a - 5th July 2001 ## DEVELOPER RELEASE ## #------------------------------------------------------------------------ * Changed GD plugin and tests to require GD version 1.20. See http://www.tt2.org/pipermail/templates/2001-July/001212.html * Applied Craig's fix for the DBI plugin to correctly destroy a statement handle to ensure that finish() gets called on it even if the iterator doesn't complete. See: http://www.tt2.org/pipermail/templates/2001-July/001216.html * Further to Craig's points in the above post, I added get_all() and get() to the DBI iterator so that you can now do this: [% people = DBI.query(...) %] [% person = people.get %] # first person [% person = people.get %] # second person [% FOREACH person = people.get_all %] # third to nth person(s) [% END %] * Fixed Template::Provider which wasn't saving compiled templates to disk when specified with an absolute path, as reported by Merlyn. See http://www.template-toolkit.org/pipermail/templates/2001-July/001213.html * Updated Makefile.PL to accept various command line args including TT_ACCEPT to automatically accept all default values and TT_QUIET to shut the file up with all those yackety yack, yack messages. #------------------------------------------------------------------------ # Version 2.04 - 29th June 2001 #------------------------------------------------------------------------ * Applied a patch from Craig Barratt to both the regular Template::Stash and the alternate Template::Stash::Context which allows array indexes into hashes and arrays (slices) in the same manner as Perl. For example: [% keys = [ 'foo', 'bar' ] vals = hash.$keys # [ hash.foo, hash.bar ] keys = [ 2, 3, 7 ] vals = list.$keys # [ list.2, list.3, list.7 ] %] * Applied another patch from Craig to Parser.pm which fixes a bug relating to text strings being interpolated in a numerical context. See: http://www.tt2.org/pipermail/templates/2001-April/000901.html * Applied yet another patch from Craig ("Man of the Patch" for v2.04 :-), to fix a problem with NEXT not working inside switch: FOREACH and WHILE now get a LOOP: label, and NEXT and LAST now generate "next LOOP;" and "last LOOP;". However, the original code allows naked "NEXT" or "LAST" (which behave like STOP). I didn't want to change this behavior, so NEXT and LAST only get the LOOP label inside loops (except in the top-level atomexpr FOREACH and atomexpr WHILE cases, which should be ok). * Does he ever sleep! :-) Another patch from Craig to improve upon the ref->template mapping feature in Template::View. Documentation pending. For further details, see http://www.tt2.org/pipermail/templates/2001-June/001161.html * Applied a patch from Mark Fowler, which fixes the problem with search/replace virtual methods incorrectly returning with a search pattern of '0'. e.g. [% bob = '0'; bob.replace('0', 'zero') %] now returns 'zero' instead of ''. * Applied a patch from Doug Steinwand to prevent the Stash from raising undef error reporting 'Can't locate object methof "bar" via package "Foo"' unless $DEBUG is enabled. * Applied a patch to the DBI plugin from Rafael Kitover which calls the DBI connect_cached() method instead of connect() to allow connection caching in a persistent server environment (e.g. Apache mod_perl). * Changed html filter to be a dynamic filter factory, allowing the 'entity' option to be set to prevent entities of the form '&word;' being converted to '&word;' [% FILTER html(entity = 1) %] < & > # < & > [% END %] * Changed Template::Stash to propogate any object errors that are references (e.g. Template::Exception objects or otherwise) or string that don't look like "Can't locate object method ...". * Fixed various typos in docsrc/xml/ttdocsrc with a deft: s/Plugin::GD::Graphs/Plugin::GD::Graph/g; * Applied a patch from Leon Brocard to remove a suspect test from t/filter.t which Chris Nandor reported as causing problems. * Added Craig's comments on replace backreferences and TT grammar to TODO list. * Applied various patches from Leon: to remove redundant "print 1..0" in various t/*.t files; to add '1;' to end of '.defaults.cfg' file; and to fix t/vmeth.t and t/leak.t to run correctly under latest bleadperl. * Applied a patch from Jonas Liljegren to fix problems with errors being raised in -T taint mode. * Fixed another problem identified by Jonas so that filters are no longer cached. See: http://www.tt2.org/pipermail/templates/2001-June/001192.html #------------------------------------------------------------------------ # Version 2.03 - 15th June 2001 #------------------------------------------------------------------------ * Added new virtual methods 'item', 'list', 'hash' to each of scalar, list and hash ops to Do The Right Thing to convert the original value to what the caller wants. This is based on a patch supplied by Craig Barratt... * ...which implements a number of new features to the stash, most notably the ability to specify the context in which you want an object method or subroutine to be called in by appending '.list' or '.scalar' to a dotted variable. e.g. [% cgi.param('foo').scalar %]. I haven't folded this patch into the core Stash yet (other than adopting the virtual methods described above) but it's provided as an alternate stash implementation, Template::Stash::Context, which you can create and specify to your Template object via the STASH configuration option. I'd like to a) benchmark it and b) give people the option of trying it out (and hacking on it?) before integrating the new features into the default stash. * Applied a patch to add the Latex filter and GD plugin functionality, thanks to the excellent work of Craig Barratt and Richard Tietjen. In Craig's words: Here is a new version of my Latex filter and GD plugin code. (This adds a latex filter that supports PDF, PS and DVI output, plus 16 or so plugins for the GD::* modules, allowing PNG, GIF output.) [Includes] Richard Tietjen's changes for the latex filter for WinXX [which] didn't make it into the May 20th version. The new version includes the correct changes for WinXX and also now has been tested against TexLive and MikTeX on WinXX. Craig's patch also included full documentation so you can read all about it in the Manual and Module pages. In addition, the Makefile.PL now searches for GD modules and external Latex programs and does some extra user prompting for confirmation of Latex installation/configuration. Not only that, but Craig also managed to roll in a couple of other minor bug fixes and documention updates. Nice work! * Fixed the parser to accept fully dotted up variable assignments in argument lists, e.g. in INCLUDE, etc. You can now do this: [% INCLUDE html/head html.head.title = 'My Title' %] Note however that the assignment to such variables is always "global", even though INCLUDE claims to localise the stash. Remember that the localisation does not perform a deep copy so the localised copy of the 'html' variable might just be a copy of the reference to a previously defined hash array. Thus, you modify the original albeit via a copy of the reference to it. See INCLUDE section of Template::Manual::Directives for further details. * Added 'base' option to Template::View. This allows one view to inherit from another "base class" view. If a template isn't defined in a derived view then it automatically asks its base view for it, and so on up the inheritance tree. [% VIEW myview.default prefix = 'view/default/'; END %] [% VIEW myview.fancy base = myview.default prefix = 'view/fancy/'; END %] In this example, [% myview.fancy.header %] will be resolved as [% INCLUDE view/fancy/header %] or [% INCLUDE view/default/header %] if 'view/fancy/header' doesn't exist. Variables are also inherited. * Added the 'sealed' and 'silent' parameters to VIEW to allow view to be optionally unsealed (allow external variable updates/creation) and to silence warnings about attempts to update sealed variables, respectively. See the Template::Manual::Views page for more info on this and previosu item. * Added the HTML plugin for generating (very basic) HTML elements. See the Template::Plugin::HTML documentation. * Added the present() and content() methods to XML::DOM::Node in the XML::DOM plugin to make them work harmoniously with VIEWs. See the Template::Plugin::XML::DOM documentation for further details. * Did the same for Template::Plugin::XML::XPath, adding present($view) and content($view) methods to XML::XPath::Node::Element and a present($view) method to XML::XPath::Node::Text. See the Template::Plugin::XML::DOM documentation for more details. * Added the calc() method to the Date plugin to return an interface to the Date::Calc module. e.g. [% USE Date; calc = Date.calc %] [% calc.Monday_of_Week(22, 2001).join('/') %] * Moved Template::Tutorial to Template::Tutorial::Web and added the tutorial kindly donated by Dave Cross on generating and using data files with TT as Template::Tutorial::Datafile. Template::Tutorial is now an index to the tutorials. * Changed the bin/tt2inst script to no longer use the 'no_chdir' option of the File::Find module which isn't supported in earlier version such as distributed with pre-5.6.0 Perl. Thanks to a patch from Vivek Khera . Changed Makefile.PL to accept File::Spec version 0.6 or later. * Fixed a bug in the FOREACH directive which would barf with the error "undef error - loop is undefined" when DEBUG was enabled. * Applied a patch from Eric Cholet to fix a bug in META data items not correctly escaping ' and \ characters. * Applied another patch from Eric to fix "Use of uninitialised value" warning when using a subclassed parser. * Applied a patch to ttree from Leon Brocard print full path for ignored files. * Fixed typo in the ttree help page which incorrectly listed debug mode as '-d' (now '-dbg' as well as '--debug') * Fixed (hopefully once and for all!) the problem with choming the final newline in a template. The last newline is now chomped just like any other, depending on the POST_CHOMP flag and/or trailing '-' in the directive. e.g. [% FILTER latex('ps') %] ... [% END -%] If you explicitly want a newline then make sure one is added to the end of the template and don't enable POST_CHOMP or add a trailing '+' in the directive, e.g. [% INCLUDE footer +%] * Made a number of fixes to the HTML generated by the Splash! and HTML libraries to make it conformant with HTML 3.2 specificiation. Added DOCTYPE to html/header, ALT tags, ... added html/head, html/body and html/html to do more thorough job using nested variables. Also added html/config to load HTML plugin. Full conformance is still an issue, but we're working on it... #------------------------------------------------------------------------ # Version 2.02 - 6th April 2001 #------------------------------------------------------------------------ * Updated various components of the Splash! library, cleaned up some ugliness (a little) and revised the examples. Documentation in Template::Library::Splash is now hopelessly out of date but examples are more comprehensive. Makefile.PL now prompts user to select a colour scheme for creating the documentation and examples. * Fixed problems with Splash! images displaying the "wrong" colour on certain systems. It appears to be the case that this was automatic gamma correction at work, an otherwise very cool feature of PNG files. Alas it broke things here so we've switched to GIF files. Also made an improvement to the way of generating and using the images. By using simple transparency and doing away with the anti-aliasing it's possible to support any foreground colour for a set of images in a background colour. One set of black images are now distributed with TT. These are blown into many colours during installation, implemented by the bin/gifsplash script and defined as the 'tt2_splash' Makefile target, run automatically as part of 'make install'. * Changed redirect filter factory and the underlying Template::_output method to accept a 'binmode' flag. The bin/gifsplash script sets this flag to ensure that the GIFs generated for Splash! are valid on Win32 platforms (it's a good job SAM knows what binmode is for... :-) * Applied a patch from Leon Brocard to add 'recurse' and 'verbose' options to the ttree.cfg files generated by Makefile.PL. Their absence was preventing the docs and examples from being built (unless, like the stupid author, you already had a default ~/.ttreerc which included these flags :-). * Fixed Makefile.PL to check for File::Spec 0.82, thanks to the efforts of Doug Steinwand and Leon who found and fixed the problem with 'splitdir' otherwise not being available. Later changed requirement from 0.82 to 0.80 because this is the version currently distributed with ActivePerl 5.6.0 and it appears to work just fine (saves those poor Win32 users from having to install any more modules than absolutely necessary) * Removed test for platform specific error messages from t/xpath.t Removed warning from README that this test would fail. Thanks again to Leon for the patch and to (no name given) for reporting the problem. * Applied another patch from Leon to fix Template::Base.pm to avoid "Use of uninitialized value..." warnings. * Applied yet more patches from Leon to add "use Template::Plugin" or something similar to the File, Directory and View plugins. 'use base' doesn't work as advertised (e.g. in ensuring the module is loaded) in older versions of Perl. * Fixed t/leak.t to only run one particular test if Perl version is 5.6.0 or greater. Test fails on earlier versions due to destructors being called in a different order. * Updated Makefile.PL to supply a more typical default installation directory for Win32 systems - C:/Program File/Template Toolkit 2/. This brought to light numerous bugs (following) which were fixed with the invaluable help of Simon Matthews and Theakston's Black Sheep Ale... :-) * Pathnames generated in the Makefile.PL for the Makefile are now all "double quoted" to protect embedded whitespace, e.g. when building docs: ttree -f "C:/Program Files/...") * Patched Template/Provider.pm in several places to strip out any extra ':' characters put in the wrong place of a path. For example, when writing compiled template "C:/foo" to disk with a COMPILE_DIR of "C:/bar", the resulting file is now "C:/bar/C/foo" instead of the erroneous "C:/bar/C:/foo". * On Win32 systems, provider prefixes must be more than 1 character in length. This is a compromise for cases where you might want to do something like: [% INCLUDE C:/foo/bar %]. Remains unchanged on other platforms. * On Win32 systems the DELIMITER now defaults to a slight variation of ':' if not otherwise set. It now uses /:(?!\/)/ to split on ':' where not followed by '/'. This makes things like INCLUDE_PATH => 'C:/here:C:/there' work properly, although setting a more suitable DELIMITER for Win32 systems (e.g. ';') is still recommended (we tried automatically setting it to ';' on Win32, but that caused more problems than it was worth). * Changed Template::Provider to consider a file starting (\w:)?/ as an ABSOLUTE path when running on Win32 (e.g. C:/foo). On other platforms, it remains unchanged, looking only for a leading '/'. Also changed ttree to do the same, so that 'ttree -f C:/test.cfg' is treated as an absolute path and it doesn't try and prefix it with the ttree configuration file directory. Note that ttree does this regardless of OS. * Fixed stringification problem identified by SAM. Objects that have auto-stringification sometimes didn't get properly stringified at the right time. e.g. [% a = "$an_obj" %]. * Fixed File and Directory plugins to gracefully ignore Perl dying with "getpwuid() not supported on this platform" errors on Win32. The 'uid' and 'user' attributes of File and Directory plugin objects are left undefined. * Then, hacked t/file.t and t/directry.t test to not be run under Win32. There are a couple of outstanding minor problems with these test scripts caused by differences in '/' and '\' as path separators. Need to fix these at some point. * Makefile.PL now saves configuration options in '.defaults.cfg' file, using these values as defaults when run again. * Removed duplicated $VERSION from DBI and XML::DOM plugins, thanks to Jonathan Leffler. * Updated documentation to reflect new changes. #------------------------------------------------------------------------ # Version 2.01 - 30th March 2001 #------------------------------------------------------------------------ * Added the various template libraries in the 'templates' directory. The 'html' library implements some generally useful HTML elements. The 'pod/html' libraray contains some templates for converting POD to HTML, used in building the TT2 HTML documentation, for example. The 'ps' library contains templates defining a few useful marks and other procedures for generating PostScript pages. The 'splash' directory contains templates for the "Splash!" library which implements a widget set for building stylish HTML user interfaces. * Added a host of example pages in the 'examples' directory which demonstrate use of the above libraries. * Added an 'images' directory to contain the small images used to build up the Splash! interface components. * Added the 'docs' directory containing templates and library elements for building the TT2 documentation as HTML pages. * Updated Makefile.PL to now offer to install optional libraries, images, build HTML docs, examples, etc. Adds 'tt2_install', 'tt2_html_docs' and 'tt2_examples' as Makefile targets if requested. These then get run as part of "make install". * Totally re-organised the documentation, splitting the long user manual into separate Template::Manual::* pages, adding the Template::FAQ, Template::Internals, and various other changes. All POD and HTML documentation is built from the same sources in the form of another set of templates, POD files, XML files, scripts, etc., distributed separately as the 'docsrc' bundle, and available from the web site. The POD documentation now gets glued onto the end of the .pm modules and only creates separate .pod files for those manual pages that don't have equivalent modules (e.g. Template::FAQ, etc.) NOTE: this might mean that existing .pod files from earlier versions of TT might mask documentation in newer .pm files... * Added the Template::View module, the VIEW directive and the View plugin which can be used collectively to create dynamic views. This is a very powerful tool which fulfills a number of requirements and makes possible a number of things that have previously been messy, difficult or not possible. Views are primarily collections of templates. You can define BLOCKs within a view and they remain local to it, but can be called from outside the view. This is still very experimental. Things are likely to change. See Template::Views for (incomplete) documentation and take a look at t/view.t for examples. [% VIEW fancy_html prefix = 'splash/' # template prefix/suffix suffix = '.tt2' bgcol = '#ffffff' # and any other variables you style = 'Fancy HTML' # care to define as view metadata, items = [ foo, bar.baz ] # including complex data and foo = bar ? baz : x.y.z # expressions %] [% BLOCK header %] # define "private" view blocks Title: [% title %] [% END %] [% END %] # end of VIEW definition [% v = fancy_html %] # view is a regular object ref, re- [% mycode(v) %] # assign it, pass it around, etc. [% v.title %] # access view metadata [% v.header(title = 'Foo!') %] # view "methods" process blocks or [% v.footer %] # templates with prefix/suffix added # => [% INCLUDE splash/footer.tt2 %] * Added the facility to specify multiple templates within a PROCESS, INCLUDE, INSERT or WRAPPER directive. For all but WRAPPER, the templates are processed in the order specified. [% PROCESS config + header + menu %] [% INCLUDE section/break + html/titlebar title='A New Section' %] [% WRAPPER edge + box + titlebar %] ... [% END %] Multiple WRAPPER templates get processed in reverse order to create the correct nesting effect. In the example above, the enclosed block is processed and passed to 'titlebar' which wraps it and passes the output to 'header' which wraps it and passes the output to 'box', which wraps it and passes the output to 'edge' which wraps it and returns the output. Thus the specification order is outermost to innermost, but they are actually processed from the inside out. * Templates specified to INCLUDE, PROCESS, WRAPPER and INSERT can now be given a prefix (delimited by ':', as in "file:blahblah.txt" or "http://www.tt2.org/index.html", for example) which maps them to a particular template provider or providers. A PREFIX_MAP configuration option can be specified as a hash array mapping prefix names to a reference to a list of providers. For convenience, you can also specify the argument as a string of integers, delimited by any non-numerical sequence, to indicate indices into the LOAD_TEMPLATES provider list. e.g. my $template = Template->new({ LOAD_TEMPLATES => [ $foo, $bar, $baz, $wiz ], PREFIX_MAP => { src => '0, 2', # $foo and $baz lib => '1, 2', # $bar and $baz all => '0, 1, 2', # $foo, $bar and $baz } }); Thus [% INCLUDE src:hello.tt2 %] indicates the 'hello.tt2' template to be provided by $foo or $baz, [% INCLUDE lib:hello.tt2 %] is mapped to $bar and $baz, [% INCLUDE all:hello.tt2 %] can be provided by $foo, $bar or $baz, and the default [% INCLUDE hello.tt2 %] is mapped to the entire LOAD_TEMPLATES list: $foo, $bar, $baz and $wiz. This is initially useful for things like ttree which would like a way to differentiate between templates in one place and templates in another. It can also be used, of course, to provider special providers for certain file type, as in http://fetch.some.file.com/blah/blah/... * Fixed the parser to accept expressions on the right hand side of parameter definitions for INCLUDE, etc. e.g. [% INCLUDE header title = my_title or your_title or default_title bgcol = (style == 'dark' ? '#000000' : '#ffffff') %] * Added the PLUGIN_FACTORY configuration option to Template::Plugins to allow class names or object prototypes to be specified for plugins. No module loading is attempted, unlike the existing PLUGINS which assumes entries are module names which it tries to load. This may change in a future release (ideally by integration with PLUGINS) so it remains undocumented for now. package My::Plugin; ... package main; my $tt = Template->new({ PLUGIN_FACTORY => { plugin1 => 'My::Plugin', # class name plugin2 => My::Plugin->new(), # prototype obj }, }); * Added the File and Directory plugins which blossomed from the Directory plugin written by Michael Stevens and posted to the mailing list. These give you access to files and directories on your filesystem and also allow you to create representations of abstract files/dirs. WARNING: recognise that this gives the author of any templates you run access to information about your filesystem. We assume that the author of your templates is you or someone you trust to have access to that kind of information. If you're running "untrusted" templates (we assume you know what you're doing) then you'll very probably want to disable these plugins. Alas there is no easy way to disable plugins at the moment other than deleting them or writing null or error throwing plugins to mask them. Making this easier is a TODO. * Added the Pod plugin which uses the Pod::POM module to parse a Pod file or text string and build an object model. You can then walk it and present it in different ways using templates. Great for building HTML documentation from Pod and unsurprisingly used to build the new TT2 docs. * Applied a patch from Chris Nandor to add a new feature to the PRE_CHOMP and POST_CHOMP options. When set to 1, they continue to act as before. When set to 2, all whitespace is collapsed into a single space. CHOMP_NONE, CHOMP_ALL and CHOMP_COLLAPSE are defined in Template::Constants and can be imported as the :chomp tagset, for those who want them. * Applied a patch from Doug Steinwand to fix a problem in Template::Provider which would server stale templates if the modification time of the files went backwards. In addition, it now uses the $Template::Provider::STAT_TTL (time to live) variable (default: 1) to determine how often to stat the files to check for changes. TT2 now supports time running backwards! :-) * Applied a patch from Vivek Khera which fixes a memory leak in the MACRO directive, prevalent when using TT under mod_perl. Also added t/leak.t to test that memory is properly freed and circular references broken by the delocalisation of the stash. All seems to work as expected including plugins that contain context references, MACRO definitions, and so on (but note that this is the test suite run from the command line, and doesn't explicitly test under mod_perl...) * Applied a patch from Axel Gerstmair to fix a bug in PERL blocks and filters which caused references to the context and stash to be kept in global package variables. This meant they stayed alive for far too long. Added a couple of tests to t/leak.t to check this now works OK. * Fixed a bug in the parser triggered by [% CATCH DEFAULT %]. Thanks to Vivek Khera for reporting the problem. This also fixes a problem reported by Thierry-Michel Barral which was causing bare 'CATCH' blocks to not catch errors and instead pollute STDERR. * Fixed another bug in the parser preventing double quoted META attributes from containing single quotes, e.g. [% META title="C'est un test" %]. Thanks to Philippe Bruhat for reporting the problem. * Added the 'indent' filter to indent a block by prefixing each line with a specified string, or a number of spaces when the argument is numerical. * Added the 'trim' filter to remove leading/trailing whitespace and 'collapse' filter to additionally collapse multiple whitespace characters to a single space. * Added escapes for ' (') and " (") to the html filter, thanks to Lyle Brooks and Vivek Khera. Then, having done that, I removed the ' escape because my browser didn't recognise ' as a valid entity. What's going on here? Need to check the HTML spec... * Added tag style 'star' of the form [* ... *] * Changed the Template::Stash get() and set() methods to accept a compound variables as a single parameter and automatically convert it to an array. Note that it doesn't correctly handle arguments to dotted elements (e.g. foo(10).bar(20), but does mean that you can now write $stash->get('foo.bar.baz') instead of the more laborious $stash->get(['foo', 0, 'bar', 0, 'baz', 0]). * Fixed a bug in Template::Stash which was raising an error when an element on the left hand side of a '.' evaluated to a defined, but empty value. * Fixed an obscure bug in Template::Stash which occurred when calling a scalar method on a value which contained a valid and visible object package name. e.g. [% name = 'Foo::Bar'; name.baz() %] called Foo::Bar->baz(). * Fixed a bug in the Template::Stash 'replace' virtual method which returned the original string when the replace string was specified empty. [% var = 'foo99'; var.replace('foo', '') %] now correctly returns '99' instead of the original string 'foo99'. Thanks to Tryggve Johannesson and Jeremy Wadsack for reporting the problem. * Added magical handling of the 'import' variable to stash clone() and update methods. This implements the V1 functionality whereby you can write [% INCLUDE foo import=myhash %]. Note that 'import' is lower case, (V1 was upper case IMPORT) as in V2 it is in keeping with the virtual hash method (e.g. same as myhash.import(another.hash)). Thanks to Brian Cooper for raising the issue. * Yet another change to Template::Stash. Objects which are blessed arrays will now honour virtual array methods if the object doesn't otherwise implement a particular method. For example, you can now write [% USE Datafile(...) %] and then [% Datafile.size %]. The '.size' now works as virtual method on the blessed ARRAY which consitutes the Datafile object. Thanks to Keith Murphy for identifying the problem. * Fixed another obscure bug, this time in Template::Parser which wasn't chomping the final newline in the input string. Thanks to Paul Makepeace for reporting the problem. * Finally identified the cause of an error occasionally being reported by Template::Service when is thrown a non-reference exception. It appears to be a problem interacting with CGI::Carp. For now, it's fixed and tolerated in Template::Service (but could possibly do with a better long term solution?). Thanks to Jo Walsh, Trond Michelson, and I'm sure several others who reported this and helped to track the problem down (and also fixing the confess() bug I introduced when I added the tracer code. D'Oh!) * Removed some old "delegate-to-another-object" code from Template::Plugin, including a nasty AUTOLOAD method which prevented derived objects from acting as transparent hashes. If delegative functionality is required then it should be implemented as Template::Plugin::Delegate (and may well be in the fullness of time). * Fixed a whole bunch of typos and spellos thanks to patches from Leon, Paul Sharpe and Robert McArthur. #------------------------------------------------------------------------ # Version 2.00 1st December 2000 #------------------------------------------------------------------------ * Added the repeat(n), search(pattern) and replace(search, replace) virtual methods for scalars, and fixed a warning in the split() method raised when an attempt was made to split an undefined value. * Changed the THROW directive to accept multiple parameters which become named items of the 'error.info' item, thanks to a suggestion from Piers Cawley. Positional arguments can be addressed as [% error.info.n %] or as a list as [% error.info.args %]. Named parameters can be accessed as [% error.info.name %]. e.g. [% TRY %] [% THROW foo 'one' 2 three=3.14 %], [% CATCH %] [% error.type %] # foo [% error.info.0 %] # one [% error.info.1 %] # 2 [% error.info.three %] # 3.14 [% END %] * Moved the definition of Template::TieString from Template::Directive into Template::Config (for now) to ensure that its definition is visible even if the Template::Parser, and through it, the Template::Directive module, haven't been loaded. This fixes the bug causing the error "Can't locate object method "TIEHANDLE" via package Template::String..." raised when using EVAL_PERL with compiled templates only. In this case, the parser wasn't getting loaded (because it had no templates to parse, them all being pre- compiled) and the Template::TieString defintion wasn't visible to the EVAL_PERL blocks that require it. Added a test to t/compile3.t. Thanks to Igor Vylusko for reporting the problem. * Changed the Template::Directive Perl generator for EVAL_PERL blocks to generate code to first test the EVAL_PERL option in the runtime context and throw a 'perl error - EVAL_PERL not set' exception if unset. Thus the behaviour for EVAL_PERL when using compiled templates is now: if the EVAL_PERL option isn't set in the _compiling_ context, then Perl code will be generated which *always* throws an exception 'perl error - EVAL_PERL not set'. If EVAL_PERL is set, then it will generate code which tests the EVAL_PERL option in the _running_ context (which may not be the same context that compiled it), and throws the same error is the option is not set. Note that [% RAWPERL %] blocks are added verbatim to the generated code if the EVAL_PERL option is set in the compiling context and no runtime check for EVAL_PERL is made. Similarly, [% PERL %] blocks could contain a Perl BEGIN block, e.g. "BEGIN { # subterfuge code here }" which will always get executed at runtime, regardless of any runtime EVAL_PERL option. Thanks to Randal Schwartz for raising this issue. * Fixed an obscure bug in WRAPPER which was causing some variables to have apparently strange values when within the block content. This was due to the content being formed into a closure which was called from within the WRAPPER template, possibly after some variable values had been changed. e.g. [% title = "foo" %] [% WRAPPER outer title="bar" %] The title is [% title %] [% END %] Here, the 'outer' template should be called with a 'title' value of 'bar' but with 'content' set to 'The title is foo'. Previously, the content would have been processed from within the 'outer' template, resulting in a 'content' value of 'The title is bar'. The behaviour is now correct. * Filter failures are now raised as 'filter' exception types, instead of 'undef'. * Applied a patch from Simon Matthews to fix some minor bugs in the DBI plugin: - Added _connect method to Plugin::DBI for backwards compatability with code from version 1 of Template that subclassed the plugin - Changed the new mothod on the DBI plugin so that it checks to see if it is being called by a subclassed object. - Fixed the return value in the DBI plugin when connect is called more than once in the lifetime of the plugin * Removed a dubious looking chomp() from Template::Plugins which may have caused abject stringification of any error object throw by a failed plugin constructor. Thanks to Piers Cawley for finding the devious culprit. * Changed ttree to not offer to create a ~/.ttreerc file if it doesn't exist when the user has specified a '-f file' on the command line. Thanks to Michael Stevens for raising the issue. * Added the match($result, $expect) subroutine to Template::Test. * Modified the final test of wrap.t to strip any trailing whitespace from the output due to a problem with Text::Wrap under 5.005_02. Thanks to Rob Stone for reporting the problem. * Added documentation for DEBUG options and stderr filter. Thanks to Piers Cawley for spotting the omission. #------------------------------------------------------------------------ # Version 2.00-rc2 14th November 2000 #------------------------------------------------------------------------ * Added the 'prev' and 'next' methods to Template::Iterator and Template::Plugin::DBI::Iterator to return the previous and next items from the data set. * Added the 'sort' and 'nsort' virtual methods for hash arrays, thanks to a patch provided by Leon Brocard. * Various fixes to DBI plugin, configuration and test:- modified Makefile.PL to prompt for DBI DSN specific to user's DBD; changed DBI plugin to accept DBI attributes (e.g. ChopBlanks) as named parameters to connect method; fixed t/dbi.t to not munge 'user' variable in final test; added 'ChopBlanks' attributes to satisfy tests under certain DBD's (e.g. Pg). Thanks to Jonas Liljegren and Chris Nandor for their efforts in finding, testing and fixing the problems. * Modified the XML::DOM plugin to work with XML::DOM version 1.27 which now uses blessed array references instead of hashes as the underlying data types. Changed Makefile.PL and t/dom.t to require version 1.27 or later. * Changed the Template::Iterator module to *NOT* automatically expand the contents of blessed ARRAY objects to construct the iteration data set. The previous behaviour caused problems with modules such as XML::DOM where a single object passed to the iterator constructor would be expanded into a list of the member data, rather than being treated as a single item list containing that one object. A blessed ARRAY reference can now provide the as_list() method which the iterator constructor will call to return list data. * Fixed a bug in Template::Provider to ensure that template metadata (e.g. name, modtime, etc.) is written to compiled template files. Thanks to Steven Hetland for reporting the problem. * Changed the Template::Directive::template() generator method to raise an error if a context reference isn't passed to a template subroutine as the first argument. * Fixed t/autoformat.t to use locale dependant numerical formatting. Note that versions of Perl prior to 5.6.0 still have problems and will cause t/autoform.t tests 23 and 25 to fail under locales that use a decimal separator other than '.'. The Makefile.PL will issue a warning in such cases. Thanks to Jonas Liljegren for reporting the problem. * Applied a patch from Leon Brocard which corrects the behaviour of the URL plugin to join parameters with '&' instead of '&'. * Fixed a bug in the AUTOLOAD method of the Template::Plugin base class which caused warnings about not finding _DELEGATE pseudo-hash method under Perl 5.6.0. * Various minor documentation fixes, thanks to Henrik Edlund and Leon Brocard. #------------------------------------------------------------------------ # Version 2.00-rc1 1st November 2000 #------------------------------------------------------------------------ * Added the push(), pop(), unshift() and shift() virtual list methods and fixed the parser to allow empty lists to be created (also fixed the parser to prevent warnings being raised by empty hashes). Updated test scripts and documentation to include examples. Thanks to Stas Beckman for raising the issue. * Incorporated the DBI plugin module, written by Simon Matthews. This features a major reorganisation of the code, fixes a few bugs, removes some lava flow, and has improved documentation and test script. * Updated the Makefile.PL to prompt for DBI test parameters, check for external modules (and in particular, versions which may cause problems) and various other niceties. Also updated the README and TODO files. * Rewrote the XML::DOM plugin, fixing the memory leakage problems and adding the toTemplate() method and friends, as provided by Simon Matthews. Note that it's quite easy to send Perl into a deep recursive loop via the childrenToTemplate() and allChildrenToTemplate() methods due to a misfeature added by abw. This will be fixed in a future release and may result in behavioural changes to the *children* methods, so don't rely on them too heavily for now. * Incorporated the Dumper plugin from Simon Matthews which interfaces to the Data::Dumper module. * Fixed a bug in the Datafile plugin which was causing the last data field to be ignored. Credit due (yet again!) to Simon Matthews for finding the missing chomp(). * Fixed a bug in Template::Directive which was generating a 'Useless use of scalar ref constructor in void context...' for empty BLOCK definitions. * Added the Wrap and Autoformat plugins which interface to Text::Wrap and Text::Autoformat respectively. Thanks to Robert McArthur for the original Autoformat plugin code. * Added the XML::XPath plugin, test script and documentation. * Fixed a bug in the Template::Service module which was using any non-word characters to delimit lists of PRE/POST_PROCESS files. A value such as 'config, header.html' would be interpreted as [ 'config', 'header', 'html' ]. It now uses the DELIMITER value which is ':' by default, e.g. PRE_PROCESS => 'config:header.html' is interpreted as [ 'config', 'header.html' ]. * Fixed a bug in the parser grammar which was failing to correctly identify compound variables that contained two or more consecutive numbers. For example, the variable [% pi.3.14 %] was being interpreted as 'pi' . '3.14', instead of 'pi' . '3' . '14'. * Further modified parser to accept single quoted BLOCK names that would otherwise choke on 'illegal' characters. e.g. [% BLOCK 'foo bar' %] * Changed the Template::Context::template() method to always throw an exception when a template can't be found instead of simply setting an internal error string. Modified other Template::Context and Template::Service methods to expect this behaviour and act accordingly. The visible impact of this is that the Template error() method will now always return an exception object. Previously there were certain cases where a plain error string would have been returned. * Change the ROOT_OPS, SCALAR_OPS, HASH_OPS and LIST_OPS virtual method tables in Template::Stash to incorporate any existing defined values. Previously, you had to 'use Template::Stash' before defining any new virtual methods to prevent them being overwritten when Template::Stash was subsequently loaded. Thanks to Chris Nandor for identifying the problem and suggesting a fix. * Changed BREAK directive to LAST to keep it in line with Perl (don't know why I originally chose 'BREAK' - must have had my C head on at the time). BREAK is still supported as an alias for LAST. * Renamed the Template::Iterator number() method to count(), although number() is still supported for backwards compatability. The DBI plugin used count() instead of number() (an oversight, I think) but I decided that count() was the better name (shorter and more obvious). Also changed internal Template::Iterator counter variables to UPPER CASE to allow AUTOLOAD to be more easily reused by derived iterators such as the one for the DBI plugin. * The Template::Plugin module is now derived from Template::Base. The only significant ramification of this is that plugins should now call the error() method on failure in preference to fail(). The fail() method is still supported and delegates on to error(), but it raises a deprecation warning. * Fixed a bug in the Table plugin which caused an "undefined variable..." warning to be emitted when an empty list was provided. * Renamed 'evalperl' filter to 'perl', something that previously couldn't be done (before ANYCASE) due to 'perl' clashing with 'PERL' reserved word. 'evalperl' is still provided for backwards compatability. Also added 'evaltt' as an alias for the 'eval' filter and 'file' as an alias for 'redirect' (which I claimed to have done back in beta 3 but obviously hadn't). * Fixed a bug in the perl/evalperl filter which was causing a stash reference to be bound in a closure that could later become invalidated. This could lead to variables not getting/setting their correct values in subsequent calls to the same filter. * Documented the problem identified by Chris Winters where an IF used as a side-effect to an implied SET directive doesn't behave as expected. A directive of the form [% foo = 'bar' IF condition %] should be written explicitly as [% SET foo = 'bar' IF condition %] * Documented the 32k size limit (or typically less) for templates when the INTERPOLATE option is set. #------------------------------------------------------------------------ # Version 2.00 beta 5 14th September 2000 #------------------------------------------------------------------------ * Added define_filter($name, \&filter, $is_dynamic) method to Template::Context to allow additional filters to be defined at any time. Arguments are as per the FILTERS configuration option. These filters persist for the lifetime of the processor. * Changed the Template::Context filter() method to accept a code reference as the filter name and use it as the filter sub. This allows filters to be bound to template variables which are then used as: [% FILTER $myfilter %] There is one catch, however. TT will automatically call a subroutine bound to a variable when evaluated. Thus you must wrap your filter sub in another sub: $stash->set('foo', sub { \&myfilter }); or bless it into some class (any class) to fool TT into thinking it's not a subroutine ref: $stash->set('bar', bless \&myfilter, 'any_old_name'); * Updated documentation for FILTER directive and FILTERS option to reflect the above changes. * Fixed Template::Document to run cleanly with taint checking enabled. Unfortunately, this has been achieved by blindly untainting the generated template Perl code before calling eval(). Given that we're reading template source from external files, I don't think there's any way to do reliable taint check anyway. But thankfully we can trust the parser to generate "safe" code unless EVAL_PERL is enabled in which case all bets are off anyway. * Updated XML::DOM plugin to include changes made by Thierry-Michel Barral to accept configuration options for XML::Parser. * Fixed a bug in the Table plugin which caused the first item to be repeated n times when n items was less than a specified number of columns. Thanks to Andrew Williams for finding and fixing this bug. * The Template::Tutorial document really is included in the distribution this time. Honest. #------------------------------------------------------------------------ # Version 2.00 beta 4 12th September 2000 #------------------------------------------------------------------------ * Added the PROCESS config option which allows a template or templates to be specified which is/are processed instead of the template passed as an argument to the Template process() method. The original template is available as the 'template' variable and can be processed by calling INCLUDE or PROCESS as [% INCLUDE $template %]. * Changed what was the CASE option to now be enabled by default, and then changed the name of the option to ANYCASE to make it more obvious as to what it did. You must now specify directive keywords (INCLUDE, FOREACH, IF, etc) in UPPER CASE only, or enable the ANYCASE option to revert to the previous behaviour of recognising keywords in any case. With the increase in reserved words in version 2, there is more chance of collision with variable names. It's a real pain not being able to have a variable called 'next', an exception called 'perl', etc., because there's a reserved word of the same name. Thus, keywords are now UPPER CASE only by default, neatly side-stepping the problem. * Changed the PERL directive so that output is generated by calling print() instead of using the final value in the block. Implemented by tying STDOUT to an output buffer based on a patch sent in by Chuck Adams. new: old: [% PERL %] [% PERL %] print "foo\n"; my $output = "foo\n"; ... ... print "bar\n"; $output .= "bar\n"; [% END %] $output; [% END %] * The IMPORT directive and magical IMPORT variable have been replaced with a general purpose virtual hash method, import(). [% hash1.import(hash2) %] # was "hash1.IMPORT = hash2" [% import(hash1) %] # was "IMPORT hash1" or "IMPORT = hash1" * Modified the Template::Filters provider to examine the FILTERS package hash reference (changed name from STD_FILTERS) each time a filter is requested rather than copying them at construction time. This allows new filters to be added on-the-fly. See t/filter.t for examples and Template::Filters for more info. * Added the 'nsort' list method which sorts items using a numerical value sort rather than an alpha sort. [% data = [ 1, 5, 10, 11 ] %] [% data.sort.join(', ') %] # 1, 10, 11, 5 [% data.nsort.join(', ') %] # 1, 5, 10, 11 * Added 'div' operator to provider integer division (e.g. 'a div b' => 'int(a / b)' and 'mod' which is identical to '%' but added for backwards compatibility with V1. * Changed the (undocumented) FORNEXT directive to NEXT and documented it. * Fixed a bug in the persistent caching mechanism in Template::Provider which was failing to write compiled template files for source templates specifed in the form [% INCLUDE foo/bar %]. Intermediate directories (like 'foo' in this example) weren't being created and the disk write was failing. Thanks to Simon Matthews for identifying this problem. * Fixed an obscure bug in the Template::Stash which was ignoring the last element in a compound variable when followed by an empty argument list. e.g. [% cgi.param() %] would be treated as [% cgi %]. Also fixed the DEBUG option so that undefined variables cause 'undef' exceptions to be raised. Thanks to Jonas Liljegren for reporting the problems. * Added the reference operator, '\' which allows a "reference" to another variable to be taken. The implementation creates a closure around the referenced variable which, when called, will return the actual variable value. It is really a form of lazy evaluation, rather than genuine reference taking, but it looks and smells almost the same. Primarily, it is useful for allowing sub-routine references to be passed to another sub-routine. This is currently undocumented because I'm not sure about the validity of adding it, but see t/refs.t for examples for now. * Changed parser to automatically unescape any escaped characters in double quoted strings except for \n and \$. This permits strings to be constructed that include tag characters. e.g. [% directive = "[\% INSERT thing %\]" %] * Fixed a bug in the use of the 'component' variable when the current component is a sub-routine rather than a Template::Document. * Added the '--define var=val' option to tpage to allow template variables to be defined from the command line. Added support to ttree for various new Template configuration options. * Added $Template::Test::PRESERVE package variable which can be set to prevent newlines in test output from being automatically mangled to literal '\n'. * Completed and corrected all knows bugs in the documentation which now weighs in at around 100 pages for the Template.pm module alone. The POD documentation should now be installed by default. The Template::Tutorial document is once again included in the distribution. #------------------------------------------------------------------------ # Version 2.00 beta 3 10th August 2000 #------------------------------------------------------------------------ * Added the WRAPPER directive to include another template, passing the enclosing block as the 'content' variable. e.g. somefile: mytable: [% WRAPPER mytable %] blah blah blah [% content %] [% END %]
This is equivalent to: [% content = BLOCK %] blah blah blah [% END %] [% INCLUDE mytable %] * Added the [% INSERT file %] directive to insert the contents of a disk file without processing any of the content. Looks for the file in the INCLUDE_PATH and honours the ABSOLUTE and RELATIVE flags. Added the insert($file) method to Template::Context which calls the new load($file) method in Template::Provider which loads the file text without compiling it. * Added the DEFAULT configuration option which allows you to specify a default template which should be used whenever a named template cannot be found. This is ignored for templates specified with absolute or relative filenames, or as references to an input filehandle or text. * Added a FORNEXT directive to step on to the next iteration of a FOREACH loop, as suggested/requested by Jo Ellen Wisnosky. I chose FORNEXT rather than simply NEXT because 'next' is a very common variable name but I'm open to better suggestions. Perhaps CASE should be set by default to prevent variable conflict? This might change. * Reorganised the Template::Filters modules and changed the calling convention for requesting filters via the fetch() method. This now expects a reference to the calling Template::Context object as the third parameter (after filter name and reference to a list of arguments). Static filter sub-routines are returned as before and the context has no effect. Dynamic filter factories (denoted by a $is_dynamic flag in the FILTER_FACTORY table) are called to create a filter sub-routine (closure) for each request. The context is now passed as the first parameter, followed by the expansion of any arguments. Filter factories should return a sub-routine or (undef, $error) on error. * Added several new filters: - 'stderr' prints the output to STDERR (i.e. for generating output in the Apache logfile, for example). e.g. [% message | stderr %] - 'file' is the equivalent of the version 1 redirect() filter which writes the output to a new file, relative to OUTPUT_PATH. Throws a 'file' exception if OUTPUT_PATH is not set. There should perhaps be some other way to disable this without relying on OUTPUT_PATH. - 'eval' evaluates the input as a template and processes it. Proposed by Simon Matthews for times when you might be returning templates fragments from a database, for example. e.g. [% dirtext | eval %] - 'evalperl' evaluate the input as Perl code, as suggested by Jonas Liligren. Requires the EVAL_PERL option to be set and will throw a 'perl' error if not (see later item). e.g. [% perlcode | evalperl %] * Fixed a bug in Template::Provider which was mangling the metadata items for the template name and modification time. The [% template.name %] and [% template.modtime %] variables now work as expected. * Added 'component' variable, similar to 'template', but which references the current template component file or block, rather than the top-level template. Of course, these may be one and the same if you're not nesting any templates. * Template::Provider now reports errors raised when re-compiling modified templates rather than ignoring them, thanks to a patch from Perrin Harkins. * Fixed Template::Context to recognise the RECURSION option once more, thanks to a patch from Rafael Kitover. * Overloaded "" stringification of Template::Exception to call as_string(), again thanks to Rafael. In a catch block you can now simply say [% error %] as well as the more explicit [% error.type %] and/or [% error.info %]. * Changed Template module (via Template::Service) to return the exception raised rather than a pre-stringified form. This allows you to test the type() and/or info() if you want, or just print it and rely on the automatic stringification mentioned above to format it as expected. Note that the top-level process($file) method returns a string rather than an exception if $file can't be found. This is a bug, or a possible "gotcha" at the very least, and should get fixed some time soon. For now, test that the error is a reference before attempting to call info() or type(). * Fixed a bug preventing literal newlines from being used in strings. Thanks to Simon Matthews for bringing it to my attention by calling my hotel room at the Perl Conference and saying "Hello? Is that the Template Toolkit Helpdesk? I have a bug to report..." :-) (I fixed it on his laptop a few minutes later - good service, eh?) * Changed Template::Parser to not compile PERL or RAWPERL blocks if EVAL_PERL is not set. Previously they were compiled but switched out at runtime. This was erroneous as rogue BEGIN { } blocks could still be executed, as noted by Randal Schwartz. Any PERL or RAWPERL blocks encountered when EVAL_PERL is disabled will now cause a 'perl' exception to be thrown. * Added a define_block($name, $block) option to Template::Context to add a definition to the local BLOCKS cache. $block can be a reference to a template sub-routine or Template::Document object or template text which is first compiled. * Any other errors thrown in a PERL blocks (assuming EVAL_PERL set) are now left unchanged. Previously, these were converted to 'perl' exceptions which prevented exceptions of other kinds being throw from within Perl code. * Applied a patch from Chris Dean to fix a bug in the list 'sort' method which was converting a single element list into a hash. The sort now does nothing unless there's > 1 elements in the list. * Changed Template::Stash set() method to append the assigned value to the end of any arguments specified, rather than prepending it to the front. e.g. The foo() method called by [% myobj.foo(x, y) = z %] now receives arguments as foo(x, y, z) instead of foo(z, x, y). * Changed Template::Base::error() to accept a reference (e.g. exception) as the first parameter. In this case, no attempt is made to concatenate (and thereby stringify) the arguments. * Added a direct stash() accessor method to Template::Context rather than relying on the slower AUTOLOAD method. * Added an iterator() method to Template::Config to require Template::Iterator and instantiate an iterator, and changed generated code for FOREACH to call this factory method. This fixes a bug with pre-compiled (i.e persistent) templates which were failing if Template::Iterator wasn't already loaded. Thanks to Doug Steinwand, Rafael Kitover and Jonas Lilegren who all identified the problem and hounded me until I fixed it. :-) * Fixed a problem with persistent templates not being reloaded due to the %INC hash. This caused 1 to be returned from require() instead of the compiled template. * Added ABSOLUTE and RELATIVE options to tpage by default. * Applied various documentation and test patches from Leon Brocard. Fixed docs to quote dotted exception types to prevent string concatenation, as noted by Randal Schwartz. Generally added a whole lot more documentation. #------------------------------------------------------------------------ # Version 2.00 beta 2 14th July 2000 #------------------------------------------------------------------------ * Added COMPILE_DIR option. This allows you to specify a separate directory in which compiled templates should be written. The COMPILE_DIR is used as a root directory and each of the INCLUDE_PATH elements is created below that point. e.g. the following options COMPILE_DIR => '/tmp/ttcache', INCLUDE_PATH => '/user/foo/bar:/usr/share/templates', would create the following cache directories: /tmp/ttcache/user/foo/bar /tmp/ttcache/usr/share/templates Templates originating from source files in the INCLUDE_PATH are thus written in their compiled form (i.e. Perl) to the relevant COMPILE_DIR directory. The COMPILE_EXT option may also be used in conjunction with COMPILE_DIR to append a filename extension to all compiled files. * Fixed memory leaks caused by the huge circular reference that is the Template::Provider's linked list of cache slots. Added a DESTROY method which walks the list and explicitly breaks the chains (i.e. the NEXT/PREV links), thus allowing the compiled Template::Document objects to be correctly destroyed and their memory repooled. Thanks to Perrin Harkins for spotting the problem. * Added a work-around in Template::Stash _dotop() to the problem of the CGI module denying membership of the UNIVERSAL class on subsequent calls to UNIVERSAL::isa($cgi, 'UNIVERSAL'). It works correctly the first time, but returns false for all subsequent calls. Changed this generic "is-an-object" test to UNIVERSAL::can($cgi, 'can') on the suggestion of Drew Taylor who identified the problem. * Added t/macro.t to test MACRO directive, t/compile4.t and t/compile5.t to test the COMPILE_DIR option. * More complete documentation, but not yet fully complete. #------------------------------------------------------------------------ # Version 2.00 beta 1 10th July 2000 #------------------------------------------------------------------------ * Template::Context include()/process() now works with raw CODE refs. * Template.pm now prefixes OUTPUT with the OUTPUT_PATH when OUTPUT is a file name. * Cleaned up Template::Iterator. Now derived from Template::Base. Removed ACTION and ORDER now that they are supported as list pseudo methods in the Stash LIST_OPS. * Fixed bug in Provider preventing updated files from being automatically reloaded. Thanks to Perrin Harkins who provided the patch. * Fixed bug in Template::Plugin::Datafile which was preventing a comment from being placed on the first line of the file. * Fixed bug in parse grammer preventing commas in a META list * Added cache persistence by writing real Perl to file (rather than the previous Data::Dumper dump of the opcode tree). Had to re-organise a bunch of code around the parser/provider/document. Activated by COMPILE_EXT configuration item. * Added a work-around in Template::Stash to the problem of CGI disclaiming membership of the UNIVERSAL class after the first method call. * Added AUTO_RESET option which is enabled by default. Disable this (AUTO_RESET => 0) for block persistence across service invocations. * Fixed \@ quoting (and others) in Directive thanks to Perrin Harkins who reported the bug and Chuck Adams who provided a patch. * Added Date plugin and test, as provided by Thierry-Michel Barral. * Integrated changes to Template::Test from version 1.07 and beyond. Now supports -- process -- option in expect, mainly for use of t/date.t et al. * Integrated new upper and lower filters from 1.08, and '|' alias for FILTER from 1.07. * Added new directive.t test to test chomping and comments. * BLOCKS can now be defined as template text which gets automatically compiled into a Template::Document object. * Integrated XML plugins and tests from version 1.07 * Fixed TRIM option to work with all BLOCKs and templates. Moved TRIMing operation into context process() and include() methods. Also changed service to call $context->process($template) rather than call the sub/ doc itself, thus ensuring that the output can get TRIMmed. * Updated Template::Plugin.pm * Added '--define' option to ttree. * Integrated various plugins and filters from v1.07 * Moved Template::Utils::output into Template.pm?) and got rid of Template::Utils altogether. * Fixed bug in Context filter() provider method which wasn't caching filters with args. * [% CASE DEFAULT %] is now an alias for [% CASE %] (the default case), in consistency with [% CATCH DEFAULT %] / [% CATCH %] #------------------------------------------------------------------------ # Version 2.00 alpha 1 #------------------------------------------------------------------------ * first public alpha release of Version 2.00 #======================================================================== # VERSION 2.00 #------------------------------------------------------------------------ # The following list outlines the major differences between version 1.* # and version 2.00 of the Template Toolkit. #======================================================================== New Language Features --------------------- * New SWITCH / CASE statement. SWITCH takes an expression, CASE takes a value or list of values to match. CASE may also be left blank or written as [% CASE default %] to specify a default match. Only one CASE matches, there is no drop-through between CASE statements. [% SWITCH myvar %] [% CASE value1 %] ... [% CASE [ value2 value3 ] %] # multiple values to match ... [% CASE myhash.keys %] # ditto ... [% CASE %] # default, or [% CASE default %] ... [% END %] * New TRY / CATCH / FINAL construct for fully functional, nested exception handling. The block following the TRY is executed and output if no exceptions are throw. Otherwise, the relevant CATCH block is executed. CATCH types are hierarchical (e.g 'foo' catches 'foo.bar') or the CATCH type may be left blank or specified as [% CATCH default %] to provide a default handler. The contents of a FINAL block, if specified, will be processed last of all, regardless of the result (except an uncaught exception which is throw upwards to any enclosing TRY block). [% TRY %] ...blah...blah... [% CALL somecode %] # may throw an exception ...etc... [% INCLUDE someblock %] # may have a [% THROW ... %] directive ...and so on... [% CATCH file %] # catch system-generated 'file' exception ... [% CATCH DBI %] # catch 'DBI' or 'DBI.*' ... [% CATCH %] # catch anything else ... [% FINAL %] # optional All done! [% END %] * New CLEAR directive to clear the current output buffer. This is typically used in a CATCH block to clear the output of a failed TRY block. Any output generated in a TRY block up to the point that an exception was thrown will be output by default. The [% CLEAR %] directive in a catch block clears this output from the TRY block. [% TRY %] blah blah blah, this is the current output block [% THROW some.error 'Danger Will Robinson!' %] not reached... [% CATCH %] [% # at this point, the output block contains the 'blah blah...' line # up to the point where the THROW occured, but we don't want it CLEAR %] Here we can add some more text if we want... [% END %] In general, the CLEAR directive clears the current output from the template or enclosing block. * New META directive allowing you to define metadata items for your templates. These are attached to the compiled template and wrapped up as a Template::Document object. The 'template' variable is a reference to the current parent document and metadata items may be accessed directly. Of particular note is the fact that the 'template' variable is correctly defined for all PRE_PROCESS and POST_PROCESS headers. Thus, your headers and footers can access items from the main template (e.g. title, author, section, keywords, flags, etc) and display them or act accordingly. mytemplate: [% META title = 'This is a Test' author = 'Andy Wardley' copyright = "2000, Andy Wardley" %]

[% template.title %]

blah blah header: (a PRE_PROCESS template) [% template.title %] footer: (a POST_PROCESS template)
© Copyright [% template.copyright or '2000, MyCompany' %] * New RAWPERL ... END block directive allows you to write raw Perl code which is integrated intact and unsullied into the destination template sub-routine. The existing PERL ... END directive continues to be supported, offering runtime evaluation of a block which may contain other template directives, etc, which are first evaluated (e.g. PERL...END processes the block and filters the output into Perl evaluation at runtime). * New INSERT directive which inserts the contents of a file without processing it. * New WRAPPER directive which processes the following block into the 'content' variable and then INCLUDEs the named file. [% WRAPPER table %] blah blah blah [% END %] [% BLOCK table %] [% content %]
[% END %] * Comments now only extend to the end of the current line. [% # this is a comment a = 10 # so is this b = 20 %] Placing the '#' character immediately inside the directive will comment out the entire directive [%# entire directive is ignored %] * The TAGS directive can now be used to switch tag styles by name. Several new tag styles are defined (e.g. html, asp, php, mason). [% TAGS html %] * The output from any directive or block can now be captured and assigned to a variable. [% htext = INCLUDE header %] [% btext = BLOCK %] blah blah [% x %] [% y %] [% z %] [% END %] # you can even assign the output of loops, conditions, etc. [% numbers = FOREACH n = [2, 3, 5, 7, 11, 13] %] blah blah [% n %] [% END %] * The handling of complex expressions has been improved, permitting basic directives to contain logical shortcut operators, etc. All binary operators now have the same precedence rules as Perl. [% foo or bar %] # GET foo, or bar if foo is false (0/undef) [% CALL func1 and func2 %] # func2 only called if func1 returns true [% name = user.id or cgi.param('id') %]. * A new "x ? y : z" operation is provided as a shorthand for "if x then y else z" [% foo = bar ? baz : qux %] * A leading '$' on a variable is now used to indicate pre-interpolation of that element. This simplifies the syntax and makes it consistent with double-quoted string interpolation and text block interpolation via the INTERPOLATE flag. If you've been relying on the version 1 "feature" that ignores the leading '$' then you'll need to change your templates to remove the '$' characters (except where you really want them) or set the V1DOLLAR flag to 1 to revert to the version 1 behaviour. See the 'Gotchas' section below for more details. # version 1 [% hash.${key} %] [% hash.${complex.key} %] # version 2 [% hash.$key %] [% hash.${complex.key} %] * Various new pseudo-methods have been added for inspecting and manipulating data. The full list now looks something like this: [% var.defined %] # variable is defined [% var.length %] # length of string [% var.split(delim, limit) %] # split string as Perl does [% hash.keys %] # return list of hash keys [% hash.values %] # ditto hash values [% hash.each %] # ditto keys and values [% hash.import(hash2) %] # merge hash2 into hash [% list.size %] # number of items in list [% list.max %] # last item number (size - 1) [% list.first %] # first item [% list.last %] # last item [% list.push(item) %] # add item to end [% list.pop %] # remove item from end [% list.unshift(item) %] # add item to front [% list.shift %] # remove item from front [% list.reverse %] # return reversed order [% list.sort(field) %] # return alpha sorted order [% list.nsort(field) %] # return numerical sorted order [% list.join(joint) %] # return items joined into single string Configuration Options --------------------- * Template blocks may be pre-defined using the new BLOCKS option. These may be specified as template text or as references to sub-routines or Template::Document objects. my $template = Template->new({ BLOCKS => { header => '[% title %]', footer => '', funky => sub { blah_blah($blah); return $some_text }, } }); * Automatic error handling can be provided with the ERROR option. This allows you to specify a single template or hash array of templates which should be used in the case of an uncaught exception being raised in the a template. In other words, if something in one of your templates throws a 'dbi' error then you can define an ERROR template to catch this. The original template output is discarded and the ERROR template processed in its place. PRE_PROCESS and POST_PROCESS templates (e.g. header and footers) are left intact. This provides a particularly useful high-level error handling abstraction where you simply create templates to handle particular exceptions and provide the mapping through the ERROR hash. my $template = Template->new({ ERROR => { dbi => 'error/database.html', # DBI error 'user.pwd' => 'error/badpasswd.html', # invalid user password user => 'user/index.html', # general 'user' handler default => 'error/error.html', # default error template } }); * The INCLUDE_PATH is now fully dynamic and can be changed at any time. The new Template::Provider which manages the loading of template files will correctly adapt to chahges in the INCLUDE_PATH and act accordingly. * The LOAD_TEMPLATES option allows you to specify a list of one or more Template::Provider object which will take responsibility for loading templates. Each provider can have it's own INCLUDE_PATH, caching options (e.g CACHE_SIZE) and so on. You can sub-class the Template::Provider module to allow templates to be loaded from a database, for example, and then define your new provider in the LOAD_TEMPLATES list. The providers are queried in order as a "Chain of Responsiblity". Each may return a compiled template, raise an error, or decline to serve the template and pass control onto the next provider in line. * The CACHE_SIZE option defines a maximum number of templates that will be cached by the provider. It is undefined by default, causing all templates to be cached. A value of 0 disables caching altogether while a positive integer defines a maximum limit. The cache (now built into Template::Provider) is much smarter and will automatically reload and compile modified source templates. * The Template::Provider cache can write compiled templates (e.g. Perl code) to disk to create a persistent cache. The COMPILE_EXT may be used to specify a filename extension (e.g. '.ttc') which is used to create compiled template files. These compiled template files can then be reloaded on subsequent invocations using via Perl's require() (which is about as fast as it can get). The Template::Parser and Template::Grammar modules are loaded on demand, so if all templates have been pre-compiled then the modules don't get loaded at all. This is a big win, given that Template::Grammar is the biggy. * The ABSOLUTE and RELATIVE options are now used to enable the loading of template files (via INCLUDE or PROCESS) that are specifies with absolute (e.g. /tmp/somefile) or relative (e.g. ../tmp/another) filenames. Both are disabled by default. * The LOAD_PLUGINS option is similar to LOAD_TEMPLATES but allows you to specify one or more plugin providers. These take responsibility for loading and instantiating plugins. The Template::Plugins module is the default provider and multiplexes requests out to other Template::Plugin::* plugin modules. Loading of plugins has been simplified and improved in general The PLUGINS option can be used to map plugin names to specific modules and PLUGIN_BASE can map plugins into particular namespaces. The LOAD_PERL option can be used to load (almost) any regular Perl module and use it as a plugin. * The LOAD_FILTERS option is similar to LOAD_TEMPLATES and LOAD_PLUGINS, allowing one or more custom providers to be specified for providing filters. The Template::Filters module is the default provider here. * The TOLERANT option can be used to tailor the behaviour of providers (e.g. Template::Provider, Template::Plugins, Template::Filters) when they encounter an error. By default, providers are not TOLERANT (0) and will report all failures as errors. When TOLERANT is set to 1, they will ignore errors and return STATUS_DECLINED to give the next provider a chance to deliver a valid resource. * The INTERPOLATE option is now automatically disabled within PERL and RAWPERL blocks to prevent Perl $variables from being interpreted as template variables. # INTERPOLATE = 1 This $var will get interpolated... [% PERL %] # but these won't my $foo = 'some value'; my $bar = 'another value'; # etc... [% END %] now we're interpolating variables again, like $var * Added the TRIM option to automatically removed leading and trailing whitespace from the output of templates and BLOCKs. * The CASE option has now been obsoleted and replaces by the ANYCASE option. See comments elsewhere in this document ('Gotchas' below and notes for 2.00 beta 4) for further details. Templates Compiled to Perl Code ------------------------------- Templates are now compiled to Perl code, with credit and respect due to Doug Steinwand for providing an implementation around which the new parser was built. This brings a number of important benefits: * Speed and Memory Efficiency Version 1 used a list of opcodes to represent directives and lower-level operations. These were evaluated by the hideously contrived, and darkly sinister Template::Context::_evaluate() method. In version 2, all templates are parsed and rebuilt as Perl code. This is then evaluated and stored as a reference to a Perl sub-routine which can then be executed and re-executed significantly faster and with far less memory overhead. * Persistence. Once a template has been compiled to Perl code it can be saved to disk as a "compiled template" by defining the COMPILE_EXT option. This allows you to specify a filename extension (e.g. '.ttc') which is added to the template filename and used to create a new file containg the Perl code. Next time you use the template, even if you've shut down your program/server/computer in the mean time, the compiled template is there in a file as Perl code and is simply require()d and executed. It all happens significantly faster because there's no Template::Parser to run. In fact, if all your templates are "compiled" on disk then the Template::Parser and Template::Grammar modules won't even be loaded, further reducing startup time and memory consumption (the grammar file, in particular is rather large). The Template::Provider module handles the loading, caching and persistence of templates, and will examine file timestamps and re-compiled modified templates as required. * Flexibility. Because "compiled templates" are now nothing more than Perl sub-routines, you can use anyone or anything to generate them and run them all under the same roof. Different parser back-ends can generate Perl code optimised for speed or functionality, for example. Or different parsers can compile different template languages (PHP, ASP, Mason, roll-your-own, etc.) and run them alongside regular templates. Or if you don't trust a parser, you can even write your own Perl code and have your templates execute as fast as the code you can write. Other Enhancements and Internal Features ---------------------------------------- * Templates (i.e. sub-routines) now return their generated output, rather than sending it to $context->output(). This speeds things up and makes the code simpler, as well as allowing greater flexibility in how template sub-routines can work. * Exceptions are now raised via Perl's die() and caught by an enclosing eval { } block. Again, this simplifies the code generated and improves runtime efficiency. The [% RETURN %] and [% STOP %] directives are now implemented as special case exceptions which are caught in the appropriate place and handled accordingly. * Local named BLOCK definitions are better behaved and don't permanently mask any real files. BLOCK definitions remain local to the template in which they're defined, although they can be accessed from templates INCLUDEd or PROCESSed from within. The PROCESS directive will export defined BLOCKs to the caller (as with variables) whereas INCLUDE will keep them "private". * The Template::Stash object now encapsulates all the magical variable resolution code. Both simple and compound variables can be accessed or updated using the get() and set() methods, with all variable binding magic happening automatically. * The Template::Context object is now greatly simplified. This acts as a general interface to the Template Toolkit functionality, being a collection of the various other modules that actually implement the functionality (e.g. Template::Stash, Template::Provider, Template::Document, Template::Plugins, etc.) * The Template::Provider object provides a general facility for retrieving templates from disk (or other source), and if necessary compiling via a call to a Template::Parser helper object. Multiple Template::Provider objects may be chained together, each with their own caching options, and so on. * The Template::Parser object now compiles template text into Perl code and then evaluates it into a sub-routine reference using Perl's eval(). This is then wrapped up into a Template::Document object, including any metadata items and/or additional named BLOCKs defined in the input template. * The Template::Document object is a thin wrapper around a compiled template sub-routine. It provides a process() method for processing the template and a blocks() method for returning a reference to the hash array of any additional named BLOCKs defined in the original template text. An AUTOLOAD method returns values of metadata items, allowing a Template::Document reference to be used as the 'template' variable. * The Template::Service module provides a high-level service for processing templates, allowing PRE_PROCESS and POST_PROCESS templates to be specified along with an ERROR handling hash. * The Template::Base module defines a common base class for many of the toolkit modules. It implements shared functionality such as a constructor, error reporting and handling, etc. Modules are now much easier to sub-class, all using separate new() and _init() methods. * The Template::Config module provides methods for loading and instantiating different Template Toolkit modules. Using this factory-based approach makes it far easier to change the default object class for a specific part of the toolkit. e.g. use Template; use Template::Config; $Template::Config::PARSER = 'MyOrg::Template::MyParser'; # $tt object will create and use a MyOrg::Template::MyParser # object as PARSER my $tt = Template->new({ ... }) * The Template::Test module has been enhanced to make it easier to test more advanced TT features. You can now define multiple TT processors and switch between them for different test with the '-- use name --' directive. Also added the '-- process --' directive which can be added after '-- expect --' to hav the expected output processed by TT before comparison. * The Template module remains, as it ever was, a simple front-end to the Template Toolkit. This creates a single Template::Service to which it delegates control for processing templates. Output is returned according to the OUTPUT options specified for the module and/or any output option passed explicitly to the process() method. New Filters ----------- * 'upper' and 'lower' filters perform case folding of text. * 'eval' can be used to evaluate Template Toolkit directives at runtime. * 'perl' evaluates Perl code if (and only if) the EVAL_PERL flag is set. * 'stderr' is a simple filter to STDERR. * 'file' is a new alias for the 'redirect' filter. The OUTPUT_PATH option must be set. New Plugins ----------- * The DBI plugin is now distributed with the Template Toolkit. * The Date plugin formats dates and times via the POSIX strftime() sub. * The Iterator plugin provides access to the Template::Iterator module. * The Dumper plugin provides an interface to the Data::Dumper module. * The Wrap and Autoformat plugins interface to the Text::Wrap and Text::Autoformat modules respectively. * The XML::DOM and XML::XPath plugins provide interfaces to the relevant XML modules. Utility Scripts --------------- * Added the '--define var=val' option to ttree. Gotchas ------- Things that have changed between version 1 and 2 that might catch you out. * Bare CATCH blocks are no longer permitted and must be explicitly scoped with a matching TRY. In most cases, this simply means adding a [% TRY %] to the start of any templates that define CATCH blocks, and ensuring that the CATCH blocks are moved to the end of the file (or relevant place). # version 1 - no longer supported blah blah blah...some error occurs [% CATCH some_kind_of_error %] handler template... [% END %] # version 2 [% TRY %] blah blah blah...some error occurs... [% CATCH some_kind_of_error %] handler template... [% END %] Also be aware that this may change the expected output in case of errors. By default, all output in the TRY block up to the point of error will be returned, with the relevant catch block, and then and further template output appended. You can use [% CLEAR %] within a CATCH block to clear the output from the TRY block, if you prefer. TRY blocks can be nested indefinately. * The ERROR directive is no longer supported. It was very ill-defined anyway and serves no purpose that can't be acheived by defining custom filters, error handlers bound to template variables, or whatever. I haven't implemented any special error or logging facilities, other than the general purpose exception handling, but welcome any thoughts on what or if anything else is needed. * The ERROR option is also different. It could previously be used to specify an error handling sub-routine, but is no longer required (see previous point). The ERROR option in version 2 is used to define a map of error types to template names for automatic redirection for error handling. * The current exception caught in a catch block is now aliased to the variable 'error' rather than 'e'. This is much more logical, IMHO, and was only prevented previously by 'error' being a reserved word. Note that 'e' is still defined, in addition to 'error'. This may be deprecated at some point in the future. * The use of a leading '$' on variables is no longer optional, and should only be used to explicitly to indicate interpolatation of a variable name. Most of the time you *don't* want to do this, so leave the '$' off. This represent a slight shift away from the (optional) Perlness of the language, but I think it's a necessary step to improve the clarity and consistency of the language. As previously discussed on the mailing list, in interpolated text (i.e. a "double quoted" string or regular template text with INTERPOLATE set), both '$foo' or '${foo}' are interpolated as the value of the variable 'foo'. This is good because it is a de-facto standard, consistent with Perl, shell, etc. But inside a directive, [% $foo %] and [% ${foo} %] mean different things, the first being equivalent to [% foo %] or [% GET foo %] (the leading '$' is ignored) but the second actually fetching a variable whose name is stored in the variable 'foo'. In other words, '${foo}' interpolates to the value of foo ('bar', say) and then this is used as the parameter to GET (which itself is optional). Thus, in this case, [% ${foo} %] is [% GET ${foo} %] is [% GET bar %]. This makes more sense if you look at the common example of accesing an entry from a hash array using the value of an variable as the key (e.g. $hash->{ $key }). In version 1, the leading '$' on variables is ignored, meaning that the following are NOT identical. # version 1 [% hash.$key %] # ERROR - '$' ignored => [% hash.key %] [% hash.${key} %] # OK - '$key' is interpolated first It gets more confusing if you excercise your right to add optional leading '$'s in other places (which is one reason why I've always suggested against their use). # version 1 - same as above [% $hash.$key %] [% $hash.${key} %] In particular, that last example should demonstrate the inconsistency. Unlike interpolated text, '$...' and '${...}' are not treated the same and '$hash' is not interpolate while '${key}' is. The only consistent solution I can see to this is to make both '$xxx' and '${xxx}' indicate interpolation in all cases, so that's what I've done. In version 2, the syntax becomes a lot clearer and aligns more closely to a markup language than a programming language. I think this is a Good Thing, but let me know what you think... Here's the Version 2 summary, assuming INTERPOLATE is set. # version 2 my name is $name my name is $user.name my name is ${user.name} [% GET name %] [% name %] [% GET user.name %] [% user.name %] [% GET people.fred %] [% people.fred %] [% GET people.$name %] [% people.$name %] [% GET people.${user.name} %] [% people.${user.name} %] [% INCLUDE header title = "Home Page for $name" %] [% INCLUDE header title = "Home Page for $user.name" %] [% INCLUDE header title = "Home Page for ${user.name}" %] * Changed default TAG_STYLE to only recognise [% ... %] and not the MetaText compatability %% ... %% style. Set TAG_STYLE => 'template1' to accept both, or 'metatext' for just %% ... %% * Changed how error/return values should be returned from user code. All errors should be thrown via one of the following: die $error_msg; die (Template::Exception->new($type, $info)); $context->throw($msg); $context->throw($type, $info); $context->throw($exception); * USERDIR and USERBLOCK are not supported (they were experimental and undocumented, anyway) * $Template::Directive::While::MAXITER is now $Template::Directive::WHILE_MAX and may change again. * into() filter is now obsolete. You can now simply assign the output of another directive or block to a variable. [% x = INCLUDE foo %] [% y = BLOCK %] blah blah blah [% END %] * The CASE option has been removed and replaced with the ANYCASE option which is the logical opposite. Directive keywords should now be UPPER CASE by default and the ANYCASE option can be enabled to revert to the previous behaviour of accept keywords in any case. * The IMPORT directive and magical variable have been removed and replaced by a general purpose virtual hash method, import(). [% IMPORT myhash %] should now be written [% import(myhash) %] and [% myhash.IMPORT = another.hash %] should be written as [% myhash.import(another.hash) %] Template-Toolkit-2.24/HACKING000644 000765 000765 00000003104 11714264206 015225 0ustar00abwabw000000 000000 Template Toolkit Version 2.24 February 2012 Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. HACKER'S GUIDE -------------- Please hack on the Template Toolkit. It has been designed to be extensible and has literally dozens of programmer hooks that you can tap into to do all sorts of cool things. The object oriented architecture allows you to create your own subclassed modules to implement your own services, providers, filters, plugins, and so on. The Template::Manual::Internals document gives a brief overview of the architecture. Unfortunately, it's not as complete as it could be, but the code is well documented and generally easy to follow. Don't be afraid to use the source, Luke. The internals document also contains information about preparing and applying patches, updating the documentation and various other useful tips. SOURCE CODE ----------- The source code repository for the Template Toolkit is hosted at Github. https://github.com/abw/Template2 AUTHOR ------ The Template Toolkit was written by Andy Wardley with the invaluable assistance and contributions from many other people. See Template::Manual::Credits for details. COPYRIGHT --------- Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Template-Toolkit-2.24/images/000755 000765 000765 00000000000 11714420735 015506 5ustar00abwabw000000 000000 Template-Toolkit-2.24/INSTALL000644 000765 000765 00000016313 11714264235 015277 0ustar00abwabw000000 000000 Template Toolkit Version 2.24 February 2012 Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. QUICK INSTALL ------------- If you have the CPAN module installed then you can install the Template Toolkit like this from the command line: $ cpan Template Otherwise you can install from source code. The latest version of the Template Toolkit can be retrieved from: http://www.cpan.org/modules/by-module/Template/ Fetch and install AppConfig 1.56 if you don't already have it installed. Available from CPAN in: http://www.cpan.org/authors/Andy_Wardley/ To install the Template Toolkit from the command line: $ tar zxf Template-Toolkit-2.24.tar.gz $ cd Template-Toolkit-2.24 $ perl Makefile.PL $ make $ make test $ make install The Makefile.PL will prompt for any additional configuration options. For further details, see the sections below on CONFIGURATION, BUILDING AND TESTING, and INSTALLATION. The Template Toolkit web site also has further information about installation. http://template-toolkit.org/download/index.html PREREQUISITES ------------- The Template Toolkit is written entirely in Perl and should run on any platform on which Perl is available. It requires Perl 5.006 or later. The 'ttree' utility uses the AppConfig module (version 1.56 or above) for parsing command line options and configuration files. It is available from CPAN: http://www.cpan.org/authors/Andy_Wardley/ The Template Toolkit implements a "plugin" architecture which allow you to incorporate the functionality of virtually any Perl module into your templates. A number of plugin modules are included with the distribution for adding extra functionality or interfacing to external CPAN modules. You don't need to install any of these external modules unless you plan to use those particular plugins. See Template::Plugins and Template::Manual::Plugins for further details. OBTAINING AND INSTALLING THE TEMPLATE TOOLKIT --------------------------------------------- The latest release version of the Template Toolkit can be downloaded from any CPAN site: http://www.cpan.org/modules/by-module/Template/ Interim and development versions may also be available, along with other useful information, news, publications, mailing list archives, etc., from the Template Toolkit web site: http://template-toolkit.org/ The Template Toolkit is distributed as a gzipped tar archive file: Template-Toolkit-.tar.gz where represents the current version number, e.g. 2.24. To install the Template Toolkit, unpack the distribution archive to create an installation directory. Something like this: $ tar zxf Template-Toolkit-2.24.tar.gz or $ gunzip Template-Toolkit-2.24.tar.gz $ tar xf Template-Toolkit-2.24.tar You can then 'cd' into the directory created, $ cd Template-Toolkit-2.24 and perform the usual Perl installation procedure: $ perl Makefile.PL $ make $ make test $ make install # may need root access The Makefile.PL performs various sanity checks and then prompts for a number of configuration items. The following CONFIGURATION section covers this in greater detail. If you choose to install the optional components then you may need to perform some post-installation steps to ensure that the template libraries, HTML documentation and examples can be correctly viewed via your web browser. The INSTALLATION section covers this. INSTALLING ON MICROSOFT WIN32 PLATFORMS --------------------------------------- For advice on using Perl under Microsoft Windows, have a look here: http://win32.perl.org/ If you're using Strawberry Perl then you can install the Template Toolkit using the CPAN module as described above. If you're using ActivePerl then you can install it using the Perl Package Manager (ppm) with the pre-compiled packages built by Chris Winters. For further details, see: http://openinteract.sourceforge.net/ http://activestate.com/ If you prefer, you can manually install the Template Toolkit on Win32 systems by following the instructions in this installation guide. However, please note that you are likely to encounter problems using 'make' and should instead download and use 'nmake' as a replacement. This is available from Microsoft's ftp site. ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe In this case, you should substitute 'nmake' for 'make' in all the instructions contained herein. CONFIGURATION ------------- This section covers the configuration of the Template Toolkit via the Makefile.PL program. If you've successfully run this and didn't have any problems answering any of the questions then you probably don't need to read this section. The Makefile.PL Perl program performs the module configuration and generates the Makefile which can then be used to build, test and install the Template Toolkit. $ perl Makefile.PL The Template Toolkit now boasts a high-speed implementation of Template::Stash written in XS. You can choose to build this as an optional module for using explicitly as an alternative to the regular pure-perl stash module. In additional, you can opt to use the XS Stash as the default, typically making the Template Toolkit run twice as fast! When prompted, answer 'y' or 'n' to build and optionally use the XS Stash module by default: Do you want to build the XS Stash module? [y] Do you want to use the XS Stash for all Templates? [n] BUILDING AND TESTING -------------------- This section describes the "make" and "make test" commands which build and test the Template Toolkit. If you ran these without incident, then you can probably skip this section. The 'make' command will build the Template Toolkit modules in the usual manner. make The 'make test' command runs the test scripts in the 't' subdirectory. make test You can set the TEST_VERBOSE flag when running 'make test' to see the results of the individual tests: make test TEST_VERBOSE=1 INSTALLATION ------------ This section describes the final installation of the Template Toolkit via the "make install" and covers any additional steps you may need to take if you opted to build the HTML documentation and/or examples. The 'make install' will install the modules and scripts on your system. You may need administrator privileges to perform this task. Alternately you can can install the Template Toolkit to a local directory (see ExtUtils::MakeMaker for full details), e.g. $ perl Makefile.PL PREFIX=/home/abw/ Don't forget to update your PERL5LIB environment variable if you do this, or add a line to your script to tell Perl where to find the files, e.g. use lib qw( /home/abw/lib/perl5/site_perl/5.10.0 ); AUTHOR ------ The Template Toolkit was written by Andy Wardley with the invaluable assistance and contributions from many other people. See Template::Manual::Credits for details. COPYRIGHT --------- Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Template-Toolkit-2.24/lib/000755 000765 000765 00000000000 11714420735 015007 5ustar00abwabw000000 000000 Template-Toolkit-2.24/Makefile.PL000644 000765 000765 00000032726 11714265277 016235 0ustar00abwabw000000 000000 #!/usr/bin/perl -w # -*- perl -*- use strict; use warnings; use 5.006; use lib qw( ./lib ); use Config; use File::Spec::Functions qw( catfile ); use Template; use ExtUtils::MakeMaker; use Cwd; select STDERR; $| = 1; select STDOUT; use vars qw( $TT_VERSION $TT_PREFIX $TT_XS_ENABLE $TT_XS_DEFAULT $TT_QUIET $TT_ACCEPT $TT_YES ); # check O/S to set sensible defaults my ($WIN32, $FLAVOUR, $PREFIX, $IMAGES, $MAKE); if ($^O eq 'MSWin32') { # any others also? $WIN32 = 1; $FLAVOUR = 'Win32'; $PREFIX = 'C:/Program Files/Template Toolkit 2'; $IMAGES = '/tt2/images'; } else { $WIN32 = 0; $FLAVOUR = 'Unix'; $PREFIX = '/usr/local/tt2'; $IMAGES = '/tt2/images'; } $MAKE=$Config{'make'}; # read command line args putting TT_* into $ttconfig and # everything else (regular Makefile.PL args, e.g. PREFIX) # goes into $config my (%config, %ttconfig); while ($_ = shift) { my ($k, $v) = split(/=/, $_, 2); if ($k =~ /^TT/) { $ttconfig{ $k } = $v || 0; } else { $config{ $k } = $v || 0; } }; # print help if they asked for it if (exists $ttconfig{ TT_HELP }) { print < 'Template', 'DISTNAME' => 'Template-Toolkit', 'VERSION_FROM' => 'lib/Template.pm', 'EXE_FILES' => [ 'bin/tpage', 'bin/ttree' ], 'PMLIBDIRS' => [ 'lib' ], 'DIR' => [ ], 'PREREQ_PM' => { 'AppConfig' => $TT_APPCONFIG_VERSION, 'File::Spec' => $TT_FILE_SPEC_VERSION, 'File::Temp' => $TT_FILE_TEMP_VERSION, 'Scalar::Util' => 0, }, 'dist' => { 'COMPRESS' => 'gzip', 'SUFFIX' => 'gz', }, 'test' => { 'TESTS' => join(' ', map { glob } qw( t/*.t t/vmethods/*.t )), }, 'clean' => { 'FILES' => join(' ', qw( docs/ttree.cfg examples/ttree.cfg t/dbi_test.cfg t/test/src/baz.ttc t/test/src/complex.org t/test/src/complex.ttc t/test/src/evalperl.ttc t/test/src/foo.ttc )), }, ); push @{ $opts{'DIR'} }, 'xs' if $TT_XS_ENABLE; # Handle dev versions in our check my $mmv = $ExtUtils::MakeMaker::VERSION; $mmv =~ s/\_.+//; if ($mmv >= 5.43) { $opts{ AUTHOR } = 'Andy Wardley '; $opts{ ABSTRACT } = 'comprehensive template processing system', } if ($ExtUtils::MakeMaker::VERSION ge '6.30_00') { $opts{'LICENSE' } = 'perl'; } WriteMakefile( %opts ); print < $DEFAULTS_FILE") || die "$DEFAULTS_FILE: $!\n"; my ( $ttxs_enable, $ttxs_default ) = map { $_ ? 'y' : 'n' } ( $TT_XS_ENABLE, $TT_XS_DEFAULT ); print FP <; close(FP); ($text =~ s/^(\s*${find}\s*=\s*)'.*?'/$1'$fix'/m) || die "$find not found in $file\n"; open(FP, "> $file") || die "$file: $!\n"; print FP $text; close(FP); } #------------------------------------------------------------------------ # find_program($path, $prog) # # Find a program, $prog, by traversing the given directory path, $path. # Returns full path if the program is found. # # Written by Craig Barratt, Richard Tietjen add fixes for Win32. # # abw changed name from studly caps findProgram() to find_program() :-) #------------------------------------------------------------------------ sub find_program { my($path, $prog) = @_; # my $sep = $WIN32 ? qr/;/ : qr/:/; # foreach my $dir ( split($sep, $path) ) { foreach my $dir ( split($Config{path_sep}, $path) ) { my $file = File::Spec->catfile($dir, $prog); if ( !$WIN32 ) { return $file if ( -x $file ); } else { # Windows executables end in .xxx, exe precedes .bat and .cmd foreach my $dx ( qw/exe bat cmd/ ) { return "$file.$dx" if ( -x "$file.$dx" ); } } } } #------------------------------------------------------------------------ # message($text) # # Print message unless quiet mode. #------------------------------------------------------------------------ sub message { return if $TT_QUIET; print @_; } #------------------------------------------------------------------------ # ttprompt($message, $default) #------------------------------------------------------------------------ sub ttprompt { my ($msg, $def)=@_; my $ISA_TTY = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe? my $dispdef = defined $def ? "[$def] " : " "; $def = defined $def ? $def : ""; my $ans = ''; local $|=1; print "$msg $dispdef" unless $TT_QUIET; if ($TT_ACCEPT || ! $ISA_TTY) { print "$def\n" unless $TT_QUIET; } else { chomp($ans = ); } return ($ans ne '') ? $ans : $def; } #------------------------------------------------------------------------ # yep($text) #------------------------------------------------------------------------ sub yep { return if $TT_QUIET; print '[X] ', shift, "\n"; } #------------------------------------------------------------------------ # nope($text) #------------------------------------------------------------------------ sub nope { return if $TT_QUIET; print '[ ] ', shift, "\n"; } Template-Toolkit-2.24/MANIFEST000644 000765 000765 00000010575 11714420735 015402 0ustar00abwabw000000 000000 bin/README bin/tpage bin/tt-bench.pl bin/tt2inst bin/ttree Changes HACKING images/tt2power.gif images/ttdotorg.gif INSTALL lib/Template.pm lib/Template/Base.pm lib/Template/Config.pm lib/Template/Constants.pm lib/Template/Context.pm lib/Template/Directive.pm lib/Template/Document.pm lib/Template/Exception.pm lib/Template/FAQ.pod lib/Template/Filters.pm lib/Template/Grammar.pm lib/Template/Iterator.pm lib/Template/Manual.pod lib/Template/Manual/Config.pod lib/Template/Manual/Credits.pod lib/Template/Manual/Directives.pod lib/Template/Manual/Filters.pod lib/Template/Manual/Internals.pod lib/Template/Manual/Intro.pod lib/Template/Manual/Plugins.pod lib/Template/Manual/Syntax.pod lib/Template/Manual/Variables.pod lib/Template/Manual/Views.pod lib/Template/Manual/VMethods.pod lib/Template/Modules.pod lib/Template/Namespace/Constants.pm lib/Template/Parser.pm lib/Template/Plugin.pm lib/Template/Plugin/Assert.pm lib/Template/Plugin/CGI.pm lib/Template/Plugin/Datafile.pm lib/Template/Plugin/Date.pm lib/Template/Plugin/Directory.pm lib/Template/Plugin/Dumper.pm lib/Template/Plugin/File.pm lib/Template/Plugin/Filter.pm lib/Template/Plugin/Format.pm lib/Template/Plugin/HTML.pm lib/Template/Plugin/Image.pm lib/Template/Plugin/Iterator.pm lib/Template/Plugin/Math.pm lib/Template/Plugin/Pod.pm lib/Template/Plugin/Procedural.pm lib/Template/Plugin/Scalar.pm lib/Template/Plugin/String.pm lib/Template/Plugin/Table.pm lib/Template/Plugin/URL.pm lib/Template/Plugin/View.pm lib/Template/Plugin/Wrap.pm lib/Template/Plugins.pm lib/Template/Provider.pm lib/Template/Service.pm lib/Template/Stash.pm lib/Template/Stash/Context.pm lib/Template/Stash/XS.pm lib/Template/Test.pm lib/Template/Toolkit.pod lib/Template/Tools.pod lib/Template/Tools/tpage.pod lib/Template/Tools/ttree.pod lib/Template/Tutorial.pod lib/Template/Tutorial/Datafile.pod lib/Template/Tutorial/Web.pod lib/Template/View.pm lib/Template/VMethods.pm Makefile.PL MANIFEST META.yml Module meta-data (added by MakeMaker) parser/Grammar.pm.skel parser/Parser.yp parser/README parser/yc README t/args.t t/assert.t t/base.t t/binop.t t/block.t t/blocks.t t/capture.t t/case.t t/cgi.t t/chomp.t t/compile1.t t/compile2.t t/compile3.t t/compile4.t t/compile5.t t/config.t t/constants.t t/context.t t/datafile.t t/date.t t/debug.t t/directive.t t/directry.t t/document.t t/dumper.t t/error.t t/evalperl.t t/exception.t t/factory.t t/file.t t/fileline.t t/filter.t t/foreach.t t/format.t t/html.t t/image.t t/include.t t/iterator.t t/leak.t t/lib/Template/Plugin/ProcBar.pm t/lib/Template/Plugin/ProcFoo.pm t/lib/Template/Plugin/Simple.pm t/list.t t/macro.t t/math.t t/object.t t/output.t t/parser.t t/plugins.t t/plusfile.t t/pod.t t/prefix.t t/proc.t t/process.t t/provider.t t/README t/ref.t t/scalar.t t/service.t t/skel.t t/stash-xs-unicode.t t/stash-xs.t t/stash.t t/stashc.t t/stop.t t/strcat.t t/strict.t t/string.t t/switch.t t/table.t t/tags.t t/template.t t/test/dir/file1 t/test/dir/file2 t/test/dir/sub_one/bar t/test/dir/sub_one/foo t/test/dir/sub_two/waz.html t/test/dir/sub_two/wiz.html t/test/dir/xyzfile t/test/lib/after t/test/lib/badrawperl t/test/lib/barfed t/test/lib/before t/test/lib/blockdef t/test/lib/chomp t/test/lib/config t/test/lib/content t/test/lib/default t/test/lib/dos_newlines t/test/lib/error t/test/lib/footer t/test/lib/header t/test/lib/header.tt2 t/test/lib/incblock t/test/lib/inner t/test/lib/menu t/test/lib/one/foo t/test/lib/outer t/test/lib/process t/test/lib/README t/test/lib/simple2 t/test/lib/trimme t/test/lib/two/bar t/test/lib/two/foo t/test/lib/udata1 t/test/lib/udata2 t/test/lib/warning t/test/plugin/MyPlugs/Bar.pm t/test/plugin/MyPlugs/Baz.pm t/test/plugin/MyPlugs/Foo.pm t/test/pod/test1.pod t/test/src/bar/baz t/test/src/bar/baz.txt t/test/src/baz t/test/src/benchmark t/test/src/blam t/test/src/complex t/test/src/divisionbyzero t/test/src/evalperl t/test/src/foo t/test/src/foobar t/test/src/golf t/test/src/leak1 t/test/src/leak2 t/test/src/metadata t/test/src/mywrap t/test/src/README t/test/src/recurse t/test/tmp/README t/text.t t/throw.t t/tiedhash.t t/try.t t/unicode.t t/url.t t/url2.t t/vars.t t/varsv1.t t/view.t t/vmethods/hash.t t/vmethods/list.t t/vmethods/replace.t t/vmethods/text.t t/while.t t/wrap.t t/wrapper.t t/zz-pmv.t t/zz-pod-coverage.t t/zz-pod-kwalitee.t t/zz-stash-xs-leak.t TODO xs/Makefile.PL xs/MANIFEST xs/ppport.h xs/README xs/Stash.xs META.json Module JSON meta-data (added by MakeMaker) Template-Toolkit-2.24/META.json000644 000765 000765 00000001735 11714420735 015670 0ustar00abwabw000000 000000 { "abstract" : "comprehensive template processing system", "author" : [ "Andy Wardley " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Template-Toolkit", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : 0 } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : 0 } }, "runtime" : { "requires" : { "AppConfig" : "1.56", "File::Spec" : "0.8", "File::Temp" : "0.12", "Scalar::Util" : 0 } } }, "release_status" : "stable", "version" : "2.24" } Template-Toolkit-2.24/META.yml000644 000765 000765 00000001057 11714420735 015515 0ustar00abwabw000000 000000 --- abstract: 'comprehensive template processing system' author: - 'Andy Wardley ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.112150' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Template-Toolkit no_index: directory: - t - inc requires: AppConfig: 1.56 File::Spec: 0.8 File::Temp: 0.12 Scalar::Util: 0 version: 2.24 Template-Toolkit-2.24/parser/000755 000765 000765 00000000000 11714420735 015535 5ustar00abwabw000000 000000 Template-Toolkit-2.24/README000644 000765 000765 00000027773 11714264156 015144 0ustar00abwabw000000 000000 Template Toolkit Version 2.24 February 2012 Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. INSTALLATION ------------ If you have the CPAN module installed then you can install the Template Toolkit from the command line like so: $ cpan Template Please see the separate INSTALL file for further information on installing the Template Toolkit, including what to do if you don't have the CPAN module installed, and/or installation on MS Windows. DESCRIPTION ----------- The Template Toolkit is a collection of modules which implement a fast, flexible, powerful and extensible template processing system. It was originally designed and remains primarily useful for generating dynamic web content, but it can be used equally well for processing any other kind of text based documents: HTML, XML, POD, PostScript, LaTeX, and so on. It can be used as a stand-alone Perl module or embedded within an Apache/mod_perl server for generating highly configurable dynamic web content. A number of Perl scripts are also provided which can greatly simplify the process of creating and managing static web content and other offline document systems. WHAT'S NEW? ----------- Version 2.24 adds some new text virtual methods and fixes a silly bug in the Makefile.PL. Version 2.23 is a maintenance release which fixes a few bugs, including one in the XS Stash which caused problems when using third party modules (e.g. DateTime) which use the string-based form of eval. Version 2.22 is mostly a bug fixing release. The XS Stash now works with utf8 data. Tests that were failing on Win32 platforms have been fixed. Pod coverage and quality tests have been disabled except for release testing. The Autoformat plugin has been moved into a separate distribution. Version 2.21 featured a complete clean-out of all the old HTML documentation, examples, libraries and other cruft that was way out of date and badly unloved. A new version of the HTML documentation is available for download from http://tt2.org/download/index.html#html_docs. v2.21 also fixes a memory leak in the XS Stash. Version 2.21 also adds the STRICT option which reports the use of undefined variable values. The ANYCASE option has been improved so that you can write things like 'data.last' without the 'last' bit being interpreted as the LAST keyword. The xml filter is also new, providing a slightly more rigourous version of the html filter for use in XML documents. Version 2.20 fixed all known bugs. It also added the Scalar and Assert plugins. The HTML documentation, examples, libraries and other bits and pieces are still provided with the distribution, but are no longer installed by the Makefile.PL. If you want them (and very few people do, it seems), then you'll need to dig them out of the distribution by yourself (or uncomment the commented-out lines in Makefile.PL that handle the installation). This has been done in an effort to simplify the installation process. All of the HTML documentation is available online at http://tt2.org/ Version 2.19 fixed some minor bugs in both Perl and XS versions of the Template Stash, and fixed a problem with a test in the test suite failing under Win32. It also added the url filter as a version of what the uri filter used to do before we fixed it to do the right thing. Version 2.18 fixes a number of minor bugs. It also includes a modification to the parser grammar so that you can write expressions as arguments to subroutine, method or vmethod calls. Versions 2.17 and 2.16 were interim releases by Adam Kennedy who took care of some installation problems on Mac OSX while Andy was busy elsewhere. Version 2.15 is a major maintenance release. It applies all outstanding patches and closes all open bugs listed on http://rt.cpan.org/ It includes: * XS Stash: enhancements include support for tied hashes/arrays and "fallback" methods on objects (e.g. accessing hash and list items and calling virtual methods) * Virtual Methods: added the scalar.remove, scalar.substr, hash.delete, hash.items, hash.pairs, list.import and list.hash virtual methods. Added support for backreferences to scalar.replace and other improvements to list.push, list.unshift, list.hash, hash.list * Plugins: Added Math plugin, Bug fixes and enhancements to File, Image, URL and String plugins. Moved DBI, XML and GD plugins into separate distributions. * Numerous other bug fixes, enhancements, documentation updates, all described in detail in the Changes file. More significant is what's not in version 2.15. The DBI plugin has been moved into a separate Template-DBI distribution, the GD plugins into Template-GD, the XML plugins into Template-XML, and the Latex filters into Template-Latex. This has been done in an effort to make the Template Toolkit core distribution smaller, cleaner and easier to configure and install. Version 2.14 added Unicode support to TT, a full set of command line options for tpage, the 'caller' and 'callers' items to each template component, some enhancements to the XML::Simple plugin, and a number of minor bug fixes. See the Changes file for further details of the changes in these and earlier releases. GENERAL FEATURES ---------------- Some of the key features of the Template Toolkit are listed below. See the documentation for further detail. * simple but powerful template language * promotes a clear separation between application functionality and presentation elements * variable substitution allows binding to any Perl data types (scalars, hashes, lists, subs, objects) * conditional blocks (IF/UNLESS/ELSIF/ELSE, SWITCH/CASE) * loops and iterators (FOREACH, WHILE) * file/template inclusion (INSERT, INCLUDE, PROCESS, WRAPPER) * definition of local template components (BLOCK) * post-processing filters (FILTER) * plugin module architecture for easy extensibility (USE) * embedded Perl can be optionally enabled (PERL/RAWPERL) * full exception handling (TRY/THROW/CATCH/FINAL) * user-defined macros (MACRO) * definition of template metadata (META) * virtual methods for complex data types (e.g. list.size, hash.keys, etc.) * numerous configuration options * modular OO architecture allows extensive customisation * fast LALR(1) parser modules compiles templates according to a YACC-like grammar. * templates compiled to Perl code for efficient runtime execution * in-memory and on-disk caching of compiled templates * simple front end module (Template.pm) for ease of use * numerous plugin modules: CGI, DBI, XML, URL, Date, Table, etc * standard filters for html, case folding, regex search and replace, etc. DOCUMENTATION ------------- The Template Toolkit is provided with enough documentation to keep all but the most voracious reader happy for quite some time. The 'Changes' file in the distribution directory documents all visible changes between versions of the Template Toolkit. See the section 'VERSION COMPATABILITY' below for further details. The 'TODO' file, also in the distribution directory, lists known bugs, planned enhancements and possible new features for future versions. The 'INSTALL' file covers the configuration and installation process. The rest of the documentation is distributed in Pod format. The Pod pages are installed when you 'make install' and can be viewed using 'perldoc', e.g. perldoc Template If you're using a Unix based system then the pages should also be converted to manpages suring the 'make install'. Thus, you can also: man Template (the man pages shouldn't have any problems relating to older versions) The documentation is also available in HTML format at the TT web site: http://tt2.org/docs/ The documentation is now split into several sections. The 'Template' page is now much shorter, containing information relating to the specifics of using the Template module, and a brief summary of everything else. Information relating more generally to the Template Toolkit, features, syntax of the template language, plugins and so forth, has been split up into a number of Template::Manual::* pages. Template::Manual provides the index for the manual. perldoc Template::Manual Individual sections can be viewed as, for example, perldoc Template::Manual::Syntax perldoc Template::Manual::Directives perldoc Template::Manual::Plugins The Template::Tutorial provides an index to the tutorial documents. There are currently 2 tutorials, on generating web content, and on creating and using data files. perldoc Template::Tutorial perldoc Template::Tutorial::Web perldoc Template::Tutorial::Datafile Each of the various modules that comprise the Template Toolkit has its own associated documention. The 'Template::Modules' manpage lists these modules along with a brief description of their functions. perldoc Template::Modules See the individual pages for further detail: perldoc Template::Context perldoc Template::Parser perldoc Template::Provider If you're interested in the internals of the Template Toolkit and want to know more about how it all works, then you might like to have a look at the following: perldoc Template::Manual::Internals This document also contains important information for people wishing to hack on the Template Toolkit. The final bit of good news is that there is now a FAQ for the Template Toolkit. perldoc Template::FAQ It's now got a few question in it, and better still, some answers! Further contributions welcome. Most of the documentation is stable and reliable. Where it's not then it's usually marked as such. In particular, the documentation for the internals (Template::Manual::Internals) and FAQ (Template::FAQ) are perpetually under construction. SOURCE CODE ----------- The source code for the Template Toolkit is maintained in a public git repository at github: https://github.com/abw/Template2 If you want to hack on the source code, either to fix a bug or add a feature then you should fork the repository, make the changes, commit them, and then send me a pull request. See this guide for further information. http://help.github.com/send-pull-requests/ Any non-trivial new features should be discussed on the Template Toolkit mailing list first (see below). Don't forget to update the documentation and tests where relevant SUPPORT ------- The Template Toolkit mailing list provides a forum for discussing issues relating to the use and abuse of the Template Toolkit. There are a number of knowledgeable and helpful individuals who frequent the list (including the author) who can often offer help or suggestions. Please respect their time and patience by checking the documentation and/or mailing list archives before asking questions that may already have been answered. To subscribe to the mailing list, send an email to: templates-request@template-toolkit.org with the message 'subscribe' in the body. You can also use the web interface to subscribe or browse the archives: http://mail.template-toolkit.org/mailman/listinfo/templates A low-volume, moderated mailing list exists for announcements about new releases of the Template Toolkit and related products. To subscribe, send an email to: templates-announce-request@template-toolkit.org with the message 'subscribe' in the body. A web interface also exists for subscription and browsing the archives: http://mail.template-toolkit.org/mailman/listinfo/templates-announce For information about commercial support and consultancy for the Template Toolkit, please contact the author. AUTHOR ------ The Template Toolkit was written by Andy Wardley with the invaluable assistance and contributions from many other people. See Template::Manual::Credits for details. COPYRIGHT --------- Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. This is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Template-Toolkit-2.24/t/000755 000765 000765 00000000000 11714420735 014504 5ustar00abwabw000000 000000 Template-Toolkit-2.24/TODO000644 000765 000765 00000027043 11674036057 014744 0ustar00abwabw000000 000000 #======================================================================== # # TODO # # DESCRIPTION # TODO list for the Template Toolkit version 2.20, containing # known bugs, limitations, planned enhancements, long term visions # and a few whacky ideas. Development on TT2 has effectively # ceased for everything but bug fixes. All new features and general # enhancements are being saved for TT3. # # AUTHOR # Andy Wardley # #======================================================================== #------------------------------------------------------------------------ # Miscellaneous #------------------------------------------------------------------------ * The 'eval' filter leaks memory, as reported by Colin Johnson. The filter subroutine created contains a reference to the context and then gets cached in the FILTER_CACHE item of the context. Hey presto - circular references. The reset() method should probably clear the FILTER_CACHE. Also need to check the plugins cache for similar problems. UPDATE: this may now have been fixed. * The handling of the DELIMITER parameter could be improved. At the moments it's hardcoded and hacked to Do The Right Thing for Win32 but I'd prefer it to Do The Good Thing. * If you use 'ttree' with a COMPILE_EXT or COMPILE_DIR option then templates in the 'lib' directories will be compiled, but those in the src directories will not. This is because ttree does a chdir() to the src directory and processes files as './myfile'. TT doesn't compile RELATIVE files by default. * No recursion checking is performed for BLOCKs, only Template::Document instances. This is probably the way it will stay (unless anyone shouts loudly enough) but it should be documented anyway. STOP PRESS: I had an idea that bare BLOCK subs should be blessed into Template::Document class to allow $template->process() to be called regardless. Template::Document methods would need to test $self for CODE/HASH and Do The Right Thing. This would then allow recursion testing for BLOCKs as well as Template::Document objects. * It would be nice if there was an option so that the files generated under the COMPILE_DIR are relative to the INCLUDE_PATH and not absolute. This could cause potential conflicts (e.g. if INCLUDE_PATH changes between sessions and the same files in different INCLUDE_PATH dirs maps to the samed compiled version) but is convenient for those times when you know that's not going to be a problem. * Craig Barratt notes, in fixing the problem with NEXT not working inside SWITCH (see Changes v2.04): By the way, I came across another arcane bug: NEXT FOREACH k = [1]; is legal syntax but is an infinite loop, since $_[0]->{ INFOR } in Parser.yp is not set when the NEXT is parsed, so it generates a plain "next;" rather than calling $factor->next(). I don't see an easy, clean fix. #------------------------------------------------------------------------ # Documentation #------------------------------------------------------------------------ * Extend the FAQ. #------------------------------------------------------------------------ # Directives #------------------------------------------------------------------------ * A 'FOR', like 'FOREACH' but without using an iterator. You wouldn't get the 'loop' reference to test 'first', 'last', etc., against, but it would be faster for those cases when you didn't need it. This will likely be implemented as a facility feature (see later). * PRINT should be defined as a new directive, doing what the print() method of Template::View currently does (the Right Thing). [% PRINT node %] === [% tt.view.print(node) %] NOTE TO SELF: this is a Very Good Idea [tm]. PRINT becomes the way to display a data structure (e.g. hash, list, XML element, MyThingy, database record, etc.) in an "intelligent" fashion. Implemented underneath via the current default VIEW. * ARGS. There may be a requirement for reusable template components to define what variables they plan to use. This would allow some optimisation and also possibly help to avoid global variable clashes. Would also be a useful "comment" directive for human readers and maybe also help in debugging (WARNING: expected 'title' argument). [% ARGS title # no default bgcol='#ffffff' # default value %] #------------------------------------------------------------------------ # Parser #------------------------------------------------------------------------ * Lists don't accept arbitrary expressions as elements, although function arguments now do. So you can do this: [% foo(bar + 1) %], but you can't do this: [% foo = [bar + 1] %]. This has been fixed in the v3 parser. * The parser isn't as intelligent as it could be about blocks of template code commented out en masse. The pre-scanner find the first terminating END_TAG after an opening tag, regardless of it being on a commented line or not. e.g. [%# # # [% INCLUDE blah %] <- directive ends here # foo <- this gets printed %] * Craig Barratt reports the following: I looked at Parse.yp to see how hard it would be to push FILTER evaluation down into the expr rule, so that you could put filters inside expressions (eg: using repeat() just like "x" in perl). More about that later. In browsing through Parser.yp I noticed several issues: - The operator precedence is very different to perl, C etc. For example, these expressions evaluate differently in TT2 versus perl, C etc: + "1 || 0 && 0" evaluates to 0 in TT2 and 1 in perl or C. TT2 parses it as (1||0) && 0; in perl and C && is higher precedence than ||. + "1 + !0 + 1" evaluates to 1 in TT2 and 3 in perl or C. TT2 parses it as 1 + !(0 + 1); in perl and C ! is higher precedence than +. + Many other expressions parse incorrectly, but the effect is benign since most rules return flat text that perl correctly re-parses. Eg, 2 * 3 + 4 is incorrectly parsed as (2 * (3 + 4)), but happily just the string "2 * 3 + 4" is compiled by perl, which correctly evaluates it as (2 * 3) + 4. - There is no unary minus and the NUMBER token is signed. So you can write "x = -2;" but not "x = -y;". Moreover, "x = 1 -1;" is a syntax error (since "1 -1" returns just two tokens NUMBER, NUMBER). (As a workaround you can rewrite these as "x = 0-y;" and "x = 1 - 1".) - You cannot have expressions in lists ([..]) and function arguments. I have modified the Parser.pm (to make NUMBER unsigned) and modified Grammar.pm.skel and Parser.yp to fix most of these issues (improved operator precedence, unary minus and plus), and also to allow expressions in a few more places (eg: range). But the last item has me stuck. The parse rules for lists and function arguments make COMMA optional, so you can equivalently write [1 2 3 4] or [1,,,,,2 3 4] or [1,2,3,4]. This makes it very difficult to make each term an expression, because the resulting grammar has many ambiguities. For example, is [1 -1] two elements [1, -1] or a single element [0]? One partial solution is to move the bracketed expression rule '(' expr ')' to the term rule, allowing expressions to be included via parens. But there are also ambiguities, eg: does [foo (1+1)] have 2 elements or is it a function call to foo? Without allowing expressions in lists or function arguments, the unary minus change I've made means that the NUMBER token is unsigned, so with my changes you cannot write [-1, 2, 3]. Not a good thing. One solution is to change the grammar so that COMMAs are required in lists and arguments, but that would break several test cases and probably break lots of old templates. But this might be the only way to produce a grammar that is a lot more similar to perl. Another solution is to ignore these issues altogether and use temporary variables to precompute expressions that you need in lists or function arguments, or use explicit lvalue assignments, eg: foo(x + 2); becomes temp = x + 2; foo(temp); or List = [x+1,x+2,x+4]; becomes List = []; List.0 = x+1; List.1 = x+2; List.2 = x+4; Both of these look ugly to me. Back to the FILTER issues. Ultimately I'd like to be able to embed filters as low precedence operators in expressions, and write: List = [ "foo" | repeat(10), "bar" | repeat(10) ]; but I doubt there is a non-ambiguous upward compatible grammar that supports this. Comments? #------------------------------------------------------------------------ # Plugins #------------------------------------------------------------------------ * We need a way to easily enable/disable certain plugins. This should be addressed by facility provision. Probably something for v3. * The Template::Plugin DBI iterator first/last() methods don't behave the same as list first/last(). Randal also reports that get_all() doesn't work as it should - may be a conflict in code/docs? Again, this is a problem to solve in TT3. * PLUGINS could accept a reference to an object which is used as a singleton factory for a plugin. (NOTE: 2.01 includes PLUGIN_FACTORY to implement this, but currently undocumented because it's likely to change). * A more general solution for XML (e.g. DOM, XPath, etc) would be for TT to support a PerlSAX handler which generates the appropriate callbacks to the view. This should make it possible to easily display XML content from XML::DOM, XML::XPath, or any other SAX compliant source. Something like this: # define a view [% VIEW my_view prefix="my/xml/dom/path/" ; END %] # get some XML [% USE dom = XML.DOM %] [% doc = dom.parser(my.files.xmldata) %] # ask the view to print the data [% my_view.print(doc) %] The view print() method will call the relevant 2SAX method on the XML node, passing a SAX2TTView handler to make the relevant calls back to the view to display parts of the XML data model as SAX events are received. #------------------------------------------------------------------------ # Views #------------------------------------------------------------------------ The current implementation is there to get me (and anybody else who's interested) using it and trying to identify the problems, requirements and general issues involved. I've got a better idea now about what a VIEW should be in notional terms, but I'm still not quite sure about the syntax and API. General thoughts: * A view defines a set of templates. Things like prefix, suffix, default, etc., can be specified to customise template selection. In this sense, it is like a custom provider of those templates. It implements the template() method to fetch a template according to those rules. * It is also a custom processor of those templates. It implements the process() method. In this sense, it is like a custom context. * It also implements dispatch logic to apply the right template to the right kind of data. It does this via the print() method. It may have all kinds of custom dispatch logic. * A view takes responsiblity for things template related as opposed to anything data related (stash) or application logic related (plugins, runtime code, etc). It is the user interface facility within the engine. Template-Toolkit-2.24/xs/000755 000765 000765 00000000000 11714420735 014673 5ustar00abwabw000000 000000 Template-Toolkit-2.24/xs/Makefile.PL000644 000765 000765 00000000464 11674036057 016656 0ustar00abwabw000000 000000 # $Id$ use lib qw( ../lib ./lib ); use ExtUtils::MakeMaker; use Template; WriteMakefile( 'NAME' => 'Template::Stash::XS', 'C' => [ qw( Stash.c ) ], 'XS' => { 'Stash.xs' => 'Stash.c' }, 'OBJECT' => 'Stash.o', 'VERSION' => $Template::VERSION, 'NORECURS' => 1, ); Template-Toolkit-2.24/xs/MANIFEST000644 000765 000765 00000000045 11674036057 016030 0ustar00abwabw000000 000000 MANIFEST README Makefile.PL Stash.xs Template-Toolkit-2.24/xs/ppport.h000644 000765 000765 00000540044 11706465600 016400 0ustar00abwabw000000 000000 #if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.20 Automatically created by Devel::PPPort running under perl 5.010000. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.20 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.11.5. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagially add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL pv_display() NEED_pv_display NEED_pv_display_GLOBAL pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2010, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.20; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| BhkDISABLE||5.014000| BhkENABLE||5.014000| BhkENTRY_set||5.014000| BhkENTRY||| BhkFLAGS||| CALL_BLOCK_HOOKS||| CLASS|||n CPERLscope|5.005000||p CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV_set|5.010001||p DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_METHOD|5.006001||p G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSVn|5.009003||p GvSV||| Gv_AMupdate||5.011000| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeUTF8||5.010001| HeVAL||5.004000| HvENAME||5.013007| HvNAMELEN_get|5.009003||p HvNAME_get|5.009003||p HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LINKLIST||5.013006| LVRET||| MARK||| MULTICALL||5.014000| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| OP_CLASS||5.013007| OP_DESC||5.007003| OP_NAME||5.007003| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_DUP||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p PERL_BCDVERSION|5.014000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.004000||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.014000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.014000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_PV_ESCAPE_ALL|5.009004||p PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p PERL_PV_ESCAPE_NOCLEAR|5.009004||p PERL_PV_ESCAPE_QUOTE|5.009004||p PERL_PV_ESCAPE_RE|5.009005||p PERL_PV_ESCAPE_UNI_DETECT|5.009004||p PERL_PV_ESCAPE_UNI|5.009004||p PERL_PV_PRETTY_DUMP|5.009004||p PERL_PV_PRETTY_ELLIPSES|5.010000||p PERL_PV_PRETTY_LTGT|5.009004||p PERL_PV_PRETTY_NOCLEAR|5.010000||p PERL_PV_PRETTY_QUOTE|5.009004||p PERL_PV_PRETTY_REGPROP|5.009004||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_SYS_INIT3||5.006000| PERL_SYS_INIT||| PERL_SYS_TERM||5.014000| PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_bufend|5.014000||p PL_bufptr|5.014000||p PL_compiling|5.004050||p PL_copline|5.014000||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_error_count|5.014000||p PL_expect|5.014000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_in_my_stash|5.014000||p PL_in_my|5.014000||p PL_keyword_plugin||5.011002| PL_last_in_gv|||n PL_laststatval|5.005000||p PL_lex_state|5.014000||p PL_lex_stuff|5.014000||p PL_linestr|5.014000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofsgv|||n PL_opfreehook||5.011000|n PL_parser|5.009005|5.009005|p PL_peepp||5.007003|n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rpeepp||5.013005|n PL_rsfp_filters|5.014000||p PL_rsfp|5.014000||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p PL_tokenbuf|5.014000||p POP_MULTICALL||5.014000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2nat|5.009003||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.014000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVfARG|5.009005||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_nomg||5.013002| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK_offset||5.011000| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg_nolen||5.013007| SvPV_nomg|5.007002||p SvPV_renew|5.009003||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK||5.009005| SvRX||5.009005| SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE_nomg||5.013006| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8_MAXBYTES|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.014000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSPROTO|5.010000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_APIVERSION_BOOTCHECK||5.013004| XS_VERSION_BOOTCHECK||| XS_VERSION||| XSprePUSH|5.006000||p XS||| XopDISABLE||5.014000| XopENABLE||5.014000| XopENTRY_set||5.014000| XopENTRY||5.014000| XopFLAGS||5.013007| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _append_range_to_invlist||| _new_invlist||| _pMY_CXT|5.007003||p _swash_inversion_hash||| _swash_to_invlist||| aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.014000||p aTHXR|5.014000||p aTHX_|5.006000||p aTHX|5.006000||p add_alternate||| add_cp_to_invlist||| add_data|||n add_range_to_invlist||| add_utf16_textfilter||| addmad||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_deref_call||5.013007| amagic_i_ncmp||| amagic_ncmp||| anonymise_cv_maybe||| any_dup||| ao||| append_madprops||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| assert_uft8_cache_coherent||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| blockhook_register||5.013003| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| bytes_cmp_utf8||5.013007| bytes_from_utf8||5.007001| bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p caller_cx||5.013005| calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_type_and_open||| check_uni||| check_utf8_print||| checkcomma||| checkposixcc||| ckWARN|5.006000||p ck_entersub_args_list||5.013006| ck_entersub_args_proto_or_list||5.013006| ck_entersub_args_proto||5.013006| ck_warner_d||5.011001|v ck_warner||5.011001|v ckwarn_common||| ckwarn_d||5.009003| ckwarn||5.009003| cl_and|||n cl_anything|||n cl_init|||n cl_is_anything|||n cl_or|||n clear_placeholders||| clone_params_del|||n clone_params_new|||n closest_cop||| convert||| cop_free||| cop_hints_2hv||5.013007| cop_hints_fetch_pvn||5.013007| cop_hints_fetch_pvs||5.013007| cop_hints_fetch_pv||5.013007| cop_hints_fetch_sv||5.013007| cophh_2hv||5.013007| cophh_copy||5.013007| cophh_delete_pvn||5.013007| cophh_delete_pvs||5.013007| cophh_delete_pv||5.013007| cophh_delete_sv||5.013007| cophh_fetch_pvn||5.013007| cophh_fetch_pvs||5.013007| cophh_fetch_pv||5.013007| cophh_fetch_sv||5.013007| cophh_free||5.013007| cophh_new_empty||5.014000| cophh_store_pvn||5.013007| cophh_store_pvs||5.013007| cophh_store_pv||5.013007| cophh_store_sv||5.013007| cr_textfilter||| create_eval_scope||| croak_no_modify||5.013003| croak_nocontext|||vn croak_sv||5.013001| croak_xs_usage||5.010001| croak|||v csighandler||5.009003|n curmad||| curse||| custom_op_desc||5.007003| custom_op_name||5.007003| custom_op_register||5.013007| custom_op_xop||5.013007| cv_ckproto_len||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_get_call_checker||5.013006| cv_set_call_checker||5.013006| cv_undef||| cvgv_set||| cvstash_set||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.014000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v del_sv||| delete_eval_scope||| delimcpy||5.004000|n deprecate_commaless_var_list||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_sv||5.013001| die_unwind||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_close||| do_delete_local||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_op_xmldump||| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pmop_dump||5.006000| do_pmop_xmldump||| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| dump_all_perl||| dump_all||5.006000| dump_eval||5.006000| dump_exec_pos||| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs_perl||| dump_packsubs||5.006000| dump_sub_perl||| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| feature_is_enabled||| fetch_cop_label||5.011000| filter_add||| filter_del||| filter_gets||| filter_read||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_hash_subscript||| find_in_my_stash||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_rundefsv||5.013002| find_script||| find_uninit_var||| first_symbol|||n foldEQ_latin1||5.013008|n foldEQ_locale||5.013002|n foldEQ_utf8_flags||5.013010| foldEQ_utf8||5.013002| foldEQ||5.013002|n fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_strict_version||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_aux_mg||| get_av|5.006000||p get_context||5.006000|n get_cvn_flags|5.009005||p get_cvs|5.011000||p get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_assign_glob||| glob_assign_ref||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_bslash_c||| grok_bslash_o||| grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_add_by_type||5.011000| gv_autoload4||5.004000| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod_flags||5.011000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags|5.009002||p gv_fetchpvs|5.009004||p gv_fetchpv||| gv_fetchsv|5.009002||p gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_get_super_pkg||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_magicalize_isa||| gv_magicalize_overload||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs|5.009003||p gv_stashpv||| gv_stashsv||| gv_try_downgrade||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||5.009004| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_ename_add||| hv_ename_delete||| hv_exists_ent||5.004000| hv_exists||| hv_fetch_ent||5.004000| hv_fetchs|5.009003||p hv_fetch||| hv_fill||5.013002| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.004000| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef_flags||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush_use_sep||| incpush||| ingroup||| init_argv_symbols||| init_dbargs||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr|||n intro_my||| intuit_method||| intuit_more||| invert||| invlist_array||| invlist_destroy||| invlist_extend||| invlist_intersection||| invlist_len||| invlist_max||| invlist_set_array||| invlist_set_len||| invlist_set_max||| invlist_trim||| invlist_union||| invoke_exception_hook||| io_close||| isALNUMC|5.006000||p isALPHA||| isASCII|5.006000||p isBLANK|5.006001||p isCNTRL|5.006000||p isDIGIT||| isGRAPH|5.006000||p isGV_with_GP|5.009004||p isLOWER||| isOCTAL||5.013005| isPRINT|5.004000||p isPSXSPC|5.006001||p isPUNCT|5.006000||p isSPACE||| isUPPER||| isWORDCHAR||5.013006| isXDIGIT|5.006000||p is_an_int||| is_ascii_string||5.011000|n is_gv_magical_sv||| is_handle_constructor|||n is_inplace_av||| is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_X_LVT||| is_utf8_X_LV_LVT_V||| is_utf8_X_LV||| is_utf8_X_L||| is_utf8_X_T||| is_utf8_X_V||| is_utf8_X_begin||| is_utf8_X_extend||| is_utf8_X_non_hangul||| is_utf8_X_prepend||| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow|||n is_utf8_char||5.006000|n is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_perl_space||5.011001| is_utf8_perl_word||5.011001| is_utf8_posix_digit||5.011001| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003|n is_utf8_string_loc||5.008001|n is_utf8_string||5.006001|n is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| is_utf8_xidcont||5.013010| is_utf8_xidfirst||5.013010| isa_lookup||| items|||n ix|||n jmaybe||| join_exact||| keyword_plugin_standard||| keyword||| leave_scope||| lex_bufutf8||5.011002| lex_discard_to||5.011002| lex_grow_linestr||5.011002| lex_next_chunk||5.011002| lex_peek_unichar||5.011002| lex_read_space||5.011002| lex_read_to||5.011002| lex_read_unichar||5.011002| lex_start||5.009005| lex_stuff_pvn||5.011002| lex_stuff_pvs||5.013005| lex_stuff_pv||5.013006| lex_stuff_sv||5.011002| lex_unstuff||5.011002| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.010001||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.010001||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhints||| magic_clearhint||| magic_clearisa||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall1||| magic_methcall|||v magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| make_matcher||| make_trie_failtable||| make_trie||| malloc_good_size|||n malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQs|5.009005||p memEQ|5.004000||p memNEs|5.009005||p memNE|5.004000||p mem_collxfrm||| mem_log_common|||n mess_alloc||| mess_nocontext|||vn mess_sv||5.013001| mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_findext||5.013008| mg_find||| mg_free_type||5.013006| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| more_bodies||| more_sv||| moreswitches||| mro_clean_isarev||| mro_gather_and_rename||| mro_get_from_name||5.010001| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_get_private_data||5.010001| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mro_package_moved||| mro_register||5.010001| mro_set_mro||5.010001| mro_set_private_data||5.010001| mul128||| mulexp10|||n munge_qwlist_to_paren_list||| my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat_flags||| my_lstat||5.014000| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf|5.009003||pvn my_stat_flags||| my_stat||5.014000| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_swabn|||n my_swap||| my_unexec||| my_vsnprintf||5.009004|n need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||5.013007| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMADPROP||| newMADsv||| newMYSUB||| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSV_type|5.009005||p newSVhek||5.009003| newSViv||| newSVnv||| newSVpv_share||5.013006| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.010001||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.010001||p newSVpvn|5.004050||p newSVpvs_flags|5.010001||p newSVpvs_share|5.009003||p newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newTOKEN||| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.013007| newXS_flags||5.009004| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr|||n no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n oopsAV||| oopsHV||| op_append_elem||5.013006| op_append_list||5.013006| op_clear||| op_const_sv||| op_contextualize||5.013006| op_dump||5.006000| op_free||| op_getmad_weak||| op_getmad||| op_linklist||5.013006| op_lvalue||5.013007| op_null||5.007002| op_prepend_elem||5.013006| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_scope||5.013007| op_xmldump||| open_script||| opt_scalarhv||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package_version||| package||| packlist||5.008001| pad_add_anon||| pad_add_name_sv||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||5.011002| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_peg|||n pad_push||| pad_reset||| pad_setsv||| pad_sv||| pad_swipe||| pad_tidy||| padlist_dup||| parse_arithexpr||5.013008| parse_barestmt||5.013007| parse_block||5.013007| parse_body||| parse_fullexpr||5.013008| parse_fullstmt||5.013005| parse_label||5.013007| parse_listexpr||5.013008| parse_stmtseq||5.013006| parse_termexpr||5.013008| parse_unicode_opts||| parser_dup||| parser_free||| path_is_absolute|||n peep||| pending_Slabs_to_ro||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmop_dump||5.006000| pmop_xmldump||| pmruntime||| pmtrans||| pop_scope||| populate_isa|||v pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prepend_madprops||| prescan_version||5.011004| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_byte||| pv_display|5.006000||p pv_escape|5.009004||p pv_pretty|5.009004||p pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup_guts||| re_intuit_start||5.009005| re_intuit_string||5.006000| readpipe_override||| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch_pvn||| refcounted_he_fetch_pvs||| refcounted_he_fetch_pv||| refcounted_he_fetch_sv||| refcounted_he_free||| refcounted_he_inc||| refcounted_he_new_pvn||| refcounted_he_new_pvs||| refcounted_he_new_pv||| refcounted_he_new_sv||| refcounted_he_value||| refkids||| refto||| ref||5.014000| reg_check_named_buff_matched||| reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_namedseq||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment||| reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly||| regdump_extflags||| regdump||5.005000| regdupe_internal||| regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regpiece||| regpposixcc||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reguni||| regwhite|||n reg||| repeatcpy|||n report_evil_fh||| report_uninit||| report_wrongway_fh||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr|||n rpeep||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rv2cv_op_cv||5.013006| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_adelete||5.011000| save_aelem_flags||5.011000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hdelete||5.011000| save_hek_flags|||n save_helem_flags||5.011000| save_helem||5.004050| save_hints||5.010001| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||5.005000| save_padsv_and_mortalize||5.010001| save_pptr||| save_pushi32ptr||5.010001| save_pushptri32ptr||| save_pushptrptr||5.010001| save_pushptr||5.010001| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpvs||5.013006| savesharedpv||5.007003| savesharedsvpv||5.013006| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| screaminstr||5.005000| search_const||| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| set_regclass_bit_fold||| set_regclass_bit||| setdefout||| share_hek_flags||| share_hek||5.004000| si_dup||| sighandler|||n simplify_sort||| skipspace0||| skipspace1||| skipspace2||| skipspace||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| stack_grow||| start_force||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.014000| stdize_locale||| store_cop_label||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool_flags||5.013006| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv_flags||5.013001| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_flags||5.013006| sv_catpv_mg|5.004050||p sv_catpv_nomg||5.013006| sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs_flags||5.013006| sv_catpvs_mg||5.013006| sv_catpvs_nomg||5.013006| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_catxmlpvn||| sv_catxmlpv||| sv_catxmlsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_flags||5.013006| sv_cmp_locale_flags||5.013006| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm_flags||5.013006| sv_collxfrm||| sv_compile_2op_is_broken||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec_nomg||5.013002| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_does||5.009004| sv_dump||| sv_dup_common||| sv_dup_inc_multiple||| sv_dup_inc||| sv_dup||| sv_eq_flags||5.013006| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_i_ncmp||| sv_inc_nomg||5.013002| sv_inc||| sv_insert_flags||5.010001| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.014000|5.004000|p sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_flags||5.011005| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs_mg||5.013006| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pvs||5.013006| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagicext||5.013008| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags_grow||5.011000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade_nomg||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p sv_xmlpeek||| svtype||| swallow_bom||| swash_fetch||5.007002| swash_get||| swash_init||5.006000| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tied_method|||v tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| token_free||| token_getmad||| tokenize_use||| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| try_amagic_bin||| try_amagic_un||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unreferenced_to_tmp_stack||| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_textfilter||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_len_cache_update||| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warn_sv||5.013001| warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v watch||| whichsig||| with_queued_errors||| write_no_mem||| write_to_stderr||| xmldump_all_perl||| xmldump_all||| xmldump_attr||| xmldump_eval||| xmldump_form||| xmldump_indent|||v xmldump_packsubs_perl||| xmldump_packsubs||| xmldump_sub_perl||| xmldump_sub||| xmldump_vindent||| xs_apiversion_bootcheck||| xs_version_bootcheck||| yyerror||| yylex||| yyparse||| yyunlex||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; for $d (map { s/\s+//g; $_ } split /,/, $1) { push @{$depends{$d}}, @deps; } } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (eval \$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef memEQs # define memEQs(s1, l, s2) \ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) #endif #ifndef memNEs # define memNEs(s1, l, s2) !memEQs(s1, l, s2) #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif #endif #ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR # define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV # define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV # define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV # define PTR2NV(p) NUM2PTR(NV,p) #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef DEFSV_set # define DEFSV_set(sv) (DEFSV = (sv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef XSPROTO # define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef CPERLscope # define CPERLscope(x) x #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif /* provide these typedefs for older perls */ #if (PERL_BCDVERSION < 0x5009003) # ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef isPSXSPC # define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef EBCDIC #ifndef isALNUMC # define isALNUMC(c) isalnum(c) #endif #ifndef isASCII # define isASCII(c) isascii(c) #endif #ifndef isCNTRL # define isCNTRL(c) iscntrl(c) #endif #ifndef isGRAPH # define isGRAPH(c) isgraph(c) #endif #ifndef isPRINT # define isPRINT(c) isprint(c) #endif #ifndef isPUNCT # define isPUNCT(c) ispunct(c) #endif #ifndef isXDIGIT # define isXDIGIT(c) isxdigit(c) #endif #else # if (PERL_BCDVERSION < 0x5010000) /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # endif #ifndef isALNUMC # define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isASCII # define isASCII(c) ((U8) (c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((U8) (c) < ' ' || (c) == 127) #endif #ifndef isGRAPH # define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif #ifndef isPRINT # define isPRINT(c) (((c) >= 32 && (c) < 127)) #endif #ifndef isPUNCT # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) #endif #ifndef isXDIGIT # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_bufend bufend # define PL_bufptr bufptr # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_error_count error_count # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_in_my in_my # define PL_laststatval laststatval # define PL_lex_state lex_state # define PL_lex_stuff lex_stuff # define PL_linestr linestr # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting # define PL_tokenbuf tokenbuf /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't * use it if you can avoid is and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of * a dummy parser structure. */ #if (PERL_BCDVERSION >= 0x5009005) # ifdef DPPP_PL_parser_NO_DUMMY # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) # else # ifdef DPPP_PL_parser_NO_DUMMY_WARNING # define D_PPP_parser_dummy_warning(var) # else # define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), # endif # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif # endif /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf * Do not use this variable unless you know exactly what you're * doint. It is internal to the perl parser and may change or even * be removed in the future. As of perl 5.9.5, you have to check * for (PL_parser != NULL) for this variable to have any effect. * An always non-NULL PL_parser dummy is provided for earlier * perl versions. * If PL_parser is NULL when you try to access this variable, a * dummy is being accessed instead and a warning is issued unless * you define DPPP_PL_parser_NO_DUMMY_WARNING. * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access * this variable will croak with a panic message. */ # define PL_expect D_PPP_my_PL_parser_var(expect) # define PL_copline D_PPP_my_PL_parser_var(copline) # define PL_rsfp D_PPP_my_PL_parser_var(rsfp) # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) # define PL_linestr D_PPP_my_PL_parser_var(linestr) # define PL_bufptr D_PPP_my_PL_parser_var(bufptr) # define PL_bufend D_PPP_my_PL_parser_var(bufend) # define PL_lex_state D_PPP_my_PL_parser_var(lex_state) # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) # define PL_in_my D_PPP_my_PL_parser_var(in_my) # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) # define PL_error_count D_PPP_my_PL_parser_var(error_count) #else /* ensure that PL_parser != NULL and cannot be dereferenced */ # define PL_parser ((void *) 1) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif /* Replace: 0 */ #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv # undef call_sv # endif # if (PERL_BCDVERSION < 0x5006000) # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) # else # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) # endif #endif /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ #define D_PPP_PL_copline PL_copline void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #ifdef newSV_type # undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) # define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else # define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvPV_renew # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif /* Hint: newSVpvn_share * The SVs created by this function only mimic the behaviour of * shared PVs without really being shared. Only use if you know * what you're doing. */ #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef GvSVn # define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP # define isGV_with_GP(gv) isGV(gv) #endif #ifndef gv_fetchpvn_flags # define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) #endif #ifndef gv_fetchsv # define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) #endif #ifndef get_cvn_flags # define get_cvn_flags(name, namelen, flags) get_cv(name, flags) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef newSVpvs_share # define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef gv_fetchpvs # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef get_cvs # define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE # define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES # define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT # define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI # define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT # define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL # define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR # define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE # define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif /* Hint: pv_escape * Note that unicode functionality is only backported to * those perl versions that support it. For older perl * versions, the implementation will fall back to bytes. */ #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #ifdef pv_escape # undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr) isuni ? utf8_to_uvchr((U8*)pv, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%"UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%"UVxf"}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : /* fallthrough */ case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #ifdef pv_pretty # undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #ifdef pv_display # undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Template-Toolkit-2.24/xs/README000644 000765 000765 00000005160 11674036057 015562 0ustar00abwabw000000 000000 ---------------------------------------------------------------------- Template::Stash::XS August 2001 ---------------------------------------------------------------------- Introduction: * This is an XS implementation of the Template::Stash module, based in part upon work that Andy Wardley did late last year. It is an alternative version of the core Template::Stash methods ''get'' and ''set'' (the ones that should benefit most from a speedy C implementation), along with some virtual methods (like first, last, reverse, etc.) Doug Steinwand took the original code and made it into the fast and fully functional version you see here. Our appreciation is due to Ticketmaster, Inc. (http://www.ticketmaster.com/) who funded Doug's work on this to the benefit of us all. You can run the additional test script ''tt-bench.pl'' to see the improvement in speed. You may need to install the BSD::Resource module -- see http://search.cpan.org/search?dist=BSD-Resource perl tt-bench.pl Additional Notes: * Depending upon the size and content of a template, this version has about twice the speed of the original Template::Stash. * When a virtual method (like pop, push, nsort, sort etc.) has not been implemented in XS, it uses these hashrefs in Template::Stash package -- $HASH_OPS, $LIST_OPS, and $SCALAR_OPS -- to call perl subroutines that can do the work. * Using the ''reference'' feature of Template Toolkit -- like [% a = \foo %] -- leaks a large amount of memory. Enable the template code at the end of ''tt-bench.pl'' for a demonstration. (Note: This is a problem in the pure-perl version, too. Also, you'll need a platform that fully supports getrusage() -- FreeBSD and IRIX are two that should work. Otherwise, use a utility like ''top''. ) * Although it passes all the tests that I've thrown at it, there may still be some problems and/or bugs. My primary goal was to mirror the behavior of the pure-perl version using XS. (NOTE: The XS Stash has subsequently been tested by numerous people on the Template Toolkit mailing list and everyone has reported 100% success and notable speedups - abw) * Profiling code can be enabled with ''#define TT_PERF_ENABLE'' in the Stash.xs source, but doing so hurts performance a bit. The results can be displayed by adding the line: print Template::Stash::XS::performance(1); to your code. Use 0 instead of 1 for a more compact display. * There's no need to try crazy compiler optimizations on this code, because a majority of time is spent inside Perl's functions. Template-Toolkit-2.24/xs/Stash.xs000644 000765 000765 00000117551 11714420616 016341 0ustar00abwabw000000 000000 /*===================================================================== * * Template::Stash::XS (Stash.xs) * * DESCRIPTION * This is an XS implementation of the Template::Stash module. * It is an alternative version of the core Template::Stash methods * ''get'' and ''set'' (the ones that should benefit most from a * speedy C implementation), along with some virtual methods (like * first, last, reverse, etc.) * * AUTHORS * Andy Wardley * Doug Steinwand * * COPYRIGHT * Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. * Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. * * This module is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * * NOTE * Be very familiar with the perlguts, perlxs, perlxstut and * perlapi manpages before digging through this code. * *=====================================================================*/ #ifdef __cplusplus extern "C" { #endif #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #define NEED_sv_2pv_flags #define NEED_newRV_noinc #include "ppport.h" #include "XSUB.h" #ifdef __cplusplus } #endif #if defined(_MSC_VER) || defined(__SUNPRO_C) #define debug() #else #ifdef WIN32 #define debug(format) #else #define debug(...) /* #define debug(...) fprintf(stderr, __VA_ARGS__) */ #endif #endif #ifdef WIN32 #define snprintf _snprintf #endif #define TT_STASH_PKG "Template::Stash::XS" #define TT_LIST_OPS "Template::Stash::LIST_OPS" #define TT_HASH_OPS "Template::Stash::HASH_OPS" #define TT_SCALAR_OPS "Template::Stash::SCALAR_OPS" #define TT_PRIVATE "Template::Stash::PRIVATE" #define TT_LVALUE_FLAG 1 #define TT_DEBUG_FLAG 2 #define TT_DEFAULT_FLAG 4 typedef enum tt_ret { TT_RET_UNDEF, TT_RET_OK, TT_RET_CODEREF } TT_RET; static TT_RET hash_op(pTHX_ SV*, char*, AV*, SV**, int); static TT_RET list_op(pTHX_ SV*, char*, AV*, SV**); static TT_RET scalar_op(pTHX_ SV*, char*, AV*, SV**, int); static TT_RET tt_fetch_item(pTHX_ SV*, SV*, AV*, SV**); static TT_RET autobox_list_op(pTHX_ SV*, char*, AV*, SV**, int); static SV* dotop(pTHX_ SV*, SV*, AV*, int); static SV* call_coderef(pTHX_ SV*, AV*); static SV* fold_results(pTHX_ I32); static SV* find_perl_op(pTHX_ char*, char*); static AV* mk_mortal_av(pTHX_ SV*, AV*, SV*); static SV* do_getset(pTHX_ SV*, AV*, SV*, int); static AV* convert_dotted_string(pTHX_ const char*, I32); static int get_debug_flag(pTHX_ SV*); static int cmp_arg(const void *, const void *); static int looks_private(pTHX_ const char*); static void die_object(pTHX_ SV *); static struct xs_arg *find_xs_op(char *); static SV* list_dot_first(pTHX_ AV*, AV*); static SV* list_dot_join(pTHX_ AV*, AV*); static SV* list_dot_last(pTHX_ AV*, AV*); static SV* list_dot_max(pTHX_ AV*, AV*); static SV* list_dot_reverse(pTHX_ AV*, AV*); static SV* list_dot_size(pTHX_ AV*, AV*); static SV* hash_dot_each(pTHX_ HV*, AV*); static SV* hash_dot_keys(pTHX_ HV*, AV*); static SV* hash_dot_values(pTHX_ HV*, AV*); static SV* scalar_dot_defined(pTHX_ SV*, AV*); static SV* scalar_dot_length(pTHX_ SV*, AV*); #define THROW_SIZE 64 static char throw_fmt[] = "Can't locate object method \"%s\" via package \"%s\""; /* dispatch table for XS versions of special "virtual methods", * names must be in alphabetical order */ static const struct xs_arg { const char *name; SV* (*list_f) (pTHX_ AV*, AV*); SV* (*hash_f) (pTHX_ HV*, AV*); SV* (*scalar_f) (pTHX_ SV*, AV*); } xs_args[] = { /* name list (AV) ops. hash (HV) ops. scalar (SV) ops. -------- ---------------- --------------- ------------------ */ { "defined", NULL, NULL, scalar_dot_defined }, { "each", NULL, hash_dot_each, NULL }, /* { "first", list_dot_first, NULL, NULL }, */ { "join", list_dot_join, NULL, NULL }, { "keys", NULL, hash_dot_keys, NULL }, /* { "last", list_dot_last, NULL, NULL }, */ { "length", NULL, NULL, scalar_dot_length }, { "max", list_dot_max, NULL, NULL }, { "reverse", list_dot_reverse, NULL, NULL }, { "size", list_dot_size, NULL, NULL }, { "values", NULL, hash_dot_values, NULL }, }; /*------------------------------------------------------------------------ * tt_fetch_item(pTHX_ SV *root, SV *key_sv, AV *args, SV **result) * * Retrieves an item from the given hash or array ref. If item is found * and a coderef then the coderef will be called and passed args. Returns * TT_RET_CODEREF or TT_RET_OK and sets result. If not found, returns * TT_RET_UNDEF and result is undefined. *------------------------------------------------------------------------*/ static TT_RET tt_fetch_item(pTHX_ SV *root, SV *key_sv, AV *args, SV **result) { STRLEN key_len; char *key = SvPV(key_sv, key_len); SV **value = NULL; #ifndef WIN32 debug("fetch item: %s\n", key); #endif /* negative key_len is used to indicate UTF8 string */ if (SvUTF8(key_sv)) key_len = -key_len; if (!SvROK(root)) return TT_RET_UNDEF; switch (SvTYPE(SvRV(root))) { case SVt_PVHV: value = hv_fetch((HV *) SvRV(root), key, key_len, FALSE); break; case SVt_PVAV: if (looks_like_number(key_sv)) value = av_fetch((AV *) SvRV(root), SvIV(key_sv), FALSE); break; } if (value) { /* trigger any tied magic to FETCH value */ SvGETMAGIC(*value); /* call if a coderef */ if (SvROK(*value) && (SvTYPE(SvRV(*value)) == SVt_PVCV) && !sv_isobject(*value)) { *result = call_coderef(aTHX_ *value, args); return TT_RET_CODEREF; } else if (SvOK(*value)) { *result = *value; return TT_RET_OK; } } *result = &PL_sv_undef; return TT_RET_UNDEF; } /*------------------------------------------------------------------------ * dotop(pTHX_ SV *root, SV *key_sv, AV *args, int flags) * * Resolves dot operations of the form root.key, where 'root' is a * reference to the root item, 'key_sv' is an SV containing the * operation key (e.g. hash key, list index, first, last, each, etc), * 'args' is a list of additional arguments and 'TT_LVALUE_FLAG' is a * flag to indicate if, for certain operations (e.g. hash key), the item * should be created if it doesn't exist. Also, 'TT_DEBUG_FLAG' is the * debug flag. *------------------------------------------------------------------------*/ static SV *dotop(pTHX_ SV *root, SV *key_sv, AV *args, int flags) { dSP; STRLEN item_len; char *item = SvPV(key_sv, item_len); SV *result = &PL_sv_undef; I32 atroot; #ifndef WIN32 debug("dotop(%s)\n", item); #endif /* ignore _private or .private members */ if (!root || looks_private(aTHX_ item)) return &PL_sv_undef; if (SvROK(root)) { atroot = sv_derived_from(root, TT_STASH_PKG); if (atroot || ((SvTYPE(SvRV(root)) == SVt_PVHV) && !sv_isobject(root))) { /* root is a HASH or Template::Stash */ switch(tt_fetch_item(aTHX_ root, key_sv, args, &result)) { case TT_RET_OK: /* return immediately */ return result; break; case TT_RET_CODEREF: /* fall through */ break; default: /* for lvalue, create an intermediate hash */ if (flags & TT_LVALUE_FLAG) { SV *newhash; HV *roothv = (HV *) SvRV(root); newhash = SvREFCNT_inc((SV *) newRV_noinc((SV *) newHV())); debug("- auto-vivifying intermediate hash\n"); if (hv_store(roothv, item, item_len, newhash, 0)) { /* trigger any tied magic to STORE value */ SvSETMAGIC(newhash); } else { SvREFCNT_dec(newhash); } return sv_2mortal(newhash); } /* try hash virtual method (not at stash root, except import) */ if ((! atroot || (strcmp(item, "import") == 0)) && hash_op(aTHX_ root, item, args, &result, flags) == TT_RET_UNDEF) { /* try hash slice */ if (SvROK(key_sv) && SvTYPE(SvRV(key_sv)) == SVt_PVAV) { AV *a_av = newAV(); AV *k_av = (AV *) SvRV(key_sv); HV *r_hv = (HV *) SvRV(root); char *t; I32 i; STRLEN tlen; SV **svp; for (i = 0; i <= av_len(k_av); i++) { if ((svp = av_fetch(k_av, i, 0))) { SvGETMAGIC(*svp); t = SvPV(*svp, tlen); if((svp = hv_fetch(r_hv, t, tlen, FALSE))) { SvGETMAGIC(*svp); av_push(a_av, SvREFCNT_inc(*svp)); } } } return sv_2mortal(newRV_noinc((SV *) a_av)); } } } } else if ((SvTYPE(SvRV(root)) == SVt_PVAV) && !sv_isobject(root)) { /* root is an ARRAY, try list virtuals */ if (list_op(aTHX_ root, item, args, &result) == TT_RET_UNDEF) { switch (tt_fetch_item(aTHX_ root, key_sv, args, &result)) { case TT_RET_OK: return result; break; case TT_RET_CODEREF: break; default: /* try array slice */ if (SvROK(key_sv) && SvTYPE(SvRV(key_sv)) == SVt_PVAV) { AV *a_av = newAV(); AV *k_av = (AV *) SvRV(key_sv); AV *r_av = (AV *) SvRV(root); I32 i; SV **svp; for (i = 0; i <= av_len(k_av); i++) { if ((svp = av_fetch(k_av, i, FALSE))) { SvGETMAGIC(*svp); if (looks_like_number(*svp) && (svp = av_fetch(r_av, SvIV(*svp), FALSE))) { SvGETMAGIC(*svp); av_push(a_av, SvREFCNT_inc(*svp)); } } } return sv_2mortal(newRV_noinc((SV *) a_av)); } } } } else if (sv_isobject(root)) { /* root is an object */ I32 n, i; SV **svp; HV *stash = SvSTASH((SV *) SvRV(root)); GV *gv; /* char *error_string; */ result = NULL; if ((gv = gv_fetchmethod_autoload(stash, item, 1))) { /* eval { @result = $root->$item(@$args); }; */ PUSHMARK(SP); XPUSHs(root); n = (args && args != Nullav) ? av_len(args) : -1; for (i = 0; i <= n; i++) if ((svp = av_fetch(args, i, 0))) XPUSHs(*svp); PUTBACK; n = call_method(item, G_ARRAY | G_EVAL); SPAGAIN; if (SvTRUE(ERRSV)) { char throw_str[THROW_SIZE+1]; (void) POPs; /* remove undef from stack */ PUTBACK; result = NULL; /* if we get an exception object throw ($@ is a * ref) or a error other than "Can't locate object * method "blah"" then it's a real error that need * to be re-thrown. */ if (SvROK(ERRSV)) { die_object(aTHX_ ERRSV); } else { /* We use throw_str to construct the error message * that indicates a missing method. We use snprintf() to * avoid overflowing throw_str, and always ensure the * last character is NULL (if the item name is too long * to fit into throw_str then snprintf() doesn't add the * terminating NULL */ snprintf(throw_str, THROW_SIZE, throw_fmt, item, HvNAME(stash)); throw_str[THROW_SIZE] = '\0'; if (! strstr( SvPV(ERRSV, PL_na), throw_str)) die_object(aTHX_ ERRSV); } } else { result = fold_results(aTHX_ n); } } if (!result) { /* failed to call object method, so try some fallbacks */ if (SvTYPE(SvRV(root)) == SVt_PVHV) { /* hash based object - first try to fetch item */ switch(tt_fetch_item(aTHX_ root, key_sv, args, &result)) { case TT_RET_OK: /* return immediately */ return result; break; case TT_RET_CODEREF: /* fall through */ break; default: /* then try hash vmethod if that failed */ if (hash_op(aTHX_ root, item, args, &result, flags) == TT_RET_OK) return result; /* hash_op() will also try list_op([$hash]) */ } } else if (SvTYPE(SvRV(root)) == SVt_PVAV) { /* list based object - first try to fetch item */ switch (tt_fetch_item(aTHX_ root, key_sv, args, &result)) { case TT_RET_OK: /* return immediately */ return result; break; case TT_RET_CODEREF: /* fall through */ break; default: /* try list vmethod */ if (list_op(aTHX_ root, item, args, &result) == TT_RET_OK) return result; } } else if (scalar_op(aTHX_ root, item, args, &result, flags) == TT_RET_OK) { /* scalar_op() will also try list_op([$scalar]) */ return result; } else if (flags & TT_DEBUG_FLAG) { result = (SV *) mk_mortal_av(aTHX_ &PL_sv_undef, NULL, ERRSV); } } } } /* it doesn't look like we've got a reference to anything we know about, * so let's try the SCALAR_OPS pseudo-methods (but not for l-values) */ else if (!(flags & TT_LVALUE_FLAG) && (scalar_op(aTHX_ root, item, args, &result, flags) == TT_RET_UNDEF)) { if (flags & TT_DEBUG_FLAG) croak("don't know how to access [ %s ].%s\n", SvPV(root, PL_na), item); } /* if we have an arrayref and the first element is defined then * everything is peachy, otherwise some ugliness may have occurred */ if (SvROK(result) && SvTYPE(SvRV(result)) == SVt_PVAV) { SV **svp; AV *array = (AV *) SvRV(result); I32 len = (array == Nullav) ? 0 : (av_len(array) + 1); if (len) { svp = av_fetch(array, 0, FALSE); if (svp && (*svp != &PL_sv_undef)) { return result; } } } if ((flags & TT_DEBUG_FLAG) && (!result || !SvOK(result) || (result == &PL_sv_undef))) { croak("%s is undefined\n", item); } return result; } /*------------------------------------------------------------------------ * assign(pTHX_ SV *root, SV *key_sv, AV *args, SV *value, int flags) * * Resolves the final assignment element of a dotted compound variable * of the form "root.key(args) = value". 'root' is a reference to * the root item, 'key_sv' is an SV containing the operation key * (e.g. hash key, list item, object method), 'args' is a list of user * provided arguments (passed only to object methods), 'value' is the * assignment value to be set (appended to args) and 'deflt' (default) * is a flag to indicate that the assignment should only be performed * if the item is currently undefined/false. *------------------------------------------------------------------------*/ static SV *assign(pTHX_ SV *root, SV *key_sv, AV *args, SV *value, int flags) { dSP; SV **svp, *newsv; HV *roothv; AV *rootav; STRLEN key_len; char *key = SvPV(key_sv, key_len); char *key2 = SvPV(key_sv, key_len); /* TMP DEBUG HACK */ #ifndef WIN32 debug("assign(%s)\n", key2); #endif /* negative key_len is used to indicate UTF8 string */ if (SvUTF8(key_sv)) key_len = -key_len; if (!root || !SvOK(key_sv) || key_sv == &PL_sv_undef || looks_private(aTHX_ key)) { /* ignore _private or .private members */ return &PL_sv_undef; } else if (SvROK(root)) { /* see if root is an object (but not Template::Stash) */ if (sv_isobject(root) && !sv_derived_from(root, TT_STASH_PKG)) { HV *stash = SvSTASH((SV *) SvRV(root)); GV *gv; /* look for the named method, or an AUTOLOAD method */ if ((gv = gv_fetchmethod_autoload(stash, key, 1))) { I32 count = (args && args != Nullav) ? av_len(args) : -1; I32 i; /* push args and value onto stack, then call method */ PUSHMARK(SP); XPUSHs(root); for (i = 0; i <= count; i++) { if ((svp = av_fetch(args, i, FALSE))) XPUSHs(*svp); } XPUSHs(value); PUTBACK; debug(" - calling object method\n"); count = call_method(key, G_ARRAY); SPAGAIN; return fold_results(aTHX_ count); } } /* drop-through if not an object or method not found */ switch (SvTYPE(SvRV(root))) { case SVt_PVHV: /* HASH */ roothv = (HV *) SvRV(root); debug(" - hash assign\n"); /* check for any existing value if ''default'' flag set */ if ((flags & TT_DEFAULT_FLAG) && (svp = hv_fetch(roothv, key, key_len, FALSE))) { /* invoke any tied magical FETCH method */ debug(" - fetched default\n"); SvGETMAGIC(*svp); if (SvTRUE(*svp)) return &PL_sv_undef; } /* avoid 'modification of read-only value' error */ newsv = newSVsv(value); hv_store(roothv, key, key_len, newsv, 0); SvSETMAGIC(newsv); return value; break; case SVt_PVAV: /* ARRAY */ rootav = (AV *) SvRV(root); debug(" - list assign\n"); if (looks_like_number(key_sv)) { /* if the TT_DEFAULT_FLAG is set then first look to see if the * target is already set to some true value; if it is then * we return that value (after invoking any SvGETMAGIC required * for tied arrays) and bypass the assignment altogether */ if ( (flags & TT_DEFAULT_FLAG) && (svp = av_fetch(rootav, SvIV(key_sv), FALSE))) { debug(" - fetched default, invoking any tied magic\n"); SvGETMAGIC(*svp); if (SvTRUE(*svp)) return &PL_sv_undef; } /* create a new SV for the value and call av_store(), * incrementing the reference count on the way; we * then invoke any set magic for tied arrays; if the * return value from av_store is NULL (as appears to * be the case with tied arrays - although the same * isn't true of hv_store() for some reason???) then * we decrement the reference counter because that's * what perlguts tells us to do... */ newsv = newSVsv(value); svp = av_store(rootav, SvIV(key_sv), newsv); SvSETMAGIC(newsv); return value; } else return &PL_sv_undef; break; default: /* BARF */ /* TODO: fix [ %s ] */ croak("don't know how to assign to [ %s ].%s", SvPV(SvRV(root), PL_na), key); } } else { /* SCALAR */ /* TODO: fix [ %s ] */ croak("don't know how to assign to [ %s ].%s", SvPV(SvRV(root), PL_na), key); } /* not reached */ return &PL_sv_undef; /* just in case */ } /* dies and passes back a blessed object, * or just a string if it's not blessed */ static void die_object (pTHX_ SV *err) { if (sv_isobject(err) || SvROK(err)) { /* throw object via ERRSV ($@) */ SV *errsv = get_sv("@", TRUE); sv_setsv(errsv, err); (void) die(Nullch); } /* error string sent back via croak() */ croak("%s", SvPV(err, PL_na)); } /* pushes any arguments in 'args' onto the stack then calls the code ref * in 'code'. Calls fold_results() to return a listref or die. */ static SV *call_coderef(pTHX_ SV *code, AV *args) { dSP; SV **svp; I32 count = (args && args != Nullav) ? av_len(args) : -1; I32 i; PUSHMARK(SP); for (i = 0; i <= count; i++) if ((svp = av_fetch(args, i, FALSE))) XPUSHs(*svp); PUTBACK; count = call_sv(code, G_ARRAY|G_EVAL); SPAGAIN; if (SvTRUE(ERRSV)) { die_object(aTHX_ ERRSV); } return fold_results(aTHX_ count); } /* pops 'count' items off the stack, folding them into a list reference * if count > 1, or returning the sole item if count == 1. * Returns undef if count == 0. * Dies if first value of list is undef */ static SV* fold_results(pTHX_ I32 count) { dSP; SV *retval = &PL_sv_undef; if (count > 1) { /* convert multiple return items into a list reference */ AV *av = newAV(); SV *last_sv = &PL_sv_undef; SV *sv = &PL_sv_undef; I32 i; av_extend(av, count - 1); for(i = 1; i <= count; i++) { last_sv = sv; sv = POPs; if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv))) SvREFCNT_dec(sv); } PUTBACK; retval = sv_2mortal((SV *) newRV_noinc((SV *) av)); if (!SvOK(sv) || sv == &PL_sv_undef) { /* if first element was undef, die */ die_object(aTHX_ last_sv); } return retval; } else { if (count) retval = POPs; PUTBACK; return retval; } } /* Iterates through array calling dotop() to resolve all items * Skips the last if ''value'' is non-NULL. * If ''value'' is non-NULL, calls assign() to do the assignment. * * SV *root; AV *ident_av; SV *value; int flags; * */ static SV* do_getset(pTHX_ SV *root, AV *ident_av, SV *value, int flags) { AV *key_args; SV *key; SV **svp; I32 end_loop, i, size = av_len(ident_av); if (value) { /* make some adjustments for assign mode */ end_loop = size - 1; flags |= TT_LVALUE_FLAG; } else { end_loop = size; } for(i = 0; i < end_loop; i += 2) { if (!(svp = av_fetch(ident_av, i, FALSE))) croak(TT_STASH_PKG " %cet: bad element %i", value ? 's' : 'g', i); key = *svp; if (!(svp = av_fetch(ident_av, i + 1, FALSE))) croak(TT_STASH_PKG " %cet: bad arg. %i", value ? 's' : 'g', i + 1); if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) key_args = (AV *) SvRV(*svp); else key_args = Nullav; root = dotop(aTHX_ root, key, key_args, flags); if (!root || !SvOK(root)) return root; } if (value && SvROK(root)) { /* call assign() to resolve the last item */ if (!(svp = av_fetch(ident_av, size - 1, FALSE))) croak(TT_STASH_PKG ": set bad ident element at %i", i); key = *svp; if (!(svp = av_fetch(ident_av, size, FALSE))) croak(TT_STASH_PKG ": set bad ident argument at %i", i + 1); if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) key_args = (AV *) SvRV(*svp); else key_args = Nullav; return assign(aTHX_ root, key, key_args, value, flags); } return root; } /* return [ map { s/\(.*$//; ($_, 0) } split(/\./, $str) ]; */ static AV *convert_dotted_string(pTHX_ const char *str, I32 len) { AV *av = newAV(); char *buf, *b; int b_len = 0; New(0, buf, len + 1, char); if (!buf) croak(TT_STASH_PKG ": New() failed for convert_dotted_string"); for(b = buf; len >= 0; str++, len--) { if (*str == '(') { for(; (len > 0) && (*str != '.'); str++, len--) ; } if ((len < 1) || (*str == '.')) { *b = '\0'; av_push(av, newSVpv(buf, b_len)); av_push(av, newSViv((IV) 0)); b = buf; b_len = 0; } else { *b++ = *str; b_len++; } } Safefree(buf); return (AV *) sv_2mortal((SV *) av); } /* performs a generic hash operation identified by 'key' * (e.g. keys, * values, each) on 'hash'. * returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise. */ static TT_RET hash_op(pTHX_ SV *root, char *key, AV *args, SV **result, int flags) { struct xs_arg *a; SV *code; TT_RET retval; /* look for XS version first */ if ((a = find_xs_op(key)) && a->hash_f) { *result = a->hash_f(aTHX_ (HV *) SvRV(root), args); return TT_RET_CODEREF; } /* look for perl version in Template::Stash module */ if ((code = find_perl_op(aTHX_ key, TT_HASH_OPS))) { *result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ root, args, NULL)); return TT_RET_CODEREF; } /* try upgrading item to a list and look for a list op */ if (!(flags & TT_LVALUE_FLAG)) { /* hash.method ==> [hash].method */ return autobox_list_op(aTHX_ root, key, args, result, flags); } /* not found */ *result = &PL_sv_undef; return TT_RET_UNDEF; } /* performs a generic list operation identified by 'key' on 'list'. * Additional arguments may be passed in 'args'. * returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise. */ static TT_RET list_op(pTHX_ SV *root, char *key, AV *args, SV **result) { struct xs_arg *a; SV *code; /* look for and execute XS version first */ if ((a = find_xs_op(key)) && a->list_f) { #ifndef WIN32 debug("calling internal list vmethod: %s\n", key); #endif *result = a->list_f(aTHX_ (AV *) SvRV(root), args); return TT_RET_CODEREF; } /* look for and execute perl version in Template::Stash module */ if ((code = find_perl_op(aTHX_ key, TT_LIST_OPS))) { #ifndef WIN32 debug("calling perl list vmethod: %s\n", key); #endif *result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ root, args, NULL)); return TT_RET_CODEREF; } #ifndef WIN32 debug("list vmethod not found: %s\n", key); #endif /* not found */ *result = &PL_sv_undef; return TT_RET_UNDEF; } /* Performs a generic scalar operation identified by 'key' * on 'sv'. Additional arguments may be passed in 'args'. * returns TT_RET_CODEREF if successful, TT_RET_UNDEF otherwise. */ static TT_RET scalar_op(pTHX_ SV *sv, char *key, AV *args, SV **result, int flags) { struct xs_arg *a; SV *code; TT_RET retval; /* look for a XS version first */ if ((a = find_xs_op(key)) && a->scalar_f) { *result = a->scalar_f(aTHX_ sv, args); return TT_RET_CODEREF; } /* look for perl version in Template::Stash module */ if ((code = find_perl_op(aTHX_ key, TT_SCALAR_OPS))) { *result = call_coderef(aTHX_ code, mk_mortal_av(aTHX_ sv, args, NULL)); return TT_RET_CODEREF; } /* try upgrading item to a list and look for a list op */ if (!(flags & TT_LVALUE_FLAG)) { /* scalar.method ==> [scalar].method */ return autobox_list_op(aTHX_ sv, key, args, result, flags); } /* not found */ *result = &PL_sv_undef; return TT_RET_UNDEF; } static TT_RET autobox_list_op(pTHX_ SV *sv, char *key, AV *args, SV **result, int flags) { AV *av = newAV(); SV *avref = (SV *) newRV_inc((SV *) av); TT_RET retval; av_push(av, SvREFCNT_inc(sv)); retval = list_op(aTHX_ avref, key, args, result); SvREFCNT_dec(av); SvREFCNT_dec(avref); return retval; } /* xs_arg comparison function */ static int cmp_arg(const void *a, const void *b) { return (strcmp(((const struct xs_arg *)a)->name, ((const struct xs_arg *)b)->name)); } /* Searches the xs_arg table for key */ static struct xs_arg *find_xs_op(char *key) { struct xs_arg *ap, tmp; tmp.name = key; if ((ap = (struct xs_arg *) bsearch(&tmp, xs_args, sizeof(xs_args)/sizeof(struct xs_arg), sizeof(struct xs_arg), cmp_arg))) return ap; return NULL; } /* Searches the perl Template::Stash.pm module for ''key'' in the * hashref named ''perl_var''. Returns SV if found, NULL otherwise. */ static SV *find_perl_op(pTHX_ char *key, char *perl_var) { SV *tt_ops; SV **svp; if ((tt_ops = get_sv(perl_var, FALSE)) && SvROK(tt_ops) && (svp = hv_fetch((HV *) SvRV(tt_ops), key, strlen(key), FALSE)) && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) return *svp; return NULL; } /* Returns: @a = ($sv, @av, $more) */ static AV *mk_mortal_av(pTHX_ SV *sv, AV *av, SV *more) { SV **svp; AV *a; I32 i = 0, size; a = newAV(); av_push(a, SvREFCNT_inc(sv)); if (av && (size = av_len(av)) > -1) { av_extend(a, size + 1); for (i = 0; i <= size; i++) if ((svp = av_fetch(av, i, FALSE))) if(!av_store(a, i + 1, SvREFCNT_inc(*svp))) SvREFCNT_dec(*svp); } if (more && SvOK(more)) if (!av_store(a, i + 1, SvREFCNT_inc(more))) SvREFCNT_dec(more); return (AV *) sv_2mortal((SV *) a); } /* Returns TT_DEBUG_FLAG if _DEBUG key is true in hashref ''sv''. */ static int get_debug_flag (pTHX_ SV *sv) { const char *key = "_DEBUG"; const I32 len = 6; SV **debug; if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVHV) && (debug = hv_fetch((HV *) SvRV(sv), (char *) key, len, FALSE)) && SvOK(*debug) && SvTRUE(*debug)) return TT_DEBUG_FLAG; return 0; } static int looks_private(pTHX_ const char *name) { /* SV *priv; */ /* For now we hard-code the regex to match _private or .hidden * variables, but we do check to see if $Template::Stash::PRIVATE * is defined, allowing a user to undef it to defeat the check. * The better solution would be to match the string using the regex * defined in the $PRIVATE package varible, but I've been searching * for well over an hour now and I can't find any documentation or * examples showing me how to match a string against a pre-compiled * regex from XS. The Perl internals docs really suck in places. */ if (SvTRUE(get_sv(TT_PRIVATE, FALSE))) { return (*name == '_' || *name == '.'); } return 0; } /* XS versions of some common dot operations * ----------------------------------------- */ /* list.first */ static SV *list_dot_first(pTHX_ AV *list, AV *args) { SV **svp; if ((svp = av_fetch(list, 0, FALSE))) { /* entry fetched from arry may be code ref */ if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) { return call_coderef(aTHX_ *svp, args); } else { return *svp; } } return &PL_sv_undef; } /* list.join */ static SV *list_dot_join(pTHX_ AV *list, AV *args) { SV **svp; SV *item, *retval; I32 size, i; STRLEN jlen; char *joint; if (args && (svp = av_fetch(args, 0, FALSE)) != NULL) { joint = SvPV(*svp, jlen); } else { joint = " "; jlen = 1; } retval = newSVpvn("", 0); size = av_len(list); for (i = 0; i <= size; i++) { if ((svp = av_fetch(list, i, FALSE)) != NULL) { item = *svp; if (SvROK(item) && SvTYPE(SvRV(item)) == SVt_PVCV) { item = call_coderef(aTHX_ *svp, args); sv_catsv(retval, item); } else { sv_catsv(retval, item); } if (i != size) sv_catpvn(retval, joint, jlen); } } return sv_2mortal(retval); } /* list.last */ static SV *list_dot_last(pTHX_ AV *list, AV *args) { SV **svp; if ((av_len(list) > -1) && (svp = av_fetch(list, av_len(list), FALSE))) { /* entry fetched from arry may be code ref */ if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) { return call_coderef(aTHX_ *svp, args); } else { return *svp; } } return &PL_sv_undef; } /* list.max */ static SV *list_dot_max(pTHX_ AV *list, AV *args) { return sv_2mortal(newSViv((IV) av_len(list))); } /* list.reverse */ static SV *list_dot_reverse(pTHX_ AV *list, AV *args) { SV **svp; AV *result = newAV(); I32 size, i; if ((size = av_len(list)) >= 0) { av_extend(result, size + 1); for (i = 0; i <= size; i++) { if ((svp = av_fetch(list, i, FALSE)) != NULL) if (!av_store(result, size - i, SvREFCNT_inc(*svp))) SvREFCNT_dec(*svp); } } return sv_2mortal((SV *) newRV_noinc((SV *) result)); } /* list.size */ static SV *list_dot_size(pTHX_ AV *list, AV *args) { return sv_2mortal(newSViv((IV) av_len(list) + 1)); } /* hash.each */ static SV *hash_dot_each(pTHX_ HV *hash, AV *args) { AV *result = newAV(); HE *he; hv_iterinit(hash); while ((he = hv_iternext(hash))) { av_push(result, SvREFCNT_inc((SV *) hv_iterkeysv(he))); av_push(result, SvREFCNT_inc((SV *) hv_iterval(hash, he))); } return sv_2mortal((SV *) newRV_noinc((SV *) result)); } /* hash.keys */ static SV *hash_dot_keys(pTHX_ HV *hash, AV *args) { AV *result = newAV(); HE *he; hv_iterinit(hash); while ((he = hv_iternext(hash))) av_push(result, SvREFCNT_inc((SV *) hv_iterkeysv(he))); return sv_2mortal((SV *) newRV_noinc((SV *) result)); } /* hash.values */ static SV *hash_dot_values(pTHX_ HV *hash, AV *args) { AV *result = newAV(); HE *he; hv_iterinit(hash); while ((he = hv_iternext(hash))) av_push(result, SvREFCNT_inc((SV *) hv_iterval(hash, he))); return sv_2mortal((SV *) newRV_noinc((SV *) result)); } /* scalar.defined */ static SV *scalar_dot_defined(pTHX_ SV *sv, AV *args) { return &PL_sv_yes; } /* scalar.length */ static SV *scalar_dot_length(pTHX_ SV *sv, AV *args) { return sv_2mortal(newSViv((IV) SvUTF8(sv) ? sv_len_utf8(sv): sv_len(sv))); } /*==================================================================== * XS SECTION *====================================================================*/ MODULE = Template::Stash::XS PACKAGE = Template::Stash::XS PROTOTYPES: DISABLED #----------------------------------------------------------------------- # get(SV *root, SV *ident, SV *args) #----------------------------------------------------------------------- SV * get(root, ident, ...) SV *root SV *ident CODE: AV *args; int flags = get_debug_flag(aTHX_ root); int n; STRLEN len; char *str; /* look for a list ref of arguments, passed as third argument */ args = (items > 2 && SvROK(ST(2)) && SvTYPE(SvRV(ST(2))) == SVt_PVAV) ? (AV *) SvRV(ST(2)) : Nullav; if (SvROK(ident) && (SvTYPE(SvRV(ident)) == SVt_PVAV)) { RETVAL = do_getset(aTHX_ root, (AV *) SvRV(ident), NULL, flags); } else if (SvROK(ident)) { croak(TT_STASH_PKG ": get (arg 2) must be a scalar or listref"); } else if ((str = SvPV(ident, len)) && memchr(str, '.', len)) { /* convert dotted string into an array */ AV *av = convert_dotted_string(aTHX_ str, len); RETVAL = do_getset(aTHX_ root, av, NULL, flags); av_undef(av); } else { /* otherwise ident is a scalar so we call dotop() just once */ RETVAL = dotop(aTHX_ root, ident, args, flags); } if (!SvOK(RETVAL)) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(root); XPUSHs(ident); PUTBACK; n = call_method("undefined", G_SCALAR); SPAGAIN; if (n != 1) croak("undefined() did not return a single value\n"); RETVAL = SvREFCNT_inc(POPs); PUTBACK; FREETMPS; LEAVE; } else RETVAL = SvREFCNT_inc(RETVAL); OUTPUT: RETVAL #----------------------------------------------------------------------- # set(SV *root, SV *ident, SV *value, SV *deflt) #----------------------------------------------------------------------- SV * set(root, ident, value, ...) SV *root SV *ident SV *value CODE: int flags = get_debug_flag(aTHX_ root); STRLEN len; char *str; /* check default flag passed as fourth argument */ flags |= ((items > 3) && SvTRUE(ST(3))) ? TT_DEFAULT_FLAG : 0; if (SvROK(ident) && (SvTYPE(SvRV(ident)) == SVt_PVAV)) { RETVAL = do_getset(aTHX_ root, (AV *) SvRV(ident), value, flags); } else if (SvROK(ident)) { croak(TT_STASH_PKG ": set (arg 2) must be a scalar or listref"); } else if ((str = SvPV(ident, len)) && memchr(str, '.', len)) { /* convert dotted string into a temporary array */ AV *av = convert_dotted_string(aTHX_ str, len); RETVAL = do_getset(aTHX_ root, av, value, flags); av_undef(av); } else { /* otherwise a simple scalar so call assign() just once */ RETVAL = assign(aTHX_ root, ident, Nullav, value, flags); } if (!SvOK(RETVAL)) RETVAL = newSVpvn("", 0); /* new empty string */ else RETVAL = SvREFCNT_inc(RETVAL); OUTPUT: RETVAL Template-Toolkit-2.24/t/args.t000644 000765 000765 00000004636 11674036057 015643 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/args.t # # Testing the passing of positional and named arguments to sub-routine and # object methods. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Constants qw( :status ); $^W = 1; #------------------------------------------------------------------------ # define simple object and package sub for reporting arguments passed #------------------------------------------------------------------------ package MyObj; use base qw( Template::Base ); sub foo { my $self = shift; return "object:\n" . args(@_); } sub args { my @args = @_; my $named = ref $args[$#args] eq 'HASH' ? pop @args : { }; local $" = ', '; return " ARGS: [ @args ]\n NAMED: { " . join(', ', map { "$_ => $named->{ $_ }" } sort keys %$named) . " }\n"; } #------------------------------------------------------------------------ # main tests #------------------------------------------------------------------------ package main; use Template::Parser; $Template::Test::DEBUG = 0; $Template::Parser::DEBUG = 0; my $replace = callsign(); $replace->{ args } = \&MyObj::args; $replace->{ obj } = MyObj->new(); test_expect(\*DATA, { INTERPOLATE => 1 }, $replace); __DATA__ -- test -- [% args(a b c) %] -- expect -- ARGS: [ alpha, bravo, charlie ] NAMED: { } -- test -- [% args(a b c d=e f=g) %] -- expect -- ARGS: [ alpha, bravo, charlie ] NAMED: { d => echo, f => golf } -- test -- [% args(a, b, c, d=e, f=g) %] -- expect -- ARGS: [ alpha, bravo, charlie ] NAMED: { d => echo, f => golf } -- test -- [% args(a, b, c, d=e, f=g,) %] -- expect -- ARGS: [ alpha, bravo, charlie ] NAMED: { d => echo, f => golf } -- test -- [% args(d=e, a, b, f=g, c) %] -- expect -- ARGS: [ alpha, bravo, charlie ] NAMED: { d => echo, f => golf } -- test -- [% obj.foo(d=e, a, b, f=g, c) %] -- expect -- object: ARGS: [ alpha, bravo, charlie ] NAMED: { d => echo, f => golf } -- test -- [% obj.foo(d=e, a, b, f=g, c).split("\n").1 %] -- expect -- ARGS: [ alpha, bravo, charlie ] Template-Toolkit-2.24/t/assert.t000644 000765 000765 00000005043 11674036057 016201 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/assert.t # # Test the assert plugin which throws error if undefined values are # returned. # # Written by Andy Wardley # # Copyright (C) 1996-2008 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ../blib/lib ../blib/arch ); use Template::Test; #------------------------------------------------------------------------ # definition of test object class #------------------------------------------------------------------------ package Template::Test::Object; sub new { bless {}, shift; } sub nil { return undef; } #----------------------------------------------------------------------- # main #----------------------------------------------------------------------- package main; my $vars = { object => Template::Test::Object->new, hash => { foo => 10, bar => undef }, list => [ undef ], subref => sub { return undef }, nothing => undef, }; test_expect(\*DATA, undef, $vars); #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ -- test -- ([% object.nil %]) -- expect -- () -- test -- [% USE assert; TRY; object.assert.nil; CATCH; error; END; "\n"; TRY; object.assert.zip; CATCH; error; END; %] -- expect -- assert error - undefined value for nil assert error - undefined value for zip -- test -- [% USE assert; TRY; hash.assert.bar; CATCH; error; END; "\n"; TRY; hash.assert.bam; CATCH; error; END; %] -- expect -- assert error - undefined value for bar assert error - undefined value for bam -- test -- [% USE assert; TRY; list.assert.0; CATCH; error; END; "\n"; TRY; list.assert.first; CATCH; error; END; %] -- expect -- assert error - undefined value for 0 assert error - undefined value for first -- test -- [% USE assert; TRY; list.assert.0; CATCH; error; END; "\n"; TRY; list.assert.first; CATCH; error; END; %] -- expect -- assert error - undefined value for 0 assert error - undefined value for first -- test -- [% USE assert; TRY; assert.nothing; CATCH; error; END; %] -- expect -- assert error - undefined value for nothing -- test -- [% USE assert; TRY; assert.subref; CATCH; error; END; %] -- expect -- assert error - undefined value for subref Template-Toolkit-2.24/t/base.t000644 000765 000765 00000007156 11674036057 015621 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/base.t # # Test the Template::Base.pm module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; ntests(24); #------------------------------------------------------------------------ # a dummy module, derived from Template::Base and destined for failure #------------------------------------------------------------------------ package Template::Fail; use base qw( Template::Base ); use vars qw( $ERROR ); use Template::Base; sub _init { my $self = shift; return $self->error('expected failure'); } #------------------------------------------------------------------------ # another dummy module, expecting a 'name' parameter #------------------------------------------------------------------------ package Template::Named; use base qw( Template::Base ); use vars qw( $ERROR ); use Template::Base; sub _init { my ($self, $params) = @_; $self->{ NAME } = $params->{ name } || return $self->error("No name!"); return $self; } sub name { $_[0]->{ NAME }; } #------------------------------------------------------------------------ # module to test version #------------------------------------------------------------------------ package Template::Version; use Template::Base; use base qw( Template::Base ); use vars qw( $ERROR $VERSION ); $VERSION = 3.14; #------------------------------------------------------------------------ # main package, run some tests #------------------------------------------------------------------------ package main; my ($mod, $pkg); # instantiate a base class object and test error reporting/returning $mod = Template::Base->new(); ok( $mod ); $mod->error('barf'); ok( $mod->error() eq 'barf' ); # Template::Fail should never work, but we check it reports errors OK ok( ! Template::Fail->new() ); ok( Template::Fail->error eq 'expected failure'); ok( $Template::Fail::ERROR eq 'expected failure'); # Template::Named should only work with a 'name'parameters $mod = Template::Named->new(); ok( ! $mod ); ok( $Template::Named::ERROR eq 'No name!' ); ok( Template::Named->error() eq 'No name!' ); # give it what it wants... $mod = Template::Named->new({ name => 'foo' }); ok( $mod ); ok( $mod->name() eq 'foo' ); ok( ! $mod->error() ); # ... in 2 different flavours $mod = Template::Named->new(name => 'foo'); ok( $mod ); ok( $mod->name() eq 'foo' ); ok( ! $mod->error() ); # test the use of error() for setting and retrieving object errors ok( ! defined $mod->error('more errors') ); ok( $mod->error() eq 'more errors' ); # check package error is still set, then clear. ok( Template::Named->error() eq 'No name!' ); $Template::Named::ERROR = ''; # test via $pkg indirection $pkg = 'Template::Named'; $mod = $pkg->new(); ok( ! $mod ); ok( $pkg->error eq 'No name!' ); $mod = $pkg->new({ name => 'bar' }); ok( $mod && $mod->name eq 'bar' ); ok( ! $mod->error ); #------------------------------------------------------------------------ # test module_version() method #------------------------------------------------------------------------ $pkg = 'Template::Version'; is( $pkg->module_version(), 3.14, 'package version' ); my $obj = $pkg->new() || die $pkg->error(); ok( $obj, 'created a version object' ); is( $obj->module_version(), 3.14, 'object version' ); Template-Toolkit-2.24/t/binop.t000644 000765 000765 00000011506 11674036057 016010 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/binop.t # # Template script testing the conditional binary operators: and/&&, or/||, # not/!, <, >, <=, >= , == and !=. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ../lib ); use Template::Test; use Template::Parser; $^W = 1; $Template::Test::DEBUG = 0; $Template::Parser::DEBUG = 0; my $counter = 0; my $params = { 'yes' => 1, 'no' => 0, 'true' => 'this is true', 'false' => '0', 'happy' => 'yes', 'sad' => '', 'ten' => 10, 'twenty' => 20, 'alpha' => sub { return ++$counter }, 'omega' => sub { $counter += 10; return 0 }, 'count' => sub { return $counter }, 'reset' => sub { return $counter == 0 }, }; my $template = Template->new({ INTERPOLATE => 1, POST_CHOMP => 1 }); test_expect(\*DATA, $template, $params); __DATA__ maybe [% IF yes %] yes [% END %] -- expect -- maybe yes -- test -- [% IF yes %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF yes %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF yes and true %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF yes && true %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF yes && sad || happy %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF yes AND ten && true and twenty && 30 %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF ! yes %] no [% ELSE %] yes [% END %] -- expect -- yes -- test -- [% UNLESS yes %] no [% ELSE %] yes [% END %] -- expect -- yes -- test -- [% "yes" UNLESS no %] -- expect -- yes -- test -- [% IF ! yes %] no [% ELSE %] yes [% END %] -- expect -- yes -- test -- [% IF yes || no %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF yes || no || true || false %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF yes or no %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF not false and not sad %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF ten == 10 %] yes [% ELSE %] no [% END %] -- expect -- yes -- test -- [% IF ten == twenty %] I canna break the laws of mathematics, Captain. [% ELSIF ten > twenty %] Your numerical system is inverted. Please reboot your Universe. [% ELSIF twenty < ten %] Your inverted system is numerical. Please universe your reboot. [% ELSE %] Normality is restored. Anything you can't cope with is your own problem. [% END %] -- expect -- Normality is restored. Anything you can't cope with is your own problem. -- test -- [% IF ten >= twenty or false %] no [% ELSIF twenty <= ten %] nope [% END %] nothing -- expect -- nothing -- test -- [% IF ten >= twenty or false %] no [% ELSIF twenty <= ten %] nope [% END %] nothing -- expect -- nothing -- test -- [% IF ten > twenty %] no [% ELSIF ten < twenty %] yep [% END %] -- expect -- yep -- test -- [% IF ten != 10 %] no [% ELSIF ten == 10 %] yep [% END %] -- expect -- yep #------------------------------------------------------------------------ # test short-circuit operations #------------------------------------------------------------------------ -- test -- [% IF alpha AND omega %] alpha and omega are true [% ELSE %] alpha and/or omega are not true [% END %] count: [% count %] -- expect -- alpha and/or omega are not true count: 11 -- test -- [% IF omega AND alpha %] omega and alpha are true [% ELSE %] omega and/or alpha are not true [% END %] count: [% count %] -- expect -- omega and/or alpha are not true count: 21 -- test -- [% IF alpha OR omega %] alpha and/or omega are true [% ELSE %] neither alpha nor omega are true [% END %] count: [% count %] -- expect -- alpha and/or omega are true count: 22 -- test -- [% IF omega OR alpha %] alpha and/or omega are true [% ELSE %] neither alpha nor omega are true [% END %] count: [% count %] -- expect -- alpha and/or omega are true count: 33 -- test -- [% small = 5 mid = 7 big = 10 both = small + big less = big - mid half = big / small left = big % mid mult = big * small %] both: [% both +%] less: [% less +%] half: [% half +%] left: [% left +%] mult: [% mult +%] maxi: [% mult + 2 * 2 +%] mega: [% mult * 2 + 2 * 3 %] -- expect -- both: 15 less: 3 half: 2 left: 3 mult: 50 maxi: 54 mega: 106 -- test -- [% 10 mod 4 +%] [% 10 MOD 4 +%] [% 10 div 3 %] [% 10 DIV 3 %] -- expect -- 2 2 3 3 -- stop -- # this is for testing the lt operator which isn't enabled by default. -- test -- [% IF 'one' lt 'two' -%] one is less than two [% ELSE -%] ERROR! [% END -%] -- expect -- one is less than two Template-Toolkit-2.24/t/block.t000644 000765 000765 00000005317 11674036057 015776 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/block.t # # Template script testing BLOCK definitions. A BLOCK defined in a # template incorporated via INCLUDE should not be visible (i.e. # exported) to the calling template. In the same case for PROCESS, # the block should become visible. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; my $ttcfg = { INCLUDE_PATH => [ qw( t/test/lib test/lib ) ], POST_CHOMP => 1, BLOCKS => { header => '[% title %]', footer => '', block_a => sub { return 'this is block a' }, block_b => sub { return 'this is block b' }, }, }; test_expect(\*DATA, $ttcfg, &callsign); __DATA__ -- test -- [% BLOCK block1 %] This is the original block1 [% END %] [% INCLUDE block1 %] [% INCLUDE blockdef %] [% INCLUDE block1 %] -- expect -- This is the original block1 start of blockdef end of blockdef This is the original block1 -- test -- [% BLOCK block1 %] This is the original block1 [% END %] [% INCLUDE block1 %] [% PROCESS blockdef %] [% INCLUDE block1 %] -- expect -- This is the original block1 start of blockdef end of blockdef This is block 1, defined in blockdef, a is alpha -- test -- [% INCLUDE block_a +%] [% INCLUDE block_b %] -- expect -- this is block a this is block b -- test -- [% INCLUDE header title = 'A New Beginning' +%] A long time ago in a galaxy far, far away... [% PROCESS footer %] -- expect -- A New Beginning A long time ago in a galaxy far, far away... -- test -- [% BLOCK foo:bar %] blah [% END %] [% PROCESS foo:bar %] -- expect -- blah -- test -- [% BLOCK 'hello html' -%] Hello World! [% END -%] [% PROCESS 'hello html' %] -- expect -- Hello World! -- test -- <[% INCLUDE foo %]> [% BLOCK foo %][% END %] -- expect -- <> -- stop -- # these test the experimental BLOCK args feature which will hopefully allow # parser/eval options to be set for different blocks -- test -- [% BLOCK foo eval_perl=0 tags="star" -%] This is the foo block [% END -%] foo: [% INCLUDE foo %] -- expect -- foo: This is the foo block -- test -- [% BLOCK eval_perl=0 tags="star" -%] This is an anonymous block [% END -%] -- expect -- This is an anonymous block Template-Toolkit-2.24/t/blocks.t000644 000765 000765 00000004320 11674036057 016152 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/blocks.t # # Test ability to INCLUDE/PROCESS a block in a template. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Provider; use Cwd; $^W = 1; my $DEBUG = grep(/-d/, @ARGV); #$Template::Parser::DEBUG = $DEBUG; #$Template::Directive::PRETTY = $DEBUG; $Template::Provider::DEBUG = $DEBUG; #$Template::Context::DEBUG = $DEBUG; my $path = cwd; my $dir = -d 'test/lib' ? "$path/test/lib" : "$path/t/test/lib"; my $tt1 = Template->new({ INCLUDE_PATH => [ qw( t/test/lib test/lib ) ], ABSOLUTE => 1, }); my $tt2 = Template->new({ INCLUDE_PATH => [ qw( t/test/lib test/lib ) ], EXPOSE_BLOCKS => 1, ABSOLUTE => 1, }); my $vars = { a => 'alpha', b => 'bravo', dir => $dir, }; test_expect(\*DATA, [ off => $tt1, on => $tt2 ], $vars); __DATA__ -- test -- [% TRY; INCLUDE blockdef/block1; CATCH; error; END %] -- expect -- file error - blockdef/block1: not found -- test -- -- use on -- [% INCLUDE blockdef/block1 %] -- expect -- This is block 1, defined in blockdef, a is alpha -- test -- [% INCLUDE blockdef/block1 a='amazing' %] -- expect -- This is block 1, defined in blockdef, a is amazing -- test -- [% TRY; INCLUDE blockdef/none; CATCH; error; END %] -- expect -- file error - blockdef/none: not found -- test -- [% INCLUDE "$dir/blockdef/block1" a='abstract' %] -- expect -- This is block 1, defined in blockdef, a is abstract -- test -- [% BLOCK one -%] block one [% BLOCK two -%] this is block two, b is [% b %] [% END -%] two has been defined, let's now include it [% INCLUDE one/two b='brilliant' -%] end of block one [% END -%] [% INCLUDE one -%] = [% INCLUDE one/two b='brazen'-%] --expect -- block one two has been defined, let's now include it this is block two, b is brilliant end of block one = this is block two, b is brazen Template-Toolkit-2.24/t/capture.t000644 000765 000765 00000003134 11674036057 016342 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/capture.t # # Test that the output from a directive block can be assigned to a # variable. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; my $config = { POST_CHOMP => 1, }; my $replace = { a => 'alpha', b => 'bravo', }; test_expect(\*DATA, $config, $replace); __DATA__ -- test -- [% BLOCK foo %] This is block foo, a is [% a %] [% END %] [% b = INCLUDE foo %] [% c = INCLUDE foo a = 'ammended' %] b: <[% b %]> c: <[% c %]> -- expect -- b: c: -- test -- [% d = BLOCK %] This is the block, a is [% a %] [% END %] [% a = 'charlie' %] a: [% a %] d: [% d %] -- expect -- a: charlie d: This is the block, a is alpha -- test -- [% e = IF a == 'alpha' %] a is [% a %] [% ELSE %] that was unexpected [% END %] e: [% e %] -- expect -- e: a is alpha -- test -- [% a = FOREACH b = [1 2 3] %] [% b %], [%- END %] a is [% a %] -- expect -- a is 1,2,3, -- test -- [% BLOCK userinfo %] name: [% user +%] [% END %] [% out = PROCESS userinfo FOREACH user = [ 'tom', 'dick', 'larry' ] %] Output: [% out %] -- expect -- Output: name: tom name: dick name: larry Template-Toolkit-2.24/t/case.t000644 000765 000765 00000002727 11674036057 015621 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/case.t # # Test the CASE sensitivity option. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; ok(1); my $ttdef = Template->new({ POST_CHOMP => 1, }); my $ttanycase = Template->new({ ANYCASE => 1, POST_CHOMP => 1, }); my $tts = [ default => $ttdef, anycase => $ttanycase ]; test_expect(\*DATA, $tts, callsign()); __DATA__ -- test -- [% include = a %] [% for = b %] i([% include %]) f([% for %]) -- expect -- i(alpha) f(bravo) -- test -- [% IF a AND b %] good [% ELSE %] bad [% END %] -- expect -- good -- test -- # 'and', 'or' and 'not' can ALWAYS be expressed in lower case, regardless # of CASE sensitivity option. [% IF a and b %] good [% ELSE %] bad [% END %] -- expect -- good -- test -- [% include = a %] [% include %] -- expect -- alpha -- test -- -- use anycase -- [% include foo bar='baz' %] [% BLOCK foo %]this is foo, bar = [% bar %][% END %] -- expect -- this is foo, bar = baz -- test -- [% 10 div 3 %] [% 10 DIV 3 +%] [% 10 mod 3 %] [% 10 MOD 3 %] -- expect -- 3 3 1 1 Template-Toolkit-2.24/t/cgi.t000644 000765 000765 00000004001 11674036057 015433 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/cgi.t # # Test the CGI plugin. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ../lib ); use Template; use Template::Test; $^W = 1; #$Template::Parser::DEBUG = 1; #$Template::Parser::PRETTY = 1; #$Template::Stash::DEBUG = 1; eval "use CGI"; if ($@) { skip_all("no CGI module"); } my $cgi = CGI->new(''); $cgi = join("\n", $cgi->checkbox_group( -name => 'words', -values => [ 'eenie', 'meenie', 'minie', 'moe' ], -defaults => [ 'eenie', 'meenie' ], )); test_expect(\*DATA, undef, { cgicheck => $cgi, barf => \&barf }); sub barf { carp('failed'); } __END__ -- test -- [% USE cgi = CGI('id=abw&name=Andy+Wardley'); global.cgi = cgi -%] name: [% global.cgi.param('name') %] -- expect -- name: Andy Wardley -- test -- name: [% global.cgi.param('name') %] -- expect -- name: Andy Wardley -- test -- [% FOREACH key = global.cgi.param.sort -%] * [% key %] : [% global.cgi.param(key) %] [% END %] -- expect -- * id : abw * name : Andy Wardley -- test -- [% FOREACH key = global.cgi.param().sort -%] * [% key %] : [% global.cgi.param(key) %] [% END %] -- expect -- * id : abw * name : Andy Wardley -- test -- [% FOREACH x = global.cgi.checkbox_group( name => 'words' values => [ 'eenie', 'meenie', 'minie', 'moe' ] defaults => [ 'eenie', 'meenie' ] ) -%] [% x %] [% END %] -- expect -- -- process -- [% cgicheck %] -- test -- [% USE cgi('item=foo&items=one&items=two') -%] item: [% cgi.params.item %] item: [% cgi.params.item.join(', ') %] items: [% cgi.params.items.join(', ') %] -- expect -- item: foo item: foo items: one, two Template-Toolkit-2.24/t/chomp.t000644 000765 000765 00000017332 11674036057 016012 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/chomp.t # # Test the PRE_CHOMP and POST_CHOMP options. # # Written by Andy Wardley # # Copyright (C) 1996-2009 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template::Test; use Template::Constants qw( :chomp ); # uncomment these lines for debugging the generated Perl code #$Template::Directive::PRETTY = 1; #$Template::Parser::DEBUG = 1; match( CHOMP_NONE, 0 ); match( CHOMP_ONE, 1 ); match( CHOMP_ALL, 1 ); match( CHOMP_COLLAPSE, 2 ); match( CHOMP_GREEDY, 3 ); my $foo = "\n[% foo %]\n"; my $bar = "\n[%- bar -%]\n"; my $baz = "\n[%+ baz +%]\n"; my $ding = "!\n\n[%~ ding ~%]\n\n!"; my $dong = "!\n\n[%= dong =%]\n\n!"; my $dang = "Hello[%# blah blah blah -%]\n!"; my $winsux1 = "[% ding -%]\015\012[% dong %]"; my $winsux2 = "[% ding -%]\015\012\015\012[% dong %]"; my $winsux3 = "[% ding %]\015\012[%- dong %]"; my $winsux4 = "[% ding %]\015\012\015\012[%- dong %]"; my $blocks = { foo => $foo, bar => $bar, baz => $baz, ding => $ding, dong => $dong, dang => $dang, winsux1 => $winsux1, winsux2 => $winsux2, winsux3 => $winsux3, winsux4 => $winsux4, }; # script may be being run in distribution root or 't' directory my $dir = -d 't' ? 't/test/lib' : 'test/lib'; #------------------------------------------------------------------------ # tests without any CHOMP options set #------------------------------------------------------------------------ my $tt2 = Template->new({ BLOCKS => $blocks, INCLUDE_PATH => $dir, }); my $vars = { foo => 3.14, bar => 2.718, baz => 1.618, ding => 'Hello', dong => 'World' }; my $out; ok( $tt2->process('foo', $vars, \$out), 'foo' ); match( $out, "\n3.14\n", 'foo out' ); $out = ''; ok( $tt2->process('bar', $vars, \$out), 'bar' ); match( $out, "2.718", 'bar out' ); $out = ''; ok( $tt2->process('baz', $vars, \$out), 'baz' ); match( $out, "\n1.618\n", 'baz out' ); $out = ''; ok( $tt2->process('ding', $vars, \$out), 'ding' ); match( $out, "!Hello!", 'ding out' ); $out = ''; ok( $tt2->process('dong', $vars, \$out), 'dong' ); match( $out, "! World !", 'dong out' ); $out = ''; ok( $tt2->process('dang', $vars, \$out), 'dang' ); match( $out, "Hello!", 'dang out' ); $out = ''; ok( $tt2->process('winsux1', $vars, \$out), 'winsux1' ); match( od($out), "HelloWorld", 'winsux1 out' ); $out = ''; ok( $tt2->process('winsux2', $vars, \$out), 'winsux2' ); match( od($out), 'Hello\015\012World', 'winsux2 out' ); $out = ''; ok( $tt2->process('winsux3', $vars, \$out), 'winsux3' ); match( od($out), "HelloWorld", 'winsux3 out' ); $out = ''; ok( $tt2->process('winsux4', $vars, \$out), 'winsux4' ); match( od($out), 'Hello\015\012World', 'winsux4 out' ); $out = ''; ok( $tt2->process('dos_newlines', $vars, \$out), 'dos_newlines' ); match( $out, "HelloWorld", 'dos_newlines out' ); sub od{ join( '', map { my $ord = ord($_); ($ord > 127 || $ord < 32 ) ? sprintf '\0%lo', $ord : $_ } split //, shift() ); } #------------------------------------------------------------------------ # tests with the PRE_CHOMP option set #------------------------------------------------------------------------ $tt2 = Template->new({ PRE_CHOMP => 1, BLOCKS => $blocks, }); $out = ''; ok( $tt2->process('foo', $vars, \$out), 'pre pi' ); match( $out, "3.14\n", 'pre pi match' ); $out = ''; ok( $tt2->process('bar', $vars, \$out), 'pre e' ); match( $out, "2.718", 'pre e match' ); $out = ''; ok( $tt2->process('baz', $vars, \$out), 'pre phi' ); match( $out, "\n1.618\n", 'pre phi match' ); $out = ''; ok( $tt2->process('ding', $vars, \$out), 'pre hello' ); match( $out, "!Hello!", 'pre hello match' ); $out = ''; ok( $tt2->process('dong', $vars, \$out), 'pre world' ); match( $out, "! World !", 'pre world match' ); #------------------------------------------------------------------------ # tests with the POST_CHOMP option set #------------------------------------------------------------------------ $tt2 = Template->new({ POST_CHOMP => 1, BLOCKS => $blocks, }); $out = ''; ok( $tt2->process('foo', $vars, \$out), 'post pi' ); match( $out, "\n3.14", 'post pi match' ); $out = ''; ok( $tt2->process('bar', $vars, \$out), 'post e' ); match( $out, "2.718", 'post e match' ); $out = ''; ok( $tt2->process('baz', $vars, \$out), 'post phi' ); match( $out, "\n1.618\n", 'post phi match' ); $out = ''; ok( $tt2->process('ding', $vars, \$out), 'post hello' ); match( $out, "!Hello!", 'post hello match' ); $out = ''; ok( $tt2->process('dong', $vars, \$out), 'post world' ); match( $out, "! World !", 'post world match' ); my $tt = [ tt_pre_none => Template->new(PRE_CHOMP => CHOMP_NONE), tt_pre_one => Template->new(PRE_CHOMP => CHOMP_ONE), tt_pre_all => Template->new(PRE_CHOMP => CHOMP_ALL), tt_pre_coll => Template->new(PRE_CHOMP => CHOMP_COLLAPSE), tt_post_none => Template->new(POST_CHOMP => CHOMP_NONE), tt_post_one => Template->new(POST_CHOMP => CHOMP_ONE), tt_post_all => Template->new(POST_CHOMP => CHOMP_ALL), tt_post_coll => Template->new(POST_CHOMP => CHOMP_COLLAPSE), ]; test_expect(\*DATA, $tt); __DATA__ #------------------------------------------------------------------------ # tt_pre_none #------------------------------------------------------------------------ -- test -- begin[% a = 10; b = 20 %] [% a %] [% b %] end -- expect -- begin 10 20 end #------------------------------------------------------------------------ # tt_pre_one #------------------------------------------------------------------------ -- test -- -- use tt_pre_one -- -- test -- begin[% a = 10; b = 20 %] [% a %] [% b %] end -- expect -- begin1020 end #------------------------------------------------------------------------ # tt_pre_all #------------------------------------------------------------------------ -- test -- -- use tt_pre_all -- -- test -- begin[% a = 10; b = 20 %] [% a %] [% b %] end -- expect -- begin1020 end #------------------------------------------------------------------------ # tt_pre_coll #------------------------------------------------------------------------ -- test -- -- use tt_pre_coll -- -- test -- begin[% a = 10; b = 20 %] [% a %] [% b %] end -- expect -- begin 10 20 end #------------------------------------------------------------------------ # tt_post_none #------------------------------------------------------------------------ -- test -- -- use tt_post_none -- begin[% a = 10; b = 20 %] [% a %] [% b %] end -- expect -- begin 10 20 end #------------------------------------------------------------------------ # tt_post_all #------------------------------------------------------------------------ -- test -- -- use tt_post_all -- -- test -- begin[% a = 10; b = 20 %] [% a %] [% b %] end -- expect -- begin 10 20end #------------------------------------------------------------------------ # tt_post_one #------------------------------------------------------------------------ -- test -- -- use tt_post_one -- -- test -- begin[% a = 10; b = 20 %] [% a %] [% b %] end -- expect -- begin 10 20end #------------------------------------------------------------------------ # tt_post_coll #------------------------------------------------------------------------ -- test -- -- use tt_post_coll -- -- test -- begin[% a = 10; b = 20 %] [% a %] [% b %] end -- expect -- begin 10 20 end Template-Toolkit-2.24/t/compile1.t000644 000765 000765 00000004171 11674036057 016412 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/compile1.t # # Test the facility for the Template::Provider to maintain a persistance # cache of compiled templates by writing generated Perl code to files. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template::Test; use File::Spec; # declare extra tests to follow test_expect(); $Template::Test::EXTRA = 2; # script may be being run in distribution root or 't' directory my @dir = -d 't' ? qw(t test src) : qw(test src); my $dir = File::Spec->catfile(@dir); my $zero = File::Spec->catfile(@dir, 'divisionbyzero'); my $ttcfg = { POST_CHOMP => 1, INCLUDE_PATH => $dir, COMPILE_EXT => '.ttc', EVAL_PERL => 1, CONSTANTS => { zero => $zero, }, }; # delete any existing files foreach my $f ( "$dir/foo.ttc", "$dir/complex.ttc", "$dir/divisionbyzero.ttc" ) { ok( unlink($f) ) if -f $f; } test_expect(\*DATA, $ttcfg); # $EXTRA tests ok( -f "$dir/foo.ttc" ); ok( -f "$dir/complex.ttc" ); __DATA__ -- test -- [% INCLUDE evalperl %] -- expect -- This file includes a perl block. -- test -- [% TRY %] [% INCLUDE foo %] [% CATCH file %] Error: [% error.type %] - [% error.info %] [% END %] -- expect -- This is the foo file, a is -- test -- [% META author => 'abw' version => 3.14 %] [% INCLUDE complex %] -- expect -- This is the header, title: Yet Another Template Test This is a more complex file which includes some BLOCK definitions This is the footer, author: abw, version: 3.14 - 3 - 2 - 1 -- test -- [% INCLUDE baz %] -- expect -- This is the baz file, a: -- test -- [%- # first pass, writes the compiled code to cache -%] [% INCLUDE divisionbyzero -%] -- expect -- -- process -- undef error - Illegal division by zero at [% constants.zero %] line 1. Template-Toolkit-2.24/t/compile2.t000644 000765 000765 00000005242 11674036057 016413 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/compile2.t # # Test that the compiled template files written by compile1.t can be # loaded and used. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use File::Spec; $^W = 1; # script may be being run in distribution root or 't' directory my @dir = -d 't' ? qw(t test src) : qw(test src); my $dir = File::Spec->catfile(@dir); my $zero = File::Spec->catfile(@dir, 'divisionbyzero'); my $ttcfg = { POST_CHOMP => 1, INCLUDE_PATH => $dir, COMPILE_EXT => '.ttc', CONSTANTS => { zero => $zero, }, }; my $compiled = "$dir/foo.ttc"; # check compiled template files exist ok( -f $compiled ); ok( -f "$dir/complex.ttc" ); # ensure template metadata is saved in compiled file (bug fixed in v2.00) my $out = ''; my $tt = Template->new($ttcfg); ok( $tt->process('baz', { showname => 1 }, \$out) ); ok( scalar $out =~ /^name: baz/ ); # we're going to hack on the foo.ttc file to change some key text. # this way we can tell that the template was loaded from the compiled # version and not the source. my @current_times = (stat $compiled)[8,9]; open(FOO, $compiled) || die "$compiled: $!\n"; local $/ = undef; my $foo = ; close(FOO); $foo =~ s/the foo file/the hacked foo file/; open(FOO, "> $compiled") || die "$compiled: $!\n"; print FOO $foo; close(FOO); # Set mtime back to what it was utime( @current_times, $compiled ); test_expect(\*DATA, $ttcfg); __DATA__ -- test -- [% INCLUDE foo a = 'any value' %] -- expect -- This is the hacked foo file, a is any value -- test -- [% META author => 'billg' version => 6.66 %] [% INCLUDE complex %] -- expect -- This is the header, title: Yet Another Template Test This is a more complex file which includes some BLOCK definitions This is the footer, author: billg, version: 6.66 - 3 - 2 - 1 -- test -- [% META author => 'billg' version => 6.66 %] [% INCLUDE complex %] -- expect -- This is the header, title: Yet Another Template Test This is a more complex file which includes some BLOCK definitions This is the footer, author: billg, version: 6.66 - 3 - 2 - 1 -- test -- [%- # second pass, reads the compiled code from cache -%] [% INCLUDE divisionbyzero -%] -- expect -- -- process -- undef error - Illegal division by zero at [% constants.zero %] line 1, chunk 1. Template-Toolkit-2.24/t/compile3.t000644 000765 000765 00000007376 11674036057 016426 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/compile3.t # # Third test in the compile.t trilogy. Checks that modifications # to a source template result in a re-compilation of the template. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template::Test; use File::Copy; use File::Spec; #ntests(13); # declare extra test to follow test_expect(); $Template::Test::EXTRA = 1; #$Template::Parser::DEBUG = 1; # script may be being run in distribution root or 't' directory my @dir = -d 't' ? qw(t test src) : qw(test src); my $dir = File::Spec->catfile(@dir); my $ttcfg = { POST_CHOMP => 1, INCLUDE_PATH => $dir, COMPILE_EXT => '.ttc', }; # test process fails when EVAL_PERL not set my $tt = Template->new($ttcfg); my $out; ok( ! $tt->process("evalperl", { }, \$out) ); match( $tt->error->type, 'perl' ); match( $tt->error->info, 'EVAL_PERL not set' ); # ensure we can run compiled templates without loading parser # (fix for "Can't locate object method "TIEHANDLE" via package # Template::String..." bug) $ttcfg->{ EVAL_PERL } = 1; $tt = Template->new($ttcfg); ok( $tt->process("evalperl", { }, \$out) ) || match( $tt->error(), "" ); my $file = "$dir/complex"; # check compiled template file exists and grab modification time ok( -f "$file.ttc" ); my $mod = (stat(_))[9]; # save copy of the source file because we're going to try to break it copy($file, "$file.org") || die "failed to copy $file to $file.org\n"; # sleep for a couple of seconds to ensure clock has ticked sleep(2); # append a harmless newline to the end of the source file to change # its modification time append_file("\n"); # define 'bust_it' to append a lone "[% TRY %]" onto the end of the # source file to cause re-compilation to fail my $replace = { bust_it => sub { append_file('[% TRY %]') }, near_line => sub { my ($warning, $n) = @_; if ($warning =~ s/line (\d+)/line ${n}ish/) { my $diff = abs($1 - $n); if ($diff < 4) { # That's close enough for rock'n'roll. The line # number reported appears to vary from one version of # Perl to another return $warning; } else { return $warning . " (where 'ish' means $diff!)"; } } else { return "no idea what line number that is\n"; } } }; test_expect(\*DATA, $ttcfg, $replace ); ok( (stat($file))[9] > $mod ); # restore original source file copy("$file.org", $file) || die "failed to copy $file.org to $file\n"; #------------------------------------------------------------------------ sub append_file { local *FP; sleep(2); # ensure file time stamps are different open(FP, ">>$file") || die "$file: $!\n"; print FP @_; close(FP); } #------------------------------------------------------------------------ __DATA__ -- test -- [% META author => 'albert' version => 'emc2' %] [% INCLUDE complex %] -- expect -- This is the header, title: Yet Another Template Test This is a more complex file which includes some BLOCK definitions This is the footer, author: albert, version: emc2 - 3 - 2 - 1 -- test -- [%# we want to break 'compile' to check that errors get reported -%] [% CALL bust_it -%] [% TRY; INCLUDE complex; CATCH; near_line("$error", 18); END %] -- expect -- file error - parse error - complex line 18ish: unexpected end of input Template-Toolkit-2.24/t/compile4.t000644 000765 000765 00000004601 11674036057 016413 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/compile4.t # # Test the facility for the Template::Provider to maintain a persistance # cache of compiled templates by writing generated Perl code to files. # This is similar to compile1.t but defines COMPILE_DIR as well as # COMPILE_EXT. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Cwd qw( abs_path ); use File::Path; $^W = 1; # declare extra tests to follow test_expect(); #$Template::Test::EXTRA = 2; # script may be being run in distribution root or 't' directory my @dir = -d 't' ? qw(t test) : qw(test); my $dir = abs_path( File::Spec->catfile(@dir) ); my $tdir = abs_path( File::Spec->catfile(@dir, 'tmp')); my $cdir = File::Spec->catfile($tdir, 'cache'); my $zero = File::Spec->catfile($dir, qw(src divisionbyzero)); my $ttcfg = { POST_CHOMP => 1, INCLUDE_PATH => "$dir/src", COMPILE_DIR => $cdir, COMPILE_EXT => '.ttc', ABSOLUTE => 1, CONSTANTS => { dir => $dir, zero => $zero, }, }; # delete any existing cache files rmtree($cdir) if -d $cdir; mkpath($cdir); test_expect(\*DATA, $ttcfg, { root => abs_path($dir) } ); __DATA__ -- test -- [% TRY %] [% INCLUDE foo %] [% CATCH file %] Error: [% error.type %] - [% error.info %] [% END %] -- expect -- This is the foo file, a is -- test -- [% META author => 'abw' version => 3.14 %] [% INCLUDE complex %] -- expect -- This is the header, title: Yet Another Template Test This is a more complex file which includes some BLOCK definitions This is the footer, author: abw, version: 3.14 - 3 - 2 - 1 -- test -- [% TRY %] [% INCLUDE bar/baz word = 'wibble' %] [% CATCH file %] Error: [% error.type %] - [% error.info %] [% END %] -- expect -- This is file baz The word is 'wibble' -- test -- [% INCLUDE "$root/src/blam" %] -- expect -- This is the blam file -- test -- [%- # first pass, writes the compiled code to cache -%] [% INCLUDE divisionbyzero -%] -- expect -- -- process -- undef error - Illegal division by zero at [% constants.zero %] line 1. Template-Toolkit-2.24/t/compile5.t000644 000765 000765 00000006415 11674036057 016421 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/compile5.t # # Test that the compiled template files written by compile4.t can be # loaded and used. Similar to compile2.t but using COMPILE_DIR as well # as COMPILE_EXT. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template::Test; use Cwd qw( abs_path ); use File::Path; my @dir = -d 't' ? qw(t test) : qw(test); my $dir = abs_path( File::Spec->catfile(@dir) ); my $tdir = abs_path( File::Spec->catfile(@dir, 'tmp')); my $cdir = File::Spec->catfile($tdir, 'cache'); my $zero = File::Spec->catfile($dir, qw(src divisionbyzero)); print "zero: $zero\n"; #my $dir = abs_path( -d 't' ? 't/test' : 'test' ); #my $cdir = abs_path("$dir/tmp") . "/cache"; #my $zero = "$cdir/src/divisionbyzero"; my $ttcfg = { POST_CHOMP => 1, INCLUDE_PATH => "$dir/src", COMPILE_DIR => "$cdir/", # note trailing slash - should be handled OK COMPILE_EXT => '.ttc', ABSOLUTE => 1, CONSTANTS => { dir => $dir, zero => $zero, }, }; #print " # check compiled template files exist my $fixdir = $dir; $fixdir =~ s[:][]g if $^O eq 'MSWin32'; my ($foo, $bar, $blam) = map { "$cdir/$fixdir/src/$_.ttc" } qw( foo complex blam ); $blam =~ s[/+][/]g; ok( -f $foo, 'cached foo' ); ok( -f $bar, 'cached bar' ); ok( -f $blam, 'cached blam' ); # we're going to hack on the compiled 'foo' file to change some key text. # this way we can tell that the template was loaded from the compiled # version and not the source. my @foo_times = (stat $foo)[8,9]; open(FOO, $foo) || die "$foo: $!\n"; local $/ = undef; my $content = ; close(FOO); $content =~ s/the foo file/the newly hacked foo file/; open(FOO, "> $foo") || die "$foo: $!\n"; print FOO $content; close(FOO); # and set back utime( @foo_times, $foo ); # same again for 'blam' my @blam_times = (stat $blam)[8,9]; open(BLAM, $blam) || die "$blam: $!\n"; local $/ = undef; $content = ; close(BLAM); $content =~ s/blam/wam-bam/g; open(BLAM, "> $blam") || die "$blam: $!\n"; print BLAM $content; close(BLAM); # and set back utime( @blam_times, $blam ); test_expect(\*DATA, $ttcfg, { root => abs_path($dir) } ); exit; # cleanup cache directory rmtree($cdir) if -d $cdir; __DATA__ -- test -- [% INCLUDE foo a = 'any value' %] -- expect -- This is the newly hacked foo file, a is any value -- test -- [% META author => 'billg' version => 6.66 %] [% INCLUDE complex %] -- expect -- This is the header, title: Yet Another Template Test This is a more complex file which includes some BLOCK definitions This is the footer, author: billg, version: 6.66 - 3 - 2 - 1 -- test -- [% INCLUDE "$root/src/blam" %] -- expect -- This is the wam-bam file -- test -- [%- # second pass, reads the compiled code from cache -%] [% INCLUDE divisionbyzero -%] -- expect -- -- process -- undef error - Illegal division by zero at [% constants.zero %] line 1, chunk 1. Template-Toolkit-2.24/t/config.t000644 000765 000765 00000014742 11674036057 016153 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/config.t # # Test the Template::Config module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use vars qw( $DEBUG ); use Template::Test; use Template::Config; ntests(44); $DEBUG = 0; $Template::Config::DEBUG = 0; my $factory = 'Template::Config'; #------------------------------------------------------------------------ # parser #------------------------------------------------------------------------ print STDERR "Testing parser...\n" if $DEBUG; my $parser; $parser = $factory->parser(PRE_CHOMP => 1, INTERPOLATE => 1) || print STDERR $factory->error(), "\n"; ok( $parser ); ok( $parser->{ PRE_CHOMP } == 1); ok( $parser->{ INTERPOLATE } == 1); $parser = $factory->parser({ POST_CHOMP => 1 }) || print STDERR $factory->error(), "\n"; ok( $parser ); ok( $parser->{ POST_CHOMP } == 1); #------------------------------------------------------------------------ # provider #------------------------------------------------------------------------ print STDERR "Testing provider...\n" if $DEBUG; my $provider; $provider = $factory->provider(INCLUDE_PATH => 'here:there', PARSER => $parser) || print STDERR $factory->error(), "\n"; ok( $provider ); ok( join('...', @{ $provider->{ INCLUDE_PATH } }) eq 'here...there' ); ok( $provider->{ PARSER }->{ POST_CHOMP } == 1); $provider = $factory->provider({ INCLUDE_PATH => 'cat:mat', ANYCASE => 1, INTERPOLATE => 1 }) || print STDERR $factory->error(), "\n"; ok( $provider ); ok( join('...', @{ $provider->{ INCLUDE_PATH } }) eq 'cat...mat' ); # force provider to instantiate a parser and check it uses the correct # parameters. my $text = 'The cat sat on the mat'; ok( $provider->fetch(\$text) ); ok( $provider->{ PARSER }->{ ANYCASE } == 1); ok( $provider->{ PARSER }->{ INTERPOLATE } == 1); #------------------------------------------------------------------------ # plugins #------------------------------------------------------------------------ print STDERR "Testing plugins...\n" if $DEBUG; my $plugins; $plugins = $factory->plugins(PLUGIN_BASE => 'MyPlugins') || print STDERR $factory->error(), "\n"; ok( $plugins ); ok( join('+', @{$plugins->{ PLUGIN_BASE }}) eq 'MyPlugins+Template::Plugin' ); $plugins = $factory->plugins({ LOAD_PERL => 1, PLUGIN_BASE => 'NewPlugins', }) || print STDERR $factory->error(), "\n"; ok( $plugins ); ok( $plugins->{ LOAD_PERL } == 1 ); ok( join('+', @{$plugins->{ PLUGIN_BASE }}) eq 'NewPlugins+Template::Plugin' ); #------------------------------------------------------------------------ # filters #------------------------------------------------------------------------ print STDERR "Testing filters...\n" if $DEBUG; my $filters; $filters = $factory->filters(TOLERANT => 1) || print STDERR $factory->error(), "\n"; ok( $filters ); ok( $filters->{ TOLERANT } == 1); $filters = $factory->filters({ TOLERANT => 1 }) || print STDERR $factory->error(), "\n"; ok( $filters ); ok( $filters->{ TOLERANT } == 1); #------------------------------------------------------------------------ # stash #------------------------------------------------------------------------ print STDERR "Testing stash...\n" if $DEBUG; my $stash; $stash = $factory->stash(foo => 10, bar => 20) || print STDERR $factory->error(), "\n"; ok( $stash ); ok( $stash->get('foo') == 10); ok( $stash->get('bar') == 20); $stash = $factory->stash({ foo => 30, bar => sub { 'forty' }, }) || print STDERR $factory->error(), "\n"; ok( $stash ); ok( $stash->get('foo') == 30); ok( $stash->get('bar') eq 'forty' ); #------------------------------------------------------------------------ # context #------------------------------------------------------------------------ print STDERR "Testing context...\n" if $DEBUG; my $context; $context = $factory->context() || print STDERR $factory->error(), "\n"; ok( $context ); $context = $factory->context(INCLUDE_PATH => 'anywhere') || print STDERR $factory->error(), "\n"; ok( $context ); ok( $context->{ LOAD_TEMPLATES }->[0]->{ INCLUDE_PATH }->[0] eq 'anywhere' ); $context = $factory->context({ LOAD_TEMPLATES => [ $provider ], LOAD_PLUGINS => [ $plugins ], LOAD_FILTERS => [ $filters ], STASH => $stash, }) || print STDERR $factory->error(), "\n"; ok( $context ); ok( $context->stash->get('foo') == 30 ); ok( $context->{ LOAD_TEMPLATES }->[0]->{ PARSER }->{ INTERPOLATE } == 1); ok( $context->{ LOAD_PLUGINS }->[0]->{ LOAD_PERL } == 1 ); ok( $context->{ LOAD_FILTERS }->[0]->{ TOLERANT } == 1 ); #------------------------------------------------------------------------ # service #------------------------------------------------------------------------ print STDERR "Testing service...\n" if $DEBUG; my $service; $service = $factory->service(INCLUDE_PATH => 'amsterdam') || print STDERR $factory->error(), "\n"; ok( $service ); ok( $service->{ CONTEXT }->{ LOAD_TEMPLATES }->[0]->{ INCLUDE_PATH }->[0] eq 'amsterdam' ); #------------------------------------------------------------------------ # iterator #------------------------------------------------------------------------ print STDERR "Testing iterator...\n" if $DEBUG; my ($iterator, $value, $error); $iterator = $factory->iterator([qw(foo bar baz)]) || print STDERR $factory->error(), "\n"; ok( $iterator ); ($value, $error) = $iterator->get_first(); ok( $value eq 'foo' ); ($value, $error) = $iterator->get_next(); ok( $value eq 'bar' ); ($value, $error) = $iterator->get_next(); ok( $value eq 'baz' ); #------------------------------------------------------------------------ # instdir #------------------------------------------------------------------------ my $idir = Template::Config->instdir(); if ($Template::Config::INSTDIR) { ok( $idir eq $Template::Config::INSTDIR ); } else { ok( ! defined($idir) && $Template::Config::ERROR eq 'no installation directory' ); } my $tdir = Template::Config->instdir('templates'); if ($Template::Config::INSTDIR) { ok( $tdir eq "$Template::Config::INSTDIR/templates" ); } else { ok( ! defined($tdir) && $Template::Config::ERROR eq 'no installation directory' ); } Template-Toolkit-2.24/t/constants.t000644 000765 000765 00000012107 11674036057 016713 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/constants.t # # Test constant folding via Template::Namespace::Constants # # Written by Andy Wardley # # Copyright (C) 1996-2002 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2002 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Stash; use Template::Directive; use Template::Parser; use Template::Namespace::Constants; my $DEBUG = grep(/-d/, @ARGV); $Template::Namespace::Constants::DEBUG = $DEBUG; my $n = 0; my $constants = { author => 'Andy \'Da Man\' Wardley', single => 'foo\'bar', double => "foo'bar", joint => ', ', col => { back => '#ffffff', text => '#000000', }, counter => sub { $n++ }, }; my $namespace = Template::Namespace::Constants->new( $constants ); ok( $namespace, 'created constants namespace' ); is( $namespace->ident([ 'constants', 0, "'author'", 0 ]), q{'Andy \'Da Man\' Wardley'}, 'author match' ); is( $namespace->ident([ 'constants', 0, "'single'", 0 ]), "'foo\\'bar'", 'single match' ); is( $namespace->ident([ 'constants', 0, "'double'", 0 ]), "'foo\\'bar'", 'double match' ); is( $namespace->ident([ 'constants', 0, "'col'", 0, "'back'", 0 ]), "'#ffffff'", 'col.back match' ); is( $namespace->ident([ 'constants', 0, "'col'", 0, "'text'", 0 ]), "'#000000'", 'col.text match' ); my $factory = Template::Directive->new({ NAMESPACE => { const => $namespace, } }); ok( $factory, 'created Template::Directive factory' ); my $parser = Template::Parser->new( FACTORY => $factory ); ok( $parser, 'created Template::Parser parser' ); my $parsed = $parser->parse(<error(), "\n" unless $parsed; my $text = $parsed->{ BLOCK }; ok( scalar $text =~ /'Andy \\'Da Man\\' Wardley'/, 'author folded' ); ok( scalar $text =~ /"back is " . '#ffffff'/, 'col.back folded' ); ok( scalar $text =~ /stash->get\(\['col', 0, 'user', 0\]\)/, 'col.user unfolded' ); $parser = Template::Parser->new({ NAMESPACE => { const => $namespace, } }); ok( $parser, 'created Template::Parser parser' ); $parsed = $parser->parse(<error(), "\n" unless $parsed; $text = $parsed->{ BLOCK }; ok( scalar $text =~ /'Andy \\'Da Man\\' Wardley'/, 'author folded' ); ok( scalar $text =~ /"back is " . '#ffffff'/, 'col.back folded' ); ok( scalar $text =~ /stash->get\(\['col', 0, 'user', 0\]\)/, 'col.user unfolded' ); #------------------------------------------------------------------------ my $tt1 = Template->new({ NAMESPACE => { const => $namespace, }, }); ok( $tt1, 'created tt1' ); my $const2 = { author => 'abw', joint => ' is the new ', col => { back => 'orange', text => 'black', }, fave => 'back', }; my $tt2 = Template->new({ CONSTANTS => $const2, }); ok( $tt2, 'created tt2' ); my $tt3 = Template->new({ CONSTANTS => $const2, CONSTANTS_NAMESPACE => 'const', }); ok( $tt3, 'created tt3' ); my $engines = [ tt1 => $tt1, tt2 => $tt2, tt3 => $tt3 ]; my $vars = { col => { user => 'red', luza => 'blue', }, constants => $constants, }; test_expect(\*DATA, $engines, $vars); __DATA__ -- test -- hello [% const.author %] [% "back is $const.col.back" %] and text is [% const.col.text %] col.user is [% col.user %] -- expect -- hello Andy 'Da Man' Wardley back is #ffffff and text is #000000 col.user is red -- test -- # look ma! I can even call virtual methods on contants! [% const.col.keys.sort.join(', ') %] -- expect -- back, text -- test -- # and even pass constant arguments to constant virtual methods! [% const.col.keys.sort.join(const.joint) %] -- expect -- back, text -- test -- # my constants can be subs, etc. zero [% const.counter %] one [% const.counter %] -- expect -- zero 0 one 1 -- test -- -- use tt2 -- [% "$constants.author thinks " %] [%- constants.col.values.sort.reverse.join(constants.joint) %] -- expect -- abw thinks orange is the new black -- test -- -- use tt3 -- [% "$const.author thinks " -%] [% const.col.values.sort.reverse.join(const.joint) %] -- expect -- abw thinks orange is the new black -- test -- -- name no const.foo -- no [% const.foo %]? -- expect -- no ? -- test -- fave [% const.fave %] col [% const.col.${const.fave} %] -- expect -- fave back col orange -- test -- -- use tt2 -- -- name defer references -- [% "$key\n" FOREACH key = constants.col.keys.sort %] -- expect -- back text -- test -- -- use tt3 -- a: [% const.author %] b: [% const.author = 'Fred Smith' %] c: [% const.author %] -- expect -- a: abw b: c: abw Template-Toolkit-2.24/t/context.t000644 000765 000765 00000013566 11674036057 016375 0ustar00abwabw000000 000000 #!/usr/bin/perl -w # -*- perl -*- #============================================================= -*-perl-*- # # t/context.t # # Test the Template::Context.pm module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Constants qw( :debug ); my $DEBUG = grep(/^--?d(debug)?$/, @ARGV); #$Template::Test::DEBUG = 1; ntests(54); # script may be being run in distribution root or 't' directory my $dir = -d 't' ? 't/test' : 'test'; my $tt = Template->new({ INCLUDE_PATH => "$dir/src:$dir/lib", TRIM => 1, POST_CHOMP => 1, DEBUG => $DEBUG ? DEBUG_CONTEXT : 0, }); my $ttperl = Template->new({ INCLUDE_PATH => "$dir/src:$dir/lib", TRIM => 1, EVAL_PERL => 1, POST_CHOMP => 1, DEBUG => $DEBUG ? DEBUG_CONTEXT : 0, }); #------------------------------------------------------------------------ # misc #------------------------------------------------------------------------ # test we created a context object and check internal values my $context = $tt->service->context(); ok( $context ); ok( $context eq $tt->context() ); ok( $context->trim() ); ok( ! $context->eval_perl() ); ok( $context = $ttperl->service->context() ); ok( $context->trim() ); ok( $context->eval_perl() ); #------------------------------------------------------------------------ # template() #------------------------------------------------------------------------ banner('testing template()'); # test we can fetch a template via template() my $template = $context->template('header'); ok( $template ); ok( UNIVERSAL::isa($template, 'Template::Document') ); # test that non-existance of a template is reported eval { $template = $context->template('no_such_template') }; ok( $@ ); ok( "$@" eq 'file error - no_such_template: not found' ); # check that template() returns CODE and Template::Document refs intact my $code = sub { return "this is a hard-coded template" }; $template = $context->template($code); ok( $template eq $code ); my $doc = "this is a document"; $doc = bless \$doc, 'Template::Document'; $template = $context->template($doc); ok( $template eq $doc ); ok( $$doc = 'this is a document' ); # check the use of visit() and leave() to add temporary BLOCK lookup # tables to the context's search space my $blocks1 = { some_block_1 => 'hello', }; my $blocks2 = { some_block_2 => 'world', }; eval { $context->template('some_block_1') }; ok( $@ ); $context->visit('no doc', $blocks1); ok( $context->template('some_block_1') eq 'hello' ); eval { $context->template('some_block_2') }; ok( $@ ); $context->visit('no doc', $blocks2); ok( $context->template('some_block_1') eq 'hello' ); ok( $context->template('some_block_2') eq 'world' ); $context->leave(); ok( $context->template('some_block_1') eq 'hello' ); eval { $context->template('some_block_2') }; ok( $@ ); $context->leave(); eval { $context->template('some_block_1') }; ok( $@ ); eval { $context->template('some_block_2') }; ok( $@ ); # test that reset() clears all blocks $context->visit('no doc', $blocks1); ok( $context->template('some_block_1') eq 'hello' ); eval { $context->template('some_block_2') }; ok( $@ ); $context->visit('no doc', $blocks2); ok( $context->template('some_block_1') eq 'hello' ); ok( $context->template('some_block_2') eq 'world' ); $context->reset(); eval { $context->template('some_block_1') }; ok( $@ ); eval { $context->template('some_block_2') }; ok( $@ ); #------------------------------------------------------------------------ # plugin() #------------------------------------------------------------------------ banner('testing plugin()'); my $plugin = $context->plugin('Table', [ [1,2,3,4], { rows => 2 } ]); ok( $plugin ); ok( ref $plugin eq 'Template::Plugin::Table' ); my $row = $plugin->row(0); ok( $row && ref $row eq 'ARRAY' ); ok( $row->[0] == 1 ); ok( $row->[1] == 3 ); eval { $plugin = $context->plugin('no_such_plugin'); }; ok( "$@" eq 'plugin error - no_such_plugin: plugin not found' ); #------------------------------------------------------------------------ # filter() #------------------------------------------------------------------------ banner('testing filter()'); my $filter = $context->filter('html'); ok( $filter ); ok( ref $filter eq 'CODE' ); ok( &$filter('') eq '<input/>' ); $filter = $context->filter('replace', [ 'foo', 'bar' ], 'repsave'); ok( $filter ); ok( ref $filter eq 'CODE' ); ok( &$filter('this is foo, so it is') eq 'this is bar, so it is' ); # check filter got cached $filter = $context->filter('repsave'); ok( $filter ); ok( ref $filter eq 'CODE' ); match( &$filter('this is foo, so it is'), 'this is bar, so it is' ); #------------------------------------------------------------------------ # include() and process() #------------------------------------------------------------------------ banner('testing include()'); $context = $tt->context(); ok( $context ); my $stash = $context->stash(); ok( $stash ); $stash->set('a', 'alpha'); ok( $stash->get('a') eq 'alpha' ); my $text = $context->include('baz'); ok( $text eq 'This is the baz file, a: alpha' ); $text = $context->include('baz', { a => 'bravo' }); ok( $text eq 'This is the baz file, a: bravo' ); # check stash hasn't been altered ok( $stash->get('a') eq 'alpha' ); $text = $context->process('baz'); ok( $text eq 'This is the baz file, a: alpha' ); # check stash *has* been altered ok( $stash->get('a') eq 'charlie' ); $text = $context->process('baz', { a => 'bravo' }); ok( $text eq 'This is the baz file, a: bravo' ); ok( $stash->get('a') eq 'charlie' ); Template-Toolkit-2.24/t/datafile.t000644 000765 000765 00000003203 11674036057 016445 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/datafile.t # # Template script testing datafile plugin. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ./blib/lib ./blib/arch ../lib ../blib/lib ../blib/arch ); use Template qw( :status ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; my $base = -d 't' ? 't/test/lib' : 'test/lib'; my $params = { datafile => [ "$base/udata1", "$base/udata2" ], }; test_expect(\*DATA, { INTERPOLATE => 1, POST_CHOMP => 1 }, $params); #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ [% USE userlist = datafile(datafile.0) %] Users: [% FOREACH user = userlist %] * $user.id: $user.name [% END %] -- expect -- Users: * way: Wendy Yardley * mop: Marty Proton * nellb: Nell Browser -- test -- [% USE userlist = datafile(datafile.1, delim = '|') %] Users: [% FOREACH user = userlist %] * $user.id: $user.name <$user.email> [% END %] -- expect -- Users: * way: Wendy Yardley * mop: Marty Proton * nellb: Nell Browser -- test -- [% USE userlist = datafile(datafile.1, delim = '|') -%] size: [% userlist.size %] -- expect -- size: 3 Template-Toolkit-2.24/t/date.t000644 000765 000765 00000014716 11674036057 015624 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/date.t # # Tests the 'Date' 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template; use Template::Test; use Template::Plugin::Date; use POSIX; $^W = 1; eval "use Date::Calc"; my $got_date_calc = 0; $got_date_calc++ unless $@; $Template::Test::DEBUG = 0; my $format = { 'default' => $Template::Plugin::Date::FORMAT, 'time' => '%H:%M:%S', 'date' => '%d-%b-%Y', 'timeday' => 'the time is %H:%M:%S on %A', }; my $time = time; my @ltime = localtime($time); my $params = { time => $time, format => $format, timestr => &POSIX::strftime($format->{ time }, @ltime), datestr => &POSIX::strftime($format->{ date }, @ltime), daystr => &POSIX::strftime($format->{ timeday }, @ltime), defstr => &POSIX::strftime($format->{ default }, @ltime), now => sub { &POSIX::strftime(shift || $format->{ default }, localtime(time)); }, time_locale => \&time_locale, date_locale => \&date_locale, date_calc => $got_date_calc, }; sub time_locale { my ($time, $format, $locale) = @_; my $old_locale = &POSIX::setlocale(&POSIX::LC_ALL); # some systems expect locales to have a particular suffix for my $suffix ('', @Template::Plugin::Date::LOCALE_SUFFIX) { my $try_locale = $locale.$suffix; my $setlocale = &POSIX::setlocale(&POSIX::LC_ALL, $try_locale); if (defined $setlocale && $try_locale eq $setlocale) { $locale = $try_locale; last; } } my $datestr = &POSIX::strftime($format, localtime($time)); &POSIX::setlocale(&POSIX::LC_ALL, $old_locale); return $datestr; } sub date_locale { my ($time, $format, $locale) = @_; my @date = (split(/(?:\/| |:|-)/, $time))[2,1,0,3..5]; return (undef, Template::Exception->new('date', "bad time/date string: expects 'h:m:s d:m:y' got: '$time'")) unless @date >= 6 && defined $date[5]; $date[4] -= 1; # correct month number 1-12 to range 0-11 $date[5] -= 1900; # convert absolute year to years since 1900 $time = &POSIX::mktime(@date); return time_locale($time, $format, $locale); } # force second to rollover so that we reliably see any tests failing. # lesson learnt from 2.07b where I broke the Date plugin's handling of a # 'time' parameter, but which didn't immediately come to light because the # script could run before the second rolled over and not expose the bug sleep 1; test_expect(\*DATA, { POST_CHOMP => 1 }, $params); #------------------------------------------------------------------------ # test input # # NOTE: these tests check that the Date plugin is behaving as expected # but don't attempt to validate that the output returned from strftime() # is semantically correct. It's a closed loop (aka "vicious circle" :-) # in which we compare what date.format() returns to what we get by # calling strftime() directly. Despite this, we can rest assured that # the plugin is correctly parsing the various parameters and passing # them to strftime() as expected. #------------------------------------------------------------------------ __DATA__ -- test -- [% USE date %] Let's hope the year doesn't roll over in between calls to date.format() and now()... Year: [% date.format(format => '%Y') %] -- expect -- -- process -- Let's hope the year doesn't roll over in between calls to date.format() and now()... Year: [% now('%Y') %] -- test -- [% USE date(time => time) %] default: [% date.format %] -- expect -- -- process -- default: [% defstr %] -- test -- [% USE date(time => time) %] [% date.format(format => format.timeday) %] -- expect -- -- process -- [% daystr %] -- test -- [% USE date(time => time, format = format.date) %] Date: [% date.format %] -- expect -- -- process -- Date: [% datestr %] -- test -- [% USE date(format = format.date) %] Time: [% date.format(time, format.time) %] -- expect -- -- process -- Time: [% timestr %] -- test -- [% USE date(format = format.date) %] Time: [% date.format(time, format = format.time) %] -- expect -- -- process -- Time: [% timestr %] -- test -- [% USE date(format = format.date) %] Time: [% date.format(time = time, format = format.time) %] -- expect -- -- process -- Time: [% timestr %] -- test -- [% USE english = date(format => '%A', locale => 'en_GB') %] [% USE french = date(format => '%A', locale => 'fr_FR') %] In English, today's day is: [% english.format +%] In French, today's day is: [% french.format +%] -- expect -- -- process -- In English, today's day is: [% time_locale(time, '%A', 'en_GB') +%] In French, today's day is: [% time_locale(time, '%A', 'fr_FR') +%] -- test -- [% USE english = date(format => '%A') %] [% USE french = date() %] In English, today's day is: [%- english.format(locale => 'en_GB') +%] In French, today's day is: [%- french.format(format => '%A', locale => 'fr_FR') +%] -- expect -- -- process -- In English, today's day is: [% time_locale(time, '%A', 'en_GB') +%] In French, today's day is: [% time_locale(time, '%A', 'fr_FR') +%] -- test -- [% USE date %] [% date.format('4:20:00 13-6-2000', '%H') %] -- expect -- 04 -- test -- [% USE date %] [% date.format('2000-6-13 4:20:00', '%H') %] -- expect -- 04 -- test -- -- name September 13th 2000 -- [% USE day = date(format => '%A', locale => 'en_GB') %] [% day.format('4:20:00 13-9-2000') %] -- expect -- -- process -- [% date_locale('4:20:00 13-9-2000', '%A', 'en_GB') %] -- test -- [% TRY %] [% USE date %] [% date.format('some stupid date') %] [% CATCH date %] Bad date: [% e.info %] [% END %] -- expect -- Bad date: bad time/date string: expects 'h:m:s d:m:y' got: 'some stupid date' -- test -- [% USE date %] [% template.name %] [% date.format(template.modtime, format='%Y') %] -- expect -- -- process -- input text [% now('%Y') %] -- test -- [% IF date_calc -%] [% USE date; calc = date.calc; calc.Monday_of_Week(22, 2001).join('/') %] [% ELSE -%] not testing [% END -%] -- expect -- -- process -- [% IF date_calc -%] 2001/5/28 [% ELSE -%] not testing [% END -%] -- test -- [% USE date; date.format('12:59:00 30/09/2001', '%H:%M') -%] -- expect -- 12:59 -- test -- [% USE date; date.format('2001/09/30 12:59:00', '%H:%M') -%] -- expect -- 12:59 Template-Toolkit-2.24/t/debug.t000644 000765 000765 00000007560 11674036057 015774 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/debug.t # # Test the Debug plugin module. # # Written by Andy Wardley # # Copyright (C) 2002 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test qw( :all ); use Template::Parser; use Template::Directive; use Template::Constants qw( :debug ); my $DEBUG = grep(/-d/, @ARGV); #$Template::Parser::DEBUG = 1; #$DEBUG; #$Template::Directive::Pretty = $DEBUG; $Template::Test::PRESERVE = 1; my $dir = -d 't' ? 't/test' : 'test'; my $vars = { foo => 10, bar => 20, baz => { ping => 100, pong => 200, }, }; my $dummy = Template::Base->new() || die Template::Base->error(); ok( $dummy, 'created a dummy object' ); my $flags = Template::Constants::debug_flags($dummy, 'dirs, stash'); ok( $flags, 'created flags' ); is( $flags, DEBUG_DIRS | DEBUG_STASH, "flags value is $flags" ); $flags = Template::Constants::debug_flags($dummy, $flags) || die $dummy->error(); ok( $flags, 'got more flags back' ); is( $flags, 'dirs, stash', 'dirs, stash' ); $flags = Template::Constants::debug_flags($dummy, 'bad stupid'); ok( ! $flags, 'bad flags' ); is( $dummy->error(), 'unknown debug flag: bad', 'error correct' ); my $tt = Template->new( { DEBUG => 0, INCLUDE_PATH => "$dir/src:$dir/lib", DEBUG_FORMAT => "", } ) || die Template->error(); my $tt2 = Template->new( { DEBUG => DEBUG_DIRS, INCLUDE_PATH => "$dir/src:$dir/lib", } ) || die Template->error(); my $ttd = Template->new( { DEBUG => 'dirs, vars', INCLUDE_PATH => "$dir/src:$dir/lib", DEBUG_FORMAT => "", } ) || die Template->error(); test_expect(\*DATA, [ default => $tt, debug => $ttd, debug2 => $tt2 ], $vars); #$tt->process(\*DATA, $vars) || die $tt->error(); #print $tt->context->_dump(); __DATA__ -- test -- Hello World foo: [% foo %] -- expect -- Hello World foo: 10 -- test -- -- use debug -- Hello World foo: [% foo %] -- expect -- Hello World foo: 10 -- test -- -- use default -- Hello World foo: [% foo %] [% DEBUG on -%] Debugging enabled foo: [% foo %] -- expect -- Hello World foo: 10 Debugging enabled foo: 10 -- test -- -- use debug -- [% DEBUG off %] Hello World foo: [% foo %] [% DEBUG on -%] Debugging enabled foo: [% foo %] -- expect -- Hello World foo: 10 Debugging enabled foo: 10 -- test -- -- name ping pong -- foo: [% foo %] hello [% "$baz.ping/$baz.pong" %] world [% DEBUG off %] bar: [% bar %][% DEBUG on %] -- expect -- foo: 10 hello 100/200 world bar: 20 -- test -- -- use debug -- foo: [% foo %] [% INCLUDE foo a=10 %] [% DEBUG off -%] foo: [% foo %] [% INCLUDE foo a=20 %] -- expect -- foo: 10 This is the foo file, a is 10 foo: 10 This is the foo file, a is 20 -- stop -- -- test -- -- use default -- [% DEBUG on -%] [% DEBUG format '[ $file line $line ]' %] [% foo %] -- expect -- [ input text line 3 ]10 -- test -- -- use default -- [% DEBUG on + format '[ $file line $line ]' -%] [% foo %] -- expect -- [ input text line 2 ]10 -- test -- [% DEBUG on; DEBUG format '$text at line $line of $file'; DEBUG msg line='3.14' file='this file' text='hello world' %] -- expect -- hello world at line 3.14 of this file Template-Toolkit-2.24/t/directive.t000644 000765 000765 00000011407 11674036057 016657 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/directive.t # # Test basic directive layout and processing options. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; my $ttobjs = [ tt => Template->new(), pre => Template->new( PRE_CHOMP => 1 ), post => Template->new( POST_CHOMP => 1 ), trim => Template->new( INCLUDE_PATH => -d 't' ? 't/test/lib' : 'test/lib', TRIM => 1 ), ]; test_expect(\*DATA, $ttobjs, callsign); __DATA__ #------------------------------------------------------------------------ # basic directives #------------------------------------------------------------------------ -- test -- [% a %] [%a%] -- expect -- alpha alpha -- test -- pre [% a %] pre[% a %] -- expect -- pre alpha prealpha -- test -- [% a %] post [% a %]post -- expect -- alpha post alphapost -- test -- pre [% a %] post pre[% a %]post -- expect -- pre alpha post prealphapost -- test -- [% a %][%b%][% c %] -- expect -- alphabravocharlie -- test -- [% a %][%b %][% c %][% d %] -- expect -- alphabravocharliedelta #------------------------------------------------------------------------ # comments #------------------------------------------------------------------------ -- test -- [%# this is a comment which should be ignored in totality %]hello world -- expect -- hello world -- test -- [% # this is a one-line comment a %] -- expect -- alpha -- test -- [% # this is a two-line comment a = # here's the next line b -%] [% a %] -- expect -- bravo -- test -- [% a = c # this is a comment on the end of the line b = d # so is this -%] a: [% a %] b: [% b %] -- expect -- a: charlie b: delta #------------------------------------------------------------------------ # manual chomping #------------------------------------------------------------------------ -- test -- [% a %] [% b %] -- expect -- alpha bravo -- test -- [% a -%] [% b %] -- expect -- alphabravo -- test -- [% a -%] [% b %] -- expect -- alpha bravo -- test -- [% a %] [%- b %] -- expect -- alphabravo -- test -- [% a %] [%- b %] -- expect -- alphabravo -- test -- start [% a %] [% b %] end -- expect -- start alpha bravo end -- test -- start [%- a %] [% b -%] end -- expect -- startalpha bravoend -- test -- start [%- a -%] [% b -%] end -- expect -- startalphabravoend -- test -- start [%- a %] [%- b -%] end -- expect -- startalphabravoend #------------------------------------------------------------------------ # PRE_CHOMP enabled #------------------------------------------------------------------------ -- test -- -- use pre -- start [% a %] mid [% b %] end -- expect -- startalpha midbravo end -- test -- start [% a %] mid [% b %] end -- expect -- startalpha midbravo end -- test -- start [%+ a %] mid [% b %] end -- expect -- start alpha midbravo end -- test -- start [%+ a %] mid [% b %] end -- expect -- start alpha midbravo end -- test -- start [%- a %] mid [%- b %] end -- expect -- startalpha midbravo end #------------------------------------------------------------------------ # POST_CHOMP enabled #------------------------------------------------------------------------ -- test -- -- use post -- start [% a %] mid [% b %] end -- expect -- start alphamid bravoend -- test -- start [% a %] mid [% b %] end -- expect -- start alphamid bravoend -- test -- start [% a +%] mid [% b %] end -- expect -- start alpha mid bravoend -- test -- start [% a +%] [% b +%] end -- expect -- start alpha bravo end -- test -- start [% a -%] mid [% b -%] end -- expect -- start alphamid bravoend #------------------------------------------------------------------------ # TRIM enabled #------------------------------------------------------------------------ -- test -- -- use trim -- [% INCLUDE trimme %] -- expect -- I am a template element file which will get TRIMmed -- test -- [% BLOCK foo %] this is block foo [% END -%] [% BLOCK bar %] this is block bar [% END %] [% INCLUDE foo %] [% INCLUDE bar %] end -- expect -- this is block foo this is block bar end -- test -- [% PROCESS foo %] [% PROCESS bar %] [% BLOCK foo %] this is block foo [% END -%] [% BLOCK bar %] this is block bar [% END -%] end -- expect -- this is block foo this is block bar end -- test -- [% r; r = s; "-"; r %]. -- expect -- romeo-sierra. -- test -- [% IF a; b; ELSIF c; d; ELSE; s; END %] -- expect -- bravo Template-Toolkit-2.24/t/directry.t000644 000765 000765 00000012751 11674036057 016531 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/directory.t # # Tests the Directory 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Cwd; $^W = 1; if ($^O eq 'MSWin32') { skip_all('skipping tests on MS Win 32 platform'); } #$Template::Test::PRESERVE = 1; my $cwd = getcwd(); my $dir = -d 't' ? 't/test/dir' : 'test/dir'; my $dot = $dir; $dot =~ s/[^\/]+/../g; my $vars = { cwd => $cwd, dir => $dir, dot => $dot, }; test_expect(\*DATA, undef, $vars); __DATA__ -- test -- [% TRY ; USE Directory ; CATCH ; error ; END -%] -- expect -- Directory error - no directory specified -- test -- [% TRY ; USE Directory('/no/such/place') ; CATCH ; error.type ; ' error on ' ; error.info.split(':').0 ; END -%] -- expect -- Directory error on /no/such/place -- test -- [% USE d = Directory(dir, nostat=1) -%] [% d.path %] -- expect -- -- process -- [% dir %] -- test -- [% USE d = Directory(dir) -%] [% d.path %] -- expect -- -- process -- [% dir %] -- test -- [% USE directory(dir) -%] [% directory.path %] -- expect -- -- process -- [% dir %] -- test -- [% USE d = Directory(dir) -%] [% FOREACH f = d.files -%] - [% f.name %] [% END -%] [% FOREACH f = d.dirs; NEXT IF f.name == 'CVS'; -%] * [% f.name %] [% END %] -- expect -- - file1 - file2 - xyzfile * sub_one * sub_two -- test -- [% USE dir = Directory(dir) -%] [% INCLUDE dir %] [% BLOCK dir -%] * [% dir.name %] [% FOREACH f = dir.files -%] - [% f.name %] [% END -%] [% FOREACH f = dir.dirs; NEXT IF f.name == 'CVS'; -%] [% f.scan -%] [% INCLUDE dir dir=f FILTER indent(4) -%] [% END -%] [% END -%] -- expect -- * dir - file1 - file2 - xyzfile * sub_one - bar - foo * sub_two - waz.html - wiz.html -- test -- [% USE dir = Directory(dir) -%] * [% dir.path %] [% INCLUDE dir %] [% BLOCK dir; FOREACH f = dir.list ; NEXT IF f.name == 'CVS'; IF f.isdir ; -%] * [% f.name %] [% f.scan ; INCLUDE dir dir=f FILTER indent(4) ; ELSE -%] - [% f.name %] [% END ; END ; END -%] -- expect -- -- process -- * [% dir %] - file1 - file2 * sub_one - bar - foo * sub_two - waz.html - wiz.html - xyzfile -- test -- [% USE d = Directory(dir, recurse=1) -%] [% FOREACH f = d.files -%] - [% f.name %] [% END -%] [% FOREACH f = d.dirs; NEXT IF f.name == 'CVS'; -%] * [% f.name %] [% END %] -- expect -- - file1 - file2 - xyzfile * sub_one * sub_two -- test -- [% USE dir = Directory(dir, recurse=1, root=cwd) -%] * [% dir.path %] [% INCLUDE dir %] [% BLOCK dir; FOREACH f = dir.list ; NEXT IF f.name == 'CVS'; IF f.isdir ; -%] * [% f.name %] => [% f.path %] => [% f.abs %] [% INCLUDE dir dir=f FILTER indent(4) ; ELSE -%] - [% f.name %] => [% f.path %] => [% f.abs %] [% END ; END ; END -%] -- expect -- -- process -- * [% dir %] - file1 => [% dir %]/file1 => [% cwd %]/[% dir %]/file1 - file2 => [% dir %]/file2 => [% cwd %]/[% dir %]/file2 * sub_one => [% dir %]/sub_one => [% cwd %]/[% dir %]/sub_one - bar => [% dir %]/sub_one/bar => [% cwd %]/[% dir %]/sub_one/bar - foo => [% dir %]/sub_one/foo => [% cwd %]/[% dir %]/sub_one/foo * sub_two => [% dir %]/sub_two => [% cwd %]/[% dir %]/sub_two - waz.html => [% dir %]/sub_two/waz.html => [% cwd %]/[% dir %]/sub_two/waz.html - wiz.html => [% dir %]/sub_two/wiz.html => [% cwd %]/[% dir %]/sub_two/wiz.html - xyzfile => [% dir %]/xyzfile => [% cwd %]/[% dir %]/xyzfile -- test -- [% USE dir = Directory(dir, recurse=1, root=cwd) -%] * [% dir.path %] [% INCLUDE dir %] [% BLOCK dir; FOREACH f = dir.list ; NEXT IF f.name == 'CVS'; IF f.isdir ; -%] * [% f.name %] => [% f.home %] [% INCLUDE dir dir=f FILTER indent(4) ; ELSE -%] - [% f.name %] => [% f.home %] [% END ; END ; END -%] -- expect -- -- process -- * [% dir %] - file1 => [% dot %] - file2 => [% dot %] * sub_one => [% dot %] - bar => [% dot %]/.. - foo => [% dot %]/.. * sub_two => [% dot %] - waz.html => [% dot %]/.. - wiz.html => [% dot %]/.. - xyzfile => [% dot %] -- test -- [% USE dir = Directory(dir) -%] [% file = dir.file('xyzfile') -%] [% file.name %] -- expect -- xyzfile -- test -- [% USE dir = Directory('.', root=dir) -%] [% dir.name %] [% FOREACH f = dir.files -%] - [% f.name %] [% END -%] -- expect -- . - file1 - file2 - xyzfile -- test -- [% VIEW filelist -%] [% BLOCK file -%] f [% item.name %] => [% item.path %] [% END -%] [% BLOCK directory; NEXT IF item.name == 'CVS'; -%] d [% item.name %] => [% item.path %] [% item.content(view) | indent -%] [% END -%] [% END -%] [% USE dir = Directory(dir, recurse=1) -%] [% filelist.print(dir) %] -- expect -- -- process -- d dir => [% dir %] f file1 => [% dir %]/file1 f file2 => [% dir %]/file2 d sub_one => [% dir %]/sub_one f bar => [% dir %]/sub_one/bar f foo => [% dir %]/sub_one/foo d sub_two => [% dir %]/sub_two f waz.html => [% dir %]/sub_two/waz.html f wiz.html => [% dir %]/sub_two/wiz.html f xyzfile => [% dir %]/xyzfile Template-Toolkit-2.24/t/document.t000644 000765 000765 00000007100 11674036057 016512 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/document.t # # Test the Template::Document module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Config; use Template::Document; $^W = 1; $Template::Test::DEBUG = 0; $Template::Document::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; my $DEBUG = 0; #------------------------------------------------------------------------ # define a dummy context object for runtime processing #------------------------------------------------------------------------ package Template::DummyContext; sub new { bless { }, shift } sub visit { } sub leave { } package main; #------------------------------------------------------------------------ # create a document and check accessor methods for blocks and metadata #------------------------------------------------------------------------ my $doc = Template::Document->new({ BLOCK => sub { my $c = shift; return "some output" }, DEFBLOCKS => { foo => sub { return 'the foo block' }, bar => sub { return 'the bar block' }, }, METADATA => { author => 'Andy Wardley', version => 3.14, }, }); my $c = Template::DummyContext->new(); ok( $doc ); ok( $doc->author() eq 'Andy Wardley' ); ok( $doc->version() == 3.14 ); ok( $doc->process($c) eq 'some output' ); ok( ref($doc->block()) eq 'CODE' ); ok( ref($doc->blocks->{ foo }) eq 'CODE' ); ok( ref($doc->blocks->{ bar }) eq 'CODE' ); ok( &{ $doc->block } eq 'some output' ); ok( &{ $doc->blocks->{ foo } } eq 'the foo block' ); ok( &{ $doc->blocks->{ bar } } eq 'the bar block' ); my $dir = -d 't' ? 't/test' : 'test'; my $tproc = Template->new({ INCLUDE_PATH => "$dir/src", }); test_expect(\*DATA, $tproc, { mydoc => $doc }); __END__ -- test -- # test metadata [% META author = 'Tom Smith' version = 1.23 -%] version [% template.version %] by [% template.author %] -- expect -- version 1.23 by Tom Smith # test local block definitions are accessible -- test -- [% BLOCK foo -%] This is block foo [% INCLUDE bar -%] This is the end of block foo [% END -%] [% BLOCK bar -%] This is block bar [% END -%] [% PROCESS foo %] -- expect -- This is block foo This is block bar This is the end of block foo -- test -- [% META title = 'My Template Title' -%] [% BLOCK header -%] title: [% template.title or title %] [% END -%] [% INCLUDE header %] -- expect -- title: My Template Title -- test -- [% BLOCK header -%] HEADER component title: [% component.name %] template title: [% template.name %] [% END -%] component title: [% component.name %] template title: [% template.name %] [% PROCESS header %] -- expect -- component title: input text template title: input text HEADER component title: header template title: input text -- test -- [% META title = 'My Template Title' -%] [% BLOCK header -%] title: [% title or template.title %] [% END -%] [% INCLUDE header title = 'A New Title' %] [% INCLUDE header %] -- expect -- title: A New Title title: My Template Title -- test -- [% INCLUDE $mydoc %] -- expect -- some output -- stop -- # test for component.caller and component.callers patch -- test -- [% INCLUDE one; INCLUDE two; INCLUDE three; %] -- expect -- one, three two, three Template-Toolkit-2.24/t/dumper.t000644 000765 000765 00000002546 11674036057 016201 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/dumper.t # # Test the Dumper plugin. # # Written by Simon Matthews # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use vars qw( $DEBUG ); use Template::Test; $^W = 1; my $params = { 'baz' => 'boo', }; $DEBUG = 0; test_expect(\*DATA, undef, { params => $params }); #------------------------------------------------------------------------ __DATA__ [% USE Dumper -%] Dumper -- expect -- Dumper -- test -- [% USE Dumper -%] [% Dumper.dump({ foo = 'bar' }, 'hello' ) -%] -- expect -- $VAR1 = { 'foo' => 'bar' }; $VAR2 = 'hello'; -- test -- [% USE Dumper -%] [% Dumper.dump(params) -%] -- expect -- $VAR1 = { 'baz' => 'boo' }; -- test -- [% USE Dumper -%] [% Dumper.dump_html(params) -%] -- expect -- $VAR1 = {
'baz' => 'boo'
};
-- test -- [% USE dumper(indent=1, pad='> ', varname="frank") -%] [% dumper.dump(params) -%] -- expect -- > $frank1 = { > 'baz' => 'boo' > }; -- test -- [% USE dumper(Pad='>> ', Varname="bob") -%] [% dumper.dump(params) -%] -- expect -- >> $bob1 = { >> 'baz' => 'boo' >> }; Template-Toolkit-2.24/t/error.t000644 000765 000765 00000001665 11674036057 016037 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/error.t # # Test that errors are propagated back to the caller as a # Template::Exception object. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ../lib ); use Template::Constants qw( :status ); use Template::Test; $^W = 1; my $template = Template->new({ BLOCKS => { badinc => "[% INCLUDE nosuchfile %]", }, }); ok( ! $template->process('badinc') ); my $error = $template->error(); ok( $error ); ok( ref $error eq 'Template::Exception' ); ok( $error->type eq 'file' ); ok( $error->info eq 'nosuchfile: not found' ); Template-Toolkit-2.24/t/evalperl.t000644 000765 000765 00000007352 11674036057 016517 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/evalperl.t # # Test the evaluation of PERL and RAWPERL blocks. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; #$Template::Context::DEBUG = 0; my $tt_no_perl = Template->new({ INTERPOLATE => 1, POST_CHOMP => 1, EVAL_PERL => 0, INCLUDE_PATH => -d 't' ? 't/test/lib' : 'test/lib', }); my $tt_do_perl = Template->new({ INTERPOLATE => 1, POST_CHOMP => 1, EVAL_PERL => 1, INCLUDE_PATH => -d 't' ? 't/test/lib' : 'test/lib', }); my $ttprocs = [ no_perl => $tt_no_perl, do_perl => $tt_do_perl, ]; test_expect(\*DATA, $ttprocs, &callsign); __DATA__ -- test -- [% META author = 'Andy Wardley' title = 'Test Template $foo #6' version = 1.23 %] [% TRY %] [% PERL %] my $output = "author: [% template.author %]\n"; $stash->set('a', 'The cat sat on the mat'); $output .= "more perl generated output\n"; print $output; [% END %] [% CATCH %] Not allowed: [% error +%] [% END %] a: [% a +%] a: $a [% TRY %] [% RAWPERL %] $output .= "The cat sat on the mouse mat\n"; $stash->set('b', 'The cat sat where?'); [% END %] [% CATCH %] Still not allowed: [% error +%] [% END %] b: [% b +%] b: $b -- expect -- Not allowed: perl error - EVAL_PERL not set a: alpha a: alpha Still not allowed: perl error - EVAL_PERL not set b: bravo b: bravo -- test -- [% TRY %] nothing [% PERL %] We don't care about correct syntax within PERL blocks if EVAL_PERL isn't set. They're simply ignored. [% END %] [% CATCH %] ERROR: [% error.type %]: [% error.info %] [% END %] -- expect -- nothing ERROR: perl: EVAL_PERL not set -- test -- some stuff [% TRY %] [% INCLUDE badrawperl %] [% CATCH %] ERROR: [[% error.type %]] [% error.info %] [% END %] -- expect -- some stuff This is some text ERROR: [perl] EVAL_PERL not set -- test -- -- use do_perl -- some stuff [% TRY %] [% INCLUDE badrawperl %] [% CATCH +%] ERROR: [[% error.type %]] [% END %] -- expect -- some stuff This is some text more stuff goes here ERROR: [undef] -- test -- -- use do_perl -- [% META author = 'Andy Wardley' %] [% PERL %] my $output = "author: [% template.author %]\n"; $stash->set('a', 'The cat sat on the mat'); $output .= "more perl generated output\n"; print $output; [% END %] -- expect -- author: Andy Wardley more perl generated output -- test -- -- use do_perl -- [% META author = 'Andy Wardley' title = 'Test Template $foo #6' version = 3.14 %] [% PERL %] my $output = "author: [% template.author %]\n"; $stash->set('a', 'The cat sat on the mat'); $output .= "more perl generated output\n"; print $output; [% END %] a: [% a +%] a: $a [% RAWPERL %] $output .= "The cat sat on the mouse mat\n"; $stash->set('b', 'The cat sat where?'); [% END %] b: [% b +%] b: $b -- expect -- author: Andy Wardley more perl generated output a: The cat sat on the mat a: The cat sat on the mat The cat sat on the mouse mat b: The cat sat where? b: The cat sat where? -- test -- [% BLOCK foo %]This is block foo[% END %] [% PERL %] print $context->include('foo'); print PERLOUT "\nbar\n"; [% END %] The end -- expect -- This is block foo bar The end -- test -- [% TRY %] [%- PERL %] die "nothing to live for\n" [% END %] [% CATCH %] error: [% error %] [% END %] -- expect -- error: undef error - nothing to live for Template-Toolkit-2.24/t/exception.t000644 000765 000765 00000003015 11674036057 016673 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/except.t # # Test the Template::Exception module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Exception; my $text = 'the current output buffer'; my $e1 = Template::Exception->new('e1.type', 'e1.info'); my $e2 = Template::Exception->new('e2.type', 'e2.info', \$text); ok( $e1 ); ok( $e2 ); ok( $e1->type() eq 'e1.type' ); ok( $e2->info() eq 'e2.info' ); my @ti = $e1->type_info(); ok( $ti[0] eq 'e1.type' ); ok( $ti[1] eq 'e1.info' ); ok( $e2->as_string() eq 'e2.type error - e2.info' ); ok( $e2->text() eq 'the current output buffer' ); my $prepend = 'text to prepend '; $e2->text(\$prepend); ok( $e2->text() eq 'text to prepend the current output buffer' ); my @handlers = ('something', 'e2', 'e1.type'); ok( $e1->select_handler(@handlers) eq 'e1.type' ); ok( $e2->select_handler(@handlers) eq 'e2' ); my $e3 = Template::Exception->new('e3.type', 'e3.info', undef); ok( $e3 ); ok( $e3->text() eq ''); ok( $e3->as_string() eq 'e3.type error - e3.info' ); # test to check that overloading fallback works properly # by using a non explicitly defined op ok( $e3 ne "fish"); Template-Toolkit-2.24/t/factory.t000644 000765 000765 00000002632 11674036057 016350 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/factory.t # # Test use of a modified directive factory, based on something that # pudge suggested on #perl. # # Written by Andy Wardley # # Copyright (C) 1996-2001 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; # uncomment these lines to see how generate Perl code # for constant.* is expanded at parse time #Template::Parser::DEBUG = 1; #Template::Directive::PRETTY = 1; package My::Directive; use base qw( Template::Directive ); my $constants = { pi => 3.14, e => 2.718, }; sub ident { my ($class, $ident) = @_; # note single quoting of 'constant' if (ref $ident eq 'ARRAY' && $ident->[0] eq "'constant'") { my $key = $ident->[2]; $key =~ s/'//g; return $constants->{ $key } || ''; } return $class->SUPER::ident($ident); } package main; my $cfg = { FACTORY => 'My::Directive', }; my $vars = { foo => { bar => 'Place to purchase drinks', baz => 'Short form of "Basil"', }, }; test_expect(\*DATA, $cfg, $vars); __DATA__ -- test -- [% foo.bar %] -- expect -- Place to purchase drinks -- test -- [% constant.pi %] -- expect -- 3.14 Template-Toolkit-2.24/t/file.t000644 000765 000765 00000005570 11674036057 015624 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/file.t # # Tests the File 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Plugin::File; $^W = 1; if ($^O eq 'MSWin32') { skip_all('skipping tests on MS Win 32 platform'); } # my $dir = -d 't' ? 't/test' : 'test'; my $file = "$dir/src/foo"; my @stat; (@stat = stat $file) || die "$file: $!\n"; my $vars = { dir => $dir, file => $file, }; @$vars{ @Template::Plugin::File::STAT_KEYS } = @stat; test_expect(\*DATA, undef, $vars); __DATA__ -- test -- [% USE f = File('/foo/bar/baz.html', nostat=1) -%] p: [% f.path %] r: [% f.root %] n: [% f.name %] d: [% f.dir %] e: [% f.ext %] h: [% f.home %] a: [% f.abs %] -- expect -- p: /foo/bar/baz.html r: n: baz.html d: /foo/bar e: html h: ../.. a: /foo/bar/baz.html -- test -- [% USE f = File('foo/bar/baz.html', nostat=1) -%] p: [% f.path %] r: [% f.root %] n: [% f.name %] d: [% f.dir %] e: [% f.ext %] h: [% f.home %] a: [% f.abs %] -- expect -- p: foo/bar/baz.html r: n: baz.html d: foo/bar e: html h: ../.. a: foo/bar/baz.html -- test -- [% USE f = File('baz.html', nostat=1) -%] p: [% f.path %] r: [% f.root %] n: [% f.name %] d: [% f.dir %] e: [% f.ext %] h: [% f.home %] a: [% f.abs %] -- expect -- p: baz.html r: n: baz.html d: e: html h: a: baz.html -- test -- [% USE f = File('bar/baz.html', root='/foo', nostat=1) -%] p: [% f.path %] r: [% f.root %] n: [% f.name %] d: [% f.dir %] e: [% f.ext %] h: [% f.home %] a: [% f.abs %] -- expect -- p: bar/baz.html r: /foo n: baz.html d: bar e: html h: .. a: /foo/bar/baz.html -- test -- [% USE f = File('bar/baz.html', root='/foo', nostat=1) -%] p: [% f.path %] h: [% f.home %] rel: [% f.rel('wiz/waz.html') %] -- expect -- p: bar/baz.html h: .. rel: ../wiz/waz.html -- test -- [% USE baz = File('foo/bar/baz.html', root='/tmp/tt2', nostat=1) -%] [% USE waz = File('wiz/woz/waz.html', root='/tmp/tt2', nostat=1) -%] [% baz.rel(waz) %] -- expect -- ../../wiz/woz/waz.html -- test -- [% USE f = File('foo/bar/baz.html', nostat=1) -%] [[% f.atime %]] -- expect -- [] -- test -- [% USE f = File(file) -%] [% f.path %] [% f.name %] -- expect -- -- process -- [% dir %]/src/foo foo -- test -- [% USE f = File(file) -%] [% f.path %] [% f.mtime %] -- expect -- -- process -- [% dir %]/src/foo [% mtime %] -- test -- [% USE file(file) -%] [% file.path %] [% file.mtime %] -- expect -- -- process -- [% dir %]/src/foo [% mtime %] -- test -- [% TRY -%] [% USE f = File('') -%] n: [% f.name %] [% CATCH -%] Drat, there was a [% error.type %] error. [% END %] -- expect -- Drat, there was a File error. Template-Toolkit-2.24/t/fileline.t000644 000765 000765 00000005733 11674036057 016475 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/fileline.t # # Test the reporting of template file and line number in errors. # # Written by Andy Wardley # # Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== #BEGIN { # if ( $^O eq 'MSWin32' ) { # print "1..0 # Skip Temporarily skipping on Win32\n"; # exit(0); # } #} use strict; use warnings; use lib qw( ./lib ../lib ./blib/lib ../blib/lib ./blib/arch ../blib/arch ); use Template::Test; use Template::Parser; use Template::Directive; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; my $dir = -d 't' ? 't/test/lib' : 'test/lib'; my $warning; local $SIG{__WARN__} = sub { $warning = shift; }; my $vars = { warning => sub { return $warning }, file => sub { $warning =~ /at (.*?) line/; my $file = $1; # The error returned includes a reference to the eval string # e.g. ' ...at (eval 1) line 1'. On some platforms (notably # FreeBSD and variants like OSX), the (eval $n) part contains # a different number, presumably because it has previously # performed additional string evals. It's not important to # the success or failure of the test, so we delete it. # Thanks to Andreas Koenig for identifying the problem. # http://rt.cpan.org/Public/Bug/Display.html?id=20807 $file =~ s/eval\s+\d+/eval/; # handle backslashes on Win32 by converting them to forward slashes $file =~ s!\\!/!g if $^O eq 'MSWin32'; return $file; }, line => sub { $warning =~ /line (\d*)/; return $1; }, warn => sub { $warning =~ /(.*?) at /; return $1; }, }; my $tt2err = Template->new({ INCLUDE_PATH => $dir }) || die Template->error(); my $tt2not = Template->new({ INCLUDE_PATH => $dir, FILE_INFO => 0 }) || die Template->error(); test_expect(\*DATA, [ err => $tt2err, not => $tt2not ], $vars); __DATA__ -- test -- [% place = 'World' -%] Hello [% place %] [% a = a + 1 -%] file: [% file %] line: [% line %] warn: [% warn %] -- expect -- -- process -- Hello World file: input text line: 3 warn: Argument "" isn't numeric in addition (+) -- test -- [% INCLUDE warning -%] file: [% file.chunk(-16).last %] line: [% line %] warn: [% warn %] -- expect -- -- process -- Hello World file: test/lib/warning line: 2 warn: Argument "" isn't numeric in addition (+) -- test -- -- use not -- [% INCLUDE warning -%] file: [% file.chunk(-16).last %] line: [% line %] warn: [% warn %] -- expect -- Hello World file: (eval) line: 10 warn: Argument "" isn't numeric in addition (+) -- test -- [% TRY; INCLUDE chomp; CATCH; error; END %] -- expect -- file error - parse error - chomp line 6: unexpected token (END) [% END %] Template-Toolkit-2.24/t/filter.t000644 000765 000765 00000042366 11674036057 016176 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/filter.t # # Template script testing FILTER directive. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template::Filters; use Template qw( :status ); use Template::Parser; use Template::Test; use Template::Constants qw( :debug ); my $DEBUG = grep(/^--?d(debug)?$/, @ARGV); $Template::Test::DEBUG = 0; $Template::Test::EXTRA = 1; # ensure redirected file is created #$Template::Context::DEBUG = 1; #$Template::DEBUG = 1; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; #------------------------------------------------------------------------ # hack to allow STDERR to be tied to a variable. # (I'm really surprised there isn't a standard module which does this) #------------------------------------------------------------------------ package Tie::File2Str; sub TIEHANDLE { my ($class, $textref) = @_; bless $textref, $class; } sub PRINT { my $self = shift; $$self .= join('', @_); } #------------------------------------------------------------------------ # now for the main event... #------------------------------------------------------------------------ package main; # tie STDERR to a variable my $stderr = ''; #tie(*STDERR, "Tie::File2Str", \$stderr); my $dir = -d 't' ? 't/test/tmp' : 'test/tmp'; my $file = 'xyz'; my ($a, $b, $c, $d) = qw( alpha bravo charlie delta ); my $params = { 'a' => $a, 'b' => $b, 'c' => $c, 'd' => $d, 'list' => [ $a, $b, $c, $d ], 'text' => 'The cat sat on the mat', outfile => $file, stderr => sub { $stderr }, despace => bless(\&despace, 'anything'), widetext => "wide:\x{65e5}\x{672c}\x{8a9e}", }; my $filters = { 'nonfilt' => 'nonsense', 'microjive' => \µjive, 'microsloth' => [ \µsloth, 0 ], 'censor' => [ \&censor_factory, 1 ], 'badfact' => [ sub { return 'nonsense' }, 1 ], 'badfilt' => [ 'rubbish', 1 ], 'barfilt' => [ \&barf_up, 1 ], }; my $config1 = { INTERPOLATE => 1, POST_CHOMP => 1, FILTERS => $filters, }; my $config2 = { EVAL_PERL => 1, FILTERS => $filters, OUTPUT_PATH => $dir, BARVAL => 'some random value', }; unlink "$dir/$file" if -f "$dir/$file"; my $tt1 = Template->new($config1) || die Template->error(); my $tt2 = Template->new($config2) || die Template->error(); $tt2->context->define_filter('another', \&another, 1); tie(*STDERR, "Tie::File2Str", \$stderr); test_expect(\*DATA, [ default => $tt1, evalperl => $tt2 ], $params); ok( -f "$dir/$file", "$dir/$file exists" ); unlink "$dir/$file" if -f "$dir/$file"; #------------------------------------------------------------------------ # custom filter subs #------------------------------------------------------------------------ sub microjive { my $text = shift; $text =~ s/microsoft/The 'Soft/sig; $text; } sub microsloth { my $text = shift; $text =~ s/microsoft/Microsloth/sig; $text; } sub censor_factory { my @forbidden = @_; return sub { my $text = shift; foreach my $word (@forbidden) { $text =~ s/$word/[** CENSORED **]/sig; } return $text; } } sub barf_up { my $context = shift; my $foad = shift || 0; if ($foad == 0) { return (undef, "barfed"); } elsif ($foad == 1) { return (undef, Template::Exception->new('dead', 'deceased')); } elsif ($foad == 2) { die "keeled over\n"; } else { die (Template::Exception->new('unwell', 'sick as a parrot')); } } sub despace { my $text = shift; $text =~ s/\s+/_/g; return $text; } sub another { my ($context, $n) = @_; return sub { my $text = shift; return $text x $n; } } __DATA__ #------------------------------------------------------------------------ # test failures #------------------------------------------------------------------------ -- test -- [% TRY %] [% FILTER nonfilt %] blah blah blah [% END %] [% CATCH %] BZZZT: [% error.type %]: [% error.info %] [% END %] -- expect -- BZZZT: filter: invalid FILTER entry for 'nonfilt' (not a CODE ref) -- test -- [% TRY %] [% FILTER badfact %] blah blah blah [% END %] [% CATCH %] BZZZT: [% error.type %]: [% error.info %] [% END %] -- expect -- BZZZT: filter: invalid FILTER for 'badfact' (not a CODE ref) -- test -- [% TRY %] [% FILTER badfilt %] blah blah blah [% END %] [% CATCH %] BZZZT: [% error.type %]: [% error.info %] [% END %] -- expect -- BZZZT: filter: invalid FILTER entry for 'badfilt' (not a CODE ref) -- test -- [% TRY; "foo" | barfilt; CATCH; "$error.type: $error.info"; END %] -- expect -- filter: barfed -- test -- [% TRY; "foo" | barfilt(1); CATCH; "$error.type: $error.info"; END %] -- expect -- dead: deceased -- test -- [% TRY; "foo" | barfilt(2); CATCH; "$error.type: $error.info"; END %] -- expect -- filter: keeled over -- test -- [% TRY; "foo" | barfilt(3); CATCH; "$error.type: $error.info"; END %] -- expect -- unwell: sick as a parrot #------------------------------------------------------------------------ # test filters #------------------------------------------------------------------------ -- test -- [% FILTER html %] This is some html text All the should be escaped & protected [% END %] -- expect -- This is some html text All the <tags> should be escaped & protected -- test -- [% text = "The sat on the " %] [% FILTER html %] text: $text [% END %] -- expect -- text: The <cat> sat on the <mat> -- test -- [% text = "The sat on the " %] [% text FILTER html %] -- expect -- The <cat> sat on the <mat> -- test -- [% FILTER html %] "It isn't what I expected", he replied. [% END %] -- expect -- "It isn't what I expected", he replied. -- test -- [% FILTER xml %] "It isn't what I expected", he replied. [% END %] -- expect -- "It isn't what I expected", he replied. -- test -- [% FILTER format %] Hello World! [% END %] -- expect -- Hello World! -- test -- # test aliasing of a filter [% FILTER comment = format('') %] Hello World! [% END +%] [% "Goodbye, cruel World" FILTER comment %] -- expect -- -- test -- [% FILTER format %] Hello World! [% END %] -- expect -- Hello World! -- test -- [% "Foo" FILTER test1 = format('+++ %-4s +++') +%] [% FOREACH item = [ 'Bar' 'Baz' 'Duz' 'Doze' ] %] [% item FILTER test1 +%] [% END %] [% "Wiz" FILTER test1 = format("*** %-4s ***") +%] [% "Waz" FILTER test1 +%] -- expect -- +++ Foo +++ +++ Bar +++ +++ Baz +++ +++ Duz +++ +++ Doze +++ *** Wiz *** *** Waz *** -- test -- [% FILTER microjive %] The "Halloween Document", leaked to Eric Raymond from an insider at Microsoft, illustrated Microsoft's strategy of "Embrace, Extend, Extinguish" [% END %] -- expect -- The "Halloween Document", leaked to Eric Raymond from an insider at The 'Soft, illustrated The 'Soft's strategy of "Embrace, Extend, Extinguish" -- test -- [% FILTER microsloth %] The "Halloween Document", leaked to Eric Raymond from an insider at Microsoft, illustrated Microsoft's strategy of "Embrace, Extend, Extinguish" [% END %] -- expect -- The "Halloween Document", leaked to Eric Raymond from an insider at Microsloth, illustrated Microsloth's strategy of "Embrace, Extend, Extinguish" -- test -- [% FILTER censor('bottom' 'nipple') %] At the bottom of the hill, he had to pinch the nipple to reduce the oil flow. [% END %] -- expect -- At the [** CENSORED **] of the hill, he had to pinch the [** CENSORED **] to reduce the oil flow. -- test -- [% FILTER bold = format('%s') %] This is bold [% END +%] [% FILTER italic = format('%s') %] This is italic [% END +%] [% 'This is both' FILTER bold FILTER italic %] -- expect -- This is bold This is italic This is both -- test -- [% "foo" FILTER format("<< %s >>") FILTER format("=%s=") %] -- expect -- =<< foo >>= -- test -- [% blocktext = BLOCK %] The cat sat on the mat Mary had a little Lamb You shall have a fishy on a little dishy, when the boat comes in. What if I can't wait until then? I'm hungry! [% END -%] [% global.blocktext = blocktext; blocktext %] -- expect -- The cat sat on the mat Mary had a little Lamb You shall have a fishy on a little dishy, when the boat comes in. What if I can't wait until then? I'm hungry! -- test -- [% global.blocktext FILTER html_para %] -- expect --

The cat sat on the mat

Mary had a little Lamb

You shall have a fishy on a little dishy, when the boat comes in. What if I can't wait until then? I'm hungry!

-- test -- [% global.blocktext FILTER html_break %] -- expect -- The cat sat on the mat

Mary had a little Lamb

You shall have a fishy on a little dishy, when the boat comes in. What if I can't wait until then? I'm hungry! -- test -- [% global.blocktext FILTER html_para_break %] -- expect -- The cat sat on the mat

Mary had a little Lamb

You shall have a fishy on a little dishy, when the boat comes in. What if I can't wait until then? I'm hungry! -- test -- [% global.blocktext FILTER html_line_break %] -- expect -- The cat sat on the mat

Mary had a little Lamb



You shall have a fishy on a little dishy, when the boat comes in. What
if I can't wait until then? I'm hungry!
-- test -- [% global.blocktext FILTER truncate(10) %] -- expect -- The cat... -- test -- [% global.blocktext FILTER truncate %] -- expect -- The cat sat on the mat Mary ... -- test -- [% 'Hello World' | truncate(2) +%] [% 'Hello World' | truncate(8) +%] [% 'Hello World' | truncate(10) +%] [% 'Hello World' | truncate(11) +%] [% 'Hello World' | truncate(20) +%] -- expect -- .. Hello... Hello W... Hello World Hello World -- test -- [% "foo..." FILTER repeat(5) %] -- expect -- foo...foo...foo...foo...foo... -- test -- [% FILTER truncate(21) %] I have much to say on this matter that has previously been said on more than one occassion. [% END %] -- expect -- I have much to say... -- test -- [% FILTER truncate(25) %] Nothing much to say [% END %] -- expect -- Nothing much to say -- test -- [% FILTER repeat(3) %] Am I repeating myself? [% END %] -- expect -- Am I repeating myself? Am I repeating myself? Am I repeating myself? -- test -- [% text FILTER remove(' ') +%] [% text FILTER remove('\s+') +%] [% text FILTER remove('cat') +%] [% text FILTER remove('at') +%] [% text FILTER remove('at', 'splat') +%] -- expect -- Thecatsatonthemat Thecatsatonthemat The sat on the mat The c s on the m The c s on the m -- test -- [% text FILTER replace(' ', '_') +%] [% text FILTER replace('sat', 'shat') +%] [% text FILTER replace('at', 'plat') +%] -- expect -- The_cat_sat_on_the_mat The cat shat on the mat The cplat splat on the mplat -- test -- [% text = 'The <=> operator' %] [% text|html %] -- expect -- The <=> operator -- test -- [% text = 'The <=> operator, blah, blah' %] [% text | html | replace('blah', 'rhubarb') %] -- expect -- The <=> operator, rhubarb, rhubarb -- test -- [% | truncate(25) %] The cat sat on the mat, and wondered to itself, "How might I be able to climb up onto the shelf?", For up there I am sure I'll see, A tasty fishy snack for me. [% END %] -- expect -- The cat sat on the mat... -- test -- [% FILTER upper %] The cat sat on the mat [% END %] -- expect -- THE CAT SAT ON THE MAT -- test -- [% FILTER lower %] The cat sat on the mat [% END %] -- expect -- the cat sat on the mat -- test -- [% 'arse' | stderr %] stderr: [% stderr %] -- expect -- stderr: arse -- test -- [% percent = '%' left = "[$percent" right = "$percent]" dir = "$left a $right blah blah $left b $right" %] [% dir +%] FILTER [[% dir | eval %]] FILTER [[% dir | evaltt %]] -- expect -- [% a %] blah blah [% b %] FILTER [alpha blah blah bravo] FILTER [alpha blah blah bravo] -- test -- [% TRY %] [% dir = "[\% FOREACH a = { 1 2 3 } %\]a: [\% a %\]\n[\% END %\]" %] [% dir | eval %] [% CATCH %] error: [[% error.type %]] [[% error.info %]] [% END %] -- expect -- error: [file] [parse error - input text line 1: unexpected token (1) [% FOREACH a = { 1 2 3 } %]] -- test -- nothing [% TRY; '$x = 10; $b = 20; $x + $b' | evalperl; CATCH; "$error.type: $error.info"; END +%] happening -- expect -- nothing perl: EVAL_PERL is not set happening -- test -- [% TRY -%] before [% FILTER redirect('xyz') %] blah blah blah here is the news [% a %] [% END %] after [% CATCH %] ERROR [% error.type %]: [% error.info %] [% END %] -- expect -- before ERROR redirect: OUTPUT_PATH is not set -- test -- -- use evalperl -- [% FILTER evalperl %] $a = 10; $b = 20; $stash->{ foo } = $a + $b; $stash->{ bar } = $context->config->{ BARVAL }; "all done" [% END +%] foo: [% foo +%] bar: [% bar %] -- expect -- all done foo: 30 bar: some random value -- test -- [% TRY -%] before [% FILTER file(outfile) -%] blah blah blah here is the news [% a %] [% END -%] after [% CATCH %] ERROR [% error.type %]: [% error.info %] [% END %] -- expect -- before after -- test -- [% PERL %] # static filter subroutine $Template::Filters::FILTERS->{ bar } = sub { my $text = shift; $text =~ s/^/bar: /gm; return $text; }; [% END -%] [% FILTER bar -%] The cat sat on the mat The dog sat on the log [% END %] -- expect -- bar: The cat sat on the mat bar: The dog sat on the log -- test -- [% PERL %] # dynamic filter factory $Template::Filters::FILTERS->{ baz } = [ sub { my $context = shift; my $word = shift || 'baz'; return sub { my $text = shift; $text =~ s/^/$word: /gm; return $text; }; }, 1 ]; [% END -%] [% FILTER baz -%] The cat sat on the mat The dog sat on the log [% END %] [% FILTER baz('wiz') -%] The cat sat on the mat The dog sat on the log [% END %] -- expect -- baz: The cat sat on the mat baz: The dog sat on the log wiz: The cat sat on the mat wiz: The dog sat on the log -- test -- -- use evalperl -- [% PERL %] $stash->set('merlyn', bless \&merlyn1, 'ttfilter'); sub merlyn1 { my $text = shift || ''; $text =~ s/stone/henge/g; return $text; } [% END -%] [% FILTER $merlyn -%] Let him who is without sin cast the first stone. [% END %] -- expect -- Let him who is without sin cast the first henge. -- test -- -- use evalperl -- [% PERL %] $stash->set('merlyn', sub { \&merlyn2 }); sub merlyn2 { my $text = shift || ''; $text =~ s/stone/henge/g; return $text; } [% END -%] [% FILTER $merlyn -%] Let him who is without sin cast the first stone. [% END %] -- expect -- Let him who is without sin cast the first henge. -- test -- [% myfilter = 'html' -%] [% FILTER $myfilter -%] [% END %] -- expect -- <html> -- test -- [% FILTER $despace -%] blah blah blah [%- END %] -- expect -- blah_blah_blah -- test -- -- use evalperl -- [% PERL %] $context->filter(\&newfilt, undef, 'myfilter'); sub newfilt { my $text = shift; $text =~ s/\s+/=/g; return $text; } [% END -%] [% FILTER myfilter -%] This is a test [%- END %] -- expect -- This=is=a=test -- test -- [% PERL %] $context->define_filter('xfilter', \&xfilter); sub xfilter { my $text = shift; $text =~ s/\s+/X/g; return $text; } [% END -%] [% FILTER xfilter -%] blah blah blah [%- END %] -- expect -- blahXblahXblah -- test -- [% FILTER another(3) -%] foo bar baz [% END %] -- expect -- foo bar baz foo bar baz foo bar baz -- test -- [% '$stash->{ a } = 25' FILTER evalperl %] [% a %] -- expect -- 25 25 -- test -- [% '$stash->{ a } = 25' FILTER perl %] [% a %] -- expect -- 25 25 -- test -- [% FILTER indent -%] The cat sat on the mat [% END %] -- expect -- The cat sat on the mat -- test -- [% FILTER indent(2) -%] The cat sat on the mat [% END %] -- expect -- The cat sat on the mat -- test -- [% FILTER indent('>> ') -%] The cat sat on the mat [% END %] -- expect -- >> The cat sat >> on the mat -- test -- [% text = 'The cat sat on the mat'; text | indent('> ') | indent('+') %] -- expect -- +> The cat sat on the mat -- test -- <<[% FILTER trim %] The cat sat on the mat [% END %]>> -- expect -- <> -- test -- <<[% FILTER collapse %] The cat sat on the mat [% END %]>> -- expect -- <> -- test -- [% FILTER format('++%s++') %]Hello World[% END %] [% FILTER format %]Hello World[% END %] -- expect -- ++Hello World++ Hello World -- test -- [% "my file.html" FILTER uri %] -- expect -- my%20file.html -- test -- [% "myfile.html" FILTER uri %] -- expect -- my%3Cfile%20%26%20your%3Efile.html -- test -- [% "foo@bar" FILTER uri %] -- expect -- foo%40bar -- test -- [% "foo@bar" FILTER url %] -- expect -- foo@bar -- test -- [% "myfile.html" | uri | html %] -- expect -- my%3Cfile%20%26%20your%3Efile.html -- test -- [% widetext | uri %] -- expect -- wide%3A%E6%97%A5%E6%9C%AC%E8%AA%9E -- test -- [% 'foobar' | ucfirst %] -- expect -- Foobar -- test -- [% 'FOOBAR' | lcfirst %] -- expect -- fOOBAR Template-Toolkit-2.24/t/foreach.t000644 000765 000765 00000024506 11674036057 016314 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/foreach.t # # Template script testing the FOREACH directive. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template qw( :status ); use Template::Test; #$Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; my ($a, $b, $c, $d, $l, $o, $r, $u, $w ) = qw( alpha bravo charlie delta lima oscar romeo uncle whisky ); my $day = -1; my @days = qw( Monday Tuesday Wednesday Thursday Friday Saturday Sunday ); my @months = qw( jan feb mar apr may jun jul aug sep oct nov dec ); my @people = ( { 'id' => 'abw', 'name' => 'Andy Wardley' }, { 'id' => 'sam', 'name' => 'Simon Matthews' } ); my @seta = ( $a, $b, $w ); my @setb = ( $c, $l, $o, $u, $d ); my $params = { 'a' => $a, 'b' => $b, 'c' => $c, 'C' => uc $c, 'd' => $d, 'l' => $l, 'o' => $o, 'r' => $r, 'u' => $u, 'w' => $w, 'seta' => \@seta, 'setb' => \@setb, 'users' => \@people, 'item' => 'foo', 'items' => [ 'foo', 'bar' ], 'days' => \@days, 'months' => sub { return \@months }, 'format' => \&format, 'people' => [ { id => 'abw', code => 'abw', name => 'Andy Wardley' }, { id => 'aaz', code => 'zaz', name => 'Azbaz Azbaz Zazbazzer' }, { id => 'bcd', code => 'dec', name => 'Binary Coded Decimal' }, { id => 'efg', code => 'zzz', name => 'Extra Fine Grass' }, ], 'sections' => { one => 'Section One', two => 'Section Two', three => 'Section Three', four => 'Section Four', }, nested => [ [ qw( a b c ) ], [ qw( x y z ) ], ], }; sub format { my $format = shift; $format = '%s' unless defined $format; return sub { sprintf($format, shift); } } my $template = Template->new({ INTERPOLATE => 1, POST_CHOMP => 1, ANYCASE => 0 }); my $ttdebug = Template->new({ DEBUG => 1, DEBUG_FORMAT => '', }); test_expect(\*DATA, [ default => $template, debug => $ttdebug ], $params); __DATA__ -- test -- [% FOREACH a = [ 1, 2, 3 ] %] [% a +%] [% END %] [% FOREACH foo.bar %] [% a %] [% END %] -- expect -- 1 2 3 -- test -- Commence countdown... [% FOREACH count = [ 'five' 'four' 'three' 'two' 'one' ] %] [% count +%] [% END %] Fire! -- expect -- Commence countdown... five four three two one Fire! -- test -- [% FOR count = [ 1 2 3 ] %]${count}..[% END %] -- expect -- 1..2..3.. -- test -- people: [% bloke = r %] [% people = [ c, bloke, o, 'frank' ] %] [% FOREACH person = people %] [ [% person %] ] [% END %] -- expect -- people: [ charlie ] [ romeo ] [ oscar ] [ frank ] -- test -- [% FOREACH name = setb %] [% name %], [% END %] -- expect -- charlie, lima, oscar, uncle, delta, -- test -- [% FOREACH name = r %] [% name %], $name, wherefore art thou, $name? [% END %] -- expect -- romeo, romeo, wherefore art thou, romeo? -- test -- [% user = 'fred' %] [% FOREACH user = users %] $user.name ([% user.id %]) [% END %] [% user.name %] -- expect -- Andy Wardley (abw) Simon Matthews (sam) Simon Matthews -- test -- [% name = 'Joe Random Hacker' id = 'jrh' %] [% FOREACH users %] $name ([% id %]) [% END %] $name ($id) -- expect -- Andy Wardley (abw) Simon Matthews (sam) Joe Random Hacker (jrh) -- test -- [% FOREACH i = [1..4] %] [% i +%] [% END %] -- expect -- 1 2 3 4 -- test -- [% first = 4 last = 8 %] [% FOREACH i = [first..last] %] [% i +%] [% END %] -- expect -- 4 5 6 7 8 -- test -- [% list = [ 'one' 'two' 'three' 'four' ] %] [% list.0 %] [% list.3 %] [% FOREACH n = [0..3] %] [% list.${n} %], [%- END %] -- expect -- one four one, two, three, four, -- test -- [% "$i, " FOREACH i = [-2..2] %] -- expect -- -2, -1, 0, 1, 2, -- test -- [% FOREACH i = item -%] - [% i %] [% END %] -- expect -- - foo -- test -- [% FOREACH i = items -%] - [% i +%] [% END %] -- expect -- - foo - bar -- test -- [% FOREACH item = [ a b c d ] %] $item [% END %] -- expect -- alpha bravo charlie delta -- test -- [% items = [ d C a c b ] %] [% FOREACH item = items.sort %] $item [% END %] -- expect -- alpha bravo CHARLIE charlie delta -- test -- [% items = [ d a c b ] %] [% FOREACH item = items.sort.reverse %] $item [% END %] -- expect -- delta charlie bravo alpha -- test -- [% userlist = [ b c d a C 'Andy' 'tom' 'dick' 'harry' ] %] [% FOREACH u = userlist.sort %] $u [% END %] -- expect -- alpha Andy bravo charlie CHARLIE delta dick harry tom -- test -- [% ulist = [ b c d a 'Andy' ] %] [% USE f = format("[- %-7s -]\n") %] [% f(item) FOREACH item = ulist.sort %] -- expect -- [- alpha -] [- Andy -] [- bravo -] [- charlie -] [- delta -] -- test -- [% FOREACH item = [ a b c d ] %] [% "List of $loop.size items:\n" IF loop.first %] #[% loop.number %]/[% loop.size %]: [% item +%] [% "That's all folks\n" IF loop.last %] [% END %] -- expect -- List of 4 items: #1/4: alpha #2/4: bravo #3/4: charlie #4/4: delta That's all folks -- test -- [% items = [ d b c a ] %] [% FOREACH item = items.sort %] [% "List of $loop.size items:\n----------------\n" IF loop.first %] * [% item +%] [% "----------------\n" IF loop.last %] [% END %] -- expect -- List of 4 items: ---------------- * alpha * bravo * charlie * delta ---------------- -- test -- [% list = [ a b c d ] %] [% i = 1 %] [% FOREACH item = list %] #[% i %]/[% list.size %]: [% item +%] [% i = inc(i) %] [% END %] -- expect -- #1/4: alpha #2/4: bravo #3/4: charlie #4/4: delta -- test -- [% FOREACH a = ['foo', 'bar', 'baz'] %] * [% loop.index %] [% a +%] [% FOREACH b = ['wiz', 'woz', 'waz'] %] - [% loop.index %] [% b +%] [% END %] [% END %] -- expect -- * 0 foo - 0 wiz - 1 woz - 2 waz * 1 bar - 0 wiz - 1 woz - 2 waz * 2 baz - 0 wiz - 1 woz - 2 waz -- test -- [% id = 12345 name = 'Original' user1 = { id => 'tom', name => 'Thomas' } user2 = { id => 'reg', name => 'Reginald' } %] [% FOREACH [ user1 ] %] id: [% id +%] name: [% name +%] [% FOREACH [ user2 ] %] - id: [% id +%] - name: [% name +%] [% END %] [% END %] id: [% id +%] name: [% name +%] -- expect -- id: tom name: Thomas - id: reg - name: Reginald id: 12345 name: Original -- test -- [% them = [ people.1 people.2 ] %] [% "$p.id($p.code): $p.name\n" FOREACH p = them.sort('id') %] -- expect -- aaz(zaz): Azbaz Azbaz Zazbazzer bcd(dec): Binary Coded Decimal -- test -- [% "$p.id($p.code): $p.name\n" FOREACH p = people.sort('code') %] -- expect -- abw(abw): Andy Wardley bcd(dec): Binary Coded Decimal aaz(zaz): Azbaz Azbaz Zazbazzer efg(zzz): Extra Fine Grass -- test -- [% "$p.id($p.code): $p.name\n" FOREACH p = people.sort('code').reverse %] -- expect -- efg(zzz): Extra Fine Grass aaz(zaz): Azbaz Azbaz Zazbazzer bcd(dec): Binary Coded Decimal abw(abw): Andy Wardley -- test -- [% "$p.id($p.code): $p.name\n" FOREACH p = people.sort('code') %] -- expect -- abw(abw): Andy Wardley bcd(dec): Binary Coded Decimal aaz(zaz): Azbaz Azbaz Zazbazzer efg(zzz): Extra Fine Grass -- test -- Section List: [% FOREACH item = sections %] [% item.key %] - [% item.value +%] [% END %] -- expect -- Section List: four - Section Four one - Section One three - Section Three two - Section Two -- test -- [% FOREACH a = [ 2..6 ] %] before [% a %] [% NEXT IF a == 5 +%] after [% a +%] [% END %] -- expect -- before 2 after 2 before 3 after 3 before 4 after 4 before 5before 6 after 6 -- test -- [% count = 1; WHILE (count < 10) %] [% count = count + 1 %] [% NEXT IF count < 5 %] count: [% count +%] [% END %] -- expect -- count: 5 count: 6 count: 7 count: 8 count: 9 count: 10 -- test -- [% FOR count = [ 1 2 3 ] %]${count}..[% END %] -- expect -- 1..2..3.. -- test -- [% FOREACH count = [ 1 2 3 ] %]${count}..[% END %] -- expect -- 1..2..3.. -- test -- [% FOR [ 1 2 3 ] %]..[% END %] -- expect -- ...... -- test -- [% FOREACH [ 1 2 3 ] %]..[% END %] -- expect -- ...... -- test -- [% FOREACH outer = nested -%] outer start [% FOREACH inner = outer -%] inner [% inner +%] [% "last inner\n" IF loop.last -%] [% END %] [% "last outer\n" IF loop.last -%] [% END %] -- expect -- outer start inner a inner b inner c last inner outer start inner x inner y inner z last inner last outer -- test -- [% FOREACH n = [ 1 2 3 4 5 ] -%] [% LAST IF loop.last -%] [% n %], [%- END %] -- expect -- 1, 2, 3, 4, -- test -- [% FOREACH n = [ 1 2 3 4 5 ] -%] [% BREAK IF loop.last -%] [% n %], [%- END %] -- expect -- 1, 2, 3, 4, -- test -- -- use debug -- [% FOREACH a = [ 1, 2, 3 ] -%] * [% a %] [% END -%] -- expect -- * 1 * 2 * 3 -- test -- [% FOREACH i = [1 .. 10]; SWITCH i; CASE 5; NEXT; CASE 8; LAST; END; "$i\n"; END; -%] -- expect -- 1 2 3 4 6 7 -- test -- [% FOREACH i = [1 .. 10]; IF 1; IF i == 5; NEXT; END; IF i == 8; LAST; END; END; "$i\n"; END; -%] -- expect -- 1 2 3 4 6 7 -- test -- [% FOREACH i = [1 .. 4]; FOREACH j = [1 .. 4]; k = 1; SWITCH j; CASE 2; FOREACH k IN [ 1 .. 2 ]; LAST; END; CASE 3; NEXT IF j == 3; END; "$i,$j,$k\n"; END; END; -%] -- expect -- 1,1,1 1,2,1 1,4,1 2,1,1 2,2,1 2,4,1 3,1,1 3,2,1 3,4,1 4,1,1 4,2,1 4,4,1 -- test -- [% LAST FOREACH k = [ 1 .. 4]; "$k\n"; # Should finish loop with k = 4. Instead this is an infinite loop!! #NEXT FOREACH k = [ 1 .. 4]; #"$k\n"; -%] -- expect -- 1 -- test -- [% FOREACH prime IN [2, 3, 5, 7, 11, 13]; "$prime\n"; END -%] -- expect -- 2 3 5 7 11 13 -- test -- -- name FOR/WHILE/NEXT -- [% FOREACH i IN [ 1..6 ]; "${i}: "; j = 0; WHILE j < i; j = j + 1; NEXT IF j > 3; "${j} "; END; "\n"; END; %] -- expect -- 1: 1 2: 1 2 3: 1 2 3 4: 1 2 3 5: 1 2 3 6: 1 2 3 Template-Toolkit-2.24/t/format.t000644 000765 000765 00000003455 11674036057 016175 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/format.t # # Template script testing the format plugin. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template qw( :status ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; $Template::Test::PRESERVE = 1; my ($a, $b, $c, $d) = qw( alpha bravo charlie delta ); my $params = { 'a' => $a, 'b' => $b, 'c' => $c, 'd' => $d, }; test_expect(\*DATA, { INTERPOLATE => 1, POST_CHOMP => 1 }, $params); #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ [% USE format %] [% bold = format('%s') %] [% ital = format('%s') %] [% bold('heading') +%] [% ital('author') +%] ${ ital('affil.') } [% bold('footing') +%] $bold -- expect -- heading author affil. footing -- test -- [% USE format('
  • %s') %] [% FOREACH item = [ a b c d ] %] [% format(item) +%] [% END %] -- expect --
  • alpha
  • bravo
  • charlie
  • delta -- test -- [% USE bold = format("%s") %] [% USE ital = format("%s") %] [% bold('This is bold') +%] [% ital('This is italic') +%] -- expect -- This is bold This is italic -- test -- [% USE padleft = format('%-*s') %] [% USE padright = format('%*s') %] [% padleft(10, a) %]-[% padright(10, b) %] -- expect -- alpha - bravo Template-Toolkit-2.24/t/html.t000644 000765 000765 00000005013 11674036057 015641 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/html.t # # Tests the 'HTML' plugin. # # Written by Andy Wardley # # Copyright (C) 2001 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$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template; use Template::Test; use Template::Plugin::HTML; my $DEBUG = grep(/-d/, @ARGV); $Template::Test::DEBUG = $DEBUG; $Template::Test::PRESERVE = $DEBUG; #------------------------------------------------------------------------ # behaviour of html filter depends on these being available #------------------------------------------------------------------------ use constant HAS_HTML_Entities => eval { require HTML::Entities; 1; }; use constant HAS_Apache_Util => eval { require Apache::Util; Apache::Utils::escape_html(''); 1; }; #print "Has HTML::Entities: ", HAS_HTML_Entities ? 'yes' : 'no', "\n"; #print "Has Apache::Util: ", HAS_Apache_Util ? 'yes' : 'no', "\n"; my $h = Template::Plugin::HTML->new('foo'); ok( $h, 'created HTML plugin' ); my $cfg = { }; my $vars = { entities => HAS_HTML_Entities || HAS_Apache_Util || 0, }; test_expect(\*DATA, $cfg, $vars); __DATA__ -- test -- -- name html plugin -- [% USE HTML -%] OK -- expect -- OK -- test -- -- name html filter -- [% FILTER html -%] < & > [%- END %] -- expect -- < &amp; > -- test -- -- name html entity -- [% TRY; text = "Lon Brocard" | html_entity; IF text == "Léon Brocard"; 'passed'; ELSIF text == "Léon Brocard"; 'passed'; ELSE; "failed: $text"; END; CATCH; error; END; %] -- expect -- -- process -- [% IF entities -%] passed [%- ELSE -%] html_entity error - cannot locate Apache::Util or HTML::Entities [%- END %] -- test -- [% USE html; html.url('my file.html') -%] -- expect -- my%20file.html -- test -- -- name escape -- [% USE HTML -%] [% HTML.escape("if (a < b && c > d) ...") %] -- expect -- if (a < b && c > d) ... -- test -- -- name sorted -- [% USE HTML(sorted=1) -%] [% HTML.element(table => { border => 1, cellpadding => 2 }) %] -- expect -- -- test -- -- name attributes -- [% USE HTML -%] [% HTML.attributes(border => 1, cellpadding => 2).split.sort.join %] -- expect -- border="1" cellpadding="2" Template-Toolkit-2.24/t/image.t000644 000765 000765 00000004342 11674036057 015763 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/image.t # # Tests the Image plugin. # # Written by Andy Wardley # # Copyright (C) 2002 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Cwd; use File::Spec; $^W = 1; eval "use Image::Info"; if ($@) { eval "use Image::Size"; skip_all('Neither Image::Info nor Image::Size installed') if $@; } my $dir = -d 't' ? 'images' : File::Spec->catfile(File::Spec->updir(), 'images'); my $vars = { dir => $dir, file => { logo => File::Spec->catfile($dir, 'ttdotorg.gif'), power => File::Spec->catfile($dir, 'tt2power.gif'), lname => 'ttdotorg.gif', }, }; test_expect(\*DATA, undef, $vars); __DATA__ -- test -- [% USE Image(file.logo) -%] file: [% Image.file %] size: [% Image.size.join(', ') %] width: [% Image.width %] height: [% Image.height %] -- expect -- -- process -- file: [% file.logo %] size: 110, 60 width: 110 height: 60 -- test -- [% USE image( name = file.power) -%] name: [% image.name %] file: [% image.file %] width: [% image.width %] height: [% image.height %] size: [% image.size.join(', ') %] -- expect -- -- process -- name: [% file.power %] file: [% file.power %] width: 78 height: 47 size: 78, 47 -- test -- [% USE image file.logo -%] attr: [% image.attr %] -- expect -- attr: width="110" height="60" -- test -- [% USE image file.logo -%] tag: [% image.tag %] tag: [% image.tag(class="myimage", alt="image") %] -- expect -- -- process -- tag: tag: image # test "root" -- test -- [% USE image( root=dir name=file.lname ) -%] [% image.tag %] -- expect -- -- process -- # test separate file and name -- test -- [% USE image( file= file.logo name = "other.jpg" alt="myfile") -%] [% image.tag %] -- expect -- myfile Template-Toolkit-2.24/t/include.t000644 000765 000765 00000014051 11674036057 016322 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/include.t # # Template script testing the INCLUDE and PROCESS directives. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ../lib ); use Template::Constants qw( :status ); use Template; use Template::Test; $^W = 1; #$Template::Test::DEBUG = 0; #$Template::Context::DEBUG = 0; # sample data my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z) = qw( alpha bravo charlie delta echo foxtrot golf hotel india juliet kilo lima mike november oscar papa quebec romeo sierra tango umbrella victor whisky x-ray yankee zulu ); my $replace = { 'a' => $a, 'b' => $b, 'c' => { 'd' => $d, 'e' => $e, 'f' => { 'g' => $g, 'h' => $h, }, }, 'r' => $r, 's' => $s, 't' => $t, }; # script may be being run in distribution root or 't' directory my $dir = -d 't' ? 't/test' : 'test'; my $tproc = Template->new({ INTERPOLATE => 1, INCLUDE_PATH => "$dir/src:$dir/lib", TRIM => 1, AUTO_RESET => 0, DEFAULT => 'default', }); my $incpath = [ "$dir/src", '/nowhere' ]; my $tt_reset = Template->new({ INTERPOLATE => 1, INCLUDE_PATH => $incpath, TRIM => 1, RECURSION => 1, DEFAULT => 'bad_default', }); $incpath->[1] = "$dir/lib"; # we want to process 'metadata' directly so that the correct top-level # 'template' reference is set instead of 'input text' my $output; $tproc->process('metadata', $replace, \$output); $replace->{ metaout } = $output; $replace->{ metamod } = (stat("$dir/src/metadata"))[9]; test_expect(\*DATA, [ default => $tproc, reset => $tt_reset ], $replace); __DATA__ -- test -- [% a %] [% PROCESS incblock -%] [% b %] [% INCLUDE first_block %] -- expect -- alpha bravo this is my first block, a is set to 'alpha' -- test -- [% INCLUDE first_block %] -- expect -- this is my first block, a is set to 'alpha' -- test -- [% INCLUDE first_block a = 'abstract' %] [% a %] -- expect -- this is my first block, a is set to 'abstract' alpha -- test -- [% INCLUDE 'first_block' a = t %] [% a %] -- expect -- this is my first block, a is set to 'tango' alpha -- test -- [% INCLUDE 'second_block' %] -- expect -- this is my second block, a is initially set to 'alpha' and then set to 'sierra' b is bravo m is 98 -- test -- [% INCLUDE second_block a = r, b = c.f.g, m = 97 %] [% a %] -- expect -- this is my second block, a is initially set to 'romeo' and then set to 'sierra' b is golf m is 97 alpha -- test -- FOO: [% INCLUDE foo +%] FOO: [% INCLUDE foo a = b -%] -- expect -- FOO: This is the foo file, a is alpha FOO: This is the foo file, a is bravo -- test -- GOLF: [% INCLUDE $c.f.g %] GOLF: [% INCLUDE $c.f.g g = c.f.h %] [% DEFAULT g = "a new $c.f.g" -%] [% g %] -- expect -- GOLF: This is the golf file, g is golf GOLF: This is the golf file, g is hotel a new golf -- test -- BAZ: [% INCLUDE bar/baz %] BAZ: [% INCLUDE bar/baz word='wizzle' %] BAZ: [% INCLUDE "bar/baz" %] -- expect -- BAZ: This is file baz The word is 'qux' BAZ: This is file baz The word is 'wizzle' BAZ: This is file baz The word is 'qux' -- test -- BAZ: [% INCLUDE bar/baz.txt %] BAZ: [% INCLUDE bar/baz.txt time = 'nigh' %] -- expect -- BAZ: This is file baz The word is 'qux' The time is now BAZ: This is file baz The word is 'qux' The time is nigh -- test -- [% BLOCK bamboozle -%] This is bamboozle [%- END -%] Block defined... [% blockname = 'bamboozle' -%] [% INCLUDE $blockname %] End -- expect -- Block defined... This is bamboozle End # test that BLOCK definitions get AUTO_RESET (i.e. cleared) by default -- test -- -- use reset -- [% a %] [% PROCESS incblock -%] [% INCLUDE first_block %] [% INCLUDE second_block %] [% b %] -- expect -- alpha this is my first block, a is set to 'alpha' this is my second block, a is initially set to 'alpha' and then set to 'sierra' b is bravo m is 98 bravo -- test -- [% TRY %] [% INCLUDE first_block %] [% CATCH file %] ERROR: [% error.info %] [% END %] -- expect -- ERROR: first_block: not found -- test -- -- use default -- [% metaout %] -- expect -- -- process -- TITLE: The cat sat on the mat metadata last modified [% metamod %] -- test -- [% TRY %] [% PROCESS recurse counter = 1 %] [% CATCH file -%] [% error.info %] [% END %] -- expect -- recursion count: 1 recursion into 'my file' -- test -- [% INCLUDE nosuchfile %] -- expect -- This is the default file -- test -- -- use reset -- [% TRY %] [% PROCESS recurse counter = 1 %] [% CATCH file %] [% error.info %] [% END %] -- expect -- recursion count: 1 recursion count: 2 recursion count: 3 -- test -- [% TRY; INCLUDE nosuchfile; CATCH; "ERROR: $error"; END %] -- expect -- ERROR: file error - nosuchfile: not found -- test -- [% INCLUDE src:foo %] [% BLOCK src:foo; "This is foo!"; END %] -- expect -- This is foo! -- test -- [% a = ''; b = ''; d = ''; e = 0 %] [% INCLUDE foo name = a or b or 'c' item = d or e or 'f' -%] [% BLOCK foo; "name: $name item: $item\n"; END %] -- expect -- name: c item: f -- test -- [% style = 'light'; your_title="Hello World" -%] [% INCLUDE foo title = my_title or your_title or default_title bgcol = (style == 'dark' ? '#000000' : '#ffffff') %] [% BLOCK foo; "title: $title\nbgcol: $bgcol\n"; END %] -- expect -- title: Hello World bgcol: #ffffff -- test -- [% myhash = { name = 'Tom' item = 'teacup' } -%] [% INCLUDE myblock name = 'Fred' item = 'fish' %] [% INCLUDE myblock import=myhash %] import([% import %]) [% PROCESS myblock import={ name = 'Tim', item = 'teapot' } %] import([% import %]) [% BLOCK myblock %][% name %] has a [% item %][% END %] -- expect -- Fred has a fish Tom has a teacup import() Tim has a teapot import() -- test -- Template-Toolkit-2.24/t/iterator.t000644 000765 000765 00000007251 11674036057 016534 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/iterator.t # # Template script testing Template::Iterator and # Template::Plugin::Iterator. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Iterator; $^W = 1; #$Template::Parser::DEBUG = 0; #$Template::Test::DEBUG = 0; my $data = [ qw( foo bar baz qux wiz woz waz ) ]; my $vars = { data => $data, # iterator => Template::Iterator->new($data), }; my $i1 = Template::Iterator->new($data); ok( $i1->get_first() eq 'foo' ); ok( $i1->get_next() eq 'bar' ); ok( $i1->get_next() eq 'baz' ); my $rest = $i1->get_all(); ok( scalar @$rest == 4 ); ok( $rest->[0] eq 'qux' ); ok( $rest->[3] eq 'waz' ); my ($val, $err) = $i1->get_next(); ok( ! $val ); ok( $err == Template::Constants::STATUS_DONE ); ($val, $err) = $i1->get_all(); ok( ! $val ); ok( $err == Template::Constants::STATUS_DONE ); ($val, $err) = $i1->get_first(); ok( $i1->get_first() eq 'foo' ); ok( $i1->get_next() eq 'bar' ); $rest = $i1->get_all(); ok( scalar @$rest == 5 ); # get_all with a few values in the iterator my $i2 = Template::Iterator->new($data); ($rest, $err) = $i2->get_all(); is( scalar @$rest, 7 ); ok( ! $err); ($val, $err) = $i2->get_all(); ok( ! $val); is( $err, Template::Constants::STATUS_DONE ); # get_all with a single value. my $i3 = Template::Iterator->new(['foo']); ($rest, $err) = $i3->get_all(); is( scalar @$rest, 1 ); is( pop @$rest, 'foo' ); ok( ! $err); ($val, $err) = $i3->get_all(); ok( ! $val); is( $err, Template::Constants::STATUS_DONE ); # get_all with an empty array my $i4 = Template::Iterator->new([]); ($val, $err) = $i4->get_all(); ok( ! $val); is( $err, Template::Constants::STATUS_DONE ); test_expect(\*DATA, { POST_CHOMP => 1 }, $vars); __DATA__ -- test -- [% items = [ 'foo' 'bar' 'baz' 'qux' ] %] [% FOREACH i = items %] * [% i +%] [% END %] -- expect -- * foo * bar * baz * qux -- test -- [% items = [ 'foo' 'bar' 'baz' 'qux' ] %] [% FOREACH i = items %] #[% loop.index %]/[% loop.max %] [% i +%] [% END %] -- expect -- #0/3 foo #1/3 bar #2/3 baz #3/3 qux -- test -- [% items = [ 'foo' 'bar' 'baz' 'qux' ] %] [% FOREACH i = items %] #[% loop.count %]/[% loop.size %] [% i +%] [% END %] -- expect -- #1/4 foo #2/4 bar #3/4 baz #4/4 qux -- test -- # test that 'number' is supported as an alias to 'count', for backwards # compatability [% items = [ 'foo' 'bar' 'baz' 'qux' ] %] [% FOREACH i = items %] #[% loop.number %]/[% loop.size %] [% i +%] [% END %] -- expect -- #1/4 foo #2/4 bar #3/4 baz #4/4 qux -- test -- [% USE iterator(data) %] [% FOREACH i = iterator %] [% IF iterator.first %] List of items: [% END %] * [% i +%] [% IF iterator.last %] End of list [% END %] [% END %] -- expect -- List of items: * foo * bar * baz * qux * wiz * woz * waz End of list -- test -- [% FOREACH i = [ 'foo' 'bar' 'baz' 'qux' ] %] [% "$loop.prev<-" IF loop.prev -%][[% i -%]][% "->$loop.next" IF loop.next +%] [% END %] -- expect -- [foo]->bar foo<-[bar]->baz bar<-[baz]->qux baz<-[qux] -- test -- -- name test even/odd/parity -- [% FOREACH item IN [1..10] -%] * [% loop.count %] [% loop.odd %] [% loop.even %] [% loop.parity +%] [% END -%] -- expect -- * 1 1 0 odd * 2 0 1 even * 3 1 0 odd * 4 0 1 even * 5 1 0 odd * 6 0 1 even * 7 1 0 odd * 8 0 1 even * 9 1 0 odd * 10 0 1 even Template-Toolkit-2.24/t/leak.t000644 000765 000765 00000012014 11674036057 015610 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/leak.t # # Attempts to detect memory leaks... but fails. That's a Good Thing # if it means there are no memory leaks (in this particular aspect) # or a Bad Thing if it there are, but we're not smart enough to detect # them. :-) # # Written by Andy Wardley # # Copyright (C) 1996-2001 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2001 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ../blib/arch ); use Template::Test; $^W = 1; $Template::Test::PRESERVE = 1; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; #------------------------------------------------------------------------ package Holler; use vars qw( $TRACE $PREFIX ); $TRACE = ''; $PREFIX = 'Holler:'; sub new { my $class = shift; my $id = shift || ''; my $self = bless \$id, $class; $self->trace("created"); return $self; } sub trace { my $self = shift; $TRACE .= "$$self @_\n"; } sub clear { $TRACE = ''; return ''; } sub DESTROY { my $self = shift; $self->trace("destroyed"); } #------------------------------------------------------------------------ package Plugin::Holler; use base qw( Template::Plugin ); sub new { my ($class, $context, @args) = @_; bless { context => $context, holler => Holler->new(@args), }, $class; } sub trace { my $self = shift; $self->{ context }->process('trace'); } #------------------------------------------------------------------------ package main; my $ttcfg = { INCLUDE_PATH => -d 't' ? 't/test/src' : 'test/src', PLUGIN_FACTORY => { holler => 'Plugin::Holler' }, EVAL_PERL => 1, BLOCKS => { trace => "TRACE ==[% trace %]==", }, }; my $ttvars = { holler => sub { Holler->new(@_) }, trace => sub { $Holler::TRACE }, clear => \&Holler::clear, v56 => ( $^V && eval '$^V ge v5.6.0' && eval '$^V le v5.7.0' ), }; test_expect(\*DATA, $ttcfg, $ttvars); __DATA__ -- test -- [% a = holler('first'); trace %] -- expect -- first created -- test -- [% trace %] -- expect -- first created first destroyed -- test -- [% clear; b = [ ]; b.0 = holler('list'); trace %] -- expect -- list created -- test -- [% trace %] -- expect -- list created list destroyed -- stop -- -- test -- [% BLOCK shout; a = holler('second'); END -%] [% clear; PROCESS shout; trace %] -- expect -- second created -- test -- [% BLOCK shout; a = holler('third'); END -%] [% clear; INCLUDE shout; trace %] -- expect -- third created third destroyed -- test -- [% MACRO shout BLOCK; a = holler('fourth'); END -%] [% clear; shout; trace %] -- expect -- fourth created fourth destroyed -- test -- [% clear; USE holler('holler plugin'); trace %] -- expect -- holler plugin created -- test -- [% BLOCK shout; USE holler('process plugin'); END -%] [% clear; PROCESS shout; holler.trace %] -- expect -- TRACE ==process plugin created == -- test -- [% BLOCK shout; USE holler('include plugin'); END -%] [% clear; INCLUDE shout; trace %] -- expect -- include plugin created include plugin destroyed -- test -- [% MACRO shout BLOCK; USE holler('macro plugin'); END -%] [% clear; shout; trace %] -- expect -- macro plugin created macro plugin destroyed -- test -- [% MACRO shout BLOCK; USE holler('macro plugin'); holler.trace; END -%] [% clear; shout; trace %] -- expect -- TRACE ==macro plugin created ==macro plugin created macro plugin destroyed -- test -- [% clear; PROCESS leak1; trace %] -- expect -- Hello created -- test -- [% clear; INCLUDE leak1; trace %] -- expect -- Hello created Hello destroyed -- test -- [% clear; PROCESS leak2; trace %] -- expect -- Goodbye created -- test -- [% clear; INCLUDE leak2; trace %] -- expect -- Goodbye created Goodbye destroyed -- test -- [% MACRO leak BLOCK; PROCESS leak1 + leak2; USE holler('macro plugin'); END -%] [% IF v56; clear; leak; trace; ELSE; "Perl version < 5.6.0 or > 5.7.0, skipping this test"; END -%] -- expect -- -- process -- [% IF v56 -%] Hello created Goodbye created macro plugin created Hello destroyed Goodbye destroyed macro plugin destroyed [% ELSE -%] Perl version < 5.6.0 or > 5.7.0, skipping this test [% END -%] -- test -- [% PERL %] Holler->clear(); my $h = Holler->new('perl'); $stash->set( h => $h ); [% END -%] [% trace %] -- expect -- perl created -- test -- [% BLOCK x; PERL %] Holler->clear(); my $h = Holler->new('perl'); $stash->set( h => $h ); [% END; END -%] [% x; trace %] -- expect -- perl created perl destroyed -- test -- [% MACRO y PERL %] Holler->clear(); my $h = Holler->new('perl macro'); $stash->set( h => $h ); [% END -%] [% y; trace %] -- expect -- perl macro created perl macro destroyed Template-Toolkit-2.24/t/lib/000755 000765 000765 00000000000 11714420735 015252 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/list.t000644 000765 000765 00000010635 11674036057 015656 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/list.t # # Tests list references as variables, including pseudo-methods such # as first(), last(), etc. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Constants qw( :status ); $^W = 1; use Template::Parser; $Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; # sample data my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z) = qw( alpha bravo charlie delta echo foxtrot golf hotel india juliet kilo lima mike november oscar papa quebec romeo sierra tango umbrella victor whisky x-ray yankee zulu ); my $data = [ $r, $j, $s, $t, $y, $e, $f, $z ]; my $vars = { 'a' => $a, 'b' => $b, 'c' => $c, 'd' => $d, 'e' => $e, data => $data, days => [ qw( Mon Tue Wed Thu Fri Sat Sun ) ], wxyz => [ { id => $z, name => 'Zebedee', rank => 'aa' }, { id => $y, name => 'Yinyang', rank => 'ba' }, { id => $x, name => 'Xeexeez', rank => 'ab' }, { id => $w, name => 'Warlock', rank => 'bb' }, ], inst => [ { name => 'piano', url => '/roses.html' }, { name => 'flute', url => '/blow.html' }, { name => 'organ', url => '/tulips.html' }, ], nest => [ [ 3, 1, 4 ], [ 2, [ 7, 1, 8 ] ] ], }; my $config = {}; test_expect(\*DATA, $config, $vars); __DATA__ #------------------------------------------------------------------------ # GET #------------------------------------------------------------------------ -- test -- [% data.0 %] and [% data.1 %] -- expect -- romeo and juliet -- test -- [% data.first %] - [% data.last %] -- expect -- romeo - zulu -- test -- [% data.size %] [% data.max %] -- expect -- 8 7 -- test -- [% data.join(', ') %] -- expect -- romeo, juliet, sierra, tango, yankee, echo, foxtrot, zulu -- test -- [% data.reverse.join(', ') %] -- expect -- zulu, foxtrot, echo, yankee, tango, sierra, juliet, romeo -- test -- [% data.sort.reverse.join(' - ') %] -- expect -- zulu - yankee - tango - sierra - romeo - juliet - foxtrot - echo -- test -- [% FOREACH item = wxyz.sort('id') -%] * [% item.name %] [% END %] -- expect -- * Warlock * Xeexeez * Yinyang * Zebedee -- test -- [% FOREACH item = wxyz.sort('rank') -%] * [% item.name %] [% END %] -- expect -- * Zebedee * Xeexeez * Yinyang * Warlock -- test -- [% FOREACH n = [0..6] -%] [% days.$n +%] [% END -%] -- expect -- Mon Tue Wed Thu Fri Sat Sun -- test -- [% data = [ 'one', 'two', data.first ] -%] [% data.join(', ') %] -- expect -- one, two, romeo -- test -- [% data = [ 90, 8, 70, 6, 1, 11, 10, 2, 5, 50, 52 ] -%] sort: [% data.sort.join(', ') %] nsort: [% data.nsort.join(', ') %] -- expect -- sort: 1, 10, 11, 2, 5, 50, 52, 6, 70, 8, 90 nsort: 1, 2, 5, 6, 8, 10, 11, 50, 52, 70, 90 -- test -- [% ilist = [] -%] [% ilist.push("$i.name") FOREACH i = inst -%] [% ilist.join(",\n") -%] [% global.ilist = ilist -%] -- expect -- piano, flute, organ -- test -- [% global.ilist.pop %] -- expect -- organ -- test -- [% global.ilist.shift %] -- expect -- piano -- test -- [% global.ilist.unshift('another') -%] [% global.ilist.join(', ') %] -- expect -- another, flute -- test -- [% nest.0.0 %].[% nest.0.1 %][% nest.0.2 +%] [% nest.1.shift %].[% nest.1.0.join('') %] -- expect -- 3.14 2.718 -- test -- [% # define some initial data people => [ { id => 'tom', name => 'Tom' }, { id => 'dick', name => 'Richard' }, { id => 'larry', name => 'Larry' }, ] -%] [% folk = [] -%] [% folk.push("$person.name") FOREACH person = people.sort('name') -%] [% folk.join(",\n") -%] -- expect -- Larry, Richard, Tom -- test -- [% data.grep('r').join(', ') %] -- expect -- romeo, sierra, foxtrot -- test -- [% data.grep('^r').join(', ') %] -- expect -- romeo Template-Toolkit-2.24/t/macro.t000644 000765 000765 00000005670 11674036057 016007 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/macro.t # # Template script testing the MACRO directives. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ../lib ); use Template::Test; $^W = 1; my $config = { INCLUDE_PATH => -d 't' ? 't/test/src' : 'test/src', EVAL_PERL => 1, TRIM => 1, }; test_expect(\*DATA, $config, &callsign); __DATA__ -- test -- [% MACRO foo INCLUDE foo -%] foo: [% foo %] foo(b): [% foo(a = b) %] -- expect -- foo: This is the foo file, a is alpha foo(b): This is the foo file, a is bravo -- test -- foo: [% foo %]. -- expect -- foo: . -- test -- [% MACRO foo(a) INCLUDE foo -%] foo: [% foo %] foo(c): [% foo(c) %] -- expect -- foo: This is the foo file, a is foo(c): This is the foo file, a is charlie -- test -- [% BLOCK mypage %] Header [% content %] Footer [% END %] [%- MACRO content BLOCK -%] This is a macro which encapsulates a template block. a: [% a -%] [% END -%] begin [% INCLUDE mypage %] mid [% INCLUDE mypage a = 'New Alpha' %] end -- expect -- begin Header This is a macro which encapsulates a template block. a: alpha Footer mid Header This is a macro which encapsulates a template block. a: New Alpha Footer end -- test -- [% BLOCK table %]
    [% rows %]
    [% END -%] [% # define some dummy data udata = [ { id => 'foo', name => 'Fubar' }, { id => 'bar', name => 'Babar' } ] -%] [% # define a macro to print each row of user data MACRO user_summary INCLUDE user_row FOREACH user = udata %] [% # here's the block for each row BLOCK user_row %] [% user.id %] [% user.name %] [% END -%] [% # now we can call the main table template, and alias our macro to 'rows' INCLUDE table rows = user_summary %] -- expect --
    foo Fubar
    bar Babar
    -- test -- [% MACRO one BLOCK -%] one: [% title %] [% END -%] [% saveone = one %] [% MACRO two BLOCK; title="2[$title]" -%] two: [% title %] -> [% saveone %] [% END -%] [% two(title="The Title") %] -- expect -- two: 2[The Title] -> one: -- test -- [% MACRO one BLOCK -%] one: [% title %] [% END -%] [% saveone = \one %] [% MACRO two BLOCK; title="2[$title]" -%] two: [% title %] -> [% saveone %] [% END -%] [% two(title="The Title") %] -- expect -- two: 2[The Title] -> one: 2[The Title] -- test -- -- name number macro -- [% MACRO number(n) GET n.chunk(-3).join(',') -%] [% number(1234567) %] -- expect -- 1,234,567 -- test -- -- name perl macro -- [% MACRO triple(n) PERL %] my $n = $stash->get('n'); print $n * 3; [% END -%] [% triple(10) %] -- expect -- 30 Template-Toolkit-2.24/t/math.t000644 000765 000765 00000002340 11674036057 015626 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/math.t # # Test the Math plugin module. # # Written by Andy Wardley and ... # # Copyright (C) 2002 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test qw( :all ); $^W = 1; test_expect(\*DATA); __DATA__ -- test -- [% USE Math; Math.sqrt(9) %] -- expect -- 3 -- test -- [% USE Math; Math.abs(-1) %] -- expect -- 1 -- test -- [% USE Math; Math.atan2(42, 42).substr(0,17) %] -- expect -- 0.785398163397448 -- test -- [% USE Math; Math.cos(2).substr(0,18) %] -- expect -- -0.416146836547142 -- test -- [% USE Math; Math.exp(6).substr(0,16) %] -- expect -- 403.428793492735 -- test -- [% USE Math; Math.hex(42) %] -- expect -- 66 -- test -- [% USE Math; Math.int(9.9) %] -- expect -- 9 -- test -- [% USE Math; Math.log(42).substr(0,15) %] -- expect -- 3.7376696182833 -- test -- [% USE Math; Math.oct(72) %] -- expect -- 58 -- test -- [% USE Math; Math.sin(0.304).substr(0,17) %] -- expect -- 0.299339178269093 Template-Toolkit-2.24/t/object.t000644 000765 000765 00000016367 11674036057 016161 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # t/object.t # # Template script testing code bindings to objects. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Exception; use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; #------------------------------------------------------------------------ # definition of test object class #------------------------------------------------------------------------ package T1; sub new { my $class = shift; bless { @_ }, $class; } sub die { die "barfed up\n"; } package TestObject; use vars qw( $AUTOLOAD ); sub new { my ($class, $params) = @_; $params ||= {}; bless { PARAMS => $params, DAYS => [ qw( Monday Tuesday Wednesday Thursday Friday Saturday Sunday ) ], DAY => 0, 'public' => 314, '.private' => 425, '_hidden' => 537, }, $class; } sub yesterday { my $self = shift; return "Love was such an easy game to play..."; } sub today { my $self = shift; return "Live for today and die for tomorrow."; } sub tomorrow { my ($self, $dayno) = @_; $dayno = $self->{ DAY }++ unless defined $dayno; $dayno %= 7; return $self->{ DAYS }->[$dayno]; } sub belief { my $self = shift; my $b = join(' and ', @_); $b = '' unless length $b; return "Oh I believe in $b."; } sub concat { my $self = shift; local $" = ', '; $self->{ PARAMS }->{ args } = "ARGS: @_"; } sub _private { my $self = shift; die "illegal call to private method _private()\n"; } sub AUTOLOAD { my ($self, @params) = @_; my $name = $AUTOLOAD; $name =~ s/.*:://; return if $name eq 'DESTROY'; my $value = $self->{ PARAMS }->{ $name }; if (ref($value) eq 'CODE') { return &$value(@params); } elsif (@params) { return $self->{ PARAMS }->{ $name } = shift @params; } else { return $value; } } #------------------------------------------------------------------------ # another object for testing auto-stringification #------------------------------------------------------------------------ package Stringy; use overload '""' => 'stringify', fallback => 1; sub new { my ($class, $text) = @_; bless \$text, $class; } sub stringify { my $self = shift; return "stringified '$$self'"; } #------------------------------------------------------------------------ # Another object for tracking down a bug with DBIx::Class where TT is # causing the numification operator to be called. Matt S Trout suggests # we've got a truth test somewhere that should be a defined but that # doesn't appear to be the case... # http://rt.cpan.org/Ticket/Display.html?id=23763 #------------------------------------------------------------------------ package Numbersome; use overload '""' => 'stringify', '0+' => 'numify', fallback => 1; sub new { my ($class, $text) = @_; bless \$text, $class; } sub numify { my $self = shift; return "FAIL: numified $$self"; } sub stringify { my $self = shift; return "PASS: stringified $$self"; } sub things { return [qw( foo bar baz )]; } package GetNumbersome; sub new { my ($class, $text) = @_; bless { }, $class; } sub num { Numbersome->new("from GetNumbersome"); } #------------------------------------------------------------------------ # main #------------------------------------------------------------------------ package main; sub new { my ($class, $text) = @_; bless \$text, $class; } my $objconf = { 'a' => 'alpha', 'b' => 'bravo', 'w' => 'whisky', }; my $replace = { thing => TestObject->new($objconf), string => Stringy->new('Test String'), t1 => T1->new(a => 10), num => Numbersome->new("Numbersome"), getnum => GetNumbersome->new, %{ callsign() }, }; test_expect(\*DATA, { INTERPOLATE => 1 }, $replace); #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ # test method calling via autoload to get parameters [% thing.a %] [% thing.a %] [% thing.b %] $thing.w -- expect -- alpha alpha bravo whisky # ditto to set parameters -- test -- [% thing.c = thing.b -%] [% thing.c %] -- expect -- bravo -- test -- [% thing.concat = thing.b -%] [% thing.args %] -- expect -- ARGS: bravo -- test -- [% thing.concat(d) = thing.b -%] [% thing.args %] -- expect -- ARGS: delta, bravo -- test -- [% thing.yesterday %] [% thing.today %] [% thing.belief(thing.a thing.b thing.w) %] -- expect -- Love was such an easy game to play... Live for today and die for tomorrow. Oh I believe in alpha and bravo and whisky. -- test -- Yesterday, $thing.yesterday $thing.today ${thing.belief('yesterday')} -- expect -- Yesterday, Love was such an easy game to play... Live for today and die for tomorrow. Oh I believe in yesterday. -- test -- [% thing.belief('fish' 'chips') %] [% thing.belief %] -- expect -- Oh I believe in fish and chips. Oh I believe in . -- test -- ${thing.belief('fish' 'chips')} $thing.belief -- expect -- Oh I believe in fish and chips. Oh I believe in . -- test -- [% thing.tomorrow %] $thing.tomorrow -- expect -- Monday Tuesday -- test -- [% FOREACH [ 1 2 3 4 5 ] %]$thing.tomorrow [% END %]. -- expect -- Wednesday Thursday Friday Saturday Sunday . #------------------------------------------------------------------------ # test private methods do not get exposed #------------------------------------------------------------------------ -- test -- before[% thing._private %] mid [% thing._hidden %]after -- expect -- before mid after -- test -- [% key = '_private' -%] [[% thing.$key %]] -- expect -- [] -- test -- [% key = '.private' -%] [[% thing.$key = 'foo' %]] [[% thing.$key %]] -- expect -- [] [] #------------------------------------------------------------------------ # test auto-stringification #------------------------------------------------------------------------ -- test -- [% string.stringify %] -- expect -- stringified 'Test String' -- test -- [% string %] -- expect -- stringified 'Test String' -- test -- [% "-> $string <-" %] -- expect -- -> stringified 'Test String' <- -- test -- [% "$string" %] -- expect -- stringified 'Test String' -- test -- foo $string bar -- expect -- foo stringified 'Test String' bar -- test -- .[% t1.dead %]. -- expect -- .. -- test -- .[% TRY; t1.die; CATCH; error; END %]. -- expect -- .undef error - barfed up . #----------------------------------------------------------------------- # try and pin down the numification bug #----------------------------------------------------------------------- -- test -- [% FOREACH item IN num.things -%] * [% item %] [% END -%] -- expect -- * foo * bar * baz -- test -- [% num %] -- expect -- PASS: stringified Numbersome -- test -- [% getnum.num %] -- expect -- PASS: stringified from GetNumbersome Template-Toolkit-2.24/t/output.t000644 000765 000765 00000005243 11674036057 016242 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/output.t # # Test the OUTPUT and OUTPUT_PATH options of the Template.pm module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; ntests(14); my $dir = -d 't' ? 't/test' : 'test'; my $f1 = 'foo.bar'; my $f2 = 'foo.baz'; my $file1 = "$dir/tmp/$f1"; my $file2 = "$dir/tmp/$f2"; #------------------------------------------------------------------------ my $tt = Template->new({ INCLUDE_PATH => "$dir/src:$dir/lib", OUTPUT_PATH => "$dir/tmp", }) || die Template->error(); unlink($file1) if -f $file1; ok( $tt->process('foo', &callsign, $f1) ); ok( -f $file1 ); open(FP, $file1) || die "$file1: $!\n"; local $/ = undef; my $out = ; close(FP); ok( 1 ); match( $out, "This is the foo file, a is alpha" ); unlink($file1); #------------------------------------------------------------------------ $tt = Template->new({ INCLUDE_PATH => "$dir/src:$dir/lib", OUTPUT_PATH => "$dir/tmp", OUTPUT => $f2, }) || die Template->error(); unlink($file2) if -f $file2; ok( $tt->process('foo', &callsign) ); ok( -f $file2 ); open(FP, $file2) || die "$file2: $!\n"; local $/ = undef; $out = ; close(FP); ok( 1 ); match( $out, "This is the foo file, a is alpha" ); unlink($file2); #------------------------------------------------------------------------ # test passing options like 'binmode' to Template process() method to # ensure they get passed onto _output() subroutine. #------------------------------------------------------------------------ package My::Template; use Template; use base qw( Template ); use vars qw( $MESSAGE ); sub DEBUG { my $self = shift; $MESSAGE = join('', @_); } package main; $tt = My::Template->new({ INCLUDE_PATH => "$dir/src:$dir/lib", OUTPUT_PATH => "$dir/tmp", OUTPUT => $f2, }) || die Template->error(); $Template::DEBUG = 1; ok( $tt->process('foo', &callsign, undef, { binmode => 1 }), 'processed' ); ok( -f $file2, 'output file exists' ); is( $My::Template::MESSAGE, "set binmode\n", 'set binmode via hashref' ); $My::Template::MESSAGE = 'reset'; ok( $tt->process('foo', &callsign, $f2, binmode => 1), 'processed again' ); ok( -f $file2, 'output file exists' ); is( $My::Template::MESSAGE, "set binmode\n", 'set binmode via arglist' ); unlink($file2); Template-Toolkit-2.24/t/parser.t000644 000765 000765 00000011357 11674036057 016201 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/parser.t # # Test the Template::Parser module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( . ../lib ); use Template::Test; use Template::Config; use Template::Parser; $^W = 1; #$Template::Test::DEBUG = 0; #$Template::Test::PRESERVE = 1; #$Template::Stash::DEBUG = 1; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; my $p2 = Template::Parser->new({ START_TAG => '\[\*', END_TAG => '\*\]', ANYCASE => 1, PRE_CHOMP => 1, V1DOLLAR => 1, }); # test new/old styles my $s1 = $p2->new_style( { TAG_STYLE => 'metatext', PRE_CHOMP => 0, POST_CHOMP => 1 } ) || die $p2->error(); ok( $s1 ); match( $s1->{ START_TAG }, '%%' ); match( $s1->{ PRE_CHOMP }, '0' ); match( $s1->{ POST_CHOMP }, '1' ); #print STDERR "style: { ", join(', ', map { "$_ => $s1->{ $_ }" } keys %$s1), " }\n"; my $s2 = $p2->old_style() || die $p2->error(); ok( $s2 ); match( $s2->{ START_TAG }, '\[\*' ); match( $s2->{ PRE_CHOMP }, '1' ); match( $s2->{ POST_CHOMP }, '0' ); #print STDERR "style: { ", join(', ', map { "$_ => $s2->{ $_ }" } keys %$s2), " }\n"; my $p3 = Template::Config->parser({ TAG_STYLE => 'html', POST_CHOMP => 1, ANYCASE => 1, INTERPOLATE => 1, }); my $p4 = Template::Config->parser({ ANYCASE => 0, }); my $tt = [ tt1 => Template->new(ANYCASE => 1), tt2 => Template->new(PARSER => $p2), tt3 => Template->new(PARSER => $p3), tt4 => Template->new(PARSER => $p4), ]; my $replace = &callsign; $replace->{ alist } = [ 'foo', 0, 'bar', 0 ]; $replace->{ wintxt } = "foo\r\n\r\nbar\r\n\r\nbaz"; $replace->{ data } = { first => 11, last => 42 }; test_expect(\*DATA, $tt, $replace); __DATA__ #------------------------------------------------------------------------ # tt1 #------------------------------------------------------------------------ -- test -- start $a [% BLOCK a %] this is a [% END %] =[% INCLUDE a %]= =[% include a %]= end -- expect -- start $a = this is a = = this is a = end -- test -- [% data.first; ' to '; data.last %] -- expect -- 11 to 42 #------------------------------------------------------------------------ # tt2 #------------------------------------------------------------------------ -- test -- -- use tt2 -- begin [% this will be ignored %] [* a *] end -- expect -- begin [% this will be ignored %]alpha end -- test -- $b does nothing: [* c = 'b'; 'hello' *] stuff: [* $c *] -- expect -- $b does nothing: hello stuff: b #------------------------------------------------------------------------ # tt3 #------------------------------------------------------------------------ -- test -- -- use tt3 -- begin [% this will be ignored %] end -- expect -- begin [% this will be ignored %] alphaend -- test -- $b does something: stuff: end -- expect -- bravo does something: hellostuff: bravoend #------------------------------------------------------------------------ # tt4 #------------------------------------------------------------------------ -- test -- -- use tt4 -- start $a[% 'include' = 'hello world' %] [% BLOCK a -%] this is a [%- END %] =[% INCLUDE a %]= =[% include %]= end -- expect -- start $a =this is a= =hello world= end #------------------------------------------------------------------------ -- test -- [% sql = " SELECT * FROM table" -%] SQL: [% sql %] -- expect -- SQL: SELECT * FROM table -- test -- [% a = "\a\b\c\ndef" -%] a: [% a %] -- expect -- a: abc def -- test -- [% a = "\f\o\o" b = "a is '$a'" c = "b is \$100" -%] a: [% a %] b: [% b %] c: [% c %] -- expect -- a: foo b: a is 'foo' c: b is $100 -- test -- [% tag = { a => "[\%" z => "%\]" } quoted = "[\% INSERT foo %\]" -%] A directive looks like: [% tag.a %] INCLUDE foo [% tag.z %] The quoted value is [% quoted %] -- expect -- A directive looks like: [% INCLUDE foo %] The quoted value is [% INSERT foo %] -- test -- =[% wintxt | replace("(\r\n){2,}", "\n\n") %] -- expect -- =foo bar baz -- test -- [% nl = "\n" tab = "\t" -%] blah blah[% nl %][% tab %]x[% nl; tab %]y[% nl %]end -- expect -- blah blah x y end #------------------------------------------------------------------------ # STOP RIGHT HERE! #------------------------------------------------------------------------ -- stop -- -- test -- alist: [% $alist %] -- expect -- alist: ?? -- test -- [% foo.bar.baz %] Template-Toolkit-2.24/t/plugins.t000644 000765 000765 00000014173 11674036057 016365 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/plugins.t # # Test the Template::Plugins module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( t/lib ./lib ../lib ../blib/arch ); use Template::Test; use Template::Plugins; use Template::Constants qw( :debug ); use Cwd qw( abs_path ); $^W = 1; my $DEBUG = grep(/^--?d(debug)?$/, @ARGV); #$Template::Test::DEBUG = 0; #$Template::Plugins::DEBUG = 0; my $dir = abs_path( -d 't' ? 't/test/plugin' : 'test/plugin' ); my $src = abs_path( -d 't' ? 't/test/lib' : 'test/lib' ); unshift(@INC, $dir); my $tt1 = Template->new({ PLUGIN_BASE => ['MyPlugs','Template::Plugin'], INCLUDE_PATH => $src, DEBUG => $DEBUG ? DEBUG_PLUGINS : 0, }) || die Template->error(); require "MyPlugs/Bar.pm"; my $bar = MyPlugs::Bar->new(4); my $tt2 = Template->new({ PLUGINS => { bar => 'MyPlugs::Bar', baz => 'MyPlugs::Foo', cgi => 'MyPlugs::Bar', }, DEBUG => $DEBUG ? DEBUG_PLUGINS : 0, }) || die Template->error(); my $tt3 = Template->new({ LOAD_PERL => 1, DEBUG => $DEBUG ? DEBUG_PLUGINS : 0, }) || die Template->error(); # we need to delete one of the standard plugins from the $STD_PLUGINS hash # for the purposes of testing delete $Template::Plugins::STD_PLUGINS->{ date }; # for these we don't want the default Template::Plugin added to the # PLUGIN_BASE search path $Template::Plugins::PLUGIN_BASE = ''; my $tt4 = Template->new({ PLUGIN_BASE => 'MyPlugs', DEBUG => $DEBUG ? DEBUG_PLUGINS : 0, }); my $tt5 = Template->new({ DEBUG => $DEBUG ? DEBUG_PLUGINS : 0, }); my $tt = [ def => Template->new(), tt1 => $tt1, tt2 => $tt2, tt3 => $tt3, tt4 => $tt4, tt5 => $tt5, ]; test_expect(\*DATA, $tt, &callsign()); __END__ #------------------------------------------------------------------------ # basic plugin loads #------------------------------------------------------------------------ -- test -- [% USE Table([2, 3, 5, 7, 11, 13], rows=2) -%] [% Table.row(0).join(', ') %] -- expect -- 2, 5, 11 -- test -- [% USE table([17, 19, 23, 29, 31, 37], rows=2) -%] [% table.row(0).join(', ') %] -- expect -- 17, 23, 31 -- test -- [% USE t = Table([41, 43, 47, 49, 53, 59], rows=2) -%] [% t.row(0).join(', ') %] -- expect -- 41, 47, 53 -- test -- [% USE t = table([61, 67, 71, 73, 79, 83], rows=2) -%] [% t.row(0).join(', ') %] -- expect -- 61, 71, 79 #------------------------------------------------------------------------ # load Foo plugin through custom PLUGIN_BASE #------------------------------------------------------------------------ -- test -- -- use tt1 -- -- test -- [% USE t = table([89, 97, 101, 103, 107, 109], rows=2) -%] [% t.row(0).join(', ') %] -- expect -- 89, 101, 107 -- test -- [% USE Foo(2) -%] [% Foo.output %] -- expect -- This is the Foo plugin, value is 2 -- test -- [% USE Bar(4) -%] [% Bar.output %] -- expect -- This is the Bar plugin, value is 4 #------------------------------------------------------------------------ # load Foo plugin through custom PLUGINS #------------------------------------------------------------------------ -- test -- -- use tt2 -- [% USE t = table([113, 127, 131, 137, 139, 149], rows=2) -%] [% t.row(0).join(', ') %] -- expect -- 113, 131, 139 -- test -- [% TRY -%] [% USE Foo(8) -%] [% Foo.output %] [% CATCH -%] ERROR: [% error.info %] [% END %] -- expect -- ERROR: Foo: plugin not found -- test -- [% USE bar(16) -%] [% bar.output %] -- expect -- This is the Bar plugin, value is 16 -- test -- [% USE qux = baz(32) -%] [% qux.output %] -- expect -- This is the Foo plugin, value is 32 -- test -- [% USE wiz = cgi(64) -%] [% wiz.output %] -- expect -- This is the Bar plugin, value is 64 #------------------------------------------------------------------------ # LOAD_PERL #------------------------------------------------------------------------ -- test -- -- use tt3 -- [% USE baz = MyPlugs.Baz(128) -%] [% baz.output %] -- expect -- This is the Baz module, value is 128 -- test -- [% USE boz = MyPlugs.Baz(256) -%] [% boz.output %] -- expect -- This is the Baz module, value is 256 #------------------------------------------------------------------------ # Test case insensitivity of plugin names. We first look for the plugin # using the name specified in its original case. From v2.15 we also look # for standard plugins using the lower case conversion of the plugin name # specified. #------------------------------------------------------------------------ -- test -- [% USE mycgi = url('/cgi-bin/bar.pl', debug=1); %][% mycgi %] -- expect -- /cgi-bin/bar.pl?debug=1 -- test -- [% USE mycgi = URL('/cgi-bin/bar.pl', debug=1); %][% mycgi %] -- expect -- /cgi-bin/bar.pl?debug=1 -- test -- [% USE mycgi = UrL('/cgi-bin/bar.pl', debug=1); %][% mycgi %] -- expect -- /cgi-bin/bar.pl?debug=1 #------------------------------------------------------------------------ # ADD_DEFAULT_PLUGIN_BASE = 0. # Template::Plugins::URL no longer works since Template::Plugins is not # added to the default plugin base. Same with others. However, url will # work since it is specified as a plugin in # Template::Plugins::STD_PLUGINS. #------------------------------------------------------------------------ # should find Foo as we've specified 'MyPlugs' in the PLUGIN_BASE -- test -- -- use tt4 -- [% USE Foo(20) -%] [% Foo.output %] -- expect -- This is the Foo plugin, value is 20 -- test -- -- use tt4 -- [% TRY -%] [% USE Date() -%] [% CATCH -%] ERROR: [% error.info %] [% END %] -- expect -- ERROR: Date: plugin not found -- test -- [% USE mycgi = url('/cgi-bin/bar.pl', debug=1); %][% mycgi %] -- expect -- /cgi-bin/bar.pl?debug=1 -- test -- -- use tt1 -- -- name Simple plugin filter -- [% USE Simple -%] test 1: [% 'hello' | simple %] [% INCLUDE simple2 %] test 3: [% 'world' | simple %] -- expect -- test 1: **hello** test 2: **badger** test 3: **world** Template-Toolkit-2.24/t/plusfile.t000644 000765 000765 00000003636 11674036057 016531 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/plufile.t # # Test ability to specify INCLUDE/PROCESS/WRAPPER files in the # form "foo+bar+baz". # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template; use Template::Test; use Template::Context; $^W = 1; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; $Template::Test::PRESERVE = 1; my $dir = -d 't' ? 't/test/src' : 'test/src'; test_expect(\*DATA, { INCLUDE_PATH => $dir }); __DATA__ -- test -- [% INCLUDE foo %] [% BLOCK foo; "This is foo!"; END %] -- expect -- This is foo! -- test -- [% INCLUDE foo+bar -%] [% BLOCK foo; "This is foo!\n"; END %] [% BLOCK bar; "This is bar!\n"; END %] -- expect -- This is foo! This is bar! -- test -- [% PROCESS foo+bar -%] [% BLOCK foo; "This is foo!\n"; END %] [% BLOCK bar; "This is bar!\n"; END %] -- expect -- This is foo! This is bar! -- test -- [% WRAPPER edge + box + indent title = "The Title" -%] My content [% END -%] [% BLOCK indent -%] [% content -%] [% END -%] [% BLOCK box -%] [% content -%] [% END -%] [% BLOCK edge -%] [% content -%] [% END -%] -- expect -- My content -- test -- [% INSERT foo+bar/baz %] -- expect -- This is the foo file, a is [% a -%][% DEFAULT word = 'qux' -%] This is file baz The word is '[% word %]' -- test -- [% file1 = 'foo' file2 = 'bar/baz' -%] [% INSERT "$file1" + "$file2" %] -- expect -- This is the foo file, a is [% a -%][% DEFAULT word = 'qux' -%] This is file baz The word is '[% word %]' Template-Toolkit-2.24/t/pod.t000644 000765 000765 00000004055 11674036057 015464 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/pod.t # # Tests the 'Pod' plugin. # # Written by Andy Wardley # # Copyright (C) 2001 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Carp qw( confess ); $^W = 1; $Template::Test::DEBUG = 0; $Template::Test::PRESERVE = 1; #$Template::View::DEBUG = 1; eval "use Pod::POM"; if ($@) { skip_all('Pod::POM not installed'); } my $config = { INCLUDE_PATH => 'templates:../templates', # RELATIVE => 1, # POST_CHOMP => 1, }; my $vars = { podloc => -d 't' ? 't/test/pod' : 'test/pod', }; test_expect(\*DATA, $config, $vars); __DATA__ -- test -- [% USE pod; pom = pod.parse("$podloc/no_such_file.pod"); pom ? 'not ok' : 'ok'; ' - file does not exist'; %] -- expect -- ok - file does not exist -- test -- [% USE pod; pom = pod.parse("$podloc/test1.pod"); pom ? 'ok' : 'not ok'; ' - file parsed'; global.pom = pom; global.warnings = pod.warnings; %] -- expect -- ok - file parsed -- test -- [% global.warnings.join("\n") %] -- expect -- -- process -- spurious '>' at [% podloc %]/test1.pod line 17 spurious '>' at [% podloc %]/test1.pod line 21 -- test -- [% FOREACH h1 = global.pom.head1 -%] * [% h1.title %] [% END %] -- expect -- * NAME * SYNOPSIS * DESCRIPTION * THE END -- test -- [% FOREACH h2 = global.pom.head1.2.head2 -%] + [% h2.title %] [% END %] -- expect -- + First Subsection + Second Subsection -- test -- [% PROCESS $item.type FOREACH item=global.pom.head1.2.content %] [% BLOCK head2 -%]

    [% item.title | trim %]

    [% END %] [% BLOCK text -%]

    [% item | trim %]

    [% END %] [% BLOCK verbatim -%] 
    [% item | trim %]
    [% END %] -- expect --

    This is the description for My::Module.

    This is verbatim

    First Subsection

    Second Subsection

    Template-Toolkit-2.24/t/prefix.t000644 000765 000765 00000002724 11674036057 016200 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/prefix.t # # Test template prefixes within INCLUDE, etc., directives. # # Written by Andy Wardley # # Copyright (C) 1996-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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template; use Template::Test; use Template::Config; $^W = 1; #$Template::Test::DEBUG = 0; #$Template::Context::DEBUG = 0; # script may be being run in distribution root or 't' directory my $dir = -d 't' ? 't/test' : 'test'; my $src_prov = Template::Config->provider( INCLUDE_PATH => "$dir/src" ); my $lib_prov = Template::Config->provider( INCLUDE_PATH => "$dir/lib" ); my $config = { LOAD_TEMPLATES => [ $src_prov, $lib_prov ], PREFIX_MAP => { src => '0', lib => '1', all => '0, 1', }, }; test_expect(\*DATA, $config); __DATA__ -- test -- [% INCLUDE foo a=10 %] -- expect -- This is the foo file, a is 10 -- test -- [% INCLUDE src:foo a=20 %] -- expect -- This is the foo file, a is 20 -- test -- [% INCLUDE all:foo a=30 %] -- expect -- This is the foo file, a is 30 -- test -- [% TRY; INCLUDE lib:foo a=30 ; CATCH; error; END %] -- expect -- file error - lib:foo: not found -- test -- [% INSERT src:foo %] -- expect -- This is the foo file, a is [% a -%] Template-Toolkit-2.24/t/proc.t000644 000765 000765 00000001543 11674036057 015644 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/proc.t # # Template script testing the procedural template plugin # # Written by Mark Fowler # # Copyright (C) 2002 Makr Fowler. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib t/lib ); use Template::Test; $^W = 1; my $ttcfg = {}; test_expect(\*DATA, $ttcfg, &callsign()); __DATA__ -- test -- [% USE ProcFoo -%] [% ProcFoo.foo %] [% ProcFoo.bar %] -- expect -- This is procfoofoo This is procfoobar -- test -- [% USE ProcBar -%] [% ProcBar.foo %] [% ProcBar.bar %] [% ProcBar.baz %] -- expect -- This is procfoofoo This is procbarbar This is procbarbaz Template-Toolkit-2.24/t/process.t000644 000765 000765 00000003606 11674036057 016361 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/process.t # # Test the PROCESS option. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Service; my $dir = -d 't' ? 't/test' : 'test'; my $config = { INCLUDE_PATH => "$dir/src:$dir/lib", PROCESS => 'content', TRIM => 1, }; my $tt1 = Template->new($config); $config->{ PRE_PROCESS } = 'config'; $config->{ PROCESS } = 'header:content'; $config->{ POST_PROCESS } = 'footer'; $config->{ TRIM } = 0; my $tt2 = Template->new($config); $config->{ PRE_PROCESS } = 'config:header.tt2'; $config->{ PROCESS } = ''; my $tt3 = Template->new($config); my $replace = { title => 'Joe Random Title', }; test_expect(\*DATA, [ tt1 => $tt1, tt2 => $tt2, tt3 => $tt3 ], $replace); __END__ -- test -- This is the first test -- expect -- This is the main content wrapper for "untitled" This is the first test This is the end. -- test -- [% META title = 'Test 2' -%] This is the second test -- expect -- This is the main content wrapper for "Test 2" This is the second test This is the end. -- test -- -- use tt2 -- [% META title = 'Test 3' -%] This is the third test -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' This is the main content wrapper for "Test 3" This is the third test This is the end. footer -- test -- -- use tt3 -- [% META title = 'Test 3' -%] This is the third test -- expect -- header.tt2: title: Joe Random Title menu: This is the menu, defined in 'config' footer Template-Toolkit-2.24/t/provider.t000644 000765 000765 00000026105 11674036057 016534 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/provider.t # # Test the Template::Provider module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Config; use Template::Provider; use Cwd 'abs_path'; $^W = 1; my $DEBUG = grep(/-d/, @ARGV); $Template::Test::DEBUG = 0; use Template::Constants qw( :debug ); $Template::Provider::DEBUG = $DEBUG ? DEBUG_PROVIDER | DEBUG_CALLER : 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; # uncommenting the next line should cause test 43 to fail because # the provider doesn't stat the file. # $Template::Provider::STAT_TTL = 10; my $factory = 'Template::Config'; # script may be being run in distribution root or 't' directory my $dir = -d 't' ? 't/test/src' : 'test/src'; my $lib = -d 't' ? 't/test/lib' : 'test/lib'; my $file = 'foo'; my $relfile = "./$dir/$file"; my $absfile = abs_path($dir) . '/' . $file; my $newfile = "$dir/foobar"; my $vars = { file => $file, relfile => $relfile, absfile => $absfile, fixfile => \&update_file, }; #------------------------------------------------------------------------ # This is used to test that source files are automatically reloaded # when updated on disk. we call it first to write a template file, # which is then included in one of the -- test -- sections below. # Then we call update_file() (via the 'fixfile' variable) and # include it again to see if the new file contents were loaded. #------------------------------------------------------------------------ sub update_file { local *FP; sleep(2); # ensure file time stamps are different open(FP, ">$newfile") || die "$newfile: $!\n"; print(FP @_) || die "failed to write $newfile: $!\n"; close(FP); } update_file('This is the old content'); #------------------------------------------------------------------------ # instantiate a bunch of providers, using various different techniques, # with different load options but sharing the same parser; then set them # to work fetching some files and check they respond as expected #------------------------------------------------------------------------ my $parser = $factory->parser(POST_CHOMP => 1) || die $factory->error(); ok( $parser ); my $provinc = $factory->provider( INCLUDE_PATH => $dir, PARSER => $parser, TOLERANT => 1 ) || die $factory->error(); ok( $provinc ); my $provabs = $factory->provider({ ABSOLUTE => 1, PARSER => $parser, }) || die $factory->error(); ok( $provabs ); my $provrel = Template::Provider->new({ RELATIVE => 1, PARSER => $parser, }) || die $Template::Provider::ERROR; ok( $provrel ); ok( $provinc->{ PARSER } == $provabs->{ PARSER } ); ok( $provabs->{ PARSER } == $provrel->{ PARSER } ); banner('matrix'); ok( delivered( $provinc, $file ) ); ok( declined( $provinc, $absfile ) ); ok( declined( $provinc, $relfile ) ); ok( declined( $provabs, $file ) ); ok( delivered( $provabs, $absfile ) ); ok( denied( $provabs, $relfile ) ); ok( declined( $provrel, $file ) ); ok( denied( $provrel, $absfile ) ); ok( delivered( $provrel, $relfile ) ); sub delivered { my ($provider, $file) = @_; my ($result, $error) = $provider->fetch($file); my $nice_result = defined $result ? $result : ''; my $nice_error = defined $error ? $error : ''; # print STDERR "$provider->fetch($file) -> [$nice_result] [$nice_error]\n" # if $DEBUG; return ! $error; } sub declined { my ($provider, $file) = @_; my ($result, $error) = $provider->fetch($file); my $nice_result = defined $result ? $result : ''; my $nice_error = defined $error ? $error : ''; # print STDERR "$provider->fetch($file) -> [$nice_result] [$nice_error]\n" # if $DEBUG; return ($error == Template::Constants::STATUS_DECLINED); } sub denied { my ($provider, $file) = @_; my ($result, $error) = $provider->fetch($file); # print STDERR "$provider->fetch($file) -> [$result] [$error]\n" # if $DEBUG; return ($error == Template::Constants::STATUS_ERROR); } #------------------------------------------------------------------------ # Test if can fetch from a file handle #------------------------------------------------------------------------ my $ttglob = Template->new || die "$Template::ERROR\n"; ok( $ttglob, 'Created template for glob test' ); # Make sure we have a multi-line template file so $/ is tested. my $glob_file = abs_path($dir) . '/baz'; open GLOBFILE, $glob_file or die "Failed to open '$absfile': $!"; my $outstr = ''; $ttglob->process( \*GLOBFILE, { a => 'globtest' }, \$outstr ) || die $ttglob->error; close GLOBFILE; my $glob_expect = "This is the baz file, a: globtest\n"; my $ok = $glob_expect eq $outstr; ok( $ok, $ok ? 'Fetch template from file handle' : <new( LOAD_TEMPLATES => [ $provinc ] ) || die "$Template::ERROR\n"; ok( $ttinc ); my $ttabs = Template->new( LOAD_TEMPLATES => [ $provabs ] ) || die "$Template::ERROR\n"; ok( $ttabs ); my $ttrel = Template->new( LOAD_TEMPLATES => [ $provrel ] ) || die "$Template::ERROR\n"; ok( $ttrel ); #------------------------------------------------------------------------ # here's a test of the dynamic path capability. we'll define a handler # sub and an object to return a dynamic list of paths #------------------------------------------------------------------------ package My::DPaths; sub new { my ($class, @paths) = @_; bless \@paths, $class; } sub paths { my $self = shift; return [ @$self ]; } package main; sub dpaths { return [ "$lib/one", "$lib/two" ], } # this one is designed to test the $MAX_DIRS runaway limit $Template::Provider::MAX_DIRS = 42; sub badpaths { return [ \&badpaths ], } my $dpaths = My::DPaths->new("$lib/two", "$lib/one"); my $ttd1 = Template->new({ INCLUDE_PATH => [ \&dpaths, $dir ], PARSER => $parser, }) || die "$Template::ERROR\n"; ok( $ttd1, 'dynamic path (sub) template object created' ); my $ttd2 = Template->new({ INCLUDE_PATH => [ $dpaths, $dir ], PARSER => $parser, }) || die "$Template::ERROR\n"; ok( $ttd1, 'dynamic path (obj) template object created' ); my $ttd3 = Template->new({ INCLUDE_PATH => [ \&badpaths ], PARSER => $parser, }) || die "$Template::ERROR\n"; ok( $ttd3, 'dynamic path (bad) template object created' ); my $uselist = [ ttinc => $ttinc, ttabs => $ttabs, ttrel => $ttrel, ttd1 => $ttd1, ttd2 => $ttd2, ttdbad => $ttd3 ]; test_expect(\*DATA, $uselist, $vars); __DATA__ -- test -- -- use ttinc -- [% TRY %] [% INCLUDE foo %] [% INCLUDE $relfile %] [% CATCH file %] Error: [% error.type %] - [% error.info.split(': ').1 %] [% END %] -- expect -- This is the foo file, a is Error: file - not found -- test -- [% TRY %] [% INCLUDE foo %] [% INCLUDE $absfile %] [% CATCH file %] Error: [% error.type %] - [% error.info.split(': ').1 %] [% END %] -- expect -- This is the foo file, a is Error: file - not found -- test -- [% TRY %] [% INSERT foo +%] [% INSERT $absfile %] [% CATCH file %] Error: [% error %] [% END %] -- expect -- -- process -- [% TAGS [* *] %] This is the foo file, a is [% a -%] Error: file error - [* absfile *]: not found #------------------------------------------------------------------------ -- test -- -- use ttrel -- [% TRY %] [% INCLUDE $relfile %] [% INCLUDE foo %] [% CATCH file -%] Error: [% error.type %] - [% error.info %] [% END %] -- expect -- This is the foo file, a is Error: file - foo: not found -- test -- [% TRY %] [% INCLUDE $relfile -%] [% INCLUDE $absfile %] [% CATCH file %] Error: [% error.type %] - [% error.info.split(': ').1 %] [% END %] -- expect -- This is the foo file, a is Error: file - absolute paths are not allowed (set ABSOLUTE option) -- test -- foo: [% TRY; INSERT foo; CATCH; "$error\n"; END %] rel: [% TRY; INSERT $relfile; CATCH; "$error\n"; END +%] abs: [% TRY; INSERT $absfile; CATCH; "$error\n"; END %] -- expect -- -- process -- [% TAGS [* *] %] foo: file error - foo: not found rel: This is the foo file, a is [% a -%] abs: file error - [* absfile *]: absolute paths are not allowed (set ABSOLUTE option) #------------------------------------------------------------------------ -- test -- -- use ttabs -- [% TRY %] [% INCLUDE $absfile %] [% INCLUDE foo %] [% CATCH file %] Error: [% error.type %] - [% error.info %] [% END %] -- expect -- This is the foo file, a is Error: file - foo: not found -- test -- [% TRY %] [% INCLUDE $absfile %] [% INCLUDE $relfile %] [% CATCH file %] Error: [% error.type %] - [% error.info.split(': ').1 %] [% END %] -- expect -- This is the foo file, a is Error: file - relative paths are not allowed (set RELATIVE option) -- test -- foo: [% TRY; INSERT foo; CATCH; "$error\n"; END %] rel: [% TRY; INSERT $relfile; CATCH; "$error\n"; END %] abs: [% TRY; INSERT $absfile; CATCH; "$error\n"; END %] -- expect -- -- process -- [% TAGS [* *] %] foo: file error - foo: not found rel: file error - [* relfile *]: relative paths are not allowed (set RELATIVE option) abs: This is the foo file, a is [% a -%] #------------------------------------------------------------------------ # test that files updated on disk are automatically reloaded. #------------------------------------------------------------------------ -- test -- -- use ttinc -- [% INCLUDE foobar %] -- expect -- This is the old content -- test -- [% CALL fixfile('This is the new content') %] [% INCLUDE foobar %] -- expect -- This is the new content #------------------------------------------------------------------------ # dynamic path tests #------------------------------------------------------------------------ -- test -- -- use ttd1 -- foo: [% PROCESS foo | trim +%] bar: [% PROCESS bar | trim +%] baz: [% PROCESS baz a='alpha' | trim %] -- expect -- foo: This is one/foo bar: This is two/bar baz: This is the baz file, a: alpha -- test -- foo: [% INSERT foo | trim +%] bar: [% INSERT bar | trim +%] -- expect -- foo: This is one/foo bar: This is two/bar -- test -- -- use ttd2 -- foo: [% PROCESS foo | trim +%] bar: [% PROCESS bar | trim +%] baz: [% PROCESS baz a='alpha' | trim %] -- expect -- foo: This is two/foo bar: This is two/bar baz: This is the baz file, a: alpha -- test -- foo: [% INSERT foo | trim +%] bar: [% INSERT bar | trim +%] -- expect -- foo: This is two/foo bar: This is two/bar -- test -- -- use ttdbad -- [% TRY; INCLUDE foo; CATCH; e; END %] -- expect -- file error - INCLUDE_PATH exceeds 42 directories Template-Toolkit-2.24/t/README000644 000765 000765 00000006226 11674036057 015377 0ustar00abwabw000000 000000 Script Testing ----------------------------------------------------------------------------- args.t Passing positional and named arguments to code/object methods autoform.t Autoformat plugin (Template::Plugin::Autoformat) base.t Template::Base.pm module binop.t Binary operators block.t BLOCK definition capture.t Capture directive output and assign to a variable case.t CASE option to switch case sensitivity cgi.t CGI plugin (Template::Plugin::CGI) compile1.t Compile templates to Perl code and save to file compile2.t Reload above compiled templates without re-parsing compile3.t Ensure that touching source template causes re-compilation compile4.t Compiling templates to a COMPILE_DIR compile5.t Reload templates from a COMPILE_DIR config.t Template::Config factory module context.t Template::Context module datafile.t Datafile plugin (Template::Plugin::Datafile) date.t Date plugin (Template::Plugin::Date) dbi.t DBI plugin (Template::Plugin::DBI) directive.t Directive layout, chomping, comments, etc. document.t Template::Document module dom.t XML::DOM plugin (Template::Plugin::XML::DOM) dumper.t Data::Dumper plugin (Template::Plugin::Data::Dumper) error.t Test that errors are reported back to caller as exceptions evalperl.t Evaluation of PERL and RAWPERL blocks exception.t Template::Exception module filter.t FILTER directive and various filters foreach.t FOREACH directive format.t Format plugin (Template::Plugin::Format) include.t INCLUDE and PROCESS directive iterator.t Template::Iterator and Iterator plugin modules list.t List definition and access via various methods macro.t MACRO directive object.t Binding objects to template variables output.t OUTPUT_PATH and OUTPUT options parser.t Template::Parser module plugins.t Template::Plugins provider module (incomplete) process.t PRE_PROCESS, PROCESS and POST_PROCESS options provider.t Template::Provider module ref.t Test the \ reference operator (currently undocumented) rss.t XML::RSS plugin (Template::Plugin::XML::RSS) service.t Template::Service module skel.t Skeleton test file. Copy and edit to create your own tests. stash.t Template::Stash module stop.t STOP directive and throwing 'stop' exception switch.t SWITCH / CASE directives table.t Table plugin (Template::Plugin::Table) tags.t TAGS directive template.t Template front-end module text.t Plain text blocks, ensuring all characters are reproducable try.t TRY / THROW / CATCH / FINAL directives url.t URL plugin (Template::Plugin::URL) vars.t Variable usage and GET / SET / CALL / DEFAULT directives varsv1.t As above, using version 1 handling of leading '$' vmeth.t Virtual scalar/hash/list methods while.t WHILE directive wrap.t Wrap plugin (Template::Plugin::Wrap) wrapper.t WRAPPER directive xpath.t XML::XPath plugin (Template::Plugin::XML::XPath) Template-Toolkit-2.24/t/ref.t000644 000765 000765 00000003206 11674036057 015453 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/ref.t # # Template script testing variable references. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ../lib ); use Template::Constants qw( :status ); use Template; use Template::Test; $^W = 1; #$Template::Test::DEBUG = 0; #$Template::Context::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY= 1; local $" = ', '; my $replace = { a => sub { return "a sub [@_]" }, j => { k => 3, l => 5, m => { n => sub { "nsub [@_]" } } }, z => sub { my $sub = shift; return "z called " . &$sub(10, 20, 30) }, }; test_expect(\*DATA, undef, $replace); __DATA__ -- test -- a: [% a %] a(5): [% a(5) %] a(5,10): [% a(5,10) %] -- expect -- a: a sub [] a(5): a sub [5] a(5,10): a sub [5, 10] -- test -- [% b = \a -%] b: [% b %] b(5): [% b(5) %] b(5,10): [% b(5,10) %] -- expect -- b: a sub [] b(5): a sub [5] b(5,10): a sub [5, 10] -- test -- [% c = \a(10,20) -%] c: [% c %] c(30): [% c(30) %] c(30,40): [% c(30,40) %] -- expect -- c: a sub [10, 20] c(30): a sub [10, 20, 30] c(30,40): a sub [10, 20, 30, 40] -- test -- [% z(\a) %] -- expect -- z called a sub [10, 20, 30] -- test -- [% f = \j.k -%] f: [% f %] -- expect -- f: 3 -- test -- [% f = \j.m.n -%] f: [% f %] f(11): [% f(11) %] -- expect -- f: nsub [] f(11): nsub [11] Template-Toolkit-2.24/t/scalar.t000644 000765 000765 00000005101 11674036057 016140 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/scalar.t # # Test the Scalar plugin which allows object methods to be called in # scalar context. # # Written by Andy Wardley # # Copyright (C) 1996-2008 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ../blib/lib ../blib/arch ); use Template::Test; #------------------------------------------------------------------------ # definition of test object class #------------------------------------------------------------------------ package Template::Test::HashObject; sub new { bless {}, shift; } sub bar { return wantarray ? qw( hash object method called in array context ) : 'hash object method called in scalar context'; } package Template::Test::ListObject; sub new { bless [], shift; } sub bar { return wantarray ? qw( list object method called in array context ) : 'list object method called in scalar context'; } #----------------------------------------------------------------------- # main #----------------------------------------------------------------------- package main; my $vars = { hashobj => Template::Test::HashObject->new, listobj => Template::Test::ListObject->new, subref => sub { return wantarray ? (qw( subroutine called in array context ), @_) : 'subroutine called in scalar context ' . join(' ', @_); } }; test_expect(\*DATA, undef, $vars); #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ -- test -- [% hashobj.bar.join %] -- expect -- hash object method called in array context -- test -- [% USE scalar -%] [% hashobj.scalar.bar %] -- expect -- hash object method called in scalar context -- test -- [% listobj.bar.join %] -- expect -- list object method called in array context -- test -- [% USE scalar -%] [% listobj.scalar.bar %] -- expect -- list object method called in scalar context -- test -- [% hash = { a = 10 }; TRY; hash.scalar.a; CATCH; error; END; %] -- expect -- scalar error - invalid object method: a -- test -- [% subref(10, 20).join %] -- expect -- subroutine called in array context 10 20 -- test -- [% USE scalar; scalar.subref(30, 40) %] -- expect -- subroutine called in scalar context 30 40 Template-Toolkit-2.24/t/service.t000644 000765 000765 00000012105 11674036057 016335 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/service.t # # Test the Template::Service module. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Service; use Template::Document; use Template::Constants qw( :debug ); my $DEBUG = grep(/^--?d(debug)?$/, @ARGV); my $dir = -d 't' ? 't/test' : 'test'; my $config = { INCLUDE_PATH => "$dir/src:$dir/lib", PRE_PROCESS => [ 'config', 'header' ], POST_PROCESS => 'footer', BLOCKS => { demo => sub { return 'This is a demo' }, astext => "Another template block, a is '[% a %]'", }, ERROR => { barf => 'barfed', default => 'error', }, DEBUG => $DEBUG ? DEBUG_SERVICE : 0, }; my $tt1 = Template->new($config); $config->{ AUTO_RESET } = 0; my $tt2 = Template->new($config); $config->{ ERROR } = 'barfed'; my $tt3 = Template->new($config); $config->{ PRE_PROCESS } = 'before'; $config->{ POST_PROCESS } = 'after'; $config->{ PROCESS } = 'process'; $config->{ WRAPPER } = 'outer'; my $tt4 = Template->new($config); $config->{ WRAPPER } = [ 'outer', 'inner' ]; my $tt5 = Template->new($config); my $replace = { title => 'Joe Random Title', }; test_expect(\*DATA, [ tt1 => $tt1, tt2 => $tt2, tt3 => $tt3, wrapper => $tt4, nested => $tt5, ], $replace); __END__ # test that headers and footers get added -- test -- This is some text -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' This is some text footer # test that the 'demo' block (template sub) is defined -- test -- [% INCLUDE demo %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' This is a demo footer # and also the 'astext' block (template text) -- test -- [% INCLUDE astext a = 'artifact' %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' Another template block, a is 'artifact' footer # test that 'barf' exception gets redirected to the correct error template -- test -- [% THROW barf 'Not feeling too good' %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' barfed: [barf] [Not feeling too good] footer # test all other errors get redirected correctly -- test -- [% INCLUDE no_such_file %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' error: [file] [no_such_file: not found] footer # import some block definitions from 'blockdef'... -- test -- [% PROCESS blockdef -%] [% INCLUDE block1 a = 'alpha' %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' start of blockdef end of blockdef This is block 1, defined in blockdef, a is alpha footer # ...and make sure they go away for the next service -- test -- [% INCLUDE block1 %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' error: [file] [block1: not found] footer # now try it again with AUTO_RESET turned off... -- test -- -- use tt2 -- [% PROCESS blockdef -%] [% INCLUDE block1 a = 'alpha' %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' start of blockdef end of blockdef This is block 1, defined in blockdef, a is alpha footer # ...and the block definitions should persist -- test -- [% INCLUDE block1 a = 'alpha' %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' This is block 1, defined in blockdef, a is alpha footer # test that the 'demo' block is still defined -- test -- [% INCLUDE demo %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' This is a demo footer # and also the 'astext' block -- test -- [% INCLUDE astext a = 'artifact' %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' Another template block, a is 'artifact' footer # test that a single ERROR template can be specified -- test -- -- use tt3 -- [% THROW food 'cabbages' %] -- expect -- header: title: Joe Random Title menu: This is the menu, defined in 'config' barfed: [food] [cabbages] footer -- test -- -- use wrapper -- [% title = 'The Foo Page' -%] begin page content title is "[% title %]" end page content -- expect -- This comes before begin process begin page content title is "The Foo Page" end page content end process This comes after -- test -- -- use nested -- [% title = 'The Bar Page' -%] begin page content title is "[% title %]" end page content -- expect -- This comes before begin process begin page content title is "The Bar Page" end page content end process This comes after Template-Toolkit-2.24/t/skel.t000644 000765 000765 00000001657 11674036057 015645 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/skel.t # # Skeleton test script. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; ok(1); my $config = { POST_CHOMP => 1, EVAL_PERL => 1, }; my $replace = { a => 'alpha', b => 'bravo', }; test_expect(\*DATA, $config, $replace); __DATA__ # this is the first test -- test -- [% a %] -- expect -- alpha # this is the second test -- test -- [% b %] -- expect -- bravo Template-Toolkit-2.24/t/stash-xs-unicode.t000644 000765 000765 00000003421 11704036146 020065 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/stash-xs-unicode.t # # Template script to test unicode data with the XS Stash # # Written by Andy Wardley based on code provided # by Максим Вуец. # # Copyright (C) 1996-2009 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ../blib/lib ../blib/arch ./blib/lib ./blib/arch ); use utf8; use Template; use Template::Test; BEGIN { unless ($] > 5.007) { skip_all("perl < 5.8 can't do unicode well enough\n"); } } eval { require Template::Stash::XS; }; if ($@) { warn $@; skip_all('cannot load Template::Stash::XS'); } binmode STDOUT, ':utf8'; $Template::Config::STASH = 'Template::Stash::XS'; my $data = { ascii => 'key', utf8 => 'ключ', hash => { key => 'value', ключ => 'значение' }, str => 'щука' }; test_expect(\*DATA, undef, $data); __DATA__ -- test -- -- name ASCII key -- ascii = [% ascii %] hash.$ascii = [% hash.$ascii %] -- expect -- ascii = key hash.$ascii = value -- test -- -- name UTF8 length -- str.length = [% str.length %] -- expect -- str.length = 4 -- test -- -- name UTF8 key fetch -- utf8 = [% utf8 %] hash.$utf8 = hash.[% utf8 %] = [% hash.$utf8 %] -- expect -- utf8 = ключ hash.$utf8 = hash.ключ = значение -- test -- -- name UTF8 key assign -- [% value = hash.$utf8; hash.$value = utf8 -%] value = [% value %] hash.$value = hash.[% value %] = [% hash.$value %] -- expect -- value = значение hash.$value = hash.значение = ключ Template-Toolkit-2.24/t/stash-xs.t000644 000765 000765 00000020240 11707773156 016453 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/stash-xs.t # # Template script testing (some elements of) the XS version of # Template::Stash # # Written by Andy Wardley # # Copyright (C) 1996-2009 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ../blib/lib ../blib/arch ./blib/lib ./blib/arch ); use Template::Constants qw( :status ); use Template; use Template::Test; eval { require Template::Stash::XS; }; if ($@) { warn $@; skip_all('cannot load Template::Stash::XS'); } #------------------------------------------------------------------------ # define some simple objects for testing #------------------------------------------------------------------------ package Buggy; sub new { bless {}, shift } sub croak { my $self = shift; die @_ } package ListObject; package HashObject; sub hello { my $self = shift; return "Hello $self->{ planet }"; } sub goodbye { my $self = shift; return $self->no_such_method(); } sub now_is_the_time_to_test_a_very_long_method_to_see_what_happens { my $self = shift; return $self->this_method_does_not_exist(); } #----------------------------------------------------------------------- # another object without overloaded comparison. # http://rt.cpan.org/Ticket/Display.html?id=24044 #----------------------------------------------------------------------- package CmpOverloadObject; use overload ('cmp' => 'compare_overload', '<=>', 'compare_overload'); sub new { bless {}, shift }; sub hello { return "Hello"; } sub compare_overload { die "Mayhem!"; } package main; my $count = 20; my $data = { foo => 10, bar => { baz => 20, }, baz => sub { return { boz => ($count += 10), biz => (shift || ''), }; }, obj => bless({ name => 'an object', }, 'AnObject'), bop => sub { return ( bless ({ name => 'an object' }, 'AnObject') ) }, listobj => bless([10, 20, 30], 'ListObject'), hashobj => bless({ planet => 'World' }, 'HashObject'), cmp_ol => CmpOverloadObject->new(), clean => sub { my $error = shift; $error =~ s/(\s*\(.*?\))?\s+at.*$//; return $error; }, correct => sub { die @_ }, buggy => Buggy->new(), str_eval_die => sub { # This is to test bug RT#47929 eval "use No::Such::Module::Exists"; return "str_eval_die returned"; }, }; my $stash = Template::Stash::XS->new($data); match( $stash->get('foo'), 10 ); #match( $stash->get(['foo']), 10 ); # fails match( $stash->get([ 'bar', 0, 'baz', 0 ]), 20 ); match( $stash->get('bar.baz'), 20 ); match( $stash->get('bar(10).baz'), 20 ); match( $stash->get('baz.boz'), 30 ); match( $stash->get('baz.boz'), 40 ); match( $stash->get('baz.biz'), '' ); match( $stash->get('baz(50).biz'), '' ); # args are ignored #match( $stash->get('str_eval_die'), '' ); $stash->set( 'bar.buz' => 100 ); match( $stash->get('bar.buz'), 100 ); # test the dotop() method match( $stash->dotop({ foo => 10 }, 'foo'), 10 ); my $stash_dbg = Template::Stash::XS->new({ %$data, _DEBUG => 1 }); my $ttlist = [ 'default' => Template->new( STASH => $stash ), 'warn' => Template->new( STASH => $stash_dbg ), ]; test_expect(\*DATA, $ttlist, $data); __DATA__ -- test -- -- name scalar list method -- [% foo = 'bar'; foo.join %] -- expect -- bar -- test -- a: [% a %] -- expect -- a: -- test -- -- use warn -- [% TRY; a; CATCH; "ERROR: $error"; END %] -- expect -- ERROR: undef error - a is undefined -- test -- -- use default -- [% myitem = 'foo' -%] 1: [% myitem %] 2: [% myitem.item %] 3: [% myitem.item.item %] -- expect -- 1: foo 2: foo 3: foo -- test -- [% myitem = 'foo' -%] [% "* $item\n" FOREACH item = myitem -%] [% "+ $item\n" FOREACH item = myitem.list %] -- expect -- * foo + foo -- test -- [% myitem = 'foo' -%] [% myitem.hash.value %] -- expect -- foo -- test -- [% myitem = 'foo' mylist = [ 'one', myitem, 'three' ] global.mylist = mylist -%] [% mylist.item %] 0: [% mylist.item(0) %] 1: [% mylist.item(1) %] 2: [% mylist.item(2) %] -- expect -- one 0: one 1: foo 2: three -- test -- [% "* $item\n" FOREACH item = global.mylist -%] [% "+ $item\n" FOREACH item = global.mylist.list -%] -- expect -- * one * foo * three + one + foo + three -- test -- [% global.mylist.push('bar'); "* $item.key => $item.value\n" FOREACH item = global.mylist.hash -%] -- expect -- * one => foo * three => bar -- test -- [% myhash = { msg => 'Hello World', things => global.mylist, a => 'alpha' }; global.myhash = myhash -%] * [% myhash.item('msg') %] -- expect -- * Hello World -- test -- [% global.myhash.delete('things') -%] keys: [% global.myhash.keys.sort.join(', ') %] -- expect -- keys: a, msg -- test -- [% "* $item\n" FOREACH item IN global.myhash.items.sort -%] -- expect -- * a * alpha * Hello World * msg -- test -- [% items = [ 'foo', 'bar', 'baz' ]; take = [ 0, 2 ]; slice = items.$take; slice.join(', '); %] -- expect -- foo, baz -- test -- -- name slice of lemon -- [% items = { foo = 'one', bar = 'two', baz = 'three' } take = [ 'foo', 'baz' ]; slice = items.$take; slice.join(', '); %] -- expect -- one, three -- test -- -- name slice of toast -- [% items = { foo = 'one', bar = 'two', baz = 'three' } keys = items.keys.sort; items.${keys}.join(', '); %] -- expect -- two, three, one -- test -- [% i = 0 %] [%- a = [ 0, 1, 2 ] -%] [%- WHILE i < 3 -%] [%- i %][% a.$i -%] [%- i = i + 1 -%] [%- END %] -- expect -- 001122 -- test -- [%- a = [ "alpha", "beta", "gamma", "delta" ] -%] [%- b = "foo" -%] [%- a.$b -%] -- expect -- -- test -- [%- a = [ "alpha", "beta", "gamma", "delta" ] -%] [%- b = "2" -%] [%- a.$b -%] -- expect -- gamma -- test -- [% obj.name %] -- expect -- an object -- test -- [% obj.name.list.first %] -- expect -- an object -- test -- -- name bop -- [% bop.first.name %] -- expect -- an object -- test -- [% obj.items.first %] -- expect -- name -- test -- [% obj.items.1 %] -- expect -- an object -- test -- =[% size %]= -- expect -- == -- test -- [% USE Dumper; TRY; correct(["hello", "there"]); CATCH; error.info.join(', '); END; %] == [% TRY; buggy.croak(["hello", "there"]); CATCH; error.info.join(', '); END; %] -- expect -- hello, there == hello, there -- test -- [% hash = { } list = [ hash ] list.last.message = 'Hello World'; "message: $list.last.message\n" -%] -- expect -- message: Hello World # test Dave Howorth's patch (v2.15) which makes the stash more strict # about what it considers to be a missing method error -- test -- [% hashobj.hello %] -- expect -- Hello World -- test -- [% TRY; hashobj.goodbye; CATCH; "ERROR: "; clean(error); END %] -- expect -- ERROR: undef error - Can't locate object method "no_such_method" via package "HashObject" -- test -- [% TRY; hashobj.now_is_the_time_to_test_a_very_long_method_to_see_what_happens; CATCH; "ERROR: "; clean(error); END %] -- expect -- ERROR: undef error - Can't locate object method "this_method_does_not_exist" via package "HashObject" -- test -- [% foo = { "one" = "bar" "" = "empty" } -%] foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]} setting foo.one to baz [% fookey = "one" foo.$fookey = "baz" -%] foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]} setting foo."" to quux [% fookey = "" foo.$fookey = "full" -%] foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]} --expect -- foo is { "" = "empty" "one" = "bar" } setting foo.one to baz foo is { "" = "empty" "one" = "baz" } setting foo."" to quux foo is { "" = "full" "one" = "baz" } # Exercise the object with the funky overloaded comparison -- test -- [% cmp_ol.hello %] -- expect -- Hello -- test -- Before [% TRY; str_eval_die; CATCH; "caught error: $error"; END; %] After -- expect -- Before str_eval_die returned After -- test -- [% str_eval_die %] -- expect -- str_eval_die returned Template-Toolkit-2.24/t/stash.t000644 000765 000765 00000017641 11674036057 016031 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/stash.t # # Template script testing (some elements of) the Template::Stash # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Constants qw( :status :debug ); use Template; use Template::Stash; use Template::Config; use Template::Test; $^W = 1; my $DEBUG = grep(/-d/, @ARGV); #$Template::Parser::DEBUG = $DEBUG; #$Template::Directive::PRETTY = $DEBUG; #------------------------------------------------------------------------ # define some simple objects for testing #------------------------------------------------------------------------ package ListObject; package HashObject; sub hello { my $self = shift; return "Hello $self->{ planet }"; } sub goodbye { my $self = shift; return $self->no_such_method(); } #------------------------------------------------------------------------ # Another object for tracking down a bug with DBIx::Class where TT is # causing the numification operator to be called. Matt S Trout suggests # we've got a truth test somewhere that should be a defined but that # doesn't appear to be the case... # http://rt.cpan.org/Ticket/Display.html?id=23763 #------------------------------------------------------------------------ package Numbersome; use overload '""' => 'stringify', '0+' => 'numify', fallback => 1; sub new { my ($class, $text) = @_; bless \$text, $class; } sub numify { my $self = shift; return "FAIL: numified $$self"; } sub stringify { my $self = shift; return "PASS: stringified $$self"; } sub things { return [qw( foo bar baz )]; } package GetNumbersome; sub new { my ($class, $text) = @_; bless { }, $class; } sub num { Numbersome->new("from GetNumbersome"); } #----------------------------------------------------------------------- # another object without overloaded comparison. # http://rt.cpan.org/Ticket/Display.html?id=24044 #----------------------------------------------------------------------- package CmpOverloadObject; use overload ('cmp' => 'compare_overload', '<=>', 'compare_overload'); sub new { bless {}, shift }; sub hello { return "Hello"; } sub compare_overload { die "Mayhem!"; } package main; $Template::Config::STASH = 'Template::Stash'; my $count = 20; my $data = { foo => 10, bar => { baz => 20, }, baz => sub { return { boz => ($count += 10), biz => (shift || ''), }; }, obj => bless({ name => 'an object', }, 'AnObject'), bop => sub { return ( bless ({ name => 'an object' }, 'AnObject') ) }, hashobj => bless({ planet => 'World' }, 'HashObject'), listobj => bless([10, 20, 30], 'ListObject'), num => Numbersome->new("Numbersome"), getnum => GetNumbersome->new, cmp_ol => CmpOverloadObject->new(), clean => sub { my $error = shift; $error =~ s/(\s*\(.*?\))?\s+at.*$//; return $error; }, }; my $stash = Template::Stash->new($data); match( $stash->get('foo'), 10 ); match( $stash->get([ 'bar', 0, 'baz', 0 ]), 20 ); match( $stash->get('bar.baz'), 20 ); match( $stash->get('bar(10).baz'), 20 ); match( $stash->get('baz.boz'), 30 ); match( $stash->get('baz.boz'), 40 ); match( $stash->get('baz.biz'), '' ); match( $stash->get('baz(50).biz'), '' ); # args are ignored $stash->set( 'bar.buz' => 100 ); match( $stash->get('bar.buz'), 100 ); # test the dotop() method match( $stash->dotop({ foo => 10 }, 'foo'), 10 ); my $ttlist = [ 'default' => Template->new(), 'warn' => Template->new(DEBUG => DEBUG_UNDEF, DEBUG_FORMAT => ''), ]; test_expect(\*DATA, $ttlist, $data); __DATA__ -- test -- a: [% a %] -- expect -- a: -- test -- -- use warn -- [% TRY; a; CATCH; "ERROR: $error"; END %] -- expect -- ERROR: undef error - a is undefined -- test -- -- use default -- [% myitem = 'foo' -%] 1: [% myitem %] 2: [% myitem.item %] 3: [% myitem.item.item %] -- expect -- 1: foo 2: foo 3: foo -- test -- [% myitem = 'foo' -%] [% "* $item\n" FOREACH item = myitem -%] [% "+ $item\n" FOREACH item = myitem.list %] -- expect -- * foo + foo -- test -- [% myitem = 'foo' -%] [% myitem.hash.value %] -- expect -- foo -- test -- [% myitem = 'foo' mylist = [ 'one', myitem, 'three' ] global.mylist = mylist -%] [% mylist.item %] 0: [% mylist.item(0) %] 1: [% mylist.item(1) %] 2: [% mylist.item(2) %] -- expect -- one 0: one 1: foo 2: three -- test -- [% "* $item\n" FOREACH item = global.mylist -%] [% "+ $item\n" FOREACH item = global.mylist.list -%] -- expect -- * one * foo * three + one + foo + three -- test -- [% global.mylist.push('bar'); "* $item.key => $item.value\n" FOREACH item = global.mylist.hash -%] -- expect -- * one => foo * three => bar -- test -- [% myhash = { msg => 'Hello World', things => global.mylist, a => 'alpha' }; global.myhash = myhash -%] * [% myhash.item('msg') %] -- expect -- * Hello World -- test -- [% global.myhash.delete('things') -%] keys: [% global.myhash.keys.sort.join(', ') %] -- expect -- keys: a, msg -- test -- [% "* $item\n" FOREACH item IN global.myhash.items.sort -%] -- expect -- * a * alpha * Hello World * msg -- test -- [% items = [ 'foo', 'bar', 'baz' ]; take = [ 0, 2 ]; slice = items.$take; slice.join(', '); %] -- expect -- foo, baz -- test -- [% items = { foo = 'one', bar = 'two', baz = 'three' } take = [ 'foo', 'baz' ]; slice = items.$take; slice.join(', '); %] -- expect -- one, three -- test -- [% items = { foo = 'one', bar = 'two', baz = 'three' } keys = items.keys.sort; items.${keys}.join(', '); %] -- expect -- two, three, one -- test -- [% obj.name %] -- expect -- an object -- test -- [% obj.name.list.first %] -- expect -- an object -- test -- [% obj.items.first %] -- expect -- name -- test -- [% obj.items.1 %] -- expect -- an object -- test -- [% bop.first.name %] -- expect -- an object -- test -- [% listobj.0 %] / [% listobj.first %] -- expect -- 10 / 10 -- test -- [% listobj.2 %] / [% listobj.last %] -- expect -- 30 / 30 -- test -- [% listobj.join(', ') %] -- expect -- 10, 20, 30 -- test -- =[% size %]= -- expect -- == -- test -- [% foo = { "one" = "bar" "" = "empty" } -%] foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]} setting foo.one to baz [% fookey = "one" foo.$fookey = "baz" -%] foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]} setting foo."" to quux [% fookey = "" foo.$fookey = "full" -%] foo is { [% FOREACH k IN foo.keys.sort %]"[% k %]" = "[% foo.$k %]" [% END %]} --expect -- foo is { "" = "empty" "one" = "bar" } setting foo.one to baz foo is { "" = "empty" "one" = "baz" } setting foo."" to quux foo is { "" = "full" "one" = "baz" } # test Dave Howorth's patch (v2.15) which makes the stash more strict # about what it considers to be a missing method error -- test -- [% hashobj.hello %] -- expect -- Hello World -- test -- [% TRY; hashobj.goodbye; CATCH; "ERROR: "; clean(error); END %] -- expect -- ERROR: undef error - Can't locate object method "no_such_method" via package "HashObject" #----------------------------------------------------------------------- # try and pin down the numification bug #----------------------------------------------------------------------- -- test -- [% FOREACH item IN num.things -%] * [% item %] [% END -%] -- expect -- * foo * bar * baz -- test -- [% num %] -- expect -- PASS: stringified Numbersome -- test -- [% getnum.num %] -- expect -- PASS: stringified from GetNumbersome # Exercise the object with the funky overloaded comparison -- test -- [% cmp_ol.hello %] -- expect -- Hello Template-Toolkit-2.24/t/stashc.t000644 000765 000765 00000003136 11674036057 016166 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/stashc.t # # Template script testing the Template::Stash::Context module. # Currently only partially complete. # # Written by Andy Wardley # # Copyright (C) 1996-2001 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2001 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ../lib ); use Template::Constants qw( :status ); use Template::Stash::Context; use Template::Test; $^W = 1; my $count = 20; my $data = { foo => 10, bar => { baz => 20, }, baz => sub { return { boz => ($count += 10), biz => (shift || ''), }; }, numbers => sub { return wantarray ? (1, 2, 3) : "one two three"; } }; my $stash = Template::Stash::Context->new($data); match( $stash->get('foo'), 10 ); match( $stash->get([ 'bar', 0, 'baz', 0 ]), 20 ); match( $stash->get('bar.baz'), 20 ); match( $stash->get('bar(10).baz'), 20 ); match( $stash->get('baz.boz'), 30 ); match( $stash->get('baz.boz'), 40 ); match( $stash->get('baz.biz'), '' ); match( $stash->get('baz(50).biz'), '' ); # args are ignored $stash->set( 'bar.buz' => 100 ); match( $stash->get('bar.buz'), 100 ); test_expect(\*DATA, { STASH => $stash }); __DATA__ -- test -- [% numbers.join(', ') %] -- expect -- 1, 2, 3 -- test -- [% numbers.scalar %] -- expect -- one two three -- test -- [% numbers.ref %] -- expect -- CODE Template-Toolkit-2.24/t/stop.t000644 000765 000765 00000005045 11704054034 015654 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/stop.t # # Test the [% STOP %] directive. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ../blib/lib ../blib/arch ./blib/lib ./blib/arch ); use vars qw( $DEBUG ); use Template::Test; use Template::Parser; use Template::Exception; #$Template::Parser::DEBUG = 1; $DEBUG = 1; my $ttblocks = { header => sub { "This is the header\n" }, footer => sub { "This is the footer\n" }, halt1 => sub { die Template::Exception->new('stop', 'big error') }, }; my $ttvars = { halt => sub { die Template::Exception->new('stop', 'big error') }, }; my $ttbare = Template->new(BLOCKS => $ttblocks); my $ttwrap = Template->new({ PRE_PROCESS => 'header', POST_PROCESS => 'footer', BLOCKS => $ttblocks, }); test_expect(\*DATA, [ bare => $ttbare, wrapped => $ttwrap ], $ttvars); __END__ -- test -- This is some text [% STOP %] More text -- expect -- This is some text -- test -- This is some text [% halt %] More text -- expect -- This is some text -- test -- This is some text [% INCLUDE halt1 %] More text -- expect -- This is some text -- test -- This is some text [% INCLUDE myblock1 %] More text [% BLOCK myblock1 -%] This is myblock1 [% STOP %] more of myblock1 [% END %] -- expect -- This is some text This is myblock1 -- test -- This is some text [% INCLUDE myblock2 %] More text [% BLOCK myblock2 -%] This is myblock2 [% halt %] more of myblock2 [% END %] -- expect -- This is some text This is myblock2 #------------------------------------------------------------------------ # ensure 'stop' exceptions get ignored by TRY...END blocks #------------------------------------------------------------------------ -- test -- before [% TRY -%] trying [% STOP -%] tried [% CATCH -%] caught [[% error.type %]] - [% error.info %] [% END %] after -- expect -- before trying #------------------------------------------------------------------------ # ensure PRE_PROCESS and POST_PROCESS templates get added with STOP #------------------------------------------------------------------------ -- test -- -- use wrapped -- This is some text [% STOP %] More text -- expect -- This is the header This is some text This is the footer Template-Toolkit-2.24/t/strcat.t000644 000765 000765 00000001362 11674036057 016200 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/strcat.t # # Test the string concatenation operator ' _ '. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; test_expect(\*DATA); __DATA__ -- test -- [% foo = 'the foo string' bar = 'the bar string' baz = foo _ ' and ' _ bar -%] baz: [% baz %] -- expect -- baz: the foo string and the bar string Template-Toolkit-2.24/t/strict.t000644 000765 000765 00000003020 11674036057 016201 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/strict.t # # Test strict mode. # # Written by Andy Wardley # # Copyright (C) 1996-2009 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ../lib ); use Template; use Template::Test; my $template = Template->new( STRICT => 1 ); test_expect( \*DATA, { STRICT => 1 }, { foo => 10, bar => undef, baz => { boz => undef } } ); __DATA__ -- test -- -- name defined variable -- [% foo %] -- expect -- 10 -- test -- -- name variable with undefined value -- [% TRY; bar; CATCH; error; END %] -- expect -- var.undef error - undefined variable: bar -- test -- -- name dotted variable with undefined value -- [% TRY; baz.boz; CATCH; error; END %] -- expect -- var.undef error - undefined variable: baz.boz -- test -- -- name undefined first part of dotted.variable -- [% TRY; wiz.bang; CATCH; error; END %] -- expect -- var.undef error - undefined variable: wiz.bang -- test -- -- name undefined second part of dotted.variable -- [% TRY; baz.booze; CATCH; error; END %] -- expect -- var.undef error - undefined variable: baz.booze -- test -- -- name dotted.variable with args -- [% TRY; baz(10).booze(20, 'blah', "Foo $foo"); CATCH; error; END %] -- expect -- var.undef error - undefined variable: baz(10).booze(20, 'blah', 'Foo 10') Template-Toolkit-2.24/t/string.t000644 000765 000765 00000016601 11674036057 016210 0ustar00abwabw000000 000000 #!/usr/bin/perl -w #============================================================= -*-perl-*- # # t/string.t # # Test the String plugin # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Plugin::String; my $DEBUG = grep /-d/, @ARGV; #$Template::Parser::DEBUG = $DEBUG; #$Template::Directive::PRETTY = $DEBUG; test_expect(\*DATA); __DATA__ -- test -- [% USE String -%] string: [[% String.text %]] -- expect -- string: [] -- test -- [% USE String 'hello world' -%] string: [[% String.text %]] -- expect -- string: [hello world] -- test -- [% USE String text='hello world' -%] string: [[% String.text %]] -- expect -- string: [hello world] -- test -- [% USE String -%] string: [[% String %]] -- expect -- string: [] -- test -- [% USE String 'hello world' -%] string: [[% String %]] -- expect -- string: [hello world] -- test -- [% USE String text='hello world' -%] string: [[% String %]] -- expect -- string: [hello world] -- test -- [% USE String text='hello' -%] string: [[% String.append(' world') %]] string: [[% String %]] -- expect -- string: [hello world] string: [hello world] -- test -- [% USE String text='hello' -%] [% copy = String.copy -%] string: [[% String %]] string: [[% copy %]] -- expect -- string: [hello] string: [hello] -- test -- [% USE String -%] [% hi = String.new('hello') -%] [% lo = String.new('world') -%] [% hw = String.new(text="$hi $lo") -%] hi: [[% hi %]] lo: [[% lo %]] hw: [[% hw %]] -- expect -- hi: [hello] lo: [world] hw: [hello world] -- test -- [% USE hi = String 'hello' -%] [% lo = hi.new('world') -%] hi: [[% hi %]] lo: [[% lo %]] -- expect -- hi: [hello] lo: [world] -- test -- [% USE hi = String 'hello' -%] [% lo = hi.copy -%] hi: [[% hi %]] lo: [[% lo %]] -- expect -- hi: [hello] lo: [hello] -- test -- [% USE hi = String 'hello' -%] [% lo = hi.copy.append(' world') -%] hi: [[% hi %]] lo: [[% lo %]] -- expect -- hi: [hello] lo: [hello world] -- test -- [% USE hi = String 'hello' -%] [% lo = hi.new('hey').append(' world') -%] hi: [[% hi %]] lo: [[% lo %]] -- expect -- hi: [hello] lo: [hey world] -- test -- [% USE hi=String "hello world\n" -%] hi: [[% hi %]] [% lo = hi.chomp -%] hi: [[% hi %]] lo: [[% lo %]] -- expect -- hi: [hello world ] hi: [hello world] lo: [hello world] -- test -- [% USE foo=String "foop" -%] [[% foo.chop %]] [[% foo.chop %]] -- expect -- [foo] [fo] -- test -- [% USE hi=String "hello" -%] left: [[% hi.copy.left(11) %]] right: [[% hi.copy.right(11) %]] center: [[% hi.copy.center(11) %]] centre: [[% hi.copy.centre(12) %]] -- expect -- left: [hello ] right: [ hello] center: [ hello ] centre: [ hello ] -- test -- [% USE str=String('hello world') -%] hi: [[% str.upper %]] hi: [[% str %]] lo: [[% str.lower %]] cap: [[% str.capital %]] -- expect -- hi: [HELLO WORLD] hi: [HELLO WORLD] lo: [hello world] cap: [Hello world] -- test -- [% USE str=String('hello world') -%] len: [[% str.length %]] -- expect -- len: [11] -- test -- [% USE str=String(" \n\n\t\r hello\nworld\n\r \n \r") -%] [[% str.trim %]] -- expect -- [hello world] -- test -- [% USE str=String(" \n\n\t\r hello \n \n\r world\n\r \n \r") -%] [[% str.collapse %]] -- expect -- [hello world] -- test -- [% USE str=String("hello") -%] [[% str.append(' world') %]] [[% str.prepend('well, ') %]] -- expect -- [hello world] [well, hello world] -- test -- [% USE str=String("hello") -%] [[% str.push(' world') %]] [[% str.unshift('well, ') %]] -- expect -- [hello world] [well, hello world] -- test -- [% USE str=String('foo bar') -%] [[% str.copy.pop(' bar') %]] [[% str.copy.shift('foo ') %]] -- expect -- [foo] [bar] -- test -- [% USE str=String('Hello World') -%] [[% str.copy.truncate(5) %]] [[% str.copy.truncate(8, '...') %]] [[% str.copy.truncate(20, '...') %]] -- expect -- [Hello] [Hello...] [Hello World] -- test -- [% USE String('foo') -%] [[% String.append(' ').repeat(4) %]] -- expect -- [foo foo foo foo ] -- test -- [% USE String('foo') -%] [% String.format("[%s]") %] -- expect -- [foo] -- test -- [% USE String('foo bar foo baz') -%] [[% String.replace('foo', 'oof') %]] -- expect -- [oof bar oof baz] -- test -- [% USE String('foo bar foo baz') -%] [[% String.copy.remove('foo\s*') %]] [[% String.copy.remove('ba[rz]\s*') %]] -- expect -- [bar baz] [foo foo ] -- test -- [% USE String('foo bar foo baz') -%] [[% String.split.join(', ') %]] -- expect -- [foo, bar, foo, baz] -- test -- [% USE String('foo bar foo baz') -%] [[% String.split(' bar ').join(', ') %]] -- expect -- [foo, foo baz] -- test -- [% USE String('foo bar foo baz') -%] [[% String.split(' bar ').join(', ') %]] -- expect -- [foo, foo baz] -- test -- [% USE String('foo bar foo baz') -%] [[% String.split('\s+').join(', ') %]] -- expect -- [foo, bar, foo, baz] -- test -- [% USE String('foo bar foo baz') -%] [[% String.split('\s+', 2).join(', ') %]] -- expect -- [foo, bar foo baz] -- test -- [% USE String('foo bar foo baz') -%] [% String.search('foo') ? 'ok' : 'not ok' %] [% String.search('fooz') ? 'not ok' : 'ok' %] [% String.search('^foo') ? 'ok' : 'not ok' %] [% String.search('^bar') ? 'not ok' : 'ok' %] -- expect -- ok ok ok ok -- test -- [% USE String 'foo < bar' filter='html' -%] [% String %] -- expect -- foo < bar -- test -- [% USE String 'foo bar' filter='uri' -%] [% String %] -- expect -- foo%20bar -- test -- [% USE String 'foo bar' filters='uri' -%] [% String %] -- expect -- foo%20bar -- test -- [% USE String ' foo bar ' filters=['trim' 'uri'] -%] [[% String %]] -- expect -- [foo%20bar] -- test -- [% USE String ' foo bar ' filter='trim, uri' -%] [[% String %]] -- expect -- [foo%20bar] -- test -- [% USE String ' foo bar ' filters='trim, uri' -%] [[% String %]] -- expect -- [foo%20bar] -- test -- [% USE String 'foo bar' filters={ replace=['bar', 'baz'], trim='', uri='' } -%] [[% String %]] -- expect -- [foo%20baz] -- test -- [% USE String 'foo bar' filters=[ 'replace', ['bar', 'baz'], 'trim', 'uri' ] -%] [[% String %]] -- expect -- [foo%20baz] -- test -- [% USE String 'foo bar' -%] [% String %] [% String.filter('uri') %] [% String.filter('replace', 'bar', 'baz') %] [% String.output_filter('uri') -%] [% String %] [% String.output_filter({ repeat => [3] }) -%] [% String %] -- expect -- foo bar foo%20bar foo baz foo%20bar foo%20barfoo%20barfoo%20bar -- test -- [% USE String; a = 'HeLLo'; b = 'hEllO'; a == b ? "not ok 0\n" : "ok 0\n"; String.new(a) == String.new(b) ? "not ok 1\n" : "ok 1\n"; String.new(a).lower == String.new(b).lower ? "ok 2\n" : "not ok 2\n"; String.new(a).lower.equals(String.new(b).lower) ? "ok 3\n" : "not ok 3\n"; a.search("(?i)^$b\$") ? "ok 4\n" : "not ok 4\n"; -%] -- expect -- ok 0 ok 1 ok 2 ok 3 ok 4 -- test -- [% USE String('Hello World') -%] a: [% String.substr(6) %]! b: [% String.substr(0, 5) %]! c: [% String.substr(0, 5, 'Goodbye') %]! d: [% String %]! -- expect -- a: World! b: Hello! c: Hello! d: Goodbye World! -- test -- [% USE str = String('foo bar baz wiz waz woz') -%] a: [% str.substr(4, 3) %] b: [% str.substr(12) %] c: [% str.substr(0, 11, 'FOO') %] d: [% str %] -- expect -- a: bar b: wiz waz woz c: foo bar baz d: FOO wiz waz woz Template-Toolkit-2.24/t/switch.t000644 000765 000765 00000007517 11674036057 016211 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/switch.t # # Template script testing SWITCH / CASE blocks # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 0; my $ttcfg = { # INCLUDE_PATH => [ qw( t/test/lib test/lib ) ], POST_CHOMP => 1, }; test_expect(\*DATA, $ttcfg, &callsign()); __DATA__ #------------------------------------------------------------------------ # test simple case #------------------------------------------------------------------------ -- test -- before [% SWITCH a %] this is ignored [% END %] after -- expect -- before after -- test -- before [% SWITCH a %] this is ignored [% CASE x %] not matched [% END %] after -- expect -- before after -- test -- before [% SWITCH a %] this is ignored [% CASE not_defined %] not matched [% END %] after -- expect -- before after -- test -- before [% SWITCH a %] this is ignored [% CASE 'alpha' %] matched [% END %] after -- expect -- before matched after -- test -- before [% SWITCH a %] this is ignored [% CASE a %] matched [% END %] after -- expect -- before matched after -- test -- before [% SWITCH 'alpha' %] this is ignored [% CASE a %] matched [% END %] after -- expect -- before matched after -- test -- before [% SWITCH a %] this is ignored [% CASE b %] matched [% END %] after -- expect -- before after -- test -- before [% SWITCH a %] this is ignored [% CASE a %] matched [% CASE b %] not matched [% END %] after -- expect -- before matched after -- test -- before [% SWITCH a %] this is ignored [% CASE b %] not matched [% CASE a %] matched [% END %] after -- expect -- before matched after #------------------------------------------------------------------------ # test default case #------------------------------------------------------------------------ -- test -- before [% SWITCH a %] this is ignored [% CASE a %] matched [% CASE b %] not matched [% CASE %] default not matched [% END %] after -- expect -- before matched after -- test -- before [% SWITCH a %] this is ignored [% CASE a %] matched [% CASE b %] not matched [% CASE DEFAULT %] default not matched [% END %] after -- expect -- before matched after -- test -- before [% SWITCH a %] this is ignored [% CASE z %] not matched [% CASE x %] not matched [% CASE %] default matched [% END %] after -- expect -- before default matched after -- test -- before [% SWITCH a %] this is ignored [% CASE z %] not matched [% CASE x %] not matched [% CASE DEFAULT %] default matched [% END %] after -- expect -- before default matched after #------------------------------------------------------------------------ # test multiple matches #------------------------------------------------------------------------ -- test -- before [% SWITCH a %] this is ignored [% CASE [ a b c ] %] matched [% CASE d %] not matched [% CASE %] default not matched [% END %] after -- expect -- before matched after -- test -- before [% SWITCH a %] this is ignored [% CASE [ a b c ] %] matched [% CASE a %] not matched, no drop-through [% CASE DEFAULT %] default not matched [% END %] after -- expect -- before matched after #----------------------------------------------------------------------- # regex metacharacter quoting # http://rt.cpan.org/Ticket/Display.html?id=24183 #----------------------------------------------------------------------- -- test -- [% foo = 'a(b)' bar = 'a(b)'; SWITCH foo; CASE bar; 'ok'; CASE; 'not ok'; END %] -- expect -- ok Template-Toolkit-2.24/t/table.t000644 000765 000765 00000005264 11674036057 015774 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/table.t # # Tests the 'Table' plugin. # # Written by Andy Wardley # # Copyright (C) 2000-2006 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$ # #======================================================================== use strict; use warnings; use lib qw( ../lib ); use Template::Test; $Template::Test::DEBUG = 0; my $params = { alphabet => [ 'a'..'z' ], empty => [ ], }; test_expect(\*DATA, { POST_CHOMP => 1 }, $params); #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ -- test -- [% USE table(alphabet, rows=5) %] [% FOREACH letter = table.col(0) %] [% letter %].. [%- END +%] [% FOREACH letter = table.col(1) %] [% letter %].. [%- END %] -- expect -- a..b..c..d..e.. f..g..h..i..j.. -- test -- [% USE table(alphabet, rows=5) %] [% FOREACH letter = table.row(0) %] [% letter %].. [%- END +%] [% FOREACH letter = table.row(1) %] [% letter %].. [%- END %] -- expect -- a..f..k..p..u..z.. b..g..l..q..v.... -- test -- [% USE table(alphabet, rows=3) %] [% FOREACH col = table.cols %] [% col.0 %] [% col.1 %] [% col.2 +%] [% END %] -- expect -- a b c d e f g h i j k l m n o p q r s t u v w x y z -- test -- [% USE alpha = table(alphabet, cols=3, pad=0) %] [% FOREACH group = alpha.col %] [ [% group.first %] - [% group.last %] ([% group.size %] letters) ] [% END %] -- expect -- [ a - i (9 letters) ] [ j - r (9 letters) ] [ s - z (8 letters) ] -- test -- [% USE alpha = table(alphabet, rows=5, pad=0, overlap=1) %] [% FOREACH group = alpha.col %] [ [% group.first %] - [% group.last %] ([% group.size %] letters) ] [% END %] -- expect -- [ a - e (5 letters) ] [ e - i (5 letters) ] [ i - m (5 letters) ] [ m - q (5 letters) ] [ q - u (5 letters) ] [ u - y (5 letters) ] [ y - z (2 letters) ] -- test -- [% USE table(alphabet, rows=5, pad=0) %] [% FOREACH col = table.cols %] [% col.join('-') +%] [% END %] -- expect -- a-b-c-d-e f-g-h-i-j k-l-m-n-o p-q-r-s-t u-v-w-x-y z -- test -- [% USE table(alphabet, rows=8, overlap=1 pad=0) %] [% FOREACH col = table.cols %] [% FOREACH item = col %][% item %] [% END +%] [% END %] -- expect -- a b c d e f g h h i j k l m n o o p q r s t u v v w x y z -- test -- [% USE table([1,3,5], cols=5) %] [% FOREACH t = table.rows %] [% t.join(', ') %] [% END %] -- expect -- 1, 3, 5 -- test -- > [% USE table(empty, rows=3) -%] [% FOREACH col = table.cols -%] col [% FOREACH item = col -%] item: [% item -%] [% END -%] [% END -%] < -- expect -- > < Template-Toolkit-2.24/t/tags.t000644 000765 000765 00000006666 11704060615 015641 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/tags.t # # Template script testing TAGS parse-time directive to switch the # tokens that mark start and end of directive tags. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ./blib/lib ./blib/arch ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; my $params = { 'a' => 'alpha', 'b' => 'bravo', 'c' => 'charlie', 'd' => 'delta', 'e' => 'echo', tags => 'my tags', flags => 'my flags', }; my $tt = [ basic => Template->new(INTERPOLATE => 1), htags => Template->new(TAG_STYLE => 'html'), stags => Template->new(START_TAG => '\[\*', END_TAG => '\*\]'), ]; test_expect(\*DATA, $tt, $params); __DATA__ [%a%] [% a %] [% a %] -- expect -- alpha alpha alpha -- test -- Redefining tags [% TAGS (+ +) %] [% a %] [% b %] (+ c +) -- expect -- Redefining tags [% a %] [% b %] charlie -- test -- [% a %] [% TAGS (+ +) %] [% a %] %% b %% (+ c +) (+ TAGS <* *> +) (+ d +) <* e *> -- expect -- alpha [% a %] %% b %% charlie (+ d +) echo -- test -- [% TAGS default -%] [% a %] %% b %% (+ c +) -- expect -- alpha %% b %% (+ c +) -- test -- # same as 'default' [% TAGS template -%] [% a %] %% b %% (+ c +) -- expect -- alpha %% b %% (+ c +) -- test -- [% TAGS metatext -%] [% a %] %% b %% <* c *> -- expect -- [% a %] bravo <* c *> -- test -- [% TAGS template1 -%] [% a %] %% b %% (+ c +) -- expect -- alpha bravo (+ c +) -- test -- [% TAGS html -%] [% a %] %% b %% -- expect -- [% a %] %% b %% charlie -- test -- [% TAGS asp -%] [% a %] %% b %% <% d %> -- expect -- [% a %] %% b %% delta -- test -- [% TAGS php -%] [% a %] %% b %% <% d %> -- expect -- [% a %] %% b %% <% d %> echo #------------------------------------------------------------------------ # test processor with pre-defined TAG_STYLE #------------------------------------------------------------------------ -- test -- -- use htags -- [% TAGS ignored -%] [% a %] more stuff -- expect -- [% TAGS ignored -%] [% a %] charlie more stuff #------------------------------------------------------------------------ # test processor with pre-defined START_TAG and END_TAG #------------------------------------------------------------------------ -- test -- -- use stags -- [% TAGS ignored -%] [* a *] blah [* b *] blah -- expect -- [% TAGS ignored -%] alpha blah bravo blah #------------------------------------------------------------------------ # XML style tags #------------------------------------------------------------------------ -- test -- -- use basic -- [% TAGS -%] a: -- expect -- a: 10 1 3 5 7 -- test -- [% TAGS star -%] [* a = 10 -*] a is [* a *] -- expect -- a is 10 -- test -- [% tags; flags %] [* a = 10 -*] a is [* a *] -- expect -- my tagsmy flags [* a = 10 -*] a is [* a *] -- test -- flags: [% flags | html %] tags: [% tags | html %] -- expect -- flags: my flags tags: my tags Template-Toolkit-2.24/t/template.t000644 000765 000765 00000002762 11674036057 016520 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/template.t # # Test the Template.pm module. Does nothing of any great importance # at the moment, but all of its options are tested in the various other # test scripts. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template; use Template::Test; my $out; my $dir = -d 't' ? 't/test' : 'test'; my $tt = Template->new({ INCLUDE_PATH => "$dir/src:$dir/lib", OUTPUT => \$out, }); ok( $tt ); ok( $tt->process('header') ); ok( $out ); $out = ''; ok( ! $tt->process('this_file_does_not_exist') ); my $error = $tt->error(); ok( $error->type() eq 'file' ); ok( $error->info() eq 'this_file_does_not_exist: not found' ); my @output; $tt->process('header', undef, \@output); ok(length($output[-1])); sub myout { my $output = shift; ok($output) } ok($tt->process('header', undef, \&myout)); $out = Myout->new(); ok($tt->process('header', undef, $out)); package Myout; use Template::Test; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless($self, $class); return $self; } sub print { my $output = shift; ok($output); } Template-Toolkit-2.24/t/test/000755 000765 000765 00000000000 11714420735 015463 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/text.t000644 000765 000765 00000005613 11674036057 015667 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/text.t # # Test general text blocks, ensuring all characters can be used. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; ok(1); #------------------------------------------------------------------------ package Stringy; use overload '""' => \&asString; sub asString { my $self = shift; return $$self; } sub new { my ($class, $val) = @_; return bless \$val, $class; } #------------------------------------------------------------------------ package main; my $tt = [ basic => Template->new(), interp => Template->new(INTERPOLATE => 1), ]; my $vars = callsign(); my $v2 = { ref => sub { my $a = shift; "$a\[" . ref($a) . ']' }, sfoo => Stringy->new('foo'), sbar => Stringy->new('bar'), }; @$vars{ keys %$v2 } = values %$v2; test_expect(\*DATA, $tt, $vars); __DATA__ -- test -- This is a text block "hello" 'hello' 1/3 1\4 $ @ { } @{ } ${ } # ~ ' ! % *foo $a ${b} $c -- expect -- This is a text block "hello" 'hello' 1/3 1\4 $ @ { } @{ } ${ } # ~ ' ! % *foo $a ${b} $c -- test -- © -- expect --
    © -- test -- [% foo = 'Hello World' -%] start [% # # [% foo %] # # -%] end -- expect -- start end -- test -- pre [% # [% PROCESS foo %] -%] mid [% BLOCK foo; "This is foo"; END %] -- expect -- pre mid -- test -- -- use interp -- This is a text block "hello" 'hello' 1/3 1\4 \$ @ { } @{ } \${ } # ~ ' ! % *foo $a ${b} $c -- expect -- This is a text block "hello" 'hello' 1/3 1\4 $ @ { } @{ } ${ } # ~ ' ! % *foo alpha bravo charlie -- test --
    © -- expect --
    © -- test -- [% foo = 'Hello World' -%] start [% # # [% foo %] # # -%] end -- expect -- start end -- test -- pre [% # # [% PROCESS foo %] # -%] mid [% BLOCK foo; "This is foo"; END %] -- expect -- pre mid -- test -- [% a = "C'est un test"; a %] -- expect -- C'est un test -- test -- [% META title = "C'est un test" -%] [% component.title -%] -- expect -- C'est un test -- test -- [% META title = 'C\'est un autre test' -%] [% component.title -%] -- expect -- C'est un autre test -- test -- [% META title = "C'est un \"test\"" -%] [% component.title -%] -- expect -- C'est un "test" -- test -- [% sfoo %]/[% sbar %] -- expect -- foo/bar -- test -- [% s1 = "$sfoo" s2 = "$sbar "; s3 = sfoo; ref(s1); '/'; ref(s2); '/'; ref(s3); -%] -- expect -- foo[]/bar []/foo[Stringy] Template-Toolkit-2.24/t/throw.t000644 000765 000765 00000003674 11674036057 016053 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/throw.t # # Test the THROW directive. # # 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template; use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; test_expect(\*DATA); __DATA__ -- test -- [% me = 'I' -%] [% TRY -%] [%- THROW chicken "Failed failed failed" 'boo' name='Fred' -%] [% CATCH -%] ERROR: [% error.type %] - [% error.info.0 %]/[% error.info.1 %]/[% error.info.name %] [% END %] -- expect -- ERROR: chicken - Failed failed failed/boo/Fred -- test -- [% TRY -%] [% THROW food 'eggs' -%] [% CATCH -%] ERROR: [% error.type %] / [% error.info %] [% END %] -- expect -- ERROR: food / eggs # test throwing multiple params -- test -- [% pi = 3.14 e = 2.718 -%] [% TRY -%] [% THROW foo pi e msg="fell over" reason="brain exploded" -%] [% CATCH -%] [% error.type %]: pi=[% error.info.0 %] e=[% error.info.1 %] I [% error.info.msg %] because my [% error.info.reason %]! [% END %] -- expect -- foo: pi=3.14 e=2.718 I fell over because my brain exploded! -- test -- [% TRY -%] [% THROW foo 'one' 2 three=3.14 -%] [% CATCH -%] [% error.type %] [% error.info.0 %] [% error.info.1 %] [% error.info.three %] [%- FOREACH e = error.info.args %] * [% e %] [%- END %] [% END %] -- expect -- foo one 2 3.14 * one * 2 -- test -- [% TRY -%] [% THROW food 'eggs' 'flour' msg="Missing Ingredients" -%] [% CATCH food -%] [% error.info.msg %] [% FOREACH item = error.info.args -%] * [% item %] [% END -%] [% END %] -- expect -- Missing Ingredients * eggs * flour Template-Toolkit-2.24/t/tiedhash.t000644 000765 000765 00000012027 11674036057 016471 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/tiedhash.t # # Template script testing variable via a tied hash. # # Written by Andy Wardley # # Copyright (C) 1996-2001 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2001 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use warnings; use lib qw( blib/lib blib/arch lib ../blib/lib ../blib/arch ../lib ); use Template::Test; use Template::Stash; our $DEBUG = grep(/-d/, @ARGV); eval { require Template::Stash::XS; }; if ($@) { warn $@; skip_all('cannot load Template::Stash::XS'); } #print "stash: $Template::Config::STASH\n"; #$Template::Config::STASH = 'Template::Stash::XS'; our $STORE_PREFIX = ''; our $FETCH_PREFIX = ''; #------------------------------------------------------------------------ package My::Tied::Hash; use Tie::Hash; use base 'Tie::StdHash'; sub FETCH { my ($hash, $key) = @_; print STDERR "FETCH($key)\n" if $main::DEBUG; my $val = $hash->{ $key }; return $val ? (ref $val ? $val : "$main::FETCH_PREFIX$val") : undef; } sub STORE { my ($hash, $key, $val) = @_; print STDERR "STORE($key, $val)\n" if $main::DEBUG; $hash->{ $key } = ref $val ? $val : "$main::STORE_PREFIX$val"; } #------------------------------------------------------------------------ package My::Tied::List; use Tie::Array; use base 'Tie::StdArray'; sub FETCH { my ($list, $n) = @_; print STDERR "FETCH from list [$n]\n" if $main::DEBUG; my $val = $list->[ $n ]; return $val ? (ref $val ? $val : "$main::FETCH_PREFIX$val") : undef; } sub STORE { my ($list, $n, $val) = @_; print STDERR "STORE to list [$n => $val]\n" if $main::DEBUG; $list->[$n] = ref $val ? $val : "$main::STORE_PREFIX$val"; } #------------------------------------------------------------------------ package main; # setup a tied hash and a tied list my @list; tie @list, 'My::Tied::List'; push(@list, 10, 20, 30); my %hash = (a => 'alpha'); tie %hash, 'My::Tied::Hash'; $hash{ a } = 'alpha'; $hash{ b } = 'bravo'; $hash{ zero } = 0; $hash{ one } = 1; # now turn on the prefixes so we can track items going in # and out of the tied hash/list $FETCH_PREFIX = 'FETCH:'; $STORE_PREFIX = 'STORE:'; my $data = { hash => \%hash, list => \@list, }; my $stash_perl = Template::Stash->new($data); my $stash_xs = Template::Stash::XS->new($data); my $tt = [ perl => Template->new( STASH => $stash_perl ), xs => Template->new( STASH => $stash_xs ), ]; test_expect(\*DATA, $tt); __DATA__ #------------------------------------------------------------------------ # first try with the Perl stash #------------------------------------------------------------------------ # hash tests -- test -- [% hash.a %] -- expect -- FETCH:alpha -- test -- [% hash.b %] -- expect -- FETCH:bravo -- test -- ready set:[% hash.c = 'cosmos' %] go:[% hash.c %] -- expect -- ready set: go:FETCH:STORE:cosmos -- test -- [% hash.foo.bar = 'one' -%] [% hash.foo.bar %] -- expect -- one # list tests -- test -- [% list.0 %] -- expect -- FETCH:10 -- test -- [% list.first %]-[% list.last %] -- expect -- FETCH:10-FETCH:30 -- test -- [% list.push(40); list.last %] -- expect -- FETCH:40 -- test -- [% list.4 = 50; list.4 %] -- expect -- FETCH:STORE:50 #------------------------------------------------------------------------ # now try using the XS stash #------------------------------------------------------------------------ # hash tests -- test -- -- use xs -- [% hash.a %] -- expect -- FETCH:alpha -- test -- [% hash.b %] -- expect -- FETCH:bravo -- test -- [% hash.c = 'crazy'; hash.c %] -- expect -- FETCH:STORE:crazy -- test -- [% DEFAULT hash.c = 'more crazy'; hash.c %] -- expect -- FETCH:STORE:crazy -- test -- [% hash.wiz = 'woz' -%] [% hash.wiz %] -- expect -- FETCH:STORE:woz -- test -- [% DEFAULT hash.zero = 'nothing'; hash.zero %] -- expect -- FETCH:STORE:nothing -- test -- before: [% hash.one %] after: [% DEFAULT hash.one = 'solitude'; hash.one %] -- expect -- before: FETCH:1 after: FETCH:1 -- test -- [% hash.foo = 10; hash.foo = 20; hash.foo %] -- expect -- FETCH:STORE:20 # this test should create an intermediate hash -- test -- [% DEFAULT hash.person = { }; hash.person.name = 'Arthur Dent'; hash.person.email = 'dent@tt2.org'; -%] name: [% hash.person.name %] email: [% hash.person.email %] -- expect -- name: Arthur Dent email: dent@tt2.org # list tests -- test -- [% list.0 %] -- expect -- FETCH:10 -- test -- [% list.first %]-[% list.last %] -- expect -- FETCH:10-FETCH:STORE:50 -- test -- [% list.push(60); list.last %] -- expect -- FETCH:60 -- test -- [% list.5 = 70; list.5 %] -- expect -- FETCH:STORE:70 -- test -- [% DEFAULT list.5 = 80; list.5 %] -- expect -- FETCH:STORE:70 -- test -- [% list.10 = 100; list.10 %] -- expect -- FETCH:STORE:100 -- test -- [% stuff = [ ]; stuff.0 = 'some stuff'; stuff.0 -%] -- expect -- some stuff Template-Toolkit-2.24/t/try.t000644 000765 000765 00000023520 11674036057 015516 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/try.t # # Template script testing TRY / THROW / CATCH / FINAL blocks. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; my $ttcfg = { INCLUDE_PATH => [ qw( t/test/lib test/lib ) ], POST_CHOMP => 1, }; my $replace = &callsign(); $replace->{ throw_egg } = sub { die (Template::Exception->new('egg', 'scrambled')); }; $replace->{ throw_any } = sub { die "undefined error\n"; }; test_expect(\*DATA, $ttcfg, $replace); __DATA__ #------------------------------------------------------------------------ # throw default type #------------------------------------------------------------------------ -- test -- [% TRY %] [% THROW foxtrot %] [% CATCH %] [[% error.type%]] [% error.info %] [% END %] -- expect -- [undef] foxtrot -- test -- [% TRY %] [% THROW $f %] [% CATCH %] [[% error.type%]] [% error.info %] [% END %] -- expect -- [undef] foxtrot #------------------------------------------------------------------------ # throw simple types #------------------------------------------------------------------------ -- test -- before try [% TRY %] try this [% THROW barf "Feeling sick" %] don't try this [% CATCH barf %] caught barf: [% error.info +%] [% END %] after try -- expect -- before try try this caught barf: Feeling sick after try -- test -- before [% TRY %] some content [% THROW up 'more malaise' %] afterthought [% CATCH barf %] no barf [% CATCH up %] caught up: [% error.info +%] [% CATCH %] no default [% END %] after -- expect -- before some content caught up: more malaise after -- test -- before [% TRY %] some content [% THROW up b %] afterthought [% CATCH barf %] no barf [% CATCH up %] caught up: [% error.info +%] [% CATCH %] no default [% END %] after -- expect -- before some content caught up: bravo after -- test -- before [% TRY %] some content [% THROW $a b %] afterthought [% CATCH barf %] no barf [% CATCH up %] caught up: [% error.info +%] [% CATCH alpha %] caught up: [% error.info +%] [% CATCH %] no default [% END %] after -- expect -- before some content caught up: bravo after #------------------------------------------------------------------------ # throw complex (hierarchical) exception types #------------------------------------------------------------------------ -- test -- before [% TRY %] some content [% THROW alpha.bravo c %] afterthought [% CATCH alpha.charlie %] WRONG: [% error.info +%] [% CATCH alpha.bravo %] RIGHT: [% error.info +%] [% CATCH alpha %] WRONG: [% error.info +%] [% CATCH %] WRONG: [% error.info +%] [% END %] after -- expect -- before some content RIGHT: charlie after -- test -- before [% TRY %] some content [% THROW alpha.bravo c %] afterthought [% CATCH delta.charlie %] WRONG: [% error.info +%] [% CATCH delta.bravo %] WRONG: [% error.info +%] [% CATCH alpha %] RIGHT: [% error.info +%] [% CATCH %] WRONG: [% error.info +%] [% END %] after -- expect -- before some content RIGHT: charlie after -- test -- before [% TRY %] some content [% THROW "alpha.$b" c %] afterthought [% CATCH delta.charlie %] WRONG: [% error.info +%] [% CATCH alpha.bravo %] RIGHT: [% error.info +%] [% CATCH alpha.charlie %] WRONG: [% error.info +%] [% CATCH %] WRONG: [% error.info +%] [% END %] after -- expect -- before some content RIGHT: charlie after -- test -- before [% TRY %] some content [% THROW alpha.bravo c %] afterthought [% CATCH delta.charlie %] WRONG: [% error.info +%] [% CATCH delta.bravo %] WRONG: [% error.info +%] [% CATCH alpha.charlie %] WRONG: [% error.info +%] [% CATCH %] RIGHT: [% error.info +%] [% END %] after -- expect -- before some content RIGHT: charlie after -- test -- before [% TRY %] some content [% THROW alpha.bravo.charlie d %] afterthought [% CATCH alpha.bravo.charlie %] RIGHT: [% error.info +%] [% CATCH alpha.bravo %] WRONG: [% error.info +%] [% CATCH alpha %] WRONG: [% error.info +%] [% CATCH %] WRONG: [% error.info +%] [% END %] after -- expect -- before some content RIGHT: delta after -- test -- before [% TRY %] some content [% THROW alpha.bravo.charlie d %] afterthought [% CATCH alpha.bravo.foxtrot %] WRONG: [% error.info +%] [% CATCH alpha.bravo %] RIGHT: [% error.info +%] [% CATCH alpha %] WRONG: [% error.info +%] [% CATCH %] WRONG: [% error.info +%] [% END %] after -- expect -- before some content RIGHT: delta after -- test -- before [% TRY %] some content [% THROW alpha.bravo.charlie d %] afterthought [% CATCH alpha.bravo.foxtrot %] WRONG: [% error.info +%] [% CATCH alpha.echo %] WRONG: [% error.info +%] [% CATCH alpha %] RIGHT: [% error.info +%] [% CATCH %] WRONG: [% error.info +%] [% END %] after -- expect -- before some content RIGHT: delta after #------------------------------------------------------------------------ # test FINAL block #------------------------------------------------------------------------ -- test -- [% TRY %] foo [% CATCH %] bar [% FINAL %] baz [% END %] -- expect -- foo baz -- test -- [% TRY %] foo [% THROW anything %] [% CATCH %] bar [% FINAL %] baz [% END %] -- expect -- foo bar baz #------------------------------------------------------------------------ # use CLEAR to clear output from TRY block #------------------------------------------------------------------------ -- test -- before [% TRY %] foo [% THROW anything %] [% CATCH %] [% CLEAR %] bar [% FINAL %] baz [% END %] -- expect -- before bar baz -- test -- before [% TRY %] foo [% CATCH %] bar [% FINAL %] [% CLEAR %] baz [% END %] -- expect -- before baz #------------------------------------------------------------------------ # nested TRY blocks #------------------------------------------------------------------------ -- test -- before [% TRY %] outer [% TRY %] inner [% THROW foo g %] more inner [% CATCH %] caught inner [% END %] more outer [% CATCH %] caught outer [% END %] after -- expect -- before outer inner caught inner more outer after -- test -- before [% TRY %] outer [% TRY %] inner [% THROW foo g %] more inner [% CATCH foo %] caught inner foo [% CATCH %] caught inner [% END %] more outer [% CATCH foo %] caught outer [% END %] after -- expect -- before outer inner caught inner foo more outer after -- test -- before [% TRY %] outer [% TRY %] inner [% THROW foo g %] more inner [% CATCH foo %] caught inner foo [% THROW $error %] [% CATCH %] caught inner [% END %] more outer [% CATCH foo %] caught outer foo [% error.info +%] [% CATCH %] caught outer [[% error.type %]] [% error.info +%] [% END %] after -- expect -- before outer inner caught inner foo caught outer foo golf after -- test -- before [% TRY %] outer [% TRY %] inner [% THROW foo g %] more inner [% CATCH foo %] caught inner foo [% THROW bar error.info %] [% CATCH %] caught inner [% END %] more outer [% CATCH foo %] WRONG: caught outer foo [% error.info +%] [% CATCH bar %] RIGHT: caught outer bar [% error.info +%] [% CATCH %] caught outer [[% error.type %]] [% error.info +%] [% END %] after -- expect -- before outer inner caught inner foo RIGHT: caught outer bar golf after -- test -- before [% TRY %] outer [% TRY %] inner [% THROW foo g %] more inner [% CATCH foo %] [% CLEAR %] caught inner foo [% THROW bar error.info %] [% CATCH %] caught inner [% END %] more outer [% CATCH foo %] WRONG: caught outer foo [% error.info +%] [% CATCH bar %] RIGHT: caught outer bar [% error.info +%] [% CATCH %] caught outer [[% error.type %]] [% error.info +%] [% END %] after -- expect -- before outer caught inner foo RIGHT: caught outer bar golf after -- test -- before [% TRY %] outer [% TRY %] inner [% THROW foo g %] more inner [% CATCH foo %] caught inner foo [% THROW bar error.info %] [% CATCH %] caught inner [% END %] more outer [% CATCH foo %] WRONG: caught outer foo [% error.info +%] [% CATCH bar %] [% CLEAR %] RIGHT: caught outer bar [% error.info +%] [% CATCH %] caught outer [[% error.type %]] [% error.info +%] [% END %] after -- expect -- before RIGHT: caught outer bar golf after -- test -- before [% TRY %] outer [% TRY %] inner [% THROW foo g %] more inner [% CATCH bar %] caught inner bar [% END %] more outer [% CATCH foo %] RIGHT: caught outer foo [% error.info +%] [% CATCH bar %] WRONG: caught outer bar [% error.info +%] [% CATCH %] caught outer [[% error.type %]] [% error.info +%] [% END %] after -- expect -- before outer inner RIGHT: caught outer foo golf after #------------------------------------------------------------------------ # test throwing from Perl code via die() #------------------------------------------------------------------------ -- test -- [% TRY %] before [% throw_egg %] after [% CATCH egg %] caught egg: [% error.info +%] [% END %] after -- expect -- before caught egg: scrambled after -- test -- [% TRY %] before [% throw_any %] after [% CATCH egg %] caught egg: [% error.info +%] [% CATCH %] caught any: [[% error.type %]] [% error.info %] [% END %] after -- expect -- before caught any: [undef] undefined error after -- test -- [% TRY %] [% THROW up 'feeling sick' %] [% CATCH %] [% error %] [% END %] -- expect -- up error - feeling sick -- test -- [% TRY %] [% THROW up 'feeling sick' %] [% CATCH %] [% e %] [% END %] -- expect -- up error - feeling sick -- test -- [% TRY; THROW food 'cabbage'; CATCH DEFAULT; "caught $e.info"; END %] -- expect -- caught cabbage -- test -- [% TRY; THROW food 'cabbage'; CATCH food; "caught food: $e.info\n"; CATCH DEFAULT; "caught default: $e.info"; END %] -- expect -- caught food: cabbage -- test -- [% TRY; PROCESS no_such_file; CATCH; "error: $error\n"; END; %] -- expect -- error: file error - no_such_file: not found Template-Toolkit-2.24/t/unicode.t000644 000765 000765 00000011064 11674036057 016326 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/unicode.t # # Test the handling of Unicode text in templates. # # Written by Mark Fowler # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template::Provider; #use Template::Test; #ntests(20); BEGIN { unless ($] > 5.007) { print "1..0 # Skip perl < 5.8 can't do unicode well enough\n"; exit; } } use Template; use File::Temp qw(tempfile tempdir); use File::Spec::Functions; use Cwd; use Test::More tests => 20; # This is 'moose...' (with slashes in the 'o's them, and the '...' as one char). my $moose = "m\x{f8}\x{f8}se\x{2026}"; # right, create some templates in various encodings by hand # (it's the only way to be 100% sure they contain the right text) my %encoded_text = ( 'UTF-8' => "\x{ef}\x{bb}\x{bf}m\x{c3}\x{b8}\x{c3}\x{b8}se\x{e2}\x{80}\x{a6}", 'UTF-16BE' => "\x{fe}\x{ff}\x{0}m\x{0}\x{f8}\x{0}\x{f8}\x{0}s\x{0}e &", 'UTF-16LE' => "\x{ff}\x{fe}m\x{0}\x{f8}\x{0}\x{f8}\x{0}s\x{0}e\x{0}& ", 'UTF-32BE' => "\x{0}\x{0}\x{fe}\x{ff}\x{0}\x{0}\x{0}m\x{0}\x{0}\x{0}\x{f8}\x{0}\x{0}\x{0}\x{f8}\x{0}\x{0}\x{0}s\x{0}\x{0}\x{0}e\x{0}\x{0} &", 'UTF-32LE' => "\x{ff}\x{fe}\x{0}\x{0}m\x{0}\x{0}\x{0}\x{f8}\x{0}\x{0}\x{0}\x{f8}\x{0}\x{0}\x{0}s\x{0}\x{0}\x{0}e\x{0}\x{0}\x{0}& \x{0}\x{0}", ); # write those variables to temp files in a temp directory my %filenames = ( map { $_ => write_to_temp_file( filename => $_, text => $encoded_text{ $_ }, # uncomment to create files in cwd # dir => cwd, ) } keys %encoded_text ); my $tempdir = create_cache_dir(); # setup template toolkit and test all the encodings my $tt = setup_tt( tempdir => $tempdir ); test_it("first try", $tt, \%filenames, $moose); test_it("in memory", $tt, \%filenames, $moose); # okay, now we test everything again to see if the cache file # was written in a consisant state $tt = setup_tt( tempdir => $tempdir ); test_it("from cache", $tt, \%filenames, $moose); test_it("in cache, in memory", $tt, \%filenames, $moose); ######################################################################### sub create_cache_dir { return tempdir( CLEANUP => 1 ); } sub setup_tt { my %args = @_; return Template->new( ABSOLUTE => 1, COMPILE_DIR => $args{tempdir}, COMPILE_EXT => ".ttcache"); } sub test_it { local $Test::Builder::Level = $Test::Builder::Level + 1; my $name = shift; my $tt = shift; my $filenames = shift; my $string = shift; foreach my $encoding (keys %{ $filenames }) { my $output; $tt->process($filenames->{ $encoding },{},\$output) or $output = $tt->error; is(reasciify($output), reasciify($string), "$name - $encoding"); } } #------------------------------------------------------------------------ # reascify($string) # # escape all the high and low chars to \x{..} sequences #------------------------------------------------------------------------ sub reasciify { my $string = shift; $string = join '', map { my $ord = ord($_); ($ord > 127 || ($ord < 32 && $ord != 10)) ? sprintf '\x{%x}', $ord : $_ } split //, $string; return $string; } #------------------------------------------------------------------------ # write_to_temp_file( dir => $dir, filename => $file, text => $text) # # escape all the high and low chars to \x{..} sequences #------------------------------------------------------------------------ sub write_to_temp_file { my %args = @_; # use a temp dir unless one was specified. We automatically # delete the contents when we're done with the tempdir, where # otherwise we just leave the files lying around. unless (exists $args{dir}) { $args{dir} = tempdir( CLEANUP => 1 ); } # work out where we're going to store it my $temp_filename = catfile($args{dir}, $args{filename}); # open a filehandle with some PerlIO magic to convert data into # the correct encoding with the correct BOM on the front open my $temp_fh, ">:raw", $temp_filename or die "Can't write to '$temp_filename': $!"; # write the data out print $temp_fh $args{text}; close $temp_fh; # return where we've created it return $temp_filename; } Template-Toolkit-2.24/t/url.t000644 000765 000765 00000007671 11674036057 015513 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/url.t # # Template script testing URL 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$ # #======================================================================== use strict; use lib qw( ../lib ); use Template qw( :status ); use Template::Test; use Template::Plugin::URL; $^W = 1; $Template::Test::DEBUG = 0; my $urls = { product => { map { $_->{ name }, Template::Plugin::URL->new(undef, # no context $_->{ url }, $_->{ args }); } ( { name => 'view', url => '/product', }, { name => 'add', url => '/product', args => { action => 'add' }, }, { name => 'edit', url => '/product', args => { action => 'edit', style => 'editor' }, }, ), }, }; my $vars = { url => $urls, sorted => \&sort_params, no_escape => sub { $Template::Plugin::URL::JOINT = '&' }, }; test_expect(\*DATA, { INTERPOLATE => 1 }, $vars); # url params are constructed in a non-deterministic order. we obviously # can't test against this so we use this devious hack to reorder a # query so that its parameters are in alphabetical order. # ------------------------------------------------------------------------ # later note: in adding support for parameters with multiple values, the # sort_params() hacked below got broken so as a temporary solution, I # changed teh URL plugin to sort all params by key when generating the # URL sub sort_params { my $query = shift; my ($base, $args) = split(/\?/, $query); my (@args, @keys, %argtab); print STDERR "sort_parms(\"$query\")\n" if $Template::Test::DEBUG; @args = split('&', $args); @keys = map { (split('=', $_))[0] } @args; @argtab{ @keys } = @args; @keys = sort keys %argtab; @args = map { $argtab{ $_ } } @keys; $args = join('&', @args); $query = join('?', length $base ? ($base, $args) : $args); print STDERR "returning [$query]\n" if $Template::Test::DEBUG; return $query; } #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ -- test -- [% USE url -%] loaded [% url %] [% url('foo') %] [% url(foo='bar') %] [% url('bar', wiz='woz') %] -- expect -- loaded foo foo=bar bar?wiz=woz -- test -- [% USE url('here') -%] [% url %] [% url('there') %] [% url(any='where') %] [% url('every', which='way') %] [% sorted( url('every', which='way', you='can') ) %] -- expect -- here there here?any=where every?which=way every?which=way&you=can -- test -- [% USE url('there', name='fred') -%] [% url %] [% url(name='tom') %] [% sorted( url(age=24) ) %] [% sorted( url(age=42, name='frank') ) %] -- expect -- there?name=fred there?name=tom there?age=24&name=fred there?age=42&name=frank -- test -- [% USE url('/cgi-bin/woz.pl') -%] [% url(name="Elrich von Benjy d'Weiro") %] -- expect -- /cgi-bin/woz.pl?name=Elrich%20von%20Benjy%20d%27Weiro -- test -- [% USE url '/script' { one => 1, two => [ 2, 4 ], three => [ 3, 6, 9] } -%] [% url %] -- expect -- /script?one=1&three=3&three=6&three=9&two=2&two=4 -- test -- [% url.product.view %] [% url.product.view(style='compact') %] -- expect -- /product /product?style=compact -- test -- [% url.product.add %] [% url.product.add(style='compact') %] -- expect -- /product?action=add /product?action=add&style=compact -- test -- [% url.product.edit %] [% url.product.edit(style='compact') %] -- expect -- /product?action=edit&style=editor /product?action=edit&style=compact -- test -- [% CALL no_escape -%] [% url.product.edit %] [% url.product.edit(style='compact') %] -- expect -- /product?action=edit&style=editor /product?action=edit&style=compact Template-Toolkit-2.24/t/url2.t000644 000765 000765 00000007337 11674036057 015574 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/url.t # # Template script testing URL 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$ # #======================================================================== use strict; use lib qw( ../lib ); use Template qw( :status ); use Template::Test; use Template::Plugin::URL; $^W = 1; skip_all("We can't agree on the right joint for the URL plugin"); $Template::Test::DEBUG = 0; my $urls = { product => { map { $_->{ name }, Template::Plugin::URL->new(undef, # no context $_->{ url }, $_->{ args }); } ( { name => 'view', url => '/product', }, { name => 'add', url => '/product', args => { action => 'add' }, }, { name => 'edit', url => '/product', args => { action => 'edit', style => 'editor' }, }, ), }, }; my $vars = { url => $urls, sorted => \&sort_params, }; test_expect(\*DATA, { INTERPOLATE => 1 }, $vars); # url params are constructed in a non-deterministic order. we obviously # can't test against this so we use this devious hack to reorder a # query so that its parameters are in alphabetical order. # ------------------------------------------------------------------------ # later note: in adding support for parameters with multiple values, the # sort_params() hacked below got broken so as a temporary solution, I # changed teh URL plugin to sort all params by key when generating the # URL sub sort_params { my $query = shift; my ($base, $args) = split(/\?/, $query); my (@args, @keys, %argtab); print STDERR "sort_parms(\"$query\")\n" if $Template::Test::DEBUG; @args = split('&', $args); @keys = map { (split('=', $_))[0] } @args; @argtab{ @keys } = @args; @keys = sort keys %argtab; @args = map { $argtab{ $_ } } @keys; $args = join('&', @args); $query = join('?', length $base ? ($base, $args) : $args); print STDERR "returning [$query]\n" if $Template::Test::DEBUG; return $query; } #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ -- test -- [% USE url -%] loaded [% url %] [% url('foo') %] [% url(foo='bar') %] [% url('bar', wiz='woz') %] -- expect -- loaded foo foo=bar bar?wiz=woz -- test -- [% USE url('here') -%] [% url %] [% url('there') %] [% url(any='where') %] [% url('every', which='way') %] [% sorted( url('every', which='way', you='can') ) %] -- expect -- here there here?any=where every?which=way every?which=way;you=can -- test -- [% USE url('there', name='fred') -%] [% url %] [% url(name='tom') %] [% sorted( url(age=24) ) %] [% sorted( url(age=42, name='frank') ) %] -- expect -- there?name=fred there?name=tom there?age=24;name=fred there?age=42;name=frank -- test -- [% USE url('/cgi-bin/woz.pl') -%] [% url(name="Elrich von Benjy d'Weiro") %] -- expect -- /cgi-bin/woz.pl?name=Elrich%20von%20Benjy%20d%27Weiro -- test -- [% USE url '/script' { one => 1, two => [ 2, 4 ], three => [ 3, 6, 9] } -%] [% url %] -- expect -- /script?one=1;three=3;three=6;three=9;two=2;two=4 -- test -- [% url.product.view %] [% url.product.view(style='compact') %] -- expect -- /product /product?style=compact -- test -- [% url.product.add %] [% url.product.add(style='compact') %] -- expect -- /product?action=add /product?action=add;style=compact -- test -- [% url.product.edit %] [% url.product.edit(style='compact') %] -- expect -- /product?action=edit;style=editor /product?action=edit;style=compact Template-Toolkit-2.24/t/vars.t000644 000765 000765 00000026153 11674036057 015660 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/vars.t # # Template script testing variable use. # # Written by Andy Wardley # # Copyright (C) 1996-2006 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template::Test; use Template::Stash; use Template::Constants qw( :status ); use Template::Directive; use Template::Parser; $Template::Test::DEBUG = 0; $Template::Parser::DEBUG = 0; # sample data my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z) = qw( alpha bravo charlie delta echo foxtrot golf hotel india juliet kilo lima mike november oscar papa quebec romeo sierra tango umbrella victor whisky x-ray yankee zulu ); my @days = qw( Monday Tuesday Wednesday Thursday Friday Saturday Sunday ); my $day = -1; my $count = 0; my $params = { 'a' => $a, 'b' => $b, 'c' => $c, 'd' => $d, 'e' => $e, 'f' => { 'g' => $g, 'h' => $h, 'i' => { 'j' => $j, 'k' => $k, }, }, 'g' => "solo $g", 'l' => $l, 'r' => $r, 's' => $s, 't' => $t, 'w' => $w, 'n' => sub { $count }, 'up' => sub { ++$count }, 'down' => sub { --$count }, 'reset' => sub { $count = shift(@_) || 0 }, 'undef' => sub { undef }, 'zero' => sub { 0 }, 'one' => sub { 'one' }, 'halt' => sub { die Template::Exception->new('stop', 'stopped') }, 'join' => sub { join(shift, @_) }, 'split' => sub { my $s = shift; $s = quotemeta($s); my @r = split(/$s/, shift); \@r }, 'magic' => { 'chant' => 'Hocus Pocus', 'spell' => sub { join(" and a bit of ", @_) }, }, 'day' => { 'prev' => \&yesterday, 'this' => \&today, 'next' => \&tomorrow, }, 'belief' => \&belief, 'people' => sub { return qw( Tom Dick Larry ) }, 'gee' => 'g', "letter$a" => "'$a'", 'yankee' => \&yankee, '_private' => 123, '_hidden' => 456, expose => sub { undef $Template::Stash::PRIVATE }, add => sub { $_[0] + $_[1] }, # don't define a 'z' - DEFAULT test relies on its non-existance }; my $tt = [ default => Template->new({ INTERPOLATE => 1, ANYCASE => 1 }), notcase => Template->new({ INTERPOLATE => 1, ANYCASE => 0 }) ]; test_expect(\*DATA, $tt, $params); #------------------------------------------------------------------------ # subs #------------------------------------------------------------------------ sub yesterday { return "All my troubles seemed so far away..."; } sub today { my $when = shift || 'Now'; return "$when it looks as though they're here to stay."; } sub tomorrow { my $dayno = shift; unless (defined $dayno) { $day++; $day %= 7; $dayno = $day; } return $days[$dayno]; } sub belief { my @beliefs = @_; my $b = join(' and ', @beliefs); $b = '' unless length $b; return "Oh I believe in $b."; } sub yankee { my $a = []; $a->[1] = { a => 1 }; $a->[3] = { a => 2 }; return $a; } __DATA__ #------------------------------------------------------------------------ # GET #------------------------------------------------------------------------ -- test -- [[% nosuchvariable %]] [$nosuchvariable] -- expect -- [] [] -- test -- [% a %] [% GET b %] [% get c %] -- expect -- alpha bravo charlie -- test -- [% b %] [% GET b %] -- expect -- bravo bravo -- test -- $a $b ${c} ${d} [% e %] -- expect -- alpha bravo charlie delta echo -- test -- [% letteralpha %] [% ${"letter$a"} %] [% GET ${"letter$a"} %] -- expect -- 'alpha' 'alpha' 'alpha' -- test -- [% f.g %] [% f.$gee %] [% f.${gee} %] -- expect -- golf golf golf -- test -- [% GET f.h %] [% get f.h %] [% f.${'h'} %] [% get f.${'h'} %] -- expect -- hotel hotel hotel hotel -- test -- $f.h ${f.g} ${f.h}.gif -- expect -- hotel golf hotel.gif -- test -- [% f.i.j %] [% GET f.i.j %] [% get f.i.k %] -- expect -- juliet juliet kilo -- test -- [% f.i.j %] $f.i.k [% f.${'i'}.${"j"} %] ${f.i.k}.gif -- expect -- juliet kilo juliet kilo.gif -- test -- [% 'this is literal text' %] [% GET 'so is this' %] [% "this is interpolated text containing $r and $f.i.j" %] [% GET "$t?" %] [% "$f.i.k" %] -- expect -- this is literal text so is this this is interpolated text containing romeo and juliet tango? kilo -- test -- [% name = "$a $b $w" -%] Name: $name -- expect -- Name: alpha bravo whisky -- test -- [% join('--', a b, c, f.i.j) %] -- expect -- alpha--bravo--charlie--juliet -- test -- [% text = 'The cat sat on the mat' -%] [% FOREACH word = split(' ', text) -%]<$word> [% END %] -- expect -- -- test -- [% magic.chant %] [% GET magic.chant %] [% magic.chant('foo') %] [% GET magic.chant('foo') %] -- expect -- Hocus Pocus Hocus Pocus Hocus Pocus Hocus Pocus -- test -- <<[% magic.spell %]>> [% magic.spell(a b c) %] -- expect -- <<>> alpha and a bit of bravo and a bit of charlie -- test -- [% one %] [% one('two', 'three') %] [% one(2 3) %] -- expect -- one one one -- test -- [% day.prev %] [% day.this %] [% belief('yesterday') %] -- expect -- All my troubles seemed so far away... Now it looks as though they're here to stay. Oh I believe in yesterday. -- test -- Yesterday, $day.prev $day.this ${belief('yesterday')} -- expect -- Yesterday, All my troubles seemed so far away... Now it looks as though they're here to stay. Oh I believe in yesterday. -- test -- -- use notcase -- [% day.next %] $day.next -- expect -- Monday Tuesday -- test -- [% FOREACH [ 1 2 3 4 5 ] %]$day.next [% END %] -- expect -- Wednesday Thursday Friday Saturday Sunday -- test -- -- use default -- before [% halt %] after -- expect -- before -- test -- [% FOREACH k = yankee -%] [% loop.count %]. [% IF k; k.a; ELSE %]undef[% END %] [% END %] -- expect -- 1. undef 2. 1 3. undef 4. 2 #------------------------------------------------------------------------ # CALL #------------------------------------------------------------------------ -- test -- before [% CALL a %]a[% CALL b %]n[% CALL c %]d[% CALL d %] after -- expect -- before and after -- test -- ..[% CALL undef %].. -- expect -- .... -- test -- ..[% CALL zero %].. -- expect -- .... -- test -- ..[% n %]..[% CALL n %].. -- expect -- ..0.... -- test -- ..[% up %]..[% CALL up %]..[% n %] -- expect -- ..1....2 -- test -- [% CALL reset %][% n %] -- expect -- 0 -- test -- [% CALL reset(100) %][% n %] -- expect -- 100 #------------------------------------------------------------------------ # SET #------------------------------------------------------------------------ -- test -- [% a = a %] $a [% a = b %] $a -- expect -- alpha bravo -- test -- [% SET a = a %] $a [% SET a = b %] $a [% SET a = $c %] [$a] [% SET a = $gee %] $a [% SET a = ${gee} %] $a -- expect -- alpha bravo [] solo golf solo golf -- test -- [% a = b b = c c = d d = e %][% a %] [% b %] [% c %] [% d %] -- expect -- bravo charlie delta echo -- test -- [% SET a = c b = d c = e %]$a $b $c -- expect -- charlie delta echo -- test -- [% 'a' = d 'include' = e 'INCLUDE' = f.g %][% a %]-[% ${'include'} %]-[% ${'INCLUDE'} %] -- expect -- delta-echo-golf -- test -- [% a = f.g %] $a [% a = f.i.j %] $a -- expect -- golf juliet -- test -- [% f.g = r %] $f.g [% f.i.j = s %] $f.i.j [% f.i.k = f.i.j %] ${f.i.k} -- expect -- romeo sierra sierra -- test -- [% user = { id = 'abw' name = 'Andy Wardley' callsign = "[-$a-$b-$w-]" } -%] ${user.id} ${ user.id } $user.id ${user.id}.gif [% message = "$b: ${ user.name } (${user.id}) ${ user.callsign }" -%] MSG: $message -- expect -- abw abw abw abw.gif MSG: bravo: Andy Wardley (abw) [-alpha-bravo-whisky-] -- test -- [% product = { id => 'XYZ-2000', desc => 'Bogon Generator', cost => 678, } -%] The $product.id $product.desc costs \$${product.cost}.00 -- expect -- The XYZ-2000 Bogon Generator costs $678.00 -- test -- [% data => { g => 'my data' } complex = { gee => 'g' } -%] [% data.${complex.gee} %] -- expect -- my data #------------------------------------------------------------------------ # DEFAULT #------------------------------------------------------------------------ -- test -- [% a %] [% DEFAULT a = b -%] [% a %] -- expect -- alpha alpha -- test -- [% a = '' -%] [% DEFAULT a = b -%] [% a %] -- expect -- bravo -- test -- [% a = '' b = '' -%] [% DEFAULT a = c b = d z = r -%] [% a %] [% b %] [% z %] -- expect -- charlie delta romeo #------------------------------------------------------------------------ # 'global' vars #------------------------------------------------------------------------ -- test -- [% global.version = '3.14' -%] Version: [% global.version %] -- expect -- Version: 3.14 -- test -- Version: [% global.version %] -- expect -- Version: 3.14 -- test -- [% global.newversion = global.version + 1 -%] Version: [% global.version %] Version: [% global.newversion %] -- expect -- Version: 3.14 Version: 4.14 -- test -- Version: [% global.version %] Version: [% global.newversion %] -- expect -- Version: 3.14 Version: 4.14 -- test -- [% hash1 = { foo => 'Foo', bar => 'Bar', } hash2 = { wiz => 'Wiz', woz => 'Woz', } -%] [% hash1.import(hash2) -%] keys: [% hash1.keys.sort.join(', ') %] -- expect -- keys: bar, foo, wiz, woz -- test -- [% mage = { name => 'Gandalf', aliases => [ 'Mithrandir', 'Olorin', 'Incanus' ] } -%] [% import(mage) -%] [% name %] [% aliases.join(', ') %] -- expect -- Gandalf Mithrandir, Olorin, Incanus # test private variables -- test -- [[% _private %]][[% _hidden %]] -- expect -- [][] # make them visible -- test -- [% CALL expose -%] [[% _private %]][[% _hidden %]] -- expect -- [123][456] # Stas reported a problem with spacing in expressions but I can't # seem to reproduce it... -- test -- [% a = 4 -%] [% b=6 -%] [% c = a + b -%] [% d=a+b -%] [% c %]/[% d %] -- expect -- 10/10 -- test -- [% a = 1 b = 2 c = 3 -%] [% d = 1+1 %]d: [% d %] [% e = a+b %]e: [% e %] -- expect -- d: 2 e: 3 # these tests check that the incorrect precedence in the parser has now # been fixed, thanks to Craig Barrat. -- test -- [% 1 || 0 && 0 # should be 1 || (0&&0), not (1||0)&&0 %] -- expect -- 1 -- test -- [% 1 + !0 + 1 # should be 1 + (!0) + 0, not 1 + !(0 + 1) %] -- expect -- 3 -- test -- [% "x" _ "y" == "y"; ',' # should be ("x"_"y")=="y", not "x"_("y"=="y") %] -- expect -- , -- test -- [% "x" _ "y" == "xy" # should be ("x"_"y")=="xy", not "x"_("y"=="xy") %] -- expect -- 1 -- test -- [% add(3, 5) %] -- expect -- 8 -- test -- [% add(3 + 4, 5 + 7) %] -- expect -- 19 -- test -- [% a = 10; b = 20; c = 30; add(add(a,b+1),c*3); %] -- expect -- 121 -- test -- [% a = 10; b = 20; c = 30; d = 5; e = 7; add(a+5, b < 10 ? c : d + e*5); -%] -- expect -- 55 Template-Toolkit-2.24/t/varsv1.t000644 000765 000765 00000021725 11674036057 016127 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/varsv1.t # # Template script testing variable use with version 1 compatibility. # In version 1, leading '$' on variables were ignored. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; use Template::Constants qw( :status ); $^W = 1; $Template::Test::DEBUG = 0; # sample data my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $j, $k, $l, $m, $n, $o, $p, $q, $r, $s, $t, $u, $v, $w, $x, $y, $z) = qw( alpha bravo charlie delta echo foxtrot golf hotel india juliet kilo lima mike november oscar papa quebec romeo sierra tango umbrella victor whisky x-ray yankee zulu ); my @days = qw( Monday Tuesday Wednesday Thursday Friday Saturday Sunday ); my $day = -1; my $count = 0; my $params = { 'a' => $a, 'b' => $b, 'c' => $c, 'd' => $d, 'e' => $e, 'f' => { 'g' => $g, 'h' => $h, 'i' => { 'j' => $j, 'k' => $k, }, }, 'l' => $l, 'r' => $r, 's' => $s, 't' => $t, 'w' => $w, 'n' => sub { $count }, 'up' => sub { ++$count }, 'down' => sub { --$count }, 'reset' => sub { $count = shift(@_) || 0 }, 'undef' => sub { undef }, 'zero' => sub { 0 }, 'one' => sub { 'one' }, 'halt' => sub { die Template::Exception->new('stop', 'stopped') }, 'join' => sub { join(shift, @_) }, 'split' => sub { my $s = shift; $s = quotemeta($s); my @r = split(/$s/, shift); \@r }, 'magic' => { 'chant' => 'Hocus Pocus', 'spell' => sub { join(" and a bit of ", @_) }, }, 'day' => { 'prev' => \&yesterday, 'this' => \&today, 'next' => \&tomorrow, }, 'belief' => \&belief, 'people' => sub { return qw( Tom Dick Larry ) }, "letter$a" => "'$a'", # don't define a 'z' - DEFAULT test relies on its non-existance }; my $tt = [ default => Template->new({ INTERPOLATE => 1, ANYCASE => 1, V1DOLLAR => 1, }), notcase => Template->new({ INTERPOLATE => 1, V1DOLLAR => 0, }) ]; test_expect(\*DATA, $tt, $params); #------------------------------------------------------------------------ # subs #------------------------------------------------------------------------ sub yesterday { return "All my troubles seemed so far away..."; } sub today { my $when = shift || 'Now'; return "$when it looks as though they're here to stay."; } sub tomorrow { my $dayno = shift; unless (defined $dayno) { $day++; $day %= 7; $dayno = $day; } return $days[$dayno]; } sub belief { my @beliefs = @_; my $b = join(' and ', @beliefs); $b = '' unless length $b; return "Oh I believe in $b."; } __DATA__ #------------------------------------------------------------------------ # GET #------------------------------------------------------------------------ -- test -- [% a %] [% $a %] [% GET b %] [% GET $b %] [% get c %] [% get $c %] -- expect -- alpha alpha bravo bravo charlie charlie -- test -- [% b %] [% $b %] [% GET b %] [% GET $b %] -- expect -- bravo bravo bravo bravo -- test -- $a $b ${c} ${d} [% $e %] -- expect -- alpha bravo charlie delta echo -- test -- [% letteralpha %] [% ${"letter$a"} %] [% GET ${"letter$a"} %] -- expect -- 'alpha' 'alpha' 'alpha' -- test -- [% f.g %] [% $f.g %] [% $f.$g %] -- expect -- golf golf golf -- test -- [% GET f.h %] [% get $f.h %] [% get f.${'h'} %] [% get $f.${'h'} %] -- expect -- hotel hotel hotel hotel -- test -- $f.h ${f.g} ${f.h}.gif -- expect -- hotel golf hotel.gif -- test -- [% f.i.j %] [% $f.i.j %] [% f.$i.j %] [% f.i.$j %] [% $f.$i.$j %] -- expect -- juliet juliet juliet juliet juliet -- test -- [% f.i.j %] [% $f.i.j %] [% GET f.i.j %] [% GET $f.i.j %] -- expect -- juliet juliet juliet juliet -- test -- [% get $f.i.k %] -- expect -- kilo -- test -- [% f.i.j %] $f.i.k [% f.${'i'}.${"j"} %] ${f.i.k}.gif -- expect -- juliet kilo juliet kilo.gif -- test -- [% 'this is literal text' %] [% GET 'so is this' %] [% "this is interpolated text containing $r and $f.i.j" %] [% GET "$t?" %] [% "$f.i.k" %] -- expect -- this is literal text so is this this is interpolated text containing romeo and juliet tango? kilo -- test -- [% name = "$a $b $w" -%] Name: $name -- expect -- Name: alpha bravo whisky -- test -- [% join('--', a b, c, f.i.j) %] -- expect -- alpha--bravo--charlie--juliet -- test -- [% text = 'The cat sat on the mat' -%] [% FOREACH word = split(' ', text) -%]<$word> [% END %] -- expect -- -- test -- [% magic.chant %] [% GET magic.chant %] [% magic.chant('foo') %] [% GET $magic.chant('foo') %] -- expect -- Hocus Pocus Hocus Pocus Hocus Pocus Hocus Pocus -- test -- <<[% magic.spell %]>> [% magic.spell(a b c) %] -- expect -- <<>> alpha and a bit of bravo and a bit of charlie -- test -- [% one %] [% one('two', 'three') %] [% one(2 3) %] -- expect -- one one one -- test -- [% day.prev %] [% day.this %] [% belief('yesterday') %] -- expect -- All my troubles seemed so far away... Now it looks as though they're here to stay. Oh I believe in yesterday. -- test -- Yesterday, $day.prev $day.this ${belief('yesterday')} -- expect -- Yesterday, All my troubles seemed so far away... Now it looks as though they're here to stay. Oh I believe in yesterday. -- test -- -- use notcase -- [% day.next %] $day.next -- expect -- Monday Tuesday -- test -- [% FOREACH [ 1 2 3 4 5 ] %]$day.next [% END %] -- expect -- Wednesday Thursday Friday Saturday Sunday -- test -- -- use default -- before [% halt %] after -- expect -- before #------------------------------------------------------------------------ # CALL #------------------------------------------------------------------------ -- test -- before [% CALL a %]a[% CALL b %]n[% CALL c %]d[% CALL d %] after -- expect -- before and after -- test -- ..[% CALL undef %].. -- expect -- .... -- test -- ..[% CALL zero %].. -- expect -- .... -- test -- ..[% n %]..[% CALL n %].. -- expect -- ..0.... -- test -- ..[% up %]..[% CALL up %]..[% n %] -- expect -- ..1....2 -- test -- [% CALL reset %][% n %] -- expect -- 0 -- test -- [% CALL reset(100) %][% n %] -- expect -- 100 #------------------------------------------------------------------------ # SET #------------------------------------------------------------------------ -- test -- [% a = a %] $a [% a = b %] $a [% a = $c %] $a [% $a = d %] $a [% $a = $e %] $a -- expect -- alpha bravo charlie delta echo -- test -- [% SET a = a %] $a [% SET a = b %] $a [% SET a = $c %] $a [% SET $a = d %] $a [% SET $a = $e %] $a -- expect -- alpha bravo charlie delta echo -- test -- [% a = b b = c c = d d = e %][% a %] [% b %] [% c %] [% d %] -- expect -- bravo charlie delta echo -- test -- [% SET a = c b = d c = e %]$a $b $c -- expect -- charlie delta echo -- test -- [% a = f.g %] $a [% a = $f.h %] $a [% a = f.i.j %] $a [% a = $f.i.k %] $a -- expect -- golf hotel juliet kilo -- test -- [% f.g = r %] $f.g [% $f.h = $r %] $f.h [% f.i.j = $s %] $f.i.j [% $f.i.k = f.i.j %] ${f.i.k} -- expect -- romeo romeo sierra sierra -- test -- [% user = { id = 'abw' name = 'Andy Wardley' callsign = "[-$a-$b-$w-]" } -%] ${user.id} ${ user.id } $user.id ${user.id}.gif [% message = "$b: ${ user.name } (${user.id}) ${ user.callsign }" -%] MSG: $message -- expect -- abw abw abw abw.gif MSG: bravo: Andy Wardley (abw) [-alpha-bravo-whisky-] -- test -- [% product = { id => 'XYZ-2000', desc => 'Bogon Generator', cost => 678, } -%] The $product.id $product.desc costs \$${product.cost}.00 -- expect -- The XYZ-2000 Bogon Generator costs $678.00 #------------------------------------------------------------------------ # DEFAULT #------------------------------------------------------------------------ -- test -- [% a %] [% DEFAULT a = b -%] [% a %] -- expect -- alpha alpha -- test -- [% a = '' -%] [% DEFAULT a = b -%] [% a %] -- expect -- bravo -- test -- [% a = '' b = '' -%] [% DEFAULT a = c b = d z = r -%] [% a %] [% b %] [% z %] -- expect -- charlie delta romeo #------------------------------------------------------------------------ # 'global' vars #------------------------------------------------------------------------ -- test -- [% global.version = '3.14' -%] Version: [% global.version %] -- expect -- Version: 3.14 -- test -- Version: [% global.version %] -- expect -- Version: 3.14 -- test -- [% global.newversion = global.version + 1 -%] Version: [% global.version %] Version: [% global.newversion %] -- expect -- Version: 3.14 Version: 4.14 -- test -- Version: [% global.version %] Version: [% global.newversion %] -- expect -- Version: 3.14 Version: 4.14 Template-Toolkit-2.24/t/view.t000644 000765 000765 00000042671 11707316115 015653 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/view.t # # 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$ # #======================================================================== use strict; use lib qw( ./lib ../lib ); use Template::Test; $^W = 1; use Template::View; #$Template::View::DEBUG = 1; #$Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; $Template::Test::PRESERVE = 1; #------------------------------------------------------------------------ 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; } #------------------------------------------------------------------------ package main; my $vars = { foo => Foo->new( pi => 3.14, e => 2.718 ), blessed_list => bless([ "Hello", "World" ], 'Blessed::List'), }; my $template = Template->new() || die Template->error; my $context = $template->context(); my $view = $context->view( ); ok( $view ); $view = $context->view( prefix => 'my' ); ok( $view ); match( $view->prefix(), 'my' ); my $config = { VIEWS => [ bottom => { prefix => 'bottom/' }, middle => { prefix => 'middle/', base => 'bottom' }, ], }; test_expect(\*DATA, $config, $vars); __DATA__ -- test -- -- name pre-defined bottom view -- [% BLOCK bottom/list; "BOTTOM LIST: "; item.join(', '); END; list = [10, 20 30]; bottom.print(list) %] -- expect -- BOTTOM LIST: 10, 20, 30 -- test -- -- name pre-defined middle view -- [% BLOCK bottom/list; "BOTTOM LIST: "; item.join(', '); END; BLOCK middle/hash; "MIDDLE HASH: "; item.values.nsort.join(', '); END; list = [10, 20 30]; hash = { pi => 3.142, e => 2.718 }; middle.print(list); "\n"; middle.print(hash); "\n"; %] -- expect -- BOTTOM LIST: 10, 20, 30 MIDDLE HASH: 2.718, 3.142 -- test -- [% USE v = View -%] [[% v.prefix %]] -- expect -- [] -- test -- [% USE v = View( map => { default="any" } ) -%] [[% v.map.default %]] -- expect -- [any] -- test -- [% USE view( prefix=> 'foo/', suffix => '.tt2') -%] [[% view.prefix %]bar[% view.suffix %]] [[% view.template_name('baz') %]] -- expect -- [foo/bar.tt2] [foo/baz.tt2] -- test -- [% USE view( prefix=> 'foo/', suffix => '.tt2') -%] [[% view.prefix %]bar[% view.suffix %]] [[% view.template_name('baz') %]] -- expect -- [foo/bar.tt2] [foo/baz.tt2] -- test -- [% USE view -%] [% view.print('Hello World') %] [% BLOCK text %]TEXT: [% item %][% END -%] -- expect -- TEXT: Hello World -- test -- [% USE view -%] [% view.print( { foo => 'bar' } ) %] [% BLOCK hash %]HASH: { [% FOREACH key = item.keys.sort -%] [% key %] => [% item.$key %] [%- END %] } [% END -%] -- expect -- HASH: { foo => bar } -- test -- [% 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 -%] -- expect -- HASH: { bar => baz } -- test -- [% USE view(prefix='my_') -%] [% view.print( foo => 'wiz', bar => 'waz' ) %] [% BLOCK my_hash %]KEYS: [% item.keys.sort.join(', ') %][% END %] -- expect -- KEYS: bar, foo -- test -- [% USE view -%] [% view.print( view ) %] [% BLOCK Template_View %]Printing a Template::View object[% END -%] -- expect -- Printing a Template::View object -- test -- [% 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 -%] -- expect -- Printing my Template::View object Printing your Template::View object -- test -- [% 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 -%] -- expect -- Printing any of my objects Printing any of your objects -- test -- [% 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 -%] -- expect -- Catching all defaults Catching some defaults -- test -- [% 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 -%] -- expect -- catchnone catchall Catching all defaults Catching some defaults -- test -- [% USE view(prefix='my_', default='catchall' notfound='lost') -%] [% view.print( view ) %] [% BLOCK my_lost %]Something has been found[% END -%] -- expect -- Something has been found -- test -- [% USE view -%] [% TRY ; view.print( view ) ; CATCH view ; "[$error.type] $error.info" ; END %] -- expect -- [view] file error - Template_View: not found -- test -- [% USE view -%] [% view.print( foo ) %] -- expect -- { e => 2.718, pi => 3.14 } -- test -- [% USE view -%] [% view.print( foo, method => 'reverse' ) %] -- expect -- { pi => 3.14, e => 2.718 } -- test -- [% USE view(prefix='my_', include_naked=0, view_naked=1) -%] [% BLOCK my_foo; "Foo: $item"; END -%] [[% view.view_foo(20) %]] [[% view.foo(30) %]] -- expect -- [Foo: 20] [Foo: 30] -- test -- [% 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 %] -- expect -- [Foo: 20] no such view member: foo -- test -- [% 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' ]) %] -- expect -- TEXT: some text HASH: alpha, bravo LIST: charlie, delta -- test -- [% 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' ]) %] -- expect -- TEXT: some text HASH: alpha, bravo LIST: charlie, delta -- test -- [% 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 -%] -- expect -- TEXT: Hello World MY TEXT: Hello World NO TEXT: Hello World -- test -- [% 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 -%] -- expect -- 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 -- test -- [% USE view( prefix => 'my_', item => 'thing' ) -%] [% view.view('thingy', [ 'foo', 'bar'] ) %] [% BLOCK my_thingy %]thingy: [ [% thing.join(', ') %] ][%END %] -- expect -- thingy: [ foo, bar ] -- test -- [% USE view -%] [% view.map.${'Template::View'} = 'myview' -%] [% view.print(view) %] [% BLOCK myview %]MYVIEW[% END%] -- expect -- MYVIEW -- test -- [% USE view -%] [% view.include('greeting', msg => 'Hello World!') %] [% BLOCK greeting %]msg: [% msg %][% END -%] -- expect -- msg: Hello World! -- test -- [% USE view( prefix="my_" )-%] [% view.include('greeting', msg => 'Hello World!') %] [% BLOCK my_greeting %]msg: [% msg %][% END -%] -- expect -- msg: Hello World! -- test -- [% USE view( prefix="my_" )-%] [% view.include_greeting( msg => 'Hello World!') %] [% BLOCK my_greeting %]msg: [% msg %][% END -%] -- expect -- msg: Hello World! -- test -- [% USE view( prefix="my_" )-%] [% INCLUDE $view.template('greeting') msg = 'Hello World!' %] [% BLOCK my_greeting %]msg: [% msg %][% END -%] -- expect -- msg: Hello World! -- test -- [% USE view( title="My View" )-%] [% view.title %] -- expect -- My View -- test -- [% 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 %] -- expect -- My View My View Chartreuse New Title Chartreuse #------------------------------------------------------------------------ -- test -- [% VIEW fred prefix='blat_' %] This is the view [% END -%] [% BLOCK blat_foo; 'This is blat_foo'; END -%] [% fred.view_foo %] -- expect -- This is blat_foo -- test -- [% VIEW fred %] This is the view [% view.prefix = 'blat_' %] [% END -%] [% BLOCK blat_foo; 'This is blat_foo'; END -%] [% fred.view_foo %] -- expect -- This is blat_foo -- test -- [% VIEW fred %] This is the view [% view.prefix = 'blat_' %] [% view.thingy = 'bloop' %] [% fred.name = 'Freddy' %] [% END -%] [% fred.prefix %] [% fred.thingy %] [% fred.name %] -- expect -- blat_ bloop Freddy -- test -- [% 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 %] -- expect -- blat_ Fred view error - cannot update config item in sealed view: prefix view error - cannot update item in sealed view: name -- test -- [% 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) %] -- expect -- age => 23 height => 1.82 other => another title => fred -- test -- [% VIEW foo %] [% BLOCK hello -%] Hello World! [% END %] [% BLOCK goodbye -%] Goodbye World! [% END %] [% END -%] [% TRY; INCLUDE foo; CATCH; error; END %] [% foo.include_hello %] -- expect -- file error - foo: not found Hello World! -- test -- [% 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") %] -- expect -- 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 -- test -- [% 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 %] -- expect -- My View Andy Wardley #ffffff argument #1 argument #2 cloned! New View Andy Wardley #ffffff New Arg1 argument #2 originals: My View argument #1 -- test -- [% 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" ) %] -- expect -- === 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 -- test -- [% VIEW baz notfound='lost' %] [% BLOCK lost; 'lost, not found'; END %] [% END -%] [% baz.any %] -- expect -- lost, not found -- test -- [% VIEW woz prefix='outer_' %] [% BLOCK wiz; 'The inner wiz'; END %] [% END -%] [% BLOCK outer_waz; 'The outer waz'; END -%] [% woz.wiz %] [% woz.waz %] -- expect -- The inner wiz The outer waz -- test -- [% 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' }) %] -- expect -- File: some_file File: some_file Dir: some_dir -- test -- [% BLOCK parent -%] This is the base block [%- END -%] [% VIEW super %] [%- BLOCK parent -%] [%- INCLUDE parent | replace('base', 'super') -%] [%- END -%] [% END -%] base: [% INCLUDE parent %] super: [% super.parent %] -- expect -- base: This is the base block super: This is the super block -- test -- [% 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 %] -- expect -- public foo block public foo block -- test -- [% VIEW foo %] [% BLOCK Blessed_List -%] This is a list: [% item.as_list.join(', ') %] [% END -%] [% END -%] [% foo.print(blessed_list) %] -- expect -- This is a list: Hello, World -- test -- [% VIEW my.foo value=33; END -%] n: [% my.foo.value %] -- expect -- n: 33 -- test -- [% 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 %] -- expect -- 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 -- test -- [% VIEW my.view.default prefix = 'view/default/' value = 3.14; END -%] value: [% my.view.default.value %] -- expect -- value: 3.14 -- test -- [% 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 %] -- expect -- 0: Default foo 1: One foo 2: Default foo 0: 3.14 1: 3.14 2: 2.718 -- test -- [% VIEW foo number = 10 sealed = 0; END -%] a: [% foo.number %] b: [% foo.number = 20 %] c: [% foo.number %] d: [% foo.number(30) %] e: [% foo.number %] -- expect -- a: 10 b: c: 20 d: 30 e: 30 -- test -- [% VIEW foo number = 10 silent = 1; END -%] a: [% foo.number %] b: [% foo.number = 20 %] c: [% foo.number %] d: [% foo.number(30) %] e: [% foo.number %] -- expect -- a: 10 b: c: 10 d: 10 e: 10 -- test -- -- name bad base -- [% TRY; VIEW wiz base=no_such_base_at_all; END; CATCH; error; END -%] -- expect -- view error - Invalid base specified for view Template-Toolkit-2.24/t/vmethods/000755 000765 000765 00000000000 11714420735 016335 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/while.t000644 000765 000765 00000006270 11674036057 016013 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/while.t # # Test the WHILE directive # # Written by Andy Wardley # # Copyright (C) 1996-2009 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Template::Test; use Template::Parser; use Template::Directive; $Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; # set low limit on WHILE's maximum iteration count $Template::Directive::WHILE_MAX = 100; my $config = { INTERPOLATE => 1, POST_CHOMP => 1, }; my @list = ( 'x-ray', 'yankee', 'zulu', ); my @pending; my $replace = { 'a' => 'alpha', 'b' => 'bravo', 'c' => 'charlie', 'd' => 'delta', 'dec' => sub { --$_[0] }, 'inc' => sub { ++$_[0] }, 'reset' => sub { @pending = @list; "Reset list\n" }, 'next' => sub { shift @pending }, 'true' => 1, }; test_expect(\*DATA, $config, $replace); __DATA__ before [% WHILE bollocks %] do nothing [% END %] after -- expect -- before after -- test -- Commence countdown... [% a = 10 %] [% WHILE a %] [% a %]..[% a = dec(a) %] [% END +%] The end -- expect -- Commence countdown... 10..9..8..7..6..5..4..3..2..1.. The end -- test -- [% reset %] [% WHILE (item = next) %] item: [% item +%] [% END %] -- expect -- Reset list item: x-ray item: yankee item: zulu -- test -- [% reset %] [% WHILE (item = next) %] item: [% item +%] [% BREAK IF item == 'yankee' %] [% END %] Finis -- expect -- Reset list item: x-ray item: yankee Finis -- test -- [% reset %] [% "* $item\n" WHILE (item = next) %] -- expect -- Reset list * x-ray * yankee * zulu -- test -- [% TRY %] [% WHILE true %].[% END %] [% CATCH +%] error: [% error.info %] [% END %] -- expect -- ................................................................................................... error: WHILE loop terminated (> 100 iterations) -- test -- [% reset %] [% WHILE (item = next) %] [% NEXT IF item == 'yankee' -%] * [% item +%] [% END %] -- expect -- Reset list * x-ray * zulu -- test -- [% i = 1; WHILE i <= 10; SWITCH i; CASE 5; i = i + 1; NEXT; CASE 8; LAST; END; "$i\n"; i = i + 1; END; -%] -- expect -- 1 2 3 4 6 7 -- test -- [% i = 1; WHILE i <= 10; IF 1; IF i == 5; i = i + 1; NEXT; END; IF i == 8; LAST; END; END; "$i\n"; i = i + 1; END; -%] -- expect -- 1 2 3 4 6 7 -- test -- [% i = 1; WHILE i <= 4; j = 1; WHILE j <= 4; k = 1; SWITCH j; CASE 2; WHILE k == 1; LAST; END; CASE 3; IF j == 3; j = j + 1; NEXT; END; END; "$i,$j,$k\n"; j = j + 1; END; i = i + 1; END; -%] -- expect -- 1,1,1 1,2,1 1,4,1 2,1,1 2,2,1 2,4,1 3,1,1 3,2,1 3,4,1 4,1,1 4,2,1 4,4,1 -- test -- [% k = 1; LAST WHILE k == 1; "$k\n"; -%] -- expect -- 1 Template-Toolkit-2.24/t/wrap.t000644 000765 000765 00000005221 11674036057 015647 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/wrap.t # # Template script testing wrap plugin. # # Written by Andy Wardley # # Copyright (C) 1996-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$ # #======================================================================== use strict; use lib qw( ../lib ); use Template qw( :status ); use Template::Test; $^W = 1; $Template::Test::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; eval "use Text::Wrap"; if ($@) { skip_all('Text::Wrap not installed'); } test_expect(\*DATA); #------------------------------------------------------------------------ # test input #------------------------------------------------------------------------ __DATA__ -- test -- [% USE Wrap -%] [% text = BLOCK -%] This is a long block of text that goes on for a long long time and then carries on some more after that, it's very interesting, NOT! [%- END -%] [% text = BLOCK; text FILTER replace('\s+', ' '); END -%] [% Wrap(text, 25,) %] -- expect -- This is a long block of text that goes on for a long long time and then carries on some more after that, it's very interesting, NOT! -- test -- [% FILTER wrap -%] This is a long block of text that goes on for a long long time and then carries on some more after that, it's very interesting, NOT! [% END %] -- expect -- This is a long block of text that goes on for a long long time and then carries on some more after that, it's very interesting, NOT! -- test -- [% USE wrap -%] [% FILTER wrap(25) -%] This is a long block of text that goes on for a long long time and then carries on some more after that, it's very interesting, NOT! [% END %] -- expect -- This is a long block of text that goes on for a long long time and then carries on some more after that, it's very interesting, NOT! -- test -- [% FILTER wrap(10, '> ', '+ ') -%] The cat sat on the mat and then sat on the flat. [%- END %] -- expect -- > The cat + sat on + the mat + and + then + sat on + the + flat. -- test -- [% USE wrap -%] [% FILTER bullet = wrap(40, '* ', ' ') -%] First, attach the transmutex multiplier to the cross-wired quantum homogeniser. [%- END %] [% FILTER remove('\s+(?=\n)') -%] [% FILTER bullet -%] Then remodulate the shield to match the harmonic frequency, taking care to correct the phase difference. [% END %] [% END %] -- expect -- * First, attach the transmutex multiplier to the cross-wired quantum homogeniser. * Then remodulate the shield to match the harmonic frequency, taking care to correct the phase difference. Template-Toolkit-2.24/t/wrapper.t000644 000765 000765 00000007712 11674036057 016365 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/wrapper.t # # Template script testing the WRAPPER directive. # # Written by Andy Wardley # # Copyright (C) 1996-2000 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ../lib ./lib ); use Template::Constants qw( :status ); use Template; use Template::Test; $^W = 1; #$Template::Test::DEBUG = 0; #$Template::Context::DEBUG = 0; #$Template::Parser::DEBUG = 1; #$Template::Directive::PRETTY = 1; my $dir = -d 't' ? 't/test' : 'test'; my $tproc = Template->new({ INCLUDE_PATH => "$dir/src:$dir/lib", TRIM => 1, # WRAPPER => 'wrapper', }); test_expect(\*DATA, $tproc, &callsign()); __DATA__ -- test -- [% BLOCK mypage %] This is the header [% content %] This is the footer [% END -%] [% WRAPPER mypage -%] This is the content [%- END %] -- expect -- This is the header This is the content This is the footer -- test -- [% WRAPPER mywrap title = 'Another Test' -%] This is some more content [%- END %] -- expect -- Wrapper Header Title: Another Test This is some more content Wrapper Footer -- test -- [% WRAPPER mywrap title = 'Another Test' -%] This is some content [%- END %] -- expect -- Wrapper Header Title: Another Test This is some content Wrapper Footer -- test -- [% WRAPPER page title = 'My Interesting Page' %] [% WRAPPER section title = 'Quantum Mechanics' -%] Quantum mechanics is a very interesting subject wish should prove easy for the layman to fully comprehend. [%- END %] [% WRAPPER section title = 'Desktop Nuclear Fusion for under $50' -%] This describes a simple device which generates significant sustainable electrical power from common tap water by process of nuclear fusion. [%- END %] [% END %] [% BLOCK page -%]

    [% title %]

    [% content %]
    [% END %] [% BLOCK section -%]

    [% title %]

    [% content %]

    [% END %] -- expect --

    My Interesting Page

    Quantum Mechanics

    Quantum mechanics is a very interesting subject wish should prove easy for the layman to fully comprehend.

    Desktop Nuclear Fusion for under $50

    This describes a simple device which generates significant sustainable electrical power from common tap water by process of nuclear fusion.

    -- test -- [%# FOREACH s = [ 'one' 'two' ]; WRAPPER section; PROCESS $s; END; END %] [% PROCESS $s WRAPPER section FOREACH s = [ 'one' 'two' ] %] [% BLOCK one; title = 'Block One' %]This is one[% END %] [% BLOCK two; title = 'Block Two' %]This is two[% END %] [% BLOCK section %]

    [% title %]

    [% content %]

    [% END %] -- expect --

    Block One

    This is one

    Block Two

    This is two

    -- test -- [% BLOCK one; title = 'Block One' %]This is one[% END %] [% BLOCK section %]

    [% title %]

    [% content %]

    [% END %] [% WRAPPER section -%] [% PROCESS one %] [%- END %] title: [% title %] -- expect --

    Block One

    This is one

    title: Block One -- test -- [% title = "foo" %] [% WRAPPER outer title="bar" -%] The title is [% title %] [%- END -%] [% BLOCK outer -%] outer [[% title %]]: [% content %] [%- END %] -- expect -- outer [bar]: The title is foo -- test-- [% BLOCK a; "$content"; END; BLOCK b; "$content"; END; BLOCK c; "$content"; END; WRAPPER a + b + c; 'FOO'; END; %] -- expect -- FOO -- stop -- # This next text demonstrates a limitation in the parser # http://tt2.org/pipermail/templates/2006-January/008197.html -- test-- [% BLOCK a; "$content"; END; BLOCK b; "$content"; END; BLOCK c; "$content"; END; A='a'; B='b'; C='c'; WRAPPER $A + $B + $C; 'BAR'; END; %] -- expect -- BAR Template-Toolkit-2.24/t/zz-pmv.t000644 000765 000765 00000002227 11674036057 016144 0ustar00abwabw000000 000000 #!/usr/bin/perl # Test that our declared minimum Perl version matches our syntax use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Perl::MinimumVersion 1.20', 'Test::MinimumVersion 0.008', ); # Don't run tests for installs use Test::More; # NOTE: Perl::MinimumVersion / PPI can't parse hash definitions with utf8 # values or keys. That means that t/stash-xs-unicode.t always fails. We # have no option but to disable this test until PPI can handle this case # or Test::MinimumVersion gives us a way to specify files to skip. plan( skip_all => "These aren't the tests you're looking for... move along" ); # NOTHING RUN PAST THIS POINT unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { eval "use $MODULE"; if ( $@ ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } #all_minimum_version_ok(5.006); minimum_version_ok('t/stash-xs-unicode.t', 5.006); Template-Toolkit-2.24/t/zz-pod-coverage.t000644 000765 000765 00000003222 11707734625 017714 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/pod_coverage.t # # Use Test::Pod::Coverage (if available) to test the POD documentation. # # Written by Andy Wardley # # Copyright (C) 2008-2012 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Test::More; plan( skip_all => "Author tests not required for installation" ) unless $ENV{ RELEASE_TESTING } or $ENV{ AUTOMATED_TESTING }; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; plan tests => 11; # still got some work to do on getting all modules full documented pod_coverage_ok('Template'); pod_coverage_ok('Template::Base'); pod_coverage_ok('Template::Config'); pod_coverage_ok('Template::Context'); pod_coverage_ok('Template::Document'); #pod_coverage_ok('Template::Exception'); #pod_coverage_ok('Template::Filters'); pod_coverage_ok('Template::Iterator'); #pod_coverage_ok('Template::Parser'); #pod_coverage_ok('Template::Plugin'); pod_coverage_ok('Template::Plugins'); pod_coverage_ok('Template::Provider'); pod_coverage_ok('Template::Service'); pod_coverage_ok('Template::Stash'); #pod_coverage_ok('Template::Test'); #pod_coverage_ok('Template::View'); #pod_coverage_ok('Template::VMethods'); pod_coverage_ok('Template::Namespace::Constants'); #pod_coverage_ok('Template::Stash::Context'); #pod_coverage_ok('Template::Stash::XS'); #all_pod_coverage_ok(); Template-Toolkit-2.24/t/zz-pod-kwalitee.t000644 000765 000765 00000001413 11707726155 017725 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/pod_kwalitee.t # # Use Test::Pod (if available) to test the POD documentation. # # Written by Andy Wardley # # Copyright (C) 2008-2012 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ); use Test::More; plan( skip_all => "Author tests not required for installation" ) unless $ENV{ RELEASE_TESTING } or $ENV{ AUTOMATED_TESTING }; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Template-Toolkit-2.24/t/zz-stash-xs-leak.t000644 000765 000765 00000002643 11704043437 020022 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/stash-xs-leak.t # # Template script to investigate a leak in the XS Stash # # Written by Andy Wardley # # Copyright (C) 1996-2009 Andy Wardley. All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ../blib/lib ../blib/arch ./blib/lib ./blib/arch ); use Template::Constants qw( :status ); use Template; use Test::More; my $author = grep(/--abw/, @ARGV); # belt and braces unless ($author) { plan( skip_all => 'Internal test for abw, add the --abw flag to run' ); } unless ( $author or $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } require Template::Stash::XS; my $stash = Template::Stash::XS->new( { x => 10, y => { } } ); my ($a, $b) = (5, 10_000); print <get( ['x', 0, 'y', 0] ); $stash->get( ['x', 0, 'length', 0] ); $stash->get( ['y', 0, 'length', 0] ); } print "pausing...\n"; sleep 1; } Template-Toolkit-2.24/t/vmethods/hash.t000644 000765 000765 00000005631 11674036057 017457 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/vmethods/hash.t # # Testing hash virtual variable methods. # # Written by Andy Wardley # # Copyright (C) 1996-2006 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$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ../../lib ); use Template::Test; # make sure we're using the Perl stash $Template::Config::STASH = 'Template::Stash'; my $params = { hash => { a => 'b', c => 'd' }, uhash => { tobe => '2b', nottobe => undef }, }; my $tt = Template->new() || die Template->error(); my $tc = $tt->context(); $tc->define_vmethod(hash => dump => sub { my $hash = shift; return '{ ' . join(', ', map { "$_ => '$hash->{$_}'" } sort keys %$hash) . ' }'; }); test_expect(\*DATA, undef, $params); __DATA__ #------------------------------------------------------------------------ # hash virtual methods #------------------------------------------------------------------------ -- test -- -- name hash keys -- [% hash.keys.sort.join(', ') %] -- expect -- a, c -- test -- -- name hash values -- [% hash.values.sort.join(', ') %] -- expect -- b, d -- test -- -- name hash each -- [% hash.each.sort.join(', ') %] -- expect -- a, b, c, d -- test -- -- name hash items -- [% hash.items.sort.join(', ') %] -- expect -- a, b, c, d -- test -- -- name hash size -- [% hash.size %] -- expect -- 2 -- test -- [% hash.defined('a') ? 'good' : 'bad' %] [% hash.a.defined ? 'good' : 'bad' %] [% hash.defined('x') ? 'bad' : 'good' %] [% hash.x.defined ? 'bad' : 'good' %] [% hash.defined ? 'good def' : 'bad def' %] [% no_such_hash.defined ? 'bad no def' : 'good no def' %] -- expect -- good good good good good def good no def -- test -- [% uhash.defined('tobe') ? 'good' : 'bad' %] [% uhash.tobe.defined ? 'good' : 'bad' %] [% uhash.exists('tobe') ? 'good' : 'bad' %] [% uhash.defined('nottobe') ? 'bad' : 'good' %] [% hash.nottobe.defined ? 'bad' : 'good' %] [% uhash.exists('nottobe') ? 'good' : 'bad' %] -- expect -- good good good good good good -- test -- -- name hash.pairs -- [% FOREACH pair IN hash.pairs -%] * [% pair.key %] => [% pair.value %] [% END %] -- expect -- * a => b * c => d -- test -- -- name hash.list (old style) -- [% FOREACH pair IN hash.list -%] * [% pair.key %] => [% pair.value %] [% END %] -- expect -- * a => b * c => d #------------------------------------------------------------------------ # user defined hash virtual methods #------------------------------------------------------------------------ -- test -- -- name dump hash -- [% product = { id = 'abc-123', name = 'ABC Widget #123' price = 7.99 }; product.dump %] -- expect -- { id => 'abc-123', name => 'ABC Widget #123', price => '7.99' } Template-Toolkit-2.24/t/vmethods/list.t000644 000765 000765 00000022702 11704061665 017502 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/vmethods/list.t # # Testing list virtual variable methods. # # Written by Andy Wardley # # Copyright (C) 1996-2006 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$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ../../lib ../../../lib ); use Template::Test; # make sure we're using the Perl stash $Template::Config::STASH = 'Template::Stash'; # add some new list ops $Template::Stash::LIST_OPS->{ sum } = \∑ $Template::Stash::LIST_OPS->{ odd } = \&odd; $Template::Stash::LIST_OPS->{ jumble } = \&jumble; # make sure we're using the Perl stash $Template::Config::STASH = 'Template::Stash'; #------------------------------------------------------------------------ # define a simple object to test sort vmethod calling object method #------------------------------------------------------------------------ package My::Object; sub new { my ($class, $name, $extra) = @_; bless { _NAME => $name, _EXTRA => $extra, }, $class; } sub name { my $self = shift; return $self->{ _NAME }; } sub extra { my $self = shift; return $self->{ _EXTRA }; } #------------------------------------------------------------------------ package main; sub sum { my $list = shift; my $n = 0; foreach (@$list) { $n += $_; } return $n; } sub odd { my $list = shift; return [ grep { $_ % 2 } @$list ]; } sub jumble { my ($list, $chop) = @_; $chop = 1 unless defined $chop; return $list unless @$list > 3; push(@$list, splice(@$list, 0, $chop)); return $list; } my $params = { metavars => [ qw( foo bar baz qux wiz waz woz ) ], people => [ { id => 'tom', name => 'Tom' }, { id => 'dick', name => 'Richard' }, { id => 'larry', name => 'Larry' }, ], primes => [ 13, 11, 17, 19, 2, 3, 5, 7 ], phones => { 3141 => 'Leon', 5131 => 'Andy', 4131 => 'Simon' }, groceries => { 'Flour' => 3, 'Milk' => 1, 'Peanut Butter' => 21 }, names => [ map { My::Object->new($_) } qw( Tom Dick Larry ) ], more_names => [ My::Object->new('Smith', 'William'), My::Object->new('Smith', 'Andrew'), My::Object->new('Jones', 'Peter'), My::Object->new('Jones', 'Mark'), ], numbers => [ map { My::Object->new($_) } qw( 1 02 10 12 021 ) ], duplicates => [ 1, 1, 2, 2, 3, 3, 4, 4, 5, 5], }; my $tt = Template->new(); my $tc = $tt->context(); # define vmethods using define_vmethod() interface. $tc->define_vmethod(list => oddnos => \&odd); $tc->define_vmethod(array => jumblate => \&jumble); test_expect(\*DATA, undef, $params); __DATA__ #------------------------------------------------------------------------ # list virtual methods #------------------------------------------------------------------------ -- test -- [% metavars.first %] -- expect -- foo -- test -- [% metavars.last %] -- expect -- woz -- test -- [% metavars.size %] -- expect -- 7 -- test -- [% empty = [ ]; empty.size %] -- expect -- 0 -- test -- [% metavars.max %] -- expect -- 6 -- test -- [% metavars.join %] -- expect -- foo bar baz qux wiz waz woz -- test -- [% metavars.join(', ') %] -- expect -- foo, bar, baz, qux, wiz, waz, woz -- test -- [% metavars.sort.join(', ') %] -- expect -- bar, baz, foo, qux, waz, wiz, woz -- test -- [% metavars.defined ? 'list def ok' : 'list def not ok' %] [% metavars.defined(2) ? 'list two ok' : 'list two not ok' %] [% metavars.defined(7) ? 'list seven not ok' : 'list seven ok' %] -- expect -- list def ok list two ok list seven ok -- test -- [% list = [1]; list.defined('asdf') ? 'asdf is defined' : 'asdf is not defined' %] -- expect -- asdf is not defined -- test -- [% FOREACH person = people.sort('id') -%] [% person.name +%] [% END %] -- expect -- Richard Larry Tom -- test -- [% FOREACH obj = names.sort('name') -%] [% obj.name +%] [% END %] -- expect -- Dick Larry Tom -- test -- [% FOREACH obj IN more_names.sort('name', 'extra') -%] [% obj.extra %] [% obj.name %] [% END %] -- expect -- Mark Jones Peter Jones Andrew Smith William Smith -- test -- [% FOREACH obj = numbers.sort('name') -%] [% obj.name +%] [% END %] -- expect -- 02 021 1 10 12 -- test -- [% FOREACH obj = numbers.nsort('name') -%] [% obj.name +%] [% END %] -- expect -- 1 02 10 12 021 -- test -- [% FOREACH person = people.sort('name') -%] [% person.name +%] [% END %] -- expect -- Larry Richard Tom -- test -- [% folk = [] -%] [% folk.push("$person.name") FOREACH person = people.sort('id') -%] [% folk.join(",\n") %] -- expect -- Richard, Larry, Tom -- test -- [% primes.sort.join(', ') %] -- expect -- 11, 13, 17, 19, 2, 3, 5, 7 -- test -- [% primes.nsort.join(', ') %] -- expect -- 2, 3, 5, 7, 11, 13, 17, 19 -- test -- [% duplicates.unique.join(', ') %] --expect -- 1, 2, 3, 4, 5 -- test -- [% duplicates.unique.join(', ') %] -- expect -- 1, 2, 3, 4, 5 -- test -- -- name list import one -- [% list_one = [ 1 2 3 ]; list_two = [ 4 5 6 ]; list_one.import(list_two).join(', ') %] -- expect -- 1, 2, 3, 4, 5, 6 -- test -- -- name list import two -- [% list_one = [ 1 2 3 ]; list_two = [ 4 5 6 ]; list_three = [ 7 8 9 0 ]; list_one.import(list_two, list_three).join(', ') %] -- expect -- 1, 2, 3, 4, 5, 6, 7, 8, 9, 0 -- test -- -- name list merge one -- [% list_one = [ 1 2 3 ]; list_two = [ 4 5 6 ]; "'$l' " FOREACH l = list_one.merge(list_two) %] -- expect -- '1' '2' '3' '4' '5' '6' -- test -- -- name list merge two -- [% list_one = [ 1 2 3 ]; list_two = [ 4 5 6 ]; list_three = [ 7 8 9 0 ]; "'$l' " FOREACH l = list_one.merge(list_two, list_three) %] -- expect -- '1' '2' '3' '4' '5' '6' '7' '8' '9' '0' -- test -- [% list_one = [ 1 2 3 4 5 ] -%] a: [% list_one.splice.join(', ') %] b: [% list_one.size ? list_one.join(', ') : 'empty list' %] -- expect -- a: 1, 2, 3, 4, 5 b: empty list -- test -- [% list_one = [ 'a' 'b' 'c' 'd' 'e' ] -%] a: [% list_one.splice(3).join(', ') %] b: [% list_one.join(', ') %] -- expect -- a: d, e b: a, b, c -- test -- [% list_one = [ 'a' 'b' 'c' 'd' 'e' ] -%] c: [% list_one.splice(3, 1).join(', ') %] d: [% list_one.join(', ') %] -- expect -- c: d d: a, b, c, e -- test -- [% list_one = [ 'a' 'b' 'c' 'd' 'e' ] -%] c: [% list_one.splice(3, 1, 'foo').join(', ') %] d: [% list_one.join(', ') %] e: [% list_one.splice(0, 1, 'ping', 'pong').join(', ') %] f: [% list_one.join(', ') %] g: [% list_one.splice(-1, 1, ['wibble', 'wobble']).join(', ') %] h: [% list_one.join(', ') %] -- expect -- c: d d: a, b, c, foo, e e: a f: ping, pong, b, c, foo, e g: e h: ping, pong, b, c, foo, wibble, wobble -- test -- -- name scrabble -- [% play_game = [ 'play', 'scrabble' ]; ping_pong = [ 'ping', 'pong' ] -%] a: [% play_game.splice(1, 1, ping_pong).join %] b: [% play_game.join %] -- expect -- a: scrabble b: play ping pong -- test -- -- name first -- [% primes = [ 2, 3, 5, 7, 11, 13 ] -%] [% primes.first +%] [% primes.first(3).join(', ') %] -- expect -- 2 2, 3, 5 -- test -- -- name first -- [% primes = [ 2, 3, 5, 7, 11, 13 ] -%] [% primes.last +%] [% primes.last(3).join(', ') %] -- expect -- 13 7, 11, 13 -- test -- -- name slice -- [% primes = [ 2, 3, 5, 7, 11, 13 ] -%] [% primes.slice(0, 2).join(', ') +%] [% primes.slice(-2, -1).join(', ') +%] [% primes.slice(3).join(', ') +%] [% primes.slice.join(', ') +%] --expect -- 2, 3, 5 11, 13 7, 11, 13 2, 3, 5, 7, 11, 13 -- test -- -- name list.hash -- [% items = ['zero', 'one', 'two', 'three']; hash = items.hash(0); "$key = $value\n" FOREACH hash.pairs; -%] -- expect -- 0 = zero 1 = one 2 = two 3 = three -- test -- -- name list.hash(10) -- [% items = ['zero', 'one', 'two', 'three']; hash = items.hash(10); "$key = $value\n" FOREACH hash.pairs; -%] -- expect -- 10 = zero 11 = one 12 = two 13 = three -- test -- -- name list.hash -- [% items = ['zero', 'one', 'two', 'three']; hash = items.hash; "$key = $value\n" FOREACH hash.pairs; -%] -- expect -- two = three zero = one #------------------------------------------------------------------------ # USER DEFINED LIST OPS #------------------------------------------------------------------------ -- test -- [% items = [0..6] -%] [% items.jumble.join(', ') %] [% items.jumble(3).join(', ') %] -- expect -- 1, 2, 3, 4, 5, 6, 0 4, 5, 6, 0, 1, 2, 3 -- test -- -- name jumblate method -- [% items = [0..6] -%] [% items.jumblate.join(', ') %] [% items.jumblate(3).join(', ') %] -- expect -- 1, 2, 3, 4, 5, 6, 0 4, 5, 6, 0, 1, 2, 3 -- test -- [% primes.sum %] -- expect -- 77 -- test -- [% primes.odd.nsort.join(', ') %] -- expect -- 3, 5, 7, 11, 13, 17, 19 -- test -- -- name oddnos -- [% primes.oddnos.nsort.join(', ') %] -- expect -- 3, 5, 7, 11, 13, 17, 19 -- test -- [% FOREACH n = phones.sort -%] [% phones.$n %] is [% n %], [% END %] -- expect -- Andy is 5131, Leon is 3141, Simon is 4131, -- test -- -- name groceries -- [% FOREACH n = groceries.nsort.reverse -%] I want [% groceries.$n %] kilos of [% n %], [% END %] -- expect -- I want 21 kilos of Peanut Butter, I want 3 kilos of Flour, I want 1 kilos of Milk, -- test -- [% hash = { } list = [ hash ] list.last.message = 'Hello World'; "message: $list.last.message\n" -%] -- expect -- message: Hello World Template-Toolkit-2.24/t/vmethods/replace.t000644 000765 000765 00000010364 11674036057 020146 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/vmethods/replace.t # # Testing the 'replace' scalar virtual method, and in particular the # use of backreferences. # # Written by Andy Wardley and Sergey Martynoff # # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # $Id$ # #======================================================================== use strict; use lib qw( ./lib ../lib ../../lib ); use Template::Test; use Template::Config; use Template::Stash; $^W = 1; # make sure we're using the Perl stash $Template::Config::STASH = 'Template::Stash'; test_expect(\*DATA); __DATA__ -- test -- -- name: two backrefs -- [% text = 'The cat sat on the mat'; text.replace( '(\w+) sat on the (\w+)', 'dirty $1 shat on the filthy $2' ) %] -- expect -- The dirty cat shat on the filthy mat # test more than 9 captures to make sure $10, $11, etc., work ok -- test -- -- name: ten+ backrefs -- [% text = 'one two three four five six seven eight nine ten eleven twelve thirteen'; text.replace( '(\w+) (\w+) (\w+) (\w+) (\w+) (\w+) (\w+) (\w+) (\w+) (\w+) (\w+) (\w+)', '[$12-$11-$10-$9-$8-$7-$6-$5-$4-$3-$2-$1]' ) %] -- expect -- [twelve-eleven-ten-nine-eight-seven-six-five-four-three-two-one] thirteen -- test -- -- name: repeat backrefs -- [% text = 'one two three four five six seven eight nine ten eleven twelve thirteen'; text.replace( '(\w+) ', '[$1]-' ) %] -- expect -- [one]-[two]-[three]-[four]-[five]-[six]-[seven]-[eight]-[nine]-[ten]-[eleven]-[twelve]-thirteen -- test -- -- name: one backref -- [% var = 'foo'; var.replace('f(o+)$', 'b$1') %] -- expect -- boo -- test -- -- name: three backrefs -- [% var = 'foo|bar/baz'; var.replace('(fo+)\|(bar)(.*)$', '[ $1, $2, $3 ]') %] -- expect -- [ foo, bar, /baz ] #------------------------------------------------------------------------ # tests based on Sergey's test script: http://martynoff.info/tt2/ #------------------------------------------------------------------------ -- test -- [% text = 'foo bar'; text.replace('foo', 'bar') %] -- expect -- bar bar -- test -- [% text = 'foo bar'; text.replace('(f)(o+)', '$2$1') %] -- expect -- oof bar -- test -- [% text = 'foo bar foo'; text.replace('(?i)FOO', 'zoo') %] -- expect -- zoo bar zoo #------------------------------------------------------------------------ # references to $n vars that don't exists are ignored #------------------------------------------------------------------------ -- test -- [% text = 'foo bar'; text.replace('(f)(o+)', '$20$1') %] -- expect -- f bar -- test -- [% text = 'foo bar'; text.replace('(f)(o+)', '$2$10') %] -- expect -- oo bar -- test -- [% text = 'foo fgoo foooo bar'; text.replace('((?:f([^o]*)(o+)\s)+)', '1=$1;2=$2;3=$3;') %] -- expect -- 1=foo fgoo foooo ;2=;3=oooo;bar #------------------------------------------------------------------------ # $n in source string should not be interpolated #------------------------------------------------------------------------ -- test -- [% text = 'foo $1 bar'; text.replace('(foo)(.*)(bar)', '$1$2$3') %] -- expect -- foo $1 bar -- test -- [% text = 'foo $1 bar'; text.replace('(foo)(.*)(bar)', '$3$2$1') %] -- expect -- bar $1 foo -- test -- [% text = 'foo $200bar foobar'; text.replace('(f)(o+)', 'zoo') %] -- expect -- zoo $200bar zoobar #------------------------------------------------------------------------ # escaped \$ in replacement string #------------------------------------------------------------------------ -- test -- -- name: escape dollar -- [% text = 'foo bar'; text.replace('(f)(o+)', '\\$2$1') %] -- expect -- $2f bar -- test -- -- name: escape backslash -- [% text = 'foo bar'; text.replace('(f)(o+)', 'x$1\\\\y$2'); # this is 'x$1\\y$2' %] -- expect -- xf\yoo bar -- test -- -- name: backslash again -- [% text = 'foo bar'; text.replace('(f)(o+)', '$2\\\\$1'); # this is '$2\\$1' %] -- expect -- oo\f bar -- test -- -- name: escape all over -- [% text = 'foo bar'; text.replace('(f)(o+)', '$2\\\\\\$1'); # this is '$2\\\$') %] -- expect -- oo\$1 bar -- test -- [% text = 'foo bar foobar'; text.replace('(o)|([ar])', '$2!') %] -- expect -- f!! ba!r! f!!ba!r! Template-Toolkit-2.24/t/vmethods/text.t000644 000765 000765 00000017745 11714165235 017525 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # t/vmethods/text.t # # Testing scalar (text) virtual variable methods. # # Written by Andy Wardley # # Copyright (C) 1996-2006 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$ # #======================================================================== use strict; use warnings; use lib qw( ./lib ../lib ../../lib ); use Template::Test; # make sure we're using the Perl stash $Template::Config::STASH = 'Template::Stash'; # define a new text method $Template::Stash::SCALAR_OPS->{ commify } = sub { local $_ = shift; my $c = shift || ","; my $n = int(shift || 3); return $_ if $n<1; 1 while s/^([-+]?\d+)(\d{$n})/$1$c$2/; return $_; }; my $tt = Template->new(); my $tc = $tt->context(); # define vmethods using define_vmethod() interface. $tc->define_vmethod( item => commas => $Template::Stash::SCALAR_OPS->{ commify } ); my $params = { undef => undef, zero => 0, one => 1, animal => 'cat', string => 'The cat sat on the mat', spaced => ' The dog sat on the log', word => 'bird', # The bird is the word WORD => 'BIRD', the_bird => "\n The bird\n is the word \n ", quotable => "Tim O'Reilly said \"Oh really?\"", markup => 'a < b > & c "d" \'e\'', }; test_expect(\*DATA, undef, $params); __DATA__ -- test -- -- name text.defined implicit undef -- [% notdef.defined ? 'def' : 'undef' %] -- expect -- undef -- test -- -- name text.defined explicit undef -- [% undef.defined ? 'def' : 'undef' %] -- expect -- undef -- test -- -- name text.defined zero -- [% zero.defined ? 'def' : 'undef' %] -- expect -- def -- test -- -- name text.defined one -- [% one.defined ? 'def' : 'undef' %] -- expect -- def -- test -- -- name string.length -- [% string.length %] -- expect -- 22 -- test -- -- name text.upper -- [% string.upper %] -- expect -- THE CAT SAT ON THE MAT -- test -- -- name text.lower -- [% string.lower %] -- expect -- the cat sat on the mat -- test -- -- name text.ucfirst -- [% word.ucfirst %] [% WORD.ucfirst %] [% WORD.lower.ucfirst %] -- expect -- Bird BIRD Bird -- test -- -- name text.lcfirst -- [% word.lcfirst %] [% WORD.lcfirst %] -- expect -- bird bIRD -- test -- -- name text.trim -- >[% the_bird.trim %]< -- expect -- >The bird is the word< -- test -- -- name text.collapse -- >[% the_bird.collapse %]< -- expect -- >The bird is the word< -- test -- -- name text.sort.join -- [% string.sort.join %] -- expect -- The cat sat on the mat -- test -- -- name text.split.join a -- [% string.split.join('_') %] -- expect -- The_cat_sat_on_the_mat -- test -- -- name text.split.join b -- [% string.split(' ', 3).join('_') %] -- expect -- The_cat_sat on the mat -- test -- -- name text.split.join c -- [% spaced.split.join('_') %] -- expect -- The_dog_sat_on_the_log -- test -- -- name text.split.join d -- [% spaced.split(' ').join('_') %] -- expect -- __The_dog_sat_on_the_log -- test -- -- name text.list -- [% string.list.join %] -- expect -- The cat sat on the mat -- test -- -- name text.hash -- [% string.hash.value %] -- expect -- The cat sat on the mat -- test -- -- name text.size -- [% string.size %] -- expect -- 1 -- test -- -- name text.squote -- [% quotable %] [% quotable.squote %] -- expect -- Tim O'Reilly said "Oh really?" Tim O\'Reilly said "Oh really?" -- test -- -- name text.dquote -- [% quotable %] [% quotable.dquote %] -- expect -- Tim O'Reilly said "Oh really?" Tim O'Reilly said \"Oh really?\" -- test -- -- name text.html -- [% markup.html %] -- expect -- a < b > & c "d" 'e' -- test -- -- name text.xml -- [% markup.xml %] -- expect -- a < b > & c "d" 'e' -- test -- -- name text.repeat -- [% animal.repeat(3) %] -- expect -- catcatcat -- test -- -- name text.search -- [% animal.search('at$') ? "found 'at\$'" : "didn't find 'at\$'" %] -- expect -- found 'at$' -- test -- -- name text.search -- [% animal.search('^at') ? "found '^at'" : "didn't find '^at'" %] -- expect -- didn't find '^at' -- test -- -- name text.match an -- [% text = 'bandanna'; text.match('an') ? 'match' : 'no match' %] -- expect -- match -- test -- -- name text.match on -- [% text = 'bandanna'; text.match('on') ? 'match' : 'no match' %] -- expect -- no match -- test -- -- name text.match global an -- [% text = 'bandanna'; text.match('an', 1).size %] matches -- expect -- 2 matches -- test -- -- name text.match global an -- [% text = 'bandanna' -%] matches are [% text.match('an+', 1).join(', ') %] -- expect -- matches are an, ann -- test -- -- name text.match global on -- [% text = 'bandanna'; text.match('on+', 1) ? 'match' : 'no match' %] -- expect -- no match -- test -- -- name: text substr method -- [% text = 'Hello World' -%] a: [% text.substr(6) %]! b: [% text.substr(0, 5) %]! c: [% text.substr(0, 5, 'Goodbye') %]! d: [% text %]! -- expect -- a: World! b: Hello! c: Goodbye World! d: Hello World! -- test -- -- name: another text substr method -- [% text = 'foo bar baz wiz waz woz' -%] a: [% text.substr(4, 3) %] b: [% text.substr(12) %] c: [% text.substr(0, 11, 'FOO') %] d: [% text %] -- expect -- a: bar b: wiz waz woz c: FOO wiz waz woz d: foo bar baz wiz waz woz -- test -- -- name: text.remove -- [% text = 'hello world!'; text.remove('\s+world') %] -- expect -- hello! -- test -- -- name chunk left -- [% string = 'TheCatSatTheMat' -%] [% string.chunk(3).join(', ') %] -- expect -- The, Cat, Sat, The, Mat -- test -- -- name chunk leftover -- [% string = 'TheCatSatonTheMat' -%] [% string.chunk(3).join(', ') %] -- expect -- The, Cat, Sat, onT, heM, at -- test -- -- name chunk right -- [% string = 'TheCatSatTheMat' -%] [% string.chunk(-3).join(', ') %] -- expect -- The, Cat, Sat, The, Mat -- test -- -- name chunk rightover -- [% string = 'TheCatSatonTheMat' -%] [% string.chunk(-3).join(', ') %] -- expect -- Th, eCa, tSa, ton, The, Mat -- test -- -- name chunk ccard -- [% ccard_no = "1234567824683579"; ccard_no.chunk(4).join %] -- expect -- 1234 5678 2468 3579 -- test -- [% string = 'foo' -%] [% string.repeat(3) %] -- expect -- foofoofoo -- test -- [% string1 = 'foobarfoobarfoo' string2 = 'foobazfoobazfoo' -%] [% string1.search('bar') ? 'ok' : 'not ok' %] [% string2.search('bar') ? 'not ok' : 'ok' %] [% string1.replace('bar', 'baz') %] [% string2.replace('baz', 'qux') %] -- expect -- ok ok foobazfoobazfoo fooquxfooquxfoo -- test -- [% string1 = 'foobarfoobarfoo' string2 = 'foobazfoobazfoo' -%] [% string1.match('bar') ? 'ok' : 'not ok' %] [% string2.match('bar') ? 'not ok' : 'ok' %] -- expect -- ok ok -- test -- [% string = 'foo bar ^%$ baz' -%] [% string.replace('\W+', '_') %] -- expect -- foo_bar_baz -- test -- [% var = 'value99' ; var.replace('value', '') %] -- expect -- 99 -- test -- [% bob = "0" -%] bob: [% bob.replace('0','') %]. -- expect -- bob: . -- test -- [% string = 'The cat sat on the mat'; match = string.match('The (\w+) (\w+) on the (\w+)'); -%] [% match.0 %].[% match.1 %]([% match.2 %]) -- expect -- cat.sat(mat) -- test -- [% string = 'The cat sat on the mat' -%] [% IF (match = string.match('The (\w+) sat on the (\w+)')) -%] matched animal: [% match.0 %] place: [% match.1 %] [% ELSE -%] no match [% END -%] [% IF (match = string.match('The (\w+) shat on the (\w+)')) -%] matched animal: [% match.0 %] place: [% match.1 %] [% ELSE -%] no match [% END -%] -- expect -- matched animal: cat place: mat no match -- test -- [% big_num = "1234567890"; big_num.commify %] -- expect -- 1,234,567,890 -- test -- [% big_num = "1234567890"; big_num.commify(":", 2) %] -- expect -- 12:34:56:78:90 -- test -- [% big_num = "1234567812345678"; big_num.commify(" ", 4) %] -- expect -- 1234 5678 1234 5678 -- test -- [% big_num = "hello world"; big_num.commify %] -- expect -- hello world -- test -- [% big_num = "1234567890"; big_num.commas %] -- expect -- 1,234,567,890 Template-Toolkit-2.24/t/test/dir/000755 000765 000765 00000000000 11714420735 016241 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/lib/000755 000765 000765 00000000000 11714420735 016231 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/plugin/000755 000765 000765 00000000000 11714420735 016761 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/pod/000755 000765 000765 00000000000 11714420735 016245 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/src/000755 000765 000765 00000000000 11714420735 016252 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/tmp/000755 000765 000765 00000000000 11714420735 016263 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/tmp/README000644 000765 000765 00000000100 11674036057 017137 0ustar00abwabw000000 000000 This is a temporary directory used by some of the test scripts. Template-Toolkit-2.24/t/test/src/bar/000755 000765 000765 00000000000 11714420735 017016 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/src/baz000644 000765 000765 00000000174 11674036057 016760 0ustar00abwabw000000 000000 [% "name: $template.name modtime: $template.modtime\n" IF showname -%] This is the baz file, a: [% a %][% a = 'charlie' %] Template-Toolkit-2.24/t/test/src/benchmark000644 000765 000765 00000000733 11674036057 020137 0ustar00abwabw000000 000000 [% PROCESS header title = 'This is a Test' %] Once upon a time there was a small caterpillar called Frank. Frank was very hungry so he went into the garden and ate all the cabbages. Item: [% FOREACH item = ['foo', 'bar', 'baz'] %] * [% item %] [% END %] People: [% FOREACH person = people %] * [% person.id %] : [% person.name %] ([% person.email %]) [% IF person.isadmin -%] ** THIS PERSON IS AN ADMINISTRATOR ** [% END -%] [% END -%] [% PROCESS footer %]Template-Toolkit-2.24/t/test/src/blam000644 000765 000765 00000000025 11674036057 017112 0ustar00abwabw000000 000000 This is the blam fileTemplate-Toolkit-2.24/t/test/src/complex000644 000765 000765 00000000726 11714420717 017651 0ustar00abwabw000000 000000 [% META author = 'abw' version = 1.23 %] [% INCLUDE header title = "Yet Another Template Test" +%] This is a more complex file which includes some BLOCK definitions [% INCLUDE footer +%] [% BLOCK header %] This is the header, title: [% title %] [% END %] [% BLOCK footer %][%# NOTE: the 'template' is the parent doc, not this one %] This is the footer, author: [% template.author %], version: [% template.version+%] [% "- $x " FOREACH x = [3 2 1] %] [% END %] Template-Toolkit-2.24/t/test/src/divisionbyzero000644 000765 000765 00000000064 11674036057 021261 0ustar00abwabw000000 000000 [% a = 420; b = 0; TRY; a / b; CATCH; error; END %] Template-Toolkit-2.24/t/test/src/evalperl000644 000765 000765 00000000074 11674036057 020015 0ustar00abwabw000000 000000 This file includes a [% PERL %]print "perl"[% END %] block. Template-Toolkit-2.24/t/test/src/foo000644 000765 000765 00000000043 11674036057 016762 0ustar00abwabw000000 000000 This is the foo file, a is [% a -%]Template-Toolkit-2.24/t/test/src/foobar000644 000765 000765 00000000027 11714420730 017437 0ustar00abwabw000000 000000 This is the new contentTemplate-Toolkit-2.24/t/test/src/golf000644 000765 000765 00000000070 11674036057 017126 0ustar00abwabw000000 000000 [% DEFAULT g = c.f.g -%] This is the golf file, g is $g Template-Toolkit-2.24/t/test/src/leak1000644 000765 000765 00000000054 11674036057 017176 0ustar00abwabw000000 000000 [% a = holler('Hello') -%] Template-Toolkit-2.24/t/test/src/leak2000644 000765 000765 00000000062 11674036057 017176 0ustar00abwabw000000 000000 [% USE h = holler('Goodbye') -%] Template-Toolkit-2.24/t/test/src/metadata000644 000765 000765 00000000241 11674036057 017757 0ustar00abwabw000000 000000 [% META title = 'The cat sat on the mat' author = 'Andy Wardley' -%] TITLE: [% template.title %] [% template.name %] last modified [% template.modtime %] Template-Toolkit-2.24/t/test/src/mywrap000644 000765 000765 00000000076 11674036057 017524 0ustar00abwabw000000 000000 Wrapper Header Title: [% title %] [% content %] Wrapper FooterTemplate-Toolkit-2.24/t/test/src/README000644 000765 000765 00000000111 11674036057 017130 0ustar00abwabw000000 000000 This directory contains various template files used by the test scripts. Template-Toolkit-2.24/t/test/src/recurse000644 000765 000765 00000000213 11674036057 017646 0ustar00abwabw000000 000000 [% META name = 'my file' -%] recursion count: [% counter %] [% counter = counter + 1 -%] [% RETURN IF counter > 3 -%] [% PROCESS recurse %]Template-Toolkit-2.24/t/test/src/bar/baz000644 000765 000765 00000000105 11674036057 017516 0ustar00abwabw000000 000000 [% DEFAULT word = 'qux' -%] This is file baz The word is '[% word %]'Template-Toolkit-2.24/t/test/src/bar/baz.txt000644 000765 000765 00000000103 11674036057 020332 0ustar00abwabw000000 000000 [% DEFAULT time = 'now' -%] [% INCLUDE bar/baz %] The time is $timeTemplate-Toolkit-2.24/t/test/pod/test1.pod000644 000765 000765 00000000533 11674036057 020017 0ustar00abwabw000000 000000 =head1 NAME My::Module =head1 SYNOPSIS use My::Module; =head1 DESCRIPTION This is the description for My::Module. This is verbatim =head2 First Subsection This is the first subsection. foo->bar(); =head2 Second Subsection This is the second subsection. bar->baz(); =head1 THE END This is the end. Beautiful friend, the end. Template-Toolkit-2.24/t/test/plugin/MyPlugs/000755 000765 000765 00000000000 11714420735 020361 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/plugin/MyPlugs/Bar.pm000644 000765 000765 00000000432 11674036057 021427 0ustar00abwabw000000 000000 package MyPlugs::Bar; use Template::Plugin; use base qw( Template::Plugin ); sub new { my ($class, $context, $value) = @_; bless { VALUE => $value, }, $class; } sub output { my $self = shift; return "This is the Bar plugin, value is $self->{ VALUE }"; } 1; Template-Toolkit-2.24/t/test/plugin/MyPlugs/Baz.pm000644 000765 000765 00000000330 11674036057 021434 0ustar00abwabw000000 000000 package MyPlugs::Baz; sub new { my ($class, $value) = @_; bless { VALUE => $value, }, $class; } sub output { my $self = shift; return "This is the Baz module, value is $self->{ VALUE }"; } 1; Template-Toolkit-2.24/t/test/plugin/MyPlugs/Foo.pm000644 000765 000765 00000000432 11674036057 021446 0ustar00abwabw000000 000000 package MyPlugs::Foo; use Template::Plugin; use base qw( Template::Plugin ); sub new { my ($class, $context, $value) = @_; bless { VALUE => $value, }, $class; } sub output { my $self = shift; return "This is the Foo plugin, value is $self->{ VALUE }"; } 1; Template-Toolkit-2.24/t/test/lib/after000644 000765 000765 00000000020 11674036057 017252 0ustar00abwabw000000 000000 This comes afterTemplate-Toolkit-2.24/t/test/lib/badrawperl000644 000765 000765 00000000176 11674036057 020310 0ustar00abwabw000000 000000 This is some text [% RAWPERL %] This is some illegal perl code which should cause a parse error [% END %] more stuff goes hereTemplate-Toolkit-2.24/t/test/lib/barfed000644 000765 000765 00000000056 11674036057 017405 0ustar00abwabw000000 000000 barfed: [[% error.type %]] [[% error.info %]] Template-Toolkit-2.24/t/test/lib/before000644 000765 000765 00000000022 11674036057 017415 0ustar00abwabw000000 000000 This comes before Template-Toolkit-2.24/t/test/lib/blockdef000644 000765 000765 00000000307 11674036057 017732 0ustar00abwabw000000 000000 start of blockdef [%- BLOCK block1 -%] This is block 1, defined in blockdef, a is [% a %] [% END %] [% BLOCK block2 -%] This is block 2, defined in blockdef, b is [% b %] [% END -%] end of blockdef Template-Toolkit-2.24/t/test/lib/chomp000644 000765 000765 00000000070 11674036057 017264 0ustar00abwabw000000 000000 [%- 1 %] [%- 1 %] [%- 1 %] [%- 1 %] [%- 1 %] [%- END %] Template-Toolkit-2.24/t/test/lib/config000644 000765 000765 00000000152 11674036057 017424 0ustar00abwabw000000 000000 [% DEFAULT title = 'Default Title' -%] [% BLOCK menu -%] This is the menu, defined in 'config' [%- END -%]Template-Toolkit-2.24/t/test/lib/content000644 000765 000765 00000000163 11674036057 017633 0ustar00abwabw000000 000000 This is the main content wrapper for "[% template.title or 'untitled' %]" [% PROCESS $template %] This is the end. Template-Toolkit-2.24/t/test/lib/default000644 000765 000765 00000000031 11674036057 017577 0ustar00abwabw000000 000000 This is the default file Template-Toolkit-2.24/t/test/lib/dos_newlines000644 000765 000765 00000000032 11674036057 020645 0ustar00abwabw000000 000000 [% ding -%] [% dong -%] Template-Toolkit-2.24/t/test/lib/error000644 000765 000765 00000000055 11674036057 017312 0ustar00abwabw000000 000000 error: [[% error.type %]] [[% error.info %]] Template-Toolkit-2.24/t/test/lib/footer000644 000765 000765 00000000007 11674036057 017454 0ustar00abwabw000000 000000 footer Template-Toolkit-2.24/t/test/lib/header000644 000765 000765 00000000070 11674036057 017406 0ustar00abwabw000000 000000 header: title: [% title %] menu: [% INCLUDE menu %] Template-Toolkit-2.24/t/test/lib/header.tt2000644 000765 000765 00000000074 11674036057 020122 0ustar00abwabw000000 000000 header.tt2: title: [% title %] menu: [% INCLUDE menu %] Template-Toolkit-2.24/t/test/lib/incblock000644 000765 000765 00000000401 11674036057 017740 0ustar00abwabw000000 000000 [% BLOCK first_block -%] this is my first block, a is set to '[% a %]' [%- END -%] [% BLOCK second_block; DEFAULT b = 99 m = 98 -%] this is my second block, a is initially set to '[% a %]' and then set to [% a = s %]'[% a %]' b is $b m is $m [%- END -%] Template-Toolkit-2.24/t/test/lib/inner000644 000765 000765 00000000120 11674036057 017265 0ustar00abwabw000000 000000 [% content %] [% title = "inner $title" -%]Template-Toolkit-2.24/t/test/lib/menu000644 000765 000765 00000000050 11674036057 017120 0ustar00abwabw000000 000000 This is the menu defined in its own fileTemplate-Toolkit-2.24/t/test/lib/one/000755 000765 000765 00000000000 11714420735 017012 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/lib/outer000644 000765 000765 00000000063 11674036057 017316 0ustar00abwabw000000 000000 [% content %] Template-Toolkit-2.24/t/test/lib/process000644 000765 000765 00000000062 11674036057 017635 0ustar00abwabw000000 000000 begin process [% PROCESS $template -%] end processTemplate-Toolkit-2.24/t/test/lib/README000644 000765 000765 00000000121 11674036057 017110 0ustar00abwabw000000 000000 This directory contains various template components as used by the test scripts.Template-Toolkit-2.24/t/test/lib/simple2000644 000765 000765 00000000063 11674036057 017533 0ustar00abwabw000000 000000 [% USE Simple -%] test 2: [% 'badger' | simple -%] Template-Toolkit-2.24/t/test/lib/trimme000644 000765 000765 00000000251 11674036057 017454 0ustar00abwabw000000 000000 [% DEFAULT title = 'something' colour = 'red' %] [%# more spae-gobbling directives %] I am a template element file which will get TRIMmed [% foo = 'bar' %] Template-Toolkit-2.24/t/test/lib/two/000755 000765 000765 00000000000 11714420735 017042 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/lib/udata1000644 000765 000765 00000000320 11674036057 017333 0ustar00abwabw000000 000000 # test data for the Datafile plugin id : name : email # this is another comment way : Wendy Yardley : way@cre.canon.co.uk mop : Marty Proton : mop@cre.canon.co.uk nellb : Nell Browser : nellb@cre.canon.co.uk Template-Toolkit-2.24/t/test/lib/udata2000644 000765 000765 00000000273 11674036057 017343 0ustar00abwabw000000 000000 # more test data for the Datafile plugin id | name | email way | Wendy Yardley | way@cre.canon.co.uk mop | Marty Proton | mop@cre.canon.co.uk nellb | Nell Browser | nellb@cre.canon.co.uk Template-Toolkit-2.24/t/test/lib/warning000644 000765 000765 00000000035 11674036057 017624 0ustar00abwabw000000 000000 Hello [% a = a + 1 -%] World Template-Toolkit-2.24/t/test/lib/two/bar000644 000765 000765 00000000017 11674036057 017534 0ustar00abwabw000000 000000 This is two/barTemplate-Toolkit-2.24/t/test/lib/two/foo000644 000765 000765 00000000017 11674036057 017553 0ustar00abwabw000000 000000 This is two/fooTemplate-Toolkit-2.24/t/test/lib/one/foo000644 000765 000765 00000000017 11674036057 017523 0ustar00abwabw000000 000000 This is one/fooTemplate-Toolkit-2.24/t/test/dir/file1000644 000765 000765 00000000016 11674036057 017166 0ustar00abwabw000000 000000 This is file 1Template-Toolkit-2.24/t/test/dir/file2000644 000765 000765 00000000016 11674036057 017167 0ustar00abwabw000000 000000 This is file 2Template-Toolkit-2.24/t/test/dir/sub_one/000755 000765 000765 00000000000 11714420735 017673 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/dir/sub_two/000755 000765 000765 00000000000 11714420735 017723 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/test/dir/xyzfile000644 000765 000765 00000000023 11674036057 017656 0ustar00abwabw000000 000000 This is the xyzfileTemplate-Toolkit-2.24/t/test/dir/sub_two/waz.html000644 000765 000765 00000000030 11674036057 021410 0ustar00abwabw000000 000000 This is sub_two/waz.htmlTemplate-Toolkit-2.24/t/test/dir/sub_two/wiz.html000644 000765 000765 00000000030 11674036057 021420 0ustar00abwabw000000 000000 This is sub_two/wiz.htmlTemplate-Toolkit-2.24/t/test/dir/sub_one/bar000644 000765 000765 00000000023 11674036057 020362 0ustar00abwabw000000 000000 This is sub_one/barTemplate-Toolkit-2.24/t/test/dir/sub_one/foo000644 000765 000765 00000000023 11674036057 020401 0ustar00abwabw000000 000000 This is sub_one/fooTemplate-Toolkit-2.24/t/lib/Template/000755 000765 000765 00000000000 11714420735 017025 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/lib/Template/Plugin/000755 000765 000765 00000000000 11714420735 020263 5ustar00abwabw000000 000000 Template-Toolkit-2.24/t/lib/Template/Plugin/ProcBar.pm000644 000765 000765 00000000257 11674036057 022162 0ustar00abwabw000000 000000 package Template::Plugin::ProcBar; use Template::Plugin::ProcFoo; @ISA = qw(Template::Plugin::ProcFoo); sub bar { "This is procbarbar" } sub baz { "This is procbarbaz" } 1; Template-Toolkit-2.24/t/lib/Template/Plugin/ProcFoo.pm000644 000765 000765 00000000265 11674036057 022200 0ustar00abwabw000000 000000 package Template::Plugin::ProcFoo; use Template::Plugin::Procedural; @ISA = qw(Template::Plugin::Procedural); sub foo { "This is procfoofoo" } sub bar { "This is procfoobar" } 1; Template-Toolkit-2.24/t/lib/Template/Plugin/Simple.pm000644 000765 000765 00000000523 11674036057 022057 0ustar00abwabw000000 000000 package Template::Plugin::Simple; use base 'Template::Plugin::Filter'; sub init { my $self = shift; $self->{ _DYNAMIC } = 1; my $name = $self->{ _CONFIG }->{ name } || 'simple'; $self->install_filter($name); return $self; } sub filter { my ($self, $text, $args, $conf) = @_; return '**' . $text . '**'; } 1; Template-Toolkit-2.24/parser/Grammar.pm.skel000644 000765 000765 00000012525 11674036057 020430 0ustar00abwabw000000 000000 #============================================================= -*-Perl-*- # # Template::Grammar # # DESCRIPTION # Grammar file for the Template Toolkit language containing token # definitions and parser state/rules tables generated by Parse::Yapp. # # AUTHOR # Andy Wardley # # COPYRIGHT # Copyright (C) 1996-2006 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # REVISION # $Id$ # # IMPORTANT NOTE # This module is constructed from the parser/Grammar.pm.skel file by # running the parser/yc script. You only need to do this if # you # have modified the grammar in the parser/Parser.yp file and need # # to-recompile it. See the README in the 'parser' directory for # more information (sub-directory of the Template distribution). # #======================================================================== package Template::Grammar; use strict; use warnings; our $VERSION = 2.25; my (@RESERVED, %CMPOP, $LEXTABLE, $RULES, $STATES); my ($factory, $rawstart); #======================================================================== # Reserved words, comparison and binary operators #======================================================================== @RESERVED = qw( GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER BLOCK END USE PLUGIN FILTER MACRO PERL RAWPERL TO STEP AND OR NOT DIV MOD IF UNLESS ELSE ELSIF FOR NEXT WHILE SWITCH CASE META IN TRY THROW CATCH FINAL LAST RETURN STOP CLEAR VIEW DEBUG ); # for historical reasons, != and == are converted to ne and eq to perform # stringwise comparison (mainly because it doesn't generate "non-numerical # comparison" warnings which != and == can) but the others (e.g. < > <= >=) # are not converted to their stringwise equivalents. I added 'gt' et al, # briefly for v2.04d and then took them out again in 2.04e. %CMPOP = qw( != ne == eq < < > > >= >= <= <= ); # eq eq # add these lines to the above to # lt lt # enable the eq, lt and gt operators # gt gt #======================================================================== # Lexer Token Table #======================================================================== # lookup table used by lexer is initialised with special-cases $LEXTABLE = { 'FOREACH' => 'FOR', 'BREAK' => 'LAST', '&&' => 'AND', '||' => 'OR', '!' => 'NOT', '|' => 'FILTER', '.' => 'DOT', '_' => 'CAT', '..' => 'TO', # ':' => 'MACRO', '=' => 'ASSIGN', '=>' => 'ASSIGN', # '->' => 'ARROW', ',' => 'COMMA', '\\' => 'REF', 'and' => 'AND', # explicitly specified so that qw( and or 'or' => 'OR', # not ) can always be used in lower case, 'not' => 'NOT', # regardless of ANYCASE flag 'mod' => 'MOD', 'div' => 'DIV', }; # localise the temporary variables needed to complete lexer table { # my @tokens = qw< ( ) [ ] { } ${ $ / ; : ? >; my @tokens = qw< ( ) [ ] { } ${ $ + / ; : ? >; my @cmpop = keys %CMPOP; # my @binop = qw( + - * % ); # '/' above, in @tokens my @binop = qw( - * % ); # '+' and '/' above, in @tokens # fill lexer table, slice by slice, with reserved words and operators @$LEXTABLE{ @RESERVED, @cmpop, @binop, @tokens } = ( @RESERVED, ('CMPOP') x @cmpop, ('BINOP') x @binop, @tokens ); } #======================================================================== # CLASS METHODS #======================================================================== sub new { my $class = shift; bless { LEXTABLE => $LEXTABLE, STATES => $STATES, RULES => $RULES, }, $class; } # update method to set package-scoped $factory lexical sub install_factory { my ($self, $new_factory) = @_; $factory = $new_factory; } #======================================================================== # States #======================================================================== $STATES = <<$states>>; #======================================================================== # Rules #======================================================================== $RULES = <<$rules>>; 1; __END__ =head1 NAME Template::Grammar - Parser state/rule tables for the TT grammar =head1 SYNOPSIS # no user serviceable parts inside =head1 DESCRIPTION This module defines the state and rule tables that the L module uses to parse templates. It is generated from a YACC-like grammar using the C module. The F sub-directory of the Template Toolkit source distribution contains the grammar and other files required to generate this module. But you don't need to worry about any of that unless you're planning to modify the Template Toolkit language. =head1 AUTHOR Andy Wardley Eabw@wardley.orgE L =head1 COPYRIGHT Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: Template-Toolkit-2.24/parser/Parser.yp000644 000765 000765 00000041775 11674036057 017366 0ustar00abwabw000000 000000 #============================================================= -*-Perl-*- # # Parser.yp # # DESCRIPTION # Definition of the parser grammar for the Template Toolkit language. # # AUTHOR # Andy Wardley # # HISTORY # Totally re-written for version 2, based on Doug Steinwand's # implementation which compiles templates to Perl code. The generated # code is _considerably_ faster, more portable and easier to process. # # WARNINGS # Expect 1 reduce/reduce conflict. This can safely be ignored. # Now also expect 1 shift/reduce conflict, created by adding a rule # to 'args' to allow assignments of the form 'foo.bar = baz'. It # should be possible to fix the problem by rewriting some rules, but # I'm loathed to hack it up too much right now. Maybe later. # # COPYRIGHT # Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved. # Copyright (C) 1998-2004 Canon Research Centre Europe Ltd. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #------------------------------------------------------------------------ # # NOTE: this module is constructed from the parser/Grammar.pm.skel # file by running the parser/yc script. You only need to do this if # you have modified the grammar in the parser/Parser.yp file and need # to-recompile it. See the README in the 'parser' directory for more # information (sub-directory of the Template distribution). # #------------------------------------------------------------------------ # # $Id$ # #======================================================================== %right ASSIGN %right '?' ':' %left COMMA %left AND OR %left NOT %left CAT %left DOT %left CMPOP %left BINOP %left '+' %left '/' %left DIV %left MOD %left TO %% #-------------------------------------------------------------------------- # START AND TOP-LEVEL RULES #-------------------------------------------------------------------------- template: block { $factory->template($_[1]) } ; block: chunks { $factory->block($_[1]) } | /* NULL */ { $factory->block() } ; chunks: chunks chunk { push(@{$_[1]}, $_[2]) if defined $_[2]; $_[1] } | chunk { defined $_[1] ? [ $_[1] ] : [ ] } ; chunk: TEXT { $factory->textblock($_[1]) } | statement ';' { return '' unless $_[1]; $_[0]->location() . $_[1]; } ; statement: directive | defblock | anonblock | capture | macro | use | view | rawperl | expr { $factory->get($_[1]) } | META metadata { $_[0]->add_metadata($_[2]); } | /* empty statement */ ; directive: setlist { $factory->set($_[1]) } | atomdir | condition | switch | loop | try | perl ; #-------------------------------------------------------------------------- # DIRECTIVE RULES #-------------------------------------------------------------------------- atomexpr: expr { $factory->get($_[1]) } | atomdir ; atomdir: GET expr { $factory->get($_[2]) } | CALL expr { $factory->call($_[2]) } | SET setlist { $factory->set($_[2]) } | DEFAULT setlist { $factory->default($_[2]) } | INSERT nameargs { $factory->insert($_[2]) } | INCLUDE nameargs { $factory->include($_[2]) } | PROCESS nameargs { $factory->process($_[2]) } | THROW nameargs { $factory->throw($_[2]) } | RETURN { $factory->return() } | STOP { $factory->stop() } | CLEAR { "\$output = '';"; } | LAST { $_[0]->block_label('last ', ';') } | NEXT { $_[0]->in_block('FOR') ? $factory->next($_[0]->block_label) : $_[0]->block_label('next ', ';') } | DEBUG nameargs { if ($_[2]->[0]->[0] =~ /^'(on|off)'$/) { $_[0]->{ DEBUG_DIRS } = ($1 eq 'on'); $factory->debug($_[2]); } else { $_[0]->{ DEBUG_DIRS } ? $factory->debug($_[2]) : ''; } } | wrapper | filter ; condition: IF expr ';' block else END { $factory->if(@_[2, 4, 5]) } | atomexpr IF expr { $factory->if(@_[3, 1]) } | UNLESS expr ';' block else END { $factory->if("!($_[2])", @_[4, 5]) } | atomexpr UNLESS expr { $factory->if("!($_[3])", $_[1]) } ; else: ELSIF expr ';' block else { unshift(@{$_[5]}, [ @_[2, 4] ]); $_[5]; } | ELSE ';' block { [ $_[3] ] } | /* NULL */ { [ undef ] } ; switch: SWITCH expr ';' block case END { $factory->switch(@_[2, 5]) } ; case: CASE term ';' block case { unshift(@{$_[5]}, [ @_[2, 4] ]); $_[5]; } | CASE DEFAULT ';' block { [ $_[4] ] } | CASE ';' block { [ $_[3] ] } | /* NULL */ { [ undef ] } ; loop: FOR loopvar ';' { $_[0]->enter_block('FOR') } block END { $factory->foreach(@{$_[2]}, $_[5], $_[0]->leave_block) } | atomexpr FOR loopvar { $factory->foreach(@{$_[3]}, $_[1]) } | WHILE expr ';' { $_[0]->enter_block('WHILE') } block END { $factory->while(@_[2, 5], $_[0]->leave_block) } | atomexpr WHILE expr { $factory->while(@_[3, 1]) } ; loopvar: IDENT ASSIGN term args { [ @_[1, 3, 4] ] } | IDENT IN term args { [ @_[1, 3, 4] ] } | term args { [ 0, @_[1, 2] ] } ; wrapper: WRAPPER nameargs ';' block END { $factory->wrapper(@_[2, 4]) } | atomexpr WRAPPER nameargs { $factory->wrapper(@_[3, 1]) } ; try: TRY ';' block final END { $factory->try(@_[3, 4]) } ; final: CATCH filename ';' block final { unshift(@{$_[5]}, [ @_[2,4] ]); $_[5]; } | CATCH DEFAULT ';' block final { unshift(@{$_[5]}, [ undef, $_[4] ]); $_[5]; } | CATCH ';' block final { unshift(@{$_[4]}, [ undef, $_[3] ]); $_[4]; } | FINAL ';' block { [ $_[3] ] } | /* NULL */ { [ 0 ] } # no final ; use: USE lnameargs { $factory->use($_[2]) } ; view: VIEW nameargs ';' { $_[0]->push_defblock(); } block END { $factory->view(@_[2,5], $_[0]->pop_defblock) } ; perl: PERL ';' { ${$_[0]->{ INPERL }}++; } block END { ${$_[0]->{ INPERL }}--; $_[0]->{ EVAL_PERL } ? $factory->perl($_[4]) : $factory->no_perl(); } ; rawperl: RAWPERL { ${$_[0]->{ INPERL }}++; $rawstart = ${$_[0]->{'LINE'}}; } ';' TEXT END { ${$_[0]->{ INPERL }}--; $_[0]->{ EVAL_PERL } ? $factory->rawperl($_[4], $rawstart) : $factory->no_perl(); } ; filter: FILTER lnameargs ';' block END { $factory->filter(@_[2,4]) } | atomexpr FILTER lnameargs { $factory->filter(@_[3,1]) } ; defblock: defblockname blockargs ';' template END { my $name = join('/', @{ $_[0]->{ DEFBLOCKS } }); pop(@{ $_[0]->{ DEFBLOCKS } }); $_[0]->define_block($name, $_[4]); undef } ; defblockname: BLOCK blockname { push(@{ $_[0]->{ DEFBLOCKS } }, $_[2]); $_[2]; } ; blockname: filename | LITERAL { $_[1] =~ s/^'(.*)'$/$1/; $_[1] } ; blockargs: metadata | /* NULL */ ; anonblock: BLOCK blockargs ';' block END { local $" = ', '; print STDERR "experimental block args: [@{ $_[2] }]\n" if $_[2]; $factory->anon_block($_[4]) } ; capture: ident ASSIGN mdir { $factory->capture(@_[1, 3]) } ; macro: MACRO IDENT '(' margs ')' mdir { $factory->macro(@_[2, 6, 4]) } | MACRO IDENT mdir { $factory->macro(@_[2, 3]) } ; mdir: directive | BLOCK ';' block END { $_[3] } ; margs: margs IDENT { push(@{$_[1]}, $_[2]); $_[1] } | margs COMMA { $_[1] } | IDENT { [ $_[1] ] } ; metadata: metadata meta { push(@{$_[1]}, @{$_[2]}); $_[1] } | metadata COMMA | meta ; meta: IDENT ASSIGN LITERAL { for ($_[3]) { s/^'//; s/'$//; s/\\'/'/g }; [ @_[1,3] ] } | IDENT ASSIGN '"' TEXT '"' { [ @_[1,4] ] } | IDENT ASSIGN NUMBER { [ @_[1,3] ] } ; #-------------------------------------------------------------------------- # FUNDAMENTAL ELEMENT RULES #-------------------------------------------------------------------------- term: lterm | sterm ; lterm: '[' list ']' { "[ $_[2] ]" } | '[' range ']' { "[ $_[2] ]" } | '[' ']' { "[ ]" } | '{' hash '}' { "{ $_[2] }" } ; sterm: ident { $factory->ident($_[1]) } | REF ident { $factory->identref($_[2]) } | '"' quoted '"' { $factory->quoted($_[2]) } | LITERAL | NUMBER ; list: list term { "$_[1], $_[2]" } | list COMMA | term ; range: sterm TO sterm { $_[1] . '..' . $_[3] } ; hash: params | /* NULL */ { "" } ; params: params param { "$_[1], $_[2]" } | params COMMA | param ; param: LITERAL ASSIGN expr { "$_[1] => $_[3]" } | item ASSIGN expr { "$_[1] => $_[3]" } ; ident: ident DOT node { push(@{$_[1]}, @{$_[3]}); $_[1] } | ident DOT NUMBER { push(@{$_[1]}, map {($_, 0)} split(/\./, $_[3])); $_[1]; } | node ; node: item { [ $_[1], 0 ] } | item '(' args ')' { [ $_[1], $factory->args($_[3]) ] } ; item: IDENT { "'$_[1]'" } | '${' sterm '}' { $_[2] } | '$' IDENT { $_[0]->{ V1DOLLAR } ? "'$_[2]'" : $factory->ident(["'$_[2]'", 0]) } ; expr: expr BINOP expr { "$_[1] $_[2] $_[3]" } | expr '/' expr { "$_[1] $_[2] $_[3]" } | expr '+' expr { "$_[1] $_[2] $_[3]" } | expr DIV expr { "int($_[1] / $_[3])" } | expr MOD expr { "$_[1] % $_[3]" } | expr CMPOP expr { "$_[1] $CMPOP{ $_[2] } $_[3]" } | expr CAT expr { "$_[1] . $_[3]" } | expr AND expr { "$_[1] && $_[3]" } | expr OR expr { "$_[1] || $_[3]" } | NOT expr { "! $_[2]" } | expr '?' expr ':' expr { "$_[1] ? $_[3] : $_[5]" } | '(' assign ')' { $factory->assign(@{$_[2]}) } | '(' expr ')' { "($_[2])" } | term ; setlist: setlist assign { push(@{$_[1]}, @{$_[2]}); $_[1] } | setlist COMMA | assign ; assign: ident ASSIGN expr { [ $_[1], $_[3] ] } | LITERAL ASSIGN expr { [ @_[1,3] ] } ; # The 'args' production constructs a list of named and positional # parameters. Named parameters are stored in a list in element 0 # of the args list. Remaining elements contain positional parameters args: args expr { push(@{$_[1]}, $_[2]); $_[1] } | args param { push(@{$_[1]->[0]}, $_[2]); $_[1] } | args ident ASSIGN expr { push(@{$_[1]->[0]}, "'', " . $factory->assign(@_[2,4])); $_[1] } | args COMMA { $_[1] } | /* init */ { [ [ ] ] } ; # These are special case parameters used by INCLUDE, PROCESS, etc., which # interpret barewords as quoted strings rather than variable identifiers; # a leading '$' is used to explicitly specify a variable. It permits '/', # '.' and '::' characters, allowing it to be used to specify filenames, etc. # without requiring quoting. lnameargs: lvalue ASSIGN nameargs { push(@{$_[3]}, $_[1]); $_[3] } | nameargs ; lvalue: item | '"' quoted '"' { $factory->quoted($_[2]) } | LITERAL ; nameargs: '$' ident args { [ [$factory->ident($_[2])], $_[3] ] } | names args { [ @_[1,2] ] } | names '(' args ')' { [ @_[1,3] ] } ; names: names '+' name { push(@{$_[1]}, $_[3]); $_[1] } | name { [ $_[1] ] } ; name: '"' quoted '"' { $factory->quoted($_[2]) } | filename { "'$_[1]'" } | LITERAL ; filename: filename DOT filepart { "$_[1].$_[3]" } | filepart ; filepart: FILENAME | IDENT | NUMBER ; # The 'quoted' production builds a list of 'quotable' items that might # appear in a quoted string, namely text and identifiers. The lexer # adds an explicit ';' after each directive it finds to help the # parser identify directive/text boundaries; we're not interested in # them here so we can simply accept and ignore by returning undef quoted: quoted quotable { push(@{$_[1]}, $_[2]) if defined $_[2]; $_[1] } | /* NULL */ { [ ] } ; quotable: ident { $factory->ident($_[1]) } | TEXT { $factory->text($_[1]) } | ';' { undef } ; %% Template-Toolkit-2.24/parser/README000644 000765 000765 00000006374 11674036057 016434 0ustar00abwabw000000 000000 #======================================================================== # Template Toolkit - parser #======================================================================== This directory contains the YAPP grammar for the Template processor. You only need to worry about the files in this directory if you want to modify the template parser grammar. If you're doing such a thing, then it is assumed that you have some idea of what you're doing. Files: Parser.yp Yapp grammar file for the Template parser. Grammar.pm.skel Skeleton file for ../lib/Template/Grammar.pm. yc Simple shell cript to compile grammar and build new ../lib/Template/Grammer.pm file from Grammar.pm.skel and the output rules and states generated from the grammar. Parser.output Output file generated by the yapp parser. This is for information and debugging purposes only and can otherwise be ignored. README This file If you don't know what you're doing and would like to, then I can recommend "Lex and Yacc" by John R. Levine, Tony Mason & Doug Brown (O'Reilly, ISBN: 1-56592-000-7) which gives a good introduction to the principles of an LALR parser and how to define grammars in YACC. YAPP is identical to YACC in all the important ways. See also the Parse::Yapp documentation and the comments in Template::Parser for more info. For an in-depth study of parser and compiler theory, consult "Compiler Theory and Practice", a.k.a. "The Dragon Book", by Alfred V. Aho, Ravi Sethi and Jeffrey D.Ullman (Addison-Wesley, ISBN: 0-201-10194-7) The parser grammar is compiled by 'yapp', the front-end script to Francois Desarmenien's Parse::Yapp module(s). You will need Parse::Yapp version 0.32 or later, available from CPAN, to compile the grammar. The grammar file that yapp produces (../Template/Grammar.pm) contains the rule and state tables for the grammar. These are then loaded by Template::Parser and used to run the DFA which is implemented by the parse_directive() method. This has been derived from the standalone parser created by Parse::Yapp. Having modified the Parser.yp file to add your language changes, simply run: ./yc to compile the grammar and install it in ../lib/Template/Grammar.pm. You can then make, make test, make install, or whatever you normally do, and the new grammar should be used by the template processor. To revert to the original grammar, simply copy the original distribution Parser.yp file back into this directory and repeat the above process. To create a separate grammar, copy and modify the Parser.yp and Grammar.pm.skel files as you wish and then run yapp to compile them: yapp -v -s -o ../lib/Template/MyGrammar.pm \ -t MyGrammar.pm.skel MyParser.yp You can then instantiate you own grammar and pass this to the Template constructor. my $template = Template->new({ GRAMMAR => Template::MyGrammar->new(), }); Changing the grammar is a simple process, in theory at least, if you're familiar with YAPP/YACC. In practice, it also requires some insight into the inner working of the template toolkit which should probably be better documented somewhere. Andy Wardley Template-Toolkit-2.24/parser/yc000755 000765 000765 00000001612 11674036057 016103 0ustar00abwabw000000 000000 #!/bin/sh #======================================================================== # # yc - yapp compile # # This calls 'yapp', distributed with the Parse::Yapp module, to # compile the parser grammar and construct the ../Template/Grammar.pm # file. The grammar is defined in ./Parser.yp. The skeleton file # Grammar.pm.skel is used as a template for creating the grammar file. # An output file 'Parser.output' is generated containing a summary of # the rule and state tables. # # You only need to run this script if you have changed the grammar and # wish to recompile it. # # Andy Wardley # #======================================================================== : ${GRAMMAR:="Parser.yp"} : ${OUTPUT:="../lib/Template/Grammar.pm"} : ${TEMPLATE:="Grammar.pm.skel"} echo "Compiling parser grammar (${GRAMMAR} -> ${OUTPUT})" yapp -v -s -o ${OUTPUT} -t ${TEMPLATE} ${GRAMMAR} Template-Toolkit-2.24/lib/Template/000755 000765 000765 00000000000 11714420735 016562 5ustar00abwabw000000 000000 Template-Toolkit-2.24/lib/Template.pm000644 000765 000765 00000060641 11714264017 017126 0ustar00abwabw000000 000000 #============================================================= -*-perl-*- # # Template # # DESCRIPTION # Module implementing a simple, user-oriented front-end to the Template # Toolkit. # # AUTHOR # Andy Wardley # # COPYRIGHT # Copyright (C) 1996-2012 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #======================================================================== package Template; use strict; use warnings; use 5.006; use base 'Template::Base'; use Template::Config; use Template::Constants; use Template::Provider; use Template::Service; use File::Basename; use File::Path; use Scalar::Util qw(blessed); our $VERSION = '2.24'; our $ERROR = ''; our $DEBUG = 0; our $BINMODE = 0 unless defined $BINMODE; our $AUTOLOAD; # preload all modules if we're running under mod_perl Template::Config->preload() if $ENV{ MOD_PERL }; #------------------------------------------------------------------------ # process($input, \%replace, $output) # # Main entry point for the Template Toolkit. The Template module # delegates most of the processing effort to the underlying SERVICE # object, an instance of the Template::Service class. #------------------------------------------------------------------------ sub process { my ($self, $template, $vars, $outstream, @opts) = @_; my ($output, $error); my $options = (@opts == 1) && ref($opts[0]) eq 'HASH' ? shift(@opts) : { @opts }; $options->{ binmode } = $BINMODE unless defined $options->{ binmode }; # we're using this for testing in t/output.t and t/filter.t so # don't remove it if you don't want tests to fail... $self->DEBUG("set binmode\n") if $DEBUG && $options->{ binmode }; $output = $self->{ SERVICE }->process($template, $vars); if (defined $output) { $outstream ||= $self->{ OUTPUT }; unless (ref $outstream) { my $outpath = $self->{ OUTPUT_PATH }; $outstream = "$outpath/$outstream" if $outpath; } # send processed template to output stream, checking for error return ($self->error($error)) if ($error = &_output($outstream, \$output, $options)); return 1; } else { return $self->error($self->{ SERVICE }->error); } } #------------------------------------------------------------------------ # service() # # Returns a reference to the the internal SERVICE object which handles # all requests for this Template object #------------------------------------------------------------------------ sub service { my $self = shift; return $self->{ SERVICE }; } #------------------------------------------------------------------------ # context() # # Returns a reference to the the CONTEXT object withint the SERVICE # object. #------------------------------------------------------------------------ sub context { my $self = shift; return $self->{ SERVICE }->{ CONTEXT }; } sub template { shift->context->template(@_); } #======================================================================== # -- PRIVATE METHODS -- #======================================================================== #------------------------------------------------------------------------ # _init(\%config) #------------------------------------------------------------------------ sub _init { my ($self, $config) = @_; # convert any textual DEBUG args to numerical form my $debug = $config->{ DEBUG }; $config->{ DEBUG } = Template::Constants::debug_flags($self, $debug) || return if defined $debug && $debug !~ /^\d+$/; # prepare a namespace handler for any CONSTANTS definition if (my $constants = $config->{ CONSTANTS }) { my $ns = $config->{ NAMESPACE } ||= { }; my $cns = $config->{ CONSTANTS_NAMESPACE } || 'constants'; $constants = Template::Config->constants($constants) || return $self->error(Template::Config->error); $ns->{ $cns } = $constants; } $self->{ SERVICE } = $config->{ SERVICE } || Template::Config->service($config) || return $self->error(Template::Config->error); $self->{ OUTPUT } = $config->{ OUTPUT } || \*STDOUT; $self->{ OUTPUT_PATH } = $config->{ OUTPUT_PATH }; return $self; } #------------------------------------------------------------------------ # _output($where, $text) #------------------------------------------------------------------------ sub _output { my ($where, $textref, $options) = @_; my $reftype; my $error = 0; # call a CODE reference if (($reftype = ref($where)) eq 'CODE') { &$where($$textref); } # print to a glob (such as \*STDOUT) elsif ($reftype eq 'GLOB') { print $where $$textref; } # append output to a SCALAR ref elsif ($reftype eq 'SCALAR') { $$where .= $$textref; } # push onto ARRAY ref elsif ($reftype eq 'ARRAY') { push @$where, $$textref; } # call the print() method on an object that implements the method # (e.g. IO::Handle, Apache::Request, etc) elsif (blessed($where) && $where->can('print')) { $where->print($$textref); } # a simple string is taken as a filename elsif (! $reftype) { local *FP; # make destination directory if it doesn't exist my $dir = dirname($where); eval { mkpath($dir) unless -d $dir; }; if ($@) { # strip file name and line number from error raised by die() ($error = $@) =~ s/ at \S+ line \d+\n?$//; } elsif (open(FP, ">$where")) { # binmode option can be 1 or a specific layer, e.g. :utf8 my $bm = $options->{ binmode }; if ($bm && $bm eq 1) { binmode FP; } elsif ($bm){ binmode FP, $bm; } print FP $$textref; close FP; } else { $error = "$where: $!"; } } # give up, we've done our best else { $error = "output_handler() cannot determine target type ($where)\n"; } return $error; } 1; __END__ =head1 NAME Template - Front-end module to the Template Toolkit =head1 SYNOPSIS use Template; # some useful options (see below for full list) my $config = { INCLUDE_PATH => '/search/path', # or list ref INTERPOLATE => 1, # expand "$var" in plain text POST_CHOMP => 1, # cleanup whitespace PRE_PROCESS => 'header', # prefix each template EVAL_PERL => 1, # evaluate Perl code blocks }; # create Template object my $template = Template->new($config); # define template variables for replacement my $vars = { var1 => $value, var2 => \%hash, var3 => \@list, var4 => \&code, var5 => $object, }; # specify input filename, or file handle, text reference, etc. my $input = 'myfile.html'; # process input template, substituting variables $template->process($input, $vars) || die $template->error(); =head1 DESCRIPTION This documentation describes the Template module which is the direct Perl interface into the Template Toolkit. It covers the use of the module and gives a brief summary of configuration options and template directives. Please see L for the complete reference manual which goes into much greater depth about the features and use of the Template Toolkit. The L is also available as an introductory guide to using the Template Toolkit. =head1 METHODS =head2 new(\%config) The C constructor method (implemented by the L base class) instantiates a new C