package CGI::Ex::Template;

###----------------------------------------------------------------###
#  See the perldoc in CGI/Ex/Template.pod
#  Copyright 2006 - Paul Seamons                                     #
#  Distributed under the Perl Artistic License without warranty      #
###----------------------------------------------------------------###

use strict;
use constant trace => $ENV{'CET_TRACE'} || 0; # enable for low level tracing
use vars qw($VERSION
            $TAGS
            $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS $VOBJS
            $DIRECTIVES $QR_DIRECTIVE

            $OPERATORS
            $OP_DISPATCH
            $OP_ASSIGN
            $OP
            $OP_PREFIX
            $OP_POSTFIX
            $OP_TERNARY

            $QR_OP
            $QR_OP_PREFIX
            $QR_OP_ASSIGN

            $QR_COMMENTS
            $QR_FILENAME
            $QR_NUM
            $QR_AQ_NOTDOT
            $QR_AQ_SPACE
            $QR_PRIVATE

            $PACKAGE_EXCEPTION $PACKAGE_ITERATOR $PACKAGE_CONTEXT $PACKAGE_STASH $PACKAGE_PERL_HANDLE
            $WHILE_MAX
            $EXTRA_COMPILE_EXT
            $DEBUG
            );

BEGIN {
    $VERSION = '2.04';

    $PACKAGE_EXCEPTION   = 'CGI::Ex::Template::Exception';
    $PACKAGE_ITERATOR    = 'CGI::Ex::Template::Iterator';
    $PACKAGE_CONTEXT     = 'CGI::Ex::Template::_Context';
    $PACKAGE_STASH       = 'CGI::Ex::Template::_Stash';
    $PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle';

    $TAGS = {
        default  => ['[%',   '%]'],  # default
        template => ['[%',   '%]'],  # default
        metatext => ['%%',   '%%'],  # Text::MetaText
        star     => ['[*',   '*]'],  # TT alternate
        php      => ['<?',   '?>'],  # PHP
        asp      => ['<%',   '%>'],  # ASP
        mason    => ['<%',   '>' ],  # HTML::Mason
        html     => ['<!--', '-->'], # HTML comments
    };

    $SCALAR_OPS = {
        '0'      => sub { shift },
        as       => \&vmethod_as_scalar,
        chunk    => \&vmethod_chunk,
        collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
        defined  => sub { 1 },
        indent   => \&vmethod_indent,
        int      => sub { local $^W; int $_[0] },
        'format' => \&vmethod_format,
        hash     => sub { {value => $_[0]} },
        html     => sub { local $_ = $_[0]; s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; s/\"/&quot;/g; $_ },
        lcfirst  => sub { lcfirst $_[0] },
        length   => sub { defined($_[0]) ? length($_[0]) : 0 },
        list     => sub { [$_[0]] },
        lower    => sub { lc $_[0] },
        match    => \&vmethod_match,
        new      => sub { defined $_[0] ? $_[0] : '' },
        null     => sub { '' },
        rand     => sub { local $^W; rand shift },
        remove   => sub { vmethod_replace(shift, shift, '', 1) },
        repeat   => \&vmethod_repeat,
        replace  => \&vmethod_replace,
        search   => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return scalar $str =~ /$pat/ },
        size     => sub { 1 },
        split    => \&vmethod_split,
        stderr   => sub { print STDERR $_[0]; '' },
        substr   => sub { my ($str, $i, $len) = @_; defined($len) ? substr($str, $i, $len) : substr($str, $i) },
        trim     => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
        ucfirst  => sub { ucfirst $_[0] },
        upper    => sub { uc $_[0] },
        uri      => \&vmethod_uri,
    };

    $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops
        eval     => [\&filter_eval, 1],
        evaltt   => [\&filter_eval, 1],
        file     => [\&filter_redirect, 1],
        redirect => [\&filter_redirect, 1],
    };

    $LIST_OPS = {
        as      => \&vmethod_as_list,
        first   => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
        grep    => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
        hash    => sub { local $^W; my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
        join    => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
        last    => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]},
        list    => sub { $_[0] },
        max     => sub { $#{ $_[0] } },
        merge   => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
        new     => sub { local $^W; return [@_] },
        nsort   => \&vmethod_nsort,
        pop     => sub { pop @{ $_[0] } },
        push    => sub { my $ref = shift; push @$ref, @_; return '' },
        random  => sub { my $ref = shift; $ref->[ rand @$ref ] },
        reverse => sub { [ reverse @{ $_[0] } ] },
        shift   => sub { shift  @{ $_[0] } },
        size    => sub { scalar @{ $_[0] } },
        slice   => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
        sort    => \&vmethod_sort,
        splice  => \&vmethod_splice,
        unique  => sub { my %u; return [ grep { ! $u{$_} ++ } @{ $_[0] } ] },
        unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
    };

    $HASH_OPS = {
        as      => \&vmethod_as_hash,
        defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } },
        delete  => sub { return '' if ! defined $_[1]; delete  $_[0]->{ $_[1] } },
        each    => sub { [%{ $_[0] }] },
        exists  => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
        hash    => sub { $_[0] },
        import  => sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
        item    => sub { my ($h, $k) = @_; return '' if ! defined $k || $k =~ $QR_PRIVATE; $h->{$k} },
        items   => sub { [ %{ $_[0] } ] },
        keys    => sub { [keys %{ $_[0] }] },
        list    => sub { [$_[0]] },
        new     => sub { local $^W; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} },
        nsort   => sub { my $ref = shift; [sort {$ref->{$a}    <=> $ref->{$b}   } keys %$ref] },
        pairs   => sub { [map { {key => $_, value => $_[0]->{$_}} } keys %{ $_[0] } ] },
        size    => sub { scalar keys %{ $_[0] } },
        sort    => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] },
        values  => sub { [values %{ $_[0] }] },
    };

    $VOBJS = {
        Text => $SCALAR_OPS,
        List => $LIST_OPS,
        Hash => $HASH_OPS,
    };
    foreach (values %$VOBJS) {
        $_->{'Text'} = $_->{'as'};
        $_->{'Hash'} = $_->{'hash'};
        $_->{'List'} = $_->{'list'};
    }

    $DIRECTIVES = {
        #name       parse_sub        play_sub         block    postdir  continue  move_to_front
        BLOCK   => [\&parse_BLOCK,   \&play_BLOCK,    1,       0,       0,        1],
        BREAK   => [sub {},          \&play_control],
        CALL    => [\&parse_CALL,    \&play_CALL],
        CASE    => [\&parse_CASE,    undef,           0,       0,       {SWITCH => 1, CASE => 1}],
        CATCH   => [\&parse_CATCH,   undef,           0,       0,       {TRY => 1, CATCH => 1}],
        CLEAR   => [sub {},          \&play_CLEAR],
        '#'     => [sub {},          sub {}],
        DEBUG   => [\&parse_DEBUG,   \&play_DEBUG],
        DEFAULT => [\&parse_DEFAULT, \&play_DEFAULT],
        DUMP    => [\&parse_DUMP,    \&play_DUMP],
        ELSE    => [sub {},          undef,           0,       0,       {IF => 1, ELSIF => 1, UNLESS => 1}],
        ELSIF   => [\&parse_IF,      undef,           0,       0,       {IF => 1, ELSIF => 1, UNLESS => 1}],
        END     => [undef,           sub {}],
        FILTER  => [\&parse_FILTER,  \&play_FILTER,   1,       1],
        '|'     => [\&parse_FILTER,  \&play_FILTER,   1,       1],
        FINAL   => [sub {},          undef,           0,       0,       {TRY => 1, CATCH => 1}],
        FOR     => [\&parse_FOREACH, \&play_FOREACH,  1,       1],
        FOREACH => [\&parse_FOREACH, \&play_FOREACH,  1,       1],
        GET     => [\&parse_GET,     \&play_GET],
        IF      => [\&parse_IF,      \&play_IF,       1,       1],
        INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE],
        INSERT  => [\&parse_INSERT,  \&play_INSERT],
        LAST    => [sub {},          \&play_control],
        MACRO   => [\&parse_MACRO,   \&play_MACRO],
        META    => [undef,           sub {}],
        METADEF => [undef,           \&play_METADEF],
        NEXT    => [sub {},          \&play_control],
        PERL    => [\&parse_PERL,    \&play_PERL,     1],
        PROCESS => [\&parse_PROCESS, \&play_PROCESS],
        RAWPERL => [\&parse_PERL,    \&play_RAWPERL,  1],
        RETURN  => [sub {},          \&play_control],
        SET     => [\&parse_SET,     \&play_SET],
        STOP    => [sub {},          \&play_control],
        SWITCH  => [\&parse_SWITCH,  \&play_SWITCH,   1],
        TAGS    => [undef,           sub {}],
        THROW   => [\&parse_THROW,   \&play_THROW],
        TRY     => [sub {},          \&play_TRY,      1],
        UNLESS  => [\&parse_UNLESS,  \&play_UNLESS,   1,       1],
        USE     => [\&parse_USE,     \&play_USE],
        WHILE   => [\&parse_IF,      \&play_WHILE,    1,       1],
        WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER,  1,       1],
        #name       #parse_sub       #play_sub        #block   #postdir #continue #move_to_front
    };
    $QR_DIRECTIVE = qr{ ^ (\w+|\|) (?= $|[\s;\#]) }x;

    ### setup the operator parsing
    $OPERATORS = [
        # type      precedence symbols              action (undef means play_operator will handle)
        ['postfix', 99,        ['++'],              undef                                       ],
        ['postfix', 99,        ['--'],              undef                                       ],
        ['prefix',  98,        ['++'],              undef                                       ],
        ['prefix',  98,        ['--'],              undef                                       ],
        ['right',   96,        ['**', 'pow'],       sub {     $_[0] ** $_[1]                  } ],
        ['prefix',  93,        ['!'],               sub {   ! $_[0]                           } ],
        ['prefix',  93,        ['-'],               sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
        ['left',    90,        ['*'],               sub {     $_[0] *  $_[1]                  } ],
        ['left',    90,        ['/'],               sub {     $_[0] /  $_[1]                  } ],
        ['left',    90,        ['div', 'DIV'],      sub { int($_[0] /  $_[1])                 } ],
        ['left',    90,        ['%', 'mod', 'MOD'], sub {     $_[0] %  $_[1]                  } ],
        ['left',    85,        ['+'],               sub {     $_[0] +  $_[1]                  } ],
        ['left',    85,        ['-'],               sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
        ['left',    85,        ['~', '_'],          sub { join "", @_                         } ],
        ['none',    80,        ['<'],               sub {     $_[0] <  $_[1]                  } ],
        ['none',    80,        ['>'],               sub {     $_[0] >  $_[1]                  } ],
        ['none',    80,        ['<='],              sub {     $_[0] <= $_[1]                  } ],
        ['none',    80,        ['>='],              sub {     $_[0] >= $_[1]                  } ],
        ['none',    80,        ['lt'],              sub {     $_[0] lt $_[1]                  } ],
        ['none',    80,        ['gt'],              sub {     $_[0] gt $_[1]                  } ],
        ['none',    80,        ['le'],              sub {     $_[0] le $_[1]                  } ],
        ['none',    80,        ['ge'],              sub {     $_[0] ge $_[1]                  } ],
        ['none',    75,        ['==', 'eq'],        sub {     $_[0] eq $_[1]                  } ],
        ['none',    75,        ['!=', 'ne'],        sub {     $_[0] ne $_[1]                  } ],
        ['left',    70,        ['&&'],              undef                                       ],
        ['right',   65,        ['||'],              undef                                       ],
        ['none',    60,        ['..'],              sub {     $_[0] .. $_[1]                  } ],
        ['ternary', 55,        ['?', ':'],          undef                                       ],
        ['assign',  53,        ['+='],              sub {     $_[0] +  $_[1]                  } ],
        ['assign',  53,        ['-='],              sub {     $_[0] -  $_[1]                  } ],
        ['assign',  53,        ['*='],              sub {     $_[0] *  $_[1]                  } ],
        ['assign',  53,        ['/='],              sub {     $_[0] /  $_[1]                  } ],
        ['assign',  53,        ['%='],              sub {     $_[0] %  $_[1]                  } ],
        ['assign',  53,        ['**='],             sub {     $_[0]**  $_[1]                  } ],
        ['assign',  53,        ['~=', '_='],        sub {     $_[0] .  $_[1]                  } ],
        ['assign',  52,        ['='],               undef                                       ],
        ['prefix',  50,        ['not', 'NOT'],      sub {   ! $_[0]                           } ],
        ['left',    45,        ['and', 'AND'],      undef                                       ],
        ['right',   40,        ['or', 'OR'],        undef                                       ],
        ['',         0,        ['hash'],            sub { return {@_};                        } ],
        ['',         0,        ['array'],           sub { return [@_]                         } ],
    ];
    $OP          = {map {my $ref = $_; map {$_ => $ref}      @{$ref->[2]}} grep {$_->[0] ne 'prefix' } @$OPERATORS}; # all non-prefix
    $OP_PREFIX   = {map {my $ref = $_; map {$_ => $ref}      @{$ref->[2]}} grep {$_->[0] eq 'prefix' } @$OPERATORS};
    $OP_DISPATCH = {map {my $ref = $_; map {$_ => $ref->[3]} @{$ref->[2]}} grep {$_->[3]             } @$OPERATORS};
    $OP_ASSIGN   = {map {my $ref = $_; map {$_ => 1}         @{$ref->[2]}} grep {$_->[0] eq 'assign' } @$OPERATORS};
    $OP_POSTFIX  = {map {my $ref = $_; map {$_ => 1}         @{$ref->[2]}} grep {$_->[0] eq 'postfix'} @$OPERATORS}; # bool is postfix
    $OP_TERNARY  = {map {my $ref = $_; map {$_ => 1}         @{$ref->[2]}} grep {$_->[0] eq 'ternary'} @$OPERATORS}; # bool is ternary
    sub _op_qr { # no mixed \w\W operators
        my %used;
        my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_;
        my $chr  = join '',          sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/}     @_;
        my $word = join '|', reverse sort                    grep {++$used{$_} < 2} grep {/^\w+$/}    @_;
        $chr = "[$chr]" if $chr;
        $word = "\\b(?:$word)\\b" if $word;
        return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex";
    }
    sub _build_op_qr        { _op_qr(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS) }
    sub _build_op_qr_prefix { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS) }
    sub _build_op_qr_assign { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS) }
    $QR_OP        = _build_op_qr();
    $QR_OP_PREFIX = _build_op_qr_prefix();
    $QR_OP_ASSIGN = _build_op_qr_assign();

    $QR_COMMENTS  = '(?-s: \# .* \s*)*';
    $QR_FILENAME  = '([a-zA-Z]]:/|/)? [\w\-\.]+ (?:/[\w\-\.]+)*';
    $QR_NUM       = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?';
    $QR_AQ_NOTDOT = "(?! \\s* $QR_COMMENTS \\.)";
    $QR_AQ_SPACE  = '(?: \\s+ | \$ | (?=[;+]) )'; # the + comes into play on filenames
    $QR_PRIVATE   = qr/^_/;

    $WHILE_MAX    = 1000;
    $EXTRA_COMPILE_EXT = '.sto';
};

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

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

  ### "enable" debugging - we only support DEBUG_DIRS and DEBUG_UNDEF
  if ($self->{'DEBUG'}) {
      $self->{'_debug_dirs'}  = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 8 : $self->{'DEBUG'} =~ /dirs|all/;
      $self->{'_debug_undef'} = 1 if $self->{'DEBUG'} =~ /^\d+$/ ? $self->{'DEBUG'} & 2 : $self->{'DEBUG'} =~ /undef|all/;
  }

  return $self;
}

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

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 {
        ### load the document
        $doc = $self->load_parsed_tree($file) || $self->throw('undef', "Zero length content");;

        ### 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;

        ### execute the document
        if (! @{ $doc->{'_tree'} }) { # no tags found - just return the content
            $$out_ref = ${ $doc->{'_content'} };
        } else {
            local $self->{'_vars'}->{'component'} = $doc;
            $self->{'_vars'}->{'template'}  = $doc if $self->{'_top_level'};
            $self->execute_tree($doc->{'_tree'}, $out_ref);
            delete $self->{'_vars'}->{'template'} if $self->{'_top_level'};
        }
    };

    ### 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 ref($err) !~ /Template::Exception$/;
        $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
        die $err if ! $self->{'_top_level'} || $err->type !~ /stop|return/;
    }

    return 1;
}

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

sub load_parsed_tree {
    my $self = shift;
    my $file = shift;
    return if ! defined $file;

    my $doc = {name => $file};

    ### looks like a string reference
    if (ref $file) {
        $doc->{'_content'}   = $file;
        $doc->{'name'}       = 'input text';
        $doc->{'is_str_ref'} = 1;

    ### looks like a previously cached-in-memory document
    } elsif ($self->{'_documents'}->{$file}
             && (   ($self->{'_documents'}->{$file}->{'_cache_time'} == time) # don't stat more than once a second
                 || ($self->{'_documents'}->{$file}->{'modtime'}
                     == (stat $self->{'_documents'}->{$file}->{'_filename'})[9]))) {
        $doc = $self->{'_documents'}->{$file};
        $doc->{'_cache_time'} = time;
        return $doc;

    ### looks like a block name of some sort
    } elsif ($self->{'BLOCKS'}->{$file}) {
        my $block = $self->{'BLOCKS'}->{$file};

        ### allow for predefined blocks that are a code or a string
        if (UNIVERSAL::isa($block, 'CODE')) {
            $block = $block->();
        }
        if (! UNIVERSAL::isa($block, 'HASH')) {
            $self->throw('block', "Unsupported BLOCK type \"$block\"") if ref $block;
            my $copy = $block;
            $block = eval { $self->load_parsed_tree(\$copy) }
                || $self->throw('block', 'Parse error on predefined block');
        }
        $doc->{'_tree'} = $block->{'_tree'} || $self->throw('block', "Invalid block definition (missing tree)");
        return $doc;


    ### go and look on the file system
    } else {
        $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 = '';
                while ($file =~ s|/([^/.]+)$||) {
                    $block_name = length($block_name) ? "$1/$block_name" : $1;
                    my $ref = eval { $self->load_parsed_tree($file) } || next;
                    my $_tree = $ref->{'_tree'};
                    foreach my $node (@$_tree) {
                        next if ! ref $node;
                        next if $node->[0] eq 'METADEF';
                        last if $node->[0] ne 'BLOCK';
                        next if $block_name ne $node->[3];
                        $doc->{'_content'} = $ref->{'_content'};
                        $doc->{'_tree'}    = $node->[4];
                        $doc->{'modtime'} = $ref->{'modtime'};
                        $file = $ref->{'name'};
                        last;
                    }
                }
                die $err if ! $doc->{'_tree'};
            } elsif ($self->{'DEFAULT'}) {
                $doc->{'_filename'} = eval { $self->include_filename($self->{'DEFAULT'}) } || die $err;
            } else {
                die $err;
            }
        }

        ### no tree yet - look for a file cache
        if (! $doc->{'_tree'}) {
            $doc->{'modtime'} = (stat $doc->{'_filename'})[9];
            if  ($self->{'COMPILE_DIR'} || $self->{'COMPILE_EXT'}) {
                if ($self->{'COMPILE_DIR'}) {
                    $doc->{'_compile_filename'} = $self->{'COMPILE_DIR'} .'/'. $file;
                } else {
                    $doc->{'_compile_filename'} = $doc->{'_filename'};
                }
                $doc->{'_compile_filename'} .= $self->{'COMPILE_EXT'} if defined($self->{'COMPILE_EXT'});
                $doc->{'_compile_filename'} .= $EXTRA_COMPILE_EXT       if defined $EXTRA_COMPILE_EXT;

                if (-e $doc->{'_compile_filename'} && (stat _)[9] == $doc->{'modtime'}) {
                    require Storable;
                    $doc->{'_tree'} = Storable::retrieve($doc->{'_compile_filename'});
                    $doc->{'compile_was_used'} = 1;
                } else {
                    my $str = $self->slurp($doc->{'_filename'});
                    $doc->{'_content'}  = \$str;
                }
            } else {
                my $str = $self->slurp($doc->{'_filename'});
                $doc->{'_content'}  = \$str;
            }
        }

    }

    ### haven't found a parsed tree yet - parse the content into a tree
    if (! $doc->{'_tree'}) {
        if ($self->{'CONSTANTS'}) {
            my $key = $self->{'CONSTANT_NAMESPACE'} || 'constants';
            $self->{'NAMESPACE'}->{$key} ||= $self->{'CONSTANTS'};
        }

        local $self->{'_vars'}->{'component'} = $doc;
        $doc->{'_tree'} = $self->parse_tree($doc->{'_content'}); # errors die
    }

    ### cache parsed_tree in memory unless asked not to do so
    if (! $doc->{'is_str_ref'} && (! defined($self->{'CACHE_SIZE'}) || $self->{'CACHE_SIZE'})) {
        $self->{'_documents'}->{$file} ||= $doc;
        $doc->{'_cache_time'} = time;

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

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

    return $doc;
}

sub parse_tree {
    my $self    = shift;
    my $str_ref = shift;
    if (! $str_ref || ! defined $$str_ref) {
        $self->throw('parse.no_string', "No string or undefined during parse");
    }

    my $STYLE = $self->{'TAG_STYLE'} || 'default';
    my $START = $self->{'START_TAG'} || $TAGS->{$STYLE}->[0];
    my $END   = $self->{'END_TAG'}   || $TAGS->{$STYLE}->[1];
    my $len_s = length $START;
    my $len_e = length $END;

    my @tree;             # the parsed tree
    my $pointer = \@tree; # pointer to current tree to handle nested blocks
    my @state;            # maintain block levels
    local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS)
    local $self->{'_in_perl'};         # no interpolation in perl
    my @move_to_front;    # items that need to be declared first (usually BLOCKS)
    my @meta;             # place to store any found meta information (to go into METADEF)
    my $i = 0;            # start index
    my $j = 0;            # end index
    my $last = 0;         # previous end index
    my $post_chomp = 0;   # previous post_chomp setting
    my $continue;         # multiple directives in the same tag
    my $post_op;          # found a post-operative DIRECTIVE
    my $capture;          # flag to start capture
    my $func;
    my $node;
    my $tag;
    while (1) {
        ### continue looking for information in a semi-colon delimited tag
        if ($continue) {
            $i = $continue;
            $node = [undef, $i, $j];

        ### look through the string using index
        } else {
            $i = index($$str_ref, $START, $last);
            last if $i == -1; # no start tag found - we are done
            if ($last != $i) { # found a text portion - chomp it, interpolate it and store it
                my $text  = substr($$str_ref, $last, $i - $last);
                my $_last = $last;
                if ($post_chomp) {
                    if    ($post_chomp == 1) { $_last += length($1)     if $text =~ s{ ^ ([^\S\n]* \n) }{}x  }
                    elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+)         }{ }x }
                    elsif ($post_chomp == 3) { $_last += length($1)     if $text =~ s{ ^ (\s+)         }{}x  }
                }
                if (length $text) {
                    push @$pointer, $text;
                    $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
                }
            }
            $j = index($$str_ref, $END, $i + $len_s);
            $last = $j + $len_e;
            if ($j == -1) { # missing closing tag
                $last = length($$str_ref);
                last;
            }
            $tag = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
            $node = [undef, $i + $len_s, $j];

            ### take care of whitespace and comments flags
            my $pre_chomp = $tag =~ s{ ^ ([+=~-]) }{}x ? $1 : $self->{'PRE_CHOMP'};
            $post_chomp   = $tag =~ s{ ([+=~-]) $ }{}x ? $1 : $self->{'POST_CHOMP'};
            $pre_chomp  =~ y/-=~+/1230/ if $pre_chomp;
            $post_chomp =~ y/-=~+/1230/ if $post_chomp;
            if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) {
                if    ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x  }
                elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{             (\s+) \z }{ }x }
                elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{             (\s+) \z }{}x  }
                splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length
            }
            if ($tag =~ /^\#/) { # leading # means to comment the entire section
                $node->[0] = '#';
                push @$pointer, $node;
                next;
            }
            $tag =~ s{ ^ \s+ $QR_COMMENTS }{}ox;
        }

        if (! length $tag) {
            undef $continue;
            undef $post_op;
            next;
        }

        ### look for DIRECTIVES
        if ($tag =~ $QR_DIRECTIVE     # find a word
            && $DIRECTIVES->{$1} ) {  # is it a directive
            $node->[0] = $func = $1;
            $tag =~ s{ ^ (\w+ | \|) \s* $QR_COMMENTS }{}ox;

            ### store out this current node level
            if ($post_op) { # on a post operator - replace the original node with the new one - store the old in the new
                my @post_op = @$post_op;
                @$post_op = @$node;
                $node = $post_op;
                $node->[4] = [\@post_op];
            } elsif ($capture) {
                # do nothing - it will be handled further down
            } else{
                push @$pointer, $node;
            }

            ### anything that behaves as a block ending
            if ($func eq 'END' || $DIRECTIVES->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc)
                if (! @state) {
                    $self->throw('parse', "Found an $func tag while not in a block", $node);
                }
                my $parent_node = pop @state;

                if ($func ne 'END') {
                    pop @$pointer; # we will store the node in the parent instead
                    $parent_node->[5] = $node;
                    my $parent_type = $parent_node->[0];
                    if (! $DIRECTIVES->{$func}->[4]->{$parent_type}) {
                        $self->throw('parse', "Found unmatched nested block", $node, 0);
                    }
                }

                ### restore the pointer up one level (because we hit the end of a block)
                $pointer = (! @state) ? \@tree : $state[-1]->[4];

                ### normal end block
                if ($func eq 'END') {
                    if ($DIRECTIVES->{$parent_node->[0]}->[5]) { # move things like BLOCKS to front
                        push @move_to_front, $parent_node;
                        if ($pointer->[-1] && ! $pointer->[-1]->[6]) { # capturing doesn't remove the var
                            splice(@$pointer, -1, 1, ());
                        }
                    } elsif ($parent_node->[0] =~ /PERL$/) {
                        delete $self->{'_in_perl'};
                    }

                ### continuation block - such as an elsif
                } else {
                    $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \$tag, $node) };
                    if (my $err = $@) {
                        $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
                        die $err;
                    }
                    push @state, $node;
                    $pointer = $node->[4] ||= [];
                }

            } elsif ($func eq 'TAGS') {
                if ($tag =~ / ^ (\w+) /x && $TAGS->{$1}) {
                    $tag =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox;
                    ($START, $END) = @{ $TAGS->{$1} };
                } elsif ($tag =~ s{ ^ (\S+) \s+ (\S+) \s* $QR_COMMENTS }{}ox) {
                    ($START, $END) = ($1, $2);
                }
                $len_s = length $START;
                $len_e = length $END;

            } elsif ($func eq 'META') {
                my $args = $self->parse_args(\$tag);
                my $hash;
                if (($hash = $self->play_expr($args->[-1]))
                    && UNIVERSAL::isa($hash, 'HASH')) {
                    unshift @meta, %$hash; # first defined win
                }

            ### all other "normal" tags
            } else {
                $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \$tag, $node) };
                if (my $err = $@) {
                    $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
                    die $err;
                }
                if ($DIRECTIVES->{$func}->[2] && ! $post_op) { # this looks like a block directive
                    push @state, $node;
                    $pointer = $node->[4] ||= [];
                }
            }

        ### allow for bare variable getting and setting
        } elsif (defined(my $var = $self->parse_expr(\$tag))) {
            push @$pointer, $node;
            if ($tag =~ s{ ^ ($QR_OP_ASSIGN) >? \s* $QR_COMMENTS }{}ox) {
                $node->[0] = 'SET';
                $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, \$tag, $node, $1, $var) };
                if (my $err = $@) {
                    $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
                    die $err;
                }
            } else {
                $node->[0] = 'GET';
                $node->[3] = $var;
            }

        } else { # error
            my $all  = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
            $all =~ s/^\s+//;
            $all =~ s/\s+$//;
            $self->throw('parse', "Not sure how to handle tag \"$all\"", $node);
        }

        ### we now have the directive to capture for an item like "SET foo = BLOCK" - store it
        if ($capture) {
            my $parent_node = $capture;
            push @{ $parent_node->[4] }, $node;
            undef $capture;
        }

        ### we are flagged to start capturing the output of the next directive - set it up
        if ($node->[6]) {
            $continue  = $j - length $tag;
            $node->[2] = $continue;
            $post_op   = undef;
            $capture   = $node;

        ### semi-colon = end of statement - we will need to continue parsing this tag
        } elsif ($tag =~ s{ ^ ; \s* $QR_COMMENTS }{}ox) {
            $continue  = $j - length $tag;
            $node->[2] = $continue;
            $post_op   = undef;

        ### looking at a post operator ([% u FOREACH u IN [1..3] %])
        } elsif ($tag =~ $QR_DIRECTIVE         # find a word
                 && $DIRECTIVES->{$1}          # is it a directive
                 && $DIRECTIVES->{$1}->[3]) {  # it is a post operative directive
            $continue  = $j - length $tag;
            $node->[2] = $continue;
            $post_op   = $node;

        ### unlink TT2 - look for another directive
        } elsif (length $tag) {
            #$self->throw('parse', "Found trailing info \"$tag\"", $node);
            $continue  = $j - length $tag;
            $node->[2] = $continue;
            $post_op   = undef;

        } else {
            $continue = undef;
            $post_op  = undef;
        }
    }

    if (@move_to_front) {
        unshift @tree, @move_to_front;
    }
    if (@meta) {
        unshift @tree, ['METADEF', 0, 0, {@meta}];
    }

    if ($#state > -1) {
        $self->throw('parse.missing.end', "Missing END", $state[-1], 0);
    }

    ### pull off the last text portion - if any
    if ($last != length($$str_ref)) {
        my $text  = substr($$str_ref, $last, length($$str_ref) - $last);
        my $_last = $last;
        if ($post_chomp) {
            if    ($post_chomp == 1) { $_last += length($1)     if $text =~ s{ ^ ([^\S\n]* \n) }{}x  }
            elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+)         }{ }x }
            elsif ($post_chomp == 3) { $_last += length($1)     if $text =~ s{ ^ (\s+)         }{}x  }
        }
        if (length $text) {
            push @$pointer, $text;
            $self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
        }
    }

    return \@tree;
}

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

    # 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) {
            warn "NODE: TEXT\n" if trace;
            $$out_ref .= $node if defined $node;
            next;
        }

        warn "NODE: $node->[0] (char $node->[1])\n" if trace;
        $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};

        my $val = $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref);
        $$out_ref .= $val if defined $val;
    }
}

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

sub parse_expr {
    my $self    = shift;
    my $str_ref = shift;
    my $ARGS    = shift || {};

    ### allow for custom auto_quoting (such as hash constructors)
    if ($ARGS->{'auto_quote'}) {
        if ($$str_ref =~ $ARGS->{'auto_quote'}) {
            my $str = $1;
            substr($$str_ref, 0, length($str), '');
            $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox;
            return $str;
        ### allow for auto-quoted $foo or ${foo.bar} type constructs
        } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox
                 || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
            my $name = $1;
            return $self->parse_expr(\$name);
        }
    }

    my $copy = $$str_ref; # copy while parsing to allow for errors

    ### test for leading prefix operators
    my $has_prefix;
    while ($copy =~ s{ ^ ($QR_OP_PREFIX) \s* $QR_COMMENTS }{}ox) {
        return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
        push @{ $has_prefix }, $1;
    }

    my @var;
    my $is_literal;
    my $is_namespace;

    ### allow hex
    if ($copy =~ s{ ^ 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }{}ox) {
        my $number = eval { hex $1 } || 0;
        push @var, \ $number;
        $is_literal = 1;

    ### allow for numbers
    } elsif ($copy =~ s{ ^ ( $QR_NUM ) \s* $QR_COMMENTS }{}ox) {
        my $number = $1;
        push @var, \ $number;
        $is_literal = 1;

    ### allow for quoted array constructor
    } elsif ($copy =~ s{ ^ qw (\W) \s* }{}x) {
        my $quote = $1;
        $quote =~ y|([{<|)]}>|;
        $copy =~ s{ ^ (.*) \Q$quote\E \s* $QR_COMMENTS }{}sx
            || $self->throw('parse.missing.array_close', "Missing close \"$quote\"", undef, length($$str_ref) - length($copy));
        my $str = $1;
        $str =~ s{ ^ \s+ | \s+ $ }{}x;
        my $arrayref = ['array', split /\s+/, $str];
        push @var, \ $arrayref;

    ### looks like a normal variable start
    } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
        push @var, $1;
        $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};

    ### allow for literal strings
    } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) {
        if ($1 eq "'") { # no interpolation on single quoted strings
            my $str = $2;
            $str =~ s{ \\\' }{\'}xg;
            push @var, \ $str;
            $is_literal = 1;
        } else {
            my $str = $2;
            $str =~ s/\\n/\n/g;
            $str =~ s/\\t/\t/g;
            $str =~ s/\\r/\r/g;
            $str =~ s/\\([\"\$])/$1/g;
            my @pieces = $ARGS->{'auto_quote'}
                ? split(m{ (\$\w+            | \$\{ [^\}]+ \}) }x, $str)  # autoquoted items get a single $\w+ - no nesting
                : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $str);
            my $n = 0;
            foreach my $piece (@pieces) {
                next if ! ($n++ % 2);
                next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
                    && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x;
                my $name = $1;
                $piece = $self->parse_expr(\$name);
            }
            @pieces = grep {defined && length} @pieces;
            if (@pieces == 1 && ! ref $pieces[0]) {
                push @var, \ $pieces[0];
                $is_literal = 1;
            } elsif (! @pieces) {
                push @var, \ '';
                $is_literal = 1;
            } else {
                push @var, \ ['~', @pieces];
            }
        }
        if ($ARGS->{'auto_quote'}){
            $$str_ref = $copy;
            return ${ $var[0] } if $is_literal;
            push @var, 0;
            return \@var;
        }

    ### allow for leading $foo or ${foo.bar} type constructs
    } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox
        || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
        my $name = $1;
        push @var, $self->parse_expr(\$name);

    ### looks like an array constructor
    } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) {
        local $self->{'_operator_precedence'} = 0; # reset presedence
        my $arrayref = ['array'];
        while (defined(my $var = $self->parse_expr(\$copy))) {
            push @$arrayref, $var;
            $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
        }
        $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox
            || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, length($$str_ref) - length($copy));
        push @var, \ $arrayref;

    ### looks like a hash constructor
    } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) {
        local $self->{'_operator_precedence'} = 0; # reset precedence
        my $hashref = ['hash'];
        while (defined(my $key = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) {
            $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox;
            my $val = $self->parse_expr(\$copy);
            push @$hashref, $key, $val;
            $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
        }
        $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox
            || $self->throw('parse.missing.curly_bracket', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy));
        push @var, \ $hashref;

    ### looks like a paren grouper
    } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
        local $self->{'_operator_precedence'} = 0; # reset precedence
        my $var = $self->parse_expr(\$copy, {allow_parened_ops => 1});
        $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
            || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
        @var = @$var;
        pop(@var); # pull off the trailing args of the paren group

    ### nothing to find - return failure
    } else {
        return;
    }

    return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated

    ### looks for args for the initial
    if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
        local $self->{'_operator_precedence'} = 0; # reset precedence
        my $args = $self->parse_args(\$copy);
        $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
            || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
        push @var, $args;
    } else {
        push @var, 0;
    }

    ### allow for nested items
    while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) {
        push(@var, $1) if ! $ARGS->{'no_dots'};

        ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two
        if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox
            || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) {
            my $name = $1;
            my $var = $self->parse_expr(\$name);
            push @var, $var;

        ### allow for names
        } elsif ($copy =~ s{ ^ (-? \w+) \s* $QR_COMMENTS }{}ox) {
            push @var, $1;

        } else {
            $self->throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)");
        }

        ### looks for args for the nested item
        if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
            local $self->{'_operator_precedence'} = 0; # reset precedence
            my $args = $self->parse_args(\$copy);
            $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
                || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
            push @var, $args;
        } else {
            push @var, 0;
        }

    }

    ### flatten literals and constants as much as possible
    my $var = ($is_literal && $#var == 1) ? ${ $var[0] }
            : $is_namespace               ? $self->play_expr(\@var, {is_namespace_during_compile => 1})
            :                               \@var;

    ### allow for all "operators"
    if (! $self->{'_operator_precedence'}) {
        my $tree;
        my $found;
        while ($copy =~ s{ ^ ($QR_OP) (\s* $QR_COMMENTS) }{}ox) { ## look for operators - then move along
            if (! $ARGS->{'allow_parened_ops'} && $OP_ASSIGN->{$1}) {
                $copy = $1 . $2 . $copy;
                last;
            }

            local $self->{'_operator_precedence'} = 1;
            my $op = $1;

            ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --)
            if ($OP_POSTFIX->{$op}) {
                $var = [\ [$op, $var, 1], 0]; # cheat - give a "second value" to postfix ops
                next;

            ### allow for prefix operator precedence
            } elsif ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix->[-1]}->[1]) {
                if ($tree) {
                    if ($#$tree == 1) { # only one operator - keep simple things fast
                        $var = [\ [$tree->[0], $var, $tree->[1]], 0];
                    } else {
                        unshift @$tree, $var;
                        $var = $self->apply_precedence($tree, $found);
                    }
                    undef $tree;
                    undef $found;
                }
                $var = [ \ [ $has_prefix->[-1], $var ], 0 ];
                if (! @$has_prefix) { undef $has_prefix } else { pop @$has_prefix }
            }

            ### add the operator to the tree
            my $var2 =  $self->parse_expr(\$copy);
            push (@{ $tree ||= [] }, $op, $var2);
            $found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op}
        }

        ### if we found operators - tree the nodes by operator precedence
        if ($tree) {
            if (@$tree == 2) { # only one operator - keep simple things fast
                $var = [\ [$tree->[0], $var, $tree->[1]], 0];
            } else {
                unshift @$tree, $var;
                $var = $self->apply_precedence($tree, $found);
            }
        }
    }

    ### allow for prefix on non-chained variables
    if ($has_prefix) {
        $var = [ \ [ $_, $var ], 0 ] for reverse @$has_prefix;
    }

    $$str_ref = $copy; # commit the changes
    return $var;
}

### this is used to put the parsed variables into the correct operations tree
sub apply_precedence {
    my ($self, $tree, $found) = @_;

    my @var;
    my $trees;
    ### look at the operators we found in the order we found them
    for my $prec (sort keys %$found) {
        my $ops = $found->{$prec};
        local $found->{$prec};
        delete $found->{$prec};

        ### split the array on the current operators for this level
        my @ops;
        my @exprs;
        for (my $i = 1; $i <= $#$tree; $i += 2) {
            next if ! $ops->{ $tree->[$i] };
            push @ops, $tree->[$i];
            push @exprs, [splice @$tree, 0, $i, ()];
            shift @$tree;
            $i = -1;
        }
        next if ! @exprs; # this iteration didn't have the current operator
        push @exprs, $tree if scalar @$tree; # add on any remaining items

        ### simplify sub expressions
        for my $node (@exprs) {
            if (@$node == 1) {
                $node = $node->[0]; # single item - its not a tree
            } elsif (@$node == 3) {
                $node = [ \ [ $node->[1], $node->[0], $node->[2] ], 0 ]; # single operator - put it straight on
            } else {
                $node = $self->apply_precedence($node, $found); # more complicated - recurse
            }
        }

        ### assemble this current level

        ### some rules:
        # 1) items at the same precedence level must all be either right or left or ternary associative
        # 2) ternary items cannot share precedence with anybody else.
        # 3) there really shouldn't be another operator at the same level as a postfix
        my $type = $OP->{$ops[0]}->[0];

        if ($type eq 'ternary') {
            my $op = $OP->{$ops[0]}->[2]->[0]; # use the first op as what we are using

            ### return simple ternary
            if (@exprs == 3) {
                $self->throw('parse', "Ternary operator mismatch") if $ops[0] ne $op;
                $self->throw('parse', "Ternary operator mismatch") if ! $ops[1] || $ops[1] eq $op;
                return [ \ [ $op, @exprs ], 0 ];
            }


            ### reorder complex ternary - rare case
            while ($#ops >= 1) {
                ### if we look starting from the back - the first lead ternary op will always be next to its matching op
                for (my $i = $#ops; $i >= 0; $i --) {
                    next if $OP->{$ops[$i]}->[2]->[1] eq $ops[$i];
                    my ($op, $op2) = splice @ops, $i, 2, (); # remove the pair of operators
                    my $node = [ \ [$op, @exprs[$i .. $i + 2] ], 0 ];
                    splice @exprs, $i, 3, $node;
                }
            }
            return $exprs[0]; # at this point the ternary has been reduced to a single operator

        } elsif ($type eq 'right' || $type eq 'assign') {
            my $val = $exprs[-1];
            $val = [ \ [ $ops[$_ - 1], $exprs[$_], $val ], 0 ] for reverse (0 .. $#exprs - 1);
            return $val;

        } else {
            my $val = $exprs[0];
            $val = [ \ [ $ops[$_ - 1], $val, $exprs[$_] ], 0 ] for (1 .. $#exprs);
            return $val;

        }
    }

    $self->throw('parse', "Couldn't apply precedence");
}

### look for arguments - both positional and named
sub parse_args {
    my $self    = shift;
    my $str_ref = shift;
    my $ARGS    = shift || {};
    my $copy    = $$str_ref;

    my @args;
    my @named;
    while (length $$str_ref) {
        my $copy = $$str_ref;
        if (defined(my $name = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
            && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
            $self->throw('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'};
            my $val = $self->parse_expr(\$copy);
            $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
            push @named, $name, $val;
            $$str_ref = $copy;
        } elsif (defined(my $arg = $self->parse_expr($str_ref))) {
            push @args, $arg;
            $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
        } else {
            last;
        }
    }

    ### allow for named arguments to be added also
    push @args, [\ ['hash', @named], 0] if scalar @named;

    return \@args;
}

### allow for looking for $foo or ${foo.bar} in TEXT "nodes" of the parse tree.
sub interpolate_node {
    my ($self, $tree, $offset) = @_;
    return if $self->{'_in_perl'};

    ### split on variables while keeping the variables
    my @pieces = split m{ (?: ^ | (?<! \\)) (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $tree->[-1];
    if ($#pieces <= 0) {
        $tree->[-1] =~ s{ \\ ([\"\$]) }{$1}xg;
        return;
    }

    my @sub_tree;
    my $n = 0;
    foreach my $piece (@pieces) {
        $offset += length $piece; # we track the offset to make sure DEBUG has the right location
        if (! ($n++ % 2)) { # odds will always be text chunks
            next if ! length $piece;
            $piece =~ s{ \\ ([\"\$]) }{$1}xg;
            push @sub_tree, $piece;
        } elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
                 || $piece =~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x) {
            my $name = $1;
            push @sub_tree, ['GET', $offset - length($piece), $offset, $self->parse_expr(\$name)];
        } else {
            $self->throw('parse', "Parse error during interpolate node");
        }
    }

    ### replace the tree
    splice @$tree, -1, 1, @sub_tree;
}

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

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

    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++];
    warn "play_expr: begin \"$name\"\n" if trace;
    if (ref $name) {
        if (ref $name eq 'SCALAR') { # a scalar literal
            $ref = $$name;
        } elsif (ref $name eq 'REF') { # operator
            return $self->play_operator($$name) if ${ $name }->[0] eq '..';
            $ref = $self->play_operator($$name);
        } else { # a named variable access (ie via $name.foo)
            $name = $self->play_expr($name);
            if (defined $name) {
                return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
                $ref = $self->{'_vars'}->{$name};
            }
        }
    } elsif (defined $name) {
        if ($ARGS->{'is_namespace_during_compile'}) {
            $ref = $self->{'NAMESPACE'}->{$name};
        } else {
            return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
            $ref = $self->{'_vars'}->{$name};
            $ref = $VOBJS->{$name} if ! defined $ref;
        }
    }


    my %seen_filters;
    while (defined $ref) {

        ### check at each point if the rurned thing was a code
        if (UNIVERSAL::isa($ref, 'CODE')) {
            my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ());
            if (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++];
        warn "play_expr: nested \"$name\"\n" if trace;

        ### 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 =~ $QR_PRIVATE || $name =~ /^\./) {
                    $ref = undef;
                    last;
                }
            } else {
                die "Shouldn't get a ". ref($name) ." during a vivify on chain";
            }
        }
        if ($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 ($SCALAR_OPS->{$name}) {                        # normal scalar op
                $ref = $SCALAR_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 CET
                     || (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 ref($err) !~ /Template::Exception$/;
                        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 ref($err) !~ /Template::Exception$/;
                                die $err;
                            } elsif (! UNIVERSAL::isa($sub, 'CODE')) {
                                $self->throw('filter', "invalid FILTER for '$name' (not a CODE ref)")
                                    if ref($sub) !~ /Template::Exception$/;
                                die $sub;
                            }
                        }
                        $ref = $sub->($ref);
                    };
                    if (my $err = $@) {
                        $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/;
                        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')) {
                my @args = $args ? map { $self->play_expr($_) } @$args : ();
                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"/;
                } 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
            }

            ### hash member access
            if (UNIVERSAL::isa($ref, 'HASH')) {
                if ($was_dot_call && exists($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 {
                    $ref = undef;
                }

            ### array access
            } elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
                if ($name =~ m{ ^ -? $QR_NUM $ }ox) {
                    $ref = $ref->[$name];
                } elsif ($LIST_OPS->{$name}) {
                    $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
                } else {
                    $ref = undef;
                }
            }
        }

    } # end of while

    ### allow for undefinedness
    if (! defined $ref) {
        if ($self->{'_debug_undef'}) {
            my $chunk = $var->[$i - 2];
            $chunk = $self->play_expr($chunk) if ref($chunk) eq 'ARRAY';
            die "$chunk is undefined\n";
        } else {
            $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) {
        if (ref($ref) eq 'ARRAY') { # named access (ie via $name.foo)
            $ref = $self->play_expr($ref);
            if (defined $ref && $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;
            }
        } else { # all other types can't be set
            return;
        }
    } elsif (defined $ref) {
        return if $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 @results = $ref->($args ? map { $self->play_expr($_) } @$args : ());
            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;
            }
        }

        ### 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 ($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 @args = $args ? map { $self->play_expr($_) } @$args : ();
            if ($i >= $#$var) {
                $lvalueish = 1;
                push @args, $val;
            }
            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
        }

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

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

        }

    }

    return;
}

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

sub play_operator {
    my $self = shift;
    my $tree = shift;

    if ($OP_DISPATCH->{$tree->[0]}) {
        local $^W;
        if ($OP_ASSIGN->{$tree->[0]}) {
            my $val = $OP_DISPATCH->{$tree->[0]}->( $self->play_expr($tree->[1]), $self->play_expr($tree->[2]) );
            $self->set_variable($tree->[1], $val);
            return $val;
        } else {
            return $OP_DISPATCH->{$tree->[0]}->( map { $self->play_expr($tree->[$_]) } 1 .. $#$tree );
        }
    }

    my $op = $tree->[0];

    ### do custom and short-circuitable operators
    if ($op eq '=') {
        my $val = $self->play_expr($tree->[2]);
        $self->set_variable($tree->[1], $val);
        return $val;

   } elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
        return $self->play_expr($tree->[1]) || $self->play_expr($tree->[2]) || '';

    } elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') {
        my $var = $self->play_expr($tree->[1]) && $self->play_expr($tree->[2]);
        return $var ? $var : 0;

    } elsif ($op eq '?') {
        local $^W;
        return $self->play_expr($tree->[1]) ? $self->play_expr($tree->[2]) : $self->play_expr($tree->[3]);

    } elsif ($op eq '++') {
        local $^W;
        my $val = 0 + $self->play_expr($tree->[1]);
        $self->set_variable($tree->[1], $val + 1);
        return $tree->[2] ? $val : $val + 1; # ->[2] is set to 1 during parsing of postfix ops

    } elsif ($op eq '--') {
        local $^W;
        my $val = 0 + $self->play_expr($tree->[1]);
        $self->set_variable($tree->[1], $val - 1);
        return $tree->[2] ? $val : $val - 1; # ->[2] is set to 1 during parsing of postfix ops
    }

    $self->throw('operator', "Un-implemented operation $op");
}

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

sub parse_BLOCK {
    my ($self, $tag_ref, $node) = @_;

    my $block_name = '';
    if ($$tag_ref =~ s{ ^ (\w+ (?: :\w+)*) \s* (?! [\.\|]) }{}x
        || $$tag_ref =~ s{ ^ '(|.*?[^\\])' \s* (?! [\.\|]) }{}x
        || $$tag_ref =~ s{ ^ "(|.*?[^\\])" \s* (?! [\.\|]) }{}x
        ) {
        $block_name = $1;
        ### allow for nested blocks to have nested names
        my @names = map {$_->[3]} grep {$_->[0] eq 'BLOCK'} @{ $self->{'_state'} };
        $block_name = join("/", @names, $block_name) if scalar @names;
    }

    return $block_name;
}

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

    ### store a named reference - but do nothing until something processes it
    $self->{'BLOCKS'}->{$block_name} = {
        _tree => $node->[4],
        name  => $self->{'_vars'}->{'component'}->{'name'} .'/'. $block_name,
    };

    return;
}

sub parse_CALL { $DIRECTIVES->{'GET'}->[0]->(@_) }

sub play_CALL { $DIRECTIVES->{'GET'}->[1]->(@_); return }

sub parse_CASE {
    my ($self, $tag_ref) = @_;
    return if $$tag_ref =~ s{ ^ DEFAULT \s* }{}x;
    return $self->parse_expr($tag_ref);
}

sub parse_CATCH {
    my ($self, $tag_ref) = @_;
    return $self->parse_expr($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
}

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 = '';
}

sub parse_DEBUG {
    my ($self, $tag_ref) = @_;
    $$tag_ref =~ s{ ^ (on | off | format) \s* }{}xi || $self->throw('parse', "Unknown DEBUG option");
    my $ret = [lc($1)];
    if ($ret->[0] eq 'format') {
        $$tag_ref =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* }{}xs || $self->throw('parse', "Missing format string");
        $ret->[1] = $2;
    }
    return $ret;
}

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];
    }
}

sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) }

sub play_DEFAULT {
    my ($self, $set) = @_;
    foreach (@$set) {
        my ($op, $set, $default) = @$_;
        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 parse_DUMP {
    my ($self, $tag_ref) = @_;
    my $ref = $self->parse_expr($tag_ref);
    return $ref;
}

sub play_DUMP {
    my ($self, $ident, $node) = @_;
    require Data::Dumper;
    my $info = $self->node_info($node);
    my $out;
    my $var;
    if ($ident) {
        $out = Data::Dumper::Dumper($self->play_expr($ident));
        $var = $info->{'text'};
        $var =~ s/^[+\-~=]?\s*DUMP\s+//;
        $var =~ s/\s*[+\-~=]?$//;
    } else {
        my @were_never_here = (qw(template component), grep {$_ =~ $QR_PRIVATE} keys %{ $self->{'_vars'} });
        local @{ $self->{'_vars'} }{ @were_never_here };
        delete @{ $self->{'_vars'} }{ @were_never_here };
        $out = Data::Dumper::Dumper($self->{'_vars'});
        $var = 'EntireStash';
    }
    if ($ENV{'REQUEST_METHOD'}) {
        $out =~ s/</&lt;/g;
        $out = "<pre>$out</pre>";
        $out =~ s/\$VAR1/$var/;
        $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out";
    } else {
        $out =~ s/\$VAR1/$var/;
    }

    return $out;
}

sub parse_FILTER {
    my ($self, $tag_ref) = @_;
    my $name = '';
    if ($$tag_ref =~ s{ ^ ([^\W\d]\w*) \s* = \s* }{}x) {
        $name = $1;
    }

    my $filter = $self->parse_expr($tag_ref);
    $filter = '' if ! defined $filter;

    return [$name, $filter];
}

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 { $self->execute_tree($sub_tree, \$out) };
    die $@ if $@ && ref($@) !~ /Template::Exception$/;

    my $var = [\$out, 0, '|', @$filter]; # make a temporary var out of it


    return $DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
}

sub parse_FOREACH {
    my ($self, $tag_ref) = @_;
    my $items = $self->parse_expr($tag_ref);
    my $var;
    if ($$tag_ref =~ s{ ^ (= | [Ii][Nn]\b) \s* }{}x) {
        $var = [@$items];
        $items = $self->parse_expr($tag_ref);
    }
    return [$var, $items];
}

sub play_FOREACH {
    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 = $PACKAGE_ITERATOR->new($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);

            ### execute the sub tree
            eval { $self->execute_tree($sub_tree, $out_ref) };
            if (my $err = $@) {
                if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
                    if ($err->type eq 'next') {
                        ($item, $error) = $items->get_next;
                        next;
                    }
                    last if $err->type =~ /last|break/;
                }
                die $err;
            }

            ($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) {

            if (ref($item) eq 'HASH') {
                @$copy{keys %$item} = values %$item;
            }

            ### execute the sub tree
            eval { $self->execute_tree($sub_tree, $out_ref) };
            if (my $err = $@) {
                if (UNIVERSAL::isa($err, $PACKAGE_EXCEPTION)) {
                    if ($err->type eq 'next') {
                        ($item, $error) = $items->get_next;
                        next;
                    }
                    last if $err->type =~ /last|break/;
                }
                die $err;
            }

            ($item, $error) = $items->get_next;
        }
        die $error if $error && $error != 3; # Template::Constants::STATUS_DONE;
    }

    return undef;
}

sub parse_GET {
    my ($self, $tag_ref) = @_;
    my $ref = $self->parse_expr($tag_ref);
    $self->throw('parse', "Missing variable name") if ! defined $ref;
    return $ref;
}

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

sub parse_IF {
    my ($self, $tag_ref) = @_;
    return $self->parse_expr($tag_ref);
}

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

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

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

sub parse_INCLUDE { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }

sub play_INCLUDE {
    my ($self, $tag_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};

    my $str = $DIRECTIVES->{'PROCESS'}->[1]->($self, $tag_ref, $node, $out_ref);

    return $str;
}

sub parse_INSERT { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }

sub play_INSERT {
    my ($self, $var, $node, $out_ref) = @_;
    my ($names, $args) = @$var;

    foreach my $name (@$names) {
        my $filename = $self->play_expr($name);
        $$out_ref .= $self->_insert($filename);
    }

    return;
}

sub parse_MACRO {
    my ($self, $tag_ref, $node) = @_;
    my $copy = $$tag_ref;

    my $name = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo});
    $self->throw('parse', "Missing macro name") if ! defined $name;
    if (! ref $name) {
        $name = [ $name, 0 ];
    }

    my $args;
    if ($copy =~ s{ ^ \( \s* }{}x) {
        $args = $self->parse_args(\$copy, {positional_only => 1});
        $copy =~ s { ^ \) \s* }{}x || $self->throw('parse.missing', "Missing close ')'");
    }

    $node->[6] = 1;           # set a flag to keep parsing
    $$tag_ref = $copy;
    return [$name, $args];
}

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 ($sub_tree->[0]->[0] eq 'BLOCK') {
        $sub_tree = $sub_tree->[0]->[4];
    }

    my $self_copy = $self->weak_copy;

    ### install a closure in the stash that will handle the macro
    $self->set_variable($name, sub {
        ### macros localize
        my $copy = $self_copy->{'_vars'};
        local $self_copy->{'_vars'}= {%$copy};

        ### 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});
        }

        ### finally - run the sub tree
        my $out = '';
        $self_copy->execute_tree($sub_tree, \$out);
        return $out;
    });

    return;
}

sub play_METADEF {
    my ($self, $hash) = @_;
    my $ref;
    if ($self->{'_top_level'}) {
        $ref = $self->{'_vars'}->{'template'} ||= {};
    } else {
        $ref = $self->{'_vars'}->{'component'} ||= {};
    }
    foreach my $key (keys %$hash) {
        next if $key eq 'name' || $key eq 'modtime';
        $ref->{$key} = $hash->{$key};
    }
    return;
}

sub parse_PERL { shift->{'_in_perl'} = 1; 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  = '';
    $self->execute_tree($perl, \$out);
    $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway

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

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

        ### setup a fake handle
        local *PERLOUT;
        tie *PERLOUT, $CGI::Ex::Template::PACKAGE_PERL_HANDLE, $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 ref($err) !~ /Template::Exception$/;
        die $err;
    }

    return;
}

sub parse_PROCESS {
    my ($self, $tag_ref) = @_;
    my $info = [[], []];
    while (defined(my $filename = $self->parse_expr($tag_ref, {
                       auto_quote => qr{ ^ ($QR_FILENAME | \w+ (?: :\w+)* ) $QR_AQ_SPACE }xo,
                   }))) {
        push @{$info->[0]}, $filename;
        last if $$tag_ref !~ s{ ^ \+ \s* }{}x;
    }

    ### allow for post process variables
    while (length $$tag_ref) {
        last if $$tag_ref =~ / ^ (\w+) (?: ;|$|\s)/x && $DIRECTIVES->{$1}; ### looks like a directive - we are done

        my $var = $self->parse_expr($tag_ref);
        last if ! defined $var;
        if ($$tag_ref !~ s{ ^ = >? \s* }{}x) {
            $self->throw('parse.missing.equals', 'Missing equals while parsing args');
        }

        my $val = $self->parse_expr($tag_ref);
        push @{$info->[1]}, [$var, $val];
        $$tag_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox if $val;
    }

    return $info;
}

sub play_PROCESS {
    my ($self, $info, $node, $out_ref) = @_;

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

    ### set passed args
    foreach (@$args) {
        my ($key, $val) = @$_;
        $val = $self->play_expr($val);
        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 $ref (@$files) {
        next if ! defined $ref;
        my $filename = $self->play_expr($ref);
        my $out = ''; # have temp item to allow clear to correctly clear

        ### normal blocks or filenames
        if (! ref $filename) {
            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 {
            $self->throw('process', "Unable to process document $filename") if $ref->[0] ne 'template';
            $self->throw('process', "Recursion detected in $node->[0] \$template") if $self->{'_process_dollar_template'};
            local $self->{'_process_dollar_template'} = 1;
            local $self->{'_vars'}->{'component'} = my $doc = $filename;
            return if ! $doc->{'_tree'};

            ### execute and trim
            eval { $self->execute_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 ref($err) !~ /Template::Exception$/;
                $err->doc($doc) if $doc && $err->can('doc') && ! $err->doc;
            }

        }

        ### append any output
        $$out_ref .= $out;
        if (my $err = $@) {
            die $err if ref($err) !~ /Template::Exception$/ || $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  = '';
    $self->execute_tree($tree, \$perl);
    $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway

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

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

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

    $$out_ref .= $output;

    if ($err) {
        $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
        die $err;
    }

    return;
}

sub parse_SET {
    my ($self, $tag_ref, $node, $initial_op, $initial_var) = @_;
    my @SET;
    my $copy = $$tag_ref;
    my $func;

    if ($initial_op) {
        if ($$tag_ref =~ $QR_DIRECTIVE   # find a word
            && $DIRECTIVES->{$1}) {      # is it a directive - if so set up capturing
            $node->[6] = 1;              # set a flag to keep parsing
            my $val = $node->[4] ||= []; # setup storage
            return [[$initial_op, $initial_var, $val]];
        } else { # get a normal variable
            return [[$initial_op, $initial_var, $self->parse_expr($tag_ref)]];
        }
    }

    while (length $$tag_ref) {
        my $set = $self->parse_expr($tag_ref);
        last if ! defined $set;

        if ($$tag_ref =~ s{ ^ ($QR_OP_ASSIGN) >? \s* }{}x) {
            my $op = $1;
            if ($$tag_ref =~ $QR_DIRECTIVE   # find a word
                && $DIRECTIVES->{$1}) {      # is it a directive - if so set up capturing
                $node->[6] = 1;              # set a flag to keep parsing
                my $val = $node->[4] ||= []; # setup storage
                push @SET, [$op, $set, $val];
                last;
            } else { # get a normal variable
                push @SET, [$op, $set, $self->parse_expr($tag_ref)];
            }
        } else {
            push @SET, ['=', $set, undef];
        }
    }
    return \@SET;
}

sub play_SET {
    my ($self, $set, $node) = @_;
    foreach (@$set) {
        my ($op, $set, $val) = @$_;
        if (! defined $val) { # not defined
            $val = '';
        } 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 = '';
            $self->execute_tree($sub_tree, \$val);
        } else { # normal var
            $val = $self->play_expr($val);
        }

        if ($OP_DISPATCH->{$op}) {
            local $^W;
            $val = $OP_DISPATCH->{$op}->($self->play_expr($set), $val);
        }

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

sub parse_SWITCH { $DIRECTIVES->{'GET'}->[0]->(@_) }

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;
            if ($val ne $test) { # check string-wise first - then numerical
                next if $val  !~ m{ ^ -? $QR_NUM $ }ox;
                next if $test !~ m{ ^ -? $QR_NUM $ }ox;
                next if $val != $test;
            }

            my $body_ref = $node->[4] ||= [];
            $self->execute_tree($body_ref, $out_ref);
            return;
        }
    }

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

    return;
}

sub parse_THROW {
    my ($self, $tag_ref, $node) = @_;
    my $name = $self->parse_expr($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
    $self->throw('parse.missing', "Missing name in THROW", $node) if ! $name;
    my $args = $self->parse_args($tag_ref);
    return [$name, $args];
}

sub play_THROW {
    my ($self, $ref, $node) = @_;
    my ($name, $args) = @$ref;
    $name = $self->play_expr($name);
    my @args = $args ? map { $self->play_expr($_) } @$args : ();
    $self->throw($name, \@args, $node);
}

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

    my $body_ref = $node->[4];
    eval { $self->execute_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 ref($err) !~ /Template::Exception$/;
        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->execute_tree($catch_body_ref, \$out) };
        if (my $err = $@) {
            $$out_ref .= $out;
            die $err;
        }
    }

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

    $$out_ref .= $out;

    return;
}

sub parse_UNLESS {
    my $ref = $DIRECTIVES->{'IF'}->[0]->(@_);
    return [ \ [ '!', $ref ], 0 ];
}

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

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

    my $var;
    my $copy = $$tag_ref;
    if (defined(my $_var = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
        && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
        $var = $_var;
        $$tag_ref = $copy;
    }

    $copy = $$tag_ref;
    my $module = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+ (?: (?:\.|::) \w+)*) $QR_AQ_NOTDOT }xo});
    $self->throw('parse', "Missing plugin name while parsing $$tag_ref") if ! defined $module;
    $module =~ s/\./::/g;

    my $args;
    my $open = $copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox;
    $args = $self->parse_args(\$copy);

    if ($open) {
        $copy =~ s { ^ \) \s* $QR_COMMENTS }{}ox || $self->throw('parse.missing', "Missing close ')'");
    }

    $$tag_ref = $copy;
    return [$var, $module, $args];
}

sub play_USE {
    my ($self, $ref, $node, $out_ref) = @_;
    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 '.'

    ### look for a plugin_base
    my $base = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
    my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
       : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
       : "${base}::${module}";
    my $require = "$package.pm";
    $require =~ s|::|/|g;

    ### try and load the module - fall back to bare module if allowed
    my $obj;
    if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
        my $shape   = $package->load;
        my $context = $self->context;
        my @args    = $args ? map { $self->play_expr($_) } @$args : ();
        $obj = $shape->new($context, @args);
    } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
        $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($args->[0]) : []);
    } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
        foreach my $package (@packages) {
            my $require = "$package.pm";
            $require =~ s|::|/|g;
            eval {require $require} || next;
            my $shape   = $package->load;
            my $context = $self->context;
            my @args    = $args ? map { $self->play_expr($_) } @$args : ();
            $obj = $shape->new($context, @args);
        }
    } elsif ($self->{'LOAD_PERL'}) {
        my $require = "$module.pm";
        $require =~ s|::|/|g;
        if (eval {require $require}) {
            my @args = $args ? map { $self->play_expr($_) } @$args : ();
            $obj = $module->new(@args);
        }
    }
    if (! defined $obj) {
        my $err = "$module: plugin not found";
        $self->throw('plugin', $err);
    }

    ### all good
    $self->set_variable(\@var, $obj);

    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 = $WHILE_MAX;
    while (--$count > 0) {

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

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

    return undef;
}

sub parse_WRAPPER { $DIRECTIVES->{'INCLUDE'}->[0]->(@_) }

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

    my ($names, $args) = @$var;

    my $out = '';
    $self->execute_tree($sub_tree, \$out);

    foreach my $name (reverse @$names) {
        local $self->{'_vars'}->{'content'} = $out;
        $out = '';
        $DIRECTIVES->{'INCLUDE'}->[1]->($self, [[$name], $args], $node, \$out);
    }

    $$out_ref .= $out;
    return;
}

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

sub _vars {
    my $self = shift;
    $self->{'_vars'} = shift if $#_ == 0;
    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'} ||= 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'} || $self->throw('file', "INCLUDE_PATH not set");
        $paths = $paths->()                 if UNIVERSAL::isa($paths, 'CODE');
        $paths = $self->split_paths($paths) if ! UNIVERSAL::isa($paths, 'ARRAY');
        $paths; # return of the do
    };
    foreach my $path (@$paths) {
        return "$path/$file" if -e "$path/$file";
    }

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

sub split_paths {
    my ($self, $path) = @_;
    return $path if ref $path;
    my $delim = $self->{'DELIMITER'} || ':';
    $delim = ($delim eq ':' && $^O eq 'MSWin32') ? qr|:(?!/)| : qr|\Q$delim\E|;
    return [split $delim, $path];
}

sub _insert {
    my ($self, $file) = @_;
    return $self->slurp($self->include_filename($file));
}

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

sub process_simple {
    my $self = shift;
    my $in   = shift || die "Missing input";
    my $swap = shift || die "Missing variable hash";
    my $out  = shift || die "Missing output string ref";

    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;
            return;
        }
    }
    return 1;
}

sub process {
    my ($self, $in, $swap, $out, @ARGS) = @_;
    delete $self->{'error'};

    my $args;
    $args = ($#ARGS == 0 && UNIVERSAL::isa($ARGS[0], 'HASH')) ? {%{$ARGS[0]}} : {@ARGS} if scalar @ARGS;
    $self->DEBUG("set binmode\n") if $DEBUG && $args->{'binmode'}; # holdover for TT2 tests

    ### get the content
    my $content;
    if (ref $in) {
        if (UNIVERSAL::isa($in, 'SCALAR')) { # reference to a string
            $content = $in;
        } elsif (UNIVERSAL::isa($in, 'CODE')) {
            $content = $in->();
            $content = \$content;
        } else { # should be a file handle
            local $/ = undef;
            $content = <$in>;
            $content = \$content;
        }
    } else {
        ### should be a filename
        $content = $in;
    }


    ### prepare block localization
    my $blocks = $self->{'BLOCKS'} ||= {};


    ### do the swap
    my $output = '';
    eval {

        ### localize the stash
        $swap ||= {};
        my $var1 = $self->{'_vars'} ||= {};
        my $var2 = $self->{'VARIABLES'} || $self->{'PRE_DEFINE'} || {};
        $var1->{'global'} ||= {}; # allow for the "global" namespace - that continues in between processing
        my $copy = {%$var2, %$var1, %$swap};
        local $copy->{'template'};

        local $self->{'BLOCKS'} = $blocks = {%$blocks}; # localize blocks - but save a copy to possibly restore

        delete $self->{'_debug_off'};
        delete $self->{'_debug_format'};

        ### handle pre process items that go before every document
        if ($self->{'PRE_PROCESS'}) {
            foreach my $name (@{ $self->split_paths($self->{'PRE_PROCESS'}) }) {
                my $out = '';
                $self->_process($name, $copy, \$out);
                $output = $out . $output;
            }
        }

        ### handle the process config - which loads a template in place of the real one
        if (exists $self->{'PROCESS'}) {
            ### load the meta data for the top document
            my $doc  = $self->load_parsed_tree($content) || {};
            my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'METADEF')
                ? $doc->{'_tree'}->[0]->[3] : {};

            $copy->{'template'} = $doc;
            @{ $doc }{keys %$meta} = values %$meta;

            ### process any other templates
            foreach my $name (@{ $self->split_paths($self->{'PROCESS'}) }) {
                next if ! length $name;
                $self->_process($name, $copy, \$output);
            }

        ### handle "normal" content
        } else {
            local $self->{'_start_top_level'} = 1;
            $self->_process($content, $copy, \$output);
        }


        ### handle post process items that go after every document
        if ($self->{'POST_PROCESS'}) {
            foreach my $name (@{ $self->split_paths($self->{'POST_PROCESS'}) }) {
                $self->_process($name, $copy, \$output);
            }
        }

    };
    if (my $err = $@) {
        $err = $self->exception('undef', $err) if ref($err) !~ /Template::Exception$/;
        if ($err->type !~ /stop|return|next|last|break/) {
            $self->{'error'} = $err;
            return;
        }
    }



    ### clear blocks as asked (AUTO_RESET) defaults to on
    $self->{'BLOCKS'} = $blocks if exists($self->{'AUTO_RESET'}) && ! $self->{'AUTO_RESET'};

    ### send the content back out
    $out ||= $self->{'OUTPUT'};
    if (ref $out) {
        if (UNIVERSAL::isa($out, 'CODE')) {
            $out->($output);
        } elsif (UNIVERSAL::can($out, 'print')) {
            $out->print($output);
        } elsif (UNIVERSAL::isa($out, 'SCALAR')) { # reference to a string
            $$out = $output;
        } elsif (UNIVERSAL::isa($out, 'ARRAY')) {
            push @$out, $output;
        } else { # should be a file handle
            print $out $output;
        }
    } elsif ($out) { # should be a filename
        my $file;
        if ($out =~ m|^/|) {
            if (! $self->{'ABSOLUTE'}) {
                $self->{'error'} = $self->throw('file', "ABSOLUTE paths disabled");
            } else {
                $file = $out;
            }
        } elsif ($out =~ m|^\.\.?/|) {
            if (! $self->{'RELATIVE'}) {
                $self->{'error'} = $self->throw('file', "RELATIVE paths disabled");
            } else {
                $file = $out;
            }
        } else {
            if (! $self->{'OUTPUT_PATH'}) {
                $self->{'error'} = $self->throw('file', "OUTPUT_PATH not set");
            } else {
                $file = $self->{'OUTPUT_PATH'} . '/' . $out;
            }
        }
        if ($file) {
            local *FH;
            if (open FH, ">$file") {
                if (my $bm = $args->{'binmode'}) {
                    if (+$bm == 1) { binmode FH }
                    else           { binmode FH, $bm }
                }
                print FH $output;
                close FH;
            } else {
                $self->{'error'} = $self->throw('file', "$out couldn't be opened for writing: $!");
            }
        }
    } else {
        print $output;
    }

    return if $self->{'error'};
    return 1;
}

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

sub DEBUG {
    my $self = shift;
    print STDERR "DEBUG: ", @_;
}

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

sub exception {
    my ($self, $type, $info, $node) = @_;
    return $type if ref($type) =~ /Template::Exception$/;
    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 $PACKAGE_EXCEPTION->new($type, $info, $node);
}

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

sub context {
    my $self = shift;
    return bless {_template => $self}, $PACKAGE_CONTEXT; # a fake context
}

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 list_filters {
    my $self = shift;
    return $self->{'_filters'} ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {};
}

sub list_plugins {
    my $self = shift;
    my $args = shift || {};
    my $base = $args->{'base'} || '';

    return $self->{'_plugins'}->{$base} ||= do {
        my @plugins;

        $base =~ s|::|/|g;
        my @dirs = grep {-d $_} map {"$_/$base"} @INC;

        foreach my $dir (@dirs) {
            require File::Find;
            File::Find::find(sub {
                my $mod = $base .'/'. ($File::Find::name =~ m|^ $dir / (.*\w) \.pm $|x ? $1 : return);
                $mod =~ s|/|::|g;
                push @plugins, $mod;
            }, $dir);
        }

        \@plugins; # return of the do
    };
}

### get a copy of self without circular refs for use in closures
sub weak_copy {
    my $self = shift;
    my $self_copy;
    if (eval { require Scalar::Util }
        && defined &Scalar::Util::weaken) {
        $self_copy = $self;
        Scalar::Util::weaken($self_copy);
    } else {
        $self_copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on old perls (pre 5.8)
    }
    return $self_copy;
}

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->{'_vars'}->{'component'};
    my $i = $node->[1];
    my $j = $node->[2] || return ''; # METADEF can be 0
    $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
    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) = @_;
    ### get the line offsets for the doc
    my $lines = $doc->{'line_offsets'} ||= do {
        $doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
        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)
    return $#$lines + 1 if $index > $lines->[-1];
    my ($i, $j) = (0, $#$lines);
    while (1) {
        return $i + 1 if abs($i - $j) <= 1;
        my $k = int(($i + $j) / 2);
        $j = $k if $lines->[$k] >= $index;
        $i = $k if $lines->[$k] <= $index;
    }
}

###----------------------------------------------------------------###
### long virtual methods or filters
### many of these vmethods have used code from Template/Stash.pm to
### assure conformance with the TT spec.

sub define_vmethod {
    my ($self, $type, $name, $sub) = @_;
    if (   $type =~ /scalar|item/i) { $SCALAR_OPS->{$name} = $sub }
    elsif ($type =~ /array|list/i ) { $LIST_OPS->{  $name} = $sub }
    elsif ($type =~ /hash/i       ) { $HASH_OPS->{  $name} = $sub }
    elsif ($type =~ /filter/i     ) { $FILTER_OPS->{$name} = $sub }
    else {
        die "Invalid type vmethod type $type";
    }
    return 1;
}

sub vmethod_as_scalar {
    my ($str, $pat) = @_;
    $pat = '%s' if ! defined $pat;
    local $^W;
    return sprintf $pat, $str;
}

sub vmethod_as_list {
    my ($ref, $pat, $sep) = @_;
    $pat = '%s' if ! defined $pat;
    $sep = ' '  if ! defined $sep;
    local $^W;
    return join($sep, map {sprintf $pat, $_} @$ref);
}

sub vmethod_as_hash {
    my ($ref, $pat, $sep) = @_;
    $pat = "%s\t%s" if ! defined $pat;
    $sep = "\n"  if ! defined $sep;
    local $^W;
    return join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref);
}

sub vmethod_chunk {
    my $str  = shift;
    my $size = shift || 1;
    my @list;
    if ($size < 0) { # chunk from the opposite end
        $str = reverse $str;
        $size = -$size;
        unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg;
    } else {
        push(@list, $1)                   while $str =~ /( .{$size} | .+ )/xg;
    }
    return \@list;
}

sub vmethod_indent {
    my $str = shift; $str = '' if ! defined $str;
    my $pre = shift; $pre = 4  if ! defined $pre;
    $pre = ' ' x $pre if $pre =~ /^\d+$/;
    $str =~ s/^/$pre/mg;
    return $str;
}

sub vmethod_format {
    my $str = shift; $str = ''   if ! defined $str;
    my $pat = shift; $pat = '%s' if ! defined $pat;
    return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
}

sub vmethod_match {
    my ($str, $pat, $global) = @_;
    return [] if ! defined $str || ! defined $pat;
    my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
    return (@res >= 2) ? \@res : (@res == 1) ? $res[0] : '';
}

sub vmethod_nsort {
    my ($list, $field) = @_;
    return defined($field)
        ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field}
                                                               : UNIVERSAL::can($_, $field) ? $_->$field()
                                                               : $_)]} @$list ]
        : [sort {$a <=> $b} @$list];
}

sub vmethod_repeat {
    my ($str, $n, $join) = @_;
    return if ! length $str;
    $n = 1 if ! defined($n) || ! length $n;
    $join = '' if ! defined $join;
    return join $join, ($str) x $n;
}

### This method is a combination of my submissions along
### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum
sub vmethod_replace {
    my ($text, $pattern, $replace, $global) = @_;
    $text      = '' unless defined $text;
    $pattern   = '' unless defined $pattern;
    $replace   = '' unless defined $replace;
    $global    = 1  unless defined $global;
    my $expand = sub {
        my ($chunk, $start, $end) = @_;
        $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{
            $1 ? $1
                : ($2 > $#$start || $2 == 0) ? ''
                : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
        }exg;
        $chunk;
    };
    if ($global) {
        $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg;
    } else {
        $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e;
    }
    return $text;
}

sub vmethod_sort {
    my ($list, $field) = @_;
    return defined($field)
        ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field}
                                                                 : UNIVERSAL::can($_, $field) ? $_->$field()
                                                                 : $_)]} @$list ]
        : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive
}

sub vmethod_splice {
    my ($ref, $i, $len, @replace) = @_;
    @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
    if (defined $len) {
        return [splice @$ref, $i || 0, $len, @replace];
    } else {
        return [splice @$ref, $i || 0];
    }
}

sub vmethod_split {
    my ($str, $pat, @args) = @_;
    $str = '' if ! defined $str;
    return defined $pat ? [split $pat, $str, @args] : [split ' ', $str, @args];
}

sub vmethod_uri {
    my $str = shift;
    utf8::encode($str) if defined &utf8::encode;
    $str =~ s/([^A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg;
    return $str;
}

sub filter_eval {
    my $context = shift;
    return sub {
        my $text = shift;
        return $context->process(\$text);
    };
}

sub filter_redirect {
    my ($context, $file, $options) = @_;
    my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set');
    $context->throw('redirect', 'Invalid filename - cannot include "/../"')
        if $file =~ m{(^|/)\.\./};

    return sub {
        my $text = shift;
        if (! -d $path) {
            require File::Path;
            File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
        }
        local *FH;
        open (FH, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
        if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) {
            if (+$bm == 1) { binmode FH }
            else { binmode FH, $bm}
        }
        print FH $text;
        close FH;
        return '';
    };
}

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

sub dump_parse {
    my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
    my $str = shift;
    require Data::Dumper;
    return Data::Dumper::Dumper($obj->parse_expr(\$str));
}

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

package CGI::Ex::Template::Exception;

use overload
    '""' => \&as_string,
    bool => sub { defined shift },
    fallback => 1;

sub new {
    my ($class, $type, $info, $node, $pos, $str_ref) = @_;
    return bless [$type, $info, $node, $pos, $str_ref], $class;
}

sub type { shift->[0] }

sub info { shift->[1] }

sub node {
    my $self = shift;
    $self->[2] = shift if $#_ == 0;
    $self->[2];
}

sub offset { shift->[3] || 0 }

sub doc {
    my $self = shift;
    $self->[4] = shift if $#_ == 0;
    $self->[4];
}

sub as_string {
    my $self = shift;
    my $msg  = $self->type .' error - '. $self->info;
    if (my $node = $self->node) {
#        $msg .= " (In tag $node->[0] starting at char ".($node->[1] + $self->offset).")";
    }
    return $msg;
}

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

package CGI::Ex::Template::Iterator;

sub new {
    my ($class, $items) = @_;
    $items = [] if ! defined $items;
    if (UNIVERSAL::isa($items, 'HASH')) {
	$items = [ map { {key => $_, value => $items->{ $_ }} } sort keys %$items ];
    } elsif (UNIVERSAL::can($items, 'as_list')) {
	$items = $items->as_list;
    } elsif (! UNIVERSAL::isa($items, 'ARRAY')) {
        $items = [$items];
    }
    return bless [$items, 0], $class;
}

sub get_first {
    my $self = shift;
    return (undef, 3) if ! @{ $self->[0] };
    return ($self->[0]->[$self->[1] = 0], undef);
}

sub get_next {
    my $self = shift;
    return (undef, 3) if ++ $self->[1] > $#{ $self->[0] };
    return ($self->items->[$self->[1]], undef);
}

sub items { shift->[0] }

sub index { shift->[1] }

sub max { $#{ shift->[0] } }

sub size { shift->max + 1 }

sub count { shift->index + 1 }

sub number { shift->index + 1 }

sub first { (shift->index == 0) || 0 }

sub last { my $self = shift; return ($self->index == $self->max) || 0 }

sub prev {
    my $self = shift;
    return undef if $self->index <= 0;
    return $self->items->[$self->index - 1];
}

sub next {
    my $self = shift;
    return undef if $self->index >= $self->max;
    return $self->items->[$self->index + 1];
}

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

package CGI::Ex::Template::_Context;

use vars qw($AUTOLOAD);

sub _template { shift->{'_template'} || die "Missing _template" }

sub config { shift->_template }

sub stash {
    my $self = shift;
    return $self->{'stash'} ||= bless {_template => $self->_template}, $CGI::Ex::Template::PACKAGE_STASH;
}

sub insert { shift->_template->_insert(@_) }

sub eval_perl { shift->_template->{'EVAL_PERL'} }

sub process {
    my $self = shift;
    my $ref  = shift;
    my $vars = $self->_template->_vars;
    my $out  = '';
    $self->_template->_process($ref, $vars, \$out);
    return $out;
}

sub include {
    my $self = shift;
    my $file = shift;
    my $args = shift || {};

    $self->_template->set_variable($_, $args->{$_}) for keys %$args;

    my $out = ''; # have temp item to allow clear to correctly clear
    eval { $self->_template->_process($file, $self->{'_vars'}, \$out) };
    if (my $err = $@) {
        die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
    }

    return $out;
}

sub define_filter {
    my ($self, $name, $filter, $is_dynamic) = @_;
    $filter = [ $filter, 1 ] if $is_dynamic;
    $self->define_vmethod('filter', $name, $filter);
}

sub filter {
    my ($self, $name, $args, $alias) = @_;
    my $t = $self->_template;

    my $filter;
    if (! ref $name) {
        $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex::Template::FILTER_OPS->{$name} || $CGI::Ex::Template::SCALAR_OPS->{$name};
        $t->throw('filter', $name) if ! $filter;
    } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) {
        $filter = $name;
    } elsif (UNIVERSAL::can($name, 'factory')) {
        $filter = $name->factory || $t->throw($name->error);
    } else {
        $t->throw('undef', "$name: filter not found");
    }

    if (UNIVERSAL::isa($filter, 'ARRAY')) {
        $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
    } elsif ($args && @$args) {
        my $sub = $filter;
        $filter = sub { $sub->(shift, @$args) };
    }

    $t->{'FILTERS'}->{$alias} = $filter if $alias;

    return $filter;
}

sub define_vmethod { shift->_template->define_vmethod(@_) }

sub throw {
    my ($self, $type, $info) = @_;

    if (UNIVERSAL::isa($type, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
	die $type;
    } elsif (defined $info) {
	$self->_template->throw($type, $info);
    } else {
	$self->_template->throw('undef', $type);
    }
}

sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }

sub DESTROY {}

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

package CGI::Ex::Template::_Stash;

use vars qw($AUTOLOAD);

sub _template { shift->{'_template'} || die "Missing _template" }

sub get {
    my ($self, $var) = @_;
    if (! ref $var) {
        if ($var =~ /^\w+$/) {  $var = [$var, 0] }
        else {                  $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
    }
    return $self->_template->play_expr($var, {no_dots => 1});
}

sub set {
    my ($self, $var, $val) = @_;
    if (! ref $var) {
        if ($var =~ /^\w+$/) {  $var = [$var, 0] }
        else {                  $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
    }
    $self->_template->set_variable($var, $val, {no_dots => 1});
    return $val;
}

sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }

sub DESTROY {}

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

package CGI::Ex::Template::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;

### See the perldoc in CGI/Ex/Template.pod
