File Coverage

blib/lib/Template/Alloy/Play.pm

Criterion	Covered	Total	%
statement	529	572	92.4
branch	232	322	72.0
condition	114	194	58.7
subroutine	44	46	95.6
pod	1	34	2.9
total	920	1168	78.7

package Template::Alloy::Play;

=head1 NAME

Template::Alloy::Play - Play role - allows for playing out the AST

=cut

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

our $VERSION    = $Template::Alloy::VERSION;
our $QR_NUM     = '(?:\d*\.\d+ | \d+)';
our $DIRECTIVES = {
    BLOCK   => \&play_BLOCK,
    BREAK   => \&play_control,
    CALL    => \&play_CALL,
    CASE    => undef,
    CATCH   => undef,
    CLEAR   => \&play_CLEAR,
    '#'     => sub {},
    COMMENT => sub {},
    CONFIG  => \&play_CONFIG,
    DEBUG   => \&play_DEBUG,
    DEFAULT => \&play_DEFAULT,
    DUMP    => \&play_DUMP,
    ELSE    => undef,
    ELSIF   => undef,
    END     => sub {},
    EVAL    => \&play_EVAL,
    FILTER  => \&play_FILTER,
    '|'     => \&play_FILTER,
    FINAL   => undef,
    FOR     => \&play_FOR,
    FOREACH => \&play_FOR,
    GET     => \&play_GET,
    IF      => \&play_IF,
    INCLUDE => \&play_INCLUDE,
    INSERT  => \&play_INSERT,
    LAST    => \&play_control,
    LOOP    => \&play_LOOP,
    MACRO   => \&play_MACRO,
    META    => \&play_META,
    NEXT    => \&play_control,
    PERL    => \&play_PERL,
    PROCESS => \&play_PROCESS,
    RAWPERL => \&play_RAWPERL,
    RETURN  => \&play_RETURN,
    SET     => \&play_SET,
    STOP    => \&play_control,
    SWITCH  => \&play_SWITCH,
    TAGS    => sub {},
    THROW   => \&play_THROW,
    TRY     => \&play_TRY,
    UNLESS  => \&play_UNLESS,
    USE     => \&play_USE,
    VIEW    => \&play_VIEW,
    WHILE   => \&play_WHILE,
    WRAPPER => \&play_WRAPPER,
};

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

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

sub play_tree {
    my ($self, $tree, $out_ref) = @_;

    return $self->stream_tree($tree) if $self->{'STREAM'};

    # 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
    for my $node (@$tree) {
        ### text nodes are just the bare text
        if (! ref $node) {
            $$out_ref .= $node if defined $node;
            next;
        }

        $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};

        $DIRECTIVES->{$node->[0]}->($self, $node->[3], $node, $out_ref);
    }
}

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

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

sub play_BLOCK {
    my ($self, $block_name, $node, $out_ref) = @_;

    # store a named reference - but do nothing until something processes it
    my $comp = $self->{'_component'};
    $self->{'BLOCKS'}->{$block_name} = {
        _tree => $node->[4],
        name  => $comp->{'name'} .'/'. $block_name,
        ($comp->{'_filename'} ? (_filename => $comp->{'_filename'}) : ()),
    };

    return;
}

sub play_CALL {
    my ($self, $ident, $node) = @_;
    my $var = $self->play_expr($ident);
    $var = $self->undefined_get($ident, $node) if ! defined $var;
    return;
}

sub play_control {
    my ($self, $undef, $node) = @_;
    $self->throw(lc($node->[0]), 'Control exception', $node);
}

sub play_CLEAR {
    my ($self, $undef, $node, $out_ref) = @_;
    $$out_ref = '';
    return;
}

sub play_CONFIG {
    my ($self, $config, $node, $out_ref) = @_;

    my %rtime = map {$_ => 1} @Template::Alloy::CONFIG_RUNTIME;

    ### do runtime config - not many options get these
    my ($named, @the_rest) = @$config;
    $named = $self->play_expr($named);
    $self->throw("config.strict", "Cannot disable STRICT once it is enabled", $node) if exists $named->{'STRICT'} && ! $named->{'STRICT'};
    @{ $self }{keys %$named} = @{ $named }{keys %$named};

    ### show what current values are
    $$out_ref .= join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest);
    return;
}

sub play_DEBUG {
    my ($self, $ref) = @_;
    if ($ref->[0] eq 'on') {
        delete $self->{'_debug_off'};
    } elsif ($ref->[0] eq 'off') {
        $self->{'_debug_off'} = 1;
    } elsif ($ref->[0] eq 'format') {
        $self->{'_debug_format'} = $ref->[1];
    }
    return;
}

sub play_DEFAULT {
    my ($self, $set) = @_;
    foreach my $item (@$set) {
        my ($op, $set, $default) = @$item;
        next if ! defined $set;
        my $val = $self->play_expr($set);
        if (! $val) {
            $default = defined($default) ? $self->play_expr($default) : '';
            $self->set_variable($set, $default);
        }
    }
    return;
}

sub play_DUMP {
    my ($self, $dump, $node, $out_ref) = @_;

    my $conf = $self->{'DUMP'};
    return if ! $conf && defined $conf; # DUMP => 0
    $conf = {} if ref $conf ne 'HASH';

    ### allow for handler override
    my $handler = $conf->{'handler'};
    if (! $handler) {
        require Data::Dumper;
        my $obj = Data::Dumper->new([]);
        my $meth;
        foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) }
        my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1;
        $obj->Sortkeys(sub { my $h = shift; [grep {! $Template::Alloy::QR_PRIVATE
                                                       || $_ !~ $Template::Alloy::QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] });
        $handler = sub { $obj->Values([@_]); $obj->Dump }
    }

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

    ### look for the text describing what to dump
    my $info = eval { $self->node_info($node) } || {text => 'unknown', file => 'unknown', line => 'unknown'};
    my $out;
    if (@dump) {
        $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump);
        my $name = $info->{'text'};
        $name =~ s/^[+=~-]?\s*DUMP\s+//;
        $name =~ s/\s*[+=~-]?$//;
        $out =~ s/\$VAR1/$name/;
    } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) {
        $out = '';
    } else {
        $out = $handler->($self->{'_vars'});
        $out =~ s/\$VAR1/EntireStash/g;
    }

    if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) {
        $out = $Template::Alloy::SCALAR_OPS->{'xml'}->($out);
        $out = "$out";
        $out = "DUMP: File \"$info->{file}\" line $info->{line}$out" if $conf->{'header'} || ! defined $conf->{'header'};
    } else {
        $out = "DUMP: File \"$info->{file}\" line $info->{line}\n    $out" if $conf->{'header'} || ! defined $conf->{'header'};
    }

    $$out_ref .= $out;
    return;
}

sub play_EVAL {
    my ($self, $ref, $node, $out_ref) = @_;
    my ($named, @strs) = @$ref;

    foreach my $str (@strs) {
        $str = $self->play_expr($str);
        next if ! defined $str;
        $str = $self->play_expr([[undef, '-temp-', $str], 0, '|', 'eval', [$named]]);
        $$out_ref .= $str if defined $str;
    }
    return;
}

sub play_FILTER {
    my ($self, $ref, $node, $out_ref) = @_;
    my ($name, $filter) = @$ref;

    return '' if ! @$filter;

    $self->{'FILTERS'}->{$name} = $filter if length $name;

    my $sub_tree = $node->[4];

    ### play the block
    my $out = '';
    eval { local $self->{'STREAM'} = undef; $self->play_tree($sub_tree, \$out) };
    die $@ if $@ && ! UNIVERSAL::can($@, 'type'); # TODO - shouldn't they all die ?

    $out = $self->play_expr([[undef, '-temp-', $out], 0, '|', @$filter]);
    $$out_ref .= $out if defined $out;
    return;
}

sub play_FOR {
    my ($self, $ref, $node, $out_ref) = @_;

    ### get the items - make sure it is an arrayref
    my ($var, $items) = @$ref;

    $items = $self->play_expr($items);
    return '' if ! defined $items;

    if (ref($items) !~ /Iterator$/) {
        $items = $self->iterator($items);
    }

    my $sub_tree = $node->[4];

    local $self->{'_vars'}->{'loop'} = $items;

    ### if the FOREACH tag sets a var - then nothing but the loop var gets localized
    if (defined $var) {
        my ($item, $error) = $items->get_first;
        while (! $error) {
            $self->set_variable($var, $item);

            eval { $self->play_tree($sub_tree, $out_ref) };
            if (my $err = $@) {
                die $err if ! UNIVERSAL::can($err, 'type');
                last if $err->type =~ /last|break/;
                die  if $err->type ne 'next';
            }
            ($item, $error) = $items->get_next;
        }
        die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
    ### if the FOREACH tag doesn't set a var - then everything gets localized
    } else {

        ### localize variable access for the foreach
        my $swap = $self->{'_vars'};
        local $self->{'_vars'} = my $copy = {%$swap};

        ### iterate use the iterator object
        #foreach (my $i = $items->index; $i <= $#$vals; $items->index(++ $i)) {
        my ($item, $error) = $items->get_first;
        while (! $error) {
            @$copy{keys %$item} = values %$item if ref($item) eq 'HASH';

            eval { $self->play_tree($sub_tree, $out_ref) };
            if (my $err = $@) {
                die $err if ! UNIVERSAL::can($err, 'type');
                last if $err->type =~ /last|break/;
                die  if $err->type ne 'next';
            }
            ($item, $error) = $items->get_next;
        }
        die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
    }

    return;
}

sub play_GET {
    my ($self, $ident, $node, $out_ref) = @_;
    my $var = $self->play_expr($ident);
    if (defined $var) {
        $$out_ref .= $var;
    } else {
        $var = $self->undefined_get($ident, $node);
        $$out_ref .= $var if defined $var;
    }
    return;
}

sub play_IF {
    my ($self, $var, $node, $out_ref) = @_;

    my $val = $self->play_expr($var);
    if ($val) {
        my $body_ref = $node->[4] ||= [];
        $self->play_tree($body_ref, $out_ref);
        return;
    }

    while ($node = $node->[5]) { # ELSE, ELSIF's
        if ($node->[0] eq 'ELSE') {
            my $body_ref = $node->[4] ||= [];
            $self->play_tree($body_ref, $out_ref);
            return;
        }
        my $var = $node->[3];
        my $val = $self->play_expr($var);
        if ($val) {
            my $body_ref = $node->[4] ||= [];
            $self->play_tree($body_ref, $out_ref);
            return;
        }
    }
    return;
}

sub play_INCLUDE {
    my ($self, $str_ref, $node, $out_ref) = @_;

    ### localize the swap
    my $swap = $self->{'_vars'} || {};
    local $self->{'_vars'} = {%$swap};

    ### localize the blocks
    my $blocks = $self->{'BLOCKS'} || {};
    local $self->{'BLOCKS'} = {%$blocks};

    return $DIRECTIVES->{'PROCESS'}->($self, $str_ref, $node, $out_ref);
}

sub play_INSERT {
    my ($self, $args, $node, $out_ref) = @_;
    if ($self->{'NO_INCLUDES'}) {
        $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive");
    }

    my ($named, @files) = @$args;

    foreach my $name (@files) {
        my $file = $self->play_expr($name);
        my $ref  = $self->slurp($self->include_filename($file));
        $$out_ref .= $$ref;
    }

    return;
}

sub play_JS {
    my $self = shift;
    $self->throw('js', 'COMPILE_JS not set while running a JS block') if ! $self->{'COMPILE_JS'};
    $self->throw('js', 'Cannot run JS directly');
}

sub play_LOOP {
    my ($self, $ref, $node, $out_ref) = @_;

    my $var = $self->play_expr(ref($ref) ? $ref : [$ref,0]); # allow for "string" identified loops
    my $sub_tree = $node->[4];

    my $global = ! $self->{'SYNTAX'} || $self->{'SYNTAX'} ne 'ht' || $self->{'GLOBAL_VARS'};

    my $items = ref($var) eq 'ARRAY' ? $var : ref($var) eq 'HASH' ? [$var] : [];

    my $i = 0;
    for my $ref (@$items) {
        ### setup the loop
        $self->throw('loop', 'Scalar value used in LOOP') if $ref && ref($ref) ne 'HASH';
        local $self->{'_vars'} = (! $global) ? ($ref || {}) : (ref($ref) eq 'HASH') ? {%{ $self->{'_vars'} }, %$ref} : $self->{'_vars'};
        if ($self->{'LOOP_CONTEXT_VARS'} && ! $Template::Alloy::QR_PRIVATE) {
            $self->{'_vars'}->{'__counter__'} = ++$i;
            $self->{'_vars'}->{'__first__'} = $i == 1 ? 1 : 0;
            $self->{'_vars'}->{'__last__'}  = $i == @$items ? 1 : 0;
            $self->{'_vars'}->{'__inner__'} = $i == 1 || $i == @$items ? 0 : 1;
            $self->{'_vars'}->{'__odd__'}   = ($i % 2) ? 1 : 0;
        }

        ### execute the sub tree
        $self->play_tree($sub_tree, $out_ref);
    }

    return;
}

sub play_MACRO {
    my ($self, $ref, $node, $out_ref) = @_;
    my ($name, $args) = @$ref;

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

    ### install a closure in the stash that will handle the macro
    $self->set_variable($name, $self->_macro_sub($args, $sub_tree, $out_ref));

    return;
}

sub _macro_sub {
    my ($self, $args, $sub_tree, $out_ref) = @_;

    my $self_copy = $self;

    my $sub = sub {
        ### macros localize
        my $copy = $self_copy->{'_vars'};
        local $self_copy->{'_vars'}= {%$copy};

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

        ### set arguments
        my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
        my @positional = @_;
        foreach my $var (@$args) {
            $self_copy->set_variable($var, shift(@positional));
        }
        foreach my $name (sort keys %$named) {
            $self_copy->set_variable([$name, 0], $named->{$name});
        }

        local $self->{'STREAM'} = undef;

        ### finally - run the sub tree
        my $out = '';
        eval { $self_copy->play_tree($sub_tree, \$out) };
        if (my $err = $@) {
            die $err if $err->type ne 'return';
            return $err->info->{'return_val'} if UNIVERSAL::isa($err->info, 'HASH');
            return;
        }
        return $out;
    };

    eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
    return $sub;
}

sub play_META {
    my ($self, $hash) = @_;
    return if ! $hash;
    $hash = {@$hash} if ref($hash) eq 'ARRAY';
    my @keys = keys %$hash;

    my $ref;
    if ($self->{'_top_level'}) {
        $ref = $self->{'_template'} ||= {};
    } else {
        $ref = $self->{'_component'} ||= {};
    }

    @{ $ref }{ @keys } = @{ $hash }{ @keys };
    return;
}

sub play_PERL {
    my ($self, $info, $node, $out_ref) = @_;
    $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};

    ### fill in any variables
    my $perl = $node->[4] || return;
    my $out  = '';
    {
        local $self->{'STREAM'} = undef;
        $self->play_tree($perl, \$out);
    };
    $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway

    ### try the code
    my $err;
    eval {
        package Template::Alloy::Perl;

        my $context = $self->context;
        my $stash   = $context->stash;

        ### setup a fake handle
        local *PERLOUT;
        tie *PERLOUT, 'Template::Alloy::EvalPerlHandle', $out_ref;
        my $old_fh = select PERLOUT;

        eval $out;
        $err = $@;

        ### put the handle back
        select $old_fh;

    };
    $err ||= $@;


    if ($err) {
        $self->throw('undef', $err) if ! UNIVERSAL::can($err, 'type');
        die $err;
    }

    return;
}

sub play_PROCESS {
    my ($self, $info, $node, $out_ref) = @_;
    if ($self->{'NO_INCLUDES'}) {
        $self->throw('file', "NO_INCLUDES was set during a $node->[0] directive");
    }

    my ($args, @files) = @$info;

    ### process files first
    foreach my $ref (@files) {
        $ref = $self->play_expr($ref) if defined $ref;
    }

    ### set passed args
    # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
    $args = $args->[0];
    foreach (my $i = 2; $i < @$args; $i+=2) {
        my $key = $args->[$i];
        my $val = $self->play_expr($args->[$i+1]);
        if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever
            foreach my $key (keys %$val) {
                $self->set_variable([$key,0], $val->{$key});
            }
            next;
        }
        $self->set_variable($key, $val);
    }

    ### iterate on any passed block or filename
    foreach my $filename (@files) {
        next if ! defined $filename;
        my $out = ''; # have temp item to allow clear to correctly clear

        ### normal blocks or filenames
        if (! ref($filename) || ref($filename) eq 'SCALAR') {
            eval { $self->_process($filename, $self->{'_vars'}, \$out) }; # restart the swap - passing it our current stash

        ### allow for $template which is used in some odd instances
        } else {
            my $doc = $filename;

            $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'};
            local $self->{'_process_dollar_template'} = 1;
            local $self->{'_component'} = $doc;

            ### run the document however we can
            if (ref($doc) ne 'HASH' || (! $doc->{'_perl'} && ! $doc->{'_tree'})) {
                $self->throw('process', "Passed item doesn't appear to be a valid document");
            } elsif ($doc->{'_perl'}) {
                eval { $doc->{'_perl'}->{'code'}->($self, \$out) };
            } else {
                eval { $self->play_tree($doc->{'_tree'}, \$out) };
            }

            if ($self->{'TRIM'}) {
                $out =~ s{ \s+ $ }{}x;
                $out =~ s{ ^ \s+ }{}x;
            }

            ### handle exceptions
            if (my $err = $@) {
                $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type');
                $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
            }

        }

        ### append any output
        $$out_ref .= $out;
        if (my $err = $@) {
            die $err if ! UNIVERSAL::can($err, 'type') || $err->type !~ /return/;
        }
    }

    return;
}

sub play_RAWPERL {
    my ($self, $info, $node, $out_ref) = @_;
    $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};

    ### fill in any variables
    my $tree = $node->[4] || return;
    my $perl  = '';
    {
        local $self->{'STREAM'} = undef;
        $self->play_tree($tree, \$perl);
    }
    $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway

    ### try the code
    my $err;
    my $output = '';
    eval {
        package Template::Alloy::Perl;

        my $context = $self->context;
        my $stash   = $context->stash;

        eval $perl;
        $err = $@;
    };
    $err ||= $@;

    $$out_ref .= $output;

    if ($err) {
        $self->throw('undef', $err) if ! UNIVERSAL::can($err, 'type');
        die $err;
    }

    return;
}

sub play_RETURN {
    my ($self, $undef, $node) = @_;
    my $var = $node->[3];
    $var = {return_val => $self->play_expr($var)} if defined $var;
    $self->throw('return', $var, $node);
}

sub play_SET {
    my ($self, $set, $node) = @_;
    foreach my $item (@$set) {
        my ($op, $set, $val) = @$item;
        if (! defined $val) { # not defined
            # do nothing - allow for setting to 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';
            $val = '';
            local $self->{'STREAM'} = undef;
            $self->play_tree($sub_tree, \$val);
        } else { # normal var
            $val = $self->play_expr($val);
        }

        $self->set_variable($set, $val);
    }
    return;
}

sub play_SWITCH {
    my ($self, $var, $node, $out_ref) = @_;

    my $val = $self->play_expr($var);
    $val = '' if ! defined $val;
    ### $node->[4] is thrown away

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

        my $val2 = $self->play_expr($var);
        $val2 = [$val2] if ! UNIVERSAL::isa($val2, 'ARRAY');
        for my $test (@$val2) { # find matching values
            next if ! defined $val && defined $test;
            next if defined $val && ! defined $test;
            next if $val ne $test;
            my $body_ref = $node->[4] ||= [];
            $self->play_tree($body_ref, $out_ref);
            return;
        }
    }

    if ($default) {
        $self->play_tree($default, $out_ref);
    }

    return;
}

sub play_THROW {
    my ($self, $ref, $node) = @_;
    my ($name, $args) = @$ref;

    $name = $self->play_expr($name);

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

    @args = map { $self->play_expr($_) } @args;
    $self->throw($name, \@args, $node); # dies
    return; # but return just in case
}

sub play_TRY {
    my ($self, $foo, $node, $out_ref) = @_;
    my $out = '';

    my $body_ref = $node->[4];
    eval { $self->play_tree($body_ref, \$out) };
    my $err = $@;

    if (! $node->[5]) { # no catch or final
        if (! $err) { # no final block and no error
            $$out_ref .= $out;
            return;
        }
        $self->throw('parse.missing', "Missing CATCH block", $node);
    }
    if ($err) {
        $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type');
        if ($err->type =~ /stop|return/) {
            $$out_ref .= $out;
            die $err;
        }
    }

    ### loop through the nested catch and final blocks
    my $catch_body_ref;
    my $last_found;
    my $type = $err ? $err->type : '';
    my $final;
    while ($node = $node->[5]) { # CATCH
        if ($node->[0] eq 'FINAL') {
            $final = $node->[4];
            next;
        }
        next if ! $err;
        my $name = $self->play_expr($node->[3]);
        $name = '' if ! defined $name || lc($name) eq 'default';
        if ($type =~ / ^ \Q$name\E \b /x
            && (! defined($last_found) || length($last_found) < length($name))) { # more specific wins
            $catch_body_ref = $node->[4] || [];
            $last_found     = $name;
        }
    }

    ### play the best catch block
    if ($err) {
        if (! $catch_body_ref) {
            $$out_ref .= $out;
            die $err;
        }
        local $self->{'_vars'}->{'error'} = $err;
        local $self->{'_vars'}->{'e'}     = $err;
        eval { $self->play_tree($catch_body_ref, \$out) };
        if (my $err = $@) {
            $$out_ref .= $out;
            die $err;
        }
    }

    ### the final block
    $self->play_tree($final, \$out) if $final;

    $$out_ref .= $out;

    return;
}

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

sub play_USE {
    my ($self, $ref, $node, $out_ref, $foreign) = @_; # foreign allows for usage from JS
    my ($var, $module, $args) = @$ref;

    ### get the stash storage location - default to the module
    $var = $module if ! defined $var;
    my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
    pop @var; # remove the trailing '.'

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

    ### try and load the module - fall back to bare module if allowed
    my $obj;
    if (my $fact = $self->{'PLUGIN_FACTORY'}->{$module} || $self->{'PLUGIN_FACTORY'}->{lc $module}) {
        if (UNIVERSAL::isa($fact, 'CODE')) {
            $obj = $fact->($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args);
        }

    } elsif (my $pkg = $self->{'PLUGINS'}->{$module} || $self->{'PLUGINS'}->{lc $module}) {
        (my $req = "$pkg.pm") =~ s|::|/|g;
        if (UNIVERSAL::isa($pkg, 'UNIVERSAL') || eval { require $req }) {
            my $shape = $pkg->load;
            $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args);
        }

    } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works fine too)
        $obj = $self->iterator($foreign ? @$foreign : map { $self->play_expr($_) } @args);

    } else {
        my $found;
        my $BASE = $self->{'PLUGIN_BASE'};
        foreach my $base ((ref($BASE) eq 'ARRAY' ? @$BASE : $BASE), (my $e = 'TP-Fallback')) {
            if ($base && $base eq 'TP-Fallback' && eval { require Template::Plugins }) { # want to allow Template::Plugins without requiring we use them
                $base = $Template::Plugins::PLUGIN_BASE || next;
                if ($Template::Plugins::STD_PLUGINS
                    && (my $pkg = $Template::Plugins::STD_PLUGINS->{lc $module})) {
                    (my $req = "$pkg.pm") =~ s|::|/|g;
                    $found = 1;
                    if (eval { require $req }) {
                        my $shape = $pkg->load;
                        $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args);
                    }
                    last;
                }
            }
            next if ! $base;

            my $pkg = "${base}::${module}";
            (my $req = "$pkg.pm") =~ s|::|/|g;
            if ($pkg->can('load') || eval { require $req }) {
                my $shape = $pkg->load;
                $obj = $shape->new($self->context, $foreign ? @$foreign : map { $self->play_expr($_) } @args);
                $found = 1;
                last;
            }
        }

        if (! $found && $self->{'LOAD_PERL'}) {
            (my $req = "$module.pm") =~ s|::|/|g;
            if ($module->can('new') || eval { require $req }) {
                $obj = $module->new($foreign ? @$foreign : map { $self->play_expr($_) } @args);
            }
        }
    }

    if (! defined $obj) {
        my $err = "$module: plugin not found";
        $self->throw('plugin', $err);
    }

    return $obj if $foreign;
    $self->set_variable(\@var, $obj);

    return;
}

sub play_VIEW {
    my ($self, $ref, $node, $out_ref) = @_;

    my ($blocks, $args, $name) = @$ref;

    ### get args ready
    # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
    $args = $args->[0];
    my $hash = {};
    foreach (my $i = 2; $i < @$args; $i+=2) {
        my $key = $args->[$i];
        my $val = $self->play_expr($args->[$i+1]);
        if (ref $key) {
            if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
                $key = $key->[0];
            } else {
                $self->set_variable($key, $val);
                next; # what TT does
            }
        }
        $hash->{$key} = $val;
    }

    ### prepare the blocks
    my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : '';
    foreach my $key (keys %$blocks) {
        $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}};
    }
    $hash->{'blocks'} = $blocks;

    ### get the view
    if (! eval { require Template::View }) {
        $self->throw('view', 'Could not load Template::View library');
    }
    my $view = Template::View->new($self->context, $hash)
        || $self->throw('view', $Template::View::ERROR);

    ### 'play it'
    my $old_view = $self->play_expr(['view', 0]);
    $self->set_variable($name, $view);
    $self->set_variable(['view', 0], $view);

    if ($node->[4]) {
        my $out = '';
        $self->play_tree($node->[4], \$out);
        # throw away $out
    }

    $self->set_variable(['view', 0], $old_view);
    $view->seal;

    return;
}

sub play_WHILE {
    my ($self, $var, $node, $out_ref) = @_;
    return if ! defined $var;

    my $sub_tree = $node->[4];

    ### iterate use the iterator object
    my $count = $Template::Alloy::WHILE_MAX;
    while (--$count > 0) {

        $self->play_expr($var) || last;

        ### execute the sub tree
        eval { $self->play_tree($sub_tree, $out_ref) };
        if (my $err = $@) {
            if (UNIVERSAL::can($err, 'type')) {
                next if $err->type =~ /next/;
                last if $err->type =~ /last|break/;
            }
            die $err;
        }
    }
    die "WHILE loop terminated (> $Template::Alloy::WHILE_MAX iterations)\n" if ! $count;

    return;
}

sub play_WRAPPER {
    my ($self, $args, $node, $out_ref) = @_;
    my $sub_tree = $node->[4] || return;

    my ($named, @files) = @$args;

    my $out = '';
    {
        local $self->{'STREAM'} = undef;
        $self->play_tree($sub_tree, \$out);
        foreach my $name (reverse @files) {
            local $self->{'_vars'}->{'content'} = $out;
            $out = '';
            $DIRECTIVES->{'INCLUDE'}->($self, [$named, $name], $node, \$out);
        }
    }
    if ($self->{'STREAM'}) {
        print $out;
        $out = '';
    }

    $$out_ref .= $out;
    return;
}

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

package Template::Alloy::EvalPerlHandle;

sub TIEHANDLE {
    my ($class, $out_ref) = @_;
    return bless [$out_ref], $class;
}

sub PRINT {
    my $self = shift;
    ${ $self->[0] } .= $_ for grep {defined && length} @_;
    return 1;
}

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

1;

__END__