# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Template::Parser
#   Author: Jason Rhinelander
#   CVS Info :                          
#   $Id: Parser.pm,v 2.140 2005/07/05 00:33:57 jagerman Exp $
#
# Copyright (c) 2005 Gossamer Threads Inc.  All Rights Reserved.
# ====================================================================
#
# Description:
#   A module for parsing templates. This module actually generates
#   Perl code that will print the template.
#

package GT::Template::Parser;
# ===============================================================

use 5.004_04;
use strict;

use GT::Base;
use GT::Template;

use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS %ESCAPE_MAP);

@ISA     = qw/GT::Base/;
$VERSION = sprintf "%d.%03d", q$Revision: 2.140 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0;
$ATTRIBS = { root => '.', indent => '  ', begin => '<%', end => '%>', print => 0 };
$ERRORS  = {
    NOTEMPLATE        => "No template file was specified.",
    BADINC            => $GT::Template::ERRORS->{BADINC},
    CANTOPEN          => "Unable to open template file '%s': %s",
    DEEPINC           => $GT::Template::ERRORS->{DEEPINC},
    EXTRAELSE         => "Error: extra else tag",
    EXTRAELSIF        => "Error: extra elsif/elseif tag",
    NOSCALAR          => "Error: Variable '%s' is not scalar",
    UNMATCHEDELSE     => "Error: Unmatched else tag",
    UNMATCHEDELSIF    => "Error: Unmatched elsif/elseif tag",
    UNMATCHEDENDIF    => "Error: Unmatched endif/endifnot/endunless tag",
    UNMATCHEDENDLOOP  => "Error: endloop found outside of loop",
    UNMATCHEDNEXTLOOP => "Error: nextloop found outside of loop",
    UNMATCHEDLASTLOOP => "Error: lastloop found outside of loop",
    UNKNOWNTAG        => $GT::Template::ERRORS->{UNKNOWNTAG},
    UNKNOWNINCLUDETAG => "Unknown tag in include: '%s'"
};

use vars qw/%FILTERS $RE_FILTERS $RE_SET $RE_MATH $RE_EXPR/;

%FILTERS = (
    escape_html   => '$tmp = GT::CGI::html_escape($tmp);',
    unescape_html => '$tmp = GT::CGI::html_unescape($tmp);',
    escape_url    => '$tmp = GT::CGI::escape($tmp);',
    unescape_url  => '$tmp = GT::CGI::unescape($tmp);',
    escape_js     => q{$tmp =~ s{([\\\/'"])}{\\\$1}g; $tmp =~ s{(?:\r\n|\r|\n)}{\\\n}g;},
    nbsp          => '$tmp =~ s/\s/&nbsp;/g;'
);
@FILTERS{qw/escapeHTML unescapeHTML escapeURL unescapeURL escapeJS/} = @FILTERS{qw/escape_html unescape_html escape_url unescape_url escape_js/};
for (qw/uc lc ucfirst lcfirst/) {
    $FILTERS{$_} = '$tmp = ' . $_ . '($tmp);';
}
$RE_FILTERS = '(?:(?:' . join('|', map quotemeta, keys %FILTERS) . ')\b\s*)+';

$RE_SET = q(set\s+(\w+(?:\.\$?\w+)*)\s*([-+*/%^.]|\bx|\|\||&&)?=\s*); # Two captures - the variable and the (optional) assignment modifier
$RE_EXPR = qq{($RE_FILTERS)?('(?:[^\\\\']|\\\\.)*'|"(?:[^\\\\"]|\\\\.)*"|(?!$RE_FILTERS)[^\\s('"]+)}; # Two captures - the (optional) filters, and the value/variable
$RE_MATH = q(\bx\b|/\d+(?=\s)|\bi/|[+*%~^/-]|\|\||&&);

sub parse {
# ---------------------------------------------------------------
# Can be called as either a class method or object method. This
# returns three things - the first is a scalar reference to a string
# containing all the perl code, the second is an array reference
# of dependencies, and the third is the filetype of the template -
# matching this regular expression:  /^((INH:)*(REL|LOCAL)|STRING)$/.
# For example, 'INH:INH:INH:INH:LOCAL', 'LOCAL', 'INH:REL', 'REL', or 'STRING'
#
    my $self = ref $_[0] ? shift : (shift->new);
    my ($template, $opt, $print) = @_; # The third argument should only be used internally.
    defined $template or return $self->fatal(NOTEMPLATE => $template);
    defined $opt      or $opt  = {};

# Set print to 1 if we were called via parse_print.
    $opt->{print} = 1 if $print;

# Load the template which can either be a filename, or a string passed in.
    $self->{root} = $opt->{root} if $opt->{root};

    my ($full, $string);
    my $type = '';
    if (exists $opt->{string}) {
        $full = $template;
        $string = $opt->{string};
        $type = "STRING";
    }
    else {
        require GT::Template::Inheritance;
        $full = GT::Template::Inheritance->get_path(path => $self->{root}, file => $template)
            or return $self->fatal(CANTOPEN => $template, "File does not exist.");
    }

    my ($mtime, $size, $tpl) = (0, 0);
    if (defined $string) {
        $tpl = \$string;
    }
    else {
        ($mtime, $size, $tpl) = $self->load_template($full);
    }

# Parse the template.
    $self->debug("Parsing '$template' (found '$full') with (print => $opt->{print})") if $self->{_debug};
    my @files = ([$template, $full, $mtime, $size]);
    my $code = $self->_parse($template, $opt, $tpl, \@files);

# Return the code, and an array reference of [filename, path, mtime, size] items
    return ($code, \@files);
}

sub parse_print {
# ---------------------------------------------------------------
# Print output as template is parsed.
#
    my $self = shift;
    $self->parse(@_[0..1], 1)
}

sub load_template {
# ---------------------------------------------------------------
# Loads either a given filename, or a template string, and returns a reference to it.
#
    my ($self, $full_file) = @_;

    $self->debug("Reading '$full_file'") if $self->{_debug};

    -e $full_file or return $self->fatal(CANTOPEN => $full_file, "File does not exist.");
    local *TPL;
    open TPL, "< $full_file" or return $self->fatal(CANTOPEN => $full_file, "$!");
    my ($mtime, $size) = (stat TPL)[9, 7];
    my $ret = \do { local $/; <TPL> };
    close TPL;

    return $mtime, $size, $ret;
}

sub _parse {
# ---------------------------------------------------------------
# Parses a template.
#
    my ($self, $template, $opt, $tpl, $files) = @_;

    local $self->{opt}     = {};
    $self->{opt}->{print}  = exists $opt->{print}  ? $opt->{print}  : $self->{print};
    $self->{opt}->{indent} = exists $opt->{indent} ? $opt->{indent} : $self->{indent};

    unless (defined $opt->{string}) {
# Set the root if this is a full path so includes can be relative to template.
        if ((not $self->{root} or $self->{root} eq '.') and ((index($template, '/') == 0) or (index($template, ':') == 1))) {
            $self->{root} = substr($template, 0, rindex($template, '/'));
            substr($template, 0, rindex($template, '/') + 1) = '';
        }
    }

    return $self->_parse_tags($tpl, $files);
}

sub _text_escape {
    my $text = shift;
    $text =~ s/(\\(?=[{}\\]|$)|[{}])/\\$1/g;
    $text;
}

sub _filter {
    my ($filter, $var) = @_;
    my $f = $FILTERS{$filter};
    $f =~ s/\$tmp\b/$var/g if $var;
    $f . " # $filter";
}

sub _comment {
    my $comment = shift;
    $comment =~ s/^/#/gm;
    $comment . "\n";
}

sub _parse_tags {
# ---------------------------------------------------------------
# Returns a string containing perl code that, when run (the code should be
# passed a template object as its argument) will produce the template.
# Specifically, the returned from this is a scalar reference (containing the
# perl code) and an array reference of the file's dependencies.
#
    my ($self, $tplref, $files) = @_;

    my $tpl = $$tplref;

    my $begin      = quotemeta($self->{begin});
    my $end        = quotemeta($self->{end});
    my $root       = $self->{root};
    my $loop_depth = 0;
    my $i          = -1;
    my @seen_else  = ();
    my @if_level   = ();
    my $print      = $self->{opt}->{print};
    my $indent       = $self->{opt}->{indent};
    my $indent_level = 0; # The file is already going to be in a hash

    my %deps;

    my $last_pos = 0;

# Can only go up to GT::Template::INCLUDE_LIMIT includes inside includes.
    my $include_safety  = 0;
# Store the "if" depth so that too many or too few <%endif%>'s in an include
# won't break things:
    my @include_ifdepth;

    my $return          = <<'CODE';

local $^W; # Get rid of warnings. unfortunately, this won't work for Perl 5.6's -W switch
my $self = shift;
my $return = '';
my $tags = $self->vars;
my $escape = $self->{opt}->{escape};
my $strict = $self->{opt}->{strict};
my ($tmp, $tmp2, $tmp3);
CODE

# We loop through the text looking for <% and %> tags, but also watching out for comments
# <%-- some comment --%> as they can contain other tags.
    my $text = sub {
        my $text = shift;
        length $text or return;
        $return .= ($indent x ($indent_level)) . ($print ? q|print q{| : q|$return .= q{|);
        $return .= _text_escape($text) . q|};
|;  };

    #               $1                                                  $2
    while ($tpl =~ /(\s*$begin\s*~\s*$end\s*|(?:\s*$begin\s*~|$begin)\s*(--.*?(?:--(?=\s*(?:~\s*)?$end)|$)|.+?)\s*(?:~\s*$end\s*|$end|$))/gs) {
        my $tag = $2;
        my $tag_len     = length $1;
        my $print_start = $last_pos;
        $last_pos       = pos $tpl;
        # Print out the text before the tag.
        $text->(substr($tpl, $print_start, $last_pos - $tag_len - $print_start));

        next unless defined $tag; # Won't be defined for: <%~%>, which is a special cased no-op, whitespace reduction tag

# Handle nested comments
        if (substr($tag,0,2) eq '--') {
            my $save_pos = pos($tag);
            while ($tag =~ /\G.*?$begin\s*(?:~\s*)?--/gs) {
                $save_pos = pos($tag);
                my $tpl_save_pos = pos($tpl);
                if ($tpl =~ /\G(.*?--\s*(?:~\s*$end\s*|$end))/gs) {
                    $tag .= $1;
                    pos($tag) = $save_pos;
                    $last_pos = pos($tpl);
                }
                else {
                    $last_pos = pos($tpl) = length($tpl);
                    $tag .= substr($tpl, $last_pos);
                    last;
                }
            }
        }
# Tag consists of only \w's and .'s - it's either a variable or some sort of
# keyword (else, endif, etc.)
        elsif ($tag !~ /[^\w.]/) {

# 'else' - If $i is already at -1, we have an umatched tag.
            if ($tag eq 'else') {
                if ($i == -1 or $indent_level != $if_level[$i]) {
                    $return .= _comment($ERRORS->{UNMATCHEDELSE});
                    $text->($ERRORS->{UNMATCHEDELSE});
                }
                elsif ($seen_else[$i]++) {
                    $return .= _comment($ERRORS->{EXTRAELSE});
                    $text->($ERRORS->{EXTRAELSE});
                }
                else {
                    $return .= $indent x ($indent_level - 1) . q|}
|;                  $return .= $indent x ($indent_level - 1) . q|else {
|;              }
            }

# 'endif', 'endunless', 'endifnot' - decrement our level. If $i is already at -1, we have an umatched tag.
            elsif ($tag eq 'endif' or $tag eq 'endifnot' or $tag eq 'endunless') {
                if ($i == -1 or @include_ifdepth and $i <= $include_ifdepth[-1][0] or $indent_level != $if_level[$i]) {
                    $return .= _comment($ERRORS->{UNMATCHEDENDIF});
                    $text->($ERRORS->{UNMATCHEDENDIF});
                }
                else {
                    --$i; --$#seen_else; --$#if_level; # for vim: {
                    $return .= $indent x --$indent_level . q|}
|;              }
            }
# 'endloop' - ends a loop
            elsif ($tag eq 'endloop') {
                if ($loop_depth <= 0) {
                    $return .= _comment($ERRORS->{UNMATCHEDENDLOOP});
                    $text->($ERRORS->{UNMATCHEDENDLOOP});
                }
                else {
                    $loop_depth--; # for vim: {{{{
                    $return .= $indent x --$indent_level . q|}
|;                  $return .= $indent x --$indent_level . q|}
|;                  $return .= $indent x --$indent_level . q|}
|;                  $return .= $indent x $indent_level . q|for (keys %loop_set) { $self->{VARS}->{$_} = $orig->{$_} }
|;                  $return .= $indent x --$indent_level . q|}
|;              }
            }
# 'lastloop' - simply put in a last;
            elsif ($tag eq 'lastloop') {
                if ($loop_depth <= 0) {
                    $return .= _comment($ERRORS->{UNMATCHEDLASTLOOP});
                    $text->($ERRORS->{UNMATCHEDLASTLOOP});
                }
                else {
                    $return .= $indent x $indent_level . q|last LOOP| . $loop_depth . q|;
|;              }
            }
# 'nextloop' - simply put in a next;
            elsif ($tag eq 'nextloop') {
                if ($loop_depth <= 0) {
                    $return .= _comment($ERRORS->{UNMATCHEDNEXTLOOP});
                    $text->($ERRORS->{UNMATCHEDNEXTLOOP});
                }
                else {
                    $return .= $indent x $indent_level . q|next;
|;              }
            }
# 'endparse' - stops the parser.
            elsif ($tag eq 'endparse') {
                $return .= $indent x $indent_level . q|return | . ($print ? q|1| : q|\$return|) . q|;
|;          }
# 'endinclude' - this is put at the end of an include when the include is inserted into the current template data.
            elsif ($tag eq 'endinclude') {
                if (@include_ifdepth) {
                    while ($indent_level > $include_ifdepth[-1][1]) { # for vim: {
                        $return .= ($indent x --$indent_level) . q|}
|;                  }
                    $i = $include_ifdepth[-1][0];
                }
                $include_safety--;
                pop @include_ifdepth; # for vim: {
                $return .= $indent x --$indent_level . q|} # Done include
|;          }
            elsif ($tag eq 'DUMP') {
                my $func = $self->_check_func('GT::Template::dump(-auto => 1)');
                $return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|;          }
# Function call (without spaces)
            elsif (my $func = $self->_check_func($tag)) {
                $return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|;          }
# Variable
            else {
                $return .= $indent x $indent_level;
                $return .= ($print ? q|print| : q|$return .=|) . q| $tmp if defined($tmp = $self->_get_var(q{| . _text_escape($tag) . q|}, $escape, $strict));
|;          }
        }
# 'if', 'ifnot', 'unless', 'elsif', 'elseif'
        elsif ($tag =~ s/^(if(?:not)?|unless|else?if)\b\s*//) {
            my $op = $1;
            $op = "unless" if $op eq "ifnot";
            $op = "elsif" if $op eq "elseif";
            if ($op eq 'elsif') {
                if ($i == -1 or $indent_level != $if_level[$i]) {
                    $return .= _comment($ERRORS->{UNMATCHEDELSIF});
                    $text->($ERRORS->{UNMATCHEDELSIF});
                    next;
                }
                elsif ($seen_else[$i]) {
                    $return .= _comment($ERRORS->{EXTRAELSIF});
                    $text->($ERRORS->{EXTRAELSIF});
                    next;
                }
                # for vim: {
                $return .= $indent x ($indent_level - 1) . q|}
|;              $return .= $indent x ($indent_level - 1) . q|elsif (|;
            }
            else {
                $seen_else[++$i] = 0;
                $return .= $indent x $indent_level++;
                $return .= "$op (";
                $if_level[$i] = $indent_level;
            }

            my @tests;
            my $bool = '';
            if ($tag =~ /\sor\s*(?:not)?\s/i) {
                @tests = grep $_, split /\s+or\s*(not)?\s+/i, $tag;
                $bool = ' or ';
            }
            elsif ($tag =~ /\sand\s*(?:not)?\s/i) {
                @tests = grep $_, split /\s+and\s*(not)?\s+/i, $tag;
                $bool = ' and ';
            }
            else {
                @tests = $tag;
            }
            if ($tests[0] =~ s/^not\s+//) {
                unshift @tests, "not";
            }
            my @all_tests;
            my $one_neg;
            for my $tag (@tests) {
                if ($tag eq 'not') {
                    $one_neg = 1;
                    next;
                }
                my $this_neg = $one_neg ? $one_neg-- : 0;
                $tag =~ s/^\$?([\w:.\$-]+)\b\s*// or next;
                my $var = $1;
                if (index($var, '::') > 0) {
                    $var = $self->_check_func($var);
                }
                else {
                    $var = q|$self->_get_var(q{| . _text_escape($var) . q|}, 0, 0)|;
                }
                my ($comp, $casei, $val);
                if (length($tag)) {
                    if    ($tag =~ s/^(==?|!=|>=?|<=?|%|(i?)(?:eq|ne|g[et]|l[et]))\s*//) { $casei = $2 ? 1 : 0; $comp = " " . ($casei ? substr($1, 1) : $1) . " " }
                    elsif ($tag =~ s/^(i?)(?:like|contains)\s+//i)                       { $casei = $1 ? 1 : 0; $comp = "contains" }
                    elsif ($tag =~ s/^(i?)(start|end)s?\s+//i)                           { $casei = $1 ? 1 : 0; $comp = $2 }
                    $val = $tag if defined $comp;
                }
                $comp = ' == ' if $comp and $comp eq ' = ';
                my $full_comp = defined($comp);
                my $result = $this_neg ? 'not(' : '';
                if ($full_comp) {
                    if (substr($val,0,1) eq '$') {
                        substr($val,0,1) = '';
                        $val = q|$self->_get_var(q{| . _text_escape($val) . q|}, 0, 0)|;
                    }
                    elsif ($val =~ /^['"]/) {
                        $val = _quoted_string($val);
                    }
                    elsif (index($val, '::') > 0) {
                        $val = $self->_check_func($val);
                    }
                    elsif ($val !~ /^[+-]?(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?$/) {
                        $val = "q{" . _text_escape($val) . "}";
                    }
                    if ($casei) {
                        $val = "lc($val)";
                        $var = "lc($var)";
                    }
                    if ($comp eq 'contains') {
                        $result .= qq|index($var, $val) >= 0|;
                    }
                    elsif ($comp eq 'start') {
                        $result .= qq|substr($var, 0, length $val) eq $val|;
                    }
                    elsif ($comp eq 'end') {
                        $result .= qq|substr($var, -length $val) eq $val|;
                    }
                    elsif ($comp) {
                        $result .= qq|$var $comp $val|;
                    }
                }
                else { # Just a simple <%if var%> (Or something we don't understand, in which case we'll treat it like a simple <%if var%>)
                    $result .= $var;
                }
                $result .= ")" if $this_neg;
                push @all_tests, $result;
            }
            my $final_result = join $bool, @all_tests;
            $return .= $final_result;
            $return .= q|) {
|; # for vim: }
        }
# 'loop' - <%loop var%>, <%loop Pkg::Func(arg, $arg => arg)%>, <%loop var(arg, $arg => arg)%>, <%loop 1 .. $end%>
        elsif ($tag =~ /^loop\s+(.+)/s) {
            $loop_depth++;
            my $loopon = $1;
            $return .= $self->_loop_on($loopon, $indent, $indent_level, $loop_depth);
        }
# 'include $foo' - runtime includes based on variable value.
        elsif ($tag =~ /^include\s*\$(.*)/) {
            my $include_var = $1;
            $return .= $indent x $indent_level++;
            $return .= q|if (defined($tmp = $self->_get_var(q{| . _text_escape($include_var) . q|}, $escape))) {
|;          $return .= $indent x $indent_level . ($print ? 'print ' : '$return .= ');
            $return .= q|$self->_include(ref $tmp eq 'SCALAR' ? $$tmp : $escape ? GT::CGI::html_escape($tmp) : $tmp);
|;          $return .= $indent x ($indent_level - 1) . q|}
|;          $return .= $indent x ($indent_level - 1) . q|else {
|;          $return .= $indent x $indent_level; # for vim: }
            $return .= ($print ? q|print q{| : q|$return .= q{|) . _text_escape(sprintf($ERRORS->{UNKNOWNINCLUDETAG}, $include_var)) . q|};
|;          $return .= $indent x --$indent_level . q|}
|;      }
# 'include' - load the file into the current template and continue parsing.
# The template must be added to this template's dependancy list.
# 'include $foo' is handled completely differently, above.
        elsif ($tag =~ /^include\b\s*([^\$].*)/) {
            my $include  = $1;

            # If inside an if, but not a loop, turn this into a runtime include, so that:
            #   <%if foo%><%include bar.html%><%endif%>
            # is faster -- at least when foo is not set.  Compile-time includes are still
            # faster (as long as they are actually used) - but not by a significant amount
            # unless inside a largish loop.
            if (!$loop_depth and $i > -1 and not ($include eq '.' or $include eq '..' or $include =~ m{[/\\]})) {
                $return .= $indent x $indent_level;
                $return .= ($print ? 'print' : '$return .=') . q| $self->_include(q{| . _text_escape($include) . q|}, 1);
|;              next;
            }

            my $filename;
            if ($include =~ m{^(?:\w:)?[/\\]}) {
                $filename = $include;
            }
            else {
                require GT::Template::Inheritance;
                $filename = GT::Template::Inheritance->get_path(path => $root, file => $include);
            }

            local *INCL;
            if ($filename and open INCL, "<$filename") {
                push @$files, [$include, $filename, (stat INCL)[9, 7]]; # mtime, size
                my $data = do { local $/; <INCL> };
                close INCL;
                substr($tpl, $last_pos - $tag_len, $tag_len) = $data . "$self->{begin}endinclude$self->{end}";
                $last_pos -= $tag_len;
                pos($tpl) = $last_pos;
                ++$include_safety <= GT::Template::INCLUDE_LIMIT or return $self->fatal('DEEPINC');

                $return .= $indent x $indent_level++ . q|{; | # The ; allows empty include files.     for vim: }
                    . _comment("Including $filename");

                push @include_ifdepth, [$i, $indent_level];
            }
            else {
                push @$files, [$include, $filename, -1, -1];
                my $errfile = $filename || "$root/$include";
                $return .= _comment(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
                $text->(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
            }
            next;
        }
# 'set' - set a value from the templates, optionally with a modifier (i.e. set
# foo = 4 vs. set foo += 4), also look for things like <%... x ...%>, <%... ~
# ...%>, etc., optionally with a 'set' on the front.  Filters are permitted as
# well.
#
#                            $1-3        $4, $5     $6           $7, $8     $9            $10           $11
        elsif ($tag =~ m{^(?:($RE_SET)(?:$RE_EXPR\s*($RE_MATH))?|$RE_EXPR\s*($RE_MATH))\s*($RE_FILTERS)?(.+)}os) {
            # $set is set if this is a 'set' (set foo = 3) as opposed to merely a modifier (foo + 3)
            # $setvar is the variable to set (obviously only if $set is set)
            # $change is set if this is a modifier assignment (i.e. 'set foo += 3' as opposed to 'set foo = 3')
            # $var is the value to set in a multi-value expression - i.e. bar in 'set foo = bar + 3', but undefined in 'set foo = $bar'
            #     or 'set foo = 3' - it can be a variable (i.e. without a $) or quoted string.
            # $var_filters are any filters that apply to $var, such as the 'escape_html' in 'set foo = escape_html $bar x 5'
            # $comp is the modifer to the value - such as the 'x' in 'set foo = $bar x 3'
            # $val is the actual value to set, and is the only parameter common to all cases handled here.  It can be a $variable,
            #     quoted string, or bareword string.
            # $val_filters are any filters to apply to $val
            my ($set, $setvar, $change, $var_filters, $var, $comp);
            my ($val_filters, $val) = ($10, $11);
            if ($1) {
                ($set, $setvar, $change, $var_filters, $var, $comp) = ($1, $2, $3 || '', $4, $5, $6);
            }
            else {
                ($var_filters, $var, $comp) = ($7, $8, $9);
            }

            if (defined $var) {
                if ($var =~ /^['"]/) {
                    $var = _quoted_string($var);
                }
                else {
                    substr($var,0,1) = '' if substr($var,0,1) eq '$';
                    $var = q|$self->_get_var(q{| . _text_escape($var) . q|})|;
                }

                if ($var_filters) {
                    $return .= $indent x $indent_level;
                    $return .= "\$tmp2 = $var;\n";
                    $var = '$tmp2';
                    for (reverse split ' ', $var_filters) {
                        $return .= $indent x $indent_level;
                        $return .= _filter($_, '$tmp2') . "\n";
                    }
                }
            }

            if (substr($val,0,1) eq '$') {
                substr($val,0,1) = '';
                $val = q|$self->_get_var(q{| . _text_escape($val) . q|})|;
            }
            elsif ($val =~ /^['"]/) {
                $val = _quoted_string($val);
            }
            elsif (my $funccode = $self->_check_func($val)) {
                $val = q|(| . $funccode . q< || '')>;
            }
            else {
                $val = q|q{| . _text_escape($val) . q|}|;
            }
            if ($val_filters) {
                $return .= $indent x $indent_level;
                $return .= "\$tmp3 = $val;\n";
                $val = '$tmp3';
                for (reverse split ' ', $val_filters) {
                    $return .= $indent x $indent_level;
                    $return .= _filter($_, '$tmp3') . "\n";
                }
            }

            my $calc;
            if ($set and not defined $var) {
                $calc = $val;
            }
            else {
                $calc = _math($var, $comp, $val);
            }

            $return .= $indent x $indent_level;
            if ($set) {
                $return .= q|$tags->{q{| . _text_escape($setvar) . q|}} = \do { my $none = (|;

                if ($change) {
                    # Passing $escape is required here, because what we save back
                    # is always a reference, thus the escaping has to occur here.
                    # $strict, however, is NOT passed because we aren't interested
                    # in variables becoming "Unknown tag: '....'"-type values.
                    $return .= _math(q|$self->_get_var(q{| . _text_escape($setvar) . q|}, $escape)|, $change, $calc);
                }
                else {
                    $return .= $calc;
                }
                $return .= ') }';
            }
            else {
                $return .= ($print ? 'print ' : q|$return .= |) . $calc;
            }

            $return .= qq|;
|;      }
# Filters: 'escape_url', 'unescape_url', 'escape_html', 'unescape_html', 'escape_js', 'uc', 'ucfirst', 'lc', 'lcfirst', 'nbsp'
        elsif ($tag =~ /^($RE_FILTERS)(\S+)/o) {
            my $var = $2;
            my @filters = reverse split ' ', $1;

            $return .= $indent x $indent_level++;
            $return .= q|if (($tmp) = $self->_raw_value(q{| . _text_escape($var) . q|})) {
|;          $return .= $indent x $indent_level;
            $return .= q|$tmp = $$tmp if ref $tmp eq 'SCALAR' or ref $tmp eq 'LVALUE';
|;          $return .= $indent x $indent_level++;
            $return .= q|if (ref $tmp) {
|;          $return .= $indent x $indent_level;
            $text->(sprintf $ERRORS->{NOSCALAR}, $var);
            $return .= $indent x ($indent_level - 1) . q|}
|;          $return .= $indent x ($indent_level - 1) . q|else {
|;          $return .= $indent x $indent_level;
            $return .= q|$tmp = $self->_get_var(q{| . _text_escape($var) . q|}, $escape);
|;          for (@filters) {
                $return .= $indent x $indent_level;
                $return .= _filter($_) . "\n";
            }
            $return .= $indent x $indent_level;
            $return .= ($print ? q|print| : q|$return .=|) . q| $tmp;
|;          $return .= $indent x --$indent_level . q|}
|;          $return .= $indent x ($indent_level - 1) . q|}
|;          $return .= $indent x ($indent_level - 1) . q|else {
|;          $return .= $indent x $indent_level;
            $text->(sprintf $ERRORS->{UNKNOWNTAG}, $var);
            $return .= $indent x --$indent_level . q|}
|;      }
# 'DUMP variable'
        elsif ($tag =~ /^DUMP\s+\$?(\w+(?:\.\$?\w+)*)$/) {
            my $func = qq{\$self->_call_func('GT::Template::dump', -auto => 1, -var => '$1')};
            $return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|;      }
        elsif (my $func = $self->_check_func($tag)) {
            $return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|;      }
        else {
            # Check to see if it's a valid variable, function call, etc.  Force
            # strict on because this is some sort of strange tag that doesn't
            # appear to be a variable, which should always produce an "Unknown
            # tag" warning.
            $return .= $indent x $indent_level;
            $return .= ($print ? q|print| : q|$return .=|) . q| $tmp if defined($tmp = $self->_get_var(q{| . _text_escape($tag) . q|}, $escape, 1));
|;      }
    }
    $text->(substr($tpl, $last_pos));
    while ($indent_level > 0) {
        $return .= ($indent x --$indent_level) . q|}
|   }
    $return .= $print ? q|return 1;| : q|return \$return;|;
    return \$return;
}

# Handles quoted string semantics.
#
# Inside double-quote strings:
# \ can preceed any non-word character to mean the character itself - following
# word characters the following escapes are currently supported: \n, \r, \t,
# \000 (octal character value), \x00 (hex character value).  \ followed by any
# other word character is undefined behaviour and should not be used.
# Variables are interpolated - you can write a variable as $foo.bar or
# ${foo.bar}.  Inner-variable interpolation (such as what happens in
# <%foo.$bar%> is supported only in the latter form: ${foo.$bar} - $foo.$bar
# would end up becoming the value of foo, a ., then the value of bar.
#
# Inside single-quote strings:
# \ can preceed \ or ' to mean the value; preceeding anything else a \ is a
# literal \
%ESCAPE_MAP = (
    t => '\t',
    n => '\n',
    r => '\r',
);
sub _quoted_string {
    my $string = shift;
    if ($string =~ s/^"//) {
        $string =~ s/"$//;
        $string =~ s[
            (\\) # $1 A backslash escape of some sort
            (?:
                (x[0-9a-fA-F]{2}) # $2 - \x5b - a hex char
            |
                ([0-7]{1,3}) # $3 - \123 - an octal char
            |
                (\w) # $4 - a word char - \n, \t, etc.
            |
                (\W) # $5 - a non word char - \\, \", etc.
            )
        |
            \$ # The dollar sign that starts a variable
            (?:
                { # opening { in a ${var}-style variable  ## vim: }
                    (\w+(?:\.\$?\w+)*) # $6 - the inner part of a ${var} variable
                }
            |
                (\w+) # $7 - the name of a $var-style variable
            )
        |
            ([{}\\]) # $8 - a character that needs to be escaped inside the q{}-delimited string - the \\ will only
                     # match at the very end of the string - though "string\" isn't really valid.
        ][
            if ($1) { # a \ escape
                if (my $code = $2 || $3) {
                    qq|}."\\$code".q{|;
                }
                elsif (exists $ESCAPE_MAP{$4}) {
                    qq|}."$ESCAPE_MAP{$4}".q{|;
                }
                elsif (defined $4) {
                    qq|}."$4".q{|;
                }
                else {
                    qq|}."\\$5".q{|;
                }
            }
            elsif ($8) {
                "\\$8"
            }
            else { # A variable
                my $variable = $6 || $7;
                q|}.$self->_get_var(q{| . _text_escape($variable) . q|}).q{|;
            }
        ]egsx;
    }
    elsif ($string =~ s/^'//) {
        $string =~ s/'$//;
        $string =~ s/\\(['\\])/$1/g;
        $string = _text_escape($string);
    }
    "q{$string}";
}
sub _math {
    my ($left, $comp, $right) = @_; # var => left, val => right
    my $calc;
    if    ($comp =~ /^[.*+-]$/ or $comp eq '||' or $comp eq '&&') { $calc = "+(($left) $comp ($right))" }
    elsif ($comp =~ m{^/(\d+)$}) { $calc = "+sprintf(q{%.$1f}, (((\$tmp = ($right)) != 0) ? (($left) / \$tmp) : 0))" }
    elsif ($comp eq '/')         { $calc = "+(((\$tmp = ($right)) != 0) ? ($left / \$tmp) : 0)" }
    elsif ($comp eq 'i/')        { $calc = "int(((\$tmp = ($right)) != 0) ? (int($left) / int(\$tmp)) : 0)" }
    elsif ($comp eq '%')         { $calc = "+(((\$tmp = ($right)) != 0) ? ($left % \$tmp) : 0)" }
    elsif ($comp eq '~')         { $calc = "+(((\$tmp = ($right)) != 0) ? (\$tmp - ($left % \$tmp)) : 1)" }
    elsif ($comp eq '^')         { $calc = "+(($left) ** ($right))" }
    elsif ($comp eq 'x')         { $calc = "+(scalar($left) x ($right))" }
    $calc ||= '';
    $calc;
}

sub _loop_on {
    my ($self, $on, $indent, $indent_level, $loop_depth) = @_;

    my $var;

    if ($on =~ /^(\d+|\$[\w.\$-]+)\s+(?:\.\.|to)\s+(\d+|\$[\w.\$-]+)$/) {
        my ($start, $end) = ($1, $2);
        for ($start, $end) {
            $_ = q|int(do { my $v = $self->_get_var(q{| . _text_escape($_) . q|}); ref $v ? 0 : $v })|
                if s/^\$//;
        }
        $var = "[$start .. $end]";
    }
    elsif (index($on, '::') > 0 or index($on, '(') > 0) {
        $var = $self->_check_func($on);
    }
    else {
        $on =~ s/^\$//;
        $var = q|$self->_raw_value(q{| . _text_escape($on) . q|})|;
    }

    my $print = $self->{opt}->{print};
    my $i0 = $indent x $indent_level;
    my $i = $indent x ($indent_level + 1);
    my $i____ = $indent x ($indent_level + 2);
    my $i________ = $indent x ($indent_level + 3);
    my $i____________ = $indent x ($indent_level + 4);
    my $i________________ = $indent x ($indent_level + 5);
    my $return = <<CODE;
${i0}\{
${i}my \$orig = {\%{\$self->{VARS}}};
${i}my %loop_set;
${i}LOOP$loop_depth: \{
${i____}my \$loop_var = $var;
${i____}my \$loop_type = ref \$loop_var;
${i____}if (\$loop_type eq 'CODE' or \$loop_type eq 'ARRAY') {
${i________}my \$next;
${i________}my \$row_num = 0;
${i________}my \$i = 0;
${i________}my \$current = \$loop_type eq 'CODE' ? \$loop_var->() : \$loop_var->[\$i++];
${i________}if (ref \$current eq 'ARRAY') {
${i____________}\$loop_type = 'ARRAY';
${i____________}\$loop_var = \$current;
${i____________}\$current = \$loop_var->[\$i++];
${i________}}
${i________}while (defined \$current) {
${i____________}if (\$loop_type eq 'CODE') {
${i________________}\$next = \$loop_var->();
${i____________}}
${i____________}else {
${i________________}\$next = \$loop_var->[\$i++];
${i____________}}
${i____________}my \$copy = {\%{\$self->{VARS}}};
${i____________}for (keys %loop_set) {
${i________________}\$copy->{\$_} = \$orig->{\$_};
${i________________}delete \$loop_set{\$_};
${i____________}}
${i____________}for (qw/row_num first last inner even odd loop_value/, keys \%\$current) { \$loop_set{\$_} = 1 }
${i____________}\$copy->{row_num} = ++\$row_num;
${i____________}\$copy->{first}   = (\$row_num == 1) || 0;
${i____________}\$copy->{last}    = (!\$next) || 0;
${i____________}\$copy->{inner}   = (!\$copy->{first} and !\$copy->{last}) || 0;
${i____________}\$copy->{even}    = (\$row_num % 2 == 0) || 0;
${i____________}\$copy->{odd}     = (not \$copy->{even}) || 0;
${i____________}if (ref \$current ne 'HASH') { \$current = { loop_value => \$current } }
${i____________}else { \$loop_set{loop_value} = 1; \$copy->{loop_value} = \$current }
${i____________}for (keys \%\$current) { \$copy->{\$_} = \$current->{\$_} }
${i____________}\$self->{VARS} = \$copy;
${i____________}\$current = \$next;

CODE
    $_[3] += 4; # Update the indent level
    return $return;
}



sub _check_func {
# ---------------------------------------------------------------
# Takes a string and if it looks like a function, returns a string
# that will call the function with the appropriate arguments.
#
# So, you enter the tag (without the <% and %>):
#   <%GFoo::function($foo, $bar, $boo, $far, '7', 'text')%>
# and you'll get back:


#   $self->_call_func('GFoo::function', $self->_get_var(q{foo},0,0), $self->_get_var(q{bar},0,0), ..., q{7}, q{text});


#   <%codevar($foo, $bar, $boo, $far => 7, text)%>
#   $self->_call_func('codevar', $self->_get_var(q{foo},0,0), $self->_get_var(q{bar},0,0), ..., q{7}, q{text});


# NOTE: NO SEMICOLON (;) ON THE END
# which will require GFoo and call GFoo::function with the arguments provided.
#
# If you call this with a tag that doesn't look like a function, undef is returned.
#
    my ($self, $str) = @_;
    my $ret;
    if (((index($str, '(') >= 0 and rindex($str, ')') >= 0) or index($str, '::') >= 1) and $str =~ /^
        (?:
# Package $1
            (
                \w+
                (?:
                    ::
                    \w+
                )*
            )
            ::
        )?
# Function $2
        (
            \w+
        )
        \s*
# Any possible arguments
        (?:
            \(
            \s*
            (
                .+? # Arguments list $3
            )?
            \s*
            \)
        )?
    $/sx) {
        my ($package, $func, $args) = ($1, $2, $3);
        $ret = '';
        $args = '' if not defined $args;

        $args = join ", ", _parse_args($args) if length $args;

        $ret = q|$self->_call_func('| . ($package ? "$package\::$func" : $func) . q|'|;
        $ret .= ", $args" if $args;
        $ret .= ")";
    }
    return $ret;
}

sub _parse_args {
# --------------------------------------------------------
# Splits up arguments on commas outside of quotes. Unquotes
#
    my $line = shift;
    my ($word, @pieces);
    local $^W;
    while (length $line) {
        my ($quoted, undef, $bareword, $delim) = $line =~ m{
            ^
            (?:
                (                           # $quoted test
                    (["'])                  # the actual quote
                    (?:\\.|(?!\2)[^\\])*    # the text
                    \2                      # followed by the same quote
                )
            |                               # --OR--
                ((?:\\.|[^\\"'])*?)         # $bareword text, plus:
                (                           # $delim
                    \Z(?!\n)                # EOL
                |
                    \s*(?:,|=>)\s*          # delimiter
                |
                    (?!^)(?=["'])           # or quote
                )
            )
            (.*)                            # and the rest ($+)
        }sx;
        return unless $quoted or length $bareword or length $delim;

        $line = $+;

        my $val;
        if ($quoted) {
            $val = _quoted_string($quoted);
        }
        elsif ($bareword =~ s/^\$//) {
            $val = q|$self->_get_var(q{| . _text_escape($bareword) . q|},0,0)|;
        }
        elsif (length $bareword) {
            $bareword =~ s/\\(.)/$1/g;
            $val = q|q{| . _text_escape($bareword) . q|}|;
        }

        $word = $word ? "$word.$val" : $val if defined $val;

        if (length $delim) {
            push @pieces, $word;
            $word = undef;
        }
    }
    push @pieces, $word if defined $word;
    return @pieces;
}

1;