ACIL FM

Nama	Ukuran	Aksi
App	-	Open
Manual	-	Open
Namespace	-	Open
Plugin	-	Open
Stash	-	Open
Tools	-	Open
Tutorial	-	Open
Base.pm	7.35 MB	View DL Edit
Config.pm	13.38 MB	View DL Edit
Constants.pm	9.39 MB	View DL Edit
Context.pm	51.18 MB	View DL Edit
Directive.pm	28.8 MB	View DL Edit
Document.pm	15.98 MB	View DL Edit
Exception.pm	6.22 MB	View DL Edit
FAQ.pod	8.62 MB	View DL Edit
Filters.pm	24.42 MB	View DL Edit
Grammar.pm	96.52 MB	View DL Edit
Iterator.pm	13.15 MB	View DL Edit
Manual.pod	2.37 MB	View DL Edit
Modules.pod	5.37 MB	View DL Edit
Parser.pm	39.68 MB	View DL Edit
Plugin.pm	8.74 MB	View DL Edit
Plugins.pm	13.76 MB	View DL Edit
Provider.pm	45.43 MB	View DL Edit
Service.pm	17.29 MB	View DL Edit
Stash.pm	28.11 MB	View DL Edit
Test.pm	21.63 MB	View DL Edit
Toolkit.pm	5.59 MB	View DL Edit
Tools.pod	1.49 MB	View DL Edit
Tutorial.pod	1.02 MB	View DL Edit
View.pm	23.45 MB	View DL Edit
VMethods.pm	15.3 MB	View DL Edit

Edit file: /usr/local/lib64/perl5/5.32/Template/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:

Batal