| Current File : //var/wcp4/hkaw/public_html/file/private/lib/GT/Template/Parser.pm |
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Template::Parser
# Author: Jason Rhinelander
# $Id: Parser.pm,v 2.78 2002/05/25 06:49:22 jagerman Exp $
#
# Copyright (c) 2001 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 $TPL $VERSION $DEBUG $ATTRIBS $ERRORS);
@ISA = qw/GT::Base/;
$VERSION = sprintf "%d.%03d", q$Revision: 2.78 $ =~ /(\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",
'LOOPNOTHASH' => "Error: An iteration of loop variable '%s' returns something other than a hash reference",
'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.
if ($print) { $opt->{print} = 1; }
# 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);
}
}
}
}
$self->load_template($full, $string);
# Parse the template.
$self->debug ("Parsing '$template' (found '$full') with (print => $opt->{print})") if $self->{_debug};
my ($code, $deps) = $self->_parse($template, $opt, 1);
$TPL = '';
return ($code, $deps, $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 into $TPL.
#
my ($self, $full_file, $string) = @_;
if (defined $string) {
$self->debug("Loading string into \$TPL") if $self->{_debug};
$TPL = $string;
return 1;
}
$self->debug("Loading '$full_file' into \$TPL") if $self->{_debug};
-e $full_file or return $self->error('CANTOPEN', 'FATAL', $full_file, "File does not exist.");
open (TPL, "< $full_file") or return $self->error('CANTOPEN', 'FATAL', $full_file, $!);
read TPL, $TPL, -s TPL;
close TPL;
# Set the last mod time.
return 1;
}
sub _parse {
# ---------------------------------------------------------------
# Parses a template.
#
my ($self, $template, $opt) = @_;
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();
}
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) = @_;
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 $last_pos = 0;
# Can only go up to 10 includes inside includes.
my $include_safety = 0;
my $return = q|
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;
|;
# 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*(--(?:(?:$begin\s*--.*?--\s*$end)|.)*?--|.+?)\s*$end)/gs) {
# The above allows 1 level of nested <%-- comments --%>, however it segfaults
# on some systems (Mac OS X) if the overall comment gets too long (even when
# _not_ using the nested comments).
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*--/g) {
$save_pos = pos($tag);
my $tpl_save_pos = pos($TPL);
if ($TPL =~ /\G(.*?--\s*$end)/g) {
$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) {
$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--;
# Close _2_ blocks - one block around the whole thing, and the block for the while loop
$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') {
$include_safety--;
$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-- if $one_neg;
$tag =~ s/([\w:-]+)\b\s*//;
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, $val);
if (length($tag)) {
if ($tag =~ s/^(==?|!=|>=?|<=?|%|eq|ne|g[et]|l[et])\s*//) { $comp = " $1 " }
elsif ($tag =~ s/^(?:like|contains)\s+//i) { $comp = 'like' }
$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 ($comp eq 'like') {
$result .= qq|index($var, $val) >= 0|;
}
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") {
read INCL, my $data, -s 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;
$deps{$dep_name} = 1;
++$include_safety <= 10 or return $self->error("DEEPINC", 'FATAL');
$return .= $indent x $indent_level++ . q|{; | # The ; is a fix for empty include files
. _comment("Including $filename");
}
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' - obvious, I think...
elsif ($tag =~ /^(escapeURL|escape_url|escapeHTML|escape_html|unescapeHTML|unescape_html|escape_js)\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) || q{> . _text_escape($var) . q|};
|; $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') { # escapes even a scalar reference
$return .= ($print ? q|print| : q|$return .=|) . q| GT::CGI::html_escape($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
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/ /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|}} | . $change . q|= |;
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|})) or 1);
|; }
else {
$return .= q|$self->_get_var(q{| . _text_escape($val) . q|});
|; }
}
elsif (index($val, '::') >= 0) {
if ($change and $change eq '/' || $change eq '%') {
$return .= q|(int(| . $self->_check_func($val) . q|) or 0);
|; }
else {
$return .= $self->_check_func($val) . q|;
|; }
}
else {
$val =~ s/^(['"])// and $val =~ s/$1$//;
if ($change and $change eq '/' || $change eq '%') {
$return .= q|(int(q{| . _text_escape($val) . q|}) or 0);
|; }
else {
$return .= q|q{| . _text_escape($val) . 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]);
}
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________}next unless ref \$current eq 'HASH'; # It didn't return anything useful
${i________}while (\$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____________}if (ref \$current ne 'HASH') { # Whatever they gave us is bad.
${i________________}@{[$print ? 'print' : '$return .=']} q{@{[_text_escape(sprintf($ERRORS->{LOOPNOTHASH}, $on))]}};
${i________________}last LOOP$loop_depth;
${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____________}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)) {
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