home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Directive.pm < prev    next >
Encoding:
Perl POD Document  |  2003-10-08  |  26.5 KB  |  1,005 lines
  1. #================================================================= -*-Perl-*- 
  2. #
  3. # Template::Directive
  4. #
  5. # DESCRIPTION
  6. #   Factory module for constructing templates from Perl code.
  7. #
  8. # AUTHOR
  9. #   Andy Wardley   <abw@kfs.org>
  10. #
  11. # WARNING
  12. #   Much of this module is hairy, even furry in places.  It needs
  13. #   a lot of tidying up and may even be moved into a different place 
  14. #   altogether.  The generator code is often inefficient, particulary in 
  15. #   being very anal about pretty-printing the Perl code all neatly, but 
  16. #   at the moment, that's still high priority for the sake of easier
  17. #   debugging.
  18. #
  19. # COPYRIGHT
  20. #   Copyright (C) 1996-2000 Andy Wardley.  All Rights Reserved.
  21. #   Copyright (C) 1998-2000 Canon Research Centre Europe Ltd.
  22. #
  23. #   This module is free software; you can redistribute it and/or
  24. #   modify it under the same terms as Perl itself.
  25. #
  26. #----------------------------------------------------------------------------
  27. #
  28. # $Id: Directive.pm,v 2.18 2003/10/08 09:34:41 abw Exp $
  29. #
  30. #============================================================================
  31.  
  32. package Template::Directive;
  33.  
  34. require 5.004;
  35.  
  36. use strict;
  37. use Template::Base;
  38. use Template::Constants;
  39. use Template::Exception;
  40.  
  41. use base qw( Template::Base );
  42. use vars qw( $VERSION $DEBUG $PRETTY $WHILE_MAX $OUTPUT );
  43.  
  44. $VERSION = sprintf("%d.%02d", q$Revision: 2.18 $ =~ /(\d+)\.(\d+)/);
  45.  
  46. $WHILE_MAX = 1000 unless defined $WHILE_MAX;
  47. $PRETTY    = 0 unless defined $PRETTY;
  48. $OUTPUT    = '$output .= ';
  49.  
  50.  
  51. sub _init {
  52.     my ($self, $config) = @_;
  53.     $self->{ NAMESPACE } = $config->{ NAMESPACE };
  54.     return $self;
  55. }
  56.  
  57.  
  58. sub pad {
  59.     my ($text, $pad) = @_;
  60.     $pad = ' ' x ($pad * 4);
  61.     $text =~ s/^(?!#line)/$pad/gm;
  62.     $text;
  63. }
  64.  
  65. #========================================================================
  66. # FACTORY METHODS
  67. #
  68. # These methods are called by the parser to construct directive instances.
  69. #========================================================================
  70.  
  71. #------------------------------------------------------------------------
  72. # template($block)
  73. #------------------------------------------------------------------------
  74.  
  75. sub template {
  76.     my ($class, $block) = @_;
  77.     $block = pad($block, 2) if $PRETTY;
  78.  
  79.     return "sub { return '' }" unless $block =~ /\S/;
  80.  
  81.     return <<EOF;
  82. sub {
  83.     my \$context = shift || die "template sub called without context\\n";
  84.     my \$stash   = \$context->stash;
  85.     my \$output  = '';
  86.     my \$error;
  87.     
  88.     eval { BLOCK: {
  89. $block
  90.     } };
  91.     if (\$@) {
  92.         \$error = \$context->catch(\$@, \\\$output);
  93.         die \$error unless \$error->type eq 'return';
  94.     }
  95.  
  96.     return \$output;
  97. }
  98. EOF
  99. }
  100.  
  101.  
  102. #------------------------------------------------------------------------
  103. # anon_block($block)                            [% BLOCK %] ... [% END %]
  104. #------------------------------------------------------------------------
  105.  
  106. sub anon_block {
  107.     my ($class, $block) = @_;
  108.     $block = pad($block, 2) if $PRETTY;
  109.  
  110.     return <<EOF;
  111.  
  112. # BLOCK
  113. $OUTPUT do {
  114.     my \$output  = '';
  115.     my \$error;
  116.     
  117.     eval { BLOCK: {
  118. $block
  119.     } };
  120.     if (\$@) {
  121.         \$error = \$context->catch(\$@, \\\$output);
  122.         die \$error unless \$error->type eq 'return';
  123.     }
  124.  
  125.     \$output;
  126. };
  127. EOF
  128. }
  129.  
  130.  
  131. #------------------------------------------------------------------------
  132. # block($blocktext)
  133. #------------------------------------------------------------------------
  134.  
  135. sub block {
  136.     my ($class, $block) = @_;
  137.     return join("\n", @{ $block || [] });
  138. }
  139.  
  140.  
  141. #------------------------------------------------------------------------
  142. # textblock($text)
  143. #------------------------------------------------------------------------
  144.  
  145. sub textblock {
  146.     my ($class, $text) = @_;
  147.     return "$OUTPUT " . &text($class, $text) . ';';
  148. }
  149.  
  150.  
  151. #------------------------------------------------------------------------
  152. # text($text)
  153. #------------------------------------------------------------------------
  154.  
  155. sub text {
  156.     my ($class, $text) = @_;
  157.     for ($text) {
  158.         s/(["\$\@\\])/\\$1/g;
  159.         s/\n/\\n/g;
  160.     }
  161.     return '"' . $text . '"';
  162. }
  163.  
  164.  
  165. #------------------------------------------------------------------------
  166. # quoted(\@items)                                               "foo$bar"
  167. #------------------------------------------------------------------------
  168.  
  169. sub quoted {
  170.     my ($class, $items) = @_;
  171.     return '' unless @$items;
  172.     return ("('' . " . $items->[0] . ')') if scalar @$items == 1;
  173.     return '(' . join(' . ', @$items) . ')';
  174. #    my $r = '(' . join(' . ', @$items) . ' . "")';
  175. #    print STDERR "[$r]\n";
  176. #    return $r;
  177. }
  178.  
  179.  
  180. #------------------------------------------------------------------------
  181. # ident(\@ident)                                             foo.bar(baz)
  182. #------------------------------------------------------------------------
  183.  
  184. sub ident {
  185.     my ($class, $ident) = @_;
  186.     return "''" unless @$ident;
  187.     my $ns;
  188.  
  189.     # does the first element of the identifier have a NAMESPACE
  190.     # handler defined?
  191.     if (ref $class && @$ident > 2 && ($ns = $class->{ NAMESPACE })) {
  192.     my $key = $ident->[0];
  193.     $key =~ s/^'(.+)'$/$1/s;
  194.     if ($ns = $ns->{ $key }) {
  195.         return $ns->ident($ident);
  196.     }
  197.     }
  198.     
  199.     if (scalar @$ident <= 2 && ! $ident->[1]) {
  200.         $ident = $ident->[0];
  201.     }
  202.     else {
  203.         $ident = '[' . join(', ', @$ident) . ']';
  204.     }
  205.     return "\$stash->get($ident)";
  206. }
  207.  
  208. #------------------------------------------------------------------------
  209. # identref(\@ident)                                         \foo.bar(baz)
  210. #------------------------------------------------------------------------
  211.  
  212. sub identref {
  213.     my ($class, $ident) = @_;
  214.     return "''" unless @$ident;
  215.     if (scalar @$ident <= 2 && ! $ident->[1]) {
  216.         $ident = $ident->[0];
  217.     }
  218.     else {
  219.         $ident = '[' . join(', ', @$ident) . ']';
  220.     }
  221.     return "\$stash->getref($ident)";
  222. }
  223.  
  224.  
  225. #------------------------------------------------------------------------
  226. # assign(\@ident, $value, $default)                             foo = bar
  227. #------------------------------------------------------------------------
  228.  
  229. sub assign {
  230.     my ($class, $var, $val, $default) = @_;
  231.  
  232.     if (ref $var) {
  233.         if (scalar @$var == 2 && ! $var->[1]) {
  234.             $var = $var->[0];
  235.         }
  236.         else {
  237.             $var = '[' . join(', ', @$var) . ']';
  238.         }
  239.     }
  240.     $val .= ', 1' if $default;
  241.     return "\$stash->set($var, $val)";
  242. }
  243.  
  244.  
  245. #------------------------------------------------------------------------
  246. # args(\@args)                                        foo, bar, baz = qux
  247. #------------------------------------------------------------------------
  248.  
  249. sub args {
  250.     my ($class, $args) = @_;
  251.     my $hash = shift @$args;
  252.     push(@$args, '{ ' . join(', ', @$hash) . ' }')
  253.         if @$hash;
  254.  
  255.     return '0' unless @$args;
  256.     return '[ ' . join(', ', @$args) . ' ]';
  257. }
  258.  
  259. #------------------------------------------------------------------------
  260. # filenames(\@names)
  261. #------------------------------------------------------------------------
  262.  
  263. sub filenames {
  264.     my ($class, $names) = @_;
  265.     if (@$names > 1) {
  266.         $names = '[ ' . join(', ', @$names) . ' ]';
  267.     }
  268.     else {
  269.         $names = shift @$names;
  270.     }
  271.     return $names;
  272. }
  273.  
  274.  
  275. #------------------------------------------------------------------------
  276. # get($expr)                                                    [% foo %]
  277. #------------------------------------------------------------------------
  278.  
  279. sub get {
  280.     my ($class, $expr) = @_;  
  281.     return "$OUTPUT $expr;";
  282. }
  283.  
  284.  
  285. #------------------------------------------------------------------------
  286. # call($expr)                                              [% CALL bar %]
  287. #------------------------------------------------------------------------
  288.  
  289. sub call {
  290.     my ($class, $expr) = @_;  
  291.     $expr .= ';';
  292.     return $expr;
  293. }
  294.  
  295.  
  296. #------------------------------------------------------------------------
  297. # set(\@setlist)                               [% foo = bar, baz = qux %]
  298. #------------------------------------------------------------------------
  299.  
  300. sub set {
  301.     my ($class, $setlist) = @_;
  302.     my $output;
  303.     while (my ($var, $val) = splice(@$setlist, 0, 2)) {
  304.         $output .= &assign($class, $var, $val) . ";\n";
  305.     }
  306.     chomp $output;
  307.     return $output;
  308. }
  309.  
  310.  
  311. #------------------------------------------------------------------------
  312. # default(\@setlist)                   [% DEFAULT foo = bar, baz = qux %]
  313. #------------------------------------------------------------------------
  314.  
  315. sub default {
  316.     my ($class, $setlist) = @_;  
  317.     my $output;
  318.     while (my ($var, $val) = splice(@$setlist, 0, 2)) {
  319.         $output .= &assign($class, $var, $val, 1) . ";\n";
  320.     }
  321.     chomp $output;
  322.     return $output;
  323. }
  324.  
  325.  
  326. #------------------------------------------------------------------------
  327. # insert(\@nameargs)                                    [% INSERT file %] 
  328. #         # => [ [ $file, ... ], \@args ]
  329. #------------------------------------------------------------------------
  330.  
  331. sub insert {
  332.     my ($class, $nameargs) = @_;
  333.     my ($file, $args) = @$nameargs;
  334.     $file = $class->filenames($file);
  335.     return "$OUTPUT \$context->insert($file);"; 
  336. }
  337.  
  338.  
  339. #------------------------------------------------------------------------
  340. # include(\@nameargs)                    [% INCLUDE template foo = bar %] 
  341. #          # => [ [ $file, ... ], \@args ]    
  342. #------------------------------------------------------------------------
  343.  
  344. sub include {
  345.     my ($class, $nameargs) = @_;
  346.     my ($file, $args) = @$nameargs;
  347.     my $hash = shift @$args;
  348.     $file = $class->filenames($file);
  349.     $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
  350.     return "$OUTPUT \$context->include($file);"; 
  351. }
  352.  
  353.  
  354. #------------------------------------------------------------------------
  355. # process(\@nameargs)                    [% PROCESS template foo = bar %] 
  356. #         # => [ [ $file, ... ], \@args ]
  357. #------------------------------------------------------------------------
  358.  
  359. sub process {
  360.     my ($class, $nameargs) = @_;
  361.     my ($file, $args) = @$nameargs;
  362.     my $hash = shift @$args;
  363.     $file = $class->filenames($file);
  364.     $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
  365.     return "$OUTPUT \$context->process($file);"; 
  366. }
  367.  
  368.  
  369. #------------------------------------------------------------------------
  370. # if($expr, $block, $else)                             [% IF foo < bar %]
  371. #                                                         ...
  372. #                                                      [% ELSE %]
  373. #                                                         ...
  374. #                                                      [% END %]
  375. #------------------------------------------------------------------------
  376.  
  377. sub if {
  378.     my ($class, $expr, $block, $else) = @_;
  379.     my @else = $else ? @$else : ();
  380.     $else = pop @else;
  381.     $block = pad($block, 1) if $PRETTY;
  382.  
  383.     my $output = "if ($expr) {\n$block\n}\n";
  384.  
  385.     foreach my $elsif (@else) {
  386.         ($expr, $block) = @$elsif;
  387.         $block = pad($block, 1) if $PRETTY;
  388.         $output .= "elsif ($expr) {\n$block\n}\n";
  389.     }
  390.     if (defined $else) {
  391.         $else = pad($else, 1) if $PRETTY;
  392.         $output .= "else {\n$else\n}\n";
  393.     }
  394.  
  395.     return $output;
  396. }
  397.  
  398.  
  399. #------------------------------------------------------------------------
  400. # foreach($target, $list, $args, $block)    [% FOREACH x = [ foo bar ] %]
  401. #                                              ...
  402. #                                           [% END %]
  403. #------------------------------------------------------------------------
  404.  
  405. sub foreach {
  406.     my ($class, $target, $list, $args, $block) = @_;
  407.     $args  = shift @$args;
  408.     $args  = @$args ? ', { ' . join(', ', @$args) . ' }' : '';
  409.  
  410.     my ($loop_save, $loop_set, $loop_restore, $setiter);
  411.     if ($target) {
  412.         $loop_save    = 'eval { $oldloop = ' . &ident($class, ["'loop'"]) . ' }';
  413.         $loop_set     = "\$stash->{'$target'} = \$value";
  414.         $loop_restore = "\$stash->set('loop', \$oldloop)";
  415.     }
  416.     else {
  417.         $loop_save    = '$stash = $context->localise()';
  418. #       $loop_set     = "\$stash->set('import', \$value) "
  419. #                       . "if ref \$value eq 'HASH'";
  420.         $loop_set     = "\$stash->get(['import', [\$value]]) "
  421.                         . "if ref \$value eq 'HASH'";
  422.         $loop_restore = '$stash = $context->delocalise()';
  423.     }
  424.     $block = pad($block, 3) if $PRETTY;
  425.  
  426.     return <<EOF;
  427.  
  428. # FOREACH 
  429. do {
  430.     my (\$value, \$error, \$oldloop);
  431.     my \$list = $list;
  432.     
  433.     unless (UNIVERSAL::isa(\$list, 'Template::Iterator')) {
  434.         \$list = Template::Config->iterator(\$list)
  435.             || die \$Template::Config::ERROR, "\\n"; 
  436.     }
  437.  
  438.     (\$value, \$error) = \$list->get_first();
  439.     $loop_save;
  440.     \$stash->set('loop', \$list);
  441.     eval {
  442. LOOP:   while (! \$error) {
  443.             $loop_set;
  444. $block;
  445.             (\$value, \$error) = \$list->get_next();
  446.         }
  447.     };
  448.     $loop_restore;
  449.     die \$@ if \$@;
  450.     \$error = 0 if \$error && \$error eq Template::Constants::STATUS_DONE;
  451.     die \$error if \$error;
  452. };
  453. EOF
  454. }
  455.  
  456. #------------------------------------------------------------------------
  457. # next()                                                       [% NEXT %]
  458. #
  459. # Next iteration of a FOREACH loop (experimental)
  460. #------------------------------------------------------------------------
  461.  
  462. sub next {
  463.     return <<EOF;
  464. (\$value, \$error) = \$list->get_next();
  465. next LOOP;
  466. EOF
  467. }
  468.  
  469.  
  470. #------------------------------------------------------------------------
  471. # wrapper(\@nameargs, $block)            [% WRAPPER template foo = bar %] 
  472. #          # => [ [$file,...], \@args ]    
  473. #------------------------------------------------------------------------
  474.  
  475. sub wrapper {
  476.     my ($class, $nameargs, $block) = @_;
  477.     my ($file, $args) = @$nameargs;
  478.     my $hash = shift @$args;
  479.  
  480.     local $" = ', ';
  481. #    print STDERR "wrapper([@$file], { @$hash })\n";
  482.  
  483.     return $class->multi_wrapper($file, $hash, $block)
  484.         if @$file > 1;
  485.     $file = shift @$file;
  486.  
  487.     $block = pad($block, 1) if $PRETTY;
  488.     push(@$hash, "'content'", '$output');
  489.     $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
  490.  
  491.     return <<EOF;
  492.  
  493. # WRAPPER
  494. $OUTPUT do {
  495.     my \$output = '';
  496. $block
  497.     \$context->include($file); 
  498. };
  499. EOF
  500. }
  501.  
  502.  
  503. sub multi_wrapper {
  504.     my ($class, $file, $hash, $block) = @_;
  505.     $block = pad($block, 1) if $PRETTY;
  506.  
  507.     push(@$hash, "'content'", '$output');
  508.     $hash = @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
  509.  
  510.     $file = join(', ', reverse @$file);
  511. #    print STDERR "multi wrapper: $file\n";
  512.  
  513.     return <<EOF;
  514.  
  515. # WRAPPER
  516. $OUTPUT do {
  517.     my \$output = '';
  518. $block
  519.     foreach ($file) {
  520.         \$output = \$context->include(\$_$hash); 
  521.     }
  522.     \$output;
  523. };
  524. EOF
  525. }
  526.  
  527.  
  528. #------------------------------------------------------------------------
  529. # while($expr, $block)                                 [% WHILE x < 10 %]
  530. #                                                         ...
  531. #                                                      [% END %]
  532. #------------------------------------------------------------------------
  533.  
  534. sub while {
  535.     my ($class, $expr, $block) = @_;
  536.     $block = pad($block, 2) if $PRETTY;
  537.  
  538.     return <<EOF;
  539.  
  540. # WHILE
  541. do {
  542.     my \$failsafe = $WHILE_MAX;
  543. LOOP:
  544.     while (--\$failsafe && ($expr)) {
  545. $block
  546.     }
  547.     die "WHILE loop terminated (> $WHILE_MAX iterations)\\n"
  548.         unless \$failsafe;
  549. };
  550. EOF
  551. }
  552.  
  553.  
  554. #------------------------------------------------------------------------
  555. # switch($expr, \@case)                                    [% SWITCH %]
  556. #                                                          [% CASE foo %]
  557. #                                                             ...
  558. #                                                          [% END %]
  559. #------------------------------------------------------------------------
  560.  
  561. sub switch {
  562.     my ($class, $expr, $case) = @_;
  563.     my @case = @$case;
  564.     my ($match, $block, $default);
  565.     my $caseblock = '';
  566.  
  567.     $default = pop @case;
  568.  
  569.     foreach $case (@case) {
  570.         $match = $case->[0];
  571.         $block = $case->[1];
  572.         $block = pad($block, 1) if $PRETTY;
  573.         $caseblock .= <<EOF;
  574. \$match = $match;
  575. \$match = [ \$match ] unless ref \$match eq 'ARRAY';
  576. if (grep(/^\$result\$/, \@\$match)) {
  577. $block
  578.     last SWITCH;
  579. }
  580. EOF
  581.     }
  582.  
  583.     $caseblock .= $default
  584.         if defined $default;
  585.     $caseblock = pad($caseblock, 2) if $PRETTY;
  586.  
  587. return <<EOF;
  588.  
  589. # SWITCH
  590. do {
  591.     my \$result = $expr;
  592.     my \$match;
  593.     SWITCH: {
  594. $caseblock
  595.     }
  596. };
  597. EOF
  598. }
  599.  
  600.  
  601. #------------------------------------------------------------------------
  602. # try($block, \@catch)                                        [% TRY %]
  603. #                                                                ...
  604. #                                                             [% CATCH %] 
  605. #                                                                ...
  606. #                                                             [% END %]
  607. #------------------------------------------------------------------------
  608.  
  609. sub try {
  610.     my ($class, $block, $catch) = @_;
  611.     my @catch = @$catch;
  612.     my ($match, $mblock, $default, $final, $n);
  613.     my $catchblock = '';
  614.     my $handlers = [];
  615.  
  616.     $block = pad($block, 2) if $PRETTY;
  617.     $final = pop @catch;
  618.     $final = "# FINAL\n" . ($final ? "$final\n" : '')
  619.            . 'die $error if $error;' . "\n" . '$output;';
  620.     $final = pad($final, 1) if $PRETTY;
  621.  
  622.     $n = 0;
  623.     foreach $catch (@catch) {
  624.         $match = $catch->[0] || do {
  625.             $default ||= $catch->[1];
  626.             next;
  627.         };
  628.         $mblock = $catch->[1];
  629.         $mblock = pad($mblock, 1) if $PRETTY;
  630.         push(@$handlers, "'$match'");
  631.         $catchblock .= $n++ 
  632.             ? "elsif (\$handler eq '$match') {\n$mblock\n}\n" 
  633.                : "if (\$handler eq '$match') {\n$mblock\n}\n";
  634.     }
  635.     $catchblock .= "\$error = 0;";
  636.     $catchblock = pad($catchblock, 3) if $PRETTY;
  637.     if ($default) {
  638.         $default = pad($default, 1) if $PRETTY;
  639.         $default = "else {\n    # DEFAULT\n$default\n    \$error = '';\n}";
  640.     }
  641.     else {
  642.         $default = '# NO DEFAULT';
  643.     }
  644.     $default = pad($default, 2) if $PRETTY;
  645.  
  646.     $handlers = join(', ', @$handlers);
  647. return <<EOF;
  648.  
  649. # TRY
  650. $OUTPUT do {
  651.     my \$output = '';
  652.     my (\$error, \$handler);
  653.     eval {
  654. $block
  655.     };
  656.     if (\$@) {
  657.         \$error = \$context->catch(\$@, \\\$output);
  658.         die \$error if \$error->type =~ /^return|stop\$/;
  659.         \$stash->set('error', \$error);
  660.         \$stash->set('e', \$error);
  661.         if (defined (\$handler = \$error->select_handler($handlers))) {
  662. $catchblock
  663.         }
  664. $default
  665.     }
  666. $final
  667. };
  668. EOF
  669. }
  670.  
  671.  
  672. #------------------------------------------------------------------------
  673. # throw(\@nameargs)                           [% THROW foo "bar error" %]
  674. #       # => [ [$type], \@args ]
  675. #------------------------------------------------------------------------
  676.  
  677. sub throw {
  678.     my ($class, $nameargs) = @_;
  679.     my ($type, $args) = @$nameargs;
  680.     my $hash = shift(@$args);
  681.     my $info = shift(@$args);
  682.     $type = shift @$type;           # uses same parser production as INCLUDE
  683.                                     # etc., which allow multiple names
  684.                                     # e.g. INCLUDE foo+bar+baz
  685.  
  686.     if (! $info) {
  687.         $args = "$type, undef";
  688.     }
  689.     elsif (@$hash || @$args) {
  690.         local $" = ', ';
  691.         my $i = 0;
  692.         $args = "$type, { args => [ " 
  693.               . join(', ', $info, @$args) 
  694.               . ' ], '
  695.               . join(', ', 
  696.                      (map { "'" . $i++ . "' => $_" } ($info, @$args)),
  697.                      @$hash)
  698.               . ' }';
  699.     }
  700.     else {
  701.         $args = "$type, $info";
  702.     }
  703.     
  704.     return "\$context->throw($args, \\\$output);";
  705. }
  706.  
  707.  
  708. #------------------------------------------------------------------------
  709. # clear()                                                     [% CLEAR %]
  710. #
  711. # NOTE: this is redundant, being hard-coded (for now) into Parser.yp
  712. #------------------------------------------------------------------------
  713.  
  714. sub clear {
  715.     return "\$output = '';";
  716. }
  717.  
  718. #------------------------------------------------------------------------
  719. # break()                                                     [% BREAK %]
  720. #
  721. # NOTE: this is redundant, being hard-coded (for now) into Parser.yp
  722. #------------------------------------------------------------------------
  723.  
  724. sub break {
  725.     return 'last LOOP;';
  726. }
  727.  
  728. #------------------------------------------------------------------------
  729. # return()                                                   [% RETURN %]
  730. #------------------------------------------------------------------------
  731.  
  732. sub return {
  733.     return "\$context->throw('return', '', \\\$output);";
  734. }
  735.  
  736. #------------------------------------------------------------------------
  737. # stop()                                                       [% STOP %]
  738. #------------------------------------------------------------------------
  739.  
  740. sub stop {
  741.     return "\$context->throw('stop', '', \\\$output);";
  742. }
  743.  
  744.  
  745. #------------------------------------------------------------------------
  746. # use(\@lnameargs)                         [% USE alias = plugin(args) %]
  747. #     # => [ [$file, ...], \@args, $alias ]
  748. #------------------------------------------------------------------------
  749.  
  750. sub use {
  751.     my ($class, $lnameargs) = @_;
  752.     my ($file, $args, $alias) = @$lnameargs;
  753.     $file = shift @$file;       # same production rule as INCLUDE
  754.     $alias ||= $file;
  755.     $args = &args($class, $args);
  756.     $file .= ", $args" if $args;
  757. #    my $set = &assign($class, $alias, '$plugin'); 
  758.     return "# USE\n"
  759.          . "\$stash->set($alias,\n"
  760.          . "            \$context->plugin($file));";
  761. }
  762.  
  763. #------------------------------------------------------------------------
  764. # view(\@nameargs, $block)                           [% VIEW name args %]
  765. #     # => [ [$file, ... ], \@args ]
  766. #------------------------------------------------------------------------
  767.  
  768. sub view {
  769.     my ($class, $nameargs, $block, $defblocks) = @_;
  770.     my ($name, $args) = @$nameargs;
  771.     my $hash = shift @$args;
  772.     $name = shift @$name;       # same production rule as INCLUDE
  773.     $block = pad($block, 1) if $PRETTY;
  774.  
  775.     if (%$defblocks) {
  776.         $defblocks = join(",\n", map { "'$_' => $defblocks->{ $_ }" }
  777.                                 keys %$defblocks);
  778.         $defblocks = pad($defblocks, 1) if $PRETTY;
  779.         $defblocks = "{\n$defblocks\n}";
  780.         push(@$hash, "'blocks'", $defblocks);
  781.     }
  782.     $hash = @$hash ? '{ ' . join(', ', @$hash) . ' }' : '';
  783.  
  784.     return <<EOF;
  785. # VIEW
  786. do {
  787.     my \$output = '';
  788.     my \$oldv = \$stash->get('view');
  789.     my \$view = \$context->view($hash);
  790.     \$stash->set($name, \$view);
  791.     \$stash->set('view', \$view);
  792.  
  793. $block
  794.  
  795.     \$stash->set('view', \$oldv);
  796.     \$view->seal();
  797.     \$output;
  798. };
  799. EOF
  800. }
  801.  
  802.  
  803. #------------------------------------------------------------------------
  804. # perl($block)
  805. #------------------------------------------------------------------------
  806.  
  807. sub perl {
  808.     my ($class, $block) = @_;
  809.     $block = pad($block, 1) if $PRETTY;
  810.  
  811.     return <<EOF;
  812.  
  813. # PERL
  814. \$context->throw('perl', 'EVAL_PERL not set')
  815.     unless \$context->eval_perl();
  816.  
  817. $OUTPUT do {
  818.     my \$output = "package Template::Perl;\\n";
  819.  
  820. $block
  821.  
  822.     local(\$Template::Perl::context) = \$context;
  823.     local(\$Template::Perl::stash)   = \$stash;
  824.  
  825.     my \$result = '';
  826.     tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$result;
  827.     my \$save_stdout = select *Template::Perl::PERLOUT;
  828.  
  829.     eval \$output;
  830.     select \$save_stdout;
  831.     \$context->throw(\$@) if \$@;
  832.     \$result;
  833. };
  834. EOF
  835. }
  836.  
  837.  
  838. #------------------------------------------------------------------------
  839. # no_perl()
  840. #------------------------------------------------------------------------
  841.  
  842. sub no_perl {
  843.     my $class = shift;
  844.     return "\$context->throw('perl', 'EVAL_PERL not set');";
  845. }
  846.  
  847.  
  848. #------------------------------------------------------------------------
  849. # rawperl($block)
  850. #
  851. # NOTE: perhaps test context EVAL_PERL switch at compile time rather than
  852. # runtime?
  853. #------------------------------------------------------------------------
  854.  
  855. sub rawperl {
  856.     my ($class, $block, $line) = @_;
  857.     for ($block) {
  858.         s/^\n+//;
  859.         s/\n+$//;
  860.     }
  861.     $block = pad($block, 1) if $PRETTY;
  862.     $line = $line ? " (starting line $line)" : '';
  863.  
  864.     return <<EOF;
  865. # RAWPERL
  866. #line 1 "RAWPERL block$line"
  867. $block
  868. EOF
  869. }
  870.  
  871.  
  872.  
  873. #------------------------------------------------------------------------
  874. # filter()
  875. #------------------------------------------------------------------------
  876.  
  877. sub filter {
  878.     my ($class, $lnameargs, $block) = @_;
  879.     my ($name, $args, $alias) = @$lnameargs;
  880.     $name = shift @$name;
  881.     $args = &args($class, $args);
  882.     $args = $args ? "$args, $alias" : ", undef, $alias"
  883.         if $alias;
  884.     $name .= ", $args" if $args;
  885.     $block = pad($block, 1) if $PRETTY;
  886.  
  887.     return <<EOF;
  888.  
  889. # FILTER
  890. $OUTPUT do {
  891.     my \$output = '';
  892.     my \$filter = \$context->filter($name)
  893.               || \$context->throw(\$context->error);
  894.  
  895. $block
  896.     
  897.     &\$filter(\$output);
  898. };
  899. EOF
  900. }
  901.  
  902.  
  903. #------------------------------------------------------------------------
  904. # capture($name, $block)
  905. #------------------------------------------------------------------------
  906.  
  907. sub capture {
  908.     my ($class, $name, $block) = @_;
  909.  
  910.     if (ref $name) {
  911.         if (scalar @$name == 2 && ! $name->[1]) {
  912.             $name = $name->[0];
  913.         }
  914.         else {
  915.             $name = '[' . join(', ', @$name) . ']';
  916.         }
  917.     }
  918.     $block = pad($block, 1) if $PRETTY;
  919.  
  920.     return <<EOF;
  921.  
  922. # CAPTURE
  923. \$stash->set($name, do {
  924.     my \$output = '';
  925. $block
  926.     \$output;
  927. });
  928. EOF
  929.  
  930. }
  931.  
  932.  
  933. #------------------------------------------------------------------------
  934. # macro($name, $block, \@args)
  935. #------------------------------------------------------------------------
  936.  
  937. sub macro {
  938.     my ($class, $ident, $block, $args) = @_;
  939.     $block = pad($block, 2) if $PRETTY;
  940.  
  941.     if ($args) {
  942.         my $nargs = scalar @$args;
  943.         $args = join(', ', map { "'$_'" } @$args);
  944.         $args = $nargs > 1 
  945.             ? "\@args{ $args } = splice(\@_, 0, $nargs)"
  946.             : "\$args{ $args } = shift";
  947.  
  948.         return <<EOF;
  949.  
  950. # MACRO
  951. \$stash->set('$ident', sub {
  952.     my \$output = '';
  953.     my (%args, \$params);
  954.     $args;
  955.     \$params = shift;
  956.     \$params = { } unless ref(\$params) eq 'HASH';
  957.     \$params = { \%args, %\$params };
  958.  
  959.     my \$stash = \$context->localise(\$params);
  960.     eval {
  961. $block
  962.     };
  963.     \$stash = \$context->delocalise();
  964.     die \$@ if \$@;
  965.     return \$output;
  966. });
  967. EOF
  968.  
  969.     }
  970.     else {
  971.         return <<EOF;
  972.  
  973. # MACRO
  974. \$stash->set('$ident', sub {
  975.     my \$params = \$_[0] if ref(\$_[0]) eq 'HASH';
  976.     my \$output = '';
  977.  
  978.     my \$stash = \$context->localise(\$params);
  979.     eval {
  980. $block
  981.     };
  982.     \$stash = \$context->delocalise();
  983.     die \$@ if \$@;
  984.     return \$output;
  985. });
  986. EOF
  987.     }
  988. }
  989.  
  990.  
  991. sub debug {
  992.     my ($class, $nameargs) = @_;
  993.     my ($file, $args) = @$nameargs;
  994.     my $hash = shift @$args;
  995.     $args  = join(', ', @$file, @$args);
  996.     $args .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
  997.     return "$OUTPUT \$context->debugging($args); ## DEBUG ##"; 
  998. }
  999.  
  1000.  
  1001. 1;
  1002.  
  1003. __END__
  1004.  
  1005.