File Coverage

blib/lib/Template/Alloy/Parse.pm

Criterion	Covered	Total	%
statement	483	547	88.3
branch	282	348	81.0
condition	133	190	70.0
subroutine	38	45	84.4
pod	5	38	13.1
total	941	1168	80.5

package Template::Alloy::Parse;

=head1 NAME

Template::Alloy::Parse - Common parsing role for creating AST from templates

=cut

use strict;
use warnings;
use base qw(Exporter);
use Template::Alloy;
use Template::Alloy::Operator qw($QR_OP $QR_OP_ASSIGN $QR_OP_PREFIX
                                 $OP $OP_ASSIGN $OP_PREFIX $OP_POSTFIX);

our $VERSION   = $Template::Alloy::VERSION;
our @EXPORT_OK = qw(define_directive define_syntax
                    $ALIASES $DIRECTIVES $TAGS $QR_DIRECTIVE $QR_COMMENTS);

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

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

our $TAGS = {
    asp       => ['<%',     '%>'    ], # ASP
    default   => ['\[%',    '%\]'   ], # default
    html      => [''   ], # HTML comments
    mason     => ['<%',     '>'     ], # HTML::Mason
    metatext  => ['%%',     '%%'    ], # Text::MetaText
    php       => ['<\?',    '\?>'   ], # PHP
    star      => ['\[\*',   '\*\]'  ], # TT alternate
    template  => ['\[%',    '%\]'   ], # Normal Template Toolkit
    template1 => ['[\[%]%', '%[%\]]'], # TT1
    tt2       => ['\[%',    '%\]'   ], # TT2
};

our $SYNTAX = {
    alloy    => sub { shift->parse_tree_tt3(@_) },
    js       => sub { shift->parse_tree_js(@_) },
    jsr      => sub { shift->parse_tree_jsr(@_) },
    ht       => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; local $self->{'EXPR'} = 0; $self->parse_tree_hte(@_) },
    hte      => sub { my $self = shift; local $self->{'V2EQUALS'} = 0; $self->parse_tree_hte(@_) },
    tt3      => sub { shift->parse_tree_tt3(@_) },
    tt2      => sub { my $self = shift; local $self->{'V2PIPE'} = 1; $self->parse_tree_tt3(@_) },
    tt1      => sub { my $self = shift; local $self->{'V2PIPE'} = 1; local $self->{'V1DOLLAR'} = 1; $self->parse_tree_tt3(@_) },
    tmpl     => sub { shift->parse_tree_tmpl(@_) },
    velocity => sub { shift->parse_tree_velocity(@_) },
};

our $DIRECTIVES = {
    #name       parse_sub        play_sub         block    postdir  continue  no_interp
    BLOCK   => [\&parse_BLOCK,   \&play_BLOCK,    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 {}],
    COMMENT => [sub {},          sub {},          1],
    CONFIG  => [\&parse_CONFIG,  \&play_CONFIG],
    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     => [sub {},          sub {}],
    EVAL    => [\&parse_EVAL,    \&play_EVAL],
    FILTER  => [\&parse_FILTER,  \&play_FILTER,   1,       1],
    '|'     => [\&parse_FILTER,  \&play_FILTER,   1,       1],
    FINAL   => [sub {},          undef,           0,       0,       {TRY => 1, CATCH => 1}],
    FOR     => [\&parse_FOR,     \&play_FOR,      1,       1],
    FOREACH => [\&parse_FOR,     \&play_FOR,      1,       1],
    GET     => [\&parse_GET,     \&play_GET],
    IF      => [\&parse_IF,      \&play_IF,       1,       1],
    INCLUDE => [\&parse_INCLUDE, \&play_INCLUDE],
    INSERT  => [\&parse_INSERT,  \&play_INSERT],
    JS      => [sub {},          \&play_JS,       1,       0,       0,        1],
    LAST    => [sub {},          \&play_control],
    LOOP    => [\&parse_LOOP,    \&play_LOOP,     1,       1],
    MACRO   => [\&parse_MACRO,   \&play_MACRO],
    META    => [\&parse_META,    \&play_META],
    NEXT    => [sub {},          \&play_control],
    PERL    => [sub {},          \&play_PERL,     1,       0,       0,        1],
    PROCESS => [\&parse_PROCESS, \&play_PROCESS],
    RAWPERL => [sub {},          \&play_RAWPERL,  1,       0,       0,        1],
    RETURN  => [\&parse_RETURN,  \&play_control],
    SET     => [\&parse_SET,     \&play_SET],
    STOP    => [sub {},          \&play_control],
    SWITCH  => [\&parse_SWITCH,  \&play_SWITCH,   1],
    TAGS    => [\&parse_TAGS,    sub {}],
    THROW   => [\&parse_THROW,   \&play_THROW],
    TRY     => [sub {},          \&play_TRY,      1],
    UNLESS  => [\&parse_UNLESS,  \&play_UNLESS,   1,       1],
    USE     => [\&parse_USE,     \&play_USE],
    VIEW    => [\&parse_VIEW,    \&play_VIEW,     1],
    WHILE   => [\&parse_WHILE,   \&play_WHILE,    1,       1],
    WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER,  1,       1],
    #name       parse_sub        play_sub         block    postdir  continue  no_interp
};
our $ALIASES = {
    EVALUATE => 'EVAL',
};


our $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )';
our $QR_COMMENTS  = '(?-s: \# .* \s*)*';
our $QR_FILENAME  = '([a-zA-Z]]:/|/)? [\w\.][\w\-\.]* (?:/[\w\-\.]+)*';
our $QR_BLOCK     = '\w+\b (?: :\w+\b)* )';
our $QR_NUM       = '(?:\d*\.\d+ | \d+) (?: [eE][+-]?\d+ )?';
our $QR_AQ_SPACE  = '(?: \\s+ | \$ | (?=;) )';

our $_escapes = {n => "\n", r => "\r", t => "\t", '"' => '"', '\\' => '\\', '$' => '$'};
our $QR_ESCAPES = qr{[nrt\"\$\\]};

sub define_directive {
    my ($self, $name, $args) = @_;
    $DIRECTIVES->{$name} = [@{ $args }{qw(parse_sub play_sub is_block is_postop continues no_interp)}];
    return 1;
}

sub define_syntax {
    my ($self, $name, $sub) = @_;
    $SYNTAX->{$name} = $sub;
    return 1;
}

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

sub parse_tree {
    my $syntax = $_[0]->{'SYNTAX'} || 'alloy';
    my $meth   = $SYNTAX->{$syntax} || $_[0]->throw('config', "Unknown SYNTAX \"$syntax\"");
    return $meth->(@_);
}

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

sub parse_expr {
    my $self    = shift;
    my $str_ref = shift;
    my $ARGS    = shift || {};
    my $is_aq   = $ARGS->{'auto_quote'} ? 1 : 0;
    my $mark    = pos $$str_ref;

    ### allow for custom auto_quoting (such as hash constructors)
    if ($is_aq) {
        if ($$str_ref =~ m{ \G \s* $QR_COMMENTS $ARGS->{'auto_quote'} }gcx) {
            return $1;

        ### allow for ${foo.bar} type constructs
        } elsif ($$str_ref =~ m{ \G \$\{ }gcx) {
            my $var = $self->parse_expr($str_ref);
            $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
                || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
            return $var;

        ### allow for auto-quoted $foo
        } elsif ($$str_ref =~ m{ \G \$ }gcx) {
            return $self->parse_expr($str_ref)
                || $self->throw('parse', "Missing variable", undef, pos($$str_ref));
        }
    }

    $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;

    ### allow for macro definer
    if ($$str_ref =~ m{ \G -> \s* }gcxo) { # longest token would be nice - until then this comes before prefix
        local $self->{'_operator_precedence'} = 0; # reset presedence
        my $args;
        if ($$str_ref =~ m{ \G \( \s* }gcx) {
            $args = $self->parse_args($str_ref, {positional_only => 1});
            $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
        }
        $$str_ref =~ m{ \G \{ $QR_COMMENTS }gcx || $self->throw('parse.missing', "Missing open '{'", undef, pos($$str_ref));
        local $self->{'END_TAG'} = qr{ \} }x;
        my $tree = $self->parse_tree_tt3($str_ref, 'one_tag_only');
        return [[undef, '->', $args || [['this',0]], $tree]];
    }

    ### test for leading prefix operators
    my $has_prefix;
    while (! $is_aq && $$str_ref =~ m{ \G ($QR_OP_PREFIX) }gcxo) {
        push @{ $has_prefix }, $1;
        $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
    }

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

    ### allow hex
    if ($$str_ref =~ m{ \G 0x ( [a-fA-F0-9]+ ) }gcx) {
        my $number = eval { hex $1 } || 0;
        push @var, \ $number;
        $is_literal = 1;

    ### allow for numbers
    } elsif ($$str_ref =~ m{ \G ( $QR_NUM ) }gcx) {
        my $number = 0 + $1;
        push @var, \ $number;
        $is_literal = 1;

    ### allow for quoted array constructor
    } elsif (! $is_aq && $$str_ref =~ m{ \G qw ([^\w\s]) \s* }gcxo) {
        my $quote = $1;
        $quote =~ y|([{<|)]}>|;
        $$str_ref =~ m{ \G (.*?) (?
            || $self->throw('parse.missing.array_close', "Missing close \"$quote\"", undef, pos($$str_ref));
        my $str = $1;
        $str =~ s{ ^ \s+ }{}x;
        $str =~ s{ \s+ $ }{}x;
        $str =~ s{ \\ \Q$quote\E }{$quote}gx;
        push @var, [undef, '[]', split /\s+/, $str];

    ### looks like a normal variable start
    } elsif ($$str_ref =~ m{ \G (\w+) }gcx) {
        push @var, $1;
        $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};

    ### allow for regex constructor
    } elsif (! $is_aq && $$str_ref =~ m{ \G / }gcx) {
        $$str_ref =~ m{ \G (.*?) (?
            || $self->throw('parse', 'Unclosed regex tag "/"', undef, pos($$str_ref));
        my ($str, $opts) = ($1, $2);
        $self->throw('parse', 'e option not allowed on regex',   undef, pos($$str_ref)) if $opts =~ /e/;
        $self->throw('parse', 'g option not supported on regex', undef, pos($$str_ref)) if $opts =~ /g/;
        $str =~ s|\\n|\n|g;
        $str =~ s|\\t|\t|g;
        $str =~ s|\\r|\r|g;
        $str =~ s|\\\/|\/|g;
        $str =~ s|\\\$|\$|g;
        $self->throw('parse', "Invalid regex: $@", undef, pos($$str_ref)) if ! eval { "" =~ /$str/; 1 };
        push @var, [undef, 'qr', $str, $opts];

    ### allow for single quoted strings
    } elsif ($$str_ref =~ m{ \G \' (.*?) (?
        my $str = $1;
        $str =~ s{ \\\' }{\'}xg;
        return $str if $is_aq;
        push @var, \ $str;
        $is_literal = 1;

    ### allow for double quoted strings
    } elsif ($$str_ref =~ m{ \G \" }gcx) {
        my @pieces;
        while ($$str_ref =~ m{ \G (.*?) ([\"\$\\]) }gcxs) {
            my ($str, $item) = ($1, $2);
            if (length $str) {
                if (defined($pieces[-1]) && ! ref($pieces[-1])) { $pieces[-1] .= $str; } else { push @pieces, $str }
            }
            if ($item eq '\\') {
                my $chr = ($$str_ref =~ m{ \G ($QR_ESCAPES) }gcxo) ? $_escapes->{$1} : '\\';
                if (defined($pieces[-1]) && ! ref($pieces[-1])) { $pieces[-1] .= $chr; } else { push @pieces, $chr }
                next;
            } elsif ($item eq '"') {
                last;
            } elsif ($self->{'AUTO_EVAL'}) {
                if (defined($pieces[-1]) && ! ref($pieces[-1])) { $pieces[-1] .= '$'; } else { push @pieces, '$' }
                next;
            }

            my $not  = $$str_ref =~ m{ \G ! }gcx;
            my $mark = pos($$str_ref);
            my $ref;
            if ($$str_ref =~ m{ \G \{ }gcx) {
                local $self->{'_operator_precedence'} = 0; # allow operators
                $ref = $self->parse_expr($str_ref);
                $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
                    || $self->throw('parse', 'Missing close }', undef, pos($$str_ref));
            } else {
                local $self->{'_operator_precedence'} = 1; # no operators
                $ref = $self->parse_expr($str_ref)
                    || $self->throw('parse', "Error while parsing for interpolated string", undef, pos($$str_ref));
            }
            if (! $not && $self->{'SHOW_UNDEFINED_INTERP'}) {
                $ref = [[undef, '//', $ref, '$'.substr($$str_ref, $mark, pos($$str_ref)-$mark)], 0];
            }
            push @pieces, $ref if defined $ref;
        }
        if (! @pieces) { # [% "" %]
            return '' if $is_aq;
            push @var, \ '';
            $is_literal = 1;
        } elsif (@pieces == 1 && ref $pieces[0]) { # [% "$foo" %] or [% "${ 1 + 2 }" %]
            return $pieces[0] if $is_aq;
            push @var, @{ $pieces[0] };
            $already_parsed_args = 1;
        } elsif ($self->{'AUTO_EVAL'}) {
            push @var, [undef, '~', @pieces], 0, '|', 'eval', 0;
            return \@var if $is_aq;
            $already_parsed_args = 1;
        } elsif (@pieces == 1) { # [% "foo" %]
            return $pieces[0] if $is_aq;
            push @var, \ $pieces[0];
            $is_literal = 1;
        } else { # [% "foo $bar baz" %]
            push @var, [undef, '~', @pieces];
            return [$var[0], 0] if $is_aq;
        }

    ### allow for leading $foo type constructs
    } elsif ($$str_ref =~ m{ \G \$ (\w+) \b }gcx) {
        if ($self->{'V1DOLLAR'}) {
            push @var, $1;
            $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
        } else {
            push @var, [$1, 0];
        }

    ### allow for ${foo.bar} type constructs
    } elsif ($$str_ref =~ m{ \G \$\{ }gcx) {
        push @var, $self->parse_expr($str_ref);
        $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
            || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));

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

    ### looks like a hash constructor
    } elsif (! $is_aq && $$str_ref =~ m{ \G \{ }gcx) {
        local $self->{'_operator_precedence'} = 0; # reset precedence
        my $hashref = [undef, '{}'];
        while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))) {
            $$str_ref =~ m{ \G \s* $QR_COMMENTS (?: = >? | [:,]) }gcxo;
            my $val = $self->parse_expr($str_ref);
            push @$hashref, $key, $val;
            $$str_ref =~ m{ \G \s* $QR_COMMENTS , }gcxo;
        }
        $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
            || $self->throw('parse.missing.curly_bracket', "Missing close \}", undef, pos($$str_ref));
        push @var, $hashref;

    ### looks like a paren grouper or a context specifier
    } elsif (! $is_aq && $$str_ref =~ m{ \G ([\$\@]?) \( }gcx) {
        local $self->{'_operator_precedence'} = 0; # reset precedence
        my $ctx = $1;
        my $var = $self->parse_expr($str_ref, {allow_parened_ops => 1});

        $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo
            || $self->throw('parse.missing.paren', "Missing close \) in group", undef, pos($$str_ref));

        $self->throw('parse', 'Paren group cannot be followed by an open paren', undef, pos($$str_ref))
            if $$str_ref =~ m{ \G \( }gcx;
        $already_parsed_args = 1;

        if (! ref $var) {
            push @var, \$var, 0;
            $is_literal = 1;
        } elsif (! defined $var->[0]) {
            push @var, $var, 0;
        } else {
            push @var, @$var;
        }
        if ($ctx) {
            my $copy = [@var];
            @var = ([undef, "$ctx()", $copy], 0);
        }

    ### nothing to find - return failure
    } else {
        pos($$str_ref) = $mark if $is_aq || $has_prefix;
        return;
    }

    # auto_quoted thing was too complicated
    if ($is_aq) {
        pos($$str_ref) = $mark;
        return;
    }

    ### looks for args for the initial
    if ($already_parsed_args) {
        # do nothing
    } elsif ($$str_ref =~ m{ \G \( }gcxo) {
        local $self->{'_operator_precedence'} = 0; # reset precedence
        my $args = $self->parse_args($str_ref, {is_parened => 1});
        $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo
            || $self->throw('parse.missing.paren', "Missing close \) in args", undef, pos($$str_ref));
        push @var, $args;
    } else {
        push @var, 0;
    }

    ### allow for nested items
    while ($$str_ref =~ m{ \G \s* $QR_COMMENTS ( \.(?!\.) | \|(?!\|) ) }gcx) {
        if ($1 eq '|' && $self->{'V2PIPE'}) {
            pos($$str_ref) -= 1;
            last;
        }

        push(@var, $1) if ! $ARGS->{'no_dots'};

        $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;

        ### allow for interpolated variables in the middle - one.$foo.two
        if ($$str_ref =~ m{ \G \$ (\w+) \b }gcxo) {
            push @var, $self->{'V1DOLLAR'} ? $1 : [$1, 0];

        ### or one.${foo.bar}.two
        } elsif ($$str_ref =~ m{ \G \$\{ }gcx) {
            push @var, $self->parse_expr($str_ref);
            $$str_ref =~ m{ \G \s* $QR_COMMENTS \} }gcxo
                || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));

        ### allow for names (foo.bar or foo.0 or foo.-1)
        } elsif ($$str_ref =~ m{ \G (-? \w+) }gcx) {
            push @var, $1;

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

        ### looks for args for the nested item
        if ($$str_ref =~ m{ \G \( }gcx) {
            local $self->{'_operator_precedence'} = 0; # reset precedence
            my $args = $self->parse_args($str_ref, {is_parened => 1});
            $$str_ref =~ m{ \G \s* $QR_COMMENTS \) }gcxo
                || $self->throw('parse.missing.paren', "Missing close \) in args of nested item", undef, pos($$str_ref));
            push @var, $args;
        } else {
            push @var, 0;
        }

    }

    ### flatten literals and constants as much as possible
    my $var;
    if ($is_literal) {
        $var = ${ $var[0] };
        if ($#var != 1) {
            $var[0] = [undef, '~', $var];
            $var = \@var;
        }
    } elsif ($is_namespace) {
        my $name = $var[0];
        local $self->{'_vars'}->{$name} = $self->{'NAMESPACE'}->{$name};
        $var = $self->play_expr(\@var, {is_namespace_during_compile => 1});
    } else {
        $var = \@var;
    }

    ### allow for all "operators"
    if (! $self->{'_operator_precedence'}) {
        my $tree;
        my $found;
        while (1) {
            my $mark = pos $$str_ref;

            $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;

            if ($self->{'_end_tag'} && $$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) {
                pos($$str_ref) = $mark;
                last;
            } elsif ($$str_ref !~ m{ \G ($QR_OP) }gcxo) {
                pos($$str_ref) = $mark;
                last;
            }
            if ($OP_ASSIGN->{$1} && ! $ARGS->{'allow_parened_ops'}) { # only allow assignment in parens
                pos($$str_ref) = $mark;
                last;
            }
            local $self->{'_operator_precedence'} = 1;
            my $op = $1;
            $op = 'eq' if $op eq '==' && (! defined($self->{'V2EQUALS'}) || $self->{'V2EQUALS'});
            $op = 'ne' if $op eq '!=' && (! defined($self->{'V2EQUALS'}) || $self->{'V2EQUALS'});

            ### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --)
            if ($OP_POSTFIX->{$op}) {
                $var = [[undef, $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 = [[undef, $tree->[0], $var, $tree->[1]], 0];
                    } else {
                        unshift @$tree, $var;
                        $var = $self->apply_precedence($tree, $found, $str_ref);
                    }
                    undef $tree;
                    undef $found;
                }
                $var = [[undef, $has_prefix->[-1], $var ], 0];
                pop @$has_prefix;
                $has_prefix = undef if ! @$has_prefix;
            }

            ### add the operator to the tree
            my $var2 = $self->parse_expr($str_ref);
            $self->throw('parse', 'Missing variable after "'.$op.'"', undef, pos($$str_ref)) if ! defined $var2;
            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
                if ($OP->{$tree->[0]}->[0] eq 'assign' && $tree->[0] =~ /(.+)=/) {
                    $var = [[undef, '=', $var, [[undef, $1, $var, $tree->[1]], 0]], 0]; # "a += b" => "a = a + b"
                } else {
                    $var = [[undef, $tree->[0], $var, $tree->[1]], 0];
                }
            } else {
                unshift @$tree, $var;
                $var = $self->apply_precedence($tree, $found, $str_ref);
            }
        }
    }

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

    return $var;
}

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

    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 = [[undef, $node->[1], $node->[0], $node->[2]], 0]; # single operator - put it straight on
            } else {
                $node = $self->apply_precedence($node, $found, $str_ref); # 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", undef, pos($$str_ref)) if $ops[0] ne $op;
                $self->throw('parse', "Ternary operator mismatch", undef, pos($$str_ref)) if ! $ops[1] || $ops[1] eq $op;
                return [[undef, $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 = [[undef, $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];
            for (reverse (0 .. $#exprs - 1)) {
                if ($type eq 'assign' && $ops[$_ - 1] =~ /(.+)=$/) {
                    $val = [[undef, '=', $exprs[$_], [[undef, $1, $exprs[$_], $val], 0]], 0];
                } else {
                    $val = [[undef, $ops[$_ - 1], $exprs[$_], $val], 0];
                }
            }
            return $val;

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

        }
    }

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

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

    my @args;
    my @named;
    my $name;
    my $end = $self->{'_end_tag'} || '(?!)';
    while (1) {
        my $mark = pos $$str_ref;

        ### look to see if the next thing is a directive or a closing tag
        if (! $ARGS->{'is_parened'}
            && ! $ARGS->{'require_arg'}
            && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$end))) }gcxo
            && ((pos($$str_ref) = $mark) || 1)                  # always revert
            && $DIRECTIVES->{$self->{'ANYCASE'} ? uc($1) : $1}  # looks like a directive - we are done
            ) {
            last;
        }
        if ($$str_ref =~ m{ \G [+=~-]? $end }gcx) {
            pos($$str_ref) = $mark;
            last;
        }

        ### find the initial arg
        my $name;
        if ($ARGS->{'allow_bare_filenames'}) {
            $name = $self->parse_expr($str_ref, {auto_quote => "
              ($QR_FILENAME               # file name
              | $QR_BLOCK                 # or block
                (?= [+=~-]? $end          # an end tag
                  | \\s*[+,;]             # followed by explicit + , or ;
                  | \\s+ (?! [\\s=])      # or space not before an =
                )  \\s* $QR_COMMENTS"});
            # filenames can be separated with a "+" - why a "+" ?
            if ($$str_ref =~ m{ \G \+ (?! \s* $QR_COMMENTS [+=~-]? $end) }gcxo) {
                push @args, $name;
                $ARGS->{'require_arg'} = 1;
                next;
            }
        }
        if (! defined $name) {
            $name = $self->parse_expr($str_ref);
            if (! defined $name) {
                if ($ARGS->{'require_arg'} && ! @args && ! $ARGS->{'positional_only'} && ! @named) {
                    $self->throw('parse', 'Argument required', undef, pos($$str_ref));
                } else {
                    last;
                }
            }
        }

        $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;

        ### see if it is named or positional
        if ($$str_ref =~ m{ \G \s* $QR_COMMENTS = >? }gcxo) {
            $self->throw('parse', 'Named arguments not allowed', undef, $mark) if $ARGS->{'positional_only'};
            my $val = $self->parse_expr($str_ref);
            $name = $name->[0] if ref($name) && @$name == 2 && ! $name->[1]; # strip a level of indirection on named arguments
            push @named, $name, $val;
        } else {
            push @args, $name;
        }

        ### look for trailing comma
        $ARGS->{'require_arg'} = ($$str_ref =~ m{ \G \s* $QR_COMMENTS , }gcxo) || 0;
    }

    ### allow for named arguments to be added at the front (if asked)
    if ($ARGS->{'named_at_front'}) {
        unshift @args, [[undef, '{}', @named], 0];
    } elsif (scalar @named) { # only add at end - if there are some
        push @args,    [[undef, '{}', @named], 0]
    }

    return \@args;
}

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

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

    my $end = $self->{'_end_tag'} || '(?!)';
    my $block_name = $self->parse_expr($str_ref, {auto_quote => "
              ($QR_FILENAME               # file name
              | $QR_BLOCK                 # or block
                (?= [+=~-]? $end          # an end tag
                  | \\s*[+,;]             # followed by explicit + , or ;
                  | \\s+ (?! [\\s=])      # or space not before an =
                )  \\s* $QR_COMMENTS"});

    return '' if ! defined $block_name;

    my $prepend = join "/", map {$_->[3]} grep {ref($_) && $_->[0] eq 'BLOCK'} @{ $self->{'_state'} || {} };
    return $prepend ? "$prepend/$block_name" : $block_name;
}

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

sub parse_CASE {
    my ($self, $str_ref) = @_;
    return if $$str_ref =~ m{ \G DEFAULT \s* }gcx;
    return $self->parse_expr($str_ref);
}

sub parse_CATCH {
    my ($self, $str_ref) = @_;
    return $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"});
}

sub parse_CONFIG {
    my ($self, $str_ref) = @_;

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

    my $mark   = pos($$str_ref);
    my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1});
    my $ref = $config->[0]->[0];
    for (my $i = 2; $i < @$ref; $i += 2) {
        my $key = $ref->[$i] = uc $ref->[$i];
        my $val = $ref->[$i + 1];
        if ($ctime{$key}) {
            $self->{$key} = $self->play_expr($val);
            if ($key eq 'INTERPOLATE') {
                $self->{'_start_tag'} = (! $self->{'INTERPOLATE'}) ? $self->{'START_TAG'} : qr{(?: $self->{'START_TAG'} | (\$))}sx;
            }
        } elsif (! $rtime{$key}) {
            $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
        }
    }
    for (my $i = 1; $i < @$config; $i++) {
        my $key = $config->[$i] = uc $config->[$i]->[0];
        if ($ctime{$key}) {
            $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef');
        } elsif (! $rtime{$key}) {
            $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
        }
    }
    return $config;
}

sub parse_DEBUG {
    my ($self, $str_ref) = @_;
    $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx
        || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref));
    my $ret = [lc($1)];
    if ($ret->[0] eq 'format') {
        $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs
            || $self->throw('parse', "Missing format string", undef, pos($$str_ref));
        $ret->[1] = $2;
    }
    return $ret;
}

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

sub parse_DUMP {
    my ($self, $str_ref) = @_;
    return $self->parse_args($str_ref, {named_at_front => 1});
}

sub parse_EVAL {
    my ($self, $str_ref) = @_;
    return $self->parse_args($str_ref, {named_at_front => 1});
}

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

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

    return [$name, $filter];
}

sub parse_FOR {
    my ($self, $str_ref) = @_;
    my $items = $self->parse_expr($str_ref);
    my $var;
    if ($$str_ref =~ m{ \G \s* $QR_COMMENTS (= | [Ii][Nn]\b) \s* }gcxo) {
        $var = [@$items];
        $items = $self->parse_expr($str_ref);
    }
    return [$var, $items];
}

sub parse_GET {
    my ($self, $str_ref) = @_;
    my $ref = $self->parse_expr($str_ref);
    $self->throw('parse', "Missing variable name", undef, pos($$str_ref)) if ! defined $ref;
    if ($self->{'AUTO_FILTER'}) {
        $ref = [[undef, '~', $ref], 0] if ! ref $ref;
        push @$ref, '|', $self->{'AUTO_FILTER'}, 0 if @$ref < 3 || $ref->[-3] ne '|';
    }
    return $ref;
}

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

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

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

sub parse_LOOP {
    my ($self, $str_ref, $node) = @_;
    return $self->parse_expr($str_ref)
        || $self->throw('parse', 'Missing variable on LOOP directive', undef, pos($$str_ref));
}

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

    my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.)"});
    $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name;
    if (! ref $name) {
        $name = [ $name, 0 ];
    }

    my $args;
    if ($$str_ref =~ m{ \G \( \s* }gcx) {
        $args = $self->parse_args($str_ref, {positional_only => 1});
        $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
    } elsif ($self->{'V1DOLLAR'}) { # allow for Velocity style macro args (no parens - but dollars are fine)
        while ($$str_ref =~ m{ \G (\s+ \$) }gcx) {
            my $lead = $1;
            my $arg  = $self->parse_expr($str_ref);
            if (! defined $arg) {
                pos($$str_ref) -= length($lead);
                last;
            }
            push @$args, $arg;
        }
    }

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

sub parse_META {
    my ($self, $str_ref) = @_;
    my $args = $self->parse_args($str_ref, {named_at_front => 1});
    my $hash;
    return [%$hash] if ($hash = $self->play_expr($args->[0])) && UNIVERSAL::isa($hash, 'HASH');
    return undef;
}

sub parse_PROCESS {
    my ($self, $str_ref) = @_;

    return $self->parse_args($str_ref, {
        named_at_front       => 1,
        allow_bare_filenames => 1,
        require_arg          => 1,
    });
}

sub parse_RETURN {
    my ($self, $str_ref) = @_;
    my $ref = $self->parse_expr($str_ref); # optional return value
    return $ref;
}

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

    if ($initial_op) {
        if ($initial_op eq '='
            && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE }gcx # find a word
            && ((pos($$str_ref) -= length($1)) || 1)             # always revert
            && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its 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
            my $val = $self->parse_expr($str_ref);
            if ($initial_op =~ /(.+)=$/) {
                $initial_op = '=';
                $val = [[undef, $1, $initial_var, $val], 0];
            }
            return [[$initial_op, $initial_var, $val]];
        }
    }

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

        if ($$str_ref =~ m{ \G \s* $QR_COMMENTS ($QR_OP_ASSIGN) >? }gcx) {
            my $op = $1;
            if ($op eq '='
                && $$str_ref =~ m{ \G \s* $QR_COMMENTS $QR_DIRECTIVE }gcx # find a word
                && ((pos($$str_ref) -= length($1)) || 1)             # always revert
                && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its a directive - if so set up capturing
                $node->[6] = 1;                                      # set a flag to keep parsing
                my $val = $node->[4] ||= [];                         # setup storage
                if ($op =~ /(.+)=$/) {
                    $op = '=';
                    $val = [[undef, $1, $set, $val], 0];
                }
                push @SET, [$op, $set, $val];
                last;
            } else { # get a normal variable
                push @SET, [$op, $set, $self->parse_expr($str_ref)];
            }
        } else {
            push @SET, ['=', $set, undef];
        }
    }

    return \@SET;
}

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

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

    my ($start, $end);
    if ($$str_ref =~ m{ \G (\w+) }gcxs) {
        my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref));
        ($start, $end) = @$ref;

    } else {
        local $self->{'_operator_precedence'} = 1; # prevent operator matching
        $start = $$str_ref =~ m{ \G (?= \s* $QR_COMMENTS [\'\"\/]) }gcx
            ? $self->parse_expr($str_ref)
            : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s+ $QR_COMMENTS"})
            || $self->throw('parse', "Invalid opening tag in TAGS", undef, pos($$str_ref));
        $end   = $$str_ref =~ m{ \G (?= \s* $QR_COMMENTS [\'\"\/]) }gcx
            ? $self->parse_expr($str_ref)
            : $self->parse_expr($str_ref, {auto_quote => "(\\S+) \\s* $QR_COMMENTS"})
            || $self->throw('parse', "Invalid closing tag in TAGS", undef, pos($$str_ref));
        for my $tag ($start, $end) {
            $tag = $self->play_expr($tag);
            $tag = quotemeta($tag) if ! ref $tag;
        }
    }
    return [$start, $end];
}

sub parse_THROW {
    my ($self, $str_ref, $node) = @_;
    my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: \\.\\w+\\b)*) $QR_AQ_SPACE \\s* $QR_COMMENTS"});
    $self->throw('parse.missing', "Missing name in THROW", $node, pos($$str_ref)) if ! $name;
    my $args = $self->parse_args($str_ref, {named_at_front => 1});
    return [$name, $args];
}

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

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

    my $var;
    my $mark = pos $$str_ref;
    if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))
        && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment
            || ((pos($$str_ref) = $mark) && 0))               # otherwise we need to rollback
        ) {
        $var = $_var;
    }

    my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"});
    $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module;
    $module =~ s/\./::/g;

    my $args;
    my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo;
    $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1});

    if ($open) {
        $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
    }

    return [$var, $module, $args];
}

sub parse_VIEW {
    my ($self, $str_ref) = @_;

    my $ref = $self->parse_args($str_ref, {
        named_at_front       => 1,
        require_arg          => 1,
    });

    return $ref;
}

sub parse_WHILE { $DIRECTIVES->{'IF'}->[0]->(@_) }

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

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

sub dump_parse_tree {
    my $self = shift;
    $self = $self->new if ! ref $self;
    my $str = shift;
    my $ref = ref($str) ? $str : \$str;
    my $sub;
    my $nest;
    $sub = sub {
        my ($tree, $indent) = @_;
        my $out = "[\n";
        foreach my $node (@$tree) {
            if (! ref($node) || (! $node->[4] && ! $node->[5])) {
                $out .= "$indent    ".$self->ast_string($node).",\n";
                next;
            }
            $out .= "$indent    " . $nest->($node, "$indent    ");
        }
        $out .= "$indent]";
    };
    $nest = sub {
        my ($node, $indent) = @_;
        my $out = $self->ast_string([@{$node}[0..3]]);
        chop $out;
        if ($node->[4]) {
            $out .= ", ";
            $out .= $sub->($node->[4], "$indent");
        }
        if ($node->[5]) {
            $out .= ", ". $nest->($node->[5], "$indent") . $indent;
        } elsif (@$node >= 6) {
            $out .= ", ". $self->ast_string($node->[5]);
        }
        if (@$node >= 7) { $out.= ", ". $self->ast_string($node->[6]) };
        $out .= "],\n";
        return $out;
    };

    return $sub->($self->parse_tree($ref), '') ."\n";
}

sub dump_parse_expr {
    my $self = shift;
    $self = $self->new if ! ref $self;
    my $str = shift;
    my $ref = ref($str) ? $str : \$str;
    return $self->ast_string($self->parse_expr($ref));
}

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

1;

__END__