PageRenderTime 68ms CodeModel.GetById 28ms RepoModel.GetById 0ms app.codeStats 0ms

/lib/Text/Perlate.pm

https://github.com/gitpan/Text-Perlate
Perl | 692 lines | 220 code | 54 blank | 418 comment | 37 complexity | 140e9f26651b25a5278ff18238295a62 MD5 | raw file
  1. package Text::Perlate;
  2. use 5.006;
  3. use strict;
  4. use warnings;
  5. our $VERSION = '0.94';
  6. =pod
  7. =head1 NAME
  8. Text::Perlate - Template module using Perl as the langauge.
  9. =head1 SYNOPSIS
  10. use Text::Perlate;
  11. $Text::Perlate::defaults->{...} = ...;
  12. print Text::Perlate::main($options);
  13. To catch errors, wrap calls to this module in eval{} and check $@.
  14. =head1 DESCRIPTION
  15. This module provides a simple translation system for writing files that are
  16. mostly text, TeX, HTML, XML, an email message, etc with some Perl code
  17. interspersed. The input files use [[ and ]] to mark the beginning and end of
  18. Perl code. Text outside of these tags is returned without modification (except
  19. for the effects of conditional statements or loops contained in surrounding
  20. tags of course). PHP users will notice the similarity to the <? ?> tags used
  21. by PHP to separate code from literal text.
  22. A template written in this style is called a "perlate". In contrast, "Perlate"
  23. is the name of this module.
  24. This approach provides the simplicity of using a language you're accustomed to
  25. (Perl) for logic, rather than inventing a trimmed-down language. Admittedly
  26. that means you must exercise restraint in separating logic and text. However,
  27. this approach is faster (in execution) and less bug-prone since it uses a
  28. well-developed compiler and language you already know well. Many argue that an
  29. unrestrained programmer will find a way to shoot themselves despite the best
  30. efforts of the language to prevent it. If you agree, Perlate is for you.
  31. =head1 WRITING PERLATES
  32. As HTML is a common use for Perlate, the following examples show HTML code
  33. outside the tags. The Perl code is surrounded in [[ ]] tags. There is no
  34. preamble or postscript; the file is otherwise indistinguishable from its
  35. output. For example, the following is a valid perlate:
  36. <html><body>
  37. [[ if($_params->{enabled}) { ]]
  38. Enabled = [[ _get "enabled"; ]]
  39. [[ } ]]
  40. </body></html>
  41. Note that statements that normally end in a semicolon must include the
  42. semicolon as shown.
  43. Perlate declares some variables and functions for you in the setup code. All
  44. symbol names prefixed with an underline are reserved. So far, the following
  45. are available for your use:
  46. =over
  47. =item * _echo() emits the expressions passed to it.
  48. =item * _get() emits the parameters named by the arguments. _get("foo") is the
  49. same as _echo($params->{foo}) and _echo($_options->{params}{foo}).
  50. =item * _echoifdef() and _getifdef() are the same as _echo() and _get() except
  51. they prevent warnings about undefined values.
  52. =item * $_options is a copy of the same hash passed by the caller, with any
  53. default settings (from the global variable $defaults) added to it. Options
  54. tell Perlate.pm what to do (what source file to load, what to do with the
  55. output, etc).
  56. =item * $_params is a convenient alias of $_options->{params}. This contains
  57. input parameters to your perlate.
  58. =back
  59. A more interesting example of using Perlate follows. The following is an
  60. example Perl program that calls a perlate:
  61. #!/usr/bin/perl
  62. use strict;
  63. use warnings;
  64. use Text::Perlate;
  65. eval {
  66. print Text::Perlate::main({
  67. input_file => "my.html.perlate",
  68. params => {
  69. enabled => 1,
  70. times => 6,
  71. message => "Display this 6 times.",
  72. },
  73. });
  74. };
  75. if($@) {
  76. print STDERR "An error occurred: $@\n";
  77. }
  78. The file my.html.perlate might contain:
  79. <html><body>
  80. [[- if($_params->{enabled}) { ]]
  81. Enabled.<br />
  82. [[- for(my $count = 0; $count < $_params->{times}; $count++) { ]]
  83. [[ _get "message"; ]]<br />
  84. [[- } ]]
  85. [[- } ]]
  86. [[ _echo "This was repeated $_params->{times} times."; ]]<br />
  87. </body></html>
  88. Some of the tags in the example have a leading hyphen. This signals Perlate to
  89. remove one line of whitespace in the source before the tag. One trailing
  90. hyphen means to remove one line of whitespace after the tag. N hyphens removes
  91. up to N lines, and a plus removes all blank lines. Removal always stops at the
  92. first nonblank line. Next, there may be an octothorpe (#), which indicates
  93. that the entire tag is a comment. Regular Perl comments within a tag are valid
  94. and terminate at the end of the tag or the first newline, as might be expected.
  95. To summarize, the tags have the following syntax (note the position of the
  96. required whitespace):
  97. \[\[(\-*|\+)#?\s.*\s(\-*|\+)\]\]
  98. The strange indentation in the example above is designed to maintain the
  99. indentation levels of the output. Flow control statements strip one line of
  100. leading whitespace and are indented independently of the HTML code and output
  101. statements. This is simply a suggested style. Feel free to invent your own.
  102. While you don't need to know the internals to use Perlate, it may be useful to
  103. understand the basic approach. It translates the perlate into a single string
  104. containing Perl code, surrounds it with a bit of setup and tear-down code, then
  105. eval's the string to create a new package, then calls the package's _main()
  106. function. The setup code includes a "package" statement and
  107. "sub _main {". The text between the tags is quoted and rewritten as a call to
  108. the _echo function. This way the user can open a lexical scope in one tag and
  109. close it in a later one, for example, to conditionally emit certain text or to
  110. repeat a block of text in a loop. A perlate is only eval'd once. Subsequent
  111. calls to it simply call _main() again. (This is the reason it is wrapped in a
  112. function declaration.) Perl allows function declarations inside of functions,
  113. so it's valid to define a function in a perlate that's called by other parts of
  114. the same perlate. This can be useful on a web page, for example, if there is a
  115. bit of HTML code that needs to be repeated in several places. (If this doesn't
  116. quite make sense, try executing the code above with the I<preprocess_only>
  117. flag.)
  118. =head1 OPTIONS
  119. There are some options available in $options. Defaults for these options can
  120. be specified as a hash in the global variable $defaults. For options where it
  121. makes sense, the default is combined with the passed options. For example, a
  122. default perlate input file can be specified instead of passing an explicit
  123. filename with every call. When used with Apache and mod_perl, for example,
  124. setting defaults can be useful in a PerlRequire script.
  125. Several options are available:
  126. =over
  127. =item * $options->{input_file} specifies a filename to read the perlate from.
  128. Overrides both the input_file and input_string defaults. If the filename is
  129. absolute (begins with a slash), the path and correct directory are not
  130. searched. See also $options->{path}.
  131. =item * $options->{input_string} specifies the source for a perlate as a
  132. literal string. Overrides both the input_file and input_string defaults. See
  133. also $options->{cache_id}.
  134. =item * $options->{cache_id} specifies a unique ID for this perlate. If the
  135. cache_id already exists, the perlate is not parsed again and the existing
  136. package name is reused. See also CAVEATS with regard to memory usage. (This
  137. is ignored when specifying $options->{input_file}.)
  138. =item * $options->{params} contains the input parameters to the perlate itself.
  139. These can be emitted into the perlate's output by calling _get("param name") or
  140. they can be accessed through the $_params hash. Default parameters are added
  141. to this hash, but do not override values set in $options->{params}.
  142. =item * $options->{path} may be set to an array of directory names to search.
  143. $defaults->{path} is always searched after that. When you add paths to
  144. $defaults->{path}, your code may work better with future code of yours if you
  145. unshift them onto the array rather than using direct assignment. The search
  146. order is always: current directory, $options->{path}, $defaults->{path}, @INC.
  147. The path option as seen from inside the perlate (called $_options->{path})
  148. includes all of these directories. See also $options->{skip_path}.
  149. =item * $options->{skip_path} specifies to interpret filenames literally rather
  150. than searching $options->{path}, @INC, etc. (Ignored without
  151. $options->{input_file}.)
  152. =item * $options->{raw} may be set to true to indicate that the whole file is
  153. Perl code without [[ ]] tags. This is useful for using parameter passing and
  154. searching $options->{path}. This is probably not going to be useful very
  155. often, except perhaps for debugging, however it is officially supported.
  156. =item * $options->{preprocess_only} may be set to true to return the
  157. preprocessed file without executing (or caching) anything. This is probably
  158. only useful for debugging, unless you want to rely on the existence of _main(),
  159. which is subject to change. At times, this can explain why Perl is reporting a
  160. syntax error.
  161. =back
  162. =head1 OTHER FEATURES & NOTES
  163. The @INC list of directories is automatically appended to the search path.
  164. This means you can put perlates in your lib directory beside any modules that
  165. call them. After all, a perlate represents a module (in a loose sense). One
  166. common approach in large web applications uses a small index.pl file to call a
  167. module containing all the real logic. Searching @INC fits in nicely with that
  168. design.
  169. Assign an integer to $Text::Perlate::debug to see some debugging information.
  170. 0 is none. 1 or more enables basic debugging. 10 or more dumps the code as
  171. it is eval'd. Changes to this knob are not considered relevent to the API.
  172. =head1 CAVEATS
  173. As described above, perlates may be specified by name, or the contents of an
  174. unnamed perlate may be passed directly. Naming a file or cache_id is
  175. preferable because Perlate will then compile each perlate only once. For files, the device number,
  176. inode number, and modification time are used to uniquely identify the specified
  177. file. Without caching, the memory usage will grow slightly with each
  178. execution, since there is no way to unload a module from memory, and each
  179. perlate is loaded more or less like any regular Perl module. Please email the
  180. author if you know of a reasonable way to free that memory.
  181. Of course, general programming wisdom holds that global variables are usually a
  182. bad approach. In a perlate, they require unusual care for several reasons.
  183. First, you must take care to free their content to avoid wasting memory, even
  184. if the perlate aborts via die(). Second, you must take care to initialize it
  185. to the value you expect every time the perlate executes, even if you need it
  186. initialized to undef; this is necessary because a perlate's namespace (package)
  187. is reused when possible, which means that a global variable's value will
  188. usually (but not always) persist between repeated executions. Third, recursive
  189. templates need to save and restore the values of global variables. If you
  190. really need a global variable, always use the "local" keyword because it
  191. addresses all of these issues. If you need a variable to keep a persistent
  192. value, give it an explicit package name that you control, such as the package
  193. name of the caller, so it doesn't break if Perlate changes the name of the
  194. execution's namespace. (Perlate tries to reuse the same namespace, but never
  195. guarantees it. The logic for deciding whether to reuse it will probably change
  196. between versions.) A concise way to declare such variables looks like this:
  197. local our $foo;
  198. Errors and warnings usually report the line number they occur on. However,
  199. Perl seems easily confused over line numbers in an eval. Often line 1 or the
  200. last line will be erroneously reported as the error point. Perlate is careful
  201. to keep the line numbers as seen by Perl consistent with the perlate, but as
  202. Perl sometimes gets confused this isn't always helpful.
  203. The "use strict;" and "use warnings;" pragmas are applied to all perlates.
  204. This is not optional. If you insist on writing bad code, you can write "no
  205. strict; no warnings;" to explicitly turn those off.
  206. This has NOT been tested with threading, which probably means it might not work
  207. with Apache 2. However, I'd be happy to fix any problems with threading, if
  208. you send me a bug report. Also send me a message if you can verify that this
  209. works under Apache 2 and/or threading so I can remove this paragraph.
  210. Recursive perlates are supported and have no known caveats.
  211. =head1 INSTALLATION
  212. This module has no dependencies besides Perl itself. Follow your favorite
  213. standard installation procedure.
  214. =head1 VERSION AND HISTORY
  215. =over
  216. Version 0.94 is likely to be identical to version 1.0. Version 1.0 may contain
  217. incompatible changes, but this is unlikely unless anyone suggests a really good
  218. reason.
  219. =item * Version 0.94, released 2007-12-04. Fixed botched release.
  220. =item * Version 0.92, released 2007-12-03. Added options skip_path and
  221. cache_id. Moved repository to Git. Added Text::Perlate::Apache.
  222. =item * Version 0.91, released 2007-05-23. Renamed the rawperl option to raw.
  223. Renamed the module from Template::Perlate to Text::Perlate. Fixed problem
  224. preventing comments and code from sharing one tag.
  225. =item * Version 0.90, released 2007-03-02.
  226. =back
  227. =head1 SEE ALSO
  228. The source repository is at git://git.devpit.org/Text-Perlate/
  229. Text::Perlate::Apache provides a direct Apache handler.
  230. =head1 AUTHOR
  231. Leif Pedersen, E<lt>bilbo@hobbiton.orgE<gt>
  232. Please send suggestions and bugfixes to this address. Even if you have nothing
  233. to contribute, please send a quick message. I'd like to get an idea of how
  234. many people use this software. Thanks!
  235. =head1 COPYRIGHT AND LICENSE
  236. This may be distributed under the terms below (BSD'ish) or under the GPL.
  237. Copyright (C) 2006-2007 by Leif Pedersen. All rights reserved.
  238. Redistribution and use in source and binary forms, with or without
  239. modification, are permitted provided that the following conditions are
  240. met:
  241. 1. Redistributions of source code must retain the above copyright
  242. notice, this list of conditions and the following disclaimer.
  243. 2. Redistributions in binary form must reproduce the above copyright
  244. notice, this list of conditions and the following disclaimer in the
  245. documentation and/or other materials provided with the
  246. distribution.
  247. THIS SOFTWARE IS PROVIDED BY AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
  248. EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  249. IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  250. PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL AUTHORS OR CONTRIBUTORS BE
  251. LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  252. CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  253. SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  254. BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  255. WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  256. OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  257. ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  258. =cut
  259. our $debug;
  260. sub main {
  261. my ($options) = @_;
  262. # Copy input data for modification
  263. $options = {%$options};
  264. $options->{params} = {%{$options->{params} or {}}};
  265. $options->{path} = ['.', @{$options->{path} or []}];
  266. our $defaults;
  267. foreach my $default (keys %$defaults) {
  268. if($default eq 'params') {
  269. # Override default params with specified params.
  270. %{$options->{$default}} = (
  271. %{$defaults->{$default}},
  272. %{$options->{$default}},
  273. );
  274. } elsif($default eq 'path') {
  275. # Search specified path before default path.
  276. push @{$options->{$default}}, @{$defaults->{$default}};
  277. } elsif($default eq 'input_file' or $default eq 'input_string') {
  278. # input_file and input_string are both overridden by specifying either in $options.
  279. $options->{$default} = $defaults->{$default} unless exists $options->{input_file} or exists $options->{input_string};
  280. } else {
  281. $options->{$default} = $defaults->{$default} unless exists $options->{$default};
  282. }
  283. }
  284. # Add @INC to search path.
  285. push @{$options->{path}}, @INC;
  286. # $package_name is unique for each compilation. This prevents sub names from
  287. # conflicting; since all subs are public and named globally in the current
  288. # package (not in the current lexical scope), if the code declares a sub named
  289. # main() in a simple eval with no package statement, it will replace this
  290. # module's main() on the next execution! Also, declaring a package allows us
  291. # to cache compilations of a module; after eval'ing to compile the perlate, it
  292. # can be executed multiple times by calling ${package_name}::_main() multiple
  293. # times.
  294. #
  295. # The unfortunate side-effect is that these packages are never destroyed, so
  296. # they are a memory leak because global variables in the namespace and Perl's
  297. # infrastructure for the namespace itself are never freed, even if they are not
  298. # used again. (I think all modules that do this have that problem though.)
  299. # The silver lining is that it would be terrible style to declare globals
  300. # inside perlates anyway, and reused compilations don't leak.
  301. #
  302. # Caching is done by simply reusing the package created during the first run.
  303. # Each package is uniquely identified, if possible. (If not, it can't be
  304. # reused.)
  305. my $input;
  306. my $reported_filename; # The filename we tell Perl that the eval'd code is from.
  307. my $package_name;
  308. my $compiled; # True if cached package found
  309. if(defined $options->{input_string}) {
  310. # input from a string
  311. $input = $options->{input_string};
  312. warn "input_string specified without a cache_id (use explicit undef to quiet this warning)" unless exists $options->{cache_id};
  313. if(defined $options->{cache_id}) {
  314. $reported_filename = $options->{cache_id};
  315. $package_name = __PACKAGE__ . "::ExplicitCacheId::" . $options->{cache_id};
  316. print STDERR __PACKAGE__ . ": Using package name ${package_name}.\n" if $debug;
  317. $compiled = eval "\$${package_name}::_compiled";
  318. }
  319. } elsif(defined $options->{input_file}) {
  320. # input from a filename
  321. my $filename = $options->{input_file};
  322. $reported_filename = $filename;
  323. my $fh;
  324. if($options->{skip_path} or $filename =~ qr~^/~s) {
  325. # Use absolute path.
  326. print STDERR __PACKAGE__ . ": Using absolute path: ${filename}.\n" if $debug;
  327. open($fh, "<", $filename) or die "${filename}: $!\n";
  328. } else {
  329. # Search path for relative name.
  330. print STDERR __PACKAGE__ . ": Search path is:\n\t", join("\n\t", @{$options->{path}}), "\n" if $debug;
  331. foreach my $path (@{$options->{path}}) {
  332. print STDERR __PACKAGE__ . ": Searching path: ${path}/${filename}..." if $debug;
  333. if(-e "${path}/${filename}") {
  334. print STDERR __PACKAGE__ . ": found\n" if $debug;
  335. open($fh, "<", "${path}/${filename}") or die "${path}/${filename}: $!\n";
  336. last;
  337. }
  338. print STDERR __PACKAGE__ . ": not found\n" if $debug;
  339. }
  340. unless($fh) {
  341. die "$filename: not found in search path\n";
  342. }
  343. }
  344. # Use the device number, inode number, and mod time to uniquely identify this file in our cache.
  345. my @stat = stat($fh);
  346. die "$filename: successful open() but stat() failed: $!\n" unless @stat;
  347. $package_name = __PACKAGE__ . "::CachedFile::" . $stat[0] . '_' . $stat[1] . '_' . $stat[9];
  348. print STDERR __PACKAGE__ . ": Using package name ${package_name}.\n" if $debug;
  349. $compiled = eval "\$${package_name}::_compiled";
  350. if(not $compiled or $options->{preprocess_only}) {
  351. local $/ = undef;
  352. $input = <$fh>;
  353. }
  354. }
  355. print STDERR __PACKAGE__ . ": Already compiled.\n" if $debug and $compiled;
  356. die "No input specified\n" unless $compiled or defined $input;
  357. # Use a temp package name unless one was assigned above.
  358. unless(defined $package_name) {
  359. our $run_count;
  360. if(defined $run_count) { $run_count++; } else { $run_count = 0; }
  361. $package_name = __PACKAGE__ . "::Uncached::${run_count}";
  362. }
  363. # Untaint input. If it was read from a file, it'll be tainted. It seems
  364. # reasonable to simply trust that the caller won't pass untrusted input as a
  365. # perlate. $input could be undef if $compiled.
  366. if(defined $input) {
  367. $input =~ qr/^(.*)$/s or die "Can't happen!";
  368. $input = $1;
  369. }
  370. if($options->{preprocess_only}) {
  371. print STDERR __PACKAGE__ . ": preprocess_only selected.\n" if $debug;
  372. return preprocess($input);
  373. }
  374. unless($compiled) {
  375. print STDERR __PACKAGE__ . ": Preprocessing.\n" if $debug;
  376. $input = preprocess($input) unless $options->{raw};
  377. print STDERR __PACKAGE__ . ": Compiling.\n" if $debug;
  378. compile($package_name, $reported_filename, $input);
  379. }
  380. print STDERR __PACKAGE__ . ": Running.\n" if $debug;
  381. return run($package_name, $options);
  382. }
  383. # This translates $input into eval'able code, but does not add any supporting
  384. # code.
  385. sub preprocess {
  386. my ($input) = @_;
  387. # Push all the chunks of code onto an array, then join it at the end. This is
  388. # more efficient that concatenating as we go. Track line numbers in $linenum
  389. # because we have to add a newline after every tag in case it contained a
  390. # comment, then tell Perl to restart the line numbering with "#line 10".
  391. my @code_chunks = ();
  392. my $linenum = 0;
  393. until($input eq '') {
  394. unless($input =~ s/^(.*?)\[\[(\-*|\+)(#?)(\s.*?\s)(\-*|\+)\]\]//s or $input =~ s/^(.*)$//s) {
  395. die "Can't happen: didn't match a regex";
  396. }
  397. my $text = $1;
  398. my $strip_pre = $2;
  399. my $comment_flag = $3;
  400. my $code = $4;
  401. my $strip_post = $5;
  402. # Some checking to help find typos
  403. if($text =~ qr/(\[\[.*)/s) {
  404. # $text contains [[
  405. my $tag = $1;
  406. if(not $tag =~ qr/^\[\[(\-*|\+)#?\s/s) {
  407. # [[ would've matched the RE at the top of this loop if it were in this format.
  408. die "Invalid tag after line ${linenum}, missing space after [[ near $tag\n";
  409. } elsif($tag =~ qr/\]\]/s) {
  410. # ]] would've matched the RE at the top of this loop if there were a space
  411. # before it.
  412. die "Invalid tag after line ${linenum}, missing space before ]] near $tag\n";
  413. } elsif(not $tag =~ qr/\]\]/s) {
  414. die "Invalid tag after line ${linenum}, missing ending ]] near $tag\n";
  415. }
  416. die "Invalid tag near after ${linenum}, near $tag (but I can't tell why it's invalid)"; # shouldn't happen
  417. }
  418. if($text =~ qr/(.*?\]\])/s) {
  419. # $text contains ]].
  420. die "Invalid tag after line ${linenum}, extraneous ]] near $1\n";
  421. }
  422. if(defined $code and $code =~ qr/^(.*?\]\])/s) {
  423. # $code contains ]]. This wouldn't slip through unless it didn't match the RE
  424. # at the top of this loop.
  425. my $tag = '[[' . $strip_pre . $1;
  426. die "Invalid tag after line ${linenum}, missing space before ]] near $tag\n";
  427. }
  428. if(defined $code and $code =~ qr/\[\[/s) {
  429. # $code contains [[. There would only be another [[ if there's a missing ]].
  430. my $tag = '[[' . $strip_pre . $code;
  431. die "Invalid tag after line ${linenum}, missing ending ]] near $tag\n";
  432. }
  433. # Strip space as specified by the tag modifiers
  434. my $stripped;
  435. $stripped = '';
  436. if(defined $strip_pre) {
  437. # $strip_pre contains indications from the beginning of the tag about whether
  438. # to strip newlines from the text before the tag. Text generated by the tag is
  439. # never stripped.
  440. if($strip_pre eq '+') {
  441. # A plus behaves just like an infinite number of minuses
  442. $text =~ s/((\r?\n[ \t]*)*)$//s;
  443. $stripped = $1;
  444. } else {
  445. # A minus means strip one newline and the whitespace after it. Multiple
  446. # minuses strip multiple newlines. More minuses than newlines is not an error.
  447. my $num = length($strip_pre);
  448. $text =~ s/((\r?\n[ \t]*){0,$num})$//s;
  449. $stripped = $1;
  450. }
  451. }
  452. # Change $text into eval'able code and append to eval string.
  453. if(defined $text and $text ne '') {
  454. $text =~ s/'/'."'".'/sg;
  455. $text =~ s/\\/'."\\\\".'/sg;
  456. $text = "_echo('$text');";
  457. push @code_chunks, $text;
  458. # Count newlines.
  459. $text =~ s/[^\n]+//sg;
  460. $linenum += length($text);
  461. }
  462. # Hide stripped newlines between statements to keep line numbers consistent.
  463. $stripped =~ s/[^\n]+//sg;
  464. push @code_chunks, $stripped;
  465. $linenum += length($stripped);
  466. $stripped = '';
  467. if(defined $strip_post) {
  468. # $strip_post contains indications from the end of the tag about whether to
  469. # strip newlines from the text after the tag. Text generated by the tag is
  470. # never stripped.
  471. if($strip_post eq '+') {
  472. # A plus behaves just like an infinite number of minuses
  473. $input =~ s/^(([ \t]*\r?\n)*)//s;
  474. $stripped = $1;
  475. } else {
  476. my $num = length($strip_post);
  477. $input =~ s/^(([ \t]*\r?\n){0,$num})//s;
  478. $stripped = $1;
  479. }
  480. }
  481. # Interpret $code
  482. if(defined $code and $code ne '') {
  483. # $code might end in a comment without a trailing newline, so add a newline and
  484. # reset Perl's line numbering.
  485. push @code_chunks, $code unless $comment_flag;
  486. $code =~ s/[^\n]//sg;
  487. $linenum += length($code);
  488. push @code_chunks, "\n#line ${linenum}\n";
  489. }
  490. # Hide stripped newlines between statements to keep line numbers consistent.
  491. $stripped =~ s/[^\n]+//sg;
  492. push @code_chunks, $stripped;
  493. $linenum += length($stripped);
  494. }
  495. # Join with spaces between statements.
  496. return "@code_chunks";
  497. }
  498. sub compile {
  499. my ($package_name, $reported_filename, @code_chunks) = @_;
  500. # Add the setup and tear-down cruft. This can't happen in preprocess() because
  501. # raw perlates need it too.
  502. @code_chunks = (
  503. 'use strict; use warnings;',
  504. # These variables interface with external code.
  505. 'our (@_out, $_options, $_params);',
  506. # Calling _echo() is the only way code emits output.
  507. 'sub _echo { push @_out, @_; }',
  508. # Extra convenience functions.
  509. 'sub _echoifdef { foreach (@_) { _echo $_ if defined $_; } }',
  510. 'sub _get { foreach (@_) { _echo $_params->{$_}; } }',
  511. 'sub _getifdef { foreach (@_) { _echo $_params->{$_} if defined $_ and defined $_params->{$_}; } }',
  512. # Encapsulate the execution in a function so we can call it multiple times (to
  513. # support caching).
  514. 'sub _main {',
  515. # Localize @_out to ensure it frees the memory before returning. This is also
  516. # important to ensure reentrancy for recursion.
  517. 'local @_out = ();',
  518. @code_chunks,
  519. 'return join("", @_out); }',
  520. );
  521. # Compile the code, but don't run it. Run it later by calling
  522. # ${package_name}::_main().
  523. if(defined $reported_filename) {
  524. $reported_filename = "#line 1 ${reported_filename}\n";
  525. } else {
  526. $reported_filename = "";
  527. }
  528. clean_eval("${reported_filename}package ${package_name}; @code_chunks our \$_compiled = 1;");
  529. return ();
  530. }
  531. sub run {
  532. my ($package_name, $options) = @_;
  533. my $out;
  534. # Insert shared variables. Localize them to ensure it frees the memory before
  535. # returning. This is also important to ensure reentrancy for recursion.
  536. eval "
  537. local \$${package_name}::_options = \$options;
  538. local \$${package_name}::_params = \$options->{params};
  539. # RUN THE CODE
  540. (\$out) = clean_eval(\"\${package_name}::_main();\");
  541. ";
  542. die $@ if $@;
  543. # XXX: We should mitigate the memory leak problem by undef'ing globals at the
  544. # end by looping through %{$package_name::} rather than just these. Can we use
  545. # a trick like that to also delete the namespace itself? Of course, this
  546. # should only be done on uncached perlates.
  547. return $out;
  548. }
  549. # This is a separate sub because all its local variables become shared with the
  550. # eval'd code.
  551. sub clean_eval {
  552. print STDERR "--------------------------------\n@_\n--------------------------------\n" if $debug and $debug >= 10;
  553. @_ = eval "@_";
  554. die $@ if $@;
  555. return @_;
  556. }
  557. 1