988 lines
39 KiB
Perl
988 lines
39 KiB
Perl
# ====================================================================
|
|
# 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;
|
|
|