├── .gitignore ├── .travis.yml ├── Changes ├── Install ├── MANIFEST ├── MANIFEST.SKIP ├── Makefile.PL ├── README.md ├── bin └── lemplate ├── doc ├── Makefile ├── html │ └── Jemplate.html └── text │ └── Jemplate.text ├── inc ├── Module │ ├── AutoInstall.pm │ ├── Install.pm │ └── Install │ │ ├── AutoInstall.pm │ │ ├── Base.pm │ │ ├── Can.pm │ │ ├── Fetch.pm │ │ ├── Include.pm │ │ ├── Makefile.pm │ │ ├── Metadata.pm │ │ ├── Scripts.pm │ │ ├── TestBase.pm │ │ ├── Win32.pm │ │ └── WriteAll.pm ├── Spiffy.pm └── Test │ ├── Base.pm │ ├── Base │ └── Filter.pm │ ├── Builder.pm │ ├── Builder │ └── Module.pm │ └── More.pm ├── lemplate ├── lib ├── Lemplate.pm └── Lemplate │ ├── Directive.pm │ ├── Grammar.pm │ └── Parser.pm ├── note ├── Design └── ToDo ├── src ├── Makefile ├── README ├── bin │ ├── make-standalone-script │ └── tpage └── parser │ ├── Grammar.pm.skel │ ├── Parser.yp │ ├── README │ └── yc ├── t ├── TestLemplate.pm ├── binop.t ├── block.t ├── blocks.t ├── data │ ├── README │ ├── after │ ├── badrawperl │ ├── barfed │ ├── before │ ├── blockdef │ ├── chomp │ ├── config │ ├── content │ ├── default │ ├── dos_newlines │ ├── error │ ├── footer │ ├── header │ ├── header.tt2 │ ├── incblock │ ├── inner │ ├── menu │ ├── one │ │ └── foo │ ├── outer │ ├── process │ ├── simple2 │ ├── trimme │ ├── two │ │ ├── bar │ │ └── foo │ ├── udata1 │ ├── udata2 │ └── warning ├── filters.t ├── iterator.t ├── pod.t ├── sanity.t ├── stash-get.t └── vmethods.t └── util ├── convert-tt2-tests └── gendoc /.gitignore: -------------------------------------------------------------------------------- 1 | .build 2 | Lemplate-* 3 | tests/tjs/var 4 | Makefile 5 | Makefile.old 6 | Makefile.js 7 | t/a.js 8 | t/b.js 9 | t/check.js 10 | *~ 11 | *.swp 12 | *.swo 13 | *.bak 14 | go 15 | a.lua 16 | html_out/ 17 | ebooks.sh 18 | *.tags 19 | META.yml 20 | MYMETA.json 21 | MYMETA.yml 22 | blib/ 23 | pm_to_blib 24 | reindex 25 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - 5.18 4 | - 5.16 5 | - 5.14 6 | - 5.12 7 | - 5.10 8 | - 5.8 9 | 10 | install: 11 | - wget https://openresty.org/download/openresty-1.11.2.3rc1.tar.gz 12 | - tar -xf openresty-1.11.2.3rc1.tar.gz 13 | - cd openresty-1.11.2.3rc1/ && ./configure -j2 && make -j2 && sudo make install && cd .. 14 | - cpanm --quiet --notest 15 | File::Find::Rule 16 | Template 17 | IPC::Run3 18 | 19 | script: 20 | - PATH="/usr/local/openresty/bin:$PATH" prove -j2 -Ilib -r t/ 21 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Lemplate. 2 | 3 | 0.15 2017-06-15 4 | * bugfix: squelched a warning from Text::Glob for some users. 5 | 6 | 0.14 2017-06-06 7 | * fixed the repository link in Makefile.PL. 8 | 9 | 0.13 2017-06-06 10 | * excluded files that should not be bundled in the release tarball. 11 | 12 | 0.12 2017-05-20 13 | * fixed the test suite with the latest resty. thanks Ingy dot Net for the 14 | report.* 15 | 16 | 0.11 2017-05-07 17 | * refactor: removed useless lemplate's runtime code. 18 | 19 | 0.10 2017-05-07 20 | * bugfix: forgot to install the lemplate script in Makefile.PL. 21 | this bug had appeared in 0.08. 22 | 23 | 0.09 2017-05-06 24 | * bugfix: added version numbers to Lemplate::Parser and Lemplate::Directive. 25 | 26 | 0.08 2017-05-06 27 | * feature: added more vmethods to Lemplate. 28 | * rewrote stash_get and implemented methods push, keys, split and join. 29 | * added a sort vmethod. 30 | * updated lempate script with new vmethod features. 31 | 32 | * feature: support custom lua TT filters. Example: 33 | 34 | lemplate = require('my.templates') 35 | lemplate.filters['upper'] = function(str, args) 36 | return string.upper(str) 37 | end 38 | lemplate.process('[% "i like pie" | upper %]') 39 | 40 | * feature: added 2 more standard filters: upper and lower. 41 | 42 | 0.07 2016-07-15 43 | * added MANIFEST.SKIP to exclude unwanted files from packaging. 44 | 45 | 0.05 2016-07-15 46 | * relaxed the minimum versions of our Perl dependency modules. 47 | * re-generate Lemplate::Grammar with the latest Parse::Yapp. 48 | 49 | 0.03 2016-03-19 50 | * feature: added support for the foo.bar() TT2 language syntax. 51 | * bugfix: avoided generating nil values in stash_get() on the Lua land. 52 | * refactor: removed useless modules Lemplate::Runtime and Lemplate::Runtime::Compact. 53 | -------------------------------------------------------------------------------- /Install: -------------------------------------------------------------------------------- 1 | == The Jemplate Compiler == 2 | 3 | The program called 'jemplate' that is next to this Install file is a 4 | standalone compiler for Jemplate. It has no dependencies except that there 5 | must be a 'perl' executable command in your PATH. (Most machines come with 6 | Perl preinstalled these days.) 7 | 8 | To use Jemplate, just download this compiler and put it in your bin PATH. 9 | That's it. 10 | 11 | To get help on the Jemplate compiler, run this command: 12 | 13 | jemplate --help 14 | 15 | --Ingy döt Net 16 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | bin/lemplate 2 | Changes 3 | doc/html/Jemplate.html 4 | doc/Makefile 5 | doc/text/Jemplate.text 6 | inc/Module/AutoInstall.pm 7 | inc/Module/Install.pm 8 | inc/Module/Install/AutoInstall.pm 9 | inc/Module/Install/Base.pm 10 | inc/Module/Install/Can.pm 11 | inc/Module/Install/Fetch.pm 12 | inc/Module/Install/Include.pm 13 | inc/Module/Install/Makefile.pm 14 | inc/Module/Install/Metadata.pm 15 | inc/Module/Install/Scripts.pm 16 | inc/Module/Install/TestBase.pm 17 | inc/Module/Install/Win32.pm 18 | inc/Module/Install/WriteAll.pm 19 | inc/Spiffy.pm 20 | inc/Test/Base.pm 21 | inc/Test/Base/Filter.pm 22 | inc/Test/Builder.pm 23 | inc/Test/Builder/Module.pm 24 | inc/Test/More.pm 25 | Install 26 | lemplate 27 | lib/Lemplate.pm 28 | lib/Lemplate/Directive.pm 29 | lib/Lemplate/Grammar.pm 30 | lib/Lemplate/Parser.pm 31 | Makefile.PL 32 | MANIFEST 33 | MANIFEST.SKIP 34 | note/Design 35 | note/ToDo 36 | README.md 37 | src/bin/make-standalone-script 38 | src/bin/tpage 39 | src/Makefile 40 | src/parser/Grammar.pm.skel 41 | src/parser/Parser.yp 42 | src/parser/README 43 | src/parser/yc 44 | src/README 45 | t/binop.t 46 | t/block.t 47 | t/blocks.t 48 | t/data/after 49 | t/data/badrawperl 50 | t/data/barfed 51 | t/data/before 52 | t/data/blockdef 53 | t/data/chomp 54 | t/data/config 55 | t/data/content 56 | t/data/default 57 | t/data/dos_newlines 58 | t/data/error 59 | t/data/footer 60 | t/data/header 61 | t/data/header.tt2 62 | t/data/incblock 63 | t/data/inner 64 | t/data/menu 65 | t/data/one/foo 66 | t/data/outer 67 | t/data/process 68 | t/data/README 69 | t/data/simple2 70 | t/data/trimme 71 | t/data/two/bar 72 | t/data/two/foo 73 | t/data/udata1 74 | t/data/udata2 75 | t/data/warning 76 | t/filters.t 77 | t/iterator.t 78 | t/pod.t 79 | t/sanity.t 80 | t/stash-get.t 81 | t/TestLemplate.pm 82 | t/vmethods.t 83 | util/convert-tt2-tests 84 | util/gendoc 85 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^html_out 2 | ^ebooks\.sh$ 3 | .*\.tags$ 4 | ^go$ 5 | ^a\.lua$ 6 | .*~$ 7 | \.git/ 8 | ^\.travis\.yml$ 9 | ^tmp.* 10 | \.gitignore$ 11 | blib/ 12 | ^Makefile$ 13 | ^MYMETA\. 14 | update-ver 15 | ^META\.yml$ 16 | ^reindex$ 17 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use lib '.'; 3 | use inc::Module::Install; 4 | 5 | name ('Lemplate'); 6 | license ('artistc'); 7 | perl_version ('5.010001'); 8 | repository ('https://github.com/openresty/lemplate'); 9 | all_from ('lib/Lemplate.pm'); 10 | 11 | install_script ("./lemplate"); 12 | 13 | requires ('Template' => 2.14); 14 | requires ('File::Find::Rule'); 15 | build_requires ('IPC::Run3'); 16 | 17 | use_test_base(); 18 | auto_install(); 19 | 20 | #tests('t/*.t t/*/*.t'); 21 | 22 | WriteAll(); 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Name 2 | 3 | Lemplate - OpenResty/Lua template framework implementing Perl's TT2 templating language 4 | 5 | Table of Contents 6 | ================= 7 | 8 | * [Name](#name) 9 | * [Status](#status) 10 | * [Synopsis](#synopsis) 11 | * [Description](#description) 12 | * [HowTo](#howto) 13 | * [Public API](#public-api) 14 | * [Current Support](#current-support) 15 | * [Community](#community) 16 | * [English Mailing List](#english-mailing-list) 17 | * [Chinese Mailing List](#chinese-mailing-list) 18 | * [Code Repository](#code-repository) 19 | * [Bugs and Patches](#bugs-and-patches) 20 | * [Credit](#credit) 21 | * [Author](#author) 22 | * [Copyright](#copyright) 23 | * [See Also](#see-also) 24 | 25 | # Status 26 | 27 | This is still under early development. Check back often. 28 | 29 | # Synopsis 30 | 31 | From the command-line: 32 | 33 | lemplate --compile path/to/lemplate/directory/ > myapp/templates.lua 34 | 35 | From OpenResty Lua code: 36 | 37 | local templates = require "myapp.templates" 38 | ngx.print(templates.process("homepage.tt2", { var1 = 32, var2 = "foo" })) 39 | 40 | From the command-line: 41 | 42 | lemplate --compile path/to/lemplate/directory/ > myapp/templates.lua 43 | 44 | # Description 45 | 46 | Lemplate is a templating framework for OpenResty/Lua that is built over 47 | Perl's Template Toolkit (TT2). 48 | 49 | Lemplate parses TT2 templates using the TT2 Perl framework, but with a twist. 50 | Instead of compiling the templates into Perl code, it compiles them into Lua 51 | that can run on OpenResty. 52 | 53 | Lemplate then provides a Lua runtime module for processing the template code. 54 | Presto, we have full featured Lua templating language! 55 | 56 | Combined with OpenResty, Lemplate provides a really simple and powerful way to 57 | do web stuff. 58 | 59 | [Back to TOC](#table-of-contents) 60 | 61 | # HowTo 62 | 63 | Lemplate comes with a command line tool call `lemplate` that you use to 64 | precompile your templates into a Lua module file. For example if you have a 65 | template directory called `templates` that contains: 66 | 67 | $ ls templates/ 68 | body.tt2 69 | footer.tt2 70 | header.tt2 71 | 72 | You might run this command: 73 | 74 | $ lemplate --compile template/* > myapp/templates.lua 75 | 76 | This will compile all the templates into one Lua module file which can be loaded in your 77 | main OpenResty/Lua application as the module `myapp.templates`. 78 | 79 | Now all you need to do is load the Lua module file in your OpenResty app: 80 | 81 | local templates = require "myapp.templates" 82 | 83 | and do the HTML page rendering: 84 | 85 | local results = templates.process("some-page.tt2", 86 | { var1 = val1, var2 = val2, ...}) 87 | 88 | Now you have Lemplate support for these templates in your OpenResty application. 89 | 90 | [Back to TOC](#table-of-contents) 91 | 92 | # Public API 93 | 94 | The Lemplate Lua runtime module has the following API method: 95 | 96 | - process(template-name, data) 97 | 98 | The `template-name` is a string like `'body.tt2'` that is the name of 99 | the top level template that you wish to process. 100 | 101 | The optional `data` specifies the data object to be used by the 102 | templates. It can be an object, a function or a url. If it is an object, 103 | it is used directly. If it is a function, the function is called and the 104 | returned object is used. 105 | 106 | [Back to TOC](#table-of-contents) 107 | 108 | # Current Support 109 | 110 | The goal of Lemplate is to support all of the Template Toolkit features 111 | that can possibly be supported. 112 | 113 | Lemplate now supports almost all the TT directives, including: 114 | 115 | * Plain text 116 | * [% [GET] variable %] 117 | * [% [SET] variable = value %] 118 | * [% DEFAULT variable = value ... %] 119 | * [% INCLUDE [arguments] %] 120 | * [% PROCESS [arguments] %] 121 | * [% BLOCK name %] 122 | * [% IF condition %] 123 | * [% ELSIF condition %] 124 | * [% ELSE %] 125 | * [% FOR x = y %] 126 | * [% FOR x IN y %] 127 | * [% WHILE expression %] 128 | * [% NEXT %] 129 | * [% LAST %] 130 | * [%# this is a comment %] 131 | 132 | ALL of the string virtual functions are supported. 133 | 134 | ALL of the array virtual functions are supported: 135 | 136 | ALL of the hash virtual functions are supported: 137 | 138 | MANY of the standard filters are implemented. 139 | 140 | The remaining features will be added very soon. See the DESIGN document 141 | in the distro for a list of all features and their progress. 142 | 143 | [Back to TOC](#table-of-contents) 144 | 145 | # Community 146 | 147 | ## English Mailing List 148 | 149 | The [openresty-en](https://groups.google.com/group/openresty-en) mailing list is for English speakers. 150 | 151 | [Back to TOC](#table-of-contents) 152 | 153 | ## Chinese Mailing List 154 | 155 | The [openresty](https://groups.google.com/group/openresty) mailing list is for Chinese speakers. 156 | 157 | [Back to TOC](#table-of-contents) 158 | 159 | # Code Repository 160 | 161 | The bleeding edge code is available via Git at 162 | git://github.com/openresty/lemplate.git 163 | 164 | [Back to TOC](#table-of-contents) 165 | 166 | # Bugs and Patches 167 | 168 | Please submit bug reports, wishlists, or patches by 169 | 170 | 1. creating a ticket on the [GitHub Issue Tracker](https://github.com/openresty/lua-nginx-module/issues), 171 | 2. or posting to the ["Community"](#community). 172 | 173 | [Back to TOC](#table-of-contents) 174 | 175 | # Credit 176 | 177 | This project is based on Ingy dot Net's excellent [Jemplate](https://metacpan.org/pod/Jemplate) project. 178 | 179 | [Back to TOC](#table-of-contents) 180 | 181 | # Author 182 | 183 | Yichun Zhang (agentzh), , OpenResty Inc. 184 | 185 | [Back to TOC](#table-of-contents) 186 | 187 | # Copyright 188 | 189 | Copyright (C) 2016-2017 Yichun Zhang (agentzh). All Rights Reserved. 190 | 191 | Copyright (C) 1996-2014 Andy Wardley. All Rights Reserved. 192 | 193 | Copyright (c) 2006-2014. Ingy döt Net. All rights reserved. 194 | 195 | Copyright (C) 1998-2000 Canon Research Centre Europe Ltd 196 | 197 | This module is free software; you can redistribute it and/or modify it under 198 | the same terms as Perl itself. 199 | 200 | [Back to TOC](#table-of-contents) 201 | 202 | # See Also 203 | 204 | - Perl TT2 Reference Manual: http://www.template-toolkit.org/docs/manual/index.html 205 | - Jemplate for compiling TT2 templates to client-side JavaScript: http://www.jemplate.net/ 206 | 207 | [Back to TOC](#table-of-contents) 208 | 209 | -------------------------------------------------------------------------------- /bin/lemplate: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Fix a bug where Text::Glob causes a warning. 4 | { 5 | package Text::Glob; 6 | no warnings 'once'; 7 | } 8 | 9 | #BOOTSTRAP-BEGIN 10 | # This section of code will be replaced by lots of inline Perl modules 11 | # to make the standalone lemplate script. 12 | use lib 'lib'; 13 | use Lemplate; 14 | #BOOTSTRAP-END 15 | 16 | our $VERSION = '0.11'; 17 | 18 | Lemplate->main(@ARGV); 19 | 20 | __END__ 21 | 22 | =encoding UTF-8 23 | 24 | =head1 Usage: 25 | 26 | lemplate --runtime [runtime-opt] 27 | 28 | lemplate --compile [compile-opt] template-list 29 | 30 | lemplate --runtime [runtime-opt] --compile [compile-opt] template-list 31 | 32 | lemplate --list template-list 33 | 34 | Where C<--runtime> and C can include: 35 | 36 | --runtime Equivalent to --ajax=ilinsky --json=json2 37 | --runtime=standard 38 | 39 | --runtime=lite Same as --ajax=none --json=none 40 | --runtime=jquery Same as --ajax=jquery --json=none 41 | --runtime=yui Same as --ajax=yui --json=yui 42 | --runtime=legacy Same as --ajax=gregory --json=json2 43 | 44 | --json By itself, equivalent to --json=json2 45 | --json=json2 Include http://www.json.org/json2.js for parsing/stringifying 46 | --json=yui Use YUI: YAHOO.lang.JSON (requires external YUI) 47 | --json=none Doesn't provide any JSON functionality except a warning 48 | 49 | --ajax By itself, equivalent to --ajax=xhr 50 | --ajax=jquery Use jQuery for Ajax get and post (requires external jQuery) 51 | --ajax=yui Use YUI: yui/connection/connection.js (requires external YUI) 52 | --ajax=xhr Use XMLHttpRequest (will automatically use --xhr=ilinsky if --xhr is not set) 53 | --ajax=none Doesn't provide any Ajax functionality except a warning 54 | 55 | --xhr By itself, equivalent to --xhr=ilinsky 56 | --xhr=ilinsky Include http://code.google.com/p/xmlhttprequest/ 57 | --xhr=gregory Include http://www.scss.com.au/family/andrew/webdesign/xmlhttprequest/ 58 | 59 | --xxx Include XXX and JJJ helper functions 60 | 61 | --compact Use the YUICompressor compacted version of the runtime 62 | 63 | Where C can include: 64 | 65 | --start-tag 66 | --end-tag 67 | --pre-chomp 68 | --post-chomp 69 | --trim 70 | --any-case 71 | --eval 72 | --noeval 73 | -s, --source 74 | --exclude 75 | 76 | See below for more information 77 | 78 | =head2 Example: 79 | 80 | Write the Lemplate runtime code into Lemplate.js, then 81 | compile all the template files in the templates/ directory and put 82 | the output in my-lemplate.js. 83 | 84 | lemplate --runtime > Lemplate.js 85 | lemplate --compile templates/* > my-lemplate.js 86 | 87 | Do the same thing, but put the output into one file. 88 | 89 | lemplate --runtime > my-lemplate.js 90 | lemplate --compile templates/* >> my-lemplate.js 91 | 92 | =head2 template-list: 93 | 94 | The template-list is the list of template files that will be compiled. 95 | If something in the list is a file, then the template name will be just 96 | the file name. If it is a directory, then all the files under that 97 | directory will be found, and the relative paths to those files will be 98 | the template name. 99 | 100 | So 'template/foo/bar.tt2' will be named 'bar.tt2', but 'template/' will 101 | find a template named 'foo/bar.tt2'. 102 | 103 | It is important to know what Lemplate thinks the template name will be 104 | when you are writing templates or code that refers to other templates. 105 | Use the --list option to check this. 106 | 107 | =head1 Commands: 108 | 109 | -r, --runtime 110 | This flag tells Lemplate to print the Lemplate JavaScript 111 | runtime code to STDOUT. You should redirect this output into 112 | a .js file. 113 | 114 | -c, --compile 115 | The --compile flag tells Lemplate to actually compile templates. 116 | The output is written to STDOUT. 117 | 118 | -l, --list 119 | Just print (STDOUT) the template names that Lemplate would use 120 | from the template-list. 121 | 122 | =head1 Template Toolkit Compile Options: 123 | 124 | Lemplate allows you to specify the following Template Toolkit compile 125 | time options. Full descriptions of these options are available at 126 | L. 127 | 128 | These options may either be set as JEMPLATE_* environment variables or as 129 | command line switches. 130 | 131 | --start-tag (JEMPLATE_START_TAG) 132 | Specify the starting template delimiter to use. Default is '[%'. 133 | 134 | --end-tag (JEMPLATE_END_TAG) 135 | Specify the ending template delimiter to use. Default is '%]'. 136 | 137 | --pre-chomp (JEMPLATE_PRE_CHOMP) 138 | Chomp leading whitespace automatically. Default is off. 139 | 140 | --post-chomp (JEMPLATE_POST_CHOMP) 141 | Chomp trailing whitespace automatically. Default is off. 142 | 143 | --trim (JEMPLATE_TRIM) 144 | Trim leading and trailing whitespace. Default is off. 145 | 146 | --any-case (JEMPLATE_ANYCASE) 147 | Allow lower or mixed case for template directives. Default is off. 148 | 149 | --eval (--noeval) (JEMPLATE_EVAL_JAVASCRIPT) 150 | Allow the execution of raw JavaScript. Default is on. 151 | Use --noeval to disallow it. 152 | 153 | =head1 Lemplate Options: 154 | 155 | These compile time options are specific to Lemplate. 156 | 157 | -s, --source 158 | Include the original template source code as a JavaScript 159 | comment next to each compiled template. 160 | 161 | --exclude 162 | Exclude any file matching the given regular expression. 163 | 164 | =cut 165 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | all: html/Jemplate.html text/Jemplate.text 2 | 3 | html/Jemplate.html: ../lib/Jemplate.pm html 4 | pod2html $< > $@ 5 | rm pod2htm*.tmp 6 | 7 | text/Jemplate.text: ../lib/Jemplate.pm text 8 | pod2text $< > $@ 9 | 10 | html text: 11 | mkdir $@ 12 | 13 | clean: 14 | rm -fr html text 15 | -------------------------------------------------------------------------------- /doc/html/Jemplate.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Jemplate - JavaScript Templating with Template Toolkit 6 | 7 | 8 | 9 | 10 | 11 | 12 |

13 | 14 | 15 | 30 | 31 | 32 |
33 |

34 |

35 |
36 |

NAME

37 |

Jemplate - JavaScript Templating with Template Toolkit

38 |

39 |

40 |
41 |

SYNOPSIS

42 | 
 43 |     var data = Ajax.get('url/data.json');
 44 |     var elem = document.getElementById('some-div');
 45 |     elem.innerHTML = Jemplate.process('my-template.html', data);
46 |

or:

47 | 
 48 |     var data = Ajax.get('url/data.json');
 49 |     var elem = document.getElementById('some-div');
 50 |     Jemplate.process('my-template.html', data, elem);
51 |

or simply:

52 | 
 53 |     Jemplate.process('my-template.html', 'url/data.json', '#some-div');
54 |

or, with jQuery.js:

55 | 
 56 |     jQuery.getJSON("url/data.json", function(data) {
 57 |         Jemplate.process('my-template.html', data, '#some-div');
 58 |     });
59 |

60 |

61 |
62 |

DESCRIPTION

63 |

Jemplate is a templating framework for JavaScript that is built over 64 | Perl's Template Toolkit (TT2).

65 |

Jemplate parses TT2 templates using the TT2 Perl framework, but with a 66 | twist. Instead of compiling the templates into Perl code, it compiles 67 | them into JavaScript.

68 |

Jemplate then provides a JavaScript runtime module for processing 69 | the template code. Presto, we have full featured JavaScript 70 | templating language!

71 |

Combined with JSON and xmlHttpRequest, Jemplate provides a really simple 72 | and powerful way to do Ajax stuff.

73 |

74 |

75 |
76 |

HOWTO

77 |

Jemplate comes with a command line tool call jemplate that you use to 78 | precompile your templates into a JavaScript file. For example if you have 79 | a template directory called templates that contains:

80 | 
 81 |     > ls templates/
 82 |     body.html
 83 |     footer.html
 84 |     header.html
85 |

You might run this command:

86 | 
 87 |     > jemplate --compile template/* > js/jemplates.js
88 |

This will compile all the templates into one JavaScript file.

89 |

You also need to generate the Jemplate runtime.

90 | 
 91 |     > jemplate --runtime > js/Jemplate.js
92 |

Now all you need to do is include these two files in your HTML:

93 | 
 94 |     <script src="js/Jemplate.js" type="text/javascript"></script>
 95 |     <script src="js/jemplates.js" type="text/javascript"></script>
96 |

Now you have Jemplate support for these templates in your HTML document.

97 |

98 |

99 |
100 |

PUBLIC API

101 |

The Jemplate.js JavaScript runtime module has the following API method:

102 |
103 |
Jemplate.process(template-name, data, target); 104 | 105 |
106 |

The template-name is a string like 'body.html' that is the name of 107 | the top level template that you wish to process.

108 |
109 |
110 |

The optional data specifies the data object to be used by the 111 | templates. It can be an object, a function or a url. If it is an object, 112 | it is used directly. If it is a function, the function is called and the 113 | returned object is used. If it is a url, an asynchronous <Ajax.get> is 114 | performed. The result is expected to be a JSON string, which gets turned 115 | into an object.

116 |
117 |
118 |

The optional target can be an HTMLElement reference, a function or a 119 | string beginning with a # char. If the target is omitted, the 120 | template result is returned. If it is a function, the function is called 121 | with the result. If it is a string, the string is used as an id to find 122 | an HTMLElement.

123 |
124 |
125 |

If an HTMLElement is used (by id or directly) then the innerHTML 126 | property is set to the template processing result.

127 |
128 | 129 |
130 |

The Jemplate.pm Perl module has the following public class methods, 131 | although you won't likely need to use them directly. Normally, you just 132 | use the jemplate command line tool.

133 |
134 |
Jemplate->compile_template_files(@template_file_paths); 135 | 136 |
137 |

Take a list of template file paths and compile them into a module of 138 | functions. Returns the text of the module.

139 |
140 | 141 |
Jemplate->compile_template_content($content, $template_name); 142 | 143 |
144 |

Compile one template whose content is in memory. You must provide a 145 | unique template name. Returns the JavaScript text result of the 146 | compilation.

147 |
148 | 149 |
Jemplate->compile_module($module_path, \@template_file_paths); 150 | 151 |
152 |

Similar to `compile_template_files`, but prints to result to the 153 | $module_path. Returns 1 if successful, undef if error.

154 |
155 | 156 |
Jemplate->compile_module_cached($module_path, \@template_file_paths); 157 | 158 |
159 |

Similar to `compile_module`, but only compiles if one of the templates 160 | is newer than the module. Returns 1 if successful compile, 0 if no 161 | compile due to cache, undef if error.

162 |
163 | 164 |
165 |

166 |

167 |
168 |

AJAX AND JSON METHODS

169 |

Jemplate comes with builtin Ajax and JSON support.

170 |
171 |
Ajax.get(url, [callback]); 172 | 173 |
174 |

Does a GET operation to the url.

175 |
176 |
177 |

If a callback is provided, the operation is asynchronous, and the data 178 | is passed to the callback. Otherwise, the operation is synchronous and 179 | the data is returned.

180 |
181 | 182 |
Ajax.post(url, data, [callback]); 183 | 184 |
185 |

Does a POST operation to the url.

186 |
187 |
188 |

Same callback rules as get apply.

189 |
190 | 191 |
JSON.stringify(object); 192 | 193 |
194 |

Return the JSON serialization of an object.

195 |
196 | 197 |
JSON.parse(jsonString); 198 | 199 |
200 |

Turns a JSON string into an object and returns the object.

201 |
202 | 203 |
204 |

205 |

206 |
207 |

CURRENT SUPPORT

208 |

The goal of Jemplate is to support all of the Template Toolkit features 209 | that can possibly be supported.

210 |

Jemplate now supports almost all the TT directives, including:

211 | 
212 |   * Plain text
213 |   * [% [GET] variable %]
214 |   * [% CALL variable %]
215 |   * [% [SET] variable = value %]
216 |   * [% DEFAULT variable = value ... %]
217 |   * [% INCLUDE [arguments] %]
218 |   * [% PROCESS [arguments] %]
219 |   * [% BLOCK name %]
220 |   * [% FILTER filter %] text... [% END %]
221 |   * [% JAVASCRIPT %] code... [% END %]
222 |   * [% WRAPPER template [variable = value ...] %]
223 |   * [% IF condition %]
224 |   * [% ELSIF condition %]
225 |   * [% ELSE %]
226 |   * [% SWITCH variable %]
227 |   * [% CASE [{value|DEFAULT}] %]
228 |   * [% FOR x = y %]
229 |   * [% WHILE expression %]
230 |   * [% RETURN %]
231 |   * [% THROW type message %]
232 |   * [% STOP %]
233 |   * [% NEXT %]
234 |   * [% LAST %]
235 |   * [% CLEAR %]
236 |   * [%# this is a comment %]
237 |

ALL of the string virtual functions are supported.

238 |

ALL of the array virtual functions are supported:

239 |

ALL of the hash virtual functions are supported (except for import):

240 |

MANY of the standard filters are implemented.

241 |

The remaining features will be added very soon. See the DESIGN document 242 | in the distro for a list of all features and their progress.

243 |

244 |

245 |
246 |

BROWSER SUPPORT

247 |

Tested successfully in:

248 | 
249 |     * Firefox Mac/Win32/Linux
250 |     * IE 6.0
251 |     * Safari
252 |     * Opera
253 |     * Konqueror
254 |

All tests run 100% successful in the above browsers.

255 |

256 |

257 |
258 |

DEVELOPMENT

259 |

The bleeding edge code is available via Subversion at 260 | http://svn.jemplate.net/repo/trunk/

261 |

You can run the runtime tests directly from 262 | http://svn.jemplate.net/repo/trunk/tests/run/index.html or from the 263 | corresponding CPAN or JSAN directories.

264 |

Jemplate development is being discussed at irc://irc.freenode.net/#jemplate

265 |

If you want a committer bit, just ask ingy on the irc channel.

266 |

267 |

268 |
269 |

CREDIT

270 |

This module is only possible because of Andy Wardley's mighty Template 271 | Toolkit. Thanks Andy. I will gladly give you half of any beers I 272 | receive for this work. (As long as you are in the same room when I'm 273 | drinking them ;)

274 |

275 |

276 |
277 |

AUTHORS

278 |

Ingy döt Net <ingy@cpan.org>

279 |

(Note: I had to list myself first so that this line would go into META.yml)

280 |

Jemplate is truly a community authored project:

281 |

Ingy döt Net <ingy@cpan.org>

282 |

Tatsuhiko Miyagawa <miyagawa@bulknews.net>

283 |

Yann Kerherve <yannk@cpan.org>

284 |

David Davis <xantus@xantus.org>

285 |

Cory Bennett <coryb@corybennett.org>

286 |

Cees Hek <ceeshek@gmail.com>

287 |

Christian Hansen

288 |

David A. Coffey <dacoffey@cogsmith.com>

289 |

Robert Krimen <robertkrimen@gmail.com>

290 |

291 |

292 |
293 |

COPYRIGHT

294 |

Copyright (c) 2006-2014. Ingy döt Net.

295 |

This program is free software; you can redistribute it and/or modify it 296 | under the same terms as Perl itself.

297 |

See http://www.perl.com/perl/misc/Artistic.html

298 | 299 | 300 | 301 | 302 | -------------------------------------------------------------------------------- /doc/text/Jemplate.text: -------------------------------------------------------------------------------- 1 | NAME 2 | Jemplate - JavaScript Templating with Template Toolkit 3 | 4 | SYNOPSIS 5 | var data = Ajax.get('url/data.json'); 6 | var elem = document.getElementById('some-div'); 7 | elem.innerHTML = Jemplate.process('my-template.html', data); 8 | 9 | or: 10 | 11 | var data = Ajax.get('url/data.json'); 12 | var elem = document.getElementById('some-div'); 13 | Jemplate.process('my-template.html', data, elem); 14 | 15 | or simply: 16 | 17 | Jemplate.process('my-template.html', 'url/data.json', '#some-div'); 18 | 19 | or, with jQuery.js: 20 | 21 | jQuery.getJSON("url/data.json", function(data) { 22 | Jemplate.process('my-template.html', data, '#some-div'); 23 | }); 24 | 25 | DESCRIPTION 26 | Jemplate is a templating framework for JavaScript that is built over 27 | Perl's Template Toolkit (TT2). 28 | 29 | Jemplate parses TT2 templates using the TT2 Perl framework, but with a 30 | twist. Instead of compiling the templates into Perl code, it compiles 31 | them into JavaScript. 32 | 33 | Jemplate then provides a JavaScript runtime module for processing the 34 | template code. Presto, we have full featured JavaScript templating 35 | language! 36 | 37 | Combined with JSON and xmlHttpRequest, Jemplate provides a really simple 38 | and powerful way to do Ajax stuff. 39 | 40 | HOWTO 41 | Jemplate comes with a command line tool call "jemplate" that you use to 42 | precompile your templates into a JavaScript file. For example if you 43 | have a template directory called "templates" that contains: 44 | 45 | > ls templates/ 46 | body.html 47 | footer.html 48 | header.html 49 | 50 | You might run this command: 51 | 52 | > jemplate --compile template/* > js/jemplates.js 53 | 54 | This will compile all the templates into one JavaScript file. 55 | 56 | You also need to generate the Jemplate runtime. 57 | 58 | > jemplate --runtime > js/Jemplate.js 59 | 60 | Now all you need to do is include these two files in your HTML: 61 | 62 | 63 | 64 | 65 | Now you have Jemplate support for these templates in your HTML document. 66 | 67 | PUBLIC API 68 | The Jemplate.js JavaScript runtime module has the following API method: 69 | 70 | Jemplate.process(template-name, data, target); 71 | The "template-name" is a string like 'body.html' that is the name of 72 | the top level template that you wish to process. 73 | 74 | The optional "data" specifies the data object to be used by the 75 | templates. It can be an object, a function or a url. If it is an 76 | object, it is used directly. If it is a function, the function is 77 | called and the returned object is used. If it is a url, an 78 | asynchronous is performed. The result is expected to be a 79 | JSON string, which gets turned into an object. 80 | 81 | The optional "target" can be an HTMLElement reference, a function or 82 | a string beginning with a "#" char. If the target is omitted, the 83 | template result is returned. If it is a function, the function is 84 | called with the result. If it is a string, the string is used as an 85 | id to find an HTMLElement. 86 | 87 | If an HTMLElement is used (by id or directly) then the innerHTML 88 | property is set to the template processing result. 89 | 90 | The Jemplate.pm Perl module has the following public class methods, 91 | although you won't likely need to use them directly. Normally, you just 92 | use the "jemplate" command line tool. 93 | 94 | Jemplate->compile_template_files(@template_file_paths); 95 | Take a list of template file paths and compile them into a module of 96 | functions. Returns the text of the module. 97 | 98 | Jemplate->compile_template_content($content, $template_name); 99 | Compile one template whose content is in memory. You must provide a 100 | unique template name. Returns the JavaScript text result of the 101 | compilation. 102 | 103 | Jemplate->compile_module($module_path, \@template_file_paths); 104 | Similar to `compile_template_files`, but prints to result to the 105 | $module_path. Returns 1 if successful, undef if error. 106 | 107 | Jemplate->compile_module_cached($module_path, \@template_file_paths); 108 | Similar to `compile_module`, but only compiles if one of the 109 | templates is newer than the module. Returns 1 if successful compile, 110 | 0 if no compile due to cache, undef if error. 111 | 112 | AJAX AND JSON METHODS 113 | Jemplate comes with builtin Ajax and JSON support. 114 | 115 | Ajax.get(url, [callback]); 116 | Does a GET operation to the url. 117 | 118 | If a callback is provided, the operation is asynchronous, and the 119 | data is passed to the callback. Otherwise, the operation is 120 | synchronous and the data is returned. 121 | 122 | Ajax.post(url, data, [callback]); 123 | Does a POST operation to the url. 124 | 125 | Same callback rules as "get" apply. 126 | 127 | JSON.stringify(object); 128 | Return the JSON serialization of an object. 129 | 130 | JSON.parse(jsonString); 131 | Turns a JSON string into an object and returns the object. 132 | 133 | CURRENT SUPPORT 134 | The goal of Jemplate is to support all of the Template Toolkit features 135 | that can possibly be supported. 136 | 137 | Jemplate now supports almost all the TT directives, including: 138 | 139 | * Plain text 140 | * [% [GET] variable %] 141 | * [% CALL variable %] 142 | * [% [SET] variable = value %] 143 | * [% DEFAULT variable = value ... %] 144 | * [% INCLUDE [arguments] %] 145 | * [% PROCESS [arguments] %] 146 | * [% BLOCK name %] 147 | * [% FILTER filter %] text... [% END %] 148 | * [% JAVASCRIPT %] code... [% END %] 149 | * [% WRAPPER template [variable = value ...] %] 150 | * [% IF condition %] 151 | * [% ELSIF condition %] 152 | * [% ELSE %] 153 | * [% SWITCH variable %] 154 | * [% CASE [{value|DEFAULT}] %] 155 | * [% FOR x = y %] 156 | * [% WHILE expression %] 157 | * [% RETURN %] 158 | * [% THROW type message %] 159 | * [% STOP %] 160 | * [% NEXT %] 161 | * [% LAST %] 162 | * [% CLEAR %] 163 | * [%# this is a comment %] 164 | 165 | ALL of the string virtual functions are supported. 166 | 167 | ALL of the array virtual functions are supported: 168 | 169 | ALL of the hash virtual functions are supported (except for import): 170 | 171 | MANY of the standard filters are implemented. 172 | 173 | The remaining features will be added very soon. See the DESIGN document 174 | in the distro for a list of all features and their progress. 175 | 176 | BROWSER SUPPORT 177 | Tested successfully in: 178 | 179 | * Firefox Mac/Win32/Linux 180 | * IE 6.0 181 | * Safari 182 | * Opera 183 | * Konqueror 184 | 185 | All tests run 100% successful in the above browsers. 186 | 187 | DEVELOPMENT 188 | The bleeding edge code is available via Subversion at 189 | http://svn.jemplate.net/repo/trunk/ 190 | 191 | You can run the runtime tests directly from 192 | http://svn.jemplate.net/repo/trunk/tests/run/index.html or from the 193 | corresponding CPAN or JSAN directories. 194 | 195 | Jemplate development is being discussed at 196 | irc://irc.freenode.net/#jemplate 197 | 198 | If you want a committer bit, just ask ingy on the irc channel. 199 | 200 | CREDIT 201 | This module is only possible because of Andy Wardley's mighty Template 202 | Toolkit. Thanks Andy. I will gladly give you half of any beers I receive 203 | for this work. (As long as you are in the same room when I'm drinking 204 | them ;) 205 | 206 | AUTHORS 207 | Ingy döt Net 208 | 209 | (Note: I had to list myself first so that this line would go into 210 | META.yml) 211 | 212 | Jemplate is truly a community authored project: 213 | 214 | Ingy döt Net 215 | 216 | Tatsuhiko Miyagawa 217 | 218 | Yann Kerherve 219 | 220 | David Davis 221 | 222 | Cory Bennett 223 | 224 | Cees Hek 225 | 226 | Christian Hansen 227 | 228 | David A. Coffey 229 | 230 | Robert Krimen 231 | 232 | COPYRIGHT 233 | Copyright (c) 2006-2008. Ingy döt Net. 234 | 235 | This program is free software; you can redistribute it and/or modify it 236 | under the same terms as Perl itself. 237 | 238 | See 239 | 240 | -------------------------------------------------------------------------------- /inc/Module/Install.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install; 3 | 4 | # For any maintainers: 5 | # The load order for Module::Install is a bit magic. 6 | # It goes something like this... 7 | # 8 | # IF ( host has Module::Install installed, creating author mode ) { 9 | # 1. Makefile.PL calls "use inc::Module::Install" 10 | # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install 11 | # 3. The installed version of inc::Module::Install loads 12 | # 4. inc::Module::Install calls "require Module::Install" 13 | # 5. The ./inc/ version of Module::Install loads 14 | # } ELSE { 15 | # 1. Makefile.PL calls "use inc::Module::Install" 16 | # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install 17 | # 3. The ./inc/ version of Module::Install loads 18 | # } 19 | 20 | use 5.006; 21 | use strict 'vars'; 22 | use Cwd (); 23 | use File::Find (); 24 | use File::Path (); 25 | 26 | use vars qw{$VERSION $MAIN}; 27 | BEGIN { 28 | # All Module::Install core packages now require synchronised versions. 29 | # This will be used to ensure we don't accidentally load old or 30 | # different versions of modules. 31 | # This is not enforced yet, but will be some time in the next few 32 | # releases once we can make sure it won't clash with custom 33 | # Module::Install extensions. 34 | $VERSION = '1.18'; 35 | 36 | # Storage for the pseudo-singleton 37 | $MAIN = undef; 38 | 39 | *inc::Module::Install::VERSION = *VERSION; 40 | @inc::Module::Install::ISA = __PACKAGE__; 41 | 42 | } 43 | 44 | sub import { 45 | my $class = shift; 46 | my $self = $class->new(@_); 47 | my $who = $self->_caller; 48 | 49 | #------------------------------------------------------------- 50 | # all of the following checks should be included in import(), 51 | # to allow "eval 'require Module::Install; 1' to test 52 | # installation of Module::Install. (RT #51267) 53 | #------------------------------------------------------------- 54 | 55 | # Whether or not inc::Module::Install is actually loaded, the 56 | # $INC{inc/Module/Install.pm} is what will still get set as long as 57 | # the caller loaded module this in the documented manner. 58 | # If not set, the caller may NOT have loaded the bundled version, and thus 59 | # they may not have a MI version that works with the Makefile.PL. This would 60 | # result in false errors or unexpected behaviour. And we don't want that. 61 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; 62 | unless ( $INC{$file} ) { die <<"END_DIE" } 63 | 64 | Please invoke ${\__PACKAGE__} with: 65 | 66 | use inc::${\__PACKAGE__}; 67 | 68 | not: 69 | 70 | use ${\__PACKAGE__}; 71 | 72 | END_DIE 73 | 74 | # This reportedly fixes a rare Win32 UTC file time issue, but 75 | # as this is a non-cross-platform XS module not in the core, 76 | # we shouldn't really depend on it. See RT #24194 for detail. 77 | # (Also, this module only supports Perl 5.6 and above). 78 | eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; 79 | 80 | # If the script that is loading Module::Install is from the future, 81 | # then make will detect this and cause it to re-run over and over 82 | # again. This is bad. Rather than taking action to touch it (which 83 | # is unreliable on some platforms and requires write permissions) 84 | # for now we should catch this and refuse to run. 85 | if ( -f $0 ) { 86 | my $s = (stat($0))[9]; 87 | 88 | # If the modification time is only slightly in the future, 89 | # sleep briefly to remove the problem. 90 | my $a = $s - time; 91 | if ( $a > 0 and $a < 5 ) { sleep 5 } 92 | 93 | # Too far in the future, throw an error. 94 | my $t = time; 95 | if ( $s > $t ) { die <<"END_DIE" } 96 | 97 | Your installer $0 has a modification time in the future ($s > $t). 98 | 99 | This is known to create infinite loops in make. 100 | 101 | Please correct this, then run $0 again. 102 | 103 | END_DIE 104 | } 105 | 106 | 107 | # Build.PL was formerly supported, but no longer is due to excessive 108 | # difficulty in implementing every single feature twice. 109 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } 110 | 111 | Module::Install no longer supports Build.PL. 112 | 113 | It was impossible to maintain duel backends, and has been deprecated. 114 | 115 | Please remove all Build.PL files and only use the Makefile.PL installer. 116 | 117 | END_DIE 118 | 119 | #------------------------------------------------------------- 120 | 121 | # To save some more typing in Module::Install installers, every... 122 | # use inc::Module::Install 123 | # ...also acts as an implicit use strict. 124 | $^H |= strict::bits(qw(refs subs vars)); 125 | 126 | #------------------------------------------------------------- 127 | 128 | unless ( -f $self->{file} ) { 129 | foreach my $key (keys %INC) { 130 | delete $INC{$key} if $key =~ /Module\/Install/; 131 | } 132 | 133 | local $^W; 134 | require "$self->{path}/$self->{dispatch}.pm"; 135 | File::Path::mkpath("$self->{prefix}/$self->{author}"); 136 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); 137 | $self->{admin}->init; 138 | @_ = ($class, _self => $self); 139 | goto &{"$self->{name}::import"}; 140 | } 141 | 142 | local $^W; 143 | *{"${who}::AUTOLOAD"} = $self->autoload; 144 | $self->preload; 145 | 146 | # Unregister loader and worker packages so subdirs can use them again 147 | delete $INC{'inc/Module/Install.pm'}; 148 | delete $INC{'Module/Install.pm'}; 149 | 150 | # Save to the singleton 151 | $MAIN = $self; 152 | 153 | return 1; 154 | } 155 | 156 | sub autoload { 157 | my $self = shift; 158 | my $who = $self->_caller; 159 | my $cwd = Cwd::getcwd(); 160 | my $sym = "${who}::AUTOLOAD"; 161 | $sym->{$cwd} = sub { 162 | my $pwd = Cwd::getcwd(); 163 | if ( my $code = $sym->{$pwd} ) { 164 | # Delegate back to parent dirs 165 | goto &$code unless $cwd eq $pwd; 166 | } 167 | unless ($$sym =~ s/([^:]+)$//) { 168 | # XXX: it looks like we can't retrieve the missing function 169 | # via $$sym (usually $main::AUTOLOAD) in this case. 170 | # I'm still wondering if we should slurp Makefile.PL to 171 | # get some context or not ... 172 | my ($package, $file, $line) = caller; 173 | die <<"EOT"; 174 | Unknown function is found at $file line $line. 175 | Execution of $file aborted due to runtime errors. 176 | 177 | If you're a contributor to a project, you may need to install 178 | some Module::Install extensions from CPAN (or other repository). 179 | If you're a user of a module, please contact the author. 180 | EOT 181 | } 182 | my $method = $1; 183 | if ( uc($method) eq $method ) { 184 | # Do nothing 185 | return; 186 | } elsif ( $method =~ /^_/ and $self->can($method) ) { 187 | # Dispatch to the root M:I class 188 | return $self->$method(@_); 189 | } 190 | 191 | # Dispatch to the appropriate plugin 192 | unshift @_, ( $self, $1 ); 193 | goto &{$self->can('call')}; 194 | }; 195 | } 196 | 197 | sub preload { 198 | my $self = shift; 199 | unless ( $self->{extensions} ) { 200 | $self->load_extensions( 201 | "$self->{prefix}/$self->{path}", $self 202 | ); 203 | } 204 | 205 | my @exts = @{$self->{extensions}}; 206 | unless ( @exts ) { 207 | @exts = $self->{admin}->load_all_extensions; 208 | } 209 | 210 | my %seen; 211 | foreach my $obj ( @exts ) { 212 | while (my ($method, $glob) = each %{ref($obj) . '::'}) { 213 | next unless $obj->can($method); 214 | next if $method =~ /^_/; 215 | next if $method eq uc($method); 216 | $seen{$method}++; 217 | } 218 | } 219 | 220 | my $who = $self->_caller; 221 | foreach my $name ( sort keys %seen ) { 222 | local $^W; 223 | *{"${who}::$name"} = sub { 224 | ${"${who}::AUTOLOAD"} = "${who}::$name"; 225 | goto &{"${who}::AUTOLOAD"}; 226 | }; 227 | } 228 | } 229 | 230 | sub new { 231 | my ($class, %args) = @_; 232 | 233 | delete $INC{'FindBin.pm'}; 234 | { 235 | # to suppress the redefine warning 236 | local $SIG{__WARN__} = sub {}; 237 | require FindBin; 238 | } 239 | 240 | # ignore the prefix on extension modules built from top level. 241 | my $base_path = Cwd::abs_path($FindBin::Bin); 242 | unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { 243 | delete $args{prefix}; 244 | } 245 | return $args{_self} if $args{_self}; 246 | 247 | $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; 248 | 249 | $args{dispatch} ||= 'Admin'; 250 | $args{prefix} ||= 'inc'; 251 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 252 | $args{bundle} ||= 'inc/BUNDLES'; 253 | $args{base} ||= $base_path; 254 | $class =~ s/^\Q$args{prefix}\E:://; 255 | $args{name} ||= $class; 256 | $args{version} ||= $class->VERSION; 257 | unless ( $args{path} ) { 258 | $args{path} = $args{name}; 259 | $args{path} =~ s!::!/!g; 260 | } 261 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 262 | $args{wrote} = 0; 263 | 264 | bless( \%args, $class ); 265 | } 266 | 267 | sub call { 268 | my ($self, $method) = @_; 269 | my $obj = $self->load($method) or return; 270 | splice(@_, 0, 2, $obj); 271 | goto &{$obj->can($method)}; 272 | } 273 | 274 | sub load { 275 | my ($self, $method) = @_; 276 | 277 | $self->load_extensions( 278 | "$self->{prefix}/$self->{path}", $self 279 | ) unless $self->{extensions}; 280 | 281 | foreach my $obj (@{$self->{extensions}}) { 282 | return $obj if $obj->can($method); 283 | } 284 | 285 | my $admin = $self->{admin} or die <<"END_DIE"; 286 | The '$method' method does not exist in the '$self->{prefix}' path! 287 | Please remove the '$self->{prefix}' directory and run $0 again to load it. 288 | END_DIE 289 | 290 | my $obj = $admin->load($method, 1); 291 | push @{$self->{extensions}}, $obj; 292 | 293 | $obj; 294 | } 295 | 296 | sub load_extensions { 297 | my ($self, $path, $top) = @_; 298 | 299 | my $should_reload = 0; 300 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { 301 | unshift @INC, $self->{prefix}; 302 | $should_reload = 1; 303 | } 304 | 305 | foreach my $rv ( $self->find_extensions($path) ) { 306 | my ($file, $pkg) = @{$rv}; 307 | next if $self->{pathnames}{$pkg}; 308 | 309 | local $@; 310 | my $new = eval { local $^W; require $file; $pkg->can('new') }; 311 | unless ( $new ) { 312 | warn $@ if $@; 313 | next; 314 | } 315 | $self->{pathnames}{$pkg} = 316 | $should_reload ? delete $INC{$file} : $INC{$file}; 317 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 318 | } 319 | 320 | $self->{extensions} ||= []; 321 | } 322 | 323 | sub find_extensions { 324 | my ($self, $path) = @_; 325 | 326 | my @found; 327 | File::Find::find( {no_chdir => 1, wanted => sub { 328 | my $file = $File::Find::name; 329 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 330 | my $subpath = $1; 331 | return if lc($subpath) eq lc($self->{dispatch}); 332 | 333 | $file = "$self->{path}/$subpath.pm"; 334 | my $pkg = "$self->{name}::$subpath"; 335 | $pkg =~ s!/!::!g; 336 | 337 | # If we have a mixed-case package name, assume case has been preserved 338 | # correctly. Otherwise, root through the file to locate the case-preserved 339 | # version of the package name. 340 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 341 | my $content = Module::Install::_read($File::Find::name); 342 | my $in_pod = 0; 343 | foreach ( split /\n/, $content ) { 344 | $in_pod = 1 if /^=\w/; 345 | $in_pod = 0 if /^=cut/; 346 | next if ($in_pod || /^=cut/); # skip pod text 347 | next if /^\s*#/; # and comments 348 | if ( m/^\s*package\s+($pkg)\s*;/i ) { 349 | $pkg = $1; 350 | last; 351 | } 352 | } 353 | } 354 | 355 | push @found, [ $file, $pkg ]; 356 | }}, $path ) if -d $path; 357 | 358 | @found; 359 | } 360 | 361 | 362 | 363 | 364 | 365 | ##################################################################### 366 | # Common Utility Functions 367 | 368 | sub _caller { 369 | my $depth = 0; 370 | my $call = caller($depth); 371 | while ( $call eq __PACKAGE__ ) { 372 | $depth++; 373 | $call = caller($depth); 374 | } 375 | return $call; 376 | } 377 | 378 | sub _read { 379 | local *FH; 380 | open( FH, '<', $_[0] ) or die "open($_[0]): $!"; 381 | binmode FH; 382 | my $string = do { local $/; }; 383 | close FH or die "close($_[0]): $!"; 384 | return $string; 385 | } 386 | 387 | sub _readperl { 388 | my $string = Module::Install::_read($_[0]); 389 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 390 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; 391 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; 392 | return $string; 393 | } 394 | 395 | sub _readpod { 396 | my $string = Module::Install::_read($_[0]); 397 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 398 | return $string if $_[0] =~ /\.pod\z/; 399 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; 400 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; 401 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; 402 | $string =~ s/^\n+//s; 403 | return $string; 404 | } 405 | 406 | sub _write { 407 | local *FH; 408 | open( FH, '>', $_[0] ) or die "open($_[0]): $!"; 409 | binmode FH; 410 | foreach ( 1 .. $#_ ) { 411 | print FH $_[$_] or die "print($_[0]): $!"; 412 | } 413 | close FH or die "close($_[0]): $!"; 414 | } 415 | 416 | # _version is for processing module versions (eg, 1.03_05) not 417 | # Perl versions (eg, 5.8.1). 418 | sub _version { 419 | my $s = shift || 0; 420 | my $d =()= $s =~ /(\.)/g; 421 | if ( $d >= 2 ) { 422 | # Normalise multipart versions 423 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; 424 | } 425 | $s =~ s/^(\d+)\.?//; 426 | my $l = $1 || 0; 427 | my @v = map { 428 | $_ . '0' x (3 - length $_) 429 | } $s =~ /(\d{1,3})\D?/g; 430 | $l = $l . '.' . join '', @v if @v; 431 | return $l + 0; 432 | } 433 | 434 | sub _cmp { 435 | _version($_[1]) <=> _version($_[2]); 436 | } 437 | 438 | # Cloned from Params::Util::_CLASS 439 | sub _CLASS { 440 | ( 441 | defined $_[0] 442 | and 443 | ! ref $_[0] 444 | and 445 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s 446 | ) ? $_[0] : undef; 447 | } 448 | 449 | 1; 450 | 451 | # Copyright 2008 - 2012 Adam Kennedy. 452 | -------------------------------------------------------------------------------- /inc/Module/Install/AutoInstall.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::AutoInstall; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.18'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub AutoInstall { $_[0] } 15 | 16 | sub run { 17 | my $self = shift; 18 | $self->auto_install_now(@_); 19 | } 20 | 21 | sub write { 22 | my $self = shift; 23 | $self->auto_install(@_); 24 | } 25 | 26 | sub auto_install { 27 | my $self = shift; 28 | return if $self->{done}++; 29 | 30 | # Flatten array of arrays into a single array 31 | my @core = map @$_, map @$_, grep ref, 32 | $self->build_requires, $self->requires; 33 | 34 | my @config = @_; 35 | 36 | # We'll need Module::AutoInstall 37 | $self->include('Module::AutoInstall'); 38 | require Module::AutoInstall; 39 | 40 | my @features_require = Module::AutoInstall->import( 41 | (@config ? (-config => \@config) : ()), 42 | (@core ? (-core => \@core) : ()), 43 | $self->features, 44 | ); 45 | 46 | my %seen; 47 | my @requires = map @$_, map @$_, grep ref, $self->requires; 48 | while (my ($mod, $ver) = splice(@requires, 0, 2)) { 49 | $seen{$mod}{$ver}++; 50 | } 51 | my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; 52 | while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { 53 | $seen{$mod}{$ver}++; 54 | } 55 | my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; 56 | while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { 57 | $seen{$mod}{$ver}++; 58 | } 59 | 60 | my @deduped; 61 | while (my ($mod, $ver) = splice(@features_require, 0, 2)) { 62 | push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; 63 | } 64 | 65 | $self->requires(@deduped); 66 | 67 | $self->makemaker_args( Module::AutoInstall::_make_args() ); 68 | 69 | my $class = ref($self); 70 | $self->postamble( 71 | "# --- $class section:\n" . 72 | Module::AutoInstall::postamble() 73 | ); 74 | } 75 | 76 | sub installdeps_target { 77 | my ($self, @args) = @_; 78 | 79 | $self->include('Module::AutoInstall'); 80 | require Module::AutoInstall; 81 | 82 | Module::AutoInstall::_installdeps_target(1); 83 | 84 | $self->auto_install(@args); 85 | } 86 | 87 | sub auto_install_now { 88 | my $self = shift; 89 | $self->auto_install(@_); 90 | Module::AutoInstall::do_install(); 91 | } 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /inc/Module/Install/Base.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Base; 3 | 4 | use strict 'vars'; 5 | use vars qw{$VERSION}; 6 | BEGIN { 7 | $VERSION = '1.18'; 8 | } 9 | 10 | # Suspend handler for "redefined" warnings 11 | BEGIN { 12 | my $w = $SIG{__WARN__}; 13 | $SIG{__WARN__} = sub { $w }; 14 | } 15 | 16 | #line 42 17 | 18 | sub new { 19 | my $class = shift; 20 | unless ( defined &{"${class}::call"} ) { 21 | *{"${class}::call"} = sub { shift->_top->call(@_) }; 22 | } 23 | unless ( defined &{"${class}::load"} ) { 24 | *{"${class}::load"} = sub { shift->_top->load(@_) }; 25 | } 26 | bless { @_ }, $class; 27 | } 28 | 29 | #line 61 30 | 31 | sub AUTOLOAD { 32 | local $@; 33 | my $func = eval { shift->_top->autoload } or return; 34 | goto &$func; 35 | } 36 | 37 | #line 75 38 | 39 | sub _top { 40 | $_[0]->{_top}; 41 | } 42 | 43 | #line 90 44 | 45 | sub admin { 46 | $_[0]->_top->{admin} 47 | or 48 | Module::Install::Base::FakeAdmin->new; 49 | } 50 | 51 | #line 106 52 | 53 | sub is_admin { 54 | ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); 55 | } 56 | 57 | sub DESTROY {} 58 | 59 | package Module::Install::Base::FakeAdmin; 60 | 61 | use vars qw{$VERSION}; 62 | BEGIN { 63 | $VERSION = $Module::Install::Base::VERSION; 64 | } 65 | 66 | my $fake; 67 | 68 | sub new { 69 | $fake ||= bless(\@_, $_[0]); 70 | } 71 | 72 | sub AUTOLOAD {} 73 | 74 | sub DESTROY {} 75 | 76 | # Restore warning handler 77 | BEGIN { 78 | $SIG{__WARN__} = $SIG{__WARN__}->(); 79 | } 80 | 81 | 1; 82 | 83 | #line 159 84 | -------------------------------------------------------------------------------- /inc/Module/Install/Can.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Can; 3 | 4 | use strict; 5 | use Config (); 6 | use ExtUtils::MakeMaker (); 7 | use Module::Install::Base (); 8 | 9 | use vars qw{$VERSION @ISA $ISCORE}; 10 | BEGIN { 11 | $VERSION = '1.18'; 12 | @ISA = 'Module::Install::Base'; 13 | $ISCORE = 1; 14 | } 15 | 16 | # check if we can load some module 17 | ### Upgrade this to not have to load the module if possible 18 | sub can_use { 19 | my ($self, $mod, $ver) = @_; 20 | $mod =~ s{::|\\}{/}g; 21 | $mod .= '.pm' unless $mod =~ /\.pm$/i; 22 | 23 | my $pkg = $mod; 24 | $pkg =~ s{/}{::}g; 25 | $pkg =~ s{\.pm$}{}i; 26 | 27 | local $@; 28 | eval { require $mod; $pkg->VERSION($ver || 0); 1 }; 29 | } 30 | 31 | # Check if we can run some command 32 | sub can_run { 33 | my ($self, $cmd) = @_; 34 | 35 | my $_cmd = $cmd; 36 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); 37 | 38 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { 39 | next if $dir eq ''; 40 | require File::Spec; 41 | my $abs = File::Spec->catfile($dir, $cmd); 42 | return $abs if (-x $abs or $abs = MM->maybe_command($abs)); 43 | } 44 | 45 | return; 46 | } 47 | 48 | # Can our C compiler environment build XS files 49 | sub can_xs { 50 | my $self = shift; 51 | 52 | # Ensure we have the CBuilder module 53 | $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); 54 | 55 | # Do we have the configure_requires checker? 56 | local $@; 57 | eval "require ExtUtils::CBuilder;"; 58 | if ( $@ ) { 59 | # They don't obey configure_requires, so it is 60 | # someone old and delicate. Try to avoid hurting 61 | # them by falling back to an older simpler test. 62 | return $self->can_cc(); 63 | } 64 | 65 | # Do we have a working C compiler 66 | my $builder = ExtUtils::CBuilder->new( 67 | quiet => 1, 68 | ); 69 | unless ( $builder->have_compiler ) { 70 | # No working C compiler 71 | return 0; 72 | } 73 | 74 | # Write a C file representative of what XS becomes 75 | require File::Temp; 76 | my ( $FH, $tmpfile ) = File::Temp::tempfile( 77 | "compilexs-XXXXX", 78 | SUFFIX => '.c', 79 | ); 80 | binmode $FH; 81 | print $FH <<'END_C'; 82 | #include "EXTERN.h" 83 | #include "perl.h" 84 | #include "XSUB.h" 85 | 86 | int main(int argc, char **argv) { 87 | return 0; 88 | } 89 | 90 | int boot_sanexs() { 91 | return 1; 92 | } 93 | 94 | END_C 95 | close $FH; 96 | 97 | # Can the C compiler access the same headers XS does 98 | my @libs = (); 99 | my $object = undef; 100 | eval { 101 | local $^W = 0; 102 | $object = $builder->compile( 103 | source => $tmpfile, 104 | ); 105 | @libs = $builder->link( 106 | objects => $object, 107 | module_name => 'sanexs', 108 | ); 109 | }; 110 | my $result = $@ ? 0 : 1; 111 | 112 | # Clean up all the build files 113 | foreach ( $tmpfile, $object, @libs ) { 114 | next unless defined $_; 115 | 1 while unlink; 116 | } 117 | 118 | return $result; 119 | } 120 | 121 | # Can we locate a (the) C compiler 122 | sub can_cc { 123 | my $self = shift; 124 | 125 | if ($^O eq 'VMS') { 126 | require ExtUtils::CBuilder; 127 | my $builder = ExtUtils::CBuilder->new( 128 | quiet => 1, 129 | ); 130 | return $builder->have_compiler; 131 | } 132 | 133 | my @chunks = split(/ /, $Config::Config{cc}) or return; 134 | 135 | # $Config{cc} may contain args; try to find out the program part 136 | while (@chunks) { 137 | return $self->can_run("@chunks") || (pop(@chunks), next); 138 | } 139 | 140 | return; 141 | } 142 | 143 | # Fix Cygwin bug on maybe_command(); 144 | if ( $^O eq 'cygwin' ) { 145 | require ExtUtils::MM_Cygwin; 146 | require ExtUtils::MM_Win32; 147 | if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { 148 | *ExtUtils::MM_Cygwin::maybe_command = sub { 149 | my ($self, $file) = @_; 150 | if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { 151 | ExtUtils::MM_Win32->maybe_command($file); 152 | } else { 153 | ExtUtils::MM_Unix->maybe_command($file); 154 | } 155 | } 156 | } 157 | } 158 | 159 | 1; 160 | 161 | __END__ 162 | 163 | #line 245 164 | -------------------------------------------------------------------------------- /inc/Module/Install/Fetch.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Fetch; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.18'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub get_file { 15 | my ($self, %args) = @_; 16 | my ($scheme, $host, $path, $file) = 17 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; 18 | 19 | if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { 20 | $args{url} = $args{ftp_url} 21 | or (warn("LWP support unavailable!\n"), return); 22 | ($scheme, $host, $path, $file) = 23 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; 24 | } 25 | 26 | $|++; 27 | print "Fetching '$file' from $host... "; 28 | 29 | unless (eval { require Socket; Socket::inet_aton($host) }) { 30 | warn "'$host' resolve failed!\n"; 31 | return; 32 | } 33 | 34 | return unless $scheme eq 'ftp' or $scheme eq 'http'; 35 | 36 | require Cwd; 37 | my $dir = Cwd::getcwd(); 38 | chdir $args{local_dir} or return if exists $args{local_dir}; 39 | 40 | if (eval { require LWP::Simple; 1 }) { 41 | LWP::Simple::mirror($args{url}, $file); 42 | } 43 | elsif (eval { require Net::FTP; 1 }) { eval { 44 | # use Net::FTP to get past firewall 45 | my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); 46 | $ftp->login("anonymous", 'anonymous@example.com'); 47 | $ftp->cwd($path); 48 | $ftp->binary; 49 | $ftp->get($file) or (warn("$!\n"), return); 50 | $ftp->quit; 51 | } } 52 | elsif (my $ftp = $self->can_run('ftp')) { eval { 53 | # no Net::FTP, fallback to ftp.exe 54 | require FileHandle; 55 | my $fh = FileHandle->new; 56 | 57 | local $SIG{CHLD} = 'IGNORE'; 58 | unless ($fh->open("|$ftp -n")) { 59 | warn "Couldn't open ftp: $!\n"; 60 | chdir $dir; return; 61 | } 62 | 63 | my @dialog = split(/\n/, <<"END_FTP"); 64 | open $host 65 | user anonymous anonymous\@example.com 66 | cd $path 67 | binary 68 | get $file $file 69 | quit 70 | END_FTP 71 | foreach (@dialog) { $fh->print("$_\n") } 72 | $fh->close; 73 | } } 74 | else { 75 | warn "No working 'ftp' program available!\n"; 76 | chdir $dir; return; 77 | } 78 | 79 | unless (-f $file) { 80 | warn "Fetching failed: $@\n"; 81 | chdir $dir; return; 82 | } 83 | 84 | return if exists $args{size} and -s $file != $args{size}; 85 | system($args{run}) if exists $args{run}; 86 | unlink($file) if $args{remove}; 87 | 88 | print(((!exists $args{check_for} or -e $args{check_for}) 89 | ? "done!" : "failed! ($!)"), "\n"); 90 | chdir $dir; return !$?; 91 | } 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /inc/Module/Install/Include.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Include; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.18'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub include { 15 | shift()->admin->include(@_); 16 | } 17 | 18 | sub include_deps { 19 | shift()->admin->include_deps(@_); 20 | } 21 | 22 | sub auto_include { 23 | shift()->admin->auto_include(@_); 24 | } 25 | 26 | sub auto_include_deps { 27 | shift()->admin->auto_include_deps(@_); 28 | } 29 | 30 | sub auto_include_dependent_dists { 31 | shift()->admin->auto_include_dependent_dists(@_); 32 | } 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /inc/Module/Install/Makefile.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Makefile; 3 | 4 | use strict 'vars'; 5 | use ExtUtils::MakeMaker (); 6 | use Module::Install::Base (); 7 | use Fcntl qw/:flock :seek/; 8 | 9 | use vars qw{$VERSION @ISA $ISCORE}; 10 | BEGIN { 11 | $VERSION = '1.18'; 12 | @ISA = 'Module::Install::Base'; 13 | $ISCORE = 1; 14 | } 15 | 16 | sub Makefile { $_[0] } 17 | 18 | my %seen = (); 19 | 20 | sub prompt { 21 | shift; 22 | 23 | # Infinite loop protection 24 | my @c = caller(); 25 | if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { 26 | die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; 27 | } 28 | 29 | # In automated testing or non-interactive session, always use defaults 30 | if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { 31 | local $ENV{PERL_MM_USE_DEFAULT} = 1; 32 | goto &ExtUtils::MakeMaker::prompt; 33 | } else { 34 | goto &ExtUtils::MakeMaker::prompt; 35 | } 36 | } 37 | 38 | # Store a cleaned up version of the MakeMaker version, 39 | # since we need to behave differently in a variety of 40 | # ways based on the MM version. 41 | my $makemaker = eval $ExtUtils::MakeMaker::VERSION; 42 | 43 | # If we are passed a param, do a "newer than" comparison. 44 | # Otherwise, just return the MakeMaker version. 45 | sub makemaker { 46 | ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 47 | } 48 | 49 | # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified 50 | # as we only need to know here whether the attribute is an array 51 | # or a hash or something else (which may or may not be appendable). 52 | my %makemaker_argtype = ( 53 | C => 'ARRAY', 54 | CONFIG => 'ARRAY', 55 | # CONFIGURE => 'CODE', # ignore 56 | DIR => 'ARRAY', 57 | DL_FUNCS => 'HASH', 58 | DL_VARS => 'ARRAY', 59 | EXCLUDE_EXT => 'ARRAY', 60 | EXE_FILES => 'ARRAY', 61 | FUNCLIST => 'ARRAY', 62 | H => 'ARRAY', 63 | IMPORTS => 'HASH', 64 | INCLUDE_EXT => 'ARRAY', 65 | LIBS => 'ARRAY', # ignore '' 66 | MAN1PODS => 'HASH', 67 | MAN3PODS => 'HASH', 68 | META_ADD => 'HASH', 69 | META_MERGE => 'HASH', 70 | PL_FILES => 'HASH', 71 | PM => 'HASH', 72 | PMLIBDIRS => 'ARRAY', 73 | PMLIBPARENTDIRS => 'ARRAY', 74 | PREREQ_PM => 'HASH', 75 | CONFIGURE_REQUIRES => 'HASH', 76 | SKIP => 'ARRAY', 77 | TYPEMAPS => 'ARRAY', 78 | XS => 'HASH', 79 | # VERSION => ['version',''], # ignore 80 | # _KEEP_AFTER_FLUSH => '', 81 | 82 | clean => 'HASH', 83 | depend => 'HASH', 84 | dist => 'HASH', 85 | dynamic_lib=> 'HASH', 86 | linkext => 'HASH', 87 | macro => 'HASH', 88 | postamble => 'HASH', 89 | realclean => 'HASH', 90 | test => 'HASH', 91 | tool_autosplit => 'HASH', 92 | 93 | # special cases where you can use makemaker_append 94 | CCFLAGS => 'APPENDABLE', 95 | DEFINE => 'APPENDABLE', 96 | INC => 'APPENDABLE', 97 | LDDLFLAGS => 'APPENDABLE', 98 | LDFROM => 'APPENDABLE', 99 | ); 100 | 101 | sub makemaker_args { 102 | my ($self, %new_args) = @_; 103 | my $args = ( $self->{makemaker_args} ||= {} ); 104 | foreach my $key (keys %new_args) { 105 | if ($makemaker_argtype{$key}) { 106 | if ($makemaker_argtype{$key} eq 'ARRAY') { 107 | $args->{$key} = [] unless defined $args->{$key}; 108 | unless (ref $args->{$key} eq 'ARRAY') { 109 | $args->{$key} = [$args->{$key}] 110 | } 111 | push @{$args->{$key}}, 112 | ref $new_args{$key} eq 'ARRAY' 113 | ? @{$new_args{$key}} 114 | : $new_args{$key}; 115 | } 116 | elsif ($makemaker_argtype{$key} eq 'HASH') { 117 | $args->{$key} = {} unless defined $args->{$key}; 118 | foreach my $skey (keys %{ $new_args{$key} }) { 119 | $args->{$key}{$skey} = $new_args{$key}{$skey}; 120 | } 121 | } 122 | elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { 123 | $self->makemaker_append($key => $new_args{$key}); 124 | } 125 | } 126 | else { 127 | if (defined $args->{$key}) { 128 | warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; 129 | } 130 | $args->{$key} = $new_args{$key}; 131 | } 132 | } 133 | return $args; 134 | } 135 | 136 | # For mm args that take multiple space-separated args, 137 | # append an argument to the current list. 138 | sub makemaker_append { 139 | my $self = shift; 140 | my $name = shift; 141 | my $args = $self->makemaker_args; 142 | $args->{$name} = defined $args->{$name} 143 | ? join( ' ', $args->{$name}, @_ ) 144 | : join( ' ', @_ ); 145 | } 146 | 147 | sub build_subdirs { 148 | my $self = shift; 149 | my $subdirs = $self->makemaker_args->{DIR} ||= []; 150 | for my $subdir (@_) { 151 | push @$subdirs, $subdir; 152 | } 153 | } 154 | 155 | sub clean_files { 156 | my $self = shift; 157 | my $clean = $self->makemaker_args->{clean} ||= {}; 158 | %$clean = ( 159 | %$clean, 160 | FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), 161 | ); 162 | } 163 | 164 | sub realclean_files { 165 | my $self = shift; 166 | my $realclean = $self->makemaker_args->{realclean} ||= {}; 167 | %$realclean = ( 168 | %$realclean, 169 | FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), 170 | ); 171 | } 172 | 173 | sub libs { 174 | my $self = shift; 175 | my $libs = ref $_[0] ? shift : [ shift ]; 176 | $self->makemaker_args( LIBS => $libs ); 177 | } 178 | 179 | sub inc { 180 | my $self = shift; 181 | $self->makemaker_args( INC => shift ); 182 | } 183 | 184 | sub _wanted_t { 185 | } 186 | 187 | sub tests_recursive { 188 | my $self = shift; 189 | my $dir = shift || 't'; 190 | unless ( -d $dir ) { 191 | die "tests_recursive dir '$dir' does not exist"; 192 | } 193 | my %tests = map { $_ => 1 } split / /, ($self->tests || ''); 194 | require File::Find; 195 | File::Find::find( 196 | sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, 197 | $dir 198 | ); 199 | $self->tests( join ' ', sort keys %tests ); 200 | } 201 | 202 | sub write { 203 | my $self = shift; 204 | die "&Makefile->write() takes no arguments\n" if @_; 205 | 206 | # Check the current Perl version 207 | my $perl_version = $self->perl_version; 208 | if ( $perl_version ) { 209 | eval "use $perl_version; 1" 210 | or die "ERROR: perl: Version $] is installed, " 211 | . "but we need version >= $perl_version"; 212 | } 213 | 214 | # Make sure we have a new enough MakeMaker 215 | require ExtUtils::MakeMaker; 216 | 217 | if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { 218 | # This previous attempted to inherit the version of 219 | # ExtUtils::MakeMaker in use by the module author, but this 220 | # was found to be untenable as some authors build releases 221 | # using future dev versions of EU:MM that nobody else has. 222 | # Instead, #toolchain suggests we use 6.59 which is the most 223 | # stable version on CPAN at time of writing and is, to quote 224 | # ribasushi, "not terminally fucked, > and tested enough". 225 | # TODO: We will now need to maintain this over time to push 226 | # the version up as new versions are released. 227 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); 228 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); 229 | } else { 230 | # Allow legacy-compatibility with 5.005 by depending on the 231 | # most recent EU:MM that supported 5.005. 232 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); 233 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); 234 | } 235 | 236 | # Generate the MakeMaker params 237 | my $args = $self->makemaker_args; 238 | $args->{DISTNAME} = $self->name; 239 | $args->{NAME} = $self->module_name || $self->name; 240 | $args->{NAME} =~ s/-/::/g; 241 | $args->{VERSION} = $self->version or die <<'EOT'; 242 | ERROR: Can't determine distribution version. Please specify it 243 | explicitly via 'version' in Makefile.PL, or set a valid $VERSION 244 | in a module, and provide its file path via 'version_from' (or 245 | 'all_from' if you prefer) in Makefile.PL. 246 | EOT 247 | 248 | if ( $self->tests ) { 249 | my @tests = split ' ', $self->tests; 250 | my %seen; 251 | $args->{test} = { 252 | TESTS => (join ' ', grep {!$seen{$_}++} @tests), 253 | }; 254 | } elsif ( $Module::Install::ExtraTests::use_extratests ) { 255 | # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. 256 | # So, just ignore our xt tests here. 257 | } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { 258 | $args->{test} = { 259 | TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), 260 | }; 261 | } 262 | if ( $] >= 5.005 ) { 263 | $args->{ABSTRACT} = $self->abstract; 264 | $args->{AUTHOR} = join ', ', @{$self->author || []}; 265 | } 266 | if ( $self->makemaker(6.10) ) { 267 | $args->{NO_META} = 1; 268 | #$args->{NO_MYMETA} = 1; 269 | } 270 | if ( $self->makemaker(6.17) and $self->sign ) { 271 | $args->{SIGN} = 1; 272 | } 273 | unless ( $self->is_admin ) { 274 | delete $args->{SIGN}; 275 | } 276 | if ( $self->makemaker(6.31) and $self->license ) { 277 | $args->{LICENSE} = $self->license; 278 | } 279 | 280 | my $prereq = ($args->{PREREQ_PM} ||= {}); 281 | %$prereq = ( %$prereq, 282 | map { @$_ } # flatten [module => version] 283 | map { @$_ } 284 | grep $_, 285 | ($self->requires) 286 | ); 287 | 288 | # Remove any reference to perl, PREREQ_PM doesn't support it 289 | delete $args->{PREREQ_PM}->{perl}; 290 | 291 | # Merge both kinds of requires into BUILD_REQUIRES 292 | my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); 293 | %$build_prereq = ( %$build_prereq, 294 | map { @$_ } # flatten [module => version] 295 | map { @$_ } 296 | grep $_, 297 | ($self->configure_requires, $self->build_requires) 298 | ); 299 | 300 | # Remove any reference to perl, BUILD_REQUIRES doesn't support it 301 | delete $args->{BUILD_REQUIRES}->{perl}; 302 | 303 | # Delete bundled dists from prereq_pm, add it to Makefile DIR 304 | my $subdirs = ($args->{DIR} || []); 305 | if ($self->bundles) { 306 | my %processed; 307 | foreach my $bundle (@{ $self->bundles }) { 308 | my ($mod_name, $dist_dir) = @$bundle; 309 | delete $prereq->{$mod_name}; 310 | $dist_dir = File::Basename::basename($dist_dir); # dir for building this module 311 | if (not exists $processed{$dist_dir}) { 312 | if (-d $dist_dir) { 313 | # List as sub-directory to be processed by make 314 | push @$subdirs, $dist_dir; 315 | } 316 | # Else do nothing: the module is already present on the system 317 | $processed{$dist_dir} = undef; 318 | } 319 | } 320 | } 321 | 322 | unless ( $self->makemaker('6.55_03') ) { 323 | %$prereq = (%$prereq,%$build_prereq); 324 | delete $args->{BUILD_REQUIRES}; 325 | } 326 | 327 | if ( my $perl_version = $self->perl_version ) { 328 | eval "use $perl_version; 1" 329 | or die "ERROR: perl: Version $] is installed, " 330 | . "but we need version >= $perl_version"; 331 | 332 | if ( $self->makemaker(6.48) ) { 333 | $args->{MIN_PERL_VERSION} = $perl_version; 334 | } 335 | } 336 | 337 | if ($self->installdirs) { 338 | warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; 339 | $args->{INSTALLDIRS} = $self->installdirs; 340 | } 341 | 342 | my %args = map { 343 | ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) 344 | } keys %$args; 345 | 346 | my $user_preop = delete $args{dist}->{PREOP}; 347 | if ( my $preop = $self->admin->preop($user_preop) ) { 348 | foreach my $key ( keys %$preop ) { 349 | $args{dist}->{$key} = $preop->{$key}; 350 | } 351 | } 352 | 353 | my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); 354 | $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); 355 | } 356 | 357 | sub fix_up_makefile { 358 | my $self = shift; 359 | my $makefile_name = shift; 360 | my $top_class = ref($self->_top) || ''; 361 | my $top_version = $self->_top->VERSION || ''; 362 | 363 | my $preamble = $self->preamble 364 | ? "# Preamble by $top_class $top_version\n" 365 | . $self->preamble 366 | : ''; 367 | my $postamble = "# Postamble by $top_class $top_version\n" 368 | . ($self->postamble || ''); 369 | 370 | local *MAKEFILE; 371 | open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 372 | eval { flock MAKEFILE, LOCK_EX }; 373 | my $makefile = do { local $/; }; 374 | 375 | $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; 376 | $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; 377 | $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; 378 | $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; 379 | $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; 380 | 381 | # Module::Install will never be used to build the Core Perl 382 | # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks 383 | # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist 384 | $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; 385 | #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; 386 | 387 | # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. 388 | $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; 389 | 390 | # XXX - This is currently unused; not sure if it breaks other MM-users 391 | # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; 392 | 393 | seek MAKEFILE, 0, SEEK_SET; 394 | truncate MAKEFILE, 0; 395 | print MAKEFILE "$preamble$makefile$postamble" or die $!; 396 | close MAKEFILE or die $!; 397 | 398 | 1; 399 | } 400 | 401 | sub preamble { 402 | my ($self, $text) = @_; 403 | $self->{preamble} = $text . $self->{preamble} if defined $text; 404 | $self->{preamble}; 405 | } 406 | 407 | sub postamble { 408 | my ($self, $text) = @_; 409 | $self->{postamble} ||= $self->admin->postamble; 410 | $self->{postamble} .= $text if defined $text; 411 | $self->{postamble} 412 | } 413 | 414 | 1; 415 | 416 | __END__ 417 | 418 | #line 544 419 | -------------------------------------------------------------------------------- /inc/Module/Install/Scripts.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Scripts; 3 | 4 | use strict 'vars'; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.18'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub install_script { 15 | my $self = shift; 16 | my $args = $self->makemaker_args; 17 | my $exe = $args->{EXE_FILES} ||= []; 18 | foreach ( @_ ) { 19 | if ( -f $_ ) { 20 | push @$exe, $_; 21 | } elsif ( -d 'script' and -f "script/$_" ) { 22 | push @$exe, "script/$_"; 23 | } else { 24 | die("Cannot find script '$_'"); 25 | } 26 | } 27 | } 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /inc/Module/Install/TestBase.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::TestBase; 3 | use strict; 4 | use warnings; 5 | 6 | use Module::Install::Base; 7 | 8 | use vars qw($VERSION @ISA); 9 | BEGIN { 10 | $VERSION = '0.86'; 11 | @ISA = 'Module::Install::Base'; 12 | } 13 | 14 | sub use_test_base { 15 | my $self = shift; 16 | $self->include('Test::Base'); 17 | $self->include('Test::Base::Filter'); 18 | $self->include('Spiffy'); 19 | $self->include('Test::More'); 20 | $self->include('Test::Builder'); 21 | $self->include('Test::Builder::Module'); 22 | $self->requires('Filter::Util::Call'); 23 | } 24 | 25 | 1; 26 | -------------------------------------------------------------------------------- /inc/Module/Install/Win32.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Win32; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.18'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | # determine if the user needs nmake, and download it if needed 15 | sub check_nmake { 16 | my $self = shift; 17 | $self->load('can_run'); 18 | $self->load('get_file'); 19 | 20 | require Config; 21 | return unless ( 22 | $^O eq 'MSWin32' and 23 | $Config::Config{make} and 24 | $Config::Config{make} =~ /^nmake\b/i and 25 | ! $self->can_run('nmake') 26 | ); 27 | 28 | print "The required 'nmake' executable not found, fetching it...\n"; 29 | 30 | require File::Basename; 31 | my $rv = $self->get_file( 32 | url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', 33 | ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', 34 | local_dir => File::Basename::dirname($^X), 35 | size => 51928, 36 | run => 'Nmake15.exe /o > nul', 37 | check_for => 'Nmake.exe', 38 | remove => 1, 39 | ); 40 | 41 | die <<'END_MESSAGE' unless $rv; 42 | 43 | ------------------------------------------------------------------------------- 44 | 45 | Since you are using Microsoft Windows, you will need the 'nmake' utility 46 | before installation. It's available at: 47 | 48 | http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe 49 | or 50 | ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe 51 | 52 | Please download the file manually, save it to a directory in %PATH% (e.g. 53 | C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to 54 | that directory, and run "Nmake15.exe" from there; that will create the 55 | 'nmake.exe' file needed by this module. 56 | 57 | You may then resume the installation process described in README. 58 | 59 | ------------------------------------------------------------------------------- 60 | END_MESSAGE 61 | 62 | } 63 | 64 | 1; 65 | -------------------------------------------------------------------------------- /inc/Module/Install/WriteAll.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::WriteAll; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.18'; 10 | @ISA = qw{Module::Install::Base}; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub WriteAll { 15 | my $self = shift; 16 | my %args = ( 17 | meta => 1, 18 | sign => 0, 19 | inline => 0, 20 | check_nmake => 1, 21 | @_, 22 | ); 23 | 24 | $self->sign(1) if $args{sign}; 25 | $self->admin->WriteAll(%args) if $self->is_admin; 26 | 27 | $self->check_nmake if $args{check_nmake}; 28 | unless ( $self->makemaker_args->{PL_FILES} ) { 29 | # XXX: This still may be a bit over-defensive... 30 | unless ($self->makemaker(6.25)) { 31 | $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; 32 | } 33 | } 34 | 35 | # Until ExtUtils::MakeMaker support MYMETA.yml, make sure 36 | # we clean it up properly ourself. 37 | $self->realclean_files('MYMETA.yml'); 38 | 39 | if ( $args{inline} ) { 40 | $self->Inline->write; 41 | } else { 42 | $self->Makefile->write; 43 | } 44 | 45 | # The Makefile write process adds a couple of dependencies, 46 | # so write the META.yml files after the Makefile. 47 | if ( $args{meta} ) { 48 | $self->Meta->write; 49 | } 50 | 51 | # Experimental support for MYMETA 52 | if ( $ENV{X_MYMETA} ) { 53 | if ( $ENV{X_MYMETA} eq 'JSON' ) { 54 | $self->Meta->write_mymeta_json; 55 | } else { 56 | $self->Meta->write_mymeta_yaml; 57 | } 58 | } 59 | 60 | return 1; 61 | } 62 | 63 | 1; 64 | -------------------------------------------------------------------------------- /inc/Spiffy.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | use strict; use warnings; 3 | package Spiffy; 4 | our $VERSION = '0.46'; 5 | 6 | use Carp; 7 | require Exporter; 8 | our @EXPORT = (); 9 | our @EXPORT_BASE = qw(field const stub super); 10 | our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ)); 11 | our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]); 12 | 13 | my $stack_frame = 0; 14 | my $dump = 'yaml'; 15 | my $bases_map = {}; 16 | 17 | sub WWW; sub XXX; sub YYY; sub ZZZ; 18 | 19 | # This line is here to convince "autouse" into believing we are autousable. 20 | sub can { 21 | ($_[1] eq 'import' and caller()->isa('autouse')) 22 | ? \&Exporter::import # pacify autouse's equality test 23 | : $_[0]->SUPER::can($_[1]) # normal case 24 | } 25 | 26 | # TODO 27 | # 28 | # Exported functions like field and super should be hidden so as not to 29 | # be confused with methods that can be inherited. 30 | # 31 | 32 | sub new { 33 | my $class = shift; 34 | $class = ref($class) || $class; 35 | my $self = bless {}, $class; 36 | while (@_) { 37 | my $method = shift; 38 | $self->$method(shift); 39 | } 40 | return $self; 41 | } 42 | 43 | my $filtered_files = {}; 44 | my $filter_dump = 0; 45 | my $filter_save = 0; 46 | our $filter_result = ''; 47 | sub import { 48 | no strict 'refs'; 49 | no warnings; 50 | my $self_package = shift; 51 | 52 | # XXX Using parse_arguments here might cause confusion, because the 53 | # subclass's boolean_arguments and paired_arguments can conflict, causing 54 | # difficult debugging. Consider using something truly local. 55 | my ($args, @export_list) = do { 56 | local *boolean_arguments = sub { 57 | qw( 58 | -base -Base -mixin -selfless 59 | -XXX -dumper -yaml 60 | -filter_dump -filter_save 61 | ) 62 | }; 63 | local *paired_arguments = sub { qw(-package) }; 64 | $self_package->parse_arguments(@_); 65 | }; 66 | return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list) 67 | if $args->{-mixin}; 68 | 69 | $filter_dump = 1 if $args->{-filter_dump}; 70 | $filter_save = 1 if $args->{-filter_save}; 71 | $dump = 'yaml' if $args->{-yaml}; 72 | $dump = 'dumper' if $args->{-dumper}; 73 | 74 | local @EXPORT_BASE = @EXPORT_BASE; 75 | 76 | if ($args->{-XXX}) { 77 | push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}} 78 | unless grep /^XXX$/, @EXPORT_BASE; 79 | } 80 | 81 | spiffy_filter() 82 | if ($args->{-selfless} or $args->{-Base}) and 83 | not $filtered_files->{(caller($stack_frame))[1]}++; 84 | 85 | my $caller_package = $args->{-package} || caller($stack_frame); 86 | push @{"$caller_package\::ISA"}, $self_package 87 | if $args->{-Base} or $args->{-base}; 88 | 89 | for my $class (@{all_my_bases($self_package)}) { 90 | next unless $class->isa('Spiffy'); 91 | my @export = grep { 92 | not defined &{"$caller_package\::$_"}; 93 | } ( @{"$class\::EXPORT"}, 94 | ($args->{-Base} or $args->{-base}) 95 | ? @{"$class\::EXPORT_BASE"} : (), 96 | ); 97 | my @export_ok = grep { 98 | not defined &{"$caller_package\::$_"}; 99 | } @{"$class\::EXPORT_OK"}; 100 | 101 | # Avoid calling the expensive Exporter::export 102 | # if there is nothing to do (optimization) 103 | my %exportable = map { ($_, 1) } @export, @export_ok; 104 | next unless keys %exportable; 105 | 106 | my @export_save = @{"$class\::EXPORT"}; 107 | my @export_ok_save = @{"$class\::EXPORT_OK"}; 108 | @{"$class\::EXPORT"} = @export; 109 | @{"$class\::EXPORT_OK"} = @export_ok; 110 | my @list = grep { 111 | (my $v = $_) =~ s/^[\!\:]//; 112 | $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v}; 113 | } @export_list; 114 | Exporter::export($class, $caller_package, @list); 115 | @{"$class\::EXPORT"} = @export_save; 116 | @{"$class\::EXPORT_OK"} = @export_ok_save; 117 | } 118 | } 119 | 120 | sub spiffy_filter { 121 | require Filter::Util::Call; 122 | my $done = 0; 123 | Filter::Util::Call::filter_add( 124 | sub { 125 | return 0 if $done; 126 | my ($data, $end) = ('', ''); 127 | while (my $status = Filter::Util::Call::filter_read()) { 128 | return $status if $status < 0; 129 | if (/^__(?:END|DATA)__\r?$/) { 130 | $end = $_; 131 | last; 132 | } 133 | $data .= $_; 134 | $_ = ''; 135 | } 136 | $_ = $data; 137 | my @my_subs; 138 | s[^(sub\s+\w+\s+\{)(.*\n)] 139 | [${1}my \$self = shift;$2]gm; 140 | s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)] 141 | [${1}${2}]gm; 142 | s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n] 143 | [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem; 144 | my $preclare = ''; 145 | if (@my_subs) { 146 | $preclare = join ',', map "\$$_", @my_subs; 147 | $preclare = "my($preclare);"; 148 | } 149 | $_ = "use strict;use warnings;$preclare${_};1;\n$end"; 150 | if ($filter_dump) { print; exit } 151 | if ($filter_save) { $filter_result = $_; $_ = $filter_result; } 152 | $done = 1; 153 | } 154 | ); 155 | } 156 | 157 | sub base { 158 | push @_, -base; 159 | goto &import; 160 | } 161 | 162 | sub all_my_bases { 163 | my $class = shift; 164 | 165 | return $bases_map->{$class} 166 | if defined $bases_map->{$class}; 167 | 168 | my @bases = ($class); 169 | no strict 'refs'; 170 | for my $base_class (@{"${class}::ISA"}) { 171 | push @bases, @{all_my_bases($base_class)}; 172 | } 173 | my $used = {}; 174 | $bases_map->{$class} = [grep {not $used->{$_}++} @bases]; 175 | } 176 | 177 | my %code = ( 178 | sub_start => 179 | "sub {\n", 180 | set_default => 181 | " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", 182 | init => 183 | " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . 184 | " unless \$#_ > 0 or defined \$_[0]->{%s};\n", 185 | weak_init => 186 | " return do {\n" . 187 | " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" . 188 | " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" . 189 | " \$_[0]->{%s};\n" . 190 | " } unless \$#_ > 0 or defined \$_[0]->{%s};\n", 191 | return_if_get => 192 | " return \$_[0]->{%s} unless \$#_ > 0;\n", 193 | set => 194 | " \$_[0]->{%s} = \$_[1];\n", 195 | weaken => 196 | " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n", 197 | sub_end => 198 | " return \$_[0]->{%s};\n}\n", 199 | ); 200 | 201 | sub field { 202 | my $package = caller; 203 | my ($args, @values) = do { 204 | no warnings; 205 | local *boolean_arguments = sub { (qw(-weak)) }; 206 | local *paired_arguments = sub { (qw(-package -init)) }; 207 | Spiffy->parse_arguments(@_); 208 | }; 209 | my ($field, $default) = @values; 210 | $package = $args->{-package} if defined $args->{-package}; 211 | die "Cannot have a default for a weakened field ($field)" 212 | if defined $default && $args->{-weak}; 213 | return if defined &{"${package}::$field"}; 214 | require Scalar::Util if $args->{-weak}; 215 | my $default_string = 216 | ( ref($default) eq 'ARRAY' and not @$default ) 217 | ? '[]' 218 | : (ref($default) eq 'HASH' and not keys %$default ) 219 | ? '{}' 220 | : default_as_code($default); 221 | 222 | my $code = $code{sub_start}; 223 | if ($args->{-init}) { 224 | my $fragment = $args->{-weak} ? $code{weak_init} : $code{init}; 225 | my @count = ($fragment =~ /(%s)/g); 226 | $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2); 227 | } 228 | $code .= sprintf $code{set_default}, $field, $default_string, $field 229 | if defined $default; 230 | $code .= sprintf $code{return_if_get}, $field; 231 | $code .= sprintf $code{set}, $field; 232 | $code .= sprintf $code{weaken}, $field, $field 233 | if $args->{-weak}; 234 | $code .= sprintf $code{sub_end}, $field; 235 | 236 | my $sub = eval $code; 237 | die $@ if $@; 238 | no strict 'refs'; 239 | *{"${package}::$field"} = $sub; 240 | return $code if defined wantarray; 241 | } 242 | 243 | sub default_as_code { 244 | require Data::Dumper; 245 | local $Data::Dumper::Sortkeys = 1; 246 | my $code = Data::Dumper::Dumper(shift); 247 | $code =~ s/^\$VAR1 = //; 248 | $code =~ s/;$//; 249 | return $code; 250 | } 251 | 252 | sub const { 253 | my $package = caller; 254 | my ($args, @values) = do { 255 | no warnings; 256 | local *paired_arguments = sub { (qw(-package)) }; 257 | Spiffy->parse_arguments(@_); 258 | }; 259 | my ($field, $default) = @values; 260 | $package = $args->{-package} if defined $args->{-package}; 261 | no strict 'refs'; 262 | return if defined &{"${package}::$field"}; 263 | *{"${package}::$field"} = sub { $default } 264 | } 265 | 266 | sub stub { 267 | my $package = caller; 268 | my ($args, @values) = do { 269 | no warnings; 270 | local *paired_arguments = sub { (qw(-package)) }; 271 | Spiffy->parse_arguments(@_); 272 | }; 273 | my ($field, $default) = @values; 274 | $package = $args->{-package} if defined $args->{-package}; 275 | no strict 'refs'; 276 | return if defined &{"${package}::$field"}; 277 | *{"${package}::$field"} = 278 | sub { 279 | require Carp; 280 | Carp::confess 281 | "Method $field in package $package must be subclassed"; 282 | } 283 | } 284 | 285 | sub parse_arguments { 286 | my $class = shift; 287 | my ($args, @values) = ({}, ()); 288 | my %booleans = map { ($_, 1) } $class->boolean_arguments; 289 | my %pairs = map { ($_, 1) } $class->paired_arguments; 290 | while (@_) { 291 | my $elem = shift; 292 | if (defined $elem and defined $booleans{$elem}) { 293 | $args->{$elem} = (@_ and $_[0] =~ /^[01]$/) 294 | ? shift 295 | : 1; 296 | } 297 | elsif (defined $elem and defined $pairs{$elem} and @_) { 298 | $args->{$elem} = shift; 299 | } 300 | else { 301 | push @values, $elem; 302 | } 303 | } 304 | return wantarray ? ($args, @values) : $args; 305 | } 306 | 307 | sub boolean_arguments { () } 308 | sub paired_arguments { () } 309 | 310 | # get a unique id for any node 311 | sub id { 312 | if (not ref $_[0]) { 313 | return 'undef' if not defined $_[0]; 314 | \$_[0] =~ /\((\w+)\)$/o or die; 315 | return "$1-S"; 316 | } 317 | require overload; 318 | overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die; 319 | return $1; 320 | } 321 | 322 | #=============================================================================== 323 | # It's super, man. 324 | #=============================================================================== 325 | package DB; 326 | { 327 | no warnings 'redefine'; 328 | sub super_args { 329 | my @dummy = caller(@_ ? $_[0] : 2); 330 | return @DB::args; 331 | } 332 | } 333 | 334 | package Spiffy; 335 | sub super { 336 | my $method; 337 | my $frame = 1; 338 | while ($method = (caller($frame++))[3]) { 339 | $method =~ s/.*::// and last; 340 | } 341 | my @args = DB::super_args($frame); 342 | @_ = @_ ? ($args[0], @_) : @args; 343 | my $class = ref $_[0] ? ref $_[0] : $_[0]; 344 | my $caller_class = caller; 345 | my $seen = 0; 346 | my @super_classes = reverse grep { 347 | ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1; 348 | } reverse @{all_my_bases($class)}; 349 | for my $super_class (@super_classes) { 350 | no strict 'refs'; 351 | next if $super_class eq $class; 352 | if (defined &{"${super_class}::$method"}) { 353 | ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"} 354 | if $method eq 'AUTOLOAD'; 355 | return &{"${super_class}::$method"}; 356 | } 357 | } 358 | return; 359 | } 360 | 361 | #=============================================================================== 362 | # This code deserves a spanking, because it is being very naughty. 363 | # It is exchanging base.pm's import() for its own, so that people 364 | # can use base.pm with Spiffy modules, without being the wiser. 365 | #=============================================================================== 366 | my $real_base_import; 367 | my $real_mixin_import; 368 | 369 | BEGIN { 370 | require base unless defined $INC{'base.pm'}; 371 | $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm'; 372 | $real_base_import = \&base::import; 373 | $real_mixin_import = \&mixin::import; 374 | no warnings; 375 | *base::import = \&spiffy_base_import; 376 | *mixin::import = \&spiffy_mixin_import; 377 | } 378 | 379 | # my $i = 0; 380 | # while (my $caller = caller($i++)) { 381 | # next unless $caller eq 'base' or $caller eq 'mixin'; 382 | # croak <isa('Spiffy'); 396 | } @base_classes; 397 | my $inheritor = caller(0); 398 | for my $base_class (@base_classes) { 399 | next if $inheritor->isa($base_class); 400 | croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n", 401 | "See the documentation of Spiffy.pm for details\n " 402 | unless $base_class->isa('Spiffy'); 403 | $stack_frame = 1; # tell import to use different caller 404 | import($base_class, '-base'); 405 | $stack_frame = 0; 406 | } 407 | } 408 | 409 | sub mixin { 410 | my $self = shift; 411 | my $target_class = ref($self); 412 | spiffy_mixin_import($target_class, @_) 413 | } 414 | 415 | sub spiffy_mixin_import { 416 | my $target_class = shift; 417 | $target_class = caller(0) 418 | if $target_class eq 'mixin'; 419 | my $mixin_class = shift 420 | or die "Nothing to mixin"; 421 | eval "require $mixin_class"; 422 | my @roles = @_; 423 | my $pseudo_class = join '-', $target_class, $mixin_class, @roles; 424 | my %methods = spiffy_mixin_methods($mixin_class, @roles); 425 | no strict 'refs'; 426 | no warnings; 427 | @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"}; 428 | @{"$target_class\::ISA"} = ($pseudo_class); 429 | for (keys %methods) { 430 | *{"$pseudo_class\::$_"} = $methods{$_}; 431 | } 432 | } 433 | 434 | sub spiffy_mixin_methods { 435 | my $mixin_class = shift; 436 | no strict 'refs'; 437 | my %methods = spiffy_all_methods($mixin_class); 438 | map { 439 | $methods{$_} 440 | ? ($_, \ &{"$methods{$_}\::$_"}) 441 | : ($_, \ &{"$mixin_class\::$_"}) 442 | } @_ 443 | ? (get_roles($mixin_class, @_)) 444 | : (keys %methods); 445 | } 446 | 447 | sub get_roles { 448 | my $mixin_class = shift; 449 | my @roles = @_; 450 | while (grep /^!*:/, @roles) { 451 | @roles = map { 452 | s/!!//g; 453 | /^!:(.*)/ ? do { 454 | my $m = "_role_$1"; 455 | map("!$_", $mixin_class->$m); 456 | } : 457 | /^:(.*)/ ? do { 458 | my $m = "_role_$1"; 459 | ($mixin_class->$m); 460 | } : 461 | ($_) 462 | } @roles; 463 | } 464 | if (@roles and $roles[0] =~ /^!/) { 465 | my %methods = spiffy_all_methods($mixin_class); 466 | unshift @roles, keys(%methods); 467 | } 468 | my %roles; 469 | for (@roles) { 470 | s/!!//g; 471 | delete $roles{$1}, next 472 | if /^!(.*)/; 473 | $roles{$_} = 1; 474 | } 475 | keys %roles; 476 | } 477 | 478 | sub spiffy_all_methods { 479 | no strict 'refs'; 480 | my $class = shift; 481 | return if $class eq 'Spiffy'; 482 | my %methods = map { 483 | ($_, $class) 484 | } grep { 485 | defined &{"$class\::$_"} and not /^_/ 486 | } keys %{"$class\::"}; 487 | my %super_methods; 488 | %super_methods = spiffy_all_methods(${"$class\::ISA"}[0]) 489 | if @{"$class\::ISA"}; 490 | %{{%super_methods, %methods}}; 491 | } 492 | 493 | 494 | # END of naughty code. 495 | #=============================================================================== 496 | # Debugging support 497 | #=============================================================================== 498 | sub spiffy_dump { 499 | no warnings; 500 | if ($dump eq 'dumper') { 501 | require Data::Dumper; 502 | $Data::Dumper::Sortkeys = 1; 503 | $Data::Dumper::Indent = 1; 504 | return Data::Dumper::Dumper(@_); 505 | } 506 | require YAML; 507 | $YAML::UseVersion = 0; 508 | return YAML::Dump(@_) . "...\n"; 509 | } 510 | 511 | sub at_line_number { 512 | my ($file_path, $line_number) = (caller(1))[1,2]; 513 | " at $file_path line $line_number\n"; 514 | } 515 | 516 | sub WWW { 517 | warn spiffy_dump(@_) . at_line_number; 518 | return wantarray ? @_ : $_[0]; 519 | } 520 | 521 | sub XXX { 522 | die spiffy_dump(@_) . at_line_number; 523 | } 524 | 525 | sub YYY { 526 | print spiffy_dump(@_) . at_line_number; 527 | return wantarray ? @_ : $_[0]; 528 | } 529 | 530 | sub ZZZ { 531 | require Carp; 532 | Carp::confess spiffy_dump(@_); 533 | } 534 | 535 | 1; 536 | -------------------------------------------------------------------------------- /inc/Test/Base.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Test::Base; 3 | our $VERSION = '0.88'; 4 | 5 | use Spiffy -Base; 6 | use Spiffy ':XXX'; 7 | 8 | my $HAS_PROVIDER; 9 | BEGIN { 10 | $HAS_PROVIDER = eval "require Test::Builder::Provider; 1"; 11 | 12 | if ($HAS_PROVIDER) { 13 | Test::Builder::Provider->import('provides'); 14 | } 15 | else { 16 | *provides = sub { 1 }; 17 | } 18 | } 19 | 20 | 21 | my @test_more_exports; 22 | BEGIN { 23 | @test_more_exports = qw( 24 | ok isnt like unlike is_deeply cmp_ok 25 | skip todo_skip pass fail 26 | eq_array eq_hash eq_set 27 | plan can_ok isa_ok diag 28 | use_ok 29 | $TODO 30 | ); 31 | } 32 | 33 | use Test::More import => \@test_more_exports; 34 | use Carp; 35 | 36 | our @EXPORT = (@test_more_exports, qw( 37 | is no_diff 38 | 39 | blocks next_block first_block 40 | delimiters spec_file spec_string 41 | filters filters_delay filter_arguments 42 | run run_compare run_is run_is_deeply run_like run_unlike 43 | skip_all_unless_require is_deep run_is_deep 44 | WWW XXX YYY ZZZ 45 | tie_output no_diag_on_only 46 | 47 | find_my_self default_object 48 | 49 | croak carp cluck confess 50 | )); 51 | 52 | field '_spec_file'; 53 | field '_spec_string'; 54 | field _filters => [qw(norm trim)]; 55 | field _filters_map => {}; 56 | field spec => 57 | -init => '$self->_spec_init'; 58 | field block_list => 59 | -init => '$self->_block_list_init'; 60 | field _next_list => []; 61 | field block_delim => 62 | -init => '$self->block_delim_default'; 63 | field data_delim => 64 | -init => '$self->data_delim_default'; 65 | field _filters_delay => 0; 66 | field _no_diag_on_only => 0; 67 | 68 | field block_delim_default => '==='; 69 | field data_delim_default => '---'; 70 | 71 | my $default_class; 72 | my $default_object; 73 | my $reserved_section_names = {}; 74 | 75 | sub default_object { 76 | $default_object ||= $default_class->new; 77 | return $default_object; 78 | } 79 | 80 | my $import_called = 0; 81 | sub import() { 82 | $import_called = 1; 83 | my $class = (grep /^-base$/i, @_) 84 | ? scalar(caller) 85 | : $_[0]; 86 | if (not defined $default_class) { 87 | $default_class = $class; 88 | } 89 | # else { 90 | # croak "Can't use $class after using $default_class" 91 | # unless $default_class->isa($class); 92 | # } 93 | 94 | unless (grep /^-base$/i, @_) { 95 | my @args; 96 | for (my $ii = 1; $ii <= $#_; ++$ii) { 97 | if ($_[$ii] eq '-package') { 98 | ++$ii; 99 | } else { 100 | push @args, $_[$ii]; 101 | } 102 | } 103 | Test::More->import(import => \@test_more_exports, @args) 104 | if @args; 105 | } 106 | 107 | _strict_warnings(); 108 | goto &Spiffy::import; 109 | } 110 | 111 | # Wrap Test::Builder::plan 112 | my $plan_code = \&Test::Builder::plan; 113 | my $Have_Plan = 0; 114 | { 115 | no warnings 'redefine'; 116 | *Test::Builder::plan = sub { 117 | $Have_Plan = 1; 118 | goto &$plan_code; 119 | }; 120 | } 121 | 122 | my $DIED = 0; 123 | $SIG{__DIE__} = sub { $DIED = 1; die @_ }; 124 | 125 | sub block_class { $self->find_class('Block') } 126 | sub filter_class { $self->find_class('Filter') } 127 | 128 | sub find_class { 129 | my $suffix = shift; 130 | my $class = ref($self) . "::$suffix"; 131 | return $class if $class->can('new'); 132 | $class = __PACKAGE__ . "::$suffix"; 133 | return $class if $class->can('new'); 134 | eval "require $class"; 135 | return $class if $class->can('new'); 136 | die "Can't find a class for $suffix"; 137 | } 138 | 139 | sub check_late { 140 | if ($self->{block_list}) { 141 | my $caller = (caller(1))[3]; 142 | $caller =~ s/.*:://; 143 | croak "Too late to call $caller()" 144 | } 145 | } 146 | 147 | sub find_my_self() { 148 | my $self = ref($_[0]) eq $default_class 149 | ? splice(@_, 0, 1) 150 | : default_object(); 151 | return $self, @_; 152 | } 153 | 154 | sub blocks() { 155 | (my ($self), @_) = find_my_self(@_); 156 | 157 | croak "Invalid arguments passed to 'blocks'" 158 | if @_ > 1; 159 | croak sprintf("'%s' is invalid argument to blocks()", shift(@_)) 160 | if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; 161 | 162 | my $blocks = $self->block_list; 163 | 164 | my $section_name = shift || ''; 165 | my @blocks = $section_name 166 | ? (grep { exists $_->{$section_name} } @$blocks) 167 | : (@$blocks); 168 | 169 | return scalar(@blocks) unless wantarray; 170 | 171 | return (@blocks) if $self->_filters_delay; 172 | 173 | for my $block (@blocks) { 174 | $block->run_filters 175 | unless $block->is_filtered; 176 | } 177 | 178 | return (@blocks); 179 | } 180 | 181 | sub next_block() { 182 | (my ($self), @_) = find_my_self(@_); 183 | my $list = $self->_next_list; 184 | if (@$list == 0) { 185 | $list = [@{$self->block_list}, undef]; 186 | $self->_next_list($list); 187 | } 188 | my $block = shift @$list; 189 | if (defined $block and not $block->is_filtered) { 190 | $block->run_filters; 191 | } 192 | return $block; 193 | } 194 | 195 | sub first_block() { 196 | (my ($self), @_) = find_my_self(@_); 197 | $self->_next_list([]); 198 | $self->next_block; 199 | } 200 | 201 | sub filters_delay() { 202 | (my ($self), @_) = find_my_self(@_); 203 | $self->_filters_delay(defined $_[0] ? shift : 1); 204 | } 205 | 206 | sub no_diag_on_only() { 207 | (my ($self), @_) = find_my_self(@_); 208 | $self->_no_diag_on_only(defined $_[0] ? shift : 1); 209 | } 210 | 211 | sub delimiters() { 212 | (my ($self), @_) = find_my_self(@_); 213 | $self->check_late; 214 | my ($block_delimiter, $data_delimiter) = @_; 215 | $block_delimiter ||= $self->block_delim_default; 216 | $data_delimiter ||= $self->data_delim_default; 217 | $self->block_delim($block_delimiter); 218 | $self->data_delim($data_delimiter); 219 | return $self; 220 | } 221 | 222 | sub spec_file() { 223 | (my ($self), @_) = find_my_self(@_); 224 | $self->check_late; 225 | $self->_spec_file(shift); 226 | return $self; 227 | } 228 | 229 | sub spec_string() { 230 | (my ($self), @_) = find_my_self(@_); 231 | $self->check_late; 232 | $self->_spec_string(shift); 233 | return $self; 234 | } 235 | 236 | sub filters() { 237 | (my ($self), @_) = find_my_self(@_); 238 | if (ref($_[0]) eq 'HASH') { 239 | $self->_filters_map(shift); 240 | } 241 | else { 242 | my $filters = $self->_filters; 243 | push @$filters, @_; 244 | } 245 | return $self; 246 | } 247 | 248 | sub filter_arguments() { 249 | $Test::Base::Filter::arguments; 250 | } 251 | 252 | sub have_text_diff { 253 | eval { require Text::Diff; 1 } && 254 | $Text::Diff::VERSION >= 0.35 && 255 | $Algorithm::Diff::VERSION >= 1.15; 256 | } 257 | 258 | provides 'is'; 259 | sub is($$;$) { 260 | (my ($self), @_) = find_my_self(@_); 261 | my ($actual, $expected, $name) = @_; 262 | local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER; 263 | if ($ENV{TEST_SHOW_NO_DIFFS} or 264 | not defined $actual or 265 | not defined $expected or 266 | $actual eq $expected or 267 | not($self->have_text_diff) or 268 | $expected !~ /\n./s 269 | ) { 270 | Test::More::is($actual, $expected, $name); 271 | } 272 | else { 273 | $name = '' unless defined $name; 274 | ok $actual eq $expected, $name; 275 | diag Text::Diff::diff(\$expected, \$actual); 276 | } 277 | } 278 | 279 | sub run(&;$) { 280 | (my ($self), @_) = find_my_self(@_); 281 | my $callback = shift; 282 | for my $block (@{$self->block_list}) { 283 | $block->run_filters unless $block->is_filtered; 284 | &{$callback}($block); 285 | } 286 | } 287 | 288 | my $name_error = "Can't determine section names"; 289 | sub _section_names { 290 | return @_ if @_ == 2; 291 | my $block = $self->first_block 292 | or croak $name_error; 293 | my @names = grep { 294 | $_ !~ /^(ONLY|LAST|SKIP)$/; 295 | } @{$block->{_section_order}[0] || []}; 296 | croak "$name_error. Need two sections in first block" 297 | unless @names == 2; 298 | return @names; 299 | } 300 | 301 | sub _assert_plan { 302 | plan('no_plan') unless $Have_Plan; 303 | } 304 | 305 | sub END { 306 | run_compare() unless $Have_Plan or $DIED or not $import_called; 307 | } 308 | 309 | sub run_compare() { 310 | (my ($self), @_) = find_my_self(@_); 311 | $self->_assert_plan; 312 | my ($x, $y) = $self->_section_names(@_); 313 | local $Test::Builder::Level = $Test::Builder::Level + 1; 314 | for my $block (@{$self->block_list}) { 315 | next unless exists($block->{$x}) and exists($block->{$y}); 316 | $block->run_filters unless $block->is_filtered; 317 | if (ref $block->$x) { 318 | is_deeply($block->$x, $block->$y, 319 | $block->name ? $block->name : ()); 320 | } 321 | elsif (ref $block->$y eq 'Regexp') { 322 | my $regexp = ref $y ? $y : $block->$y; 323 | like($block->$x, $regexp, $block->name ? $block->name : ()); 324 | } 325 | else { 326 | is($block->$x, $block->$y, $block->name ? $block->name : ()); 327 | } 328 | } 329 | } 330 | 331 | sub run_is() { 332 | (my ($self), @_) = find_my_self(@_); 333 | $self->_assert_plan; 334 | my ($x, $y) = $self->_section_names(@_); 335 | local $Test::Builder::Level = $Test::Builder::Level + 1; 336 | for my $block (@{$self->block_list}) { 337 | next unless exists($block->{$x}) and exists($block->{$y}); 338 | $block->run_filters unless $block->is_filtered; 339 | is($block->$x, $block->$y, 340 | $block->name ? $block->name : () 341 | ); 342 | } 343 | } 344 | 345 | sub run_is_deeply() { 346 | (my ($self), @_) = find_my_self(@_); 347 | $self->_assert_plan; 348 | my ($x, $y) = $self->_section_names(@_); 349 | for my $block (@{$self->block_list}) { 350 | next unless exists($block->{$x}) and exists($block->{$y}); 351 | $block->run_filters unless $block->is_filtered; 352 | is_deeply($block->$x, $block->$y, 353 | $block->name ? $block->name : () 354 | ); 355 | } 356 | } 357 | 358 | sub run_like() { 359 | (my ($self), @_) = find_my_self(@_); 360 | $self->_assert_plan; 361 | my ($x, $y) = $self->_section_names(@_); 362 | for my $block (@{$self->block_list}) { 363 | next unless exists($block->{$x}) and defined($y); 364 | $block->run_filters unless $block->is_filtered; 365 | my $regexp = ref $y ? $y : $block->$y; 366 | like($block->$x, $regexp, 367 | $block->name ? $block->name : () 368 | ); 369 | } 370 | } 371 | 372 | sub run_unlike() { 373 | (my ($self), @_) = find_my_self(@_); 374 | $self->_assert_plan; 375 | my ($x, $y) = $self->_section_names(@_); 376 | for my $block (@{$self->block_list}) { 377 | next unless exists($block->{$x}) and defined($y); 378 | $block->run_filters unless $block->is_filtered; 379 | my $regexp = ref $y ? $y : $block->$y; 380 | unlike($block->$x, $regexp, 381 | $block->name ? $block->name : () 382 | ); 383 | } 384 | } 385 | 386 | sub skip_all_unless_require() { 387 | (my ($self), @_) = find_my_self(@_); 388 | my $module = shift; 389 | eval "require $module; 1" 390 | or Test::More::plan( 391 | skip_all => "$module failed to load" 392 | ); 393 | } 394 | 395 | sub is_deep() { 396 | (my ($self), @_) = find_my_self(@_); 397 | require Test::Deep; 398 | Test::Deep::cmp_deeply(@_); 399 | } 400 | 401 | sub run_is_deep() { 402 | (my ($self), @_) = find_my_self(@_); 403 | $self->_assert_plan; 404 | my ($x, $y) = $self->_section_names(@_); 405 | for my $block (@{$self->block_list}) { 406 | next unless exists($block->{$x}) and exists($block->{$y}); 407 | $block->run_filters unless $block->is_filtered; 408 | is_deep($block->$x, $block->$y, 409 | $block->name ? $block->name : () 410 | ); 411 | } 412 | } 413 | 414 | sub _pre_eval { 415 | my $spec = shift; 416 | return $spec unless $spec =~ 417 | s/\A\s*<<<(.*?)>>>\s*$//sm; 418 | my $eval_code = $1; 419 | eval "package main; $eval_code"; 420 | croak $@ if $@; 421 | return $spec; 422 | } 423 | 424 | sub _block_list_init { 425 | my $spec = $self->spec; 426 | $spec = $self->_pre_eval($spec); 427 | my $cd = $self->block_delim; 428 | my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg); 429 | my $blocks = $self->_choose_blocks(@hunks); 430 | $self->block_list($blocks); # Need to set early for possible filter use 431 | my $seq = 1; 432 | for my $block (@$blocks) { 433 | $block->blocks_object($self); 434 | $block->seq_num($seq++); 435 | } 436 | return $blocks; 437 | } 438 | 439 | sub _choose_blocks { 440 | my $blocks = []; 441 | for my $hunk (@_) { 442 | my $block = $self->_make_block($hunk); 443 | if (exists $block->{ONLY}) { 444 | diag "I found ONLY: maybe you're debugging?" 445 | unless $self->_no_diag_on_only; 446 | return [$block]; 447 | } 448 | next if exists $block->{SKIP}; 449 | push @$blocks, $block; 450 | if (exists $block->{LAST}) { 451 | return $blocks; 452 | } 453 | } 454 | return $blocks; 455 | } 456 | 457 | sub _check_reserved { 458 | my $id = shift; 459 | croak "'$id' is a reserved name. Use something else.\n" 460 | if $reserved_section_names->{$id} or 461 | $id =~ /^_/; 462 | } 463 | 464 | sub _make_block { 465 | my $hunk = shift; 466 | my $cd = $self->block_delim; 467 | my $dd = $self->data_delim; 468 | my $block = $self->block_class->new; 469 | $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die; 470 | my $name = $1; 471 | my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk; 472 | my $description = shift @parts; 473 | $description ||= ''; 474 | unless ($description =~ /\S/) { 475 | $description = $name; 476 | } 477 | $description =~ s/\s*\z//; 478 | $block->set_value(description => $description); 479 | 480 | my $section_map = {}; 481 | my $section_order = []; 482 | while (@parts) { 483 | my ($type, $filters, $value) = splice(@parts, 0, 3); 484 | $self->_check_reserved($type); 485 | $value = '' unless defined $value; 486 | $filters = '' unless defined $filters; 487 | if ($filters =~ /:(\s|\z)/) { 488 | croak "Extra lines not allowed in '$type' section" 489 | if $value =~ /\S/; 490 | ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2; 491 | $value = '' unless defined $value; 492 | $value =~ s/^\s*(.*?)\s*$/$1/; 493 | } 494 | $section_map->{$type} = { 495 | filters => $filters, 496 | }; 497 | push @$section_order, $type; 498 | $block->set_value($type, $value); 499 | } 500 | $block->set_value(name => $name); 501 | $block->set_value(_section_map => $section_map); 502 | $block->set_value(_section_order => $section_order); 503 | return $block; 504 | } 505 | 506 | sub _spec_init { 507 | return $self->_spec_string 508 | if $self->_spec_string; 509 | local $/; 510 | my $spec; 511 | if (my $spec_file = $self->_spec_file) { 512 | open FILE, $spec_file or die $!; 513 | $spec = ; 514 | close FILE; 515 | } 516 | else { 517 | $spec = do { 518 | package main; 519 | no warnings 'once'; 520 | ; 521 | }; 522 | } 523 | return $spec; 524 | } 525 | 526 | sub _strict_warnings() { 527 | require Filter::Util::Call; 528 | my $done = 0; 529 | Filter::Util::Call::filter_add( 530 | sub { 531 | return 0 if $done; 532 | my ($data, $end) = ('', ''); 533 | while (my $status = Filter::Util::Call::filter_read()) { 534 | return $status if $status < 0; 535 | if (/^__(?:END|DATA)__\r?$/) { 536 | $end = $_; 537 | last; 538 | } 539 | $data .= $_; 540 | $_ = ''; 541 | } 542 | $_ = "use strict;use warnings;$data$end"; 543 | $done = 1; 544 | } 545 | ); 546 | } 547 | 548 | sub tie_output() { 549 | my $handle = shift; 550 | die "No buffer to tie" unless @_; 551 | tie *$handle, 'Test::Base::Handle', $_[0]; 552 | } 553 | 554 | sub no_diff { 555 | $ENV{TEST_SHOW_NO_DIFFS} = 1; 556 | } 557 | 558 | package Test::Base::Handle; 559 | 560 | sub TIEHANDLE() { 561 | my $class = shift; 562 | bless \ $_[0], $class; 563 | } 564 | 565 | sub PRINT { 566 | $$self .= $_ for @_; 567 | } 568 | 569 | #=============================================================================== 570 | # Test::Base::Block 571 | # 572 | # This is the default class for accessing a Test::Base block object. 573 | #=============================================================================== 574 | package Test::Base::Block; 575 | our @ISA = qw(Spiffy); 576 | 577 | our @EXPORT = qw(block_accessor); 578 | 579 | sub AUTOLOAD { 580 | return; 581 | } 582 | 583 | sub block_accessor() { 584 | my $accessor = shift; 585 | no strict 'refs'; 586 | return if defined &$accessor; 587 | *$accessor = sub { 588 | my $self = shift; 589 | if (@_) { 590 | Carp::croak "Not allowed to set values for '$accessor'"; 591 | } 592 | my @list = @{$self->{$accessor} || []}; 593 | return wantarray 594 | ? (@list) 595 | : $list[0]; 596 | }; 597 | } 598 | 599 | block_accessor 'name'; 600 | block_accessor 'description'; 601 | Spiffy::field 'seq_num'; 602 | Spiffy::field 'is_filtered'; 603 | Spiffy::field 'blocks_object'; 604 | Spiffy::field 'original_values' => {}; 605 | 606 | sub set_value { 607 | no strict 'refs'; 608 | my $accessor = shift; 609 | block_accessor $accessor 610 | unless defined &$accessor; 611 | $self->{$accessor} = [@_]; 612 | } 613 | 614 | sub run_filters { 615 | my $map = $self->_section_map; 616 | my $order = $self->_section_order; 617 | Carp::croak "Attempt to filter a block twice" 618 | if $self->is_filtered; 619 | for my $type (@$order) { 620 | my $filters = $map->{$type}{filters}; 621 | my @value = $self->$type; 622 | $self->original_values->{$type} = $value[0]; 623 | for my $filter ($self->_get_filters($type, $filters)) { 624 | $Test::Base::Filter::arguments = 625 | $filter =~ s/=(.*)$// ? $1 : undef; 626 | my $function = "main::$filter"; 627 | no strict 'refs'; 628 | if (defined &$function) { 629 | local $_ = 630 | (@value == 1 and not defined($value[0])) ? undef : 631 | join '', @value; 632 | my $old = $_; 633 | @value = &$function(@value); 634 | if (not(@value) or 635 | @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ 636 | ) { 637 | if ($value[0] && $_ eq $old) { 638 | Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."); 639 | } 640 | @value = ($_); 641 | } 642 | } 643 | else { 644 | my $filter_object = $self->blocks_object->filter_class->new; 645 | die "Can't find a function or method for '$filter' filter\n" 646 | unless $filter_object->can($filter); 647 | $filter_object->current_block($self); 648 | @value = $filter_object->$filter(@value); 649 | } 650 | # Set the value after each filter since other filters may be 651 | # introspecting. 652 | $self->set_value($type, @value); 653 | } 654 | } 655 | $self->is_filtered(1); 656 | } 657 | 658 | sub _get_filters { 659 | my $type = shift; 660 | my $string = shift || ''; 661 | $string =~ s/\s*(.*?)\s*/$1/; 662 | my @filters = (); 663 | my $map_filters = $self->blocks_object->_filters_map->{$type} || []; 664 | $map_filters = [ $map_filters ] unless ref $map_filters; 665 | my @append = (); 666 | for ( 667 | @{$self->blocks_object->_filters}, 668 | @$map_filters, 669 | split(/\s+/, $string), 670 | ) { 671 | my $filter = $_; 672 | last unless length $filter; 673 | if ($filter =~ s/^-//) { 674 | @filters = grep { $_ ne $filter } @filters; 675 | } 676 | elsif ($filter =~ s/^\+//) { 677 | push @append, $filter; 678 | } 679 | else { 680 | push @filters, $filter; 681 | } 682 | } 683 | return @filters, @append; 684 | } 685 | 686 | { 687 | %$reserved_section_names = map { 688 | ($_, 1); 689 | } keys(%Test::Base::Block::), qw( new DESTROY ); 690 | } 691 | 692 | 1; 693 | -------------------------------------------------------------------------------- /inc/Test/Base/Filter.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | #=============================================================================== 3 | # This is the default class for handling Test::Base data filtering. 4 | #=============================================================================== 5 | package Test::Base::Filter; 6 | use Spiffy -Base; 7 | use Spiffy ':XXX'; 8 | 9 | field 'current_block'; 10 | 11 | our $arguments; 12 | sub current_arguments { 13 | return undef unless defined $arguments; 14 | my $args = $arguments; 15 | $args =~ s/(\\s)/ /g; 16 | $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee; 17 | return $args; 18 | } 19 | 20 | sub assert_scalar { 21 | return if @_ == 1; 22 | require Carp; 23 | my $filter = (caller(1))[3]; 24 | $filter =~ s/.*:://; 25 | Carp::croak "Input to the '$filter' filter must be a scalar, not a list"; 26 | } 27 | 28 | sub _apply_deepest { 29 | my $method = shift; 30 | return () unless @_; 31 | if (ref $_[0] eq 'ARRAY') { 32 | for my $aref (@_) { 33 | @$aref = $self->_apply_deepest($method, @$aref); 34 | } 35 | return @_; 36 | } 37 | $self->$method(@_); 38 | } 39 | 40 | sub _split_array { 41 | map { 42 | [$self->split($_)]; 43 | } @_; 44 | } 45 | 46 | sub _peel_deepest { 47 | return () unless @_; 48 | if (ref $_[0] eq 'ARRAY') { 49 | if (ref $_[0]->[0] eq 'ARRAY') { 50 | for my $aref (@_) { 51 | @$aref = $self->_peel_deepest(@$aref); 52 | } 53 | return @_; 54 | } 55 | return map { $_->[0] } @_; 56 | } 57 | return @_; 58 | } 59 | 60 | #=============================================================================== 61 | # these filters work on the leaves of nested arrays 62 | #=============================================================================== 63 | sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) } 64 | sub Reverse { $self->_apply_deepest(reverse => @_) } 65 | sub Split { $self->_apply_deepest(_split_array => @_) } 66 | sub Sort { $self->_apply_deepest(sort => @_) } 67 | 68 | 69 | sub append { 70 | my $suffix = $self->current_arguments; 71 | map { $_ . $suffix } @_; 72 | } 73 | 74 | sub array { 75 | return [@_]; 76 | } 77 | 78 | sub base64_decode { 79 | $self->assert_scalar(@_); 80 | require MIME::Base64; 81 | MIME::Base64::decode_base64(shift); 82 | } 83 | 84 | sub base64_encode { 85 | $self->assert_scalar(@_); 86 | require MIME::Base64; 87 | MIME::Base64::encode_base64(shift); 88 | } 89 | 90 | sub chomp { 91 | map { CORE::chomp; $_ } @_; 92 | } 93 | 94 | sub chop { 95 | map { CORE::chop; $_ } @_; 96 | } 97 | 98 | sub dumper { 99 | no warnings 'once'; 100 | require Data::Dumper; 101 | local $Data::Dumper::Sortkeys = 1; 102 | local $Data::Dumper::Indent = 1; 103 | local $Data::Dumper::Terse = 1; 104 | Data::Dumper::Dumper(@_); 105 | } 106 | 107 | sub escape { 108 | $self->assert_scalar(@_); 109 | my $text = shift; 110 | $text =~ s/(\\.)/eval "qq{$1}"/ge; 111 | return $text; 112 | } 113 | 114 | sub eval { 115 | $self->assert_scalar(@_); 116 | my @return = CORE::eval(shift); 117 | return $@ if $@; 118 | return @return; 119 | } 120 | 121 | sub eval_all { 122 | $self->assert_scalar(@_); 123 | my $out = ''; 124 | my $err = ''; 125 | Test::Base::tie_output(*STDOUT, $out); 126 | Test::Base::tie_output(*STDERR, $err); 127 | my $return = CORE::eval(shift); 128 | no warnings; 129 | untie *STDOUT; 130 | untie *STDERR; 131 | return $return, $@, $out, $err; 132 | } 133 | 134 | sub eval_stderr { 135 | $self->assert_scalar(@_); 136 | my $output = ''; 137 | Test::Base::tie_output(*STDERR, $output); 138 | CORE::eval(shift); 139 | no warnings; 140 | untie *STDERR; 141 | return $output; 142 | } 143 | 144 | sub eval_stdout { 145 | $self->assert_scalar(@_); 146 | my $output = ''; 147 | Test::Base::tie_output(*STDOUT, $output); 148 | CORE::eval(shift); 149 | no warnings; 150 | untie *STDOUT; 151 | return $output; 152 | } 153 | 154 | sub exec_perl_stdout { 155 | my $tmpfile = "/tmp/test-blocks-$$"; 156 | $self->_write_to($tmpfile, @_); 157 | open my $execution, "$^X $tmpfile 2>&1 |" 158 | or die "Couldn't open subprocess: $!\n"; 159 | local $/; 160 | my $output = <$execution>; 161 | close $execution; 162 | unlink($tmpfile) 163 | or die "Couldn't unlink $tmpfile: $!\n"; 164 | return $output; 165 | } 166 | 167 | sub flatten { 168 | $self->assert_scalar(@_); 169 | my $ref = shift; 170 | if (ref($ref) eq 'HASH') { 171 | return map { 172 | ($_, $ref->{$_}); 173 | } sort keys %$ref; 174 | } 175 | if (ref($ref) eq 'ARRAY') { 176 | return @$ref; 177 | } 178 | die "Can only flatten a hash or array ref"; 179 | } 180 | 181 | sub get_url { 182 | $self->assert_scalar(@_); 183 | my $url = shift; 184 | CORE::chomp($url); 185 | require LWP::Simple; 186 | LWP::Simple::get($url); 187 | } 188 | 189 | sub hash { 190 | return +{ @_ }; 191 | } 192 | 193 | sub head { 194 | my $size = $self->current_arguments || 1; 195 | return splice(@_, 0, $size); 196 | } 197 | 198 | sub join { 199 | my $string = $self->current_arguments; 200 | $string = '' unless defined $string; 201 | CORE::join $string, @_; 202 | } 203 | 204 | sub lines { 205 | $self->assert_scalar(@_); 206 | my $text = shift; 207 | return () unless length $text; 208 | my @lines = ($text =~ /^(.*\n?)/gm); 209 | return @lines; 210 | } 211 | 212 | sub norm { 213 | $self->assert_scalar(@_); 214 | my $text = shift; 215 | $text = '' unless defined $text; 216 | $text =~ s/\015\012/\n/g; 217 | $text =~ s/\r/\n/g; 218 | return $text; 219 | } 220 | 221 | sub prepend { 222 | my $prefix = $self->current_arguments; 223 | map { $prefix . $_ } @_; 224 | } 225 | 226 | sub read_file { 227 | $self->assert_scalar(@_); 228 | my $file = shift; 229 | CORE::chomp $file; 230 | open my $fh, $file 231 | or die "Can't open '$file' for input:\n$!"; 232 | CORE::join '', <$fh>; 233 | } 234 | 235 | sub regexp { 236 | $self->assert_scalar(@_); 237 | my $text = shift; 238 | my $flags = $self->current_arguments; 239 | if ($text =~ /\n.*?\n/s) { 240 | $flags = 'xism' 241 | unless defined $flags; 242 | } 243 | else { 244 | CORE::chomp($text); 245 | } 246 | $flags ||= ''; 247 | my $regexp = eval "qr{$text}$flags"; 248 | die $@ if $@; 249 | return $regexp; 250 | } 251 | 252 | sub reverse { 253 | CORE::reverse(@_); 254 | } 255 | 256 | sub slice { 257 | die "Invalid args for slice" 258 | unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/; 259 | my ($x, $y) = ($1, $2); 260 | $y = $x if not defined $y; 261 | die "Invalid args for slice" 262 | if $x > $y; 263 | return splice(@_, $x, 1 + $y - $x); 264 | } 265 | 266 | sub sort { 267 | CORE::sort(@_); 268 | } 269 | 270 | sub split { 271 | $self->assert_scalar(@_); 272 | my $separator = $self->current_arguments; 273 | if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) { 274 | my $regexp = $1; 275 | $separator = qr{$regexp}; 276 | } 277 | $separator = qr/\s+/ unless $separator; 278 | CORE::split $separator, shift; 279 | } 280 | 281 | sub strict { 282 | $self->assert_scalar(@_); 283 | <<'...' . shift; 284 | use strict; 285 | use warnings; 286 | ... 287 | } 288 | 289 | sub tail { 290 | my $size = $self->current_arguments || 1; 291 | return splice(@_, @_ - $size, $size); 292 | } 293 | 294 | sub trim { 295 | map { 296 | s/\A([ \t]*\n)+//; 297 | s/(?<=\n)\s*\z//g; 298 | $_; 299 | } @_; 300 | } 301 | 302 | sub unchomp { 303 | map { $_ . "\n" } @_; 304 | } 305 | 306 | sub write_file { 307 | my $file = $self->current_arguments 308 | or die "No file specified for write_file filter"; 309 | if ($file =~ /(.*)[\\\/]/) { 310 | my $dir = $1; 311 | if (not -e $dir) { 312 | require File::Path; 313 | File::Path::mkpath($dir) 314 | or die "Can't create $dir"; 315 | } 316 | } 317 | open my $fh, ">$file" 318 | or die "Can't open '$file' for output\n:$!"; 319 | print $fh @_; 320 | close $fh; 321 | return $file; 322 | } 323 | 324 | sub yaml { 325 | $self->assert_scalar(@_); 326 | require YAML; 327 | return YAML::Load(shift); 328 | } 329 | 330 | sub _write_to { 331 | my $filename = shift; 332 | open my $script, ">$filename" 333 | or die "Couldn't open $filename: $!\n"; 334 | print $script @_; 335 | close $script 336 | or die "Couldn't close $filename: $!\n"; 337 | } 338 | 339 | 1; 340 | -------------------------------------------------------------------------------- /inc/Test/Builder/Module.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Test::Builder::Module; 3 | 4 | use strict; 5 | 6 | use Test::Builder 1.00; 7 | 8 | require Exporter; 9 | our @ISA = qw(Exporter); 10 | 11 | our $VERSION = '1.001014'; 12 | $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) 13 | 14 | 15 | #line 74 16 | 17 | sub import { 18 | my($class) = shift; 19 | 20 | # Don't run all this when loading ourself. 21 | return 1 if $class eq 'Test::Builder::Module'; 22 | 23 | my $test = $class->builder; 24 | 25 | my $caller = caller; 26 | 27 | $test->exported_to($caller); 28 | 29 | $class->import_extra( \@_ ); 30 | my(@imports) = $class->_strip_imports( \@_ ); 31 | 32 | $test->plan(@_); 33 | 34 | $class->export_to_level( 1, $class, @imports ); 35 | } 36 | 37 | sub _strip_imports { 38 | my $class = shift; 39 | my $list = shift; 40 | 41 | my @imports = (); 42 | my @other = (); 43 | my $idx = 0; 44 | while( $idx <= $#{$list} ) { 45 | my $item = $list->[$idx]; 46 | 47 | if( defined $item and $item eq 'import' ) { 48 | push @imports, @{ $list->[ $idx + 1 ] }; 49 | $idx++; 50 | } 51 | else { 52 | push @other, $item; 53 | } 54 | 55 | $idx++; 56 | } 57 | 58 | @$list = @other; 59 | 60 | return @imports; 61 | } 62 | 63 | #line 137 64 | 65 | sub import_extra { } 66 | 67 | #line 167 68 | 69 | sub builder { 70 | return Test::Builder->new; 71 | } 72 | 73 | 1; 74 | -------------------------------------------------------------------------------- /lib/Lemplate/Parser.pm: -------------------------------------------------------------------------------- 1 | package Lemplate::Parser; 2 | use strict; 3 | use warnings; 4 | use base 'Template::Parser'; 5 | 6 | our $VERSION = '0.15'; 7 | 8 | use Lemplate::Grammar; 9 | use Lemplate::Directive; 10 | 11 | sub new { 12 | my $class = shift; 13 | my $parser = $class->SUPER::new( 14 | GRAMMAR => Lemplate::Grammar->new(), 15 | FACTORY => 'Lemplate::Directive', 16 | @_, 17 | ); 18 | 19 | # flags passed from Lemplate object 20 | my %args = @_; 21 | 22 | # eval-javascript is default "on" 23 | $parser->{EVAL_JAVASCRIPT} = exists $args{EVAL_JAVASCRIPT} 24 | ? $args{EVAL_JAVASCRIPT} : 1; 25 | 26 | # tie the parser state-variable to the global Directive var 27 | $parser->{INJAVASCRIPT} = \$Lemplate::Directive::INJAVASCRIPT; 28 | 29 | return $parser; 30 | } 31 | 32 | 1; 33 | 34 | __END__ 35 | 36 | =encoding UTF-8 37 | 38 | =head1 NAME 39 | 40 | Lemplate::Parser - Lemplate Parser Subclass 41 | 42 | =head1 SYNOPSIS 43 | 44 | use Lemplate::Parser; 45 | 46 | =head1 DESCRIPTION 47 | 48 | Lemplate::Parser is a simple subclass of Template::Parser. Not much 49 | to see here. 50 | 51 | =head1 AUTHOR 52 | 53 | Ingy döt Net 54 | 55 | =head1 COPYRIGHT 56 | 57 | Copyright (c) 2006-2014. Ingy döt Net. All rights reserved. 58 | 59 | This program is free software; you can redistribute it and/or modify it 60 | under the same terms as Perl itself. 61 | 62 | See L 63 | 64 | =cut 65 | -------------------------------------------------------------------------------- /note/Design: -------------------------------------------------------------------------------- 1 | = DESIGN GOALS 2 | 3 | * Be Useful 4 | * Support as much of Perl's Template Toolkit (TT2) as feasible 5 | * Avoid cruft and scope explosion. 6 | * Make runtime fast as possible. 7 | * Actually complete the project and become stable. 8 | 9 | 10 | = OVERVIEW 11 | 12 | Jemplate leverages TT2 by using Template::Parser, but replacing the 13 | backend (Template::Directive) with Jemplate::Directive to produce 14 | JavaScript code instead of Perl code. 15 | 16 | The typical usage envisioned is that you compile your templates into one 17 | big JavaScript file. Then you import this document and the Jemplate.js 18 | runtime support module in your html. 19 | 20 | 21 | = Perl API 22 | 23 | - Jemplate::Parser->new->parse($template_text); 24 | 25 | Parse a single template and return a JavaScript function (as a 26 | string scalar). 27 | 28 | - Jemplate->compile_template_files(@template_file_paths); 29 | 30 | Take a list of template file paths and compile them into a module of 31 | functions. Returns the text of the module. 32 | 33 | - Jemplate->compile_template_content($template_content, $template_name); 34 | 35 | Take a template string and its name and return the compiled code. 36 | 37 | - Jemplate->compile_module($module_path, \@template_file_paths); 38 | 39 | Similar to `compile_templates`, but prints the result to the 40 | $module_path. Returns 1 if successful, undef if error. 41 | 42 | - Jemplate->compile_module_cached($module_path, \@template_file_paths); 43 | 44 | Similar to `compile_module`, but only compiles if one of the templates 45 | is newer than the module. Returns 1 if successful compile, 0 if no 46 | compile due to cache, undef if error. 47 | 48 | 49 | = JavaScript API 50 | 51 | - Jemplate.process(templateFileName[, dataObject][, outputTarget]); 52 | 53 | Returns a string containing the rendering of the template. 54 | templateFileName is something like `my-widget.tt` and dataObject is just 55 | a JavaScript "hash" of data values. 56 | 57 | The optional outputTarget can be a string or a function. If it is a 58 | function, the function is called with the result, and `true` is returned. 59 | 60 | If it is a string beginning with '#' followed by a word, then the word 61 | is used to locate the DOM element with that id, and the innerHTML of the 62 | element is replaced with the result. (`true` is returned) 63 | 64 | If outputTarget is anything else, an exception will be thrown. 65 | 66 | 67 | = TESTING 68 | 69 | Currently we have automated tests in the `t/` directory that prove that 70 | compilation is correct. These tests use Perl's Test::Base data driven 71 | test framework. 72 | 73 | There is also a JavaScript runtime testing suite in the `tests/` 74 | directory that you can run by simply loading the index.html file into 75 | any supported browser. These tests use a JavaScript port of the 76 | Test.Base framework. 77 | 78 | We also have a more adhoc `eg/` directory with stuff that you need to run by 79 | hand. 80 | 81 | 82 | = FEATURE CHECKLIST 83 | 84 | This is basically a copy of the Template Toolkit Quick Reference Card by 85 | Andrew Ford. This provides a really nice roadmap for Jemplate. 86 | 87 | The original is here: http://refcards.com/refcards/tt2/index.html 88 | 89 | Index: 90 | 91 | (-) Not done yet but planned. 92 | (+) Completed feature. 93 | (=) Partially completed feature. 94 | (x) Not appropriate for Jemplate. 95 | 96 | Each bullet consists of a pair of symbols. The first is for the feature 97 | completion, the second is for the testing of the feature. 98 | 99 | == Syntax 100 | 101 | === Directives 102 | 103 | ++ [% [GET] var %] 104 | ++ [% CALL var %] 105 | ++ [% [SET] var = value ... %] 106 | ++ [% DEFAULT var = value ... %] 107 | -- [% META attr = value ... %] 108 | 109 | -- [% INSERT filename %] 110 | ++ [% INCLUDE template [var = value ...] %] 111 | ++ [% PROCESS template [var = value ...] %] 112 | ++ [% WRAPPER template [var = value ...] %] text... [% END %] 113 | ++ [% BLOCK [name] %] content... [% END %] 114 | ++ [% FILTER filter %] text... [% END %] 115 | +- [% MACRO name[(varlist)] directive %] 116 | -- [% USE plugin[(param, ...)] %] 117 | xx [% PERL %] code... [% END %] 118 | xx [% RAWPERL %] code... [% END %] 119 | ++ [% JAVASCRIPT %] code... [% END %] 120 | 121 | ++ [% FOREACH var = list %] ... [% END %] 122 | ++ [% WHILE cond %] ... [% END %] 123 | ++ [% IF cond %] ... [% ELSIF cond %] ... [% ELSE %] [% END %] 124 | ++ [% SWITCH var %] ... [% CASE [{value|DEFAULT}] %] ... [% END %] 125 | -- [% TRY %] ... [% CATCH [type] %] ... [% FINAL %] ... [% END %] 126 | ++ [% THROW type info ... %] 127 | ++ [% NEXT %] 128 | ++ [% LAST %] 129 | ++ [% RETURN %] 130 | ++ [% STOP %] 131 | 132 | === Special variables 133 | 134 | -- template outermost template being processed - methods: name, modtime 135 | -- component innermost template being processed - methods: name, modtime 136 | ++ loop loop iterator - methods: count, first, last, max, prev, next 137 | -- error exception object 138 | -- content captured output for WRAPPER 139 | -- global top level namespace 140 | 141 | === Virtual methods 142 | 143 | ==== Scalar variables 144 | 145 | ++ chunk(size) negative size chunks from end 146 | ++ defined is value defined? 147 | ++ hash treat as single-element hash with key value 148 | ++ length length of string representation 149 | ++ list treat as single-item list 150 | ++ match(re) true if value matches re 151 | ++ repeat(n) repeated n times 152 | ++ replace(re, sub) replace instances of re with sub 153 | ++ search(re) returns list of matching subpatterns 154 | ++ size returns 1, as if a single-item list 155 | ++ split(re) split string on re 156 | 157 | ==== Hash variables 158 | 159 | ++ each list of alternating keys/values 160 | ++ exists(key) does key exist? 161 | +- import(hash2) import contents of hash2 162 | +- import import into current namespace hash 163 | +- item retrieve value using string 164 | ++ keys list of keys 165 | ++ list returns alternating key, value 166 | ++ nsort keys sorted numerically 167 | ++ size number of pairs 168 | ++ sort keys sorted alphabetically 169 | ++ values list of values 170 | 171 | ==== List variables 172 | 173 | ++ first first item in list 174 | ++ grep(re) items matching re 175 | ++ join(str) items joined with str 176 | ++ last last item in list 177 | ++ max maximum index number (i.e. size - 1) 178 | ++ merge(list [, list...]) combine lists 179 | ++ nsort items sorted numerically 180 | ++ pop remove first item from list 181 | ++ push(item) add item to end of list 182 | ++ reverse items in reverse order 183 | ++ shift remove last item from list 184 | ++ size number of elements 185 | ++ slice(from, to) subset of list 186 | ++ sort items sorted lexically 187 | ++ sort(key) list of hashes sorted lexically by key "key" 188 | ++ splice(off, len [,list]) modifies list 189 | ++ unique unique items (retains order) 190 | ++ unshift(item) add item to start of list 191 | 192 | === Standard filters 193 | 194 | ++ collapse collapses whitespace to a single space 195 | -- eval(text) evaluate as template text 196 | -- evaltt(text) evaluate as template text 197 | -- evalperl(text) evaluate text as Perl code 198 | -- format(str) format as per printf() 199 | ++ html performs HTML escaping on ‘<’, ‘>’, ‘&’ 200 | ++ html_break convert empty lines to HTML linebreaks 201 | ++ html_entity performs HTML escaping 202 | ++ html_line_break convert newlines to ‘
’ 203 | ++ html_para convert blank lines to HTML paras 204 | ++ indent(pad) indent by pad string or width 205 | -- latex(outfmt) process through LATEX 206 | ++ lcfirst lower case first character 207 | ++ lower convert to lower case 208 | ++ null output to the bit bucket 209 | xx perl(text) evaluate text as Perl code 210 | xx redirect(file) redirect output to file 211 | -- remove(re) removes occurrences of re 212 | ++ repeat(n) repeat n times 213 | ++ replace(re, sub) replace re with sub 214 | xx stderr redirect output to STDERR 215 | xx stdout(binmode) redirect output to STDERR in mode binmode 216 | ++ trim removes leading and trailing whitespace 217 | ++ truncate(len) truncate to length len 218 | ++ ucfirst capitalize first character 219 | ++ upper convert to upper case 220 | ++ uri performs URI-escaping 221 | 222 | === Standard plugins 223 | 224 | Refer to documentation for details of individual plugins. 225 | 226 | -- Autoformat autoformatting with Text::Autoformat 227 | -- CGI interface to CGI.pm 228 | -- Datafile data stored in plain text files 229 | -- Date generates formatted time and date strings 230 | -- Directory interface to directory contents 231 | -- DBI interface to DBI 232 | -- Dumper interface to Data::Dumper 233 | -- File provides general file abstraction 234 | -- Format provides printf-like formatting 235 | -- GD::* provide access to GD graphics library 236 | -- HTML generic HTML generation 237 | -- Iterator iterator creation 238 | -- Pod interface to Pod::POM (POD Object Model) 239 | -- String OO string manipulation interface 240 | -- Table table formatting 241 | -- Url URL construction 242 | -- Wrap simple paragraph wrapping 243 | -- XML.DOM interface to XML Document Object Model 244 | -- XML.RSS interface to XML::RSS 245 | -- XML.Simple interface to XML::Simple 246 | -- XML.Style simple stylesheet transforms of XML 247 | -- XML.XPath interface to XML::XPath 248 | 249 | == Configuration Options 250 | 251 | ++ START_TAG start of directive token ([%) 252 | ++ END_TAG end of directive token (%]) 253 | xx TAG_STYLE set pre-defined START_TAG/END_TAG style 254 | ++ PRE_CHOMP remove whitespace before directives (0) 255 | ++ POST_CHOMP remove whitespace after directives (0) 256 | ++ TRIM remove leading and trailing whitespace (0) 257 | -- INTERPOLATE interpolate embedded variables (0) 258 | ++ ANYCASE allow lower case directive keywords (0) 259 | 260 | === Template files and blocks 261 | 262 | -- INCLUDE_PATH search path for templates 263 | xx DELIMITER delimiter for separating paths (:) 264 | xx ABSOLUTE allow absolute file names (0) 265 | xx RELATIVE allow relative filenames (0) 266 | -- DEFAULT default template 267 | -- BLOCKS hash array pre-defining template blocks 268 | -- AUTO_RESET reset BLOCK definitions each time (1) 269 | -- RECURSION permit recursion in templates (0) 270 | 271 | === Template variables 272 | 273 | -- PRE_DEFINE hash array of variables and values to pre-define 274 | -- VARIABLES synonym for PRE_DEFINE 275 | 276 | === Runtime processing options 277 | 278 | -- EVAL_PERL process PERL/RAWPERL blocks (0) 279 | ++ PRE_PROCESS template(s) to process before main template 280 | +- POST_PROCESS template(s) to process after main template 281 | -- PROCESS template(s) to process instead of main template 282 | -- ERROR name of error template or reference to hash 283 | array mapping error types to templates 284 | -- OUTPUT default output location or handler 285 | -- OUTPUT_PATH directory into which output files can be written 286 | == DEBUG raise 'undef' error on access to undefined variables 287 | 288 | === Caching and Compiling Options 289 | 290 | xx CACHE_SIZE max compiled templates to cache (undef, i.e. cache all) 291 | xx COMPILE_EXT extension for compiled template files (undef) 292 | xx COMPILE_DIR directory for compiled template files (undef) 293 | 294 | === Plugins and Filters 295 | 296 | -- PLUGINS reference to a hash array mapping plugin 297 | names to Perl packages. 298 | -- PLUGIN_BASE base class(es) under which plugins may be found 299 | -- LOAD_PERL load Perl modules if plugin not found (0) 300 | -- FILTERS hash array mapping filter names to filter 301 | subroutines or factories. 302 | 303 | === Compatibility, Customisation and Extension 304 | 305 | xx V1DOLLAR backwards compatibility flag 306 | -- LOAD_TEMPLATES list of template providers 307 | -- LOAD_PLUGINS list of plugin providers 308 | -- LOAD_FILTERS list of filter providers 309 | -- TOLERANT set providers to tolerate errors as declinations (0) 310 | -- SERVICE custom service obj (Template::Service) 311 | ++ CONTEXT custom context obj (Template::Context) 312 | ++ STASH custom stash object (Template::Stash) 313 | -- PARSER custom parser object (Template::Parser) 314 | -- GRAMMAR custom grammar obj(Template::Grammar) 315 | 316 | == Command line tools 317 | 318 | -- tpage tpage processes supplied templates and sends output 319 | to STDOUT 320 | -- ttree processes directory hierarchies of templates 321 | -------------------------------------------------------------------------------- /note/ToDo: -------------------------------------------------------------------------------- 1 | == Things to do: 2 | 3 | - Switch to App::Cmd 4 | - Add Python support 5 | - Add Perl (module) support 6 | 7 | #------------------------------------------------------------------------------# 8 | # Older notes, before July 14, 2011 9 | #------------------------------------------------------------------------------# 10 | 11 | === 0.25 12 | 13 | - Find out what changed from 0.23 to 0.23_01 to HEAD 14 | - Release 0.24 15 | 16 | - Port to Python 17 | - Make tests/javascript and tests/python 18 | - Make separate JS and PY subclasses of Template classes 19 | 20 | === 0.23 21 | 22 | Add note about commit 3c4d9 referring to wrong rt, should refer to 23883 23 | 24 | TODO: Does use_test_base not work? make test compains that Test::Base is not installed -rokr 25 | 26 | FUTURE: 27 | 28 | 09:55 < nkuttler_> apparently firefox sets the accept header to request xml rather than json, which obviously is incompatible with later JSON.parse calls. I have added a 29 | req.setRequestHeader("Accept", "text/x-json"); to Jemplate.js to fix that. any comments? 30 | 10:05 < nkuttler_> kind of makes sense to me as jemplate can only handle json, at least atm 31 | 32 | var req = new XMLHttpRequest(); 33 | req.open('GET', url, Boolean(callback)); 34 | req.setRequestHeader('Accept', 'text/x-json'); 35 | return Ajax._send(req, null, callback); 36 | } 37 | 38 | 14:13 < nkuttler> hm, it could break servers that don't understand x-json but expect text/json or application/json 39 | 14:14 < nkuttler> hm, application/json http://www.ietf.org/rfc/rfc4627.txt 40 | 14:16 < nkuttler> maybe rather something like req.setRequestHeader('Accept', 'text/json; text/x-json; application/json'); 41 | 42 | 43 | - Integrate debugging with Firebug 44 | - Better warnings (provide context of fault, e.g. which template?) on bad stash data (lists, etc). 45 | 46 | Integrate different frameworks for Ajax/JSON processing and 47 | encaspulate Jemplate code so it can play nice with other javascript: 48 | 49 | --runtime Is equivalent to --ajax=ilinsky --json=json2 50 | Need to do testing of ilinsky to see if it's a better choice than gregory, but 51 | looks like it (and still has active and recent development). 52 | 53 | --runtime-lite Same as --ajax=none --json=none 54 | --runtime-jquery Same as --ajax=jquery --json=none 55 | --runtime-yui Same as --ajax=yui --json=yui 56 | --runtime-legacy Same as --ajax=gregory --json=json2 57 | 58 | --json By itself, equivalent to --json=json2 59 | --json=json2 Use http://www.json.org/json2.js for parsing/stringifying (bundle) 60 | --json=yui Use YUI: YAHOO.lang.JSON 61 | --json=none Doesn't provide any functionality except a warning 62 | 63 | --ajax By itself, equivalent to --ajax=ilinsky 64 | --ajax=jquery Use jQuery for Ajax get and post (external) 65 | --ajax=yui Use YUI: yui/connection/connection.js (external) 66 | --ajax=ilinsky Use http://code.google.com/p/xmlhttprequest/ (bundle) 67 | --ajax=gregory Use http://www.scss.com.au/family/andrew/webdesign/xmlhttprequest/ (bundle) 68 | --ajax=none Doesn't provide any functionality except a warning 69 | 70 | --xxx Include XXX and JJJ helper functions (bundle, of course) 71 | 72 | --ilinsky-xhr Provide Ilinsky's XmlHttpRequest regardless of which Ajax framework is 73 | chosen. 74 | 75 | --minify Pass output through JavaScript::Minifier 76 | --minify=/path/to/yuicompressor Pass output through an exec java using the specified yuicompressor.jar 77 | 78 | === 0.21 79 | 80 | - Use array for output 81 | - Option to include template source as comments 82 | - Put all Jemplate code into a standalone script 83 | - Test INCLUDE_PATH 84 | - Rewrite docs 85 | - Support JavaScript compression 86 | 87 | === 0.20 88 | 89 | + Fix test failures. 90 | 91 | === 0.19 92 | 93 | + Better Getopt::Long processing 94 | + Option to preserve template paths. 95 | + Support Jemplate objects. Jemplate->new({options})->process; 96 | + Allow multiple compilations to work together. 97 | x Option to bundle Jemplate.js runtime 98 | 99 | + Test --runtime == share/Jemplate.js 100 | + Test --list 101 | + Test --start-tag and JEMPLATE_START_TAG etc 102 | + Test multiple compile files 103 | + Test DEBUG_UNDEF 104 | + Test subdir templates 105 | 106 | + Change list output 107 | + make manifest 108 | 109 | 110 | === This is a list of things for you to do. Feel free to do them or add to the 111 | list. 112 | 113 | + Fix test harness output on IE. It currently shows up on one line. 114 | 115 | - Write tests to make sure all the `process` API variations work (on all 116 | browsers. This has bit me already. 117 | 118 | + Implement the hash virtual methods 119 | - Finish implementing the standard filters 120 | 121 | + Make foo.bar() compile to stash.get('foo', 0, 'bar', []) 122 | + Make sure stash calls some function in that case. 123 | 124 | - Finish the following directives: 125 | - MACRO 126 | - TRY/CATCH/FINAL 127 | - THROW 128 | + DEFAULT 129 | - META 130 | - INSERT 131 | - FILTER 132 | - USE 133 | 134 | - Implement plugin support for javascript libraries. 135 | 136 | - Port popular TT plugin modules 137 | 138 | - Write a tutorial pod 139 | 140 | + TT supports stash localization within a template. Jemplate should do this. 141 | 142 | === Add Experimental Ajax/Json/Stash support 143 | 144 | If a template says: 145 | 146 | [% JSON foo.bar -> 'data/bar.json' %] 147 | 148 | then access to foo.bar will trigger a synchronous call to the uri 149 | 'data/bar.json'. Even access to foo.bar.baz would trigger it before baz was 150 | looked up in the result. 151 | 152 | The idea is that this allows some client side templates to use serverside 153 | logic. And conditionally at that. 154 | 155 | Any subsequent calls to foo.bar.* should use the cached data. 156 | 157 | It is likely that the stash should be localized. So that other templates 158 | access to foo.bar did not use this. 159 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: fetch runtime 2 | 3 | .DELETE_ON_ERROR: $(RUNTIME_MODULE) $(RUNTIME_COMPACT_MODULE) 4 | 5 | JEMPLATE_SCRIPT=../bin/lemplate 6 | JEMPLATE_STANDALONE_SCRIPT=../lemplate 7 | GRAMMAR_MODULE=../lib/Lemplate/Grammar.pm 8 | JEMPLATE_MODULES=$(GRAMMAR_MODULE) $(RUNTIME_MODULE) $(RUNTIME_COMPACT_MODULE) 9 | 10 | all: $(JEMPLATE_STANDALONE_SCRIPT) 11 | 12 | $(JEMPLATE_STANDALONE_SCRIPT): $(JEMPLATE_MODULES) _force 13 | ./bin/make-standalone-script $(JEMPLATE_SCRIPT) > $@ 14 | chmod +x $@ 15 | 16 | $(GRAMMAR_MODULE): parser _force 17 | (cd parser; ./yc) 18 | mv parser/Grammar.pm $@ 19 | rm parser/Parser.output 20 | 21 | _force: 22 | -------------------------------------------------------------------------------- /src/README: -------------------------------------------------------------------------------- 1 | 2 | *** THIS DIRECTORY IS FOR JEMPLATE HACKERS ONLY *** 3 | 4 | 5 | This src directory contains various Perl and JavaScript files that get 6 | stitched together to make the Lemplate Perl/CPAN distribution. 7 | 8 | If you want to hack on the Lemplate parser or runtime code, you can 9 | change the files in this directory. To build your changes into the 10 | Lemplate distribution modules simply run: 11 | 12 | make 13 | 14 | from this directory. 15 | 16 | This directory is not included in the Lemplate CPAN distribution. 17 | -------------------------------------------------------------------------------- /src/bin/make-standalone-script: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use FindBin qw($Bin); 6 | use lib "$Bin/../../lib", "$Bin/../lib"; 7 | use Template; 8 | use IO::All; 9 | 10 | { 11 | my $script = io(shift)->all; 12 | $script =~ s{^#!/usr/bin/perl$}{#!/usr/bin/env perl}m; 13 | 14 | $script =~ /(.*\n#BOOTSTRAP-BEGIN\n).*\n(#BOOTSTRAP-END\n.*)/s 15 | or die; 16 | 17 | print $1 . guts() . $2; 18 | } 19 | 20 | sub guts { 21 | my $output = ''; 22 | for (qw( 23 | Number::Compare 24 | Text::Glob 25 | File::Find::Rule 26 | Template::Constants 27 | Template::Base 28 | Template::Config 29 | Template::Document 30 | Template::Exception 31 | Template::Service 32 | Template::Provider 33 | Template 34 | Template::Grammar 35 | Template::Directive 36 | Template::Parser 37 | Lemplate::Directive 38 | Lemplate::Grammar 39 | Lemplate::Parser 40 | Lemplate 41 | )) { 42 | $output .= get_module($_); 43 | } 44 | return disable_libs() . $output; 45 | } 46 | 47 | sub disable_libs { 48 | return <<'...'; 49 | # This is the standalone Lemplate compiler. 50 | # 51 | # All you need is this program and the program called `perl`. You don't need 52 | # to install any Perl modules. 53 | # 54 | # If you downloaded this program from the internet, don't forget to put it in 55 | # your path and make sure it is executable. Like this: 56 | # 57 | # mv lemplate /usr/local/bin/ 58 | # chmod +x /usr/local/bin/lemplate 59 | # 60 | # Try this command to make sure it works: 61 | # 62 | # lemplate --help 63 | 64 | use Config; 65 | BEGIN { 66 | @INC = ( 67 | $Config::Config{archlib}, 68 | $Config::Config{privlib}, 69 | ); 70 | } 71 | use strict; 72 | use warnings; 73 | 74 | ... 75 | } 76 | 77 | sub get_module { 78 | my $module = shift; 79 | eval "require $module; 1" or die "$module not found"; 80 | $module =~ s{::}{/}g; 81 | $module .= '.pm'; 82 | my $content = io($INC{$module})->all; 83 | # Get rid of DATA section 84 | $content =~ s/^__(END|DATA)__.*//sm; 85 | # Remove POD 86 | $content =~ s/^=\w+.*?(\n=cut\n|\z)//msg; 87 | # Remove comments 88 | $content =~ s/^#.*\n//gm; 89 | 90 | # Return the concatenation of prerequisite modules 91 | return 92 | "#\n# Inline include of $module\n#\n" . 93 | "BEGIN { \$INC{'$module'} = 'dummy/$module'; }\n" . 94 | "BEGIN {\n" . 95 | "#line 0 \"$module\"\n" . 96 | $content . 97 | "\n}\n" . 98 | ""; 99 | } 100 | -------------------------------------------------------------------------------- /src/bin/tpage: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Template; 6 | 7 | { 8 | my $template = shift or die "No template provided"; 9 | -f $template or die "$template does not exist"; 10 | 11 | my $t = Template->new({ 12 | INCLUDE_PATH => [ '.' ], 13 | }); 14 | 15 | $t->process($template, {}); 16 | } 17 | -------------------------------------------------------------------------------- /src/parser/Grammar.pm.skel: -------------------------------------------------------------------------------- 1 | #============================================================= -*-Perl-*- 2 | # 3 | # Lemplate::Grammar 4 | # 5 | # DESCRIPTION 6 | # Grammar file for the Template Toolkit language containing token 7 | # definitions and parser state/rules tables generated by Parse::Yapp. 8 | # 9 | # AUTHOR 10 | # Ingy döt Net 11 | # 12 | # ORIGINAL AUTHOR 13 | # Andy Wardley 14 | # 15 | # COPYRIGHT 16 | # Copyright (C) 2006-2008 Ingy döt Net. 17 | # Copyright (C) 1996-2000 Andy Wardley. 18 | # Copyright (C) 1998-2000 Canon Research Centre Europe Ltd. 19 | # 20 | # This module is free software; you can redistribute it and/or 21 | # modify it under the same terms as Perl itself. 22 | # 23 | #------------------------------------------------------------------------ 24 | # 25 | # NOTE: this module is constructed from the parser/Grammar.pm.skel 26 | # file by running the parser/yc script. You only need to do this if 27 | # you have modified the grammar in the parser/Parser.yp file and need 28 | # to-recompile it. See the README in the 'parser' directory for more 29 | # information (sub-directory of the Lemplate distribution). 30 | # 31 | #======================================================================== 32 | 33 | package Lemplate::Grammar; 34 | 35 | require 5.004; 36 | 37 | use strict; 38 | use vars qw( $VERSION ); 39 | 40 | $VERSION = '0.15'; 41 | 42 | my (@RESERVED, %CMPOP, $LEXTABLE, $RULES, $STATES); 43 | my ($factory, $rawstart); 44 | 45 | 46 | #======================================================================== 47 | # Reserved words, comparison and binary operators 48 | #======================================================================== 49 | 50 | @RESERVED = qw( 51 | GET CALL SET DEFAULT INSERT INCLUDE PROCESS WRAPPER BLOCK END 52 | USE RAW PLUGIN FILTER MACRO JAVASCRIPT TO STEP AND OR NOT DIV MOD 53 | IF UNLESS ELSE ELSIF FOR NEXT WHILE SWITCH CASE META IN 54 | TRY THROW CATCH FINAL LAST RETURN STOP CLEAR VIEW DEBUG 55 | ); 56 | 57 | # for historical reasons, != and == are converted to ne and eq to perform 58 | # stringwise comparison (mainly because it doesn't generate "non-numerical 59 | # comparison" warnings which != and == can) but the others (e.g. < > <= >=) 60 | # are not converted to their stringwise equivalents. I added 'gt' et al, 61 | # briefly for v2.04d and then took them out again in 2.04e. 62 | 63 | %CMPOP = qw( 64 | != ~= 65 | == == 66 | < < 67 | > > 68 | >= >= 69 | <= <= 70 | ); 71 | 72 | 73 | #======================================================================== 74 | # Lexer Token Table 75 | #======================================================================== 76 | 77 | # lookup table used by lexer is initialised with special-cases 78 | $LEXTABLE = { 79 | 'FOREACH' => 'FOR', 80 | 'BREAK' => 'LAST', 81 | '&&' => 'AND', 82 | '||' => 'OR', 83 | '!' => 'NOT', 84 | '|' => 'FILTER', 85 | '.' => 'DOT', 86 | '_' => 'CAT', 87 | '..' => 'TO', 88 | # ':' => 'MACRO', 89 | '=' => 'ASSIGN', 90 | '=>' => 'ASSIGN', 91 | # '->' => 'ARROW', 92 | ',' => 'COMMA', 93 | '\\' => 'REF', 94 | 'and' => 'AND', # explicitly specified so that qw( and or 95 | 'or' => 'OR', # not ) can always be used in lower case, 96 | 'not' => 'NOT', # regardless of ANYCASE flag 97 | 'mod' => 'MOD', 98 | 'div' => 'DIV', 99 | }; 100 | 101 | # localise the temporary variables needed to complete lexer table 102 | { 103 | # my @tokens = qw< ( ) [ ] { } ${ $ / ; : ? >; 104 | my @tokens = qw< ( ) [ ] { } ${ $ + / ; : ? >; 105 | my @cmpop = keys %CMPOP; 106 | # my @binop = qw( + - * % ); # '/' above, in @tokens 107 | my @binop = qw( - * % ); # '+' and '/' above, in @tokens 108 | 109 | # fill lexer table, slice by slice, with reserved words and operators 110 | @$LEXTABLE{ @RESERVED, @cmpop, @binop, @tokens } 111 | = ( @RESERVED, ('CMPOP') x @cmpop, ('BINOP') x @binop, @tokens ); 112 | } 113 | 114 | 115 | #======================================================================== 116 | # CLASS METHODS 117 | #======================================================================== 118 | 119 | sub new { 120 | my $class = shift; 121 | bless { 122 | LEXTABLE => $LEXTABLE, 123 | STATES => $STATES, 124 | RULES => $RULES, 125 | }, $class; 126 | } 127 | 128 | # update method to set package-scoped $factory lexical 129 | sub install_factory { 130 | my ($self, $new_factory) = @_; 131 | $factory = $new_factory; 132 | } 133 | 134 | 135 | #======================================================================== 136 | # States 137 | #======================================================================== 138 | 139 | $STATES = <<$states>>; 140 | 141 | 142 | #======================================================================== 143 | # Rules 144 | #======================================================================== 145 | 146 | $RULES = <<$rules>>; 147 | 148 | 1; 149 | -------------------------------------------------------------------------------- /src/parser/Parser.yp: -------------------------------------------------------------------------------- 1 | #============================================================= -*-Perl-*- 2 | # 3 | # Parser.yp 4 | # 5 | # DESCRIPTION 6 | # Definition of the parser grammar for the Template Toolkit language. 7 | # 8 | # AUTHOR 9 | # Ingy döt Net 10 | # 11 | # ORIGINAL AUTHOR 12 | # Andy Wardley 13 | # 14 | # HISTORY 15 | # Totally re-written for version 2, based on Doug Steinwand's 16 | # implementation which compiles templates to Perl code. The generated 17 | # code is _considerably_ faster, more portable and easier to process. 18 | # 19 | # WARNINGS 20 | # Expect 1 reduce/reduce conflict. This can safely be ignored. 21 | # Now also expect 1 shift/reduce conflict, created by adding a rule 22 | # to 'args' to allow assignments of the form 'foo.bar = baz'. It 23 | # should be possible to fix the problem by rewriting some rules, but 24 | # I'm loathed to hack it up too much right now. Maybe later. 25 | # 26 | # COPYRIGHT 27 | # Copyright (C) 2006,2008 Ingy döt Net. 28 | # Copyright (C) 1996-2004 Andy Wardley. 29 | # Copyright (C) 1998-2004 Canon Research Centre Europe Ltd. 30 | # 31 | # This module is free software; you can redistribute it and/or 32 | # modify it under the same terms as Perl itself. 33 | # 34 | #------------------------------------------------------------------------ 35 | # 36 | # NOTE: this module is constructed from the parser/Grammar.pm.skel 37 | # file by running the parser/yc script. You only need to do this if 38 | # you have modified the grammar in the parser/Parser.yp file and need 39 | # to-recompile it. See the README in the 'parser' directory for more 40 | # information (sub-directory of the Template distribution). 41 | # 42 | #------------------------------------------------------------------------ 43 | # 44 | # $Id: Parser.yp,v 2.20 2004/01/13 15:32:22 abw Exp $ 45 | # 46 | #======================================================================== 47 | 48 | %right ASSIGN 49 | %right '?' ':' 50 | %left COMMA 51 | %left AND OR 52 | %left NOT 53 | %left CAT 54 | %left DOT 55 | %left CMPOP 56 | %left BINOP 57 | %left '+' 58 | %left '/' 59 | %left DIV 60 | %left MOD 61 | %left TO 62 | %% 63 | 64 | #-------------------------------------------------------------------------- 65 | # START AND TOP-LEVEL RULES 66 | #-------------------------------------------------------------------------- 67 | 68 | template: block { $factory->template($_[1]) } 69 | ; 70 | 71 | block: chunks { $factory->block($_[1]) } 72 | | /* NULL */ { $factory->block() } 73 | ; 74 | 75 | chunks: chunks chunk { push(@{$_[1]}, $_[2]) 76 | if defined $_[2]; $_[1] } 77 | | chunk { defined $_[1] ? [ $_[1] ] : [ ] } 78 | ; 79 | 80 | chunk: TEXT { $factory->textblock($_[1]) } 81 | | statement ';' { return '' unless $_[1]; 82 | $_[0]->location() . $_[1]; 83 | } 84 | ; 85 | 86 | statement: directive 87 | | defblock 88 | | anonblock 89 | | capture 90 | | macro 91 | | use 92 | | raw 93 | | view 94 | | rawperl 95 | | expr { $factory->get($_[1]) } 96 | | META metadata { $_[0]->add_metadata($_[2]); } 97 | | /* empty statement */ 98 | ; 99 | 100 | directive: setlist { $factory->set($_[1]) } 101 | | atomdir 102 | | condition 103 | | switch 104 | | loop 105 | | try 106 | | javascript 107 | | perl 108 | ; 109 | 110 | 111 | #-------------------------------------------------------------------------- 112 | # DIRECTIVE RULES 113 | #-------------------------------------------------------------------------- 114 | 115 | atomexpr: expr { $factory->get($_[1]) } 116 | | atomdir 117 | ; 118 | 119 | atomdir: GET expr { $factory->get($_[2]) } 120 | | CALL expr { $factory->call($_[2]) } 121 | | SET setlist { $factory->set($_[2]) } 122 | | DEFAULT setlist { $factory->default($_[2]) } 123 | | INSERT nameargs { $factory->insert($_[2]) } 124 | | INCLUDE nameargs { $factory->include($_[2]) } 125 | | PROCESS nameargs { $factory->process($_[2]) } 126 | | THROW nameargs { $factory->throw($_[2]) } 127 | | RETURN { $factory->return() } 128 | | STOP { $factory->stop() } 129 | | CLEAR { $factory->clear() } 130 | | LAST { $factory->break() } 131 | | NEXT { $factory->next() } 132 | | DEBUG nameargs { if ($_[2]->[0]->[0] =~ /^'(on|off)'$/) { 133 | $_[0]->{ DEBUG_DIRS } = ($1 eq 'on'); 134 | $factory->debug($_[2]); 135 | } 136 | else { 137 | $_[0]->{ DEBUG_DIRS } ? $factory->debug($_[2]) : ''; 138 | } 139 | } 140 | | wrapper 141 | | filter 142 | ; 143 | 144 | condition: IF expr ';' 145 | block else END { $factory->if(@_[2, 4, 5]) } 146 | | atomexpr IF expr { $factory->if(@_[3, 1]) } 147 | | UNLESS expr ';' 148 | block else END { $factory->if("tt2_not($_[2])", @_[4, 5]) } 149 | | atomexpr UNLESS expr { $factory->if("tt2_not($_[3])", $_[1]) } 150 | ; 151 | 152 | else: ELSIF expr ';' 153 | block else { unshift(@{$_[5]}, [ @_[2, 4] ]); 154 | $_[5]; } 155 | | ELSE ';' block { [ $_[3] ] } 156 | | /* NULL */ { [ undef ] } 157 | ; 158 | 159 | switch: SWITCH expr ';' 160 | block case END { $factory->switch(@_[2, 5]) } 161 | ; 162 | 163 | case: CASE term ';' block 164 | case { unshift(@{$_[5]}, [ @_[2, 4] ]); 165 | $_[5]; } 166 | | CASE DEFAULT ';' block { [ $_[4] ] } 167 | | CASE ';' block { [ $_[3] ] } 168 | | /* NULL */ { [ undef ] } 169 | ; 170 | 171 | loop: FOR loopvar ';' { $_[0]->{ INFOR }++ } 172 | block END { $_[0]->{ INFOR }--; 173 | $factory->foreach(@{$_[2]}, $_[5]) } 174 | #loop: FOR loopvar ';' 175 | # block END { $factory->foreach(@{$_[2]}, $_[4]) } 176 | | atomexpr FOR loopvar { $factory->foreach(@{$_[3]}, $_[1]) } 177 | | WHILE expr ';' { $_[0]->{ INWHILE }++ } 178 | block END { $_[0]->{ INWHILE }--; 179 | $factory->while(@_[2, 5]) } 180 | | atomexpr WHILE expr { $factory->while(@_[3, 1]) } 181 | ; 182 | 183 | loopvar: IDENT ASSIGN term args { [ @_[1, 3, 4] ] } 184 | | IDENT IN term args { [ @_[1, 3, 4] ] } 185 | | term args { [ 0, @_[1, 2] ] } 186 | ; 187 | 188 | wrapper: WRAPPER nameargs ';' 189 | block END { $factory->wrapper(@_[2, 4]) } 190 | | atomexpr 191 | WRAPPER nameargs { $factory->wrapper(@_[3, 1]) } 192 | ; 193 | 194 | try: TRY ';' 195 | block final END { $factory->try(@_[3, 4]) } 196 | ; 197 | 198 | final: CATCH filename ';' 199 | block final { unshift(@{$_[5]}, [ @_[2,4] ]); 200 | $_[5]; } 201 | | CATCH DEFAULT ';' 202 | block final { unshift(@{$_[5]}, [ undef, $_[4] ]); 203 | $_[5]; } 204 | | CATCH ';' 205 | block final { unshift(@{$_[4]}, [ undef, $_[3] ]); 206 | $_[4]; } 207 | | FINAL ';' block { [ $_[3] ] } 208 | | /* NULL */ { [ 0 ] } # no final 209 | ; 210 | 211 | use: USE lnameargs { $factory->use($_[2]) } 212 | ; 213 | 214 | raw: RAW lnameargs { $factory->raw($_[2]) } 215 | ; 216 | 217 | view: VIEW nameargs ';' { $_[0]->push_defblock(); } 218 | block END { $factory->view(@_[2,5], 219 | $_[0]->pop_defblock) } 220 | ; 221 | 222 | javascript: JAVASCRIPT ';' { ${$_[0]->{ INJAVASCRIPT }}++; } 223 | block END { ${$_[0]->{ INJAVASCRIPT }}--; 224 | $_[0]->{ EVAL_JAVASCRIPT } 225 | ? $factory->javascript($_[4]) 226 | : $factory->no_javascript(); } 227 | ; 228 | 229 | filter: FILTER lnameargs ';' 230 | block END { $factory->filter(@_[2,4]) } 231 | | atomexpr FILTER 232 | lnameargs { $factory->filter(@_[3,1]) } 233 | ; 234 | 235 | defblock: defblockname 236 | blockargs ';' 237 | template END { my $name = join('/', @{ $_[0]->{ DEFBLOCKS } }); 238 | pop(@{ $_[0]->{ DEFBLOCKS } }); 239 | $_[0]->define_block($name, $_[4]); 240 | undef 241 | } 242 | ; 243 | 244 | defblockname: BLOCK blockname { push(@{ $_[0]->{ DEFBLOCKS } }, $_[2]); 245 | $_[2]; 246 | } 247 | ; 248 | 249 | blockname: filename 250 | | LITERAL { $_[1] =~ s/^'(.*)'$/$1/; $_[1] } 251 | ; 252 | 253 | blockargs: metadata 254 | | /* NULL */ 255 | ; 256 | 257 | anonblock: BLOCK blockargs ';' block END 258 | { local $" = ', '; 259 | print STDERR "experimental block args: [@{ $_[2] }]\n" 260 | if $_[2]; 261 | $factory->anon_block($_[4]) } 262 | ; 263 | 264 | capture: ident ASSIGN mdir { $factory->capture(@_[1, 3]) } 265 | ; 266 | 267 | macro: MACRO IDENT '(' margs ')' 268 | mdir { $factory->macro(@_[2, 6, 4]) } 269 | | MACRO IDENT mdir { $factory->macro(@_[2, 3]) } 270 | ; 271 | 272 | mdir: directive 273 | | BLOCK ';' block END { $_[3] } 274 | ; 275 | 276 | margs: margs IDENT { push(@{$_[1]}, $_[2]); $_[1] } 277 | | margs COMMA { $_[1] } 278 | | IDENT { [ $_[1] ] } 279 | ; 280 | 281 | metadata: metadata meta { push(@{$_[1]}, @{$_[2]}); $_[1] } 282 | | metadata COMMA 283 | | meta 284 | ; 285 | 286 | meta: IDENT ASSIGN LITERAL { for ($_[3]) { s/^'//; s/'$//; 287 | s/\\'/'/g }; 288 | [ @_[1,3] ] } 289 | | IDENT ASSIGN '"' TEXT '"' { [ @_[1,4] ] } 290 | | IDENT ASSIGN NUMBER { [ @_[1,3] ] } 291 | ; 292 | 293 | 294 | #-------------------------------------------------------------------------- 295 | # FUNDAMENTAL ELEMENT RULES 296 | #-------------------------------------------------------------------------- 297 | 298 | term: lterm 299 | | sterm 300 | ; 301 | 302 | lterm: '[' list ']' { "{ $_[2] }" } 303 | | '[' range ']' { "{ $_[2] }" } 304 | | '[' ']' { "{ }" } 305 | | '{' hash '}' { "{ $_[2] }" } 306 | ; 307 | 308 | sterm: ident { $factory->ident($_[1]) } 309 | | REF ident { $factory->identref($_[2]) } 310 | | '"' quoted '"' { $factory->quoted($_[2]) } 311 | | LITERAL 312 | | NUMBER 313 | ; 314 | 315 | list: list term { "$_[1], $_[2]" } 316 | | list COMMA 317 | | term 318 | ; 319 | 320 | range: sterm TO sterm { $_[1] . '..' . $_[3] } 321 | ; 322 | 323 | 324 | hash: params 325 | | /* NULL */ { "" } 326 | ; 327 | 328 | params: params param { "$_[1], $_[2]" } 329 | | params COMMA 330 | | param 331 | ; 332 | 333 | param: LITERAL ASSIGN expr { "[$_[1]] = $_[3]" } 334 | | item ASSIGN expr { "[$_[1]] = $_[3]" } 335 | ; 336 | 337 | ident: ident DOT node { push(@{$_[1]}, @{$_[3]}); $_[1] } 338 | | ident DOT NUMBER { push(@{$_[1]}, 339 | map {($_, 0)} split(/\./, $_[3])); 340 | $_[1]; } 341 | | node 342 | ; 343 | 344 | node: item { [ $_[1], 0 ] } 345 | | item '(' args ')' { [ $_[1], $factory->args($_[3]) ] } 346 | ; 347 | 348 | item: IDENT { "'$_[1]'" } 349 | | '${' sterm '}' { $_[2] } 350 | | '$' IDENT { $_[0]->{ V1DOLLAR } 351 | ? "'$_[2]'" 352 | : $factory->ident(["'$_[2]'", 0]) } 353 | ; 354 | 355 | expr: expr BINOP expr { "$_[1] $_[2] $_[3]" } 356 | | expr '/' expr { "$_[1] $_[2] $_[3]" } 357 | | expr '+' expr { "$_[1] $_[2] $_[3]" } 358 | | expr DIV expr { "math_floor($_[1] / $_[3])" } 359 | | expr MOD expr { "$_[1] % $_[3]" } 360 | | expr CMPOP expr { "$_[1] $CMPOP{ $_[2] } $_[3]" } 361 | | expr CAT expr { "$_[1] .. $_[3]" } 362 | | expr AND expr { "tt2_true($_[1]) and tt2_true($_[3])" } 363 | | expr OR expr { "tt2_true($_[1]) or tt2_true($_[3])" } 364 | | NOT expr { "tt2_not($_[2])" } 365 | | expr '?' expr ':' expr { "tt2_true($_[1]) and $_[3] or $_[5]" } 366 | | '(' assign ')' { $factory->assign(@{$_[2]}) } 367 | | '(' expr ')' { "($_[2])" } 368 | | term 369 | ; 370 | 371 | setlist: setlist assign { push(@{$_[1]}, @{$_[2]}); $_[1] } 372 | | setlist COMMA 373 | | assign 374 | ; 375 | 376 | 377 | assign: ident ASSIGN expr { [ $_[1], $_[3] ] } 378 | | LITERAL ASSIGN expr { [ @_[1,3] ] } 379 | ; 380 | 381 | # The 'args' production constructs a list of named and positional 382 | # parameters. Named parameters are stored in a list in element 0 383 | # of the args list. Remaining elements contain positional parameters 384 | 385 | args: args expr { push(@{$_[1]}, $_[2]); $_[1] } 386 | | args param { push(@{$_[1]->[0]}, $_[2]); $_[1] } 387 | | args ident ASSIGN expr { push(@{$_[1]->[0]}, "'', " . 388 | $factory->assign(@_[2,4])); $_[1] } 389 | | args COMMA { $_[1] } 390 | | /* init */ { [ [ ] ] } 391 | ; 392 | 393 | 394 | # These are special case parameters used by INCLUDE, PROCESS, etc., which 395 | # interpret barewords as quoted strings rather than variable identifiers; 396 | # a leading '$' is used to explicitly specify a variable. It permits '/', 397 | # '.' and '::' characters, allowing it to be used to specify filenames, etc. 398 | # without requiring quoting. 399 | 400 | lnameargs: lvalue ASSIGN nameargs { push(@{$_[3]}, $_[1]); $_[3] } 401 | | nameargs 402 | ; 403 | 404 | lvalue: item 405 | | '"' quoted '"' { $factory->quoted($_[2]) } 406 | | LITERAL 407 | ; 408 | 409 | nameargs: '$' ident args { [ [$factory->ident($_[2])], $_[3] ] } 410 | | names args { [ @_[1,2] ] } 411 | | names '(' args ')' { [ @_[1,3] ] } 412 | ; 413 | 414 | names: names '+' name { push(@{$_[1]}, $_[3]); $_[1] } 415 | | name { [ $_[1] ] } 416 | ; 417 | 418 | name: '"' quoted '"' { $factory->quoted($_[2]) } 419 | | filename { "'$_[1]'" } 420 | | LITERAL 421 | ; 422 | 423 | #nameargs: literal args { [ @_[1,2] ] } 424 | # | literal '(' args ')' { [ @_[1,3] ] } 425 | # | '$' ident 426 | #; 427 | 428 | #namesargs: names args { [ @_[1,2] ] } 429 | #; 430 | 431 | filename: filename DOT filepart { "$_[1].$_[3]" } 432 | | filepart 433 | ; 434 | 435 | filepart: FILENAME | IDENT | NUMBER 436 | ; 437 | 438 | 439 | # The 'quoted' production builds a list of 'quotable' items that might 440 | # appear in a quoted string, namely text and identifiers. The lexer 441 | # adds an explicit ';' after each directive it finds to help the 442 | # parser identify directive/text boundaries; we're not interested in 443 | # them here so we can simply accept and ignore by returning undef 444 | 445 | quoted: quoted quotable { push(@{$_[1]}, $_[2]) 446 | if defined $_[2]; $_[1] } 447 | | /* NULL */ { [ ] } 448 | ; 449 | 450 | quotable: ident { $factory->ident($_[1]) } 451 | | TEXT { $factory->text($_[1]) } 452 | | ';' { undef } 453 | ; 454 | 455 | 456 | %% 457 | 458 | 459 | 460 | -------------------------------------------------------------------------------- /src/parser/README: -------------------------------------------------------------------------------- 1 | #======================================================================== 2 | # Template Toolkit - parser 3 | #======================================================================== 4 | 5 | This directory contains the YAPP grammar for the Template processor. You 6 | only need to worry about the files in this directory if you want to modify 7 | the template parser grammar. If you're doing such a thing, then it is 8 | assumed that you have some idea of what you're doing. 9 | 10 | 11 | Files: 12 | 13 | Parser.yp Yapp grammar file for the Template parser. 14 | Grammar.pm.skel Skeleton file for ../lib/Template/Grammar.pm. 15 | yc Simple shell cript to compile grammar and build new 16 | ../lib/Template/Grammer.pm file from Grammar.pm.skel and 17 | the output rules and states generated from the grammar. 18 | Parser.output Output file generated by the yapp parser. This is 19 | for information and debugging purposes only and can 20 | otherwise be ignored. 21 | README This file 22 | 23 | 24 | If you don't know what you're doing and would like to, then I can 25 | recommend "Lex and Yacc" by John R. Levine, Tony Mason & Doug Brown 26 | (O'Reilly, ISBN: 1-56592-000-7) which gives a good introduction 27 | to the principles of an LALR parser and how to define grammars in YACC. 28 | YAPP is identical to YACC in all the important ways. See also the 29 | Parse::Yapp documentation and the comments in Template::Parser for more 30 | info. For an in-depth study of parser and compiler theory, consult 31 | "Compiler Theory and Practice", a.k.a. "The Dragon Book", by Alfred 32 | V. Aho, Ravi Sethi and Jeffrey D.Ullman (Addison-Wesley, ISBN: 33 | 0-201-10194-7) 34 | 35 | The parser grammar is compiled by 'yapp', the front-end script to 36 | Francois Desarmenien's Parse::Yapp module(s). You will need Parse::Yapp 37 | version 0.32 or later, available from CPAN, to compile the grammar. 38 | 39 | The grammar file that yapp produces (../Template/Grammar.pm) contains 40 | the rule and state tables for the grammar. These are then loaded by 41 | Template::Parser and used to run the DFA which is implemented by the 42 | parse_directive() method. This has been derived from the standalone 43 | parser created by Parse::Yapp. 44 | 45 | Having modified the Parser.yp file to add your language changes, simply 46 | run: 47 | 48 | ./yc 49 | 50 | to compile the grammar and install it in ../lib/Template/Grammar.pm. 51 | You can then make, make test, make install, or whatever you normally 52 | do, and the new grammar should be used by the template processor. To 53 | revert to the original grammar, simply copy the original distribution 54 | Parser.yp file back into this directory and repeat the above process. 55 | 56 | To create a separate grammar, copy and modify the Parser.yp and 57 | Grammar.pm.skel files as you wish and then run yapp to compile them: 58 | 59 | yapp -v -s -o ../lib/Template/MyGrammar.pm \ 60 | -t MyGrammar.pm.skel MyParser.yp 61 | 62 | You can then instantiate you own grammar and pass this to the 63 | Template constructor. 64 | 65 | my $template = Template->new({ 66 | GRAMMAR => Template::MyGrammar->new(), 67 | }); 68 | 69 | Changing the grammar is a simple process, in theory at least, if you're 70 | familiar with YAPP/YACC. In practice, it also requires some insight 71 | into the inner working of the template toolkit which should probably 72 | be better documented somewhere. 73 | 74 | 75 | Andy Wardley 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | -------------------------------------------------------------------------------- /src/parser/yc: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #======================================================================== 3 | # 4 | # yc - yapp compile 5 | # 6 | # This calls 'yapp', distributed with the Parse::Yapp module, to 7 | # compile the parser grammar and construct the ../Template/Grammar.pm 8 | # file. The grammar is defined in ./Parser.yp. The skeleton file 9 | # Grammar.pm.skel is used as a template for creating the grammar file. 10 | # An output file 'Parser.output' is generated containing a summary of 11 | # the rule and state tables. 12 | # 13 | # You only need to run this script if you have changed the grammar and 14 | # wish to recompile it. 15 | # 16 | # Andy Wardley 17 | # 18 | #======================================================================== 19 | 20 | : ${GRAMMAR:="Parser.yp"} 21 | # : ${OUTPUT:="../lib/Lemplate/Grammar.pm"} 22 | : ${OUTPUT:="Grammar.pm"} 23 | : ${TEMPLATE:="Grammar.pm.skel"} 24 | 25 | echo "Compiling parser grammar (${GRAMMAR} -> ${OUTPUT})" 26 | 27 | yapp -v -s -o ${OUTPUT} -t ${TEMPLATE} ${GRAMMAR} 28 | 29 | -------------------------------------------------------------------------------- /t/TestLemplate.pm: -------------------------------------------------------------------------------- 1 | package t::TestLemplate; 2 | 3 | use lib 'inc'; 4 | use Test::Base -Base; 5 | use File::Temp qw( tempfile ); 6 | use File::Copy qw( copy ); 7 | use IPC::Run3 qw( run3 ); 8 | use Lemplate; 9 | use ExtUtils::MakeMaker; 10 | 11 | our @EXPORT = qw( run_tests ); 12 | 13 | sub can_run ($); 14 | 15 | if (!can_run("resty")) { 16 | plan skip_all => "No \"resty\" utility found in PATH"; 17 | } 18 | 19 | sub run_tests { 20 | for my $block (blocks()) { 21 | run_test($block); 22 | } 23 | } 24 | 25 | sub run_test ($) { 26 | my $block = shift; 27 | #print $json_xs->pretty->encode(\@new_rows); 28 | #my $res = #print $json_xs->pretty->encode($res); 29 | my $name = $block->name; 30 | 31 | my $tt2 = $block->tt2; 32 | if (!defined $tt2) { 33 | die "No --- tt2 specified for test $name\n"; 34 | } 35 | 36 | my ($out_fh, $tt2file) = tempfile("tmpXXXXX", SUFFIX => '.tt2', UNLINK => 1); 37 | print $out_fh $tt2; 38 | close $out_fh; 39 | 40 | my @cmd = ($^X, "./bin/lemplate", "--compile", $tt2file); 41 | 42 | my ($comp_out, $comp_err); 43 | 44 | run3(\@cmd, undef, \$comp_out, \$comp_err); 45 | 46 | #warn "res:$res\nerr:$comp_err\n"; 47 | 48 | if (defined $block->comp_err) { 49 | if (ref $block->comp_err) { 50 | like $comp_err, $block->comp_err, "$name - comp_err expected"; 51 | } else { 52 | is $comp_err, $block->comp_err, "$name - comp_err expected"; 53 | } 54 | 55 | } elsif ($?) { 56 | if (defined $block->fatal) { 57 | pass("failed as expected"); 58 | 59 | } else { 60 | fail("failed to compile TT2 source for test $name: $comp_err\n"); 61 | return; 62 | } 63 | 64 | } else { 65 | if ($comp_err) { 66 | if (!defined $block->comp_err) { 67 | warn "$comp_err\n"; 68 | 69 | } else { 70 | is $comp_err, $block->comp_err, "$name - err ok"; 71 | } 72 | } 73 | } 74 | 75 | my $expected_lua = $block->lua; 76 | if (defined $expected_lua) { 77 | if (ref $expected_lua) { 78 | like $comp_out, $expected_lua, "$name - lua expected"; 79 | } else { 80 | is $comp_out, $expected_lua, "$name - lua expected"; 81 | } 82 | } 83 | 84 | my $luafile; 85 | ($out_fh, $luafile) = tempfile("tmpXXXXX", SUFFIX => '.lua', UNLINK => 1); 86 | print $out_fh $comp_out; 87 | close $out_fh; 88 | 89 | copy($luafile, "a.lua") or die $!; 90 | 91 | (my $luamod = $luafile) =~ s/\.lua$//; 92 | 93 | my $define = $block->define || ''; 94 | my $init = $block->init || ''; 95 | $init =~ s/%LUAMOD%/$luamod/g; 96 | 97 | @cmd = ("resty", "-e", qq{$init ngx.print(require("$luamod").process("$tt2file", {$define}))}); 98 | #warn "cmd: @cmd"; 99 | 100 | my ($run_out, $run_err); 101 | 102 | run3(\@cmd, undef, \$run_out, \$run_err); 103 | 104 | if (defined $block->lua_err) { 105 | $run_err =~ s/^\S+\.lua:\d+:\s*//; 106 | if (ref $block->lua_err) { 107 | like $run_err, $block->lua_err, "$name - run_err expected"; 108 | } else { 109 | is $run_err, $block->lua_err, "$name - run_err expected"; 110 | } 111 | 112 | } elsif ($?) { 113 | if (defined $block->fatal) { 114 | pass("failed as expected"); 115 | 116 | } else { 117 | fail("failed to run Lua code for test $name: $run_err\n"); 118 | return; 119 | } 120 | 121 | } else { 122 | if ($run_err) { 123 | if (!defined $block->lua_err) { 124 | warn "$run_err\n"; 125 | 126 | } else { 127 | is $run_err, $block->lua_err, "$name - err ok"; 128 | } 129 | } 130 | } 131 | 132 | my $expected_out = $block->out; 133 | if (defined $expected_out) { 134 | if (defined $run_out) { 135 | $run_out =~ s/^\n+//gs; 136 | $run_out =~ s/\n\n+$/\n/gs; 137 | } 138 | if (ref $expected_out) { 139 | like $run_out, $expected_out, "$name - out expected"; 140 | } else { 141 | is $run_out, $expected_out, "$name - out expected"; 142 | } 143 | } 144 | } 145 | 146 | # Check if we can run some command 147 | sub can_run ($) { 148 | my ($cmd) = @_; 149 | 150 | my $_cmd = $cmd; 151 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); 152 | 153 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { 154 | next if $dir eq ''; 155 | require File::Spec; 156 | my $abs = File::Spec->catfile($dir, $cmd); 157 | return $abs if (-x $abs or $abs = MM->maybe_command($abs)); 158 | } 159 | 160 | return; 161 | } 162 | 163 | 1; 164 | -------------------------------------------------------------------------------- /t/binop.t: -------------------------------------------------------------------------------- 1 | # vim:set ft= ts=4 sw=4 et fdm=marker: 2 | 3 | use t::TestLemplate; 4 | 5 | plan tests => 1 * blocks(); 6 | 7 | $ENV{LEMPLATE_POST_CHOMP} = 1; 8 | 9 | run_tests; 10 | 11 | __DATA__ 12 | 13 | === TEST 1: 14 | --- tt2 15 | maybe 16 | [% IF yes %] 17 | yes 18 | [% END %] 19 | 20 | --- define: yes = 1 21 | --- out 22 | maybe 23 | yes 24 | 25 | 26 | 27 | === TEST 2: 28 | --- tt2 29 | [% IF yes %] 30 | yes 31 | [% ELSE %] 32 | no 33 | [% END %] 34 | 35 | --- define: yes = 1 36 | --- out 37 | yes 38 | 39 | 40 | 41 | === TEST 3: 42 | --- tt2 43 | [% IF yes %] 44 | yes 45 | [% ELSE %] 46 | no 47 | [% END %] 48 | 49 | --- define: yes = 1 50 | --- out 51 | yes 52 | 53 | 54 | 55 | === TEST 4: 56 | --- tt2 57 | [% IF yes and true %] 58 | yes 59 | [% ELSE %] 60 | no 61 | [% END %] 62 | 63 | --- define: yes = 1, ['true'] = 'this is true' 64 | --- out 65 | yes 66 | 67 | 68 | 69 | === TEST 5: 70 | --- tt2 71 | [% IF yes && true %] 72 | yes 73 | [% ELSE %] 74 | no 75 | [% END %] 76 | 77 | --- define: yes = 1, ['true'] = 'this is true' 78 | --- out 79 | yes 80 | 81 | 82 | 83 | === TEST 6: 84 | --- tt2 85 | [% IF yes && sad || happy %] 86 | yes 87 | [% ELSE %] 88 | no 89 | [% END %] 90 | 91 | --- define: yes = 1, sad = '', happy = 'yes' 92 | --- out 93 | yes 94 | 95 | 96 | 97 | === TEST 7: 98 | --- tt2 99 | [% IF yes AND ten && true and twenty && 30 %] 100 | yes 101 | [% ELSE %] 102 | no 103 | [% END %] 104 | 105 | --- define: yes = 1, ten = 10, ['true'] = 'this is true', twenty = 20 106 | --- out 107 | yes 108 | 109 | 110 | 111 | === TEST 8: 112 | --- tt2 113 | [% IF ! yes %] 114 | no 115 | [% ELSE %] 116 | yes 117 | [% END %] 118 | 119 | --- define: yes = 1 120 | --- out 121 | yes 122 | 123 | 124 | 125 | === TEST 9: 126 | --- tt2 127 | [% UNLESS yes %] 128 | no 129 | [% ELSE %] 130 | yes 131 | [% END %] 132 | 133 | --- define: yes = 1 134 | --- out 135 | yes 136 | 137 | 138 | 139 | === TEST 10: 140 | --- tt2 141 | [% "yes" UNLESS no %] 142 | 143 | --- define: yes = 1, no = 0 144 | --- out chomp 145 | yes 146 | 147 | 148 | 149 | === TEST 11: 150 | --- tt2 151 | [% IF ! yes %] 152 | no 153 | [% ELSE %] 154 | yes 155 | [% END %] 156 | 157 | --- define: yes = 1, no = 0 158 | --- out 159 | yes 160 | 161 | 162 | 163 | === TEST 12: 164 | --- tt2 165 | [% IF yes || no %] 166 | yes 167 | [% ELSE %] 168 | no 169 | [% END %] 170 | 171 | --- define: yes = 1, no = 0 172 | --- out 173 | yes 174 | 175 | 176 | 177 | === TEST 13: 178 | --- tt2 179 | [% IF yes || no || true || false %] 180 | yes 181 | [% ELSE %] 182 | no 183 | [% END %] 184 | 185 | --- define: yes = 1, no = 0, ['true'] = 'this is true', ['false'] = '0' 186 | --- out 187 | yes 188 | 189 | 190 | 191 | === TEST 14: 192 | --- tt2 193 | [% IF yes or no %] 194 | yes 195 | [% ELSE %] 196 | no 197 | [% END %] 198 | 199 | --- define: yes = 1, no = 0 200 | --- out 201 | yes 202 | 203 | 204 | 205 | === TEST 15: 206 | --- tt2 207 | [% IF not false and not sad %] 208 | yes 209 | [% ELSE %] 210 | no 211 | [% END %] 212 | 213 | --- define: ['false'] = '0', sad = '' 214 | --- out 215 | yes 216 | 217 | 218 | 219 | === TEST 16: 220 | --- tt2 221 | [% IF ten == 10 %] 222 | yes 223 | [% ELSE %] 224 | no 225 | [% END %] 226 | 227 | --- define: ten = 10 228 | --- out 229 | yes 230 | 231 | 232 | 233 | === TEST 17: 234 | --- tt2 235 | [% IF ten == twenty %] 236 | I canna break the laws of mathematics, Captain. 237 | [% ELSIF ten > twenty %] 238 | Your numerical system is inverted. Please reboot your Universe. 239 | [% ELSIF twenty < ten %] 240 | Your inverted system is numerical. Please universe your reboot. 241 | [% ELSE %] 242 | Normality is restored. Anything you can't cope with is your own problem. 243 | [% END %] 244 | 245 | --- define: ten = 10, twenty = 20 246 | --- out 247 | Normality is restored. Anything you can't cope with is your own problem. 248 | 249 | 250 | 251 | === TEST 18: 252 | --- tt2 253 | [% IF ten >= twenty or false %] 254 | no 255 | [% ELSIF twenty <= ten %] 256 | nope 257 | [% END %] 258 | nothing 259 | 260 | --- define: ten = 10, twenty = 20, ['false'] = '0' 261 | --- out 262 | nothing 263 | 264 | 265 | 266 | === TEST 19: 267 | --- tt2 268 | [% IF ten >= twenty or false %] 269 | no 270 | [% ELSIF twenty <= ten %] 271 | nope 272 | [% END %] 273 | nothing 274 | 275 | --- define: ten = 10, twenty = 20, ['false'] = '0' 276 | --- out 277 | nothing 278 | 279 | 280 | 281 | === TEST 20: 282 | --- tt2 283 | [% IF ten > twenty %] 284 | no 285 | [% ELSIF ten < twenty %] 286 | yep 287 | [% END %] 288 | 289 | --- define: ten = 10, twenty = 20, ['false'] = '0' 290 | --- out 291 | yep 292 | 293 | 294 | 295 | === TEST 21: 296 | --- tt2 297 | [% IF ten != 10 %] 298 | no 299 | [% ELSIF ten == 10 %] 300 | yep 301 | [% END %] 302 | 303 | --- define: ten = 10 304 | --- out 305 | yep 306 | 307 | 308 | 309 | === TEST 22: 310 | --- tt2 311 | [% IF alpha AND omega %] 312 | alpha and omega are true 313 | [% ELSE %] 314 | alpha and/or omega are not true 315 | [% END %] 316 | count: [% count %] 317 | 318 | --- init 319 | local counter = 0 320 | --- define 321 | alpha = function () counter = counter + 1 return counter end, 322 | omega = function () counter = counter + 10 return 0 end, 323 | count = function () return counter end, 324 | reset = function () return counter == 0 end 325 | --- out chomp 326 | alpha and/or omega are not true 327 | count: 11 328 | 329 | 330 | 331 | === TEST 23: 332 | --- tt2 333 | [% IF omega AND alpha %] 334 | omega and alpha are true 335 | [% ELSE %] 336 | omega and/or alpha are not true 337 | [% END %] 338 | count: [% count %] 339 | 340 | --- init: local counter = 11 341 | --- define 342 | ['true'] = 'this is true', 343 | alpha = function () counter = counter + 1 return counter end, 344 | omega = function () counter = counter + 10 return 0 end, 345 | count = function () return counter end, 346 | reset = function () return counter == 0 end 347 | 348 | --- out chomp 349 | omega and/or alpha are not true 350 | count: 21 351 | 352 | 353 | 354 | === TEST 24: 355 | --- tt2 356 | [% IF alpha OR omega %] 357 | alpha and/or omega are true 358 | [% ELSE %] 359 | neither alpha nor omega are true 360 | [% END %] 361 | count: [% count %] 362 | 363 | --- init: local counter = 21 364 | --- define 365 | ['true'] = 'this is true', 366 | alpha = function () counter = counter + 1 return counter end, 367 | omega = function () counter = counter + 10 return 0 end, 368 | count = function () return counter end, 369 | reset = function () return counter == 0 end 370 | 371 | --- out chomp 372 | alpha and/or omega are true 373 | count: 22 374 | 375 | 376 | 377 | === TEST 25: 378 | --- tt2 379 | [% IF omega OR alpha %] 380 | alpha and/or omega are true 381 | [% ELSE %] 382 | neither alpha nor omega are true 383 | [% END %] 384 | count: [% count %] 385 | 386 | --- init: local counter = 22 387 | --- define 388 | alpha = function () counter = counter + 1 return counter end, 389 | omega = function () counter = counter + 10 return 0 end, 390 | count = function () return counter end, 391 | --- out chomp 392 | alpha and/or omega are true 393 | count: 33 394 | 395 | 396 | 397 | === TEST 26: 398 | --- tt2 399 | [% small = 5 400 | mid = 7 401 | big = 10 402 | both = small + big 403 | less = big - mid 404 | half = big / small 405 | left = big % mid 406 | mult = big * small 407 | %] 408 | both: [% both +%] 409 | less: [% less +%] 410 | half: [% half +%] 411 | left: [% left +%] 412 | mult: [% mult +%] 413 | maxi: [% mult + 2 * 2 +%] 414 | mega: [% mult * 2 + 2 * 3 %] 415 | 416 | --- out chomp 417 | both: 15 418 | less: 3 419 | half: 2 420 | left: 3 421 | mult: 50 422 | maxi: 54 423 | mega: 106 424 | -------------------------------------------------------------------------------- /t/block.t: -------------------------------------------------------------------------------- 1 | # vim:set ft= ts=4 sw=4 et fdm=marker: 2 | 3 | use t::TestLemplate; 4 | 5 | plan tests => 1 * blocks(); 6 | 7 | $ENV{LEMPLATE_POST_CHOMP} = 1; 8 | 9 | run_tests; 10 | 11 | __DATA__ 12 | 13 | === TEST 1: line 1 14 | --- tt2 15 | [% BLOCK block1 %] 16 | This is the original block1 17 | [% END %] 18 | [% INCLUDE block1 %] 19 | [% INCLUDE blockdef %] 20 | [% INCLUDE block1 %] 21 | 22 | --- out 23 | This is the original block1 24 | start of blockdef 25 | end of blockdef 26 | This is the original block1 27 | --- LAST 28 | 29 | 30 | 31 | === TEST 2: line 60 32 | --- tt2 33 | [% BLOCK block1 %] 34 | This is the original block1 35 | [% END %] 36 | [% INCLUDE block1 %] 37 | [% PROCESS blockdef %] 38 | [% INCLUDE block1 %] 39 | 40 | --- out 41 | This is the original block1 42 | start of blockdef 43 | end of blockdef 44 | This is block 1, defined in blockdef, a is alpha 45 | 46 | 47 | 48 | === TEST 3: line 74 49 | --- tt2 50 | [% INCLUDE block_a +%] 51 | [% INCLUDE block_b %] 52 | 53 | --- out 54 | this is block a 55 | this is block b 56 | 57 | 58 | 59 | === TEST 4: line 81 60 | --- tt2 61 | [% INCLUDE header 62 | title = 'A New Beginning' 63 | +%] 64 | A long time ago in a galaxy far, far away... 65 | [% PROCESS footer %] 66 | 67 | --- out 68 | A New Beginning 69 | A long time ago in a galaxy far, far away... 70 | 71 | 72 | 73 | 74 | === TEST 5: line 93 75 | --- tt2 76 | [% BLOCK foo:bar %] 77 | blah 78 | [% END %] 79 | [% PROCESS foo:bar %] 80 | 81 | --- out 82 | blah 83 | 84 | 85 | 86 | === TEST 6: line 101 87 | --- tt2 88 | [% BLOCK 'hello html' -%] 89 | Hello World! 90 | [% END -%] 91 | [% PROCESS 'hello html' %] 92 | 93 | --- out 94 | Hello World! 95 | -------------------------------------------------------------------------------- /t/blocks.t: -------------------------------------------------------------------------------- 1 | # vim:set ft= ts=4 sw=4 et fdm=marker: 2 | 3 | use t::TestLemplate; 4 | 5 | plan tests => 1 * blocks(); 6 | 7 | $ENV{LEMPLATE_POST_CHOMP} = 1; 8 | 9 | run_tests; 10 | 11 | __DATA__ 12 | 13 | === TEST 1: line 1 14 | --- tt2 15 | [% INCLUDE blockdef/block1 %] 16 | 17 | --- lua_err eval 18 | qr{file error - blockdef/block1: not found\n} 19 | --- LAST 20 | 21 | 22 | 23 | === TEST 2: line 61 24 | --- tt2 25 | [% INCLUDE blockdef/block1 %] 26 | 27 | --- out 28 | This is block 1, defined in blockdef, a is alpha 29 | 30 | 31 | 32 | === TEST 3: line 68 33 | --- tt2 34 | [% INCLUDE blockdef/block1 a='amazing' %] 35 | 36 | --- out 37 | This is block 1, defined in blockdef, a is amazing 38 | 39 | 40 | 41 | === TEST 4: line 74 42 | --- tt2 43 | [% TRY; INCLUDE blockdef/none; CATCH; error; END %] 44 | 45 | --- out 46 | file error - blockdef/none: not found 47 | 48 | 49 | 50 | === TEST 5: line 79 51 | --- tt2 52 | [% INCLUDE "$dir/blockdef/block1" a='abstract' %] 53 | 54 | --- out 55 | This is block 1, defined in blockdef, a is abstract 56 | -------------------------------------------------------------------------------- /t/data/README: -------------------------------------------------------------------------------- 1 | This directory contains various template components as used by the 2 | test scripts. 3 | -------------------------------------------------------------------------------- /t/data/after: -------------------------------------------------------------------------------- 1 | This comes after -------------------------------------------------------------------------------- /t/data/badrawperl: -------------------------------------------------------------------------------- 1 | This is some text 2 | [% RAWPERL %] 3 | This is some illegal perl code which should cause a parse error 4 | [% END %] 5 | more stuff goes here -------------------------------------------------------------------------------- /t/data/barfed: -------------------------------------------------------------------------------- 1 | barfed: [[% error.type %]] [[% error.info %]] 2 | -------------------------------------------------------------------------------- /t/data/before: -------------------------------------------------------------------------------- 1 | This comes before 2 | -------------------------------------------------------------------------------- /t/data/blockdef: -------------------------------------------------------------------------------- 1 | start of blockdef 2 | [%- BLOCK block1 -%] 3 | This is block 1, defined in blockdef, a is [% a %] 4 | [% END %] 5 | 6 | [% BLOCK block2 -%] 7 | This is block 2, defined in blockdef, b is [% b %] 8 | [% END -%] 9 | end of blockdef 10 | -------------------------------------------------------------------------------- /t/data/chomp: -------------------------------------------------------------------------------- 1 | [%- 1 %] 2 | [%- 1 %] 3 | [%- 1 %] 4 | [%- 1 %] 5 | [%- 1 %] 6 | [%- END %] 7 | -------------------------------------------------------------------------------- /t/data/config: -------------------------------------------------------------------------------- 1 | [% DEFAULT title = 'Default Title' -%] 2 | [% BLOCK menu -%] 3 | This is the menu, defined in 'config' 4 | [%- END -%] -------------------------------------------------------------------------------- /t/data/content: -------------------------------------------------------------------------------- 1 | This is the main content wrapper for "[% template.title or 'untitled' %]" 2 | [% PROCESS $template %] 3 | This is the end. 4 | -------------------------------------------------------------------------------- /t/data/default: -------------------------------------------------------------------------------- 1 | This is the default file 2 | -------------------------------------------------------------------------------- /t/data/dos_newlines: -------------------------------------------------------------------------------- 1 | [% ding -%] 2 | [% dong -%] 3 | -------------------------------------------------------------------------------- /t/data/error: -------------------------------------------------------------------------------- 1 | error: [[% error.type %]] [[% error.info %]] 2 | -------------------------------------------------------------------------------- /t/data/footer: -------------------------------------------------------------------------------- 1 | footer 2 | -------------------------------------------------------------------------------- /t/data/header: -------------------------------------------------------------------------------- 1 | header: 2 | title: [% title %] 3 | menu: [% INCLUDE menu %] 4 | -------------------------------------------------------------------------------- /t/data/header.tt2: -------------------------------------------------------------------------------- 1 | header.tt2: 2 | title: [% title %] 3 | menu: [% INCLUDE menu %] 4 | -------------------------------------------------------------------------------- /t/data/incblock: -------------------------------------------------------------------------------- 1 | [% BLOCK first_block -%] 2 | this is my first block, a is set to '[% a %]' 3 | [%- END -%] 4 | [% BLOCK second_block; DEFAULT b = 99 m = 98 -%] 5 | this is my second block, a is initially set to '[% a %]' and 6 | then set to [% a = s %]'[% a %]' b is $b m is $m 7 | [%- END -%] 8 | -------------------------------------------------------------------------------- /t/data/inner: -------------------------------------------------------------------------------- 1 | 2 | [% content %] 3 | 4 | [% title = "inner $title" -%] -------------------------------------------------------------------------------- /t/data/menu: -------------------------------------------------------------------------------- 1 | This is the menu defined in its own file -------------------------------------------------------------------------------- /t/data/one/foo: -------------------------------------------------------------------------------- 1 | This is one/foo -------------------------------------------------------------------------------- /t/data/outer: -------------------------------------------------------------------------------- 1 | 2 | [% content %] 3 | 4 | -------------------------------------------------------------------------------- /t/data/process: -------------------------------------------------------------------------------- 1 | begin process 2 | [% PROCESS $template -%] 3 | end process -------------------------------------------------------------------------------- /t/data/simple2: -------------------------------------------------------------------------------- 1 | [% USE Simple -%] 2 | test 2: [% 'badger' | simple -%] 3 | -------------------------------------------------------------------------------- /t/data/trimme: -------------------------------------------------------------------------------- 1 | [% DEFAULT 2 | title = 'something' 3 | colour = 'red' 4 | %] 5 | 6 | [%# more spae-gobbling directives %] 7 | 8 | I am a template element file which will get TRIMmed 9 | 10 | [% foo = 'bar' %] 11 | 12 | 13 | -------------------------------------------------------------------------------- /t/data/two/bar: -------------------------------------------------------------------------------- 1 | This is two/bar -------------------------------------------------------------------------------- /t/data/two/foo: -------------------------------------------------------------------------------- 1 | This is two/foo -------------------------------------------------------------------------------- /t/data/udata1: -------------------------------------------------------------------------------- 1 | # test data for the Datafile plugin 2 | id : name : email 3 | # this is another comment 4 | way : Wendy Yardley : way@cre.canon.co.uk 5 | mop : Marty Proton : mop@cre.canon.co.uk 6 | nellb : Nell Browser : nellb@cre.canon.co.uk 7 | -------------------------------------------------------------------------------- /t/data/udata2: -------------------------------------------------------------------------------- 1 | # more test data for the Datafile plugin 2 | id | name | email 3 | way | Wendy Yardley | way@cre.canon.co.uk 4 | mop | Marty Proton | mop@cre.canon.co.uk 5 | nellb | Nell Browser | nellb@cre.canon.co.uk 6 | -------------------------------------------------------------------------------- /t/data/warning: -------------------------------------------------------------------------------- 1 | Hello 2 | [% a = a + 1 -%] 3 | World 4 | -------------------------------------------------------------------------------- /t/filters.t: -------------------------------------------------------------------------------- 1 | # vim:set ft= ts=4 sw=4 et fdm=marker: 2 | 3 | use t::TestLemplate; 4 | 5 | plan tests => 1 * blocks(); 6 | 7 | $ENV{LEMPLATE_POST_CHOMP} = 1; 8 | 9 | run_tests; 10 | 11 | __DATA__ 12 | 13 | === TEST 1: html filter for > 14 | --- tt2 15 | [% "42 > 41" | html %] 16 | --- out chomp 17 | 42 > 41 18 | 19 | 20 | 21 | === TEST 2: html filter for & 22 | --- tt2 23 | [% "Jack & Jill" | html %] 24 | --- out chomp 25 | Jack & Jill 26 | 27 | 28 | 29 | === TEST 3: lower 30 | --- tt2 31 | [% "Jack & Jill" | lower %] 32 | --- out chomp 33 | jack & jill 34 | 35 | 36 | 37 | === TEST 4: upper 38 | --- tt2 39 | [% "Jack & Jill" | upper %] 40 | --- out chomp 41 | JACK & JILL 42 | 43 | 44 | 45 | === TEST 5: custom filter (with no args) 46 | --- tt2 47 | [% "Jack & Jill" | period %] 48 | --- out chomp 49 | Jack & Jill. 50 | --- init 51 | require("%LUAMOD%").filters['period'] = function(s) 52 | return s .. '.' 53 | end 54 | 55 | 56 | 57 | === TEST 6: custom filter (with args) 58 | --- tt2 59 | [% "Jack & Jill" | quote('"') %] 60 | --- out chomp 61 | "Jack & Jill" 62 | --- init 63 | require("%LUAMOD%").filters['quote'] = function(s, a) 64 | return a[1] .. s .. a[1] 65 | end 66 | -------------------------------------------------------------------------------- /t/iterator.t: -------------------------------------------------------------------------------- 1 | # vim:set ft= ts=4 sw=4 et fdm=marker: 2 | 3 | use t::TestLemplate; 4 | 5 | plan tests => 1 * blocks(); 6 | 7 | $ENV{LEMPLATE_POST_CHOMP} = 1; 8 | 9 | run_tests; 10 | 11 | __DATA__ 12 | 13 | === TEST 1: line 1 14 | --- tt2 15 | [% items = [ 'foo' 'bar' 'baz' 'qux' ] %] 16 | [% FOREACH i = items %] 17 | * [% i +%] 18 | [% END %] 19 | 20 | --- out 21 | * foo 22 | * bar 23 | * baz 24 | * qux 25 | 26 | 27 | 28 | === TEST 2: line 99 29 | --- tt2 30 | [% items = [ 'foo' 'bar' 'baz' 'qux' ] %] 31 | [% FOREACH i = items %] 32 | #[% loop.index %]/[% loop.max %] [% i +%] 33 | [% END %] 34 | 35 | --- out 36 | #0/3 foo 37 | #1/3 bar 38 | #2/3 baz 39 | #3/3 qux 40 | 41 | 42 | 43 | === TEST 3: line 110 44 | --- tt2 45 | [% items = [ 'foo' 'bar' 'baz' 'qux' ] %] 46 | [% FOREACH i = items %] 47 | #[% loop.count %]/[% loop.size %] [% i +%] 48 | [% END %] 49 | 50 | --- out 51 | #1/4 foo 52 | #2/4 bar 53 | #3/4 baz 54 | #4/4 qux 55 | 56 | 57 | 58 | === TEST 4: line 121 59 | --- SKIP 60 | --- tt2 61 | [% items = [ 'foo' 'bar' 'baz' 'qux' ] %] 62 | [% FOREACH i = items %] 63 | #[% loop.number %]/[% loop.size %] [% i +%] 64 | [% END %] 65 | 66 | --- out 67 | #1/4 foo 68 | #2/4 bar 69 | #3/4 baz 70 | #4/4 qux 71 | 72 | 73 | 74 | === TEST 5: line 134 75 | --- tt2 76 | [% USE iterator(data) %] 77 | [% FOREACH i = iterator %] 78 | [% IF iterator.first %] 79 | List of items: 80 | [% END %] 81 | * [% i +%] 82 | [% IF iterator.last %] 83 | End of list 84 | [% END %] 85 | [% END %] 86 | 87 | --- define 88 | data = {'foo', 'bar', 'baz', 'qux', 'wiz', 'woz', 'waz'} 89 | --- out 90 | List of items: 91 | * foo 92 | * bar 93 | * baz 94 | * qux 95 | * wiz 96 | * woz 97 | * waz 98 | End of list 99 | 100 | 101 | 102 | === TEST 6: line 157 103 | --- tt2 104 | [% FOREACH i = [ 'foo' 'bar' 'baz' 'qux' ] %] 105 | [% "$loop.prev<-" IF loop.prev -%][[% i -%]][% "->$loop.next" IF loop.next +%] 106 | [% END %] 107 | 108 | --- out 109 | [foo]->bar 110 | foo<-[bar]->baz 111 | bar<-[baz]->qux 112 | baz<-[qux] 113 | -------------------------------------------------------------------------------- /t/pod.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | eval "use Test::Pod"; 4 | plan skip_all => "Test::Pod required for testing POD" if $@; 5 | all_pod_files_ok(); 6 | -------------------------------------------------------------------------------- /t/sanity.t: -------------------------------------------------------------------------------- 1 | # vim:set ft= ts=4 sw=4 et fdm=marker: 2 | 3 | use t::TestLemplate; 4 | 5 | plan tests => 1 * blocks(); 6 | 7 | run_tests; 8 | 9 | __DATA__ 10 | 11 | === TEST 1: simple varaible interpolation 12 | --- tt2 13 | Hello, [% world %]! 14 | --- define: world = "Lua" 15 | --- out 16 | Hello, Lua! 17 | -------------------------------------------------------------------------------- /t/stash-get.t: -------------------------------------------------------------------------------- 1 | # vim:set ft= ts=4 sw=4 et fdm=marker: 2 | 3 | use t::TestLemplate; 4 | 5 | plan tests => 1 * blocks(); 6 | 7 | $ENV{LEMPLATE_POST_CHOMP} = 1; 8 | 9 | run_tests; 10 | 11 | __DATA__ 12 | 13 | === TEST 1: plain scalar 14 | --- tt2 15 | [% var = 'Jack'; var %] 16 | --- out chomp 17 | Jack 18 | 19 | 20 | 21 | === TEST 2: scalar number 22 | --- tt2 23 | [% var = 42; var %] 24 | --- out chomp 25 | 42 26 | 27 | 28 | 29 | === TEST 3: array element 30 | --- tt2 31 | [% array = [ 'Jack', 'Jill' ]; array.1 %] 32 | --- out chomp 33 | Jill 34 | 35 | 36 | 37 | === TEST 4: hash element 38 | --- tt2 39 | [% hash = { 'Jack' => 41, 'Jill' => 42 }; hash.Jill %] 40 | --- out chomp 41 | 42 42 | 43 | 44 | 45 | === TEST 5: array element 46 | --- tt2 47 | [% array = [ 'Jack', 'Jill' ]; index = 1; array.$index %] 48 | --- out chomp 49 | Jill 50 | 51 | 52 | 53 | === TEST 6: function variable 54 | --- tt2 55 | [% func %] 56 | --- define 57 | func = function () return "Jillian" end, 58 | --- out chomp 59 | Jillian 60 | 61 | 62 | 63 | === TEST 7: function variable with args 64 | --- tt2 65 | [% period("Jillian") %] 66 | --- define 67 | period = function (str) return str .. "." end, 68 | --- out chomp 69 | Jillian. 70 | 71 | 72 | 73 | === TEST 8: function returns array 74 | --- tt2 75 | [% array.2 %] 76 | --- define 77 | array = function () return {40, 41, 42} end, 78 | --- out chomp 79 | 42 80 | 81 | 82 | 83 | === TEST 9: chaining keys 84 | --- tt2 85 | [% string.split().sort.join('+') %] 86 | [%# jump.uppercase %] 87 | --- init 88 | require("%LUAMOD%").vmethods['uppercase'] = function (s) 89 | return string.upper(s) 90 | end 91 | --- define 92 | string = function () return "Jack Jill" end, 93 | --- out chomp 94 | Jack+Jill 95 | -------------------------------------------------------------------------------- /t/vmethods.t: -------------------------------------------------------------------------------- 1 | # vim:set ft= ts=4 sw=4 et fdm=marker: 2 | 3 | use t::TestLemplate; 4 | 5 | plan tests => 1 * blocks(); 6 | 7 | $ENV{LEMPLATE_POST_CHOMP} = 1; 8 | 9 | run_tests; 10 | 11 | __DATA__ 12 | 13 | === TEST 1: first 14 | --- tt2 15 | [% array = [ 'Jack' ] %] 16 | [% array.first() %] 17 | --- out chomp 18 | Jack 19 | 20 | 21 | 22 | === TEST 2: join (no delimiter) 23 | --- tt2 24 | [% array = [ 'Jack', 'Jill' ] %] 25 | [% array.join() %] 26 | --- out chomp 27 | Jack Jill 28 | 29 | 30 | 31 | === TEST 3: join (with delimiter) 32 | --- tt2 33 | [% array = [ 'Jack', 'Jill' ] %] 34 | [% array.join('-') %] 35 | --- out chomp 36 | Jack-Jill 37 | 38 | 39 | 40 | === TEST 4: push 41 | --- tt2 42 | [% array = [ 'Jack', 'Jill' ]; array.push('Jump') %] 43 | [% array.join('-') %] 44 | --- out chomp 45 | Jack-Jill-Jump 46 | 47 | 48 | 49 | === TEST 5: keys 50 | --- tt2 51 | [% hash = { 'Jack' => 41, 'Jill' => 42 }; hash.keys.join('-') %] 52 | --- out chomp 53 | Jack-Jill 54 | 55 | 56 | 57 | === TEST 6: split (no delimiter) 58 | --- tt2 59 | [% str = "Jack Jill"; str.split.join('-') %] 60 | --- out chomp 61 | Jack-Jill 62 | 63 | 64 | 65 | === TEST 7: split (with delimiter) 66 | --- tt2 67 | [% str = "Jack+Jill"; str.split('+').join('-') %] 68 | --- out chomp 69 | Jack-Jill 70 | 71 | 72 | 73 | === TEST 8: sort 74 | --- tt2 75 | [% array = [ 'Jill', 'Jack' ]; array.sort().join('-') %] 76 | --- out chomp 77 | Jack-Jill 78 | 79 | 80 | 81 | === TEST 9: size 82 | --- tt2 83 | [% array = [ 'Jack', 'Jill' ]; array.size %] 84 | --- out chomp 85 | 2 86 | 87 | 88 | 89 | === TEST 10: push multiple 90 | --- tt2 91 | [% array = [ 'Jack', 'Jill' ]; array.push('Jump', "Foo") %] 92 | [% array.join('-') %] 93 | --- out chomp 94 | Jack-Jill-Jump-Foo 95 | -------------------------------------------------------------------------------- /util/convert-tt2-tests: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | my $found; 7 | my $expect_input = 1; 8 | my $input = ''; 9 | my $output = ''; 10 | my @rec; 11 | my $lineno = 1; 12 | 13 | while (<>) { 14 | next if /^\#/; 15 | 16 | if (/^-- stop --/) { 17 | last; 18 | } 19 | 20 | if (!$found) { 21 | if (/^__DATA__$/) { 22 | $found = 1; 23 | } 24 | next; 25 | } 26 | 27 | if ($expect_input) { 28 | if (/^-- test --/) { 29 | next; 30 | } 31 | 32 | if (/^-- expect --/) { 33 | undef $expect_input; 34 | next; 35 | } 36 | 37 | $input .= $_; 38 | } else { 39 | if (/^-- test --/) { 40 | $input =~ s/^\n+//sg; 41 | $input =~ s/\n\n+$/\n/sg; 42 | $output =~ s/^\n+//sg; 43 | $output =~ s/\n\n+$/\n/sg; 44 | push @rec, { line => $lineno, in => $input, out => $output }; 45 | undef $input; 46 | undef $output; 47 | $expect_input = 1; 48 | $lineno = $.; 49 | next; 50 | } 51 | 52 | $output .= $_; 53 | } 54 | } 55 | 56 | #use Data::Dumper; 57 | #print Dumper(\@rec); 58 | 59 | print <<'_EOC_'; 60 | # vim:set ft= ts=4 sw=4 et fdm=marker: 61 | 62 | use t::TestLemplate; 63 | 64 | plan tests => 1 * blocks(); 65 | 66 | $ENV{LEMPLATE_POST_CHOMP} = 1; 67 | 68 | run_tests; 69 | 70 | __DATA__ 71 | 72 | _EOC_ 73 | 74 | $rec[-1]{last} = 1; 75 | my $i = 1; 76 | for my $r (@rec) { 77 | print <<_EOC_; 78 | === TEST $i: line $r->{line} 79 | --- tt2 80 | $r->{in} 81 | --- out 82 | $r->{out} 83 | _EOC_ 84 | 85 | if (!$r->{last}) { 86 | print "\n\n"; 87 | } 88 | } continue { 89 | $i++; 90 | } 91 | -------------------------------------------------------------------------------- /util/gendoc: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | pod2markdown lib/Lemplate.pm ReadMe.md 4 | markdown-toc.pl ReadMe.md 5 | --------------------------------------------------------------------------------