lib/Lemplate/Directive.pm - lemplate

Data types defined

Source code

  1. package Lemplate::Directive;
  2. use strict;
  3. use warnings;

  4. # VERSION

  5. our $OUTPUT = 'i = i + 1 output[i] =';
  6. our $WHILE_MAX = 1000;

  7. # parser state variable
  8. # only true when inside JAVASCRIPT blocks
  9. our $INJAVASCRIPT = 0;

  10. sub new {
  11.     my $class = shift;

  12.     return bless {}, $class
  13. }

  14. sub template {
  15.     my ($class, $block) = @_;

  16.     return "function() return '' end" unless $block =~ /\S/;

  17.     return <<"...";
  18. function (context)
  19.     if not context then
  20.         return error("Lemplate function called without context\\n")
  21.     end
  22.     local stash = context.stash
  23.     local output = {}
  24.     local i = 0

  25. $block

  26.     return output
  27. end
  28. ...
  29. }

  30. # Try to do 1 .. 10 expansions
  31. sub _attempt_range_expand_val ($) {
  32.     my $val = shift;
  33.     return $val unless
  34.         my ( $from, $to ) = $val =~ m/\s*\[\s*(\S+)\s*\.\.\s*(\S+)\s*\]/;

  35.     die "Range expansion is current supported for positive/negative integer values only (e.g. [ 1 .. 10 ])\nCannot expand: $val" unless $from =~ m/^-?\d+$/ && $to =~ m/^-?\d+$/;

  36.     return join '', '[', join( ',', $from .. $to ), ']';
  37. }

  38. #------------------------------------------------------------------------
  39. # textblock($text)
  40. #------------------------------------------------------------------------

  41. sub textblock {
  42.     my ($class, $text) = @_;
  43.     return $text if $INJAVASCRIPT;
  44.     return "$OUTPUT " . $class->text($text);
  45. }

  46. #------------------------------------------------------------------------
  47. # text($text)
  48. #------------------------------------------------------------------------

  49. sub text {
  50.     my ($class, $text) = @_;
  51.     for ($text) {
  52.         s/([\'\\])/\\$1/g;
  53.         s/\n/\\n/g;
  54.         s/\r/\\r/g;
  55.     }
  56.     return "'" . $text . "'";
  57. }

  58. #------------------------------------------------------------------------
  59. # ident(\@ident)                                             foo.bar(baz)
  60. #------------------------------------------------------------------------

  61. sub ident {
  62.     my ($class, $ident) = @_;
  63.     return "''" unless @$ident;
  64.     my $ns;

  65.     # does the first element of the identifier have a NAMESPACE
  66.     # handler defined?
  67.     if (ref $class && @$ident > 2 && ($ns = $class->{ NAMESPACE })) {
  68.         my $key = $ident->[0];
  69.         $key =~ s/^'(.+)'$/$1/s;
  70.         if ($ns = $ns->{ $key }) {
  71.             return $ns->ident($ident);
  72.         }
  73.     }

  74.     if (scalar @$ident <= 2 && ! $ident->[1]) {
  75.         $ident = $ident->[0];
  76.     }
  77.     else {
  78.         $ident = '{' . join(', ', @$ident) . '}';
  79.     }
  80.     return "stash_get(stash, $ident)";
  81. }


  82. #------------------------------------------------------------------------
  83. # assign(\@ident, $value, $default)                             foo = bar
  84. #------------------------------------------------------------------------

  85. sub assign {
  86.     my ($class, $var, $val, $default) = @_;

  87.     if (ref $var) {
  88.         if (scalar @$var == 2 && ! $var->[1]) {
  89.             $var = $var->[0];
  90.         }
  91.         else {
  92.             $var = '{' . join(', ', @$var) . '}';
  93.         }
  94.     }
  95.     $val_attempt_range_expand_val $val;
  96.     $val .= ', 1' if $default;
  97.     return "stash_set(stash, $var, $val)";
  98. }


  99. #------------------------------------------------------------------------
  100. # args(\@args)                                        foo, bar, baz = qux
  101. #------------------------------------------------------------------------

  102. sub args {
  103.     my ($class, $args) = @_;
  104.     my $hash = shift @$args;
  105.     push(@$args, '{ ' . join(', ', @$hash) . ' }')
  106.         if @$hash;

  107.     return '{}' unless @$args;
  108.     return '{ ' . join(', ', @$args) . ' }';
  109. }


  110. #------------------------------------------------------------------------
  111. # filenames(\@names)
  112. #------------------------------------------------------------------------

  113. sub filenames {
  114.     my ($class, $names) = @_;
  115.     if (@$names > 1) {
  116.         $names = '[ ' . join(', ', @$names) . ' ]';
  117.     }
  118.     else {
  119.         $names = shift @$names;
  120.     }
  121.     return $names;
  122. }


  123. #------------------------------------------------------------------------
  124. # get($expr)                                                    [% foo %]
  125. #------------------------------------------------------------------------

  126. sub get {
  127.     my ($class, $expr) = @_;
  128.     return "$OUTPUT $expr";
  129. }

  130. sub block {
  131.     my ($class, $block) = @_;
  132.     return join "\n", map {
  133.         s/^#(?=line \d+)/-- /gm;
  134.         $_;
  135.     } @{ $block || [] };
  136. }

  137. #------------------------------------------------------------------------
  138. # call($expr)                                              [% CALL bar %]
  139. #------------------------------------------------------------------------

  140. sub call {
  141.     my ($class, $expr) = @_;
  142.     $expr .= ';';
  143.     return $expr;
  144. }


  145. #------------------------------------------------------------------------
  146. # set(\@setlist)                               [% foo = bar, baz = qux %]
  147. #------------------------------------------------------------------------

  148. sub set {
  149.     my ($class, $setlist) = @_;
  150.     my $output;
  151.     while (my ($var, $val) = splice(@$setlist, 0, 2)) {
  152.         $output .= $class->assign($var, $val) . ";\n";
  153.     }
  154.     chomp $output;
  155.     return $output;
  156. }


  157. #------------------------------------------------------------------------
  158. # default(\@setlist)                   [% DEFAULT foo = bar, baz = qux %]
  159. #------------------------------------------------------------------------

  160. sub default {
  161.     my ($class, $setlist) = @_;
  162.     my $output;
  163.     while (my ($var, $val) = splice(@$setlist, 0, 2)) {
  164.         $output .= &assign($class, $var, $val, 1) . ";\n";
  165.     }
  166.     chomp $output;
  167.     return $output;
  168. }


  169. #------------------------------------------------------------------------
  170. # include(\@nameargs)                    [% INCLUDE template foo = bar %]
  171. #         # => [ [ $file, ... ], \@args ]
  172. #------------------------------------------------------------------------

  173. sub include {
  174.     my ($class, $nameargs) = @_;
  175.     my ($file, $args) = @$nameargs;
  176.     my $hash = shift @$args;
  177.     $file = $class->filenames($file);
  178.     (my $raw_file = $file) =~ s/^'|'$//g;
  179.     $Lemplate::ExtraTemplates{$raw_file} = 1;
  180.     my $file2 = "'$Lemplate::TemplateName/$raw_file'";
  181.     my $str_args = (@$hash ? ', { ' . join(', ', @$hash) . ' }' : '');
  182.     return "$OUTPUT context.include(context, template_map['$Lemplate::TemplateName/$raw_file'] and $file2 or $file$str_args)";
  183. }


  184. #------------------------------------------------------------------------
  185. # process(\@nameargs)                    [% PROCESS template foo = bar %]
  186. #         # => [ [ $file, ... ], \@args ]
  187. #------------------------------------------------------------------------

  188. sub process {
  189.     my ($class, $nameargs) = @_;
  190.     my ($file, $args) = @$nameargs;
  191.     my $hash = shift @$args;
  192.     $file = $class->filenames($file);
  193.     (my $raw_file = $file) =~ s/^'|'$//g;
  194.     $Lemplate::ExtraTemplates{$raw_file} = 1;
  195.     $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
  196.     return "$OUTPUT context.process(context, $file)";
  197. }


  198. #------------------------------------------------------------------------
  199. # if($expr, $block, $else)                             [% IF foo < bar %]
  200. #                                                         ...
  201. #                                                      [% ELSE %]
  202. #                                                         ...
  203. #                                                      [% END %]
  204. #------------------------------------------------------------------------

  205. sub if {
  206.     my ($class, $expr, $block, $else) = @_;
  207.     my @else = $else ? @$else : ();
  208.     $else = pop @else;

  209.     my $output = "if tt2_true($expr) then\n$block\n";

  210.     foreach my $elsif (@else) {
  211.         ($expr, $block) = @$elsif;
  212.         $output .= "elseif tt2_true($expr) then\n$block\n";
  213.     }
  214.     if (defined $else) {
  215.         $output .= "else\n$else\nend\n";
  216.     } else {
  217.         $output .= "end\n";
  218.     }

  219.     return $output;
  220. }

  221. #------------------------------------------------------------------------
  222. # foreach($target, $list, $args, $block)    [% FOREACH x = [ foo bar ] %]
  223. #                                              ...
  224. #                                           [% END %]
  225. #------------------------------------------------------------------------

  226. sub foreach {
  227.     my ($class, $target, $list, $args, $block) = @_;
  228.     $args  = shift @$args;
  229.     $args  = @$args ? ', { ' . join(', ', @$args) . ' }' : '';

  230.     my ($loop_save, $loop_set, $loop_restore, $setiter);
  231.     if ($target) {
  232.         $loop_save =
  233.             'local oldloop = ' . $class->ident(["'loop'"]);
  234.         $loop_set = "stash['$target'] = value";
  235.         $loop_restore = "stash_set(stash, 'loop', oldloop)";
  236.     }
  237.     else {
  238.         die "XXX - Not supported yet";
  239.         $loop_save = 'stash = context.localise()';
  240.         $loop_set =
  241.             "stash.get(['import', [value]]) if typeof(value) == 'object'";
  242.         $loop_restore = 'stash = context.delocalise()';
  243.     }

  244.     $list = _attempt_range_expand_val $list;

  245.     return <<EOF;

  246. -- FOREACH
  247. do
  248.     local list = $list
  249.     local iterator
  250.     if list.list then
  251.         iterator = list
  252.         list = list.list
  253.     end
  254.     $loop_save
  255.     local count
  256.     if not iterator then
  257.         count = table_maxn(list)
  258.         iterator = { count = 1, max = count - 1, index = 0, size = count, first = true, last = false, prev = "" }
  259.     else
  260.         count = iterator.size
  261.     end
  262.     stash.loop = iterator
  263.     for idx, value in ipairs(list) do
  264.         if idx == count then
  265.             iterator.last = true
  266.         end
  267.         iterator.index = idx - 1
  268.         iterator.count = idx
  269.         iterator.next = list[idx + 1]
  270.         $loop_set
  271. $block
  272.         iterator.first = false
  273.         iterator.prev = value
  274.     end
  275.     $loop_restore
  276. end
  277. EOF
  278. }


  279. #------------------------------------------------------------------------
  280. # next()                                                       [% NEXT %]
  281. #
  282. # Next iteration of a FOREACH loop (experimental)
  283. #------------------------------------------------------------------------

  284. sub next {
  285.   return <<EOF;
  286.   return error("NEXT not implemented yet")
  287. EOF
  288. }

  289. #------------------------------------------------------------------------
  290. # wrapper(\@nameargs, $block)            [% WRAPPER template foo = bar %]
  291. #          # => [ [$file,...], \@args ]
  292. #------------------------------------------------------------------------
  293. sub wrapper {
  294.     my ($class, $nameargs, $block) = @_;
  295.     my ($file, $args) = @$nameargs;
  296.     my $hash = shift @$args;

  297.     s/ => /: / for @$hash;
  298.     return $class->multi_wrapper($file, $hash, $block)
  299.         if @$file > 1;
  300.     $file = shift @$file;
  301.     push(@$hash, "'content': output");
  302.     $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';

  303.     return <<EOF;

  304. // WRAPPER
  305. $OUTPUT (function() {
  306.     var output = '';
  307. $block;
  308.     return context.include($file);
  309. })();
  310. EOF
  311. }

  312. sub multi_wrapper {
  313.     my ($class, $file, $hash, $block) = @_;

  314.     push(@$hash, "'content': output");
  315.     $hash = @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';

  316.     $file = join(', ', reverse @$file);
  317. #    print STDERR "multi wrapper: $file\n";

  318.     return <<EOF;

  319. // WRAPPER
  320. $OUTPUT (function() {
  321.     var output = '';
  322. $block;
  323.     var files = new Array($file);
  324.     for (var i = 0; i < files.length; i++) {
  325.         output = context.include(files[i]$hash);
  326.     }
  327.     return output;
  328. })();
  329. EOF
  330. }


  331. #------------------------------------------------------------------------
  332. # while($expr, $block)                                 [% WHILE x < 10 %]
  333. #                                                         ...
  334. #                                                      [% END %]
  335. #------------------------------------------------------------------------

  336. sub while {
  337.     my ($class, $expr, $block) = @_;

  338.     return <<EOF;

  339. -- WHILE
  340. do
  341.     local failsafe = $WHILE_MAX;
  342.     while $expr do
  343.         failsafe = failsafe - 1
  344.         if failsafe <= 0 then
  345.             break
  346.         end
  347. $block
  348.     end
  349.     if not failsafe then
  350.         return error("WHILE loop terminated (> $WHILE_MAX iterations)\\n")
  351.     end
  352. end
  353. EOF
  354. }

  355. #------------------------------------------------------------------------
  356. # javascript($script)                                   [% JAVASCRIPT %]
  357. #                                                           ...
  358. #                                                       [% END %]
  359. #------------------------------------------------------------------------
  360. sub javascript {
  361.     my ( $class, $javascript ) = @_;
  362.     return $javascript;
  363. }

  364. sub no_javascript {
  365.     my ( $class ) = @_;
  366.     die "EVAL_JAVASCRIPT has not been enabled, cannot process [% JAVASCRIPT %] blocks";
  367. }

  368. #------------------------------------------------------------------------
  369. # switch($expr, \@case)                                    [% SWITCH %]
  370. #                                                          [% CASE foo %]
  371. #                                                             ...
  372. #                                                          [% END %]
  373. #------------------------------------------------------------------------

  374. sub switch {
  375.     my ($class, $expr, $case) = @_;
  376.     my @case = @$case;
  377.     my ($match, $block, $default);
  378.     my $caseblock = '';

  379.     $default = pop @case;

  380.     foreach $case (@case) {
  381.         $match = $case->[0];
  382.         $block = $case->[1];
  383. #        $block = pad($block, 1) if $PRETTY;
  384.         $caseblock .= <<EOF;
  385. case $match:
  386. $block
  387. break;

  388. EOF
  389.     }

  390.     if (defined $default) {
  391.         $caseblock .= <<EOF;
  392. default:
  393. $default
  394. break;
  395. EOF
  396.     }
  397. #    $caseblock = pad($caseblock, 2) if $PRETTY;

  398. return <<EOF;

  399.     switch($expr) {
  400. $caseblock
  401.     }

  402. EOF
  403. }


  404. #------------------------------------------------------------------------
  405. # throw(\@nameargs)                           [% THROW foo "bar error" %]
  406. #       # => [ [$type], \@args ]
  407. #------------------------------------------------------------------------

  408. sub throw {
  409.     my ($class, $nameargs) = @_;
  410.     my ($type, $args) = @$nameargs;
  411.     my $hash = shift(@$args);
  412.     my $info = shift(@$args);
  413.     $type = shift @$type;

  414.     return qq{return error({$type, $info})};
  415. }


  416. #------------------------------------------------------------------------
  417. # clear()                                                     [% CLEAR %]
  418. #
  419. # NOTE: this is redundant, being hard-coded (for now) into Parser.yp
  420. #------------------------------------------------------------------------

  421. sub clear {
  422.     return "output = {}";
  423. }


  424. #------------------------------------------------------------------------
  425. # break()                                                     [% BREAK %]
  426. #
  427. # NOTE: this is redundant, being hard-coded (for now) into Parser.yp
  428. #------------------------------------------------------------------------

  429. sub break {
  430.     return 'break';
  431. }

  432. #------------------------------------------------------------------------
  433. # return()                                                   [% RETURN %]
  434. #------------------------------------------------------------------------

  435. sub return {
  436.     return "return output"
  437. }


  438. #------------------------------------------------------------------------
  439. # stop()                                                       [% STOP %]
  440. #------------------------------------------------------------------------

  441. sub stop {
  442.     return "return error('Lemplate.STOP\\n' .. concat(output))";
  443. }


  444. #------------------------------------------------------------------------
  445. # use(\@lnameargs)                         [% USE alias = plugin(args) %]
  446. #     # => [ [$file, ...], \@args, $alias ]
  447. #------------------------------------------------------------------------

  448. sub use {
  449.     my ($class, $lnameargs) = @_;
  450.     my ($file, $args, $alias) = @$lnameargs;
  451.     $file = shift @$file;       # same production rule as INCLUDE
  452.     $alias ||= $file;
  453.     $args = &args($class, $args);
  454.     $file .= ", $args" if $args;
  455.     return "-- USE\n"
  456.          . "stash_set(stash, $alias, context.plugin(context, $file))";
  457. }


  458. #------------------------------------------------------------------------
  459. # raw(\@lnameargs)                         [% RAW alias = plugin(args) %]
  460. #     # => [ [$file, ...], \@args, $alias ]
  461. #------------------------------------------------------------------------

  462. sub raw {
  463.     my ($class, $lnameargs) = @_;
  464.     my ($file, $args, $alias) = @$lnameargs;
  465.     $file = shift @$file;       # same production rule as INCLUDE
  466.     $alias ||= $file;
  467.     $args = &args($class, $args);
  468. #    $file .= ", $args" if $args;
  469.     $file =~ s/'|"//g;
  470.     return "// RAW\n"
  471.          . "stash_set(stash, $alias, $file)";
  472. }


  473. #------------------------------------------------------------------------
  474. # stubs()                                                      [% STOP %]
  475. #------------------------------------------------------------------------

  476. sub filter {
  477.     my ($class, $lnameargs, $block) = @_;
  478.     my ($name, $args, $alias) = @$lnameargs;
  479.     $name = shift @$name;
  480.     $args = &args($class, $args);
  481.     $args = $args ? "$args, $alias" : ", null, $alias"
  482.         if $alias;
  483.     $name .= ", $args" if $args;
  484.     return <<EOF;

  485. -- FILTER
  486. local value
  487. do
  488.     local output = {}
  489.     local i = 0

  490. $block

  491.     value = context.filter(output, $name)
  492. end
  493. $OUTPUT value
  494. EOF
  495. }

  496. sub quoted {
  497.     my $class = shift;
  498.     if ( @_ && ref($_[0]) ) {
  499.         return join( " .. ", @{$_[0]} );
  500.     }
  501.     return "return error('QUOTED called with unknown arguments in Lemplate')";
  502. }

  503. #------------------------------------------------------------------------
  504. # macro($name, $block, \@args)
  505. #------------------------------------------------------------------------

  506. sub macro {
  507.     my ($class, $ident, $block, $args) = @_;

  508.     if ($args) {
  509.         $args = join(';', map { "args['$_'] = fargs.shift()" } @$args);

  510.         return <<EOF;

  511. //MACRO
  512. stash.set('$ident', function () {
  513.     var output = '';
  514.     var args = {};
  515.     var fargs = Array.prototype.slice.call(arguments);
  516.     $args;
  517.     args.arguments = Array.prototype.slice.call(arguments);

  518.     var params = fargs.shift() || {};

  519.     for (var key in params) {
  520.         args[key] = params[key];
  521.     }

  522.     context.stash.clone(args);
  523.     try {
  524. $block
  525.     }
  526.     catch(e) {
  527.         var error = context.set_error(e, output);
  528.         throw(error);
  529.     }

  530.     context.stash.declone();
  531.     return output;
  532. });

  533. EOF

  534.     }
  535.     else {
  536.         return <<EOF;

  537. //MACRO

  538. stash.set('$ident', function () {
  539.     var output = '';
  540.     var args = {};

  541.     var fargs = Array.prototype.slice.call(arguments);
  542.     args.arguments = Array.prototype.slice.call(arguments);

  543.     if (typeof arguments[0] == 'object') args = arguments[0];

  544.     context.stash.clone(args);
  545.     try {
  546. $block
  547.     }
  548.     catch(e) {
  549.         var error = context.set_error(e, output);
  550.         throw(error);
  551.     }

  552.     context.stash.declone();
  553.     return output;});

  554. EOF
  555.     }
  556. }

  557. sub capture {
  558.     my ($class, $name, $block) = @_;

  559.     if (ref $name) {
  560.         if (scalar @$name == 2 && ! $name->[1]) {
  561.             $name = $name->[0];
  562.         }
  563.         else {
  564.             $name = '[' . join(', ', @$name) . ']';
  565.         }
  566.     }

  567.     return <<EOF;

  568. // CAPTURE
  569. (function() {
  570.    var output = '';
  571.    $block
  572.    stash.set($name, output);
  573. })();
  574. EOF

  575. }

  576. BEGIN {
  577.     return# Comment out this line to get callback traces
  578.     no strict 'refs';
  579.     my $pkg = __PACKAGE__ . '::';
  580.     my $stash = \ %$pkg;
  581.     use strict 'refs';
  582.     for my $name (keys %$stash) {
  583.         my $glob = $stash->{$name};
  584.         if (*$glob{CODE}) {
  585.             my $code = *$glob{CODE};
  586.             no warnings 'redefine';
  587.             $stash->{$name} = sub {
  588.                 warn "Calling $name(@_)\n";
  589.                 &$code(@_);
  590.             };
  591.         }
  592.     }
  593. }


  594. 1;

  595. __END__

  596. =encoding UTF-8

  597. =head1 NAME

  598. Lemplate::Directive - Lemplate Code Generating Backend

  599. =head1 SYNOPSIS

  600.     use Lemplate::Directive;

  601. =head1 DESCRIPTION

  602. Lemplate::Directive is the analog to Template::Directive, which is the
  603. module that produces that actual code that templates turn into. The
  604. Lemplate version obviously produces Lua code rather than Perl.
  605. Other than that the two modules are almost exactly the same.

  606. =head1 BUGS

  607. Unfortunately, some of the code generation seems to happen before
  608. Lemplate::Directive gets control. So it currently has heuristical code
  609. to rejigger Perl code snippets into Lua. This processing needs to
  610. happen upstream once I get more clarity on how Template::Toolkit works.

  611. =head1 AUTHOR

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

  613. =head1 COPYRIGHT

  614. Copyright (c) 2016. Yichun Zhang (agentzh). All rights reserved.

  615. Copyright (c) 2006-2014. Ingy döt Net. All rights reserved.

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

  618. See L<http://www.perl.com/perl/misc/Artistic.html>

  619. =cut