File Coverage

blib/lib/Template/Alloy.pm

Criterion	Covered	Total	%
statement	541	601	90.0
branch	391	502	77.8
condition	232	337	68.8
subroutine	37	39	94.8
pod	21	28	75.0
total	1222	1507	81.0

package Template::Alloy;

###----------------------------------------------------------------###
#  See the perldoc in Template/Alloy.pod                             #
#  Copyright 2007 - 2013 - Paul Seamons                              #
#  Distributed under the Perl Artistic License without warranty      #
###----------------------------------------------------------------###

use strict;
use warnings;
use Template::Alloy::Exception;
use Template::Alloy::Operator qw(play_operator define_operator);
use Template::Alloy::VMethod  qw(define_vmethod $SCALAR_OPS $ITEM_OPS $ITEM_METHODS $FILTER_OPS $LIST_OPS $HASH_OPS $VOBJS);

our $VERSION = '1.022';

our $QR_PRIVATE         = qr/^[_.]/;
our $WHILE_MAX          = 1000;
our $MAX_EVAL_RECURSE   = 50;
our $MAX_MACRO_RECURSE  = 50;
our $STAT_TTL           = 1;
our $QR_INDEX           = '(?:\d*\.\d+ | \d+)';
our @CONFIG_COMPILETIME = qw(SYNTAX CACHE_STR_REFS ANYCASE INTERPOLATE PRE_CHOMP POST_CHOMP ENCODING
                             SEMICOLONS V1DOLLAR V2PIPE V2EQUALS AUTO_EVAL SHOW_UNDEFINED_INTERP AUTO_FILTER);
our @CONFIG_RUNTIME     = qw(ADD_LOCAL_PATH CALL_CONTEXT DUMP VMETHOD_FUNCTIONS STRICT);
our $EVAL_CONFIG        = {map {$_ => 1} @CONFIG_COMPILETIME, @CONFIG_RUNTIME};
our $EXTRA_COMPILE_EXT  = '.sto';
our $PERL_COMPILE_EXT   = '.pl';
our $JS_COMPILE_EXT     = '.js';
our $GLOBAL_CACHE       = {};

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

our $AUTOROLE = {
    Compile  => [qw(load_perl compile_template compile_tree compile_expr)],
    HTE      => [qw(parse_tree_hte param output register_function clear_param query new_file new_scalar_ref new_array_ref new_filehandle)],
    Parse    => [qw(parse_tree parse_expr apply_precedence parse_args dump_parse_tree dump_parse_expr define_directive define_syntax)],
    Play     => [qw(play_tree _macro_sub)],
    Stream   => [qw(stream_tree)],
    JS       => [qw(load_js compile_template_js compile_tree_js play_js js_context process_js parse_tree_js process_jsr parse_tree_jsr)],
    TT       => [qw(parse_tree_tt3 process)],
    Tmpl     => [qw(parse_tree_tmpl set_delimiters set_strip set_value set_values parse_string set_dir parse_file loop_iteration fetch_loop_iteration)],
    Velocity => [qw(parse_tree_velocity merge)],
};
my $ROLEMAP = { map { my $type = $_; map { ($_ => $type) } @{ $AUTOROLE->{$type} } } keys %$AUTOROLE };
my %STANDIN = ('Template' => 'TT', 'Template::Toolkit' => 'TT', 'HTML::Template' => 'HTE', 'HTML::Template::Expr' => 'HTE', 'Text::Tmpl' => 'Tmpl');

our $AUTOLOAD;
sub AUTOLOAD {
    my $self = shift;
    my $meth = ($AUTOLOAD && $AUTOLOAD =~ /::(\w+)$/) ? $1 : $self->throw('autoload', "Invalid method $AUTOLOAD");
    if (! $self->can($meth)) {
        require Carp;
        Carp::croak("Can't locate object method \"$meth\" via package ".ref($self));
    }
    return $self->$meth(@_);
}

sub can {
    my ($self, $meth) = @_;
    __PACKAGE__->import($ROLEMAP->{$meth}) if $ROLEMAP->{$meth};
    return $self->SUPER::can($meth);
}

sub DESTROY {}

sub import {
    my $class = shift;
    foreach my $item (@_) {
        next if $item =~ /^(load|1)$/i;
        if (lc $item eq 'all') {
            local $AUTOROLE->{'JS'}; delete $AUTOROLE->{'JS'};
            return $class->import(keys %$AUTOROLE);
        }

        my $type;
        if ($type = $STANDIN{$item}) {
            (my $file = "$item.pm") =~ s|::|/|g;
            if (! $INC{$file} || ! $item->isa(__PACKAGE__)) {
                if ($INC{$file}) { require Carp; Carp::croak("Class $item is already loaded - can't override") }
                eval "{package $item; our \@ISA = qw(".__PACKAGE__.");}";
                $INC{$file} = __FILE__;
                next if ! $AUTOROLE->{$type}; # already imported
            }
        }
        $type ||= $AUTOROLE->{$item} ? $item : $ROLEMAP->{$item} || do { require Carp; Carp::croak("Invalid import option \"$item\"") };

        my $pkg   = __PACKAGE__."::$type";
        (my $file = "$pkg.pm") =~ s|::|/|g;
        require $file;

        no strict 'refs';
        *{__PACKAGE__."::$_"} = \&{"$pkg\::$_"} for @{ $AUTOROLE->{$type} };
        $AUTOROLE->{$type} = [];
    }
    return 1;
}

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

sub new {
  my $class = shift;
  my $args  = ref($_[0]) ? { %{ shift() } } : {@_};

  ### allow for lowercase args
  if (my @keys = grep {/^[a-z][a-z_]+$/} keys %$args) {
      @{ $args }{ map { uc $_ } @keys } = delete @{ $args }{ @keys };
  }

  return bless $args, $class;
}

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

sub run { shift->process_simple(@_) }

sub process_simple {
    my $self = shift;
    my $in   = shift || die "Missing input";
    my $swap = shift || die "Missing variable hash";
    my $out  = shift || ($self->{'STREAM'} ? \ "" : die "Missing output string ref");
    delete $self->{'error'};

    eval {
        delete $self->{'_debug_off'};
        delete $self->{'_debug_format'};
        local $self->{'_start_top_level'} = 1;
        $self->_process($in, $swap, $out);
    };
    if (my $err = $@) {
        if ($err->type !~ /stop|return|next|last|break/) {
            $self->{'error'} = $err;
            die $err if $self->{'RAISE_ERROR'};
            return;
        } elsif ($err->type eq 'return' && UNIVERSAL::isa($err->info, 'HASH')) {
            return $err->info->{'return_val'};
        }
    }
    return 1;
}

sub _process {
    my $self = shift;
    my $file = shift;
    local $self->{'_vars'} = shift || {};
    my $out_ref = shift || $self->throw('undef', "Missing output ref");
    local $self->{'_top_level'} = delete $self->{'_start_top_level'};
    my $i = length $$out_ref;

    ### parse and execute
    my $doc;
    eval {
        $doc = (ref($file) eq 'HASH') ? $file : $self->load_template($file);

        ### prevent recursion
        $self->throw('file', "recursion into '$doc->{name}'")
            if ! $self->{'RECURSION'} && $self->{'_in'}->{$doc->{'name'}} && $doc->{'name'} ne 'input text';

        local $self->{'_in'}->{$doc->{'name'}} = 1;
        local $self->{'_component'} = $doc;
        local $self->{'_template'}  = $self->{'_top_level'} ? $doc : $self->{'_template'};
        local @{ $self }{@CONFIG_RUNTIME} = @{ $self }{@CONFIG_RUNTIME};

        ### run the document however we can
        if ($self->{'STREAM'}) {
            $self->throw('process', 'No _tree found') if ! $doc->{'_tree'};
            $self->stream_tree($doc->{'_tree'});
        } elsif ($self->{'COMPILE_JS'}) {
            $self->play_js($doc, $out_ref);
        } elsif ($doc->{'_perl'}) {
            $doc->{'_perl'}->{'code'}->($self, $out_ref);
        } elsif ($doc->{'_tree'}) {
            $self->play_tree($doc->{'_tree'}, $out_ref);
        } else {
            $self->throw('process', 'No _perl and no _tree found');
        }

        ### trim whitespace from the beginning and the end of a block or template
        if ($self->{'TRIM'}) {
            substr($$out_ref, $i, length($$out_ref) - $i) =~ s{ \s+ $ }{}x; # tail first
            substr($$out_ref, $i, length($$out_ref) - $i) =~ 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;
        die $err if ! $self->{'_top_level'};
        die $err if $err->type ne 'stop' && ($err->type ne 'return' || $err->info);
    }

    return 1;
}

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

sub load_template {
    my ($self, $file) = @_;
    $self->throw('undef', 'Undefined file passed to load_template') if ! defined $file;

    my $docs = $self->{'GLOBAL_CACHE'} || ($self->{'_documents'} ||= {});
    $docs = $GLOBAL_CACHE if ! ref $docs;

    ### looks like a scalar ref
    my $doc;
    if (ref $file) {
        return $file if ref $file eq 'HASH';

        if (! defined($self->{'CACHE_STR_REFS'}) || $self->{'CACHE_STR_REFS'}) {
            my $_file = $self->string_id($file);
            if ($docs->{$_file}) { # no-ttl necessary
                $doc = $docs->{$_file};
                $doc->{'_perl'} = $self->load_perl($doc) if ! $doc->{'_perl'} && $self->{'COMPILE_PERL'}; # second hit
                return $doc;
            }
            $doc->{'_filename'} = $_file;
        } else {
            $doc->{'_no_perl'} = $self->{'FORCE_STR_REF_PERL'} ? 0 : 1;
        }
        $doc->{'_is_str_ref'} = 1;
        $doc->{'_content'}    = $file;
        $doc->{'name'}        = 'input text';
        $doc->{'modtime'}     = time;

    ### looks like a previously cached document
    } elsif ($docs->{$file}) {
        $doc = $docs->{$file};
        if (time - $doc->{'cache_time'} < ($self->{'STAT_TTL'} || $STAT_TTL) # don't stat more than once a second
            || $doc->{'modtime'} == (stat $doc->{'_filename'})[9]) {         # otherwise see if the file was modified
            $doc->{'_perl'} = $self->load_perl($doc) if ! $doc->{'_perl'} && $self->{'COMPILE_PERL'}; # second hit
            return $doc;
        }
        delete @$doc{qw(_tree modtime _content _line_offsets _perl _js)};

    ### looks like a previously cached not-found
    } elsif ($self->{'_not_found'}->{$file}) {
        $doc = $self->{'_not_found'}->{$file};
        if (time - $doc->{'cache_time'} < ($self->{'NEGATIVE_STAT_TTL'} || $self->{'STAT_TTL'} || $STAT_TTL)) { # negative cache for a second
            die $doc->{'exception'};
        }
        delete $self->{'_not_found'}->{$file}; # clear cache on failure

    ### looks like a block passed in at runtime
    } elsif ($self->{'BLOCKS'}->{$file}) {
        my $block = $self->{'BLOCKS'}->{$file};
        $block = $block->() if UNIVERSAL::isa($block, 'CODE');
        if (! UNIVERSAL::isa($block, 'HASH')) {
            $self->throw('block', "Unsupported BLOCK type \"$block\"") if ref $block;
            $block = eval { $self->load_template(\$block) } || $self->throw('block', 'Parse error on predefined block');
        }
        $doc->{'name'} = ($block->{'name'} && $block->{'name'} ne 'input text') ? $block->{'name'} : $file;
        $doc->{'_filename'} = $block->{'_filename'} if $block->{'_filename'};
        if ($block->{'_perl'}) {
            $doc->{'_perl'} = $block->{'_perl'};
        } elsif ($block->{'_tree'}) {
            $doc->{'_tree'} = $block->{'_tree'};
        } else {
            $self->throw('block', "Invalid block definition (missing tree)");
        }
        return $doc;
    }

    ### lookup the filename
    if (! $doc->{'_filename'} && ! ref $file) {
        $doc->{'name'} = $file;
        $doc->{'_filename'} = eval { $self->include_filename($file) };
        if (my $err = $@) {
            ### allow for blocks in other files
            if ($self->{'EXPOSE_BLOCKS'} && ! $self->{'_looking_in_block_file'}) {
                local $self->{'_looking_in_block_file'} = 1;
                my $block_name = '';
                OUTER: while ($file =~ s|/([^/.]+)$||) {
                    $block_name = length($block_name) ? "$1/$block_name" : $1;
                    my $ref = eval { $self->load_template($file) } || next;
                    my $_tree = $ref->{'_tree'};
                    foreach my $node (@$_tree) {
                        last if ! ref $node;
                        next if $node->[0] eq 'META';
                        last if $node->[0] ne 'BLOCK';
                        next if $block_name ne $node->[3];
                        $doc->{'_tree'} = $node->[4];
                        @{$doc}{qw(modtime _content)} = @{$ref}{qw(modtime _content)};
                        $doc->{'_perl'} = {
                            meta   => {},
                            blocks => {},
                            code   => $ref->{'_perl'}->{'blocks'}->{$block_name}->{'_perl'}->{'code'},
                        } if $ref->{'_perl'} && $ref->{'_perl'}->{'blocks'} && $ref->{'_perl'}->{'blocks'}->{$block_name};
                        $doc->{'_js'} = $self->load_js($doc) if $self->{'COMPILE_JS'} && $ref->{'_js'}; # have to regenerate because block is buried in js
                        return $doc;
                    }
              }
            } elsif ($self->{'DEFAULT'}) {
                $err = '' if ($doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) });
            }
            if ($err) {
                ### cache the negative error
                if (! defined($self->{'NEGATIVE_STAT_TTL'}) || $self->{'NEGATIVE_STAT_TTL'}) {
                    $err = $self->exception('undef', $err) if ! UNIVERSAL::can($err, 'type');
                    $self->{'_not_found'}->{$file} = {
                        cache_time => time,
                        exception  => $self->exception($err->type, $err->info." (cached)"),
                    };
                }
                die $err;
            }
        }
    }

    ### return perl - if they want perl - otherwise - the ast
    if (! $doc->{'_no_perl'} && $self->{'COMPILE_PERL'} && ($self->{'COMPILE_PERL'} ne '2' || $self->{'_tree'})) {
        $doc->{'_perl'} = $self->load_perl($doc);
    } elsif ($self->{'COMPILE_JS'}) {
        $self->load_js($doc);
    } else {
        $doc->{'_tree'} = $self->load_tree($doc);
    }

    ### cache parsed_tree in memory unless asked not to do so
    if (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'}) {
        $doc->{'cache_time'} = time;
        if (ref $file) {
            $docs->{$doc->{'_filename'}} = $doc if $doc->{'_filename'};
        } else {
            $docs->{$file} ||= $doc;
        }

        ### allow for config option to keep the cache size down
        if ($self->{'CACHE_SIZE'}) {
            if (scalar(keys %$docs) > $self->{'CACHE_SIZE'}) {
                my $n = 0;
                foreach my $file (sort {$docs->{$b}->{'cache_time'} <=> $docs->{$a}->{'cache_time'}} keys %$docs) {
                    delete($docs->{$file}) if ++$n > $self->{'CACHE_SIZE'};
                }
            }
        }
    }

    return $doc;
}

sub string_id {
    my ($self, $ref) = @_;
    require Digest::MD5;
    my $str = ref($self)
        && $self->{'ENCODING'} # ENCODING is defined
        && eval { require Encode } # Encode.pm is available
        && defined &Encode::encode
        ? Encode::encode($self->{'ENCODING'}, $$ref)
        : $$ref;
    my $sum = Digest::MD5::md5_hex($str);
    return 'Alloy_str_ref_cache/'.substr($sum,0,3).'/'.$sum;
}

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

    ### first look for a compiled optree
    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 .= $EXTRA_COMPILE_EXT     if defined $EXTRA_COMPILE_EXT;

            if (-e $file && ($doc->{'_is_str_ref'} || (stat $file)[9] == $doc->{'modtime'})) {
                require Storable;
                return Storable::retrieve($file);
            }
            $doc->{'_storable_filename'} = $file;
        }
    }

    ### no cached tree - we will need to load our own
    $doc->{'_content'} ||= $self->slurp($doc->{'_filename'});

    if ($self->{'CONSTANTS'}) {
        my $key = $self->{'CONSTANT_NAMESPACE'} || 'constants';
        $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'};
    }

    local $self->{'_component'} = $doc;
    my $tree = eval { $self->parse_tree($doc->{'_content'}) }
        || do { my $e = $@; $e->doc($doc) if UNIVERSAL::can($e, 'doc') && ! $e->doc; die $e }; # errors die

    ### save a cache on the fileside as asked
    if ($doc->{'_storable_filename'}) {
        my $dir = $doc->{'_storable_filename'};
        $dir =~ s|/[^/]+$||;
        if (! -d $dir) {
            require File::Path;
            File::Path::mkpath($dir);
        }
        require Storable;
        Storable::store($tree, $doc->{'_storable_filename'});
        utime $doc->{'modtime'}, $doc->{'modtime'}, $doc->{'_storable_filename'};
    }

    return $tree;
}

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

### allow for resolving full expression ASTs
sub play_expr {
    return $_[1] if ! ref $_[1]; # allow for the parse tree to store literals

    my $self = shift;
    my $var  = shift;
    my $ARGS = shift || {};
    my $i    = 0;

    ### determine the top level of this particular variable access
    my $ref;
    my $name = $var->[$i++];
    my $args = $var->[$i++];
    if (ref $name) {
        if (! defined $name->[0]) { # operator
            return $self->play_operator($name) if wantarray && $name->[1] eq '..';
            $ref = ($name->[1] eq '-temp-') ? $name->[2] : $self->play_operator($name);
        } else { # a named variable access (ie via $name.foo)
            $name = $self->play_expr($name);
            if (defined $name) {
                return if $QR_PRIVATE && $name =~ $QR_PRIVATE; # don't allow vars that begin with _
                return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name};
                $ref = $self->{'_vars'}->{$name};
            }
        }
    } elsif (defined $name) {
        return if $QR_PRIVATE && $name =~ $QR_PRIVATE; # don't allow vars that begin with _
        return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name};
        $ref = $self->{'_vars'}->{$name};
        if (! defined $ref) {
            $ref = ($name eq 'template' || $name eq 'component') ? $self->{"_$name"} : $VOBJS->{$name};
            $ref = $ITEM_METHODS->{$name} || $ITEM_OPS->{$name} if ! $ref && (! defined($self->{'VMETHOD_FUNCTIONS'}) || $self->{'VMETHOD_FUNCTIONS'});
            $ref = $self->{'_vars'}->{lc $name} if ! defined $ref && $self->{'LOWER_CASE_VAR_FALLBACK'};
        }
    }

    my %seen_filters;
    while (defined $ref) {

        ### check at each point if the returned thing was a code
        if (UNIVERSAL::isa($ref, 'CODE')) {
            return $ref if $i >= $#$var && $ARGS->{'return_ref'};
            my @args = $args ? map { $self->play_expr($_) } @$args : ();
            my $type = $self->{'CALL_CONTEXT'} || '';
            if ($type eq 'item') {
                $ref = $ref->(@args);
            } else {
                my @results = $ref->(@args);
                if ($type eq 'list') {
                    $ref = \@results;
                } elsif (defined $results[0]) {
                    $ref = ($#results > 0) ? \@results : $results[0];
                } elsif (defined $results[1]) {
                    die $results[1]; # TT behavior - why not just throw ?
                } else {
                    $ref = undef;
                    last;
                }
            }
        }

        ### descend one chained level
        last if $i >= $#$var;
        my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
        $name            = $var->[$i++];
        $args            = $var->[$i++];

        ### allow for named portions of a variable name (foo.$name.bar)
        if (ref $name) {
            if (ref($name) eq 'ARRAY') {
                $name = $self->play_expr($name);
                if (! defined($name) || ($QR_PRIVATE && $name =~ $QR_PRIVATE) || $name =~ /^\./) {
                    $ref = undef;
                    last;
                }
            } else {
                die "Shouldn't get a ". ref($name) ." during a vivify on chain";
            }
        }
        if (! defined $name || ($QR_PRIVATE && $name =~ $QR_PRIVATE)) { # don't allow vars that begin with _
            $ref = undef;
            last;
        }

        ### allow for scalar and filter access (this happens for every non virtual method call)
        if (! ref $ref) {
            if ($ITEM_METHODS->{$name}) {                      # normal scalar op
                $ref = $ITEM_METHODS->{$name}->($self, $ref, $args ? map { $self->play_expr($_) } @$args : ());

            } elsif ($ITEM_OPS->{$name}) {                     # normal scalar op
                $ref = $ITEM_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());

            } elsif ($LIST_OPS->{$name}) {                     # auto-promote to list and use list op
                $ref = $LIST_OPS->{$name}->([$ref], $args ? map { $self->play_expr($_) } @$args : ());

            } elsif (my $filter = $self->{'FILTERS'}->{$name}    # filter configured in Template args
                     || $FILTER_OPS->{$name}                     # predefined filters in Alloy
                     || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash
                     || $self->list_filters->{$name}) {          # filter defined in Template::Filters

                if (UNIVERSAL::isa($filter, 'CODE')) {
                    $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
                    if (my $err = $@) {
                        $self->throw('filter', $err) if ! UNIVERSAL::can($err, 'type');
                        die $err;
                    }
                } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) {
                    $self->throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)");

                } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters
                    eval {
                        my $sub = $filter->[0];
                        if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
                            ($sub, my $err) = $sub->($self->context, $args ? map { $self->play_expr($_) } @$args : ());
                            if (! $sub && $err) {
                                $self->throw('filter', $err) if ! UNIVERSAL::can($err, 'type');
                                die $err;
                            } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
                                $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
                                    if ! UNIVERSAL::can($sub, 'type');
                                die $sub;
                            }
                        }
                        $ref = $sub->($ref);
                    };
                    if (my $err = $@) {
                        $self->throw('filter', $err) if ! UNIVERSAL::can($err, 'type');
                        die $err;
                    }
                } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
                    $self->throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
                    $var = [$name, 0, '|', @$filter, @{$var}[$i..$#$var]]; # splice the filter into our current tree
                    $i = 2;
                }
                if (scalar keys %seen_filters
                    && $seen_filters{$var->[$i - 5] || ''}) {
                    $self->throw('filter', "invalid FILTER entry for '".$var->[$i - 5]."' (not a CODE ref)");
                }
            } else {
                $ref = undef;
            }

        } else {

            ### method calls on objects
            if ($was_dot_call && UNIVERSAL::can($ref, 'can')) {
                return $ref if $i >= $#$var && $ARGS->{'return_ref'};
                my $type = $self->{'CALL_CONTEXT'} || '';
                my @args = $args ? map { $self->play_expr($_) } @$args : ();
                if ($type eq 'item') {
                    $ref = $ref->$name(@args);
                    next;
                } elsif ($type eq 'list') {
                    $ref = [$ref->$name(@args)];
                    next;
                }
                my @results = eval { $ref->$name(@args) };
                if ($@) {
                    my $class = ref $ref;
                    die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/ || $type eq 'list';
                } elsif (defined $results[0]) {
                    $ref = ($#results > 0) ? \@results : $results[0];
                    next;
                } elsif (defined $results[1]) {
                    die $results[1]; # TT behavior - why not just throw ?
                } else {
                    $ref = undef;
                    last;
                }
                # didn't find a method by that name - so fail down to hash and array access
            }

            if (UNIVERSAL::isa($ref, 'HASH')) {
                if ($was_dot_call && exists($ref->{$name}) ) {
                    return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->{$name};
                    $ref = $ref->{$name};
                } elsif ($HASH_OPS->{$name}) {
                    $ref = $HASH_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
                } elsif ($ARGS->{'is_namespace_during_compile'}) {
                    return $var; # abort - can't fold namespace variable
                } else {
                    return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'};
                    $ref = undef;
                }

            } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
                if ($name =~ m{ ^ -? $QR_INDEX $ }ox) {
                    return \ $ref->[$name] if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->[$name];
                    $ref = $ref->[$name];
                } elsif ($LIST_OPS->{$name}) {
                    $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
                } else {
                    $ref = undef;
                }
            } else {
                $ref = undef;
            }
        }

    } # end of while

    if (! defined $ref) {
        $self->strict_throw($var) if $self->{'STRICT'}; # will die
        die $self->tt_var_string($var)." is undefined\n" if $self->{'_debug_undef'};
        $ref = $self->undefined_any($var);
    }

    return $ref;
}

sub set_variable {
    my ($self, $var, $val, $ARGS) = @_;
    $ARGS ||= {};
    my $i = 0;

    ### allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %])
    $var = [$var, 0] if ! ref $var;

    ### determine the top level of this particular variable access
    my $ref  = $var->[$i++];
    my $args = $var->[$i++];
    if (ref $ref) {
        ### non-named types can't be set
        return if ref($ref) ne 'ARRAY';
        if (! defined $ref->[0]) {
            return if ! $ref->[1] || $ref->[1] !~ /^[\$\@]\(\)$/; # do allow @( )
            $ref = $self->play_operator($ref);
        } else {
            # named access (ie via $name.foo)
            $ref = $self->play_expr($ref);
            if (defined $ref && (! $QR_PRIVATE || $ref !~ $QR_PRIVATE)) { # don't allow vars that begin with _
                if ($#$var <= $i) {
                    return $self->{'_vars'}->{$ref} = $val;
                } else {
                    $ref = $self->{'_vars'}->{$ref} ||= {};
                }
            } else {
                return;
            }
        }
    } elsif (defined $ref) {
        return if $QR_PRIVATE && $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
        if ($#$var <= $i) {
            return $self->{'_vars'}->{$ref} = $val;
        } else {
            $ref = $self->{'_vars'}->{$ref} ||= {};
        }
    }

    while (defined $ref) {

        ### check at each point if the returned thing was a code
        if (UNIVERSAL::isa($ref, 'CODE')) {
            my $type = $self->{'CALL_CONTEXT'} || '';
            my @args = $args ? map { $self->play_expr($_) } @$args : ();
            if ($type eq 'item') {
                $ref = $ref->(@args);
            } else {
                my @results = $ref->(@args);
                if ($type eq 'list') {
                    $ref = \@results;
                } elsif (defined $results[0]) {
                    $ref = ($#results > 0) ? \@results : $results[0];
                } elsif (defined $results[1]) {
                    die $results[1]; # TT behavior - why not just throw ?
                } else {
                    return;
                }
            }
        }

        ### descend one chained level
        last if $i >= $#$var;
        my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.';
        my $name         = $var->[$i++];
        my $args         = $var->[$i++];

        ### allow for named portions of a variable name (foo.$name.bar)
        if (ref $name) {
            if (ref($name) eq 'ARRAY') {
                $name = $self->play_expr($name);
                if (! defined($name) || $name =~ /^[_.]/) {
                    return;
                }
            } else {
                die "Shouldn't get a ".ref($name)." during a vivify on chain";
            }
        }
        if ($QR_PRIVATE && $name =~ $QR_PRIVATE) { # don't allow vars that begin with _
            return;
        }

        ### scalar access
        if (! ref $ref) {
            return;

        ### method calls on objects
        } elsif (UNIVERSAL::can($ref, 'can')) {
            my $lvalueish;
            my $type = $self->{'CALL_CONTEXT'} || '';
            my @args = $args ? map { $self->play_expr($_) } @$args : ();
            if ($i >= $#$var) {
                $lvalueish = 1;
                push @args, $val;
            }
            if ($type eq 'item') {
                $ref = $ref->$name(@args);
                return if $lvalueish;
                next;
            } elsif ($type eq 'list') {
                $ref = [$ref->$name(@args)];
                return if $lvalueish;
                next;
            }
            my @results = eval { $ref->$name(@args) };
            if (! $@) {
                if (defined $results[0]) {
                    $ref = ($#results > 0) ? \@results : $results[0];
                } elsif (defined $results[1]) {
                    die $results[1]; # TT behavior - why not just throw ?
                } else {
                    return;
                }
                return if $lvalueish;
                next;
            }
            my $class = ref $ref;
            die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/;
            # fall on down to "normal" accessors
        }

        if (UNIVERSAL::isa($ref, 'HASH')) {
            if ($#$var <= $i) {
                return $ref->{$name} = $val;
            } else {
                $ref = $ref->{$name} ||= {};
                next;
            }

        } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
            if ($name =~ m{ ^ -? $QR_INDEX $ }ox) {
                if ($#$var <= $i) {
                    return $ref->[$name] = $val;
                } else {
                    $ref = $ref->[$name] ||= {};
                    next;
                }
            } else {
                return;
            }

        }

    }

    return;
}

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

sub _vars {
    my $self = shift;
    $self->{'_vars'} = shift if @_ == 1;
    return $self->{'_vars'} ||= {};
}

sub include_filename {
    my ($self, $file) = @_;
    if ($file =~ m|^/|) {
        $self->throw('file', "$file absolute paths are not allowed (set ABSOLUTE option)") if ! $self->{'ABSOLUTE'};
        return $file if -e $file;
    } elsif ($file =~ m{(^|/)\.\./}) {
        $self->throw('file', "$file relative paths are not allowed (set RELATIVE option)") if ! $self->{'RELATIVE'};
        return $file if -e $file;
    }

    my @paths = @{ $self->include_paths };
    if ($self->{'ADD_LOCAL_PATH'}
        && $self->{'_component'}
        && $self->{'_component'}->{'_filename'}
        && $self->{'_component'}->{'_filename'} =~ m|^(.+)/[^/]+$|) {
        ($self->{'ADD_LOCAL_PATH'} < 0) ? push(@paths, $1) : unshift(@paths, $1);
    }

    foreach my $path (@paths) {
        return "$path/$file" if -e "$path/$file";
    }

    $self->throw('file', "$file: not found");
}

sub include_paths {
    my $self = shift;
    return $self->{'INCLUDE_PATHS'} ||= do {
        # TT does this everytime a file is looked up - we are going to do it just in time - the first time
        my $paths = $self->{'INCLUDE_PATH'} || ['.'];
        $paths = $paths->()                 if UNIVERSAL::isa($paths, 'CODE');
        $paths = $self->split_paths($paths) if ! UNIVERSAL::isa($paths, 'ARRAY');
        $paths; # return of the do
    };
}

sub split_paths {
    my ($self, $path) = @_;
    return $path if UNIVERSAL::isa($path, 'ARRAY');
    my $delim = $self->{'DELIMITER'} || ':';
    $delim = ($delim eq ':' && $^O eq 'MSWin32') ? qr|:(?!/)| : qr|\Q$delim\E|;
    return [split $delim, "$path"]; # allow objects to stringify as necessary
}

sub slurp {
    my ($self, $file) = @_;
    open(my $fh, '<', $file) || $self->throw('file', "$file couldn't be opened: $!");
    read $fh, my $txt, -s $file;

    if ($self->{'ENCODING'}) { # thanks to Carl Franks for this addition
        eval { require Encode };
        if ($@ || ! defined &Encode::decode) {
            warn "Encode module not found, 'ENCODING' config only available on perl >= 5.7.3\n$@";
        } else {
            $txt = Encode::decode($self->{'ENCODING'}, $txt);
        }
    }

    return \$txt;
}

sub error { shift->{'error'} }

sub exception {
    my $self_or_class = shift;
    my $type = shift;
    my $info = shift;
    return $type if UNIVERSAL::can($type, 'type');
    if (ref($info) eq 'ARRAY') {
        my $hash = ref($info->[-1]) eq 'HASH' ? pop(@$info) : {};
        if (@$info >= 2 || scalar keys %$hash) {
            my $i = 0;
            $hash->{$_} = $info->[$_] for 0 .. $#$info;
            $hash->{'args'} = $info;
            $info = $hash;
        } elsif (@$info == 1) {
            $info = $info->[0];
        } else {
            $info = $type;
            $type = 'undef';
        }
    }
    return Template::Alloy::Exception->new($type, $info, @_);
}

sub throw { die shift->exception(@_) }

sub context {
    my $self = shift;
    require Template::Alloy::Context;
    return Template::Alloy::Context->new({_template => $self});
}

sub iterator {
    my $self = shift;
    require Template::Alloy::Iterator;
    Template::Alloy::Iterator->new(@_);
}

sub undefined_get {
    my ($self, $ident, $node) = @_;
    return $self->{'UNDEFINED_GET'}->($self, $ident, $node) if $self->{'UNDEFINED_GET'};
    return '';
}

sub undefined_any {
    my ($self, $ident) = @_;
    return $self->{'UNDEFINED_ANY'}->($self, $ident) if $self->{'UNDEFINED_ANY'};
    return;
}

sub strict_throw {
    my ($self, $ident) = @_;
    my $v = $self->tt_var_string($ident);
    my $temp = $self->{'_template'}->{'name'};
    my $comp = $self->{'_component'}->{'name'};
    my $msg  = "undefined variable: $v in $comp".($comp ne $temp ? " while processing $temp" : '');
    return $self->{'STRICT_THROW'}->($self, 'var.undef', $msg, {name => $v, component => $comp, template => $temp, ident => $ident}) if $self->{'STRICT_THROW'};
    $self->throw('var.undef', $msg);
}

sub list_filters { shift->{'_filters'} ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {} }

sub debug_node {
    my ($self, $node) = @_;
    my $info = $self->node_info($node);
    my $format = $self->{'_debug_format'} || $self->{'DEBUG_FORMAT'} || "\n## \$file line \$line : [% \$text %] ##\n";
    $format =~ s{\$(file|line|text)}{$info->{$1}}g;
    return $format;
}

sub node_info {
    my ($self, $node) = @_;
    my $doc = $self->{'_component'};
    my $i = $node->[1];
    my $j = $node->[2] || return ''; # META can be 0
    return {
        file => $doc->{'name'},
        line => 'unknown',
        text => 'unknown',
    } if !$doc->{'_filename'} && !$doc->{'_content'};
    $doc->{'_content'} ||= $self->slurp($doc->{'_filename'});
    my $s = substr(${ $doc->{'_content'} }, $i, $j - $i);
    $s =~ s/^\s+//;
    $s =~ s/\s+$//;
    return {
        file => $doc->{'name'},
        line => $self->get_line_number_by_index($doc, $i),
        text => $s,
    };
}

sub get_line_number_by_index {
    my ($self, $doc, $index, $include_char) = @_;
    if (! $index || $index <= 0) {
        return $include_char ? (1, 1) : 1;
    }

    my $lines = $doc->{'_line_offsets'} ||= do {
        $doc->{'_content'} ||= $self->slurp($doc->{'_filename'});
        my $i = 0;
        my @lines = (0);
        while (1) {
            $i = index(${ $doc->{'_content'} }, "\n", $i) + 1;
            last if $i == 0;
            push @lines, $i;
        }
        \@lines;
    };

    ### binary search them (this is fast even on big docs)
    my ($i, $j) = (0, $#$lines);
    if ($index > $lines->[-1]) {
        $i = $j;
    } else {
        while (1) {
            last if abs($i - $j) <= 1;
            my $k = int(($i + $j) / 2);
            $j = $k if $lines->[$k] >= $index;
            $i = $k if $lines->[$k] <= $index;
        }
    }
    return $include_char ? ($i + 1, $index - $lines->[$i]) : $i + 1;
}

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

    return 'undef' if ! defined $var;
    return '['.join(', ', map { $self->ast_string($_) } @$var).']' if ref $var;
    return $var if $var =~ /^(-?[1-9]\d{0,13}|0)$/;

    $var =~ s/([\'\\])/\\$1/g;
    return "'$var'";
}

sub tt_var_string {
    my ($self, $ident) = @_;
    if (! ref $ident) {
        return $ident if $ident eq '0' || $ident =~ /^[1-9]\d{0,12}$/;
        $ident =~ s/\'/\\\'/g;
        return "'$ident'";
    }
    my $v = '';
    for (my $i = 0; $i < @$ident; ) {
        $v .= $ident->[$i++];
        $v .= '('.join(',',map{$self->tt_var_string($_)} @{$ident->[$i-1]}).')' if $ident->[$i++];
        $v .= $ident->[$i++] if $i < @$ident;
    }
    return $v;
}

sub item_method_eval {
    my $self = shift;
    my $text = shift; return '' if ! defined $text;
    my $args = shift || {};

    local $self->{'_eval_recurse'} = $self->{'_eval_recurse'} || 0;
    $self->throw('eval_recurse', "MAX_EVAL_RECURSE $Template::Alloy::MAX_EVAL_RECURSE reached")
        if ++$self->{'_eval_recurse'} > ($self->{'MAX_EVAL_RECURSE'} || $MAX_EVAL_RECURSE);

    my %ARGS;
    @ARGS{ map {uc} keys %$args } = values %$args;
    delete @ARGS{ grep {! $Template::Alloy::EVAL_CONFIG->{$_}} keys %ARGS };
    $self->throw("eval_strict", "Cannot disable STRICT once it is enabled") if exists $ARGS{'STRICT'} && ! $ARGS{'STRICT'};

    local @$self{ keys %ARGS } = values %ARGS;
    my $out = '';
    $self->process_simple(\$text, $self->_vars, \$out) || $self->throw($self->error);
    return $out;
}

1;

### See the perldoc in Template/Alloy.pod