Edit File - File Manager

Edit File: Directive.pm

#================================================================= -*-Perl-*-
#
# Template::Directive
#
# DESCRIPTION
#   Factory module for constructing templates from Perl code.
#
# AUTHOR
#   Andy Wardley   <abw@wardley.org>
#
# WARNING
#   Much of this module is hairy, even furry in places.  It needs
#   a lot of tidying up and may even be moved into a different place
#   altogether.  The generator code is often inefficient, particularly in
#   being very anal about pretty-printing the Perl code all neatly, but
#   at the moment, that's still high priority for the sake of easier
#   debugging.
#
# COPYRIGHT
#   Copyright (C) 1996-2022 Andy Wardley.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#============================================================================

package Template::Directive;

use strict;
use warnings;
use base 'Template::Base';
use Template::Constants;
use Template::Exception;

our $VERSION   = '3.100';
our $DEBUG     = 0 unless defined $DEBUG;
our $WHILE_MAX = 1000 unless defined $WHILE_MAX;
our $PRETTY    = 0 unless defined $PRETTY;
our $OUTPUT    = '$output .= ';

sub _init {
    my ($self, $config) = @_;
    $self->{ NAMESPACE } = $config->{ NAMESPACE };
    return $self;
}

sub trace_vars {
    my $self = shift;
    return @_
        ? ($self->{ TRACE_VARS } = shift)
        :  $self->{ TRACE_VARS };
}

sub pad {
    my ($text, $pad) = @_;
    $pad = ' ' x ($pad * 4);
    $text =~ s/^(?!#line)/$pad/gm;
    $text;
}

#========================================================================
# FACTORY METHODS
#
# These methods are called by the parser to construct directive instances.
#========================================================================

#------------------------------------------------------------------------
# template($block)
#------------------------------------------------------------------------

sub template {
    my ($self, $block) = @_;
    $block = pad($block, 2) if $PRETTY;

return "sub { return '' }" unless $block =~ /\S/;

return <<EOF;
sub {
    my \$context = shift || die "template sub called without context\\n";
    my \$stash   = \$context->stash;
    my \$output  = '';
    my \$_tt_error;

eval { BLOCK: {
$block
    } };
    if (\$@) {
        \$_tt_error = \$context->catch(\$@, \\\$output);
        die \$_tt_error unless \$_tt_error->type eq 'return';
    }

return \$output;
}
EOF
}

#------------------------------------------------------------------------
# anon_block($block)                            [% BLOCK %] ... [% END %]
#------------------------------------------------------------------------

sub anon_block {
    my ($self, $block) = @_;
    $block = pad($block, 2) if $PRETTY;

return <<EOF;

# BLOCK
$OUTPUT do {
    my \$output  = '';
    my \$_tt_error;

eval { BLOCK: {
$block
    } };
    if (\$@) {
        \$_tt_error = \$context->catch(\$@, \\\$output);
        die \$_tt_error unless \$_tt_error->type eq 'return';
    }

\$output;
};
EOF
}

#------------------------------------------------------------------------
# block($blocktext)
#------------------------------------------------------------------------

sub block {
    my ($self, $block) = @_;
    return join("\n", @{ $block || [] });
}

#------------------------------------------------------------------------
# textblock($text)
#------------------------------------------------------------------------

sub textblock {
    my ($self, $text) = @_;
    return "$OUTPUT " . &text($self, $text) . ';';
}

#------------------------------------------------------------------------
# text($text)
#------------------------------------------------------------------------

sub text {
    my ( $self, $text ) = @_;

return '' if !length $text;

if ( $text =~ tr{$@\\}{} ) {
        $text =~ s/(["\$\@\\])/\\$1/g;
        $text =~ s/\n/\\n/g;
        return '"' . $text . '"';
    }

$text =~ s{'}{\\'}g if index( $text, q{'} ) != -1;
    return q{'} . $text . q{'};
}

#------------------------------------------------------------------------
# quoted(\@items)                                               "foo$bar"
#------------------------------------------------------------------------

sub quoted {
    my ($self, $items) = @_;
    return '' unless @$items;
    return ("('' . " . $items->[0] . ')') if scalar @$items == 1;
    return '(' . join(' . ', @$items) . ')';
#    my $r = '(' . join(' . ', @$items) . ' . "")';
#    print STDERR "[$r]\n";
#    return $r;
}

#------------------------------------------------------------------------
# ident(\@ident)                                             foo.bar(baz)
#------------------------------------------------------------------------

sub ident {
    my ($self, $ident) = @_;
    return "''" unless @$ident;
    my $ns;

# Careful!  Template::Parser always creates a Template::Directive object
    # (as of v2.22_1) so $self is usually an object.  However, we used to
    # allow Template::Directive methods to be called as class methods and
    # Template::Namespace::Constants module takes advantage of this fact
    # by calling Template::Directive->ident() when it needs to generate an
    # identifier.  This hack guards against Mr Fuckup from coming to town
    # when that happens.

if (ref $self) {
        # trace variable usage
        if ($self->{ TRACE_VARS }) {
            my $root = $self->{ TRACE_VARS };
            my $n    = 0;
            my $v;
            while ($n < @$ident) {
                $v = $ident->[$n];
                for ($v) { s/^'//; s/'$// };
                $root = $root->{ $v } ||= { };
                $n += 2;
            }
        }

# does the first element of the identifier have a NAMESPACE
        # handler defined?
        if (@$ident > 2 && ($ns = $self->{ NAMESPACE })) {
            my $key = $ident->[0];

# a faster alternate to $key =~ s/^'(.+)'$/$1/s
            if ( index( $key, q[']) == 0 ) {
                substr( $key, 0, 1, '' );
                substr( $key, -1, 1, '' ); # remove the last char blindly
            }

if ($ns = $ns->{ $key }) {
                return $ns->ident($ident);
            }
        }
    }

if (scalar @$ident <= 2 && ! $ident->[1]) {
        $ident = $ident->[0];
    }
    else {
        $ident = '[' . join(', ', @$ident) . ']';
    }
    return "\$stash->get($ident)";
}

#------------------------------------------------------------------------
# identref(\@ident)                                         \foo.bar(baz)
#------------------------------------------------------------------------

sub identref {
    my ($self, $ident) = @_;
    return "''" unless @$ident;
    if (scalar @$ident <= 2 && ! $ident->[1]) {
        $ident = $ident->[0];
    }
    else {
        $ident = '[' . join(', ', @$ident) . ']';
    }
    return "\$stash->getref($ident)";
}

#------------------------------------------------------------------------
# assign(\@ident, $value, $default)                             foo = bar
#------------------------------------------------------------------------

sub assign {
    my ($self, $var, $val, $default) = @_;

if (ref $var) {
        if (scalar @$var == 2 && ! $var->[1]) {
            $var = $var->[0];
        }
        else {
            $var = '[' . join(', ', @$var) . ']';
        }
    }
    $val .= ', 1' if $default;
    return "\$stash->set($var, $val)";
}

#------------------------------------------------------------------------
# args(\@args)                                        foo, bar, baz = qux
#------------------------------------------------------------------------

sub args {
    my ($self, $args) = @_;
    my $hash = shift @$args;
    push(@$args, '{ ' . join(', ', @$hash) . ' }')
        if @$hash;

return '0' unless @$args;
    return '[ ' . join(', ', @$args) . ' ]';
}

#------------------------------------------------------------------------
# filenames(\@names)
#------------------------------------------------------------------------

sub filenames {
    my ($self, $names) = @_;
    if (@$names > 1) {
        $names = '[ ' . join(', ', @$names) . ' ]';
    }
    else {
        $names = shift @$names;
    }
    return $names;
}

#------------------------------------------------------------------------
# get($expr)                                                    [% foo %]
#------------------------------------------------------------------------

sub get {
    my ($self, $expr) = @_;
    return "$OUTPUT $expr;";
}

#------------------------------------------------------------------------
# call($expr)                                              [% CALL bar %]
#------------------------------------------------------------------------

sub call {
    my ($self, $expr) = @_;
    $expr .= ';';
    return $expr;
}

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

sub set {
    my ($self, $setlist) = @_;
    my $output;
    while (my ($var, $val) = splice(@$setlist, 0, 2)) {
        $output .= &assign($self, $var, $val) . ";\n";
    }
    chomp $output;
    return $output;
}

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

sub default {
    my ($self, $setlist) = @_;
    my $output;
    while (my ($var, $val) = splice(@$setlist, 0, 2)) {
        $output .= &assign($self, $var, $val, 1) . ";\n";
    }
    chomp $output;
    return $output;
}

#------------------------------------------------------------------------
# insert(\@nameargs)                                    [% INSERT file %]
#         # => [ [ $file, ... ], \@args ]
#------------------------------------------------------------------------

sub insert {
    my ($self, $nameargs) = @_;
    my ($file, $args) = @$nameargs;
    $file = $self->filenames($file);
    return "$OUTPUT \$context->insert($file);";
}

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

sub include {
    my ($self, $nameargs) = @_;
    my ($file, $args) = @$nameargs;
    my $hash = shift @$args;
    $file = $self->filenames($file);
    $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
    return "$OUTPUT \$context->include($file);";
}

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

sub process {
    my ($self, $nameargs) = @_;
    my ($file, $args) = @$nameargs;
    my $hash = shift @$args;
    $file = $self->filenames($file);
    $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
    return "$OUTPUT \$context->process($file);";
}

#------------------------------------------------------------------------
# if($expr, $block, $else)                             [% IF foo < bar %]
#                                                         ...
#                                                      [% ELSE %]
#                                                         ...
#                                                      [% END %]
#------------------------------------------------------------------------

sub if {
    my ($self, $expr, $block, $else) = @_;
    my @else = $else ? @$else : ();
    $else = pop @else;
    $block = pad($block, 1) if $PRETTY;

my $output = "if ($expr) {\n$block\n}\n";

foreach my $elsif (@else) {
        ($expr, $block) = @$elsif;
        $block = pad($block, 1) if $PRETTY;
        $output .= "elsif ($expr) {\n$block\n}\n";
    }
    if (defined $else) {
        $else = pad($else, 1) if $PRETTY;
        $output .= "else {\n$else\n}\n";
    }

return $output;
}

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

sub foreach {
    my ($self, $target, $list, $args, $block, $label) = @_;
    $args  = shift @$args;
    $args  = @$args ? ', { ' . join(', ', @$args) . ' }' : '';
    $label ||= 'LOOP';

my ($loop_save, $loop_set, $loop_restore, $setiter);
    if ($target) {
        $loop_save    = 'eval { $_tt_oldloop = ' . &ident($self, ["'loop'"]) . ' }';
        $loop_set     = "\$stash->{'$target'} = \$_tt_value";
        $loop_restore = "\$stash->set('loop', \$_tt_oldloop)";
    }
    else {
        $loop_save    = '$stash = $context->localise()';
#       $loop_set     = "\$stash->set('import', \$_tt_value) "
#                       . "if ref \$value eq 'HASH'";
        $loop_set     = "\$stash->get(['import', [\$_tt_value]]) "
                        . "if ref \$_tt_value eq 'HASH'";
        $loop_restore = '$stash = $context->delocalise()';
    }
    $block = pad($block, 3) if $PRETTY;

return <<EOF;

# FOREACH
do {
    my (\$_tt_value, \$_tt_error, \$_tt_oldloop);
    my \$_tt_list = $list;

unless (UNIVERSAL::isa(\$_tt_list, 'Template::Iterator')) {
        \$_tt_list = Template::Config->iterator(\$_tt_list)
            || die \$Template::Config::ERROR, "\\n";
    }

(\$_tt_value, \$_tt_error) = \$_tt_list->get_first();
    $loop_save;
    \$stash->set('loop', \$_tt_list);
    eval {
$label:   while (! \$_tt_error) {
            $loop_set;
$block;
            (\$_tt_value, \$_tt_error) = \$_tt_list->get_next();
        }
    };
    $loop_restore;
    die \$@ if \$@;
    \$_tt_error = 0 if \$_tt_error && \$_tt_error eq Template::Constants::STATUS_DONE;
    die \$_tt_error if \$_tt_error;
};
EOF
}

#------------------------------------------------------------------------
# next()                                                       [% NEXT %]
#
# Next iteration of a FOREACH loop (experimental)
#------------------------------------------------------------------------

sub next {
    my ($self, $label) = @_;
    $label ||= 'LOOP';
    return <<EOF;
(\$_tt_value, \$_tt_error) = \$_tt_list->get_next();
next $label;
EOF
}

#------------------------------------------------------------------------
# wrapper(\@nameargs, $block)            [% WRAPPER template foo = bar %]
#          # => [ [$file,...], \@args ]
#------------------------------------------------------------------------

sub wrapper {
    my ($self, $nameargs, $block) = @_;
    my ($file, $args) = @$nameargs;
    my $hash = shift @$args;

local $" = ', ';
#    print STDERR "wrapper([@$file], { @$hash })\n";

return $self->multi_wrapper($file, $hash, $block)
        if @$file > 1;
    $file = shift @$file;

$block = pad($block, 1) if $PRETTY;
    push(@$hash, "'content'", '$output');
    $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';

return <<EOF;

# WRAPPER
$OUTPUT do {
    my \$output = '';
$block
    \$context->include($file);
};
EOF
}

sub multi_wrapper {
    my ($self, $file, $hash, $block) = @_;
    $block = pad($block, 1) if $PRETTY;

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

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

return <<EOF;

# WRAPPER
$OUTPUT do {
    my \$output = '';
$block
    foreach ($file) {
        \$output = \$context->include(\$_$hash);
    }
    \$output;
};
EOF
}

#------------------------------------------------------------------------
# while($expr, $block)                                 [% WHILE x < 10 %]
#                                                         ...
#                                                      [% END %]
#------------------------------------------------------------------------

sub while {
    my ($self, $expr, $block, $label) = @_;
    $block = pad($block, 2) if $PRETTY;
    $label ||= 'LOOP';

return <<EOF;

# WHILE
do {
    my \$_tt_failsafe = $WHILE_MAX;
$label:
    while (($expr) && --\$_tt_failsafe >= 0) {
$block
    }
    die "WHILE loop terminated (> $WHILE_MAX iterations)\\n"
        if \$_tt_failsafe < 0;
};
EOF
}

#------------------------------------------------------------------------
# switch($expr, \@case)                                    [% SWITCH %]
#                                                          [% CASE foo %]
#                                                             ...
#                                                          [% END %]
#------------------------------------------------------------------------

sub switch {
    my ($self, $expr, $case) = @_;
    my @case = @$case;
    my ($match, $block, $default);
    my $caseblock = '';

$default = pop @case;

foreach $case (@case) {
        $match = $case->[0];
        $block = $case->[1];
        $block = pad($block, 1) if $PRETTY;
        $caseblock .= <<EOF;
\$_tt_match = $match;
\$_tt_match = [ \$_tt_match ] unless ref \$_tt_match eq 'ARRAY';
if (grep(/^\\Q\$_tt_result\\E\$/, \@\$_tt_match)) {
$block
    last SWITCH;
}
EOF
    }

$caseblock .= $default
        if defined $default;
    $caseblock = pad($caseblock, 2) if $PRETTY;

return <<EOF;

# SWITCH
do {
    my \$_tt_result = $expr;
    my \$_tt_match;
    SWITCH: {
$caseblock
    }
};
EOF
}

#------------------------------------------------------------------------
# try($block, \@catch)                                        [% TRY %]
#                                                                ...
#                                                             [% CATCH %]
#                                                                ...
#                                                             [% END %]
#------------------------------------------------------------------------

sub try {
    my ($self, $block, $catch) = @_;
    my @catch = @$catch;
    my ($match, $mblock, $default, $final, $n);
    my $catchblock = '';
    my $handlers = [];

$block = pad($block, 2) if $PRETTY;
    $final = pop @catch;
    $final = "# FINAL\n" . ($final ? "$final\n" : '')
           . 'die $_tt_error if $_tt_error;' . "\n" . '$output;';
    $final = pad($final, 1) if $PRETTY;

$n = 0;
    foreach $catch (@catch) {
        $match = $catch->[0] || do {
            $default ||= $catch->[1];
            next;
        };
        $mblock = $catch->[1];
        $mblock = pad($mblock, 1) if $PRETTY;
        push(@$handlers, "'$match'");
        $catchblock .= $n++
            ? "elsif (\$_tt_handler eq '$match') {\n$mblock\n}\n"
               : "if (\$_tt_handler eq '$match') {\n$mblock\n}\n";
    }
    $catchblock .= "\$_tt_error = 0;";
    $catchblock = pad($catchblock, 3) if $PRETTY;
    if ($default) {
        $default = pad($default, 1) if $PRETTY;
        $default = "else {\n    # DEFAULT\n$default\n    \$_tt_error = '';\n}";
    }
    else {
        $default = '# NO DEFAULT';
    }
    $default = pad($default, 2) if $PRETTY;

$handlers = join(', ', @$handlers);
return <<EOF;

# TRY
$OUTPUT do {
    my \$output = '';
    my (\$_tt_error, \$_tt_handler);
    eval {
$block
    };
    if (\$@) {
        \$_tt_error = \$context->catch(\$@, \\\$output);
        die \$_tt_error if \$_tt_error->type =~ /^(return|stop)\$/;
        \$stash->set('error', \$_tt_error);
        \$stash->set('e', \$_tt_error);
        if (defined (\$_tt_handler = \$_tt_error->select_handler($handlers))) {
$catchblock
        }
$default
    }
$final
};
EOF
}

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

sub throw {
    my ($self, $nameargs) = @_;
    my ($type, $args) = @$nameargs;
    my $hash = shift(@$args);
    my $info = shift(@$args);
    $type = shift @$type;           # uses same parser production as INCLUDE
                                    # etc., which allow multiple names
                                    # e.g. INCLUDE foo+bar+baz

if (! $info) {
        $args = "$type, undef";
    }
    elsif (@$hash || @$args) {
        local $" = ', ';
        my $i = 0;
        $args = "$type, { args => [ "
              . join(', ', $info, @$args)
              . ' ], '
              . join(', ',
                     (map { "'" . $i++ . "' => $_" } ($info, @$args)),
                     @$hash)
              . ' }';
    }
    else {
        $args = "$type, $info";
    }

return "\$context->throw($args, \\\$output);";
}

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

sub clear {
    return "\$output = '';";
}

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

sub OLD_break {
    return 'last LOOP;';
}

#------------------------------------------------------------------------
# return()                                                   [% RETURN %]
#------------------------------------------------------------------------

sub return {
    return "\$context->throw('return', '', \\\$output);";
}

#------------------------------------------------------------------------
# stop()                                                       [% STOP %]
#------------------------------------------------------------------------

sub stop {
    return "\$context->throw('stop', '', \\\$output);";
}

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

sub use {
    my ($self, $lnameargs) = @_;
    my ($file, $args, $alias) = @$lnameargs;
    $file = shift @$file;       # same production rule as INCLUDE
    $alias ||= $file;
    $args = &args($self, $args);
    $file .= ", $args" if $args;
#    my $set = &assign($self, $alias, '$plugin');
    return "# USE\n"
         . "\$stash->set($alias,\n"
         . "            \$context->plugin($file));";
}

#------------------------------------------------------------------------
# view(\@nameargs, $block)                           [% VIEW name args %]
#     # => [ [$file, ... ], \@args ]
#------------------------------------------------------------------------

sub view {
    my ($self, $nameargs, $block, $defblocks) = @_;
    my ($name, $args) = @$nameargs;
    my $hash = shift @$args;
    $name = shift @$name;       # same production rule as INCLUDE
    $block = pad($block, 1) if $PRETTY;

if (%$defblocks) {
        $defblocks = join(",\n", map { "'$_' => $defblocks->{ $_ }" }
                                keys %$defblocks);
        $defblocks = pad($defblocks, 1) if $PRETTY;
        $defblocks = "{\n$defblocks\n}";
        push(@$hash, "'blocks'", $defblocks);
    }
    $hash = @$hash ? '{ ' . join(', ', @$hash) . ' }' : '';

return <<EOF;
# VIEW
do {
    my \$output = '';
    my \$_tt_oldv = \$stash->get('view');
    my \$_tt_view = \$context->view($hash);
    \$stash->set($name, \$_tt_view);
    \$stash->set('view', \$_tt_view);

$block

\$stash->set('view', \$_tt_oldv);
    \$_tt_view->seal();
#    \$output;     # not used - commented out to avoid warning
};
EOF
}

#------------------------------------------------------------------------
# perl($block)
#------------------------------------------------------------------------

sub perl {
    my ($self, $block) = @_;
    $block = pad($block, 1) if $PRETTY;

return <<EOF;

# PERL
\$context->throw('perl', 'EVAL_PERL not set')
    unless \$context->eval_perl();

$OUTPUT do {
    my \$output = "package Template::Perl;\\n";

$block

local(\$Template::Perl::context) = \$context;
    local(\$Template::Perl::stash)   = \$stash;

my \$_tt_result = '';
    tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$_tt_result;
    my \$_tt_save_stdout = select *Template::Perl::PERLOUT;

eval \$output;
    select \$_tt_save_stdout;
    \$context->throw(\$@) if \$@;
    \$_tt_result;
};
EOF
}

#------------------------------------------------------------------------
# no_perl()
#------------------------------------------------------------------------

sub no_perl {
    my $self = shift;
    return "\$context->throw('perl', 'EVAL_PERL not set');";
}

#------------------------------------------------------------------------
# rawperl($block)
#
# NOTE: perhaps test context EVAL_PERL switch at compile time rather than
# runtime?
#------------------------------------------------------------------------

sub rawperl {
    my ($self, $block, $line) = @_;
    for ($block) {
        s/^\n+//;
        s/\n+$//;
    }
    $block = pad($block, 1) if $PRETTY;
    $line = $line ? " (starting line $line)" : '';

return <<EOF;
# RAWPERL
#line 1 "RAWPERL block$line"
$block
EOF
}

#------------------------------------------------------------------------
# filter()
#------------------------------------------------------------------------

sub filter {
    my ($self, $lnameargs, $block) = @_;
    my ($name, $args, $alias) = @$lnameargs;
    $name = shift @$name;
    $args = &args($self, $args);
    $args = $args ? "$args, $alias" : ", undef, $alias"
        if $alias;
    $name .= ", $args" if $args;
    $block = pad($block, 1) if $PRETTY;

return <<EOF;

# FILTER
$OUTPUT do {
    my \$output = '';
    my \$_tt_filter = \$context->filter($name)
              || \$context->throw(\$context->error);

$block

&\$_tt_filter(\$output);
};
EOF
}

#------------------------------------------------------------------------
# capture($name, $block)
#------------------------------------------------------------------------

sub capture {
    my ($self, $name, $block) = @_;

if (ref $name) {
        if (scalar @$name == 2 && ! $name->[1]) {
            $name = $name->[0];
        }
        else {
            $name = '[' . join(', ', @$name) . ']';
        }
    }
    $block = pad($block, 1) if $PRETTY;

return <<EOF;

# CAPTURE
\$stash->set($name, do {
    my \$output = '';
$block
    \$output;
});
EOF

}

#------------------------------------------------------------------------
# macro($name, $block, \@args)
#------------------------------------------------------------------------

sub macro {
    my ($self, $ident, $block, $args) = @_;
    $block = pad($block, 2) if $PRETTY;

if ($args) {
        my $nargs = scalar @$args;
        $args = join(', ', map { "'$_'" } @$args);
        $args = $nargs > 1
            ? "\@_tt_args{ $args } = splice(\@_, 0, $nargs)"
            : "\$_tt_args{ $args } = shift";

return <<EOF;

# MACRO
\$stash->set('$ident', sub {
    my \$output = '';
    my (%_tt_args, \$_tt_params);
    $args;
    \$_tt_params = shift;
    \$_tt_params = { } unless ref(\$_tt_params) eq 'HASH';
    \$_tt_params = { \%_tt_args, %\$_tt_params };

my \$stash = \$context->localise(\$_tt_params);
    eval {
$block
    };
    \$stash = \$context->delocalise();
    die \$@ if \$@;
    return \$output;
});
EOF

}
    else {
        return <<EOF;

# MACRO
\$stash->set('$ident', sub {
    my \$_tt_params = \$_[0] if ref(\$_[0]) eq 'HASH';
    my \$output = '';

my \$stash = \$context->localise(\$_tt_params);
    eval {
$block
    };
    \$stash = \$context->delocalise();
    die \$@ if \$@;
    return \$output;
});
EOF
    }
}

sub debug {
    my ($self, $nameargs) = @_;
    my ($file, $args) = @$nameargs;
    my $hash = shift @$args;
    $args  = join(', ', @$file, @$args);
    $args .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : '';
    return "$OUTPUT \$context->debugging($args); ## DEBUG ##";
}

__END__

=head1 NAME

Template::Directive - Perl code generator for template directives

=head1 SYNOPSIS

# no user serviceable parts inside

=head1 DESCRIPTION

The C<Template::Directive> module defines a number of methods that
generate Perl code for the runtime representation of the various
Template Toolkit directives.

It is used internally by the L<Template::Parser> module.

=head1 AUTHOR

Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/>

=head1 COPYRIGHT

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

=head1 SEE ALSO

L<Template::Parser>

=cut

# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4:

Back to File Manager