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