# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Template::Parser
#   Author: Jason Rhinelander
#   $Id: Parser.pm,v 2.111 2004/05/17 05:56:59 jagerman Exp $
#
# Copyright (c) 2004 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);

@ISA     = qw/GT::Base/;
$VERSION = sprintf "%d.%03d", q$Revision: 2.111 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0;
$ATTRIBS = { root => '.', indent => '  ', begin => '<%', end => '%>', print => 0 };
$ERRORS  = {
    NOTEMPLATE        => "No template file was specified.",
    BADINC            => "Error: Can't load included file: '%s'. Reason: %s",
    CANTOPEN          => "Unable to open template file '%s'. Reason: %s",
    CANTFIND          => "Unable to locate template file '%s' in '%s' or any inheritance directories",
    DEEPINC           => "Deep recursion in includes, quiting!",
    EXTRAELSE         => "Error: extra 'else' tag",
    NOSCALAR          => "Error: Value not scalar",
    UNMATCHEDELSE     => "Error: Unmatched else/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        => "Unknown tag: '%s'"
};


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->error('NOTEMPLATE', 'FATAL', $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 {
        my $root = $self->{root};
        until ($full) {
            if (-r "$root/local/$template") {
                $full = "$root/local/$template";
                $type .= "LOCAL";
            }
            elsif (-r "$root/$template") {
                $full = "$root/$template";
                $type .= "REL";
            }
            else { # Try looking in the inheritance tree
                my $tplinfo = GT::Template->load_tplinfo($root);
                if ($tplinfo and my $inherit = $tplinfo->{inheritance}) {
                    if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
                        $root = $inherit;
                    }
                    else { # Relative inheritance path. This might eventually look like /blah/a/../b/../c/../d/../e - Messy, but it works
                        $root .= "/$inherit";
                    }
                    $type .= "INH:";
                }
                else {
                    return $self->error('CANTFIND', 'FATAL', $template, $root);
                }
            }
        }
    }

    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 ($code, $deps), $mtime, $size) = $self->_parse($template, $opt, $tpl, $mtime, $size);
    return ($code, $deps, $mtime, $size, $type);
}

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->error('CANTOPEN', 'FATAL', $full_file, "File does not exist.");
    local *TPL;
    open TPL, "< $full_file" or return $self->error('CANTOPEN', 'FATAL', $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, $mtime, $size) = @_;

    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, $mtime, $size);
}

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

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, $mtime, $size) = @_;

    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 $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 %mtime = ('' => $mtime);
    my %size = ('' => $size);

    my $last_pos = 0;

# Can only go up to 10 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 $escape = $self->{opt}->{escape};
my $strict = $self->{opt}->{strict};
my $tmp;
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|};
|)  };
    while ($tpl =~ /($begin\s*(--.*?(?:--(?=\s*$end)|$)|.+?)(\s*(?:$end|$)))/gs) {
        my $tag         = $2;
        my $tag_len     = length $1;
        my $print_start = $last_pos;
        $last_pos       = pos $tpl;
        my $end_len     = length $3; # This is needed to support nested comments
        # Print out the text before the tag.
        $text->(substr($tpl, $print_start, $last_pos - $tag_len - $print_start));

# Write any comments as Perl comments in the file
        if (substr($tag,0,2) eq '--') {
            my $save_pos = pos($tag);
            while ($tag =~ /\G.*?$begin\s*--/gs) {
                $save_pos = pos($tag);
                my $tpl_save_pos = pos($tpl);
                if ($tpl =~ /\G(.*?--\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;
                }
            }
            my $comment = substr($tag, -2) eq '--' ? substr($tag, 2, -2) : substr($tag, 2);
            $return .= _comment($comment);
            next;
        }

# Tag has no spaces in it.
        if ($tag !~ /\s/) {

# 'else' - If $i is already at -1, we have an umatched tag.
            if ($tag eq 'else') {
                if ($i == -1) {
                    $return .= _comment($ERRORS->{UNMATCHEDELSE});
                    $text->($ERRORS->{UNMATCHEDELSE});
                }
                else {
                    if ($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]) {
                    $return .= _comment($ERRORS->{UNMATCHEDENDIF});
                    $text->($ERRORS->{UNMATCHEDENDIF});
                }
                else {
                    --$i; --$#seen_else;
                    $return .= $indent x --$indent_level . q|}
|;              }
            }
# 'endloop' - It will help to look for where it writes 'loop' to understand what this does
            elsif ($tag eq 'endloop') {
                if ($loop_depth <= 0) {
                    $return .= _comment($ERRORS->{UNMATCHEDENDLOOP});
                    $text->($ERRORS->{UNMATCHEDENDLOOP});
                }
                else {
                    $loop_depth--;
                    $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]) {
                        $return .= ($indent x --$indent_level) . q|}
|;                  }
                    $i = $include_ifdepth[-1][0];
                }
                $include_safety--;
                pop @include_ifdepth;
                $return .= $indent x --$indent_level . q|} # Done include
|;          }
# 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') {
                $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 (";
            }

            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 =~ s/^(['"])//) {
                        $val =~ s/$1$//;
                        $val = "q{" . _text_escape($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|) {
|;      }
# 'loop' - <%loop var%>, <%loop Pkg::Func(arg, $arg => arg)%>, <%loop var(arg, $arg => arg)%>
        elsif ($tag =~ /^loop\b\s*(.+)/s) {
            $loop_depth++;
            my $loopon = $1;
            $return .= $self->_loop_on($loopon, $indent, $indent_level, $loop_depth);
        }

# 'include' - load the file into the current template and continue parsing.
# The template must be added to this template's dependancy list.
        elsif ($tag =~ /^include\b\s*(.+)/) {
            my $include  = $1;
            my ($dep_name, $filename);
            if (-r "$root/local/$include") {
                $dep_name = "LOCAL:$include";
                $filename = "$root/local/$include";
            }
            elsif (-r "$root/$include") {
                $dep_name = "REL:$include";
                $filename = "$root/$include";
            }
            elsif (-r $include) {
                $dep_name = "ABS:$include";
                $filename = "$include";
            }
            else { # Scan the inheritance tree
                my $root = $root; # ;-)
                $dep_name = "INH:";
                until ($filename) {
                    # Try going one more level in the inheritance tree
                    my $tplinfo = GT::Template->load_tplinfo($root);
                    if ($tplinfo and my $inherit = $tplinfo->{inheritance}) {
                        if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
                            $root = $inherit;
                        }
                        else { # Relative inheritance path. This might eventually look like /blah/a/../b/../c/../d/../e - Messy, but it works
                            $root .= "/$inherit";
                        }
                    }
                    else {
                        last; # We haven't found it, and there isn't any (more) inheritance
                    }

                    # Look for the include in the inherited directory:
                    if (-r "$root/local/$include") {
                        $filename = "$root/local/$include";
                        $dep_name .= "LOCAL:$include";
                    }
                    elsif (-r "$root/$include") {
                        $filename = "$root/$include";
                        $dep_name .= "REL:$include";
                    }
                    else {
                        $dep_name .= "INH:";
                    }
                }
            }

            local *INCL;
            if ($filename and open INCL, "<$filename") {
                $deps{$dep_name} = 1;
                ($size{$dep_name}, $mtime{$dep_name}) = (stat INCL)[7, 9];
                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 <= 10 or return $self->error("DEEPINC", 'FATAL');

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

                push @include_ifdepth, [$i, $indent_level];
            }
            else {
                my $errfile = $filename || "$root/$include";
                $return .= _comment(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
                $text->(sprintf($ERRORS->{BADINC}, $errfile, "$!" || 'File does not exist'));
                $deps{"MISSING:$include"} = 1;
            }
            next;
        }
# 'escapeURL', 'escape_url', 'unescapeHTML', 'unescape_html', 'escape_js', 'escapeJS', 'uc', 'ucfirst', 'lc', 'lcfirst' - obvious, I think...
        elsif ($tag =~ /^(escapeURL|escape_url|escapeHTML|escape_html|unescapeHTML|unescape_html|escape_js|[ul]c(?:first)?)\b\s*(\S+)/) {
            my ($type, $var) = ($1, $2);
            $return .= $indent x $indent_level;
            $return .= q|$tmp = $self->_get_value(q{| . _text_escape($var) . q|}, 0);
|;          $return .= q|$tmp = q{| . _text_escape($var) . q|} if not defined $tmp;
|;          $return .= $indent x $indent_level;
            $return .= q|$tmp = $$tmp if ref($tmp) eq 'SCALAR';
|;          $return .= $indent x $indent_level++;
            $return .= q|if (ref $tmp) {
|;          $return .= $indent x $indent_level;
            $text->($ERRORS->{NOSCALAR});
            $return .= $indent x ($indent_level - 1) . q|}
|;          $return .= $indent x ($indent_level - 1) . q|else {
|;          $return .= $indent x $indent_level;
            if ($type eq 'unescapeHTML' or $type eq 'unescape_html') {
                $return .= ($print ? q|print| : q|$return .=|) . q| GT::CGI::html_unescape($tmp);
|;          }
            elsif ($type eq 'escape_js' or $type eq 'escapeJS') {
                $return .= q{$tmp =~ s{([\\\/'"])}{\\\$1}g; $tmp =~ s{(?:\r\n|\r|\n)}{\\\n}g; };
                $return .= ($print ? q|print| : q|$return .=|) . q| $tmp;
|;          }
            elsif ($type eq 'escape_html' or $type eq 'escapeHTML') {
                $return .= ($print ? q|print| : q|$return .=|) . q| GT::CGI::html_escape($tmp);
|;          }
            elsif ($type eq 'uc' or $type eq 'lc' or $type eq 'ucfirst' or $type eq 'lcfirst') {
                $return .= ($print ? q|print| : q|$return .=|) . q| | . $type . q|($tmp);
|;          }
            else {
                $return .= ($print ? q|print| : q|$return .=|) . q| GT::CGI::escape($tmp);
|;          }
            $return .= $indent x --$indent_level . q|}
|;      }
# Also - 'nbsp' - this converts whitespace to &nbsp;
        elsif ($tag =~ /^nbsp\b\s*(\S+)/) {
            my $var = $1;
            $return .= $indent x $indent_level;
            $return .= q|$tmp = $self->_get_value(q{| . _text_escape($var) . q|}, $strict);
|;          $return .= $indent x $indent_level;
            $return .= q|$tmp = (ref $tmp eq 'SCALAR' ? $$tmp : $escape ? GT::CGI::html_escape($tmp) : $tmp);
|;          $return .= $indent x $indent_level;
            $return .= q|$tmp =~ s/\s/&nbsp;/g;
|;          $return .= $indent x $indent_level;
            $return .= ($print ? q|print| : q|$return .=|) . q| $tmp;
|;
        }
# 'set' - set a value from the templates
        elsif ($tag =~ m{^set\s*(\w+)\s*([-x+*/%^.])?=\s*(.+)}s) {
            my ($var, $change, $val) = ($1, $2 || '', $3);
            $return .= $indent x $indent_level;
            $return .= q|$self->{VARS}->{q{| . _text_escape($var) . q|}} = \(|;
            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 .= q|$self->_get_var(q{| . _text_escape($var) . q|}, $escape) | . $change . ' ';
            }
            if (substr($val,0,1) eq '$') {
                substr($val,0,1) = '';
                if ($change and $change eq '/' || $change eq '%') {
                    $return .= q|(int($self->_get_var(q{| . _text_escape($val) . q|}, $escape)) or 1)|;
                }
                else {
                    $return .= q|$self->_get_var(q{| . _text_escape($val) . q|}, $escape)|;
                }
            }
            elsif (my $funccode = $self->_check_func($val)) {
                if ($change and $change eq '/' || $change eq '%') {
                    $return .= q|(int(| . $funccode . q|) or 1)|;
                }
                else {
                    $return .= $funccode;
                }
            }
            else {
                $val =~ s/^(['"])// and $val =~ s/$1$//;
                if ($change and $change eq '/' || $change eq '%') {
                    $return .= q|(int(q{| . _text_escape($val) . q|}) or 1)|;
                }
                else {
                    $return .= q|q{| . _text_escape($val) . q|}|;
                }
            }
            $return .= q|);
|;      }
# Look for things like <%... x ...%>, <%... ~ ...%>, etc.
# Also handles <%var += 3%>, <%var 
        elsif ($tag =~ m{^('[^']+'|"[^"]+"|[^\s(]+)\s*(\bx\b|\+|-|\*|/\d+(?=\s)|%|~|\^|\bi/|/)\s*(.+)}s) {
            my $var = $1;
            my $comp = $2;
            my $val = $3;

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

            if (substr($val,0,1) eq '$') {
                substr($val,0,1) = '';
                $val = q|$self->_get_var(q{| . _text_escape($val) . q|})|;
            }
            elsif ($val =~ s/^(['"])//) {
                $val =~ s/$1$//;
            }
            elsif (index($val, '::') >= 0) {
                $val = q|(| . $self->_check_func($val) . q< || '')>;
            }
            else {
                $val = q|q{| . _text_escape($val) . q|}|;
            }
            my $calc;

            # Try to do a little bit of basic math.
            # Are we writing a template parser or a programming language? Maybe a bit of both! :)
            if    ($comp =~ /^[x*+-]$/)  { $calc = "+($var $comp $val)" }
            elsif ($comp =~ /^\/(\d+)$/) { $calc = "+sprintf(q{%.$1f}, (((\$tmp = $val) != 0) ? ($var / \$tmp) : 0))" }
            elsif ($comp eq '/')         { $calc = "+(((\$tmp = $val) != 0) ? ($var / \$tmp) : 0)" }
            elsif ($comp eq 'i/')        { $calc = "int(((\$tmp = $val) != 0) ? (int($var) / int(\$tmp)) : 0)" }
            elsif ($comp eq '%')         { $calc = "+(((\$tmp = $val) != 0) ? ($var % \$tmp) : 0)" }
            elsif ($comp eq '~')         { $calc = "+(((\$tmp = $val) != 0) ? (\$tmp - ($var % \$tmp)) : 1)" }
            elsif ($comp eq '^')         { $calc = "+($var ** $val)" }
            $calc ||= '';

            $return .= $indent x $indent_level . ($print ? "print" : q|$return .=|) . " $calc;
";          next;
        }
        elsif (my $func = $self->_check_func($tag)) {
            $return .= ($indent x $indent_level) . ($print ? q|print | : q|$return .= |) . $func . q|;
|;      }
# Check to see if it's a valid variable, function call, etc.
        else {
            $return .= $indent x $indent_level++;
            $return .= q|if (defined($tmp = $self->_get_value(q{| . _text_escape($tag) . q|}, $strict))) {
|;          $return .= $indent x $indent_level;
            $return .= ($print ? q|print| : q|$return .=|) . q|(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;
            $return .= ($print ? q|print q{| : q|$return .= q{|) . _text_escape(sprintf($ERRORS->{UNKNOWNTAG}, $tag)) . q|};
|;          $return .= $indent x --$indent_level . q|}
|;      }
    }
    $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, [keys %deps], \%mtime, \%size);
}

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

    my $var;

    if (index($on, '::') > 0 or index($on, '(') > 0) {
        $var = $self->_check_func($on);
    }
    else {
        $var = q|$self->{VARS}->{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/, 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____________}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 = '';
        my @args = ();
        if ($args) {
            @args = _parse_args('\s*(?:,|=>)\s*', $args);
            for (@args) {
                if (substr($_, 0, 1) eq '$') {
                    $_ = q|$self->_get_var(q{| . _text_escape(substr($_, 1)) . q|},0,0)|
                }
                else {
                    $_ = q|q{| . _text_escape($_) . q|}|
                }
            }
        }
        $args = join ", ", @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($delimiter, $line) = @_;
    my($quote, $quoted, $unquoted, $delim, $word, @pieces);
    local $^W;
    while (length($line)) {
        ($quote, $quoted, undef, $unquoted, $delim, undef) =
            $line =~ m/^
                          (["'])                     # a $quote
                              ((?:\\.|(?!\1)[^\\])*) # and $quoted text
                          \1                         # followed by the same quote
                          (.*)                       # and the rest ($+)
                       |                           # --OR--
                       ^  ((?:\\.|[^\\"'])*?)        # $unquoted text, plus:
                          (
                              \Z(?!\n)                  # EOL
                                |
                              (?:$delimiter)            # delimiter
                                |
                              (?!^)(?=["'])             # or quote
                          )
                          (.*)                       # and the rest ($+)
                  /sx;
        return unless($quote or length $unquoted or length $delim);

        $line = $+;

        $unquoted =~ s/\\(.)/$1/g;
        if (defined $quote) {
            $quoted =~ s/\\(.)/$1/g if ($quote eq '"');
            $quoted =~ s/\\([\\'])/$1/g if ( $quote eq "'");
        }
        $word .= defined $quote ? $quoted : $unquoted;
        if (length($delim)) {
            push(@pieces, $word);
            undef $word;
        }
        if (!length($line) and defined $word) {
            push(@pieces, $word);
        }
    }
    return(@pieces);
}

1;

__END__

=head1 NAME

GT::Template::Parser - The guts of the not-so-simple template parsing module

=head1 SYNOPSIS

This module is not meant to be called directly, and should only be called
from GT::Template.

=head1 SEE INSTEAD

L<GT::Template>

=cut