lib/Template/Alloy/Compile.pm

package Template::Alloy::Compile;

=head1 NAME

Template::Alloy::Compile - Compile role - allows for compiling the AST to perl code

=cut

use strict;
use warnings;
use Template::Alloy;
use Template::Alloy::Iterator;

our $VERSION = $Template::Alloy::VERSION;
our $INDENT  = ' ' x 4;
our $DIRECTIVES = {
    BLOCK   => \&compile_BLOCK,
    BREAK   => \&compile_LAST,
    CALL    => \&compile_CALL,
    CASE    => undef,
    CATCH   => undef,
    CLEAR   => \&compile_CLEAR,
    '#'     => sub {},
    COMMENT => sub {},
    CONFIG  => \&compile_CONFIG,
    DEBUG   => \&compile_DEBUG,
    DEFAULT => \&compile_DEFAULT,
    DUMP    => \&compile_DUMP,
    ELSE    => undef,
    ELSIF   => undef,
    END     => sub {},
    EVAL    => \&compile_EVAL,
    FILTER  => \&compile_FILTER,
    '|'     => \&compile_FILTER,
    FINAL   => undef,
    FOR     => \&compile_FOR,
    FOREACH => \&compile_FOR,
    GET     => \&compile_GET,
    IF      => \&compile_IF,
    INCLUDE => \&compile_INCLUDE,
    INSERT  => \&compile_INSERT,
    JS      => \&compile_JS,
    LAST    => \&compile_LAST,
    LOOP    => \&compile_LOOP,
    MACRO   => \&compile_MACRO,
    META    => \&compile_META,
    NEXT    => \&compile_NEXT,
    PERL    => \&compile_PERL,
    PROCESS => \&compile_PROCESS,
    RAWPERL => \&compile_RAWPERL,
    RETURN  => \&compile_RETURN,
    SET     => \&compile_SET,
    STOP    => \&compile_STOP,
    SWITCH  => \&compile_SWITCH,
    TAGS    => sub {},
    THROW   => \&compile_THROW,
    TRY     => \&compile_TRY,
    UNLESS  => \&compile_UNLESS,
    USE     => \&compile_USE,
    VIEW    => \&compile_VIEW,
    WHILE   => \&compile_WHILE,
    WRAPPER => \&compile_WRAPPER,
};

sub new { die "This class is a role for use by packages such as Template::Alloy" }

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

    ### first look for a compiled perl document
    my $perl;
    if ($doc->{'_filename'}) {
        $doc->{'modtime'} ||= (stat $doc->{'_filename'})[9];
        if ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) {
            my $file = $doc->{'_filename'};
            if ($self->{'COMPILE_DIR'}) {
                $file =~ y|:|/| if $^O eq 'MSWin32';
                $file = $self->{'COMPILE_DIR'} .'/'. $file;
            } elsif ($doc->{'_is_str_ref'}) {
                $file = ($self->include_paths->[0] || '.') .'/'. $file;
            }
            $file .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'});
            $file .= $Template::Alloy::PERL_COMPILE_EXT if defined $Template::Alloy::PERL_COMPILE_EXT;

            if (-e $file && ($doc->{'_is_str_ref'} || (stat $file)[9] == $doc->{'modtime'})) {
                $perl = $self->slurp($file);
            } else {
                $doc->{'_compile_filename'} = $file;
            }
        }
    }

    $perl ||= $self->compile_template($doc);

    ### save a cache on the fileside as asked
    if ($doc->{'_compile_filename'}) {
        my $dir = $doc->{'_compile_filename'};
        $dir =~ s|/[^/]+$||;
        if (! -d $dir) {
            require File::Path;
            File::Path::mkpath($dir);
        }
        open(my $fh, ">", $doc->{'_compile_filename'}) || $self->throw('compile', "Could not open file \"$doc->{'_compile_filename'}\" for writing: $!");
        ### todo - think about locking
        if ($self->{'ENCODING'} && eval { require Encode } && defined &Encode::encode) {
            print {$fh} Encode::encode($self->{'ENCODING'}, $$perl);
        } else {
            print {$fh} $$perl;
        }
        close $fh;
        utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_compile_filename'};
    }

    $perl = eval $$perl;
    $self->throw('compile', "Trouble loading compiled perl: $@") if ! $perl && $@;

    return $perl;
}

###----------------------------------------------------------------###

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

    local $self->{'_component'} = $doc;
    my $tree = $doc->{'_tree'} ||= $self->load_tree($doc);

    local $self->{'_blocks'} = '';
    local $self->{'_meta'}   = '';

    my $code = $self->compile_tree($tree, $INDENT);
    $self->{'_blocks'} .= "\n" if $self->{'_blocks'};
    $self->{'_meta'}   .= "\n" if $self->{'_meta'};

    my $file = $doc->{'_filename'} || '';
    $file =~ s/\'/\\\'/g;

    my $str = "# Generated by ".__PACKAGE__." v$VERSION on ".localtime()."

my \$file   = '$file';
my \$blocks = {$self->{'_blocks'}};
my \$meta   = {$self->{'_meta'}};
my \$code   = sub {
${INDENT}my (\$self, \$out_ref, \$var) = \@_;"
.($self->{'_blocks'} ? "\n${INDENT}\@{ \$self->{'BLOCKS'} }{ keys %\$blocks } = values %\$blocks;" : "")
.($self->{'_meta'}   ? "\n${INDENT}\@{ \$self->{'_component'} }{ keys %\$meta } = values %\$meta;" : "")
."$code

${INDENT}return 1;
};

{
${INDENT}blocks => \$blocks,
${INDENT}meta   => \$meta,
${INDENT}code   => \$code,
};\n";
#    print $str;
    return \$str;
}

###----------------------------------------------------------------###

sub _node_info {
    my ($self, $node, $indent) = @_;
    my $doc = $self->{'_component'} || return '';
    $doc->{'_content'} ||= $self->slurp($doc->{'_filename'});
    my ($line, $char) = $self->get_line_number_by_index($doc, $node->[1], 'include_chars');
    return "\n\n${indent}# \"$node->[0]\" Line $line char $char (chars $node->[1] to $node->[2])";
}

sub compile_tree {
    my ($self, $tree, $indent) = @_;
    my $code = '';
    # node contains (0: DIRECTIVE,
    #                1: start_index,
    #                2: end_index,
    #                3: parsed tag details,
    #                4: sub tree for block types
    #                5: continuation sub trees for sub continuation block types (elsif, else, etc)
    #                6: flag to capture next directive
    my @doc;
    my $func;
    for my $node (@$tree) {

        # text nodes are just the bare text
        if (! ref $node) {
            my $copy = $node; # must make a copy before modification
            $copy =~ s/([\'\\])/\\$1/g;
            $code .= "\n\n${indent}\$\$out_ref .= '$copy';";
            next;
        }

        if ($self->{'_debug_dirs'} && ! $self->{'_debug_off'}) {
            my $info = $self->node_info($node);
            my ($file, $line, $text) = @{ $info }{qw(file line text)};
            s/\'/\\\'/g foreach $file, $line, $text;
            $code .= "\n
${indent}if (\$self->{'_debug_dirs'} && ! \$self->{'_debug_off'}) { # DEBUG
${indent}${INDENT}my \$info = {file => '$file', line => '$line', text => '$text'};
${indent}${INDENT}my \$format = \$self->{'_debug_format'} || \$self->{'DEBUG_FORMAT'} || \"\\n## \\\$file line \\\$line : [% \\\$text %] ##\\n\";
${indent}${INDENT}\$format =~ s{\\\$(file|line|text)}{\$info->{\$1}}g;
${indent}${INDENT}\$\$out_ref .= \$format;
${indent}}";
        }

        $code .= _node_info($self, $node, $indent);

        if ($func = $DIRECTIVES->{$node->[0]}) {
            $func->($self, $node, \$code, $indent);
        } else {
            ### if the method isn't defined - delegate to the play directive (if there is one)
            require Template::Alloy::Play;
            if ($func = $Template::Alloy::Play::DIRECTIVES->{$node->[0]}) {
                _compile_defer_to_play($self, $node, \$code, $indent);
            } else {
                die "Couldn't find compile or play method for directive \"$node->[0]\"";
            }
        }
    }
    return $code;
}

sub compile_expr {
    my ($self, $var, $indent) = @_;
    return "\$self->play_expr(".$self->ast_string($var).")";
}

sub _compile_defer_to_play {
    my ($self, $node, $str_ref, $indent) = @_;
    my $directive = $node->[0];
    die "Invalid node name \"$directive\"" if $directive !~ /^\w+$/;

    $$str_ref .= "
${indent}require Template::Alloy::Play;
${indent}\$var = ".$self->ast_string($node->[3]).";
${indent}\$Template::Alloy::Play::DIRECTIVES->{'$directive'}->(\$self, \$var, ".$self->ast_string($node).", \$out_ref);";

    return;
}

sub _is_empty_named_args {
    my ($hash_ident) = @_;
    # [[undef, '{}', 'key1', 'val1', 'key2, 'val2'], 0]
    return @{ $hash_ident->[0] } <= 2;
}

###----------------------------------------------------------------###

sub compile_BLOCK {
    my ($self, $node, $str_ref, $indent) = @_;

    my $ref  = \ $self->{'_blocks'};
    my $name = $node->[3];
    $name =~ s/\'/\\\'/g;
    my $name2 = $self->{'_component'}->{'name'} .'/'. $node->[3];
    $name2 =~ s/\'/\\\'/g;

    my $code = $self->compile_tree($node->[4], "$INDENT$INDENT$INDENT");

    $$ref .= "
${INDENT}'$name' => {
${INDENT}${INDENT}name  => '$name2',
${INDENT}${INDENT}_filename => \$file,
${INDENT}${INDENT}_perl => {code => sub {
${INDENT}${INDENT}${INDENT}my (\$self, \$out_ref, \$var) = \@_;$code

${INDENT}${INDENT}${INDENT}return 1;
${INDENT}${INDENT}}},
${INDENT}},";

    return;
}

sub compile_CALL {
    my ($self, $node, $str_ref, $indent) = @_;
    $$str_ref .= "\n${indent}scalar ".$self->compile_expr($node->[3], $indent).";";
    return;
}

sub compile_CLEAR {
    my ($self, $node, $str_ref, $indent) = @_;
    $$str_ref .= "
${indent}\$\$out_ref = '';";
}

sub compile_CONFIG {
    my ($self, $node, $str_ref, $indent) = @_;
    _compile_defer_to_play($self, $node, $str_ref, $indent);
}

sub compile_DEBUG {
    my ($self, $node, $str_ref, $indent) = @_;

    my $text = $node->[3]->[0];

    if ($text eq 'on') {
        $$str_ref .= "\n${indent}delete \$self->{'_debug_off'};";
    } elsif ($text eq 'off') {
        $$str_ref .= "\n${indent}\$self->{'_debug_off'} = 1;";
    } elsif ($text eq 'format') {
        my $format = $node->[3]->[1];
        $format =~ s/\'/\\\'/g;
        $$str_ref .= "\n${indent}\$self->{'_debug_format'} = '$format';";
    }
    return;
}

sub compile_DEFAULT {
    my ($self, $node, $str_ref, $indent) = @_;
    local $self->{'_is_default'} = 1;
    $DIRECTIVES->{'SET'}->($self, $node, $str_ref, $indent);
}

sub compile_DUMP {
    my ($self, $node, $str_ref, $indent) = @_;
    _compile_defer_to_play($self, $node, $str_ref, $indent);
}

sub compile_GET {
    my ($self, $node, $str_ref, $indent) = @_;
    $$str_ref .= "
$indent\$var = ".$self->compile_expr($node->[3], $indent).";
$indent\$\$out_ref .= defined(\$var) ? \$var : \$self->undefined_get(".$self->ast_string($node->[3]).");";
    return;
}

sub compile_EVAL {
    my ($self, $node, $str_ref, $indent) = @_;
    my ($named, @strs) = @{ $node->[3] };

    $$str_ref .= "
${indent}foreach (".join(",\n", map {$self->ast_string($_)} @strs).") {
${indent}${INDENT}my \$str = \$self->play_expr(\$_);
${indent}${INDENT}next if ! defined \$str;
${indent}${INDENT}\$\$out_ref .= \$self->play_expr([[undef, '-temp-', \$str], 0, '|', 'eval', [".$self->ast_string($named)."]]);
${indent}}";
}

sub compile_FILTER {
    my ($self, $node, $str_ref, $indent) = @_;
    my ($name, $filter) = @{ $node->[3] };
    return if ! @$filter;

    $$str_ref .= "
${indent}\$var = do {
${indent}${INDENT}my \$filter = ".$self->ast_string($filter).";";

    ### allow for alias
    if (length $name) {
        $name =~ s/\'/\\\'/g;
        $$str_ref .= "\n${indent}${INDENT}\$self->{'FILTERS'}->{'$name'} = \$filter; # alias for future calls\n";
    }

    $$str_ref .= "
${indent}${INDENT}my \$out = '';
${indent}${INDENT}my \$out_ref = \\\$out;"
.$self->compile_tree($node->[4], "$indent$INDENT")."

${indent}\$out = \$self->play_expr([[undef, '-temp-', \$out], 0, '|', \@\$filter]);
${indent}${INDENT}\$out;
${indent}};
${indent}\$\$out_ref .= \$var if defined \$var;";

}

sub compile_FOR {
    my ($self, $node, $str_ref, $indent) = @_;

    my ($name, $items) = @{ $node->[3] };
    local $self->{'_in_loop'} = 'FOREACH';
    my $code = $self->compile_tree($node->[4], "$indent$INDENT");

    $$str_ref .= "\n${indent}do {
${indent}my \$loop = ".$self->compile_expr($items, $indent).";
${indent}\$loop = [] if ! defined \$loop;
${indent}\$loop = \$self->iterator(\$loop) if ref(\$loop) !~ /Iterator\$/;
${indent}local \$self->{'_vars'}->{'loop'} = \$loop;";
    if (! defined $name) {
        $$str_ref .= "
${indent}my \$swap = \$self->{'_vars'};
${indent}local \$self->{'_vars'} = my \$copy = {%\$swap};";
    }

    $$str_ref .= "
${indent}my (\$var, \$error) = \$loop->get_first;
${indent}FOREACH: while (! \$error) {";

    if (defined $name) {
        $$str_ref .= "\n$indent$INDENT\$self->set_variable(".$self->ast_string($name).", \$var);";
    } else {
        $$str_ref .= "\n$indent$INDENT\@\$copy{keys %\$var} = values %\$var if ref(\$var) eq 'HASH';";
    }

    $$str_ref .= "$code
${indent}${INDENT}(\$var, \$error) = \$loop->get_next;
${indent}}
${indent}};";
    return;
}

sub compile_FOREACH { shift->compile_FOR(@_) }

sub compile_IF {
    my ($self, $node, $str_ref, $indent) = @_;

    $$str_ref .= "\n${indent}if (".$self->compile_expr($node->[3], $indent).") {";
    $$str_ref .= $self->compile_tree($node->[4], "$indent$INDENT");

    while ($node = $node->[5]) { # ELSE, ELSIF's
        $$str_ref .= _node_info($self, $node, $indent);
        if ($node->[0] eq 'ELSE') {
            $$str_ref .= "\n${indent}} else {";
            $$str_ref .= $self->compile_tree($node->[4], "$indent$INDENT");
            last;
        } else {
            $$str_ref .= "\n${indent}} elsif (".$self->compile_expr($node->[3], $indent).") {";
            $$str_ref .= $self->compile_tree($node->[4], "$indent$INDENT");
        }
    }
    $$str_ref .= "\n${indent}}";
}

sub compile_INCLUDE {
    my ($self, $node, $str_ref, $indent) = @_;
    _compile_defer_to_play($self, $node, $str_ref, $indent);
}

sub compile_INSERT {
    my ($self, $node, $str_ref, $indent) = @_;
    _compile_defer_to_play($self, $node, $str_ref, $indent);
}

sub compile_JS {
    my ($self, $node, $str_ref, $indent) = @_;
    _compile_defer_to_play($self, $node, $str_ref, $indent);
}

sub compile_LAST {
    my ($self, $node, $str_ref, $indent) = @_;
    my $type = $self->{'_in_loop'} || die "Found LAST while not in FOR, FOREACH or WHILE";
    $$str_ref .= "\n${indent}last $type;";
    return;
}

sub compile_LOOP {
    my ($self, $node, $str_ref, $indent) = @_;
    my $ref = $node->[3];
    $ref = [$ref, 0] if ! ref $ref;

    $$str_ref .= "
${indent}\$var = ".$self->compile_expr($ref, $indent).";
${indent}if (\$var) {
${indent}${INDENT}my \$global = ! \$self->{'SYNTAX'} || \$self->{'SYNTAX'} ne 'ht' || \$self->{'GLOBAL_VARS'};
${indent}${INDENT}my \$items  = ref(\$var) eq 'ARRAY' ? \$var : ref(\$var) eq 'HASH' ? [\$var] : [];
${indent}${INDENT}my \$i = 0;
${indent}${INDENT}for my \$ref (\@\$items) {
${indent}${INDENT}${INDENT}\$self->throw('loop', 'Scalar value used in LOOP') if \$ref && ref(\$ref) ne 'HASH';
${indent}${INDENT}${INDENT}local \$self->{'_vars'} = (! \$global) ? (\$ref || {}) : (ref(\$ref) eq 'HASH') ? {%{ \$self->{'_vars'} }, %\$ref} : \$self->{'_vars'};
${indent}${INDENT}${INDENT}\@{ \$self->{'_vars'} }{qw(__counter__ __first__ __last__ __inner__ __odd__)}
${indent}${INDENT}${INDENT}${INDENT}= (++\$i, (\$i == 1 ? 1 : 0), (\$i == \@\$items ? 1 : 0), (\$i == 1 || \$i == \@\$items ? 0 : 1), (\$i % 2) ? 1 : 0)
${indent}${INDENT}${INDENT}${INDENT}${INDENT}if \$self->{'LOOP_CONTEXT_VARS'} && ! \$Template::Alloy::QR_PRIVATE;"
.$self->compile_tree($node->[4], "$indent$INDENT$INDENT")."

${indent}${INDENT}}
${indent}}";
}

sub compile_MACRO {
    my ($self, $node, $str_ref, $indent) = @_;
    my ($name, $args) = @{ $node->[3] };

    ### get the sub tree
    my $sub_tree = $node->[4];
    if (! $sub_tree || ! $sub_tree->[0]) {
        $$str_ref .= "
${indent}\$self->set_variable(".$self->ast_string($name).", undef);";
        return;
    } elsif (ref($sub_tree->[0]) && $sub_tree->[0]->[0] eq 'BLOCK') {
        $sub_tree = $sub_tree->[0]->[4];
    }

    my $code = $self->compile_tree($sub_tree, "$indent$INDENT");

    $$str_ref .= "
${indent}do {
${indent}my \$self_copy = \$self;
${indent}eval {require Scalar::Util; Scalar::Util::weaken(\$self_copy)};
${indent}\$var = sub {
${indent}${INDENT}my \$copy = \$self_copy->{'_vars'};
${indent}${INDENT}local \$self_copy->{'_vars'}= {%\$copy};

${indent}${INDENT}local \$self_copy->{'_macro_recurse'} = \$self_copy->{'_macro_recurse'} || 0;
${indent}${INDENT}my \$max = \$self_copy->{'MAX_MACRO_RECURSE'} || \$Template::Alloy::MAX_MACRO_RECURSE;
${indent}${INDENT}\$self_copy->throw('macro_recurse', \"MAX_MACRO_RECURSE \$max reached\")
${indent}${INDENT}${INDENT}if ++\$self_copy->{'_macro_recurse'} > \$max;
";

    foreach my $var (@$args) {
        $$str_ref .= "
${indent}${INDENT}\$self_copy->set_variable(";
        $$str_ref .= $self->ast_string($var);
        $$str_ref .= ", shift(\@_));";
    }
    $$str_ref .= "
${indent}${INDENT}if (\@_ && \$_[-1] && UNIVERSAL::isa(\$_[-1],'HASH')) {
${indent}${INDENT}${INDENT}my \$named = pop \@_;
${indent}${INDENT}${INDENT}foreach my \$name (sort keys %\$named) {
${indent}${INDENT}${INDENT}${INDENT}\$self_copy->set_variable([\$name, 0], \$named->{\$name});
${indent}${INDENT}${INDENT}}
${indent}${INDENT}}

${indent}${INDENT}my \$out = '';
${indent}${INDENT}my \$out_ref = \\\$out;$code
${indent}${INDENT}return \$out;
${indent}};
${indent}\$self->set_variable(".$self->ast_string($name).", \$var);
${indent}};";

    return;
}

sub compile_META {
    my ($self, $node, $str_ref, $indent) = @_;
    if (my $kp = $node->[3]) {
        $kp = {@$kp} if ref($kp) eq 'ARRAY';
        while (my($key, $val) = each %$kp) {
            s/\'/\\\'/g foreach $key, $val;
            $self->{'_meta'} .= "\n${indent}'$key' => '$val',";
        }
    }
    return;
}

sub compile_NEXT {
    my ($self, $node, $str_ref, $indent) = @_;
    my $type = $self->{'_in_loop'} || die "Found next while not in FOR, FOREACH or WHILE";
    $$str_ref .= "\n${indent}(\$var, \$error) = \$loop->get_next;" if $type eq 'FOREACH';
    $$str_ref .= "\n${indent}next $type;";
    return;
}

sub compile_PERL{
    my ($self, $node, $str_ref, $indent) = @_;

    ### fill in any variables
    my $perl = $node->[4] || return;
    my $code = $self->compile_tree($perl, "$indent$INDENT");

    $$str_ref .= "
${indent}\$self->throw('perl', 'EVAL_PERL not set') if ! \$self->{'EVAL_PERL'};
${indent}require Template::Alloy::Play;
${indent}\$var = do {
${indent}${INDENT}my \$out = '';
${indent}${INDENT}my \$out_ref = \\\$out;$code
${indent}${INDENT}\$out;
${indent}};
${indent}#\$var = \$1 if \$var =~ /^(.+)\$/s; # blatant untaint

${indent}my \$err;
${indent}eval {
${indent}${INDENT}package Template::Alloy::Perl;
${indent}${INDENT}my \$context = \$self->context;
${indent}${INDENT}my \$stash   = \$context->stash;
${indent}${INDENT}local *PERLOUT;
${indent}${INDENT}tie *PERLOUT, 'Template::Alloy::EvalPerlHandle', \$out_ref;
${indent}${INDENT}my \$old_fh = select PERLOUT;
${indent}${INDENT}eval \$var;
${indent}${INDENT}\$err = \$\@;
${indent}${INDENT}select \$old_fh;
${indent}};
${indent}\$err ||= \$\@;
${indent}if (\$err) {
${indent}${INDENT}\$self->throw('undef', \$err) if ! UNIVERSAL::can(\$err, 'type');
${indent}${INDENT}die \$err;
${indent}}";

    return;
}


sub compile_PROCESS {
    my ($self, $node, $str_ref, $indent) = @_;
    _compile_defer_to_play($self, $node, $str_ref, $indent);
}

sub compile_RAWPERL {
    my ($self, $node, $str_ref, $indent) = @_;
    _compile_defer_to_play($self, $node, $str_ref, $indent);
}

sub compile_RETURN {
    my ($self, $node, $str_ref, $indent) = @_;

    if (defined($node->[3])) {
        $$str_ref .= "
${indent}\$var = {return_val => ".$self->compile_expr($node->[3])."};
${indent}\$self->throw('return', \$var);";
    } else {
        $$str_ref .= "
${indent}\$self->throw('return', undef);";
    }
}

sub compile_SET {
    my ($self, $node, $str_ref, $indent) = @_;
    my $sets = $node->[3];

    my $out = '';
    foreach (@$sets) {
        my ($op, $set, $val) = @$_;

        if ($self->{'_is_default'}) {
            $$str_ref .= "\n${indent}if (! ".$self->compile_expr($set, $indent).") {";
            $indent .= $INDENT;
        }
        $$str_ref .= "\n$indent\$var = ";

        if (! defined $val) { # not defined
            $$str_ref .= 'undef';
        } elsif ($node->[4] && $val == $node->[4]) { # a captured directive
            my $sub_tree = $node->[4];
            $sub_tree = $sub_tree->[0]->[4] if $sub_tree->[0] && $sub_tree->[0]->[0] eq 'BLOCK';
            my $code = $self->compile_tree($sub_tree, "$indent$INDENT");
            $$str_ref .= "${indent}do {
${indent}${INDENT}my \$out = '';
${indent}${INDENT}my \$out_ref = \\\$out;$code
${indent}${INDENT}\$out;
${indent}}"
        } else { # normal var
            $$str_ref .= $self->compile_expr($val, $indent);
        }

        if ($Template::Alloy::OP_DISPATCH->{$op}) {
            $$str_ref .= ' }';
        }

        $$str_ref .= ";
$indent\$self->set_variable(".$self->ast_string($set).", \$var);";

        if ($self->{'_is_default'}) {
            substr($indent, -length($INDENT), length($INDENT), '');
            $$str_ref .= "\n$indent}";
        }

        $$str_ref .= ";";
    }

    return $out;
}

sub compile_STOP {
    my ($self, $node, $str_ref, $indent) = @_;
    $$str_ref .= "
${indent}\$self->throw('stop', 'Control Exception');";
}

sub compile_SWITCH {
    my ($self, $node, $str_ref, $indent) = @_;

    $$str_ref .= "
${indent}\$var = ".$self->compile_expr($node->[3], $indent).";";

    my $default;
    my $i = 0;
    while ($node = $node->[5]) { # CASES
        if (! defined $node->[3]) {
            $default = $node;
            next;
        }

        $$str_ref .= _node_info($self, $node, $indent);
        $$str_ref .= "\n$indent" .($i++ ? "} els" : ""). "if (do {
${indent}${INDENT}no warnings;
${indent}${INDENT}my \$var2 = ".$self->compile_expr($node->[3], "$indent$INDENT").";
${indent}${INDENT}scalar grep {\$_ eq \$var} (UNIVERSAL::isa(\$var2, 'ARRAY') ? \@\$var2 : \$var2);
${indent}${INDENT}}) {
${indent}${INDENT}my \$var;";

        $$str_ref .= $self->compile_tree($node->[4], "$indent$INDENT");
    }

    if ($default) {
        $$str_ref .= _node_info($self, $default, $indent);
        $$str_ref .= "\n$indent" .($i++ ? "} else {" : "if (1) {");
        $$str_ref .= $self->compile_tree($default->[4], "$indent$INDENT");
    }

    $$str_ref .= "\n$indent}" if $i;

    return;
}

sub compile_THROW {
    my ($self, $node, $str_ref, $indent) = @_;

    my ($name, $args) = @{ $node->[3] };

    my ($named, @args) = @$args;
    push @args, $named if ! _is_empty_named_args($named); # add named args back on at end - if there are some

    $$str_ref .= "
${indent}\$self->throw(".$self->compile_expr($name, $indent).", [".join(", ", map{$self->compile_expr($_, $indent)} @args)."]);";
    return;
}


sub compile_TRY {
    my ($self, $node, $str_ref, $indent) = @_;

    $$str_ref .= "
${indent}do {
${indent}my \$out = '';
${indent}eval {
${indent}${INDENT}my \$out_ref = \\\$out;"
    . $self->compile_tree($node->[4], "$indent$INDENT") ."
${indent}};
${indent}my \$err = \$\@;
${indent}\$\$out_ref .= \$out;
${indent}if (\$err) {";

    my $final;
    my $i = 0;
    my $catches_str = '';
    my @names;
    while ($node = $node->[5]) { # CATCHES
        if ($node->[0] eq 'FINAL') {
            $final = $node;
            next;
        }
        $catches_str .= _node_info($self, $node, "$indent$INDENT");
        $catches_str .= "\n${indent}${INDENT}} elsif (\$index == ".(scalar @names).") {";
        $catches_str .= $self->compile_tree($node->[4], "$indent$INDENT$INDENT");
        push @names, $node->[3];
    }
    if (@names) {
        $$str_ref .= "
${indent}${INDENT}\$err = \$self->exception('undef', \$err) if ! UNIVERSAL::can(\$err, 'type');
${indent}${INDENT}my \$type = \$err->type;
${indent}${INDENT}die \$err if \$type =~ /stop|return/;
${indent}${INDENT}local \$self->{'_vars'}->{'error'} = \$err;
${indent}${INDENT}local \$self->{'_vars'}->{'e'}     = \$err;

${indent}${INDENT}my \$index;
${indent}${INDENT}my \@names = (";
        $i = 0;
        foreach $i (0 .. $#names) {
            if (defined $names[$i]) {
                $$str_ref .= "\n${indent}${INDENT}${INDENT}scalar(".$self->compile_expr($names[$i], "$indent$INDENT$INDENT")."), # $i;";
            } else {
                $$str_ref .= "\n${indent}${INDENT}${INDENT}undef, # $i";
            }
        }
        $$str_ref .= "
${indent}${INDENT});
${indent}${INDENT}for my \$i (0 .. \$#names) {
${indent}${INDENT}${INDENT}my \$name = (! defined(\$names[\$i]) || lc(\$names[\$i]) eq 'default') ? '' : \$names[\$i];
${indent}${INDENT}${INDENT}\$index = \$i if \$type =~ m{^ \\Q\$name\\E \\b}x && (! defined(\$index) || length(\$names[\$index]) < length(\$name));
${indent}${INDENT}}
${indent}${INDENT}if (! defined \$index) {
${indent}${INDENT}${INDENT}die \$err;"
.$catches_str."
${indent}${INDENT}}";

    } else {
        $$str_ref .= "
${indent}\$self->throw('throw', 'Missing CATCH block');";
    }
    $$str_ref .= "
${indent}}";
    if ($final) {
        $$str_ref .= _node_info($self, $final, $indent);
        $$str_ref .= $self->compile_tree($final->[4], "$indent");
    }
    $$str_ref .="
${indent}};";

    return;
}

sub compile_UNLESS { $DIRECTIVES->{'IF'}->(@_) }

sub compile_USE {
    my ($self, $node, $str_ref, $indent) = @_;
    _compile_defer_to_play($self, $node, $str_ref, $indent);
}

sub compile_VIEW {
    my ($self, $node, $str_ref, $indent) = @_;
    my ($blocks, $args, $name) = @{ $node->[3] };

    my $_name = $self->ast_string($name);

    # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
    $args = $args->[0];
    $$str_ref .= "
${indent}do {
${indent}${INDENT}my \$name = $_name;
${indent}${INDENT}my \$hash = {};";
    foreach (my $i = 2; $i < @$args; $i+=2) {
        $$str_ref .= "
${indent}${INDENT}\$var = ".$self->compile_expr($args->[$i+1], $indent).";
${indent}${INDENT}";
        my $key = $args->[$i];
        if (ref $key) {
            if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
                $key = $key->[0];
            } else {
                $$str_ref .= "
${indent}${INDENT}\$self->set_variable(".$self->compile_expr($key, $indent).", \$var);";
                next;
            }
        }
        $key =~ s/([\'\\])/\\$1/g;
        $$str_ref .= "\$hash->{'$key'} = \$var;";
    }

    $$str_ref .= "
${indent}${INDENT}my \$prefix = \$hash->{'prefix'} || (ref(\$name) && \@\$name == 2 && ! \$name->[1] && ! ref(\$name->[0])) ? \"\$name->[0]/\" : '';
${indent}${INDENT}my \$blocks = \$hash->{'blocks'} = {};";
    foreach my $key (keys %$blocks) {
        my $code = $self->compile_tree($blocks->{$key}, "$indent$INDENT$INDENT$INDENT");
        $key =~ s/([\'\\])/\\$1/g;
        $$str_ref .= "
${indent}${INDENT}\$blocks->{'$key'} = {
${indent}${INDENT}${INDENT}name  => \$prefix . '$key',
${indent}${INDENT}${INDENT}_perl => {code => sub {
${indent}${INDENT}${INDENT}${INDENT}my (\$self, \$out_ref, \$var) = \@_;$code

${indent}${INDENT}${INDENT}${INDENT}return 1;
${indent}${INDENT}${INDENT}} },
${indent}${INDENT}};";
    }

    $$str_ref .= "
${indent}${INDENT}\$self->throw('view', 'Could not load Template::View library')
${indent}${INDENT}${INDENT} if ! eval { require Template::View };
${indent}${INDENT}my \$view = Template::View->new(\$self->context, \$hash)
${indent}${INDENT}${INDENT}|| \$self->throw('view', \$Template::View::ERROR);
${indent}${INDENT}my \$old_view = \$self->play_expr(['view', 0]);
${indent}${INDENT}\$self->set_variable(\$name, \$view);
${indent}${INDENT}\$self->set_variable(['view', 0], \$view);";

    if ($node->[4]) {
        $$str_ref .= "
${indent}${INDENT}my \$out = '';
${indent}${INDENT}my \$out_ref = \\\$out;"
    .$self->compile_tree($node->[4], "$indent$INDENT");
    }

    $$str_ref .= "
${indent}${INDENT}\$self->set_variable(['view', 0], \$old_view);
${indent}${INDENT}\$view->seal;
${indent}};";


    return;
}

sub compile_WHILE {
    my ($self, $node, $str_ref, $indent) = @_;

    local $self->{'_in_loop'} = 'WHILE';
    my $code = $self->compile_tree($node->[4], "$indent$INDENT");

    $$str_ref .= "
${indent}my \$count = \$Template::Alloy::WHILE_MAX;
${indent}WHILE: while (--\$count > 0) {
${indent}my \$var = ".$self->compile_expr($node->[3], $indent).";
${indent}last if ! \$var;$code
${indent}}";
    return;
}

sub compile_WRAPPER {
    my ($self, $node, $str_ref, $indent) = @_;

    my ($named, @files) = @{ $node->[3] };
    $named = $self->ast_string($named);

    $$str_ref .= "
${indent}\$var = do {
${indent}${INDENT}my \$out = '';
${indent}${INDENT}my \$out_ref = \\\$out;"
.$self->compile_tree($node->[4], "$indent$INDENT")."
${indent}${INDENT}\$out;
${indent}};
${indent}for my \$file (reverse("
.join(",${indent}${INDENT}", map {"\$self->play_expr(".$self->ast_string($_).")"} @files).")) {
${indent}${INDENT}local \$self->{'_vars'}->{'content'} = \$var;
${indent}${INDENT}\$var = '';
${indent}${INDENT}require Template::Alloy::Play;
${indent}\$Template::Alloy::Play::DIRECTIVES->{'INCLUDE'}->(\$self, [$named, \$file], ['$node->[0]', $node->[1], $node->[2]], \\\$var);
${indent}}
${indent}\$\$out_ref .= \$var if defined \$var;";

    return;
}


###----------------------------------------------------------------###

1;

__END__

=head1 DESCRIPTION

The Template::Alloy::Compile role allows for taking the AST returned
by the Parse role, and translating it into a perl code document.  This
is in contrast Template::Alloy::Play which executes the AST directly.

=head1 TODO

=over 4

=item

Translate compile_RAWPERL to actually output rather than calling play_RAWPERL.

=back

=head1 ROLE METHODS

=over 4

=item C<compile_tree>

Takes an AST returned by parse_tree and translates it into
perl code using functions stored in the $DIRECTIVES hashref.

A template that looked like the following:

    Foo
    [% GET foo %]
    [% GET bar %]
    Bar

would parse to the following perl code:

    # Generated by Template::Alloy::Compile v1.001 on Thu Jun  7 12:58:33 2007
    # From file /home/paul/bar.tt

    my $blocks = {};
    my $meta   = {};
    my $code   = sub {
        my ($self, $out_ref, $var) = @_;

        $$out_ref .= 'Foo';

        # "GET" Line 2 char 2 (chars 6 to 15)
        $var = $self->play_expr(['foo', 0]);
        $$out_ref .= defined($var) ? $var : $self->undefined_get(['foo', 0]);

        # "GET" Line 3 char 2 (chars 22 to 31)
        $var = $self->play_expr(['bar', 0]);
        $$out_ref .= defined($var) ? $var : $self->undefined_get(['bar', 0]);

        $$out_ref .= 'Bar';

        return 1;
    };

    {
        blocks => $blocks,
        meta   => $meta,
        code   => $code,
    };

As you can see the output is quite a bit more complex than the AST, but under
mod_perl conditions, the perl will run faster than playing the AST each time.

=item C<compile_expr>

Takes an AST variable or expression and returns perl code that can lookup
the variable.

=back

=head1 AUTHOR

Paul Seamons <paul@seamons.com>

=head1 LICENSE

This module may be distributed under the same terms as Perl itself.

=cut
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)