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